macro stepper: enabled for "Module", improved debugging setup

svn: r7981

original commit: 75b2415a967ae31ca774e4ece3f8c596616087b9

collects/macro-debugger/view/debug.ss

@@ -1,14 +1,35 @@
 
 (module debug mzscheme
   (require (lib "pretty.ss")
+           (lib "class.ss")
            "debug-format.ss"
+           "prefs.ss"
            "view.ss")
   (provide debug-file)
 
+  (define (widget-mixin %)
+    (class %
+      (define/override (top-interaction-kw? x)
+        (eq? (syntax-e x) '#%top-interaction))
+      (super-new)))
+
+  (define stepper-frame%
+    (class macro-stepper-frame%
+      (define/override (get-macro-stepper-widget%)
+        (widget-mixin (super get-macro-stepper-widget%)))
+      (super-new)))
+
+  (define (make-stepper)
+    (let ([f (new macro-stepper-frame%
+                  (config (new macro-stepper-config/prefs%)))])
+      (send f show #t)
+      (send f get-widget)))
+
   (define (debug-file file)
     (let-values ([(events msg ctx) (load-debug-file file)])
       (pretty-print msg)
       (pretty-print ctx)
-      (go/trace events)))
-  
+      (let* ([w (make-stepper)])
+        (send w add-trace events)
+        w)))
   )

collects/macro-debugger/view/stepper.ss

@@ -24,7 +24,8 @@
            "../model/steps.ss"
            "cursor.ss"
            "util.ss")
-  (provide macro-stepper-widget%)
+  (provide macro-stepper-widget%
+           macro-stepper-widget/process-mixin)
 
   ;; Macro Stepper
 
@@ -378,4 +379,55 @@
       (refresh/move)
       ))
 
+  (define (macro-stepper-widget/process-mixin %)
+    (class %
+      (super-new)
+      (define/override (get-preprocess-deriv)
+        (lambda (d) (get-original-part d)))
+
+      ;; get-original-part : Deriv -> Deriv/#f
+      ;; Strip off mzscheme's #%top-interaction
+      ;; Careful: the #%top-interaction node may be inside of a lift-deriv
+      (define/private (get-original-part deriv)
+        (let ([deriv* (adjust-deriv/lift deriv)])
+          deriv*))
+      
+      ;; adjust-deriv/lift : Derivation -> (list-of Derivation)
+      (define/private (adjust-deriv/lift deriv)
+        (match deriv
+          [(Wrap lift-deriv (e1 e2 first lifted-stx second))
+           (let ([first (adjust-deriv/top first)])
+             (and first
+                  (let ([e1 (wderiv-e1 first)])
+                    (make-lift-deriv e1 e2 first lifted-stx second))))]
+          [else (adjust-deriv/top deriv)]))
+
+      ;; adjust-deriv/top : Derivation -> Derivation
+      (define/private (adjust-deriv/top deriv)
+        (if (syntax-source (wderiv-e1 deriv))
+            deriv
+            ;; It's not original...
+            ;; Strip out mzscheme's top-interactions
+            ;; Keep anything that is a non-mzscheme top-interaction
+            ;; Drop everything else (not original program)
+            (match deriv
+              [(Wrap mrule (e1 e2 tx next))
+               (match tx
+                 [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
+                  (cond [(ormap (lambda (x) (top-interaction-kw? x))
+                                rs)
+                         ;; Just mzscheme's top-interaction; strip it out
+                         (adjust-deriv/top next)]
+                        [(equal? (map syntax-e rs) '(#%top-interaction))
+                         ;; A *different* top interaction; keep it
+                         deriv]
+                        [else
+                         ;; Not original and not tagged with top-interaction
+                         #f])])]
+              [else #f])))
+
+      (define/public (top-interaction-kw? x)
+        (module-identifier=? x #'#%top-interaction))
+
+      ))
   )