suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add gui support for selecting primary partition (fg colors)

Browse Source
This commit is contained in:
Ryan Culpepper 2015-09-15 18:19:08 -04:00
parent c707389521
commit 4587b5e9bb
9 changed files with 101 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
macro-debugger-text-lib/macro-debugger/syntax-browser/interfaces.rkt
View File

@ -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<%>)
())

5
macro-debugger-text-lib/macro-debugger/syntax-browser/partition.rkt
View File

@ -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 ====

61
macro-debugger/macro-debugger/syntax-browser/controller.rkt
View File

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

7
macro-debugger/macro-debugger/syntax-browser/display.rkt
View File

@ -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))])

15
macro-debugger/macro-debugger/syntax-browser/frame.rkt
View File

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

51
macro-debugger/macro-debugger/view/frame.rkt
View File

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

1
macro-debugger/macro-debugger/view/interfaces.rkt
View File

@ -9,6 +9,7 @@
macro-hiding-mode
show-hiding-panel?
identifier=?
primary-partition
highlight-foci?
highlight-frontier?
show-rename-steps?

3
macro-debugger/macro-debugger/view/prefs.rkt
View File

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

7
macro-debugger/macro-debugger/view/stepper.rkt
View File

@ -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<%>