Fixed macro-stepper to work with #%top-interaction

svn: r5268

collects/macro-debugger/model/debug.ss

@@ -12,93 +12,5 @@
            (all-from "deriv-util.ss")
            (all-from "hiding-policies.ss")
            (all-from "hide.ss")
-           (all-from (lib "plt-match.ss"))
-           find-deriv)
-
-  (define (find-deriv pred d)
-    (define (loop d)
-      (match d
-        [(? pred d) (list d)]
-        [(AnyQ mrule (_ _ tx next))
-         (append (loop tx) (loop next))]
-        [(AnyQ lift-deriv (_ _ first lift second))
-         (append (loop first) (loop lift) (loop second))]
-        [(AnyQ transformation (_ _ _ _ _ locals))
-         (loops locals)]
-        [(struct local-expansion (_ _ _ _ deriv))
-         (loop deriv)]
-        [(struct local-bind (deriv))
-         (loop deriv)]
-        [(AnyQ p:define-syntaxes (_ _ _ rhs))
-         (loop rhs)]
-        [(AnyQ p:define-values (_ _ _ rhs))
-         (loop rhs)]
-        [(AnyQ p:if (_ _ _ _ test then else))
-         (append (loop test) (loop then) (loop else))]
-        [(AnyQ p:wcm (_ _ _ key value body))
-         (append (loop key) (loop value) (loop body))]
-        [(AnyQ p:set! (_ _ _ _ rhs))
-         (loop rhs)]
-        [(AnyQ p:set!-macro (_ _ _ deriv))
-         (loop deriv)]
-        [(AnyQ p:begin (_ _ _ lderiv))
-         (loop lderiv)]
-        [(AnyQ p:begin0 (_ _ _ first lderiv))
-         (append (loop first) (loop lderiv))]
-        [(AnyQ p:#%app (_ _ _ _ lderiv))
-         (loop lderiv)]
-        [(AnyQ p:lambda (_ _ _ _ body))
-         (loop body)]
-        [(AnyQ p:case-lambda (_ _ _ rbs))
-         (apply append (map loop (map cdr (or rbs null))))]
-        [(AnyQ p:let-values (_ _ _ _ rhss body))
-         (append (loops rhss) (loop body))]
-        [(AnyQ p:letrec-values (_ _ _ _ rhss body))
-         (append (loops rhss) (loop body))]
-        [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body))
-         (append (loops srhss) (loops vrhss) (loop body))]
-        [(AnyQ p:module (_ _ _ _ body))
-         (loop body)]
-        [(AnyQ p:#%module-begin (_ _ _ pass1 pass2))
-         (append (loops pass1) (loops pass2))]
-        [(AnyQ p:rename (_ _ _ _ inner))
-         (loop inner)]
-        [(AnyQ p:synth (_ _ _ subterms))
-         (loops (map s:subterm-deriv subterms))]
-
-        [(AnyQ lderiv (_ _ derivs))
-         (loops derivs)]
-        [(AnyQ bderiv (_ _ pass1 _ pass2))
-         (append (loops pass1) (loop pass2))]
-        [(AnyQ b:defvals (_ head))
-         (loop head)]
-        [(AnyQ b:defstx (_ deriv rhs))
-         (append (loop deriv) (loop rhs))]
-        [(AnyQ b:splice (_ head _))
-         (loop head)]
-        [(AnyQ b:expr (_ head))
-         (loop head)]
-        [(AnyQ b:begin (_ head inner))
-         (append (loop head) (loop inner))]
-        [(AnyQ mod:cons (head))
-         (loop head)]
-        [(AnyQ mod:prim (head prim))
-         (append (loop head) (loop prim))]
-        [(AnyQ mod:splice (head _))
-         (loop head)]
-        [(AnyQ mod:lift (head tail))
-         (append (loop head) (loop tail))]
-        [(AnyQ mod:lift-end (tail))
-         (loop tail)]
-        [(AnyQ mod:begin (head inner))
-         (append (loop head) (loop inner))]
-
-        [else null]))
-
-    (define (loops ds)
-      (if (list? ds)
-          (apply append (map loop ds))
-          null))
-
-    (loop d))
+           (all-from (lib "plt-match.ss")))
   )

collects/macro-debugger/model/deriv-util.ss

@@ -17,7 +17,11 @@
            outer-rewrap
            lift/deriv-e1
            lift/deriv-e2
-           wrapped?)
+           wrapped?
+
+           find-derivs
+           find-deriv
+           find-derivs/syntax)
 
   ;; IntW
   ;; Matches only interrupted wraps
