add gui support for selecting primary partition (fg colors)

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<%>
+;; relation<%>
-;; Manages marks, mappings from marks to colors
+(define-interface relation<%> ()
-(define-interface mark-manager<%> ()
+  (;; identifier=? : notify-box of (U #f (id id -> bool))
-  (;; get-primary-partition : -> partition
+   (methods:notify identifier=?)
-   get-primary-partition
+   ;; primary-partition-factory : notify-box of (-> partition%)
-
+   ;; primary-partition : notify-box of partition%
-   ;; reset-primary-partition : -> void
+   (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<%>
+                                 relation<%>)
-                                 secondary-relation<%>)
   ())
 
 

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)
+  (make-parameter
-    ("All scopes" . ,new-all-scopes-partition)))
+   `(("By macro scopes" . ,new-macro-scopes-partition)
+     ("By all scopes" . ,new-all-scopes-partition))))
 
 ;; ==== Identifier relations ====
 

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)
+     (lambda (new-value) (refresh-all-displays)))))
-       (for-each (lambda (display) (send/i display display<%> refresh))
-                 displays)))))
 
-;; mark-manager-mixin
+;; relation-mixin
-(define mark-manager-mixin
+(define relation-mixin
-  (mixin () (mark-manager<%>)
+  (mixin (displays-manager<%>) (relation<%>)
-    (init-field/i [primary-partition partition<%> (new-macro-scopes-partition)])
+    (inherit refresh-all-displays)
     (super-new)
 
-    ;; get-primary-partition : -> partition
+    (notify:define-notify primary-partition-factory
-    (define/public-final (get-primary-partition)
+      (new notify:notify-box% (value new-macro-scopes-partition)))
-      primary-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
+    (listen-primary-partition-factory
-    (define/public-final (reset-primary-partition)
+     (lambda (f) (set-primary-partition (f))))
-      (set! primary-partition (new-macro-scopes-partition)))))
 
-;; secondary-relation-mixin
+    ;; (listen-primary-partition ...)
-(define secondary-relation-mixin
+    ;; When primary-partition changes, can't just refresh displays (doesn't
-  (mixin (displays-manager<%>) (secondary-relation<%>)
+    ;; change fg colors / suffixes); need to instead re-render entire contents.
-    (inherit-field displays)
+    ;; So the stepper handles that.
-    (notify:define-notify identifier=? (new notify:notify-box% (value #f)))
 
     (listen-identifier=?
-     (lambda (name+proc)
+     (lambda (proc) (refresh-all-displays)))
-       (for ([d (in-list displays)])
+
-         (send/i d display<%> refresh))))
+    (define/public (reset-primary-partition)
-    (super-new)))
+      (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
-             (displays-manager-mixin
+             object%)))
-              object%))))
     (controller<%>)
     (super-new)))

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
+        (let* ([relation (send/i controller controller<%> get-identifier=?)]
-                (send/i controller secondary-relation<%>
-                        get-identifier=?)]
-               [relation (and name+relation (cdr name+relation))]
                [secondary-highlight-d (get-secondary-highlight-d)])
           (when relation
             (for ([id (in-list (send/i range range<%> get-identifier-list))])

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=?
+              (cond [(assoc (send c get-string-selection)
-                     (assoc (send c get-string-selection)
+                            -identifier=-choices)
-                            -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)
+            (lambda (func)
-             (send -choice set-selection
+              (send -choice set-string-selection
-                   (or (send -choice find-string (car name+func)) 0))))
+                    (for/or ([name+func (in-list -identifier=-choices)])
+                      (and (eq? (cdr name+func) func)
+                           (car name+func))))))
     ))

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,28 +129,44 @@
                                    "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)
+      (for ([p (in-list (sb:identifier=-choices))])
-                  (let ([this-choice
+        (define this-choice
-                         (new checkable-menu-item%
+          (new checkable-menu-item%
-                              (label (car p)) 
+               (label (car p))
-                              (parent id-menu)
+               (parent id-menu)
-                              (callback
+               (callback
-                               (lambda _ 
+                (lambda _ (send/i controller sb:controller<%> set-identifier=? (cdr p))))))
-                                 (send/i controller sb:controller<%> set-identifier=? p))))])
+        (send/i controller sb:controller<%> listen-identifier=?
-                    (send/i controller sb:controller<%> listen-identifier=?
+                (lambda (func) (send this-choice check (eq? func (cdr p)))))))
-                           (lambda (name+func)
-                             (send this-choice check
-                                   (eq? (car name+func) (car p)))))))
-                (sb:identifier=-choices)))
 
-    (let ([identifier=? (send/i config config<%> get-identifier=?)])
+    (cond [(assoc (send/i config config<%> get-identifier=?)
-      (when identifier=?
+                  (sb:identifier=-choices))
-        (let ([p (assoc identifier=? (sb:identifier=-choices))])
+           => (lambda (p)
-          (send/i controller sb:controller<%> set-identifier=? 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")

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?

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?)

macro-debugger/macro-debugger/view/stepper.rkt

@@ -203,9 +203,10 @@
            (parent superarea)
            (stop-callback (lambda _ (stop-processing)))))
 
-    (send/i sbc sb:controller<%>
+    (send/i sbc sb:controller<%> listen-selected-syntax
-           listen-selected-syntax
+            (lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
-           (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<%>