100 lines
3.0 KiB
Scheme
100 lines
3.0 KiB
Scheme
#lang scheme/base
|
|
(require scheme/class
|
|
macro-debugger/util/class-iop
|
|
scheme/gui
|
|
framework/framework
|
|
scheme/list
|
|
"interfaces.ss"
|
|
"partition.ss"
|
|
"prefs.ss"
|
|
"widget.ss")
|
|
(provide browse-syntax
|
|
browse-syntaxes
|
|
make-syntax-browser
|
|
syntax-browser-frame%
|
|
syntax-widget/controls%)
|
|
|
|
;; browse-syntax : syntax -> void
|
|
(define (browse-syntax stx)
|
|
(browse-syntaxes (list stx)))
|
|
|
|
;; browse-syntaxes : (list-of syntax) -> void
|
|
(define (browse-syntaxes stxs)
|
|
(let ((w (make-syntax-browser)))
|
|
(for ([stx stxs])
|
|
(send*: w syntax-browser<%>
|
|
(add-syntax stx)
|
|
(add-separator)))))
|
|
|
|
;; make-syntax-browser : -> syntax-browser<%>
|
|
(define (make-syntax-browser)
|
|
(let* ([view (new syntax-browser-frame%)])
|
|
(send view show #t)
|
|
(send view get-widget)))
|
|
|
|
;; syntax-browser-frame%
|
|
(define syntax-browser-frame%
|
|
(class* frame% ()
|
|
(inherit get-width
|
|
get-height)
|
|
(init-field: [config config<%> (new syntax-prefs%)])
|
|
(super-new (label "Syntax Browser")
|
|
(width (send: config config<%> get-width))
|
|
(height (send: config config<%> get-height)))
|
|
(define: widget syntax-browser<%>
|
|
(new syntax-widget/controls%
|
|
(parent this)
|
|
(config config)))
|
|
(define/public (get-widget) widget)
|
|
(define/augment (on-close)
|
|
(send*: config config<%>
|
|
(set-width (get-width))
|
|
(set-height (get-height)))
|
|
(send widget shutdown)
|
|
(inner (void) on-close))))
|
|
|
|
;; syntax-widget/controls%
|
|
(define syntax-widget/controls%
|
|
(class* widget% ()
|
|
(inherit get-main-panel
|
|
get-controller)
|
|
(super-new)
|
|
(inherit-field config)
|
|
|
|
(define -control-panel
|
|
(new horizontal-pane%
|
|
(parent (get-main-panel))
|
|
(stretchable-height #f)))
|
|
|
|
;; Put the control panel up front
|
|
(send (get-main-panel) change-children
|
|
(lambda (children)
|
|
(cons -control-panel (remq -control-panel children))))
|
|
|
|
(define -identifier=-choices (identifier=-choices))
|
|
(define -choice
|
|
(new choice% (label "identifer=?") (parent -control-panel)
|
|
(choices (map car -identifier=-choices))
|
|
(callback
|
|
(lambda (c e)
|
|
(send: (get-controller) controller<%> set-identifier=?
|
|
(assoc (send c get-string-selection)
|
|
-identifier=-choices))))))
|
|
(new button%
|
|
(label "Clear")
|
|
(parent -control-panel)
|
|
(callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f))))
|
|
(new button%
|
|
(label "Properties")
|
|
(parent -control-panel)
|
|
(callback
|
|
(lambda _
|
|
(send: config config<%> set-props-shown?
|
|
(not (send: config config<%> get-props-shown?))))))
|
|
|
|
(send: (get-controller) controller<%> listen-identifier=?
|
|
(lambda (name+func)
|
|
(send -choice set-selection
|
|
(or (send -choice find-string (car name+func)) 0))))
|
|
))
|