diff --git a/macro-debugger-text-lib/macro-debugger/syntax-browser/interfaces.rkt b/macro-debugger-text-lib/macro-debugger/syntax-browser/interfaces.rkt index 0a93d27..0382e69 100644 --- a/macro-debugger-text-lib/macro-debugger/syntax-browser/interfaces.rkt +++ b/macro-debugger-text-lib/macro-debugger/syntax-browser/interfaces.rkt @@ -44,32 +44,30 @@ add-syntax-display ;; remove-all-syntax-displays : -> void - remove-all-syntax-displays)) + remove-all-syntax-displays + + ;; refresh-all-displays : -> void + refresh-all-displays)) ;; selection-manager<%> (define-interface selection-manager<%> () (;; selected-syntax : notify-box of syntax/#f (methods:notify selected-syntax))) -;; mark-manager<%> -;; Manages marks, mappings from marks to colors -(define-interface mark-manager<%> () - (;; get-primary-partition : -> partition - get-primary-partition - - ;; reset-primary-partition : -> void +;; relation<%> +(define-interface relation<%> () + (;; identifier=? : notify-box of (U #f (id id -> bool)) + (methods:notify identifier=?) + ;; primary-partition-factory : notify-box of (-> partition%) + ;; primary-partition : notify-box of partition% + (methods:notify primary-partition-factory) + (methods:notify primary-partition) reset-primary-partition)) -;; secondary-relation<%> -(define-interface secondary-relation<%> () - (;; identifier=? : notify-box of (cons string (U #f (id id -> bool))) - (methods:notify identifier=?))) - ;; controller<%> (define-interface controller<%> (displays-manager<%> selection-manager<%> - mark-manager<%> - secondary-relation<%>) + relation<%>) ()) diff --git a/macro-debugger-text-lib/macro-debugger/syntax-browser/partition.rkt b/macro-debugger-text-lib/macro-debugger/syntax-browser/partition.rkt index 0472feb..47a032f 100644 --- a/macro-debugger-text-lib/macro-debugger/syntax-browser/partition.rkt +++ b/macro-debugger-text-lib/macro-debugger/syntax-browser/partition.rkt @@ -63,8 +63,9 @@ ;; ==== Partition choices ==== (define partition-choices - `(("Macro scopes" . ,new-macro-scopes-partition) - ("All scopes" . ,new-all-scopes-partition))) + (make-parameter + `(("By macro scopes" . ,new-macro-scopes-partition) + ("By all scopes" . ,new-all-scopes-partition)))) ;; ==== Identifier relations ==== diff --git a/macro-debugger/macro-debugger/syntax-browser/controller.rkt b/macro-debugger/macro-debugger/syntax-browser/controller.rkt index b4cfbde..3922742 100644 --- a/macro-debugger/macro-debugger/syntax-browser/controller.rkt +++ b/macro-debugger/macro-debugger/syntax-browser/controller.rkt @@ -9,6 +9,7 @@ ;; displays-manager-mixin (define displays-manager-mixin (mixin () (displays-manager<%>) + (super-new) ;; displays : (list-of display<%>) (field [displays null]) @@ -20,51 +21,53 @@ (define/public (remove-all-syntax-displays) (set! displays null)) - (super-new))) + ;; refresh-all-displays : -> void + (define/public (refresh-all-displays) + (for ([d (in-list displays)]) (send/i d display<%> refresh))))) ;; selection-manager-mixin (define selection-manager-mixin (mixin (displays-manager<%>) (selection-manager<%>) - (inherit-field displays) + (inherit refresh-all-displays) + (super-new) + (notify:define-notify selected-syntax (new notify:notify-box% (value #f))) - (super-new) (listen-selected-syntax - (lambda (new-value) - (for-each (lambda (display) (send/i display display<%> refresh)) - displays))))) + (lambda (new-value) (refresh-all-displays))))) -;; mark-manager-mixin -(define mark-manager-mixin - (mixin () (mark-manager<%>) - (init-field/i [primary-partition partition<%> (new-macro-scopes-partition)]) +;; relation-mixin +(define relation-mixin + (mixin (displays-manager<%>) (relation<%>) + (inherit refresh-all-displays) (super-new) - ;; get-primary-partition : -> partition - (define/public-final (get-primary-partition) - primary-partition) + (notify:define-notify primary-partition-factory + (new notify:notify-box% (value new-macro-scopes-partition))) + (notify:define-notify primary-partition + (new notify:notify-box% (value ((get-primary-partition-factory))))) + (notify:define-notify identifier=? + (new notify:notify-box% (value #f))) - ;; reset-primary-partition : -> void - (define/public-final (reset-primary-partition) - (set! primary-partition (new-macro-scopes-partition))))) + (listen-primary-partition-factory + (lambda (f) (set-primary-partition (f)))) -;; secondary-relation-mixin -(define secondary-relation-mixin - (mixin (displays-manager<%>) (secondary-relation<%>) - (inherit-field displays) - (notify:define-notify identifier=? (new notify:notify-box% (value #f))) + ;; (listen-primary-partition ...) + ;; When primary-partition changes, can't just refresh displays (doesn't + ;; change fg colors / suffixes); need to instead re-render entire contents. + ;; So the stepper handles that. (listen-identifier=? - (lambda (name+proc) - (for ([d (in-list displays)]) - (send/i d display<%> refresh)))) - (super-new))) + (lambda (proc) (refresh-all-displays))) + + (define/public (reset-primary-partition) + (set-primary-partition ((get-primary-partition-factory)))) + )) (define controller% - (class* (secondary-relation-mixin + (class* (relation-mixin (selection-manager-mixin - (mark-manager-mixin - (displays-manager-mixin - object%)))) + (displays-manager-mixin + object%))) (controller<%>) (super-new))) diff --git a/macro-debugger/macro-debugger/syntax-browser/display.rkt b/macro-debugger/macro-debugger/syntax-browser/display.rkt index 2b32f8b..47188ea 100644 --- a/macro-debugger/macro-debugger/syntax-browser/display.rkt +++ b/macro-debugger/macro-debugger/syntax-browser/display.rkt @@ -187,7 +187,7 @@ (send/i config config<%> get-colors))))) (define overflow-style (color-style (translate-color "darkgray"))) (define color-partition - (send/i controller mark-manager<%> get-primary-partition)) + (send/i controller controller<%> get-primary-partition)) (define offset start-position) ;; Optimization: don't call change-style when new style = old style (let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f]) @@ -234,10 +234,7 @@ ;; in the relation with it. (define/private (apply-secondary-relation-styles selected-syntax) (when (identifier? selected-syntax) - (let* ([name+relation - (send/i controller secondary-relation<%> - get-identifier=?)] - [relation (and name+relation (cdr name+relation))] + (let* ([relation (send/i controller controller<%> get-identifier=?)] [secondary-highlight-d (get-secondary-highlight-d)]) (when relation (for ([id (in-list (send/i range range<%> get-identifier-list))]) diff --git a/macro-debugger/macro-debugger/syntax-browser/frame.rkt b/macro-debugger/macro-debugger/syntax-browser/frame.rkt index 28b1af2..b6b2e1c 100644 --- a/macro-debugger/macro-debugger/syntax-browser/frame.rkt +++ b/macro-debugger/macro-debugger/syntax-browser/frame.rkt @@ -75,9 +75,10 @@ (choices (map car -identifier=-choices)) (callback (lambda (c e) - (send/i (get-controller) controller<%> set-identifier=? - (assoc (send c get-string-selection) - -identifier=-choices)))))) + (cond [(assoc (send c get-string-selection) + -identifier=-choices) + => (lambda (p) (send/i (get-controller) controller<%> + set-identifier=? (cdr p)))]))))) (new button% (label "Clear") (parent -control-panel) @@ -91,7 +92,9 @@ (not (send/i config config<%> get-props-shown?)))))) (send/i (get-controller) controller<%> listen-identifier=? - (lambda (name+func) - (send -choice set-selection - (or (send -choice find-string (car name+func)) 0)))) + (lambda (func) + (send -choice set-string-selection + (for/or ([name+func (in-list -identifier=-choices)]) + (and (eq? (cdr name+func) func) + (car name+func)))))) )) diff --git a/macro-debugger/macro-debugger/view/frame.rkt b/macro-debugger/macro-debugger/view/frame.rkt index 7a695b8..6399afb 100644 --- a/macro-debugger/macro-debugger/view/frame.rkt +++ b/macro-debugger/macro-debugger/view/frame.rkt @@ -8,6 +8,7 @@ "stepper.rkt" (prefix-in sb: "../syntax-browser/embed.rkt") (prefix-in sb: macro-debugger/syntax-browser/interfaces) + (prefix-in sb: macro-debugger/syntax-browser/partition) framework/notify) (provide macro-stepper-frame-mixin) @@ -128,29 +129,45 @@ "View syntax properties" (get-field props-shown? config)) + (let ([partition-menu + (new (get-menu%) + (label "Foreground colors") + (parent stepper-menu))]) + (for ([p (in-list (sb:partition-choices))]) + (define this-choice + (new checkable-menu-item% + (label (car p)) + (parent partition-menu) + (callback + (lambda _ (send/i controller sb:controller<%> set-primary-partition-factory + (cdr p)))))) + (send/i controller sb:controller<%> listen-primary-partition-factory + (lambda (func) (send this-choice check (eq? func (cdr p))))))) + (let ([id-menu (new (get-menu%) (label "Identifier=?") (parent stepper-menu))]) - (for-each (lambda (p) - (let ([this-choice - (new checkable-menu-item% - (label (car p)) - (parent id-menu) - (callback - (lambda _ - (send/i controller sb:controller<%> set-identifier=? p))))]) - (send/i controller sb:controller<%> listen-identifier=? - (lambda (name+func) - (send this-choice check - (eq? (car name+func) (car p))))))) - (sb:identifier=-choices))) + (for ([p (in-list (sb:identifier=-choices))]) + (define this-choice + (new checkable-menu-item% + (label (car p)) + (parent id-menu) + (callback + (lambda _ (send/i controller sb:controller<%> set-identifier=? (cdr p)))))) + (send/i controller sb:controller<%> listen-identifier=? + (lambda (func) (send this-choice check (eq? func (cdr p))))))) - (let ([identifier=? (send/i config config<%> get-identifier=?)]) - (when identifier=? - (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (send/i controller sb:controller<%> set-identifier=? p)))) + (cond [(assoc (send/i config config<%> get-identifier=?) + (sb:identifier=-choices)) + => (lambda (p) + (send/i controller sb:controller<%> set-identifier=? (cdr p)))]) + (cond [(assoc (send/i config config<%> get-primary-partition) + (sb:partition-choices)) + => (lambda (p) + (send/i controller sb:controller<%> set-primary-partition-factory (cdr p)))]) + (new (get-menu-item%) (label "Clear selection") (parent stepper-menu) diff --git a/macro-debugger/macro-debugger/view/interfaces.rkt b/macro-debugger/macro-debugger/view/interfaces.rkt index 9ecdbe7..417ab36 100644 --- a/macro-debugger/macro-debugger/view/interfaces.rkt +++ b/macro-debugger/macro-debugger/view/interfaces.rkt @@ -9,6 +9,7 @@ macro-hiding-mode show-hiding-panel? identifier=? + primary-partition highlight-foci? highlight-frontier? show-rename-steps? diff --git a/macro-debugger/macro-debugger/view/prefs.rkt b/macro-debugger/macro-debugger/view/prefs.rkt index fb2e97b..ed72e69 100644 --- a/macro-debugger/macro-debugger/view/prefs.rkt +++ b/macro-debugger/macro-debugger/view/prefs.rkt @@ -19,6 +19,7 @@ (preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?) (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) +(preferences:set-default 'MacroStepper:IdentifierPartition "By macro scopes" string?) (preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?) (preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?) (preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?) @@ -41,6 +42,7 @@ (define pref:macro-hiding-mode (preferences:get/set 'MacroStepper:MacroHidingMode)) (define pref:show-hiding-panel? (preferences:get/set 'MacroStepper:ShowHidingPanel?)) (define pref:identifier=? (preferences:get/set 'MacroStepper:IdentifierComparison)) +(define pref:primary-partition (preferences:get/set 'MacroStepper:IdentifierPartition)) (define pref:highlight-foci? (preferences:get/set 'MacroStepper:HighlightFoci?)) (define pref:highlight-frontier? (preferences:get/set 'MacroStepper:HighlightFrontier?)) (define pref:show-rename-steps? (preferences:get/set 'MacroStepper:ShowRenameSteps?)) @@ -69,6 +71,7 @@ (macro-hiding-mode pref:macro-hiding-mode) (show-hiding-panel? pref:show-hiding-panel?) (identifier=? pref:identifier=?) + (primary-partition pref:primary-partition) (highlight-foci? pref:highlight-foci?) (highlight-frontier? pref:highlight-frontier?) (show-rename-steps? pref:show-rename-steps?) diff --git a/macro-debugger/macro-debugger/view/stepper.rkt b/macro-debugger/macro-debugger/view/stepper.rkt index f3033cc..8941f61 100644 --- a/macro-debugger/macro-debugger/view/stepper.rkt +++ b/macro-debugger/macro-debugger/view/stepper.rkt @@ -203,9 +203,10 @@ (parent superarea) (stop-callback (lambda _ (stop-processing))))) - (send/i sbc sb:controller<%> - listen-selected-syntax - (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx))) + (send/i sbc sb:controller<%> listen-selected-syntax + (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx))) + (send/i sbc sb:controller<%> listen-primary-partition + (lambda (_p) (update/preserve-view))) (send config listen-pretty-abbrev? (lambda (_) (update/preserve-view))) (send*/i config config<%>