@@ -161,5 +165,116 @@
 ;         #'($$ S (var ...) (cons #f tag))]
 ;        [($$E S (var ...) @ tag exn)
 ;         #'($$ S (var ...) (cons exn tag))])))
+
+  ;; Utilities for finding subderivations
   
+  ;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv)
+  (define (find-derivs pred stop-short d)
+    (find-deriv/unit+join+zero pred stop-short d list append null))
+
+  ;; find-deriv : (deriv -> boolean) (deriv -> boolean) deriv -> deriv/#f
+  ;; Finds the first deriv that matches; throws the rest away
+  (define (find-deriv pred stop-short d)
+    (let/ec return (find-deriv/unit+join+zero pred stop-short d return (lambda _ #f) #f)))
+
+  ;; find-deriv/unit+join+zero
+  ;; Parameterized over monad operations for combining the results
+  ;; For example, <list, append, null> collects the results into a list
+  (define (find-deriv/unit+join+zero pred stop-short d unit join zero)
+    (define (loop d)
+      (match d
+        [(? pred d) (unit d)]
+        [(? stop-short d) zero]
+        [(AnyQ mrule (_ _ tx next))
+         (join (loop tx) (loop next))]
+        [(AnyQ lift-deriv (_ _ first lift second))
+         (join (loop first) (loop lift) (loop second))]
+        [(AnyQ transformation (_ _ _ _ _ locals))
+         (loops locals)]
+        [(struct local-expansion (_ _ _ _ deriv))
+         (loop deriv)]
+        [(struct local-bind (deriv))
+         (loop deriv)]
+        [(AnyQ p:define-syntaxes (_ _ _ rhs))
+         (loop rhs)]
+        [(AnyQ p:define-values (_ _ _ rhs))
+         (loop rhs)]
+        [(AnyQ p:if (_ _ _ _ test then else))
+         (join (loop test) (loop then) (loop else))]
+        [(AnyQ p:wcm (_ _ _ key value body))
+         (join (loop key) (loop value) (loop body))]
+        [(AnyQ p:set! (_ _ _ _ rhs))
+         (loop rhs)]
+        [(AnyQ p:set!-macro (_ _ _ deriv))
+         (loop deriv)]
+        [(AnyQ p:begin (_ _ _ lderiv))
+         (loop lderiv)]
+        [(AnyQ p:begin0 (_ _ _ first lderiv))
+         (join (loop first) (loop lderiv))]
+        [(AnyQ p:#%app (_ _ _ _ lderiv))
+         (loop lderiv)]
+        [(AnyQ p:lambda (_ _ _ _ body))
+         (loop body)]
+        [(AnyQ p:case-lambda (_ _ _ rbs))
+         (apply join (map loop (map cdr (or rbs null))))]
+        [(AnyQ p:let-values (_ _ _ _ rhss body))
+         (join (loops rhss) (loop body))]
+        [(AnyQ p:letrec-values (_ _ _ _ rhss body))
+         (join (loops rhss) (loop body))]
+        [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body))
+         (join (loops srhss) (loops vrhss) (loop body))]
+        [(AnyQ p:module (_ _ _ _ body))
+         (loop body)]
+        [(AnyQ p:#%module-begin (_ _ _ pass1 pass2))
+         (join (loops pass1) (loops pass2))]
+        [(AnyQ p:rename (_ _ _ _ inner))
+         (loop inner)]
+        [(AnyQ p:synth (_ _ _ subterms))
+         (loops (map s:subterm-deriv subterms))]
+
+        [(AnyQ lderiv (_ _ derivs))
+         (loops derivs)]
+        [(AnyQ bderiv (_ _ pass1 _ pass2))
+         (join (loops pass1) (loop pass2))]
+        [(AnyQ b:defvals (_ head))
+         (loop head)]
+        [(AnyQ b:defstx (_ deriv rhs))
+         (join (loop deriv) (loop rhs))]
+        [(AnyQ b:splice (_ head _))
+         (loop head)]
+        [(AnyQ b:expr (_ head))
+         (loop head)]
+        [(AnyQ b:begin (_ head inner))
+         (join (loop head) (loop inner))]
+        [(AnyQ mod:cons (head))
+         (loop head)]
+        [(AnyQ mod:prim (head prim))
+         (join (loop head) (loop prim))]
+        [(AnyQ mod:splice (head _))
+         (loop head)]
+        [(AnyQ mod:lift (head tail))
+         (join (loop head) (loop tail))]
+        [(AnyQ mod:lift-end (tail))
+         (loop tail)]
+        [(AnyQ mod:begin (head inner))
+         (join (loop head) (loop inner))]
+
+        [else zero]))
+
+    (define (loops ds)
+      (if (list? ds)
+          (apply join (map loop ds))
+          zero))
+    (loop d))
+
+  (define (find-derivs/syntax pred d)
+    (find-derivs (match-lambda
+                  [(AnyQ deriv (e1 e2))
+                   (pred e1)]
+                  [_ #f])
+                 (match-lambda
+                  [(AnyQ p:module (_ _ _ _ _)) #t]
+                  [(AnyQ lift-deriv (_ _ _ _ _)) #t]
+                  [_ #f])
+                 d))
   )

collects/macro-debugger/tool.ss

@@ -9,6 +9,7 @@
            (lib "bitmap-label.ss" "mrlib")
            (lib "string-constant.ss" "string-constants")
            "model/trace.ss"
+           "model/deriv-util.ss"
            (prefix view: "view/interfaces.ss")
            (prefix view: "view/gui.ss")
            (prefix view: "view/prefs.ss")
@@ -143,9 +144,9 @@
                   [debugging? debugging?])
               (values
                (lambda (expr)
-                 (if (and debugging? (and (syntax? expr) (syntax-source expr)))
+                 (if (and debugging? (syntax? expr))
                      (let-values ([(e-expr deriv) (trace/result expr)])
-                       (show-deriv deriv stepper)
+                       (show-deriv/orig-parts deriv stepper)
                        (if (syntax? e-expr)
                            (parameterize ((current-eval original-eval-handler))
                              (original-eval-handler e-expr))
@@ -164,6 +165,11 @@
                          (set! debugging? saved-debugging?)
                          (when eo (current-expand-observe eo)))))))))
 
+          (define/private (show-deriv/orig-parts deriv stepper-promise)
+            (for-each (lambda (d) (show-deriv d stepper-promise))
+                      (find-derivs/syntax (lambda (stx) (and (syntax? stx) (syntax-source stx)))
+                                          deriv)))
+
           (define/private (show-deriv deriv stepper-promise)
             (parameterize ([current-eventspace drscheme-eventspace])
               (queue-callback