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

macro stepper: added "factor common context" option

Browse Source 
svn: r13143

original commit: 10297fa579183682a62dfa3684a7b9af3c571098
This commit is contained in:
Ryan Culpepper 2009-01-15 07:30:08 +00:00
parent 4e30b60dd1
commit 382ddec6f8
7 changed files with 81 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/macro-debugger/model/steps.ss
View File

@ -40,11 +40,13 @@
;; context-fill : Context Syntax -> Syntax
(define (context-fill ctx stx)
(let loop ([ctx ctx] [stx stx])
(if (null? ctx)
stx
(let ([frame0 (car ctx)])
(loop (cdr ctx) (frame0 stx))))))
(datum->syntax
#f
(let loop ([ctx ctx] [stx stx])
(if (null? ctx)
stx
(let ([frame0 (car ctx)])
(loop (cdr ctx) (frame0 stx)))))))
(define (state-term s)
(context-fill (state-ctx s) (state-e s)))

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

@ -111,7 +111,8 @@
#:shift-table [shift-table #f]
#:definites [definites null]
#:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null])
#:hi-stxss [hi-stxss null]
#:substitutions [substitutions null])
(define (get-binders id)
(define binder
(module-identifier-mapping-get alpha-table id (lambda () #f)))
@ -120,11 +121,21 @@
(list binder)))
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(for-each (lambda (hi-stxs hi-color)
(send: display display<%>
highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
(let ([range (send: display display<%> get-range)]
[offset (send: display display<%> get-start-position)])
(for ([subst substitutions])
(for ([r (send: range range<%> get-ranges (car subst))])
(with-unlock -text
(send -text insert (cdr subst)
(+ offset (car r))
(+ offset (cdr r))
#f)
(send -text change-style
(code-style -text (send: config config<%> get-syntax-font-size))
(+ offset (car r))
(+ offset (cdr r)))))))
(for ([hi-stxs hi-stxss] [hi-color hi-colors])
(send: display display<%> highlight-syntaxes hi-stxs hi-color))
(for ([definite definites])
(hash-set! definite-table definite #t)
(when shift-table

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

@ -183,6 +183,9 @@
'always
'over-limit))
(send: widget widget<%> update/preserve-view))))
(menu-option/notify-box extras-menu
"Factor out common context?"
(get-field split-context? config))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))

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

@ -16,7 +16,8 @@
one-by-one?
extra-navigation?
debug-catch-errors?
force-letrec-transformation?)))
force-letrec-transformation?
split-context?)))
(define-interface widget<%> ()
(get-config

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

@ -26,6 +26,7 @@
(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
(preferences:set-default 'MacroStepper:SplitContext? #f boolean?)
(pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height)
@ -42,6 +43,7 @@
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(pref:get/set pref:split-context? MacroStepper:SplitContext?)
(define macro-stepper-config-base%
(class* syntax-prefs-base% (config<%>)
@ -56,6 +58,7 @@
(notify-methods extra-navigation?)
(notify-methods debug-catch-errors?)
(notify-methods force-letrec-transformation?)
(notify-methods split-context?)
(super-new)))
(define macro-stepper-config/prefs%
@ -75,6 +78,7 @@
(connect-to-pref extra-navigation? pref:extra-navigation?)
(connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
(connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
(connect-to-pref split-context? pref:split-context?)
(super-new)))
(define macro-stepper-config/prefs/readonly%
@ -93,4 +97,5 @@
(connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
(connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
(connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
(connect-to-pref/readonly split-context? pref:split-context?)
(super-new)))

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

@ -142,10 +142,50 @@
;; show-step : Step -> void
(define/private (show-step step binders shift-table)
(show-state/redex (protostep-s1 step) binders shift-table)
(separator step)
(show-state/contractum (step-s2 step) binders shift-table)
(show-lctx step binders shift-table))
(let-values ([(common-context state1 state2)
(factor-common-context (protostep-s1 step)
(step-s2 step))])
(show-state/redex state1 binders shift-table)
(separator step)
(show-state/contractum state2 binders shift-table)
(show-common-context common-context state1 binders shift-table)
(show-lctx step binders shift-table)))
(define/private (factor-common-context state1 state2)
(if (send: config config<%> get-split-context?)
(factor-common-context* state1 state2)
(values null state1 state2)))
(define/private (factor-common-context* state1 state2)
(match-define
(struct state (e1 foci1 ctx1 lctx1 binders1 uses1 frontier1 seq1)) state1)
(match-define
(struct state (e2 foci2 ctx2 lctx2 binders2 uses2 frontier2 seq2)) state2)
(define (common xs ys acc)
(if (and (pair? xs) (pair? ys) (eq? (car xs) (car ys)))
(common (cdr xs) (cdr ys) (cons (car xs) acc))
(values (reverse xs) (reverse ys) acc)))
(define-values (ctx1z ctx2z common-ctx)
(common (reverse ctx1) (reverse ctx2) null))
(define state1z
(make-state e1 foci1 ctx1z lctx1 binders1 uses1 frontier1 seq1))
(define state2z
(make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2))
(values common-ctx state1z state2z))
(define/private (show-common-context ctx state1 binders shift-table)
(match-define
(struct state (_ _ _ _ _ uses1 frontier1 _)) state1)
(when (pair? ctx)
(let* ([hole-stx #'~~HOLE~~]
[the-syntax (context-fill ctx hole-stx)])
(send*: sbview sb:syntax-browser<%>
(add-text "\nin context:\n")
(add-syntax the-syntax
#:binder-table binders
#:shift-table shift-table
#:definites uses1
#:substitutions (list (cons hole-stx "[ HOLE ]")))))))
(define/private (show-state/redex state binders shift-table)
(insert-syntax/redex (state-term state)

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

@ -153,6 +153,8 @@
(send*: config config<%>
(listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?)))
(listen-split-context?
(lambda (_) (update/preserve-view)))
(listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(listen-highlight-frontier?