From 382ddec6f800a2cf8eed7657c2527372a13bedd0 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 15 Jan 2009 07:30:08 +0000
Subject: [PATCH] macro stepper: added "factor common context" option

svn: r13143

original commit: 10297fa579183682a62dfa3684a7b9af3c571098
---
 collects/macro-debugger/model/steps.ss        | 12 +++--
 .../macro-debugger/syntax-browser/widget.ss   | 23 ++++++---
 collects/macro-debugger/view/frame.ss         |  3 ++
 collects/macro-debugger/view/interfaces.ss    |  3 +-
 collects/macro-debugger/view/prefs.ss         |  5 ++
 collects/macro-debugger/view/step-display.ss  | 50 +++++++++++++++++--
 collects/macro-debugger/view/stepper.ss       |  2 +
 7 files changed, 81 insertions(+), 17 deletions(-)

diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss
index 6dd12fd..a1fe495 100644
--- 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
index 6d90770..07d21b9 100644
--- 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
index 07221aa..d57308e 100644
--- a/collects/macro-debugger/view/frame.ss
+++ b/collects/macro-debugger/view/frame.ss
@@ -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))
diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss
index 7e14643..d5d75aa 100644
--- 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
index 73eb46d..5d9f1b9 100644
--- 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
index 733e536..ad1d941 100644
--- 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
index 8f72e06..28138be 100644
--- 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?