diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index d76a247..ac7f684 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 b8a1381..159994d 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%