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

macro stepper: more iop

Browse Source 
svn: r13134
This commit is contained in:
Ryan Culpepper 2009-01-15 00:10:09 +00:00
parent 92a938dc6d
commit b91874f41c
19 changed files with 215 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -38,7 +38,7 @@
;; mark-manager-mixin ;; mark-manager-mixin
(define mark-manager-mixin (define mark-manager-mixin
(mixin () (mark-manager<%>) (mixin () (mark-manager<%>)
(init-field [primary-partition (new-bound-partition)]) (init-field: [primary-partition partition<%> (new-bound-partition)])
(super-new) (super-new)
;; get-primary-partition : -> partition ;; get-primary-partition : -> partition
@ -63,8 +63,8 @@
(new partition% (relation (cdr name+proc))))))) (new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition (listen-secondary-partition
(lambda (p) (lambda (p)
(for-each (lambda (d) (send: d display<%> refresh)) (for ([d displays])
displays))) (send: d display<%> refresh))))
(super-new))) (super-new)))
(define controller% (define controller%

30
collects/macro-debugger/syntax-browser/display.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
scheme/gui scheme/gui
@ -19,8 +18,8 @@
(define range (define range
(pretty-print-syntax stx output-port (pretty-print-syntax stx output-port
(send: controller controller<%> get-primary-partition) (send: controller controller<%> get-primary-partition)
(send config get-colors) (send: config config<%> get-colors)
(send config get-suffix-option) (send: config config<%> get-suffix-option)
columns)) columns))
(define output-string (get-output-string output-port)) (define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline (define output-length (sub1 (string-length output-string))) ;; skip final newline
@ -55,18 +54,18 @@
;; set-standard-font : text% config number number -> void ;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end) (define (set-standard-font text config start end)
(send text change-style (send text change-style
(code-style text (send config get-syntax-font-size)) (code-style text (send: config config<%> get-syntax-font-size))
start end)) start end))
;; display% ;; display%
(define display% (define display%
(class* object% (display<%>) (class* object% (display<%>)
(init-field text) (init-field: [controller controller<%>]
(init-field controller) [config config<%>]
(init-field config) [range range<%>])
(init-field range) (init-field text
(init-field start-position) start-position
(init-field end-position) end-position)
(define extra-styles (make-hasheq)) (define extra-styles (make-hasheq))
@ -131,7 +130,7 @@
(send delta set-delta-foreground color) (send delta set-delta-foreground color)
delta)) delta))
(define color-styles (define color-styles
(list->vector (map color-style (send config get-colors)))) (list->vector (map color-style (send: config config<%> get-colors))))
(define overflow-style (color-style "darkgray")) (define overflow-style (color-style "darkgray"))
(define color-partition (define color-partition
(send: controller mark-manager<%> get-primary-partition)) (send: controller mark-manager<%> get-primary-partition))
@ -189,7 +188,7 @@
;; draw-secondary-connection : syntax -> void ;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2) (define/private (draw-secondary-connection stx2)
(for ([r (send range get-ranges stx2)]) (for ([r (send: range range<%> get-ranges stx2)])
(restyle-range r select-sub-highlight-d))) (restyle-range r select-sub-highlight-d)))
;; restyle-range : (cons num num) style-delta% -> void ;; restyle-range : (cons num num) style-delta% -> void
@ -204,11 +203,11 @@
;; Initialize ;; Initialize
(super-new) (super-new)
(send controller add-syntax-display this))) (send: controller controller<%> add-syntax-display this)))
;; fixup-parentheses : string range -> void ;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range) (define (fixup-parentheses string range)
(define (fixup r) (for ([r (send: range range<%> all-ranges)])
(let ([stx (range-obj r)] (let ([stx (range-obj r)]
[start (range-start r)] [start (range-start r)]
[end (range-end r)]) [end (range-end r)])
@ -219,8 +218,7 @@
(string-set! string (sub1 end) #\])) (string-set! string (sub1 end) #\]))
((#\{) ((#\{)
(string-set! string start #\{) (string-set! string start #\{)
(string-set! string (sub1 end) #\})))))) (string-set! string (sub1 end) #\})))))))
(for-each fixup (send range all-ranges)))
(define (open-output-string/count-lines) (define (open-output-string/count-lines)
(let ([os (open-output-string)]) (let ([os (open-output-string)])

45
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,8 +1,10 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/gui scheme/gui
framework/framework framework/framework
scheme/list scheme/list
"interfaces.ss"
"partition.ss" "partition.ss"
"prefs.ss" "prefs.ss"
"widget.ss") "widget.ss")
@ -20,8 +22,9 @@
(define (browse-syntaxes stxs) (define (browse-syntaxes stxs)
(let ((w (make-syntax-browser))) (let ((w (make-syntax-browser)))
(for ([stx stxs]) (for ([stx stxs])
(send w add-syntax stx) (send*: w syntax-browser<%>
(send w add-separator)))) (add-syntax stx)
(add-separator)))))
;; make-syntax-browser : -> syntax-browser<%> ;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser) (define (make-syntax-browser)
@ -32,21 +35,23 @@
;; syntax-browser-frame% ;; syntax-browser-frame%
(define syntax-browser-frame% (define syntax-browser-frame%
(class* frame% () (class* frame% ()
(init-field [config (new syntax-prefs%)]) (inherit get-width
get-height)
(init-field: [config config<%> (new syntax-prefs%)])
(super-new (label "Syntax Browser") (super-new (label "Syntax Browser")
(width (send config pref:width)) (width (send: config config<%> get-width))
(height (send config pref:height))) (height (send: config config<%> get-height)))
(define widget (define: widget syntax-browser<%>
(new syntax-widget/controls% (new syntax-widget/controls%
(parent this) (parent this)
(config config))) (config config)))
(define/public (get-widget) widget) (define/public (get-widget) widget)
(define/augment (on-close) (define/augment (on-close)
(send config pref:width (send this get-width)) (send*: config config<%>
(send config pref:height (send this get-height)) (set-width (get-width))
(set-height (get-height)))
(send widget shutdown) (send widget shutdown)
(inner (void) on-close)) (inner (void) on-close))))
))
;; syntax-widget/controls% ;; syntax-widget/controls%
(define syntax-widget/controls% (define syntax-widget/controls%
@ -72,23 +77,23 @@
(choices (map car -identifier=-choices)) (choices (map car -identifier=-choices))
(callback (callback
(lambda (c e) (lambda (c e)
(send (get-controller) set-identifier=? (send: (get-controller) controller<%> set-identifier=?
(assoc (send c get-string-selection) (assoc (send c get-string-selection)
-identifier=-choices)))))) -identifier=-choices))))))
(new button% (new button%
(label "Clear") (label "Clear")
(parent -control-panel) (parent -control-panel)
(callback (lambda _ (send (get-controller) select-syntax #f)))) (callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f))))
(new button% (new button%
(label "Properties") (label "Properties")
(parent -control-panel) (parent -control-panel)
(callback (callback
(lambda _ (lambda _
(send config set-props-shown? (send: config config<%> set-props-shown?
(not (send config get-props-shown?)))))) (not (send: config config<%> get-props-shown?))))))
(send (get-controller) listen-identifier=? (send: (get-controller) controller<%> listen-identifier=?
(lambda (name+func) (lambda (name+func)
(send -choice set-selection (send -choice set-selection
(or (send -choice find-string (car name+func)) 0)))) (or (send -choice find-string (car name+func)) 0))))
)) ))

41
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,8 +1,19 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop) macro-debugger/util/class-iop
"../util/notify.ss")
(provide (all-defined-out)) (provide (all-defined-out))
;; config<%>
(define-interface config<%> ()
((methods:notify suffix-option
syntax-font-size
colors
width
height
props-percentage
props-shown?)))
;; displays-manager<%> ;; displays-manager<%>
(define-interface displays-manager<%> () (define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void (;; add-syntax-display : display<%> -> void
@ -13,10 +24,8 @@
;; selection-manager<%> ;; selection-manager<%>
(define-interface selection-manager<%> () (define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f (;; selected-syntax : notify-box of syntax/#f
set-selected-syntax (methods:notify selected-syntax)))
get-selected-syntax
listen-selected-syntax))
;; mark-manager<%> ;; mark-manager<%>
;; Manages marks, mappings from marks to colors ;; Manages marks, mappings from marks to colors
@ -29,23 +38,10 @@
;; secondary-partition<%> ;; secondary-partition<%>
(define-interface secondary-partition<%> () (define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%> (;; secondary-partition : notify-box of partition<%>
get-secondary-partition ;; identifier=? : notify-box of (cons string procedure)
(methods:notify secondary-partition
;; set-secondary-partition : partition<%> -> void identifier=?)))
set-secondary-partition
;; listen-secondary-partition : (partition<%> -> void) -> void
listen-secondary-partition
;; get-identifier=? : -> (cons string procedure)
get-identifier=?
;; set-identifier=? : (cons string procedure) -> void
set-identifier=?
;; listen-identifier=? : ((cons string procedure) -> void) -> void
listen-identifier=?))
;; controller<%> ;; controller<%>
(define-interface controller<%> (displays-manager<%> (define-interface controller<%> (displays-manager<%>
@ -143,6 +139,7 @@
add-clickback add-clickback
add-separator add-separator
erase-all erase-all
get-controller
get-text)) get-text))
(define-interface partition<%> () (define-interface partition<%> ()

2
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -42,7 +42,7 @@
(super-new))) (super-new)))
(define syntax-prefs-base% (define syntax-prefs-base%
(class prefs-base% (class* prefs-base% (config<%>)
;; width, height : number ;; width, height : number
(notify-methods width) (notify-methods width)
(notify-methods height) (notify-methods height)

14
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,7 +1,9 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
syntax/stx) macro-debugger/util/class-iop
syntax/stx
"interfaces.ss")
(provide (all-defined-out)) (provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@ -45,10 +47,10 @@
(case suffixopt (case suffixopt
((never) (unintern (syntax-e id))) ((never) (unintern (syntax-e id)))
((always) ((always)
(let ([n (send partition get-partition id)]) (let ([n (send: partition partition<%> get-partition id)])
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
((over-limit) ((over-limit)
(let ([n (send partition get-partition id)]) (let ([n (send: partition partition<%> get-partition id)])
(if (<= n limit) (if (<= n limit)
(unintern (syntax-e id)) (unintern (syntax-e id))
(suffix (syntax-e id) n)))))) (suffix (syntax-e id) n))))))
@ -61,7 +63,7 @@
=> (lambda (datum) datum)] => (lambda (datum) datum)]
[(and partition (identifier? obj)) [(and partition (identifier? obj))
(when (and (eq? suffixopt 'all-if-over-limit) (when (and (eq? suffixopt 'all-if-over-limit)
(> (send partition count) limit)) (> (send: partition partition<%> count) limit))
(call-with-values (lambda () (table stx partition #f 'always)) (call-with-values (lambda () (table stx partition #f 'always))
escape)) escape))
(let ([lp-datum (make-identifier-proxy obj)]) (let ([lp-datum (make-identifier-proxy obj)])
@ -70,7 +72,7 @@
lp-datum)] lp-datum)]
[(and (syntax? obj) (check+convert-special-expression obj)) [(and (syntax? obj) (check+convert-special-expression obj))
=> (lambda (newobj) => (lambda (newobj)
(when partition (send partition get-partition obj)) (when partition (send: partition partition<%> get-partition obj))
(let* ([inner (cadr newobj)] (let* ([inner (cadr newobj)]
[lp-inner-datum (loop inner)] [lp-inner-datum (loop inner)]
[lp-datum (list (car newobj) lp-inner-datum)]) [lp-datum (list (car newobj) lp-inner-datum)])
@ -80,7 +82,7 @@
(hash-set! stx=>flat obj lp-datum) (hash-set! stx=>flat obj lp-datum)
lp-datum))] lp-datum))]
[(syntax? obj) [(syntax? obj)
(when partition (send partition get-partition obj)) (when partition (send: partition partition<%> get-partition obj))
(let ([lp-datum (loop (syntax-e obj))]) (let ([lp-datum (loop (syntax-e obj))])
(hash-set! flat=>stx lp-datum obj) (hash-set! flat=>stx lp-datum obj)
(hash-set! stx=>flat obj lp-datum) (hash-set! stx=>flat obj lp-datum)

5
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/match scheme/match
scheme/list scheme/list
mzlib/string mzlib/string
@ -205,8 +206,8 @@
(define/public (read-special src line col pos) (define/public (read-special src line col pos)
(send the-syntax-snip read-special src line col pos)) (send the-syntax-snip read-special src line col pos))
(send config listen-props-shown? (send: config config<%> listen-props-shown?
(lambda (?) (refresh-contents))) (lambda (?) (refresh-contents)))
(super-new) (super-new)
(set-snipclass snip-class) (set-snipclass snip-class)

23
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -43,6 +43,7 @@
(define/public (setup-keymap) (define/public (setup-keymap)
(new syntax-keymap% (new syntax-keymap%
(editor -text) (editor -text)
(controller controller)
(config config))) (config config)))
(send -text set-styles-sticky #f) (send -text set-styles-sticky #f)
@ -54,7 +55,7 @@
(define/private (internal-show-props show?) (define/private (internal-show-props show?)
(if show? (if show?
(unless (send -props-panel is-shown?) (unless (send -props-panel is-shown?)
(let ([p (send config get-props-percentage)]) (let ([p (send: config config<%> get-props-percentage)])
(send -split-panel add-child -props-panel) (send -split-panel add-child -props-panel)
(update-props-percentage p)) (update-props-percentage p))
(send -props-panel show #t)) (send -props-panel show #t))
@ -81,8 +82,8 @@
(define/public (shutdown) (define/public (shutdown)
(when (props-panel-shown?) (when (props-panel-shown?)
(send config set-props-percentage (send: config config<%> set-props-percentage
(cadr (send -split-panel get-percentages))))) (cadr (send -split-panel get-percentages)))))
;; syntax-browser<%> Methods ;; syntax-browser<%> Methods
@ -202,7 +203,7 @@
display))) display)))
(define/private (calculate-columns) (define/private (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size))) (define style (code-style -text (send: config config<%> get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc))) (define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width))))) (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
@ -211,13 +212,13 @@
(super-new) (super-new)
(setup-keymap) (setup-keymap)
(send config listen-props-shown? (send: config config<%> listen-props-shown?
(lambda (show?) (lambda (show?)
(show-props show?))) (show-props show?)))
(send config listen-props-percentage (send: config config<%> listen-props-percentage
(lambda (p) (lambda (p)
(update-props-percentage p))) (update-props-percentage p)))
(internal-show-props (send config get-props-shown?)))) (internal-show-props (send: config config<%> get-props-shown?))))
(define clickback-style (define clickback-style

32
collects/macro-debugger/util/class-ct.ss
View File

@ -14,7 +14,15 @@
checked-binding-iface checked-binding-iface
checked-binding checked-binding
static-interface) static-interface
interface-expander?
make-interface-expander
interface-expander-proc
interface-expander
method-entry)
(define-struct static-interface (dynamic members) (define-struct static-interface (dynamic members)
#:omit-define-syntaxes #:omit-define-syntaxes
@ -60,6 +68,11 @@
(define (checked-binding-iface x) (define (checked-binding-iface x)
(raw-checked-binding-iface (set!-transformer-procedure x))) (raw-checked-binding-iface (set!-transformer-procedure x)))
(define-struct interface-expander (proc)
#:omit-define-syntaxes)
;; Syntax ;; Syntax
(define-syntax-class static-interface (define-syntax-class static-interface
@ -71,3 +84,20 @@
(pattern x (pattern x
#:declare x (static-of 'checked-binding checked-binding?) #:declare x (static-of 'checked-binding checked-binding?)
#:with value #'x.value)) #:with value #'x.value))
(define-syntax-class interface-expander
(pattern x
#:declare x (static-of 'interface-expander interface-expander?)
#:with value #'x.value))
(define-syntax-class method-entry
(pattern method:id
#:with methods (list #'method))
(pattern (macro:interface-expander . args)
#:with methods
(apply append
(for/list ([m ((interface-expander-proc #'macro.value)
#'(macro . args))])
(syntax-parse m
[m:method-entry #'m.methods])))))

27
collects/macro-debugger/util/class-iop.ss
View File

@ -5,6 +5,7 @@
"class-ct.ss")) "class-ct.ss"))
(provide define-interface (provide define-interface
define-interface/dynamic define-interface/dynamic
define-interface-expander
send: send:
send*: send*:
@ -26,13 +27,14 @@
;; Defines NAME as an interface. ;; Defines NAME as an interface.
(define-syntax (define-interface stx) (define-syntax (define-interface stx)
(syntax-parse stx (syntax-parse stx
[(_ name:id (super:static-interface ...) (mname:id ...)) [(_ name:id (super:static-interface ...) (m:method-entry ...))
(with-syntax ([((super-method ...) ...) (with-syntax ([((super-method ...) ...)
(map static-interface-members (map static-interface-members
(syntax->datum #'(super.value ...)))]) (syntax->datum #'(super.value ...)))]
[((mname ...) ...) #'(m.methods ...)])
#'(define-interface/dynamic name #'(define-interface/dynamic name
(let ([name (interface (super ...) mname ...)]) name) (let ([name (interface (super ...) mname ... ...)]) name)
(super-method ... ... mname ...)))])) (super-method ... ... mname ... ...)))]))
;; define-interface/dynamic SYNTAX ;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...)) ;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@ -54,6 +56,11 @@
(define-syntax name (define-syntax name
(make-static-interface #'dynamic-name '(mname ...)))))])) (make-static-interface #'dynamic-name '(mname ...)))))]))
(define-syntax (define-interface-expander stx)
(syntax-parse stx
[(_ name:id rhs:expr)
#'(define-syntax name (make-interface-expander rhs))]))
;; Helper ;; Helper
(begin-for-syntax (begin-for-syntax
@ -173,19 +180,19 @@
;; FIXME: unsafe due to mutation ;; FIXME: unsafe due to mutation
(define-syntax (init-field: stx) (define-syntax (init-field: stx)
(syntax-parse stx (syntax-parse stx
[(_ (name:id iface:static-interface) ...) [(_ (name:id iface:static-interface . default) ...)
#'(begin (init1: init-field name iface) ...)])) #'(begin (init1: init-field name iface . default) ...)]))
(define-syntax (init: stx) (define-syntax (init: stx)
(syntax-parse stx (syntax-parse stx
[(_ (name:id iface:static-interface) ...) [(_ (name:id iface:static-interface . default) ...)
#'(begin (init1: init name iface) ...)])) #'(begin (init1: init name iface . default) ...)]))
(define-syntax (init1: stx) (define-syntax (init1: stx)
(syntax-parse stx (syntax-parse stx
[(_ init name:id iface:static-interface) [(_ init name:id iface:static-interface . default)
(with-syntax ([(name-internal) (generate-temporaries #'(name))]) (with-syntax ([(name-internal) (generate-temporaries #'(name))])
#'(begin (init ((name-internal name))) #'(begin (init ((name-internal name) . default))
(void (check-object<:interface init: name-internal iface)) (void (check-object<:interface init: name-internal iface))
(define-syntax name (define-syntax name
(make-checked-binding (make-checked-binding

18
collects/macro-debugger/util/notify.ss
View File

@ -3,6 +3,7 @@
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
scheme/list scheme/list
scheme/class scheme/class
macro-debugger/util/class-iop
scheme/gui) scheme/gui)
(provide define/listen (provide define/listen
field/notify field/notify
@ -15,7 +16,9 @@
menu-option/notify-box menu-option/notify-box
menu-group/notify-box menu-group/notify-box
check-box/notify-box check-box/notify-box
choice/notify-box) choice/notify-box
methods:notify)
(define-for-syntax (join . args) (define-for-syntax (join . args)
(define (->string x) (define (->string x)
@ -71,6 +74,19 @@
(define/public-final (listen-name listener) (define/public-final (listen-name listener)
(send name listen listener))))])) (send name listen listener))))]))
(define-interface-expander methods:notify
(lambda (stx)
(syntax-case stx ()
[(_ name ...)
(apply append
(for/list ([name (syntax->list #'(name ...))])
(list ;; (join "init-" #'name)
(join "get-" name)
(join "set-" name)
(join "listen-" name))))])))
(define-syntax (connect-to-pref stx) (define-syntax (connect-to-pref stx)
(syntax-case stx () (syntax-case stx ()
[(connect-to-pref name pref) [(connect-to-pref name pref)

4
collects/macro-debugger/view/debug.ss
View File

@ -2,6 +2,8 @@
#lang scheme/base #lang scheme/base
(require scheme/pretty (require scheme/pretty
scheme/class scheme/class
macro-debugger/util/class-iop
"interfaces.ss"
"debug-format.ss" "debug-format.ss"
"prefs.ss" "prefs.ss"
"view.ss") "view.ss")
@ -30,5 +32,5 @@
(pretty-print msg) (pretty-print msg)
(pretty-print ctx) (pretty-print ctx)
(let* ([w (make-stepper)]) (let* ([w (make-stepper)])
(send w add-trace events) (send: w widget<%> add-trace events)
w))) w)))

18
collects/macro-debugger/view/frame.ss
View File

@ -42,8 +42,8 @@
get-help-menu) get-help-menu)
(super-new (label (make-label)) (super-new (label (make-label))
(width (send config get-width)) (width (send: config config<%> get-width))
(height (send config get-height))) (height (send: config config<%> get-height)))
(define/private (make-label) (define/private (make-label)
(if filename (if filename
@ -54,8 +54,8 @@
"Macro stepper")) "Macro stepper"))
(define/override (on-size w h) (define/override (on-size w h)
(send config set-width w) (send: config config<%> set-width w)
(send config set-height h) (send: config config<%> set-height h)
(send: widget widget<%> update/preserve-view)) (send: widget widget<%> update/preserve-view))
(define warning-panel (define warning-panel
@ -143,7 +143,7 @@
(eq? (car name+func) (car p))))))) (eq? (car name+func) (car p)))))))
(sb:identifier=-choices))) (sb:identifier=-choices)))
(let ([identifier=? (send config get-identifier=?)]) (let ([identifier=? (send: config config<%> get-identifier=?)])
(when identifier=? (when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))]) (let ([p (assoc identifier=? (sb:identifier=-choices))])
(send: controller sb:controller<%> set-identifier=? p)))) (send: controller sb:controller<%> set-identifier=? p))))
@ -178,10 +178,10 @@
(parent extras-menu) (parent extras-menu)
(callback (callback
(lambda (i e) (lambda (i e)
(send config set-suffix-option (send: config config<%> set-suffix-option
(if (send i is-checked?) (if (send i is-checked?)
'always 'always
'over-limit)) 'over-limit))
(send: widget widget<%> update/preserve-view)))) (send: widget widget<%> update/preserve-view))))
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Highlight redex/contractum" "Highlight redex/contractum"

12
collects/macro-debugger/view/hiding-panel.ss
View File

@ -79,7 +79,7 @@
(style '(deleted)))) (style '(deleted))))
(define/private (get-mode) (define/private (get-mode)
(send config get-macro-hiding-mode)) (send: config config<%> get-macro-hiding-mode))
(define/private (macro-hiding-enabled?) (define/private (macro-hiding-enabled?)
(let ([mode (get-mode)]) (let ([mode (get-mode)])
@ -89,7 +89,7 @@
(define/private (ensure-custom-mode) (define/private (ensure-custom-mode)
(unless (equal? (get-mode) mode:custom) (unless (equal? (get-mode) mode:custom)
(send config set-macro-hiding-mode mode:custom))) (send: config config<%> set-macro-hiding-mode mode:custom)))
(define/private (update-visibility) (define/private (update-visibility)
(let ([customizing (equal? (get-mode) mode:custom)]) (let ([customizing (equal? (get-mode) mode:custom)])
@ -104,10 +104,10 @@
(list customize-panel) (list customize-panel)
null)))))) null))))))
(send config listen-macro-hiding-mode (send: config config<%> listen-macro-hiding-mode
(lambda (value) (lambda (value)
(update-visibility) (update-visibility)
(force-refresh))) (force-refresh)))
(define box:hiding (define box:hiding
(new check-box% (new check-box%

17
collects/macro-debugger/view/interfaces.ss
View File

@ -1,8 +1,23 @@
#lang scheme/base #lang scheme/base
(require macro-debugger/util/class-iop) (require macro-debugger/util/class-iop
"../util/notify.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss"))
(provide (all-defined-out)) (provide (all-defined-out))
(define-interface config<%> (sb:config<%>)
((methods:notify macro-hiding-mode
show-hiding-panel?
identifier=?
highlight-foci?
highlight-frontier?
show-rename-steps?
suppress-warnings?
one-by-one?
extra-navigation?
debug-catch-errors?
force-letrec-transformation?)))
(define-interface widget<%> () (define-interface widget<%> ()
(get-config (get-config
get-controller get-controller

3
collects/macro-debugger/view/prefs.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
framework/framework framework/framework
"interfaces.ss"
"../syntax-browser/prefs.ss" "../syntax-browser/prefs.ss"
"../util/notify.ss" "../util/notify.ss"
"../util/misc.ss") "../util/misc.ss")
@ -43,7 +44,7 @@
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?) (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(define macro-stepper-config-base% (define macro-stepper-config-base%
(class syntax-prefs-base% (class* syntax-prefs-base% (config<%>)
(notify-methods macro-hiding-mode) (notify-methods macro-hiding-mode)
(notify-methods show-hiding-panel?) (notify-methods show-hiding-panel?)
(notify-methods identifier=?) (notify-methods identifier=?)

6
collects/macro-debugger/view/step-display.ss
View File

@ -41,7 +41,7 @@
(define step-display% (define step-display%
(class* object% (step-display<%>) (class* object% (step-display<%>)
(init-field config) (init-field: (config config<%>))
(init-field ((sbview syntax-widget))) (init-field ((sbview syntax-widget)))
(super-new) (super-new)
@ -194,8 +194,8 @@
;; insert-syntax/color ;; insert-syntax/color
(define/private (insert-syntax/color stx foci binders shift-table (define/private (insert-syntax/color stx foci binders shift-table
definites frontier hi-color) definites frontier hi-color)
(define highlight-foci? (send config get-highlight-foci?)) (define highlight-foci? (send: config config<%> get-highlight-foci?))
(define highlight-frontier? (send config get-highlight-frontier?)) (define highlight-frontier? (send: config config<%> get-highlight-frontier?))
(send: sbview sb:syntax-browser<%> add-syntax stx (send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null) #:definites (or definites null)
#:binder-table binders #:binder-table binders

42
collects/macro-debugger/view/stepper.ss
View File

@ -86,7 +86,7 @@
(let ([term (focused-term)]) (let ([term (focused-term)])
(when term (when term
(let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))]) (let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
(send: new-stepper widget<%> add-deriv (send term get-raw-deriv)) (send: new-stepper widget<%> add-deriv (send: term term-record<%> get-raw-deriv))
(void))))) (void)))))
;; duplicate-stepper : -> void ;; duplicate-stepper : -> void
@ -138,7 +138,7 @@
(config config) (config config)
(syntax-widget sbview))) (syntax-widget sbview)))
(define: sbc sb:controller<%> (define: sbc sb:controller<%>
(send sbview get-controller)) (send: sbview sb:syntax-browser<%> get-controller))
(define control-pane (define control-pane
(new vertical-panel% (parent area) (stretchable-height #f))) (new vertical-panel% (parent area) (stretchable-height #f)))
(define: macro-hiding-prefs hiding-prefs<%> (define: macro-hiding-prefs hiding-prefs<%>
@ -147,22 +147,24 @@
(stepper this) (stepper this)
(config config))) (config config)))
(send config listen-show-hiding-panel? (send: sbc sb:controller<%>
(lambda (show?) (show-macro-hiding-panel show?))) listen-selected-syntax
(send sbc listen-selected-syntax (lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
(lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx))) (send*: config config<%>
(send config listen-highlight-foci? (listen-show-hiding-panel?
(lambda (_) (update/preserve-view))) (lambda (show?) (show-macro-hiding-panel show?)))
(send config listen-highlight-frontier? (listen-highlight-foci?
(lambda (_) (update/preserve-view))) (lambda (_) (update/preserve-view)))
(send config listen-show-rename-steps? (listen-highlight-frontier?
(lambda (_) (refresh/re-reduce))) (lambda (_) (update/preserve-view)))
(send config listen-one-by-one? (listen-show-rename-steps?
(lambda (_) (refresh/re-reduce))) (lambda (_) (refresh/re-reduce)))
(send config listen-force-letrec-transformation? (listen-one-by-one?
(lambda (_) (refresh/resynth))) (lambda (_) (refresh/re-reduce)))
(send config listen-extra-navigation? (listen-force-letrec-transformation?
(lambda (show?) (show-extra-navigation show?))) (lambda (_) (refresh/resynth)))
(listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?))))
(define nav:up (define nav:up
(new button% (label "Previous term") (parent navigator) (new button% (label "Previous term") (parent navigator)
@ -400,8 +402,8 @@
;; Initialization ;; Initialization
(super-new) (super-new)
(show-macro-hiding-panel (send config get-show-hiding-panel?)) (show-macro-hiding-panel (send: config config<%> get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?)) (show-extra-navigation (send: config config<%> get-extra-navigation?))
(refresh/move) (refresh/move)
)) ))

7
collects/macro-debugger/view/term-record.ss
View File

@ -33,7 +33,8 @@
(class* object% (term-record<%>) (class* object% (term-record<%>)
(init-field: (stepper widget<%>)) (init-field: (stepper widget<%>))
(define config (send stepper get-config)) (define: config config<%>
(send: stepper widget<%> get-config))
(define: displayer step-display<%> (define: displayer step-display<%>
(send: stepper widget<%> get-step-displayer)) (send: stepper widget<%> get-step-displayer))
@ -173,12 +174,12 @@
(set! steps (set! steps
(and raw-steps (and raw-steps
(let* ([filtered-steps (let* ([filtered-steps
(if (send config get-show-rename-steps?) (if (send: config config<%> get-show-rename-steps?)
raw-steps raw-steps
(filter (lambda (x) (not (rename-step? x))) (filter (lambda (x) (not (rename-step? x)))
raw-steps))] raw-steps))]
[processed-steps [processed-steps
(if (send config get-one-by-one?) (if (send: config config<%> get-one-by-one?)
(reduce:one-by-one filtered-steps) (reduce:one-by-one filtered-steps)
filtered-steps)]) filtered-steps)])
(cursor:new processed-steps)))) (cursor:new processed-steps))))