diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index d76a247f55..ac7f684eff 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -16,6 +16,7 @@ (define colorers null) (define selection-listeners null) (define selected-syntax #f) + (define identifier=?-listeners null) (init-field (properties-controller (new independent-properties-controller% (controller this)))) @@ -27,8 +28,7 @@ (for-each (lambda (c) (send c select-syntax stx)) colorers) (for-each (lambda (p) (p stx)) selection-listeners)) - (define/public (get-selected-syntax) - selected-syntax) + (define/public (get-selected-syntax) selected-syntax) (define/public (get-properties-controller) properties-controller) @@ -41,10 +41,15 @@ (define/public (add-selection-listener p) (set! selection-listeners (cons p selection-listeners))) - (define/public (on-update-identifier=? id=?) + (define/public (on-update-identifier=? name id=?) (set! -secondary-partition (and id=? (new partition% (relation id=?)))) - (for-each (lambda (c) (send c refresh)) colorers)) + (for-each (lambda (c) (send c refresh)) colorers) + (for-each (lambda (f) (f name id=?)) identifier=?-listeners)) + + (define/public (add-identifier=?-listener f) + (set! identifier=?-listeners + (cons f identifier=?-listeners))) (define/public (erase) (set! colorers null)) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index b8a1381ec9..159994dfce 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -77,6 +77,36 @@ "") (send e get-time-stamp))))) ;; FIXME: Add option for "formatted" copy/paste? + + (new menu-item% + (label "Clear selection") + (parent context-menu) + (callback (lambda _ (send controller select-syntax #f)))) + + (new separator-menu-item% (parent context-menu)) + + ;; properties + (new menu-item% + (label "Show/hide syntax properties") + (parent context-menu) + (callback (lambda _ (toggle-props)))) + + ;; primary selection + (let ([secondary (new menu% (label "identifier=?") (parent context-menu))]) + (for-each + (lambda (name func) + (let ([this-choice + (new checkable-menu-item% + (label name) + (parent secondary) + (callback + (lambda (i e) + (send controller on-update-identifier=? name func))))]) + (send controller add-identifier=?-listener + (lambda (new-name new-id=?) + (send this-choice check (eq? name new-name)))))) + (map car (identifier=-choices)) + (map cdr (identifier=-choices)))) context-menu)) ;; syntax-properties-controller<%> methods @@ -202,15 +232,16 @@ (callback (lambda _ (toggle-props)))) (define/private (on-update-identifier=?-choice) - (let ([id=? (get-identifier=?)]) - (send (get-controller) on-update-identifier=? id=?))) - - (define/private (get-identifier=?) - (cond [(assoc (send -choice get-string-selection) + (cond [(assoc (send -choice get-string-selection) -identifier=-choices) - => cdr] - [else #f])))) - + => (lambda (p) + (send (get-controller) + on-update-identifier=? (car p) (cdr p)))] + [else #f])) + (send (get-controller) add-identifier=?-listener + (lambda (name func) + (send -choice set-selection + (or (send -choice find-string name) 0)))))) ;; syntax-browser-frame% (define syntax-browser-frame% diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index 3c1414dc2b..9a50e36a8f 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -131,7 +131,14 @@ (current-module-name-resolver mnr))))) (define/private (make-handlers original-eval-handler original-module-name-resolver) - (let ([stepper (delay (make-macro-stepper (new-standard-hiding-policy)))] + (let ([stepper + (delay + (let ([frame (new macro-stepper-frame% + (policy (new-standard-hiding-policy)) + (macro-hiding? #t) + (identifier=? "bound-identifier=?"))]) + (send frame show #t) + (send frame get-widget)))] [debugging? debugging?]) (values (lambda (expr) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 48c4221d44..8599054051 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -62,7 +62,7 @@ (init policy macro-hiding?) (init (show-hiding-panel? #t) - (identifier=? #f) + (identifier=? "") (width (sb:pref:width)) (height (sb:pref:height))) (inherit get-menu% @@ -114,40 +114,49 @@ (label label) (parent menu) (callback (lambda _ (callback)))) (new separator-menu-item% (parent menu))))) - (begin - (new (get-menu-item%) (label "Show properties") (parent syntax-menu) - (callback (lambda _ (send (send widget get-view) show-props)))) - (new (get-menu-item%) (label "Hide properties") (parent syntax-menu) - (callback (lambda _ (send (send widget get-view) hide-props)))) - (define id-menu - (new (get-menu%) (label "Identifier=?") (parent syntax-menu))) - (for-each (lambda (p) - (new (get-menu-item%) (label (car p)) (parent id-menu) - (callback (lambda _ - (send (send widget get-controller) - on-update-identifier=? - (cdr p)))))) - (sb:identifier=-choices)) - (new (get-menu-item%) (label "Clear selection") (parent syntax-menu) - (callback - (lambda _ (send (send widget get-controller) select-syntax #f))))) - (define widget (new macro-stepper-widget% - (register-syntax-action (mk-register-action syntax-menu)) - (register-stepper-action (mk-register-action stepper-menu)) (parent (send this get-area-container)) (policy policy) (macro-hiding? macro-hiding?) (show-hiding-panel? show-hiding-panel?))) (define/public (get-widget) widget) + (begin + (new (get-menu-item%) (label "Show/hide syntax properties") (parent syntax-menu) + (callback (lambda _ (send (send widget get-view) toggle-props)))) + (define id-menu + (new (get-menu%) (label "Identifier=?") (parent syntax-menu))) + (for-each (lambda (p) + (let ([this-choice + (new checkable-menu-item% + (label (car p)) + (parent id-menu) + (callback (lambda _ + (send (send widget get-controller) + on-update-identifier=? + (car p) + (cdr p)))))]) + (send (send widget get-controller) + add-identifier=?-listener + (lambda (new-name new-func) + (send this-choice check (eq? new-name (car p))))))) + (sb:identifier=-choices)) + (new (get-menu-item%) (label "Clear selection") (parent syntax-menu) + (callback + (lambda _ (send (send widget get-controller) select-syntax #f)))) + (new (get-menu-item%) + (label "Show/hide macro hiding configuration") + (parent stepper-menu) + (callback (lambda _ (send widget show/hide-macro-hiding-prefs))))) + (begin (when identifier=? (let ([p (assoc identifier=? (sb:identifier=-choices))]) (when p (send (send widget get-controller) on-update-identifier=? + (car p) (cdr p)))))) (frame:reorder-menus this) @@ -157,8 +166,6 @@ (define macro-stepper-widget% (class* object% () (init-field parent) - (init-field register-syntax-action) - (init-field register-stepper-action) (init policy) (init macro-hiding?) (init show-hiding-panel?) @@ -243,10 +250,7 @@ (new button% (label "Next term") (parent updown-navigator) (callback (lambda (b e) (navigate-down))))) - (register-stepper-action "Show/hide macro hiding configuration" - (lambda () (show/hide-macro-hiding-prefs))) - - (define/private (show/hide-macro-hiding-prefs) + (define/public (show/hide-macro-hiding-prefs) (send area change-children (lambda (children) (if (memq control-pane children)