commit 4587b5e9bbac0b263eafd178260a8af9c4f123b7
parent c707389521850f662ef1e6584b41998455aae922
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 15 Sep 2015 18:19:08 -0400
add gui support for selecting primary partition (fg colors)
Diffstat:
9 files changed, 101 insertions(+), 77 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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<%>
