commit 382ddec6f800a2cf8eed7657c2527372a13bedd0
parent 4e30b60dd16d9f1f2b0c7e877ebbbc01798c63af
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 15 Jan 2009 07:30:08 +0000
macro stepper: added "factor common context" option
svn: r13143
original commit: 10297fa579183682a62dfa3684a7b9af3c571098
Diffstat:
7 files changed, 81 insertions(+), 17 deletions(-)
diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss
@@ -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)))
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -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
diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss
@@ -184,6 +184,9 @@
'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))
(menu-option/notify-box extras-menu
diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss
@@ -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
diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss
@@ -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)))
diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss
@@ -139,13 +139,53 @@
(define/private (separator/small step)
(insert-step-separator/small
(step-type->string (protostep-type step))))
-
+
;; 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)
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -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?
