Updates to macro stepper:

Handle errors in BindSyntax
  Fixed lift-deriv hiding typo
  Removed same-marks from partitions
  When stepper autodisables hiding, update panel
  Refactored stepper update function
  Fixed internal error handling

svn: r4851

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

@@ -466,11 +466,12 @@
 
       ;; BindSyntaxes Answer = Derivation
       (BindSyntaxes
-       [(phase-up (? EE/LetLifts) Eval) $2])
+       [(phase-up (? EE/LetLifts) ! Eval) $2])
       
       ;; NextBindSyntaxess Answer = (list-of Derivation)
       (NextBindSyntaxess
        (#:skipped null)
+       (#:no-wrap)
        [() null]
        [(next (? BindSyntaxes 'first) (? NextBindSyntaxess 'rest)) (cons $2 $3)])
       

collects/macro-debugger/model/hide.ss

@@ -491,7 +491,7 @@
              [(and (struct error-wrap (exn tag inner)) ew)
               (values ew (deriv-e2 inner))]
              [deriv
-              (values (rewrap d deriv) (deriv-e2 deriv))])))]))
+              (values (rewrap d deriv) (lift/deriv-e2 deriv))])))]))
 
   ;; seek : Derivation -> Derivation
   ;; Expects macro-policy, subterms-table to be set up already
@@ -505,7 +505,9 @@
 
   ;; create-synth-deriv : syntax (list-of Subterm) -> Derivation
   (define (create-synth-deriv e1 subterm-derivs)
-    (define (error? x) (and (s:subterm? x) (not (s:subterm-path x))))
+    (define (error? x)
+      (and (s:subterm? x) 
+           (or (interrupted-wrap? (s:subterm-deriv x)) (error-wrap? (s:subterm-deriv x)))))
     (let ([errors
            (map s:subterm-deriv (filter error? subterm-derivs))]
           [subterms (filter (lambda (x) (not (error? x))) subterm-derivs)])
@@ -514,9 +516,7 @@
       (let ([e2 (substitute-subterms e1 subterms)])
         (let ([d (make-p:synth e1 e2 null subterms)])
           (if (pair? errors)
-              (make-error-wrap (error-wrap-exn (car errors))
+              (rewrap (car errors) d)
-                               (error-wrap-tag (car errors))
-                               d)
               d)))))
 
   ;; subterm-derivations : Derivation -> (list-of Subterm)
@@ -638,6 +638,11 @@
         [(AnyQ mrule (e1 e2 (and ew (struct error-wrap (_ _ _))) next))
          (list (make-s:subterm #f ew))]
 
+        
+        [(AnyQ lift-deriv (e1 e2 first lifted-stx next))
+         (>>Seek (for-deriv first)
+                 (for-deriv next))]
+        
         ;; Errors
 
 ;        [(struct error-wrap (exn tag (? deriv? inner)))
@@ -763,9 +768,11 @@
            (let* ([subterm0 (car subterm-derivs)]
                   [path0 (s:subterm-path subterm0)]
                   [deriv0 (s:subterm-deriv subterm0)])
-             (substitute-subterms
+             (let ([e2 (lift/deriv-e2 deriv0)])
-              (if path0 (path-replace stx path0 (deriv-e2 deriv0)) stx)
+               (and e2
-              (cdr subterm-derivs)))]
+                    (substitute-subterms
+                     (if path0 (path-replace stx path0 (deriv-e2 deriv0)) stx)
+                     (cdr subterm-derivs)))))]
           [(s:rename? (car subterm-derivs))
            (let ([subterm0 (car subterm-derivs)])
              (substitute-subterms
@@ -1182,6 +1189,7 @@
                   (make-lift-deriv 
                    head-e1 begin-stx2
                    deriv
+                   begin-stx1
                    (make-p:begin begin-stx1 begin-stx2 null
                                  (make-lderiv (append inners-es1 (list head-e2))
                                               (append inners-es2 (list head-e2))

collects/macro-debugger/model/reductions.ss

@@ -6,6 +6,7 @@
            "context.ss"
            "deriv.ss"
            "reductions-engine.ss")
+
   (provide reductions)
 
   ;; Setup for reduction-engines
@@ -266,7 +267,9 @@
 
       ;; Skipped
       
-      [#f null]))
+      [#f null]
+      
+      #;[else (error 'reductions "unmatched case: ~s" d)]))
 
   ;; reductions-transformation : Transformation -> ReductionSequence
   (define (reductions-transformation tx)

collects/macro-debugger/syntax-browser/partition.ss

@@ -150,7 +150,6 @@
     (make-parameter
      `(("<nothing>" . #f)
        ("bound-identifier=?"  . ,bound-identifier=?)
-       ("same marks" . ,id:same-marks?)
        ("module-identifier=?" . ,module-identifier=?)
        ("module-or-top-identifier=?" . ,module-or-top-identifier=?)
        ("symbolic-identifier=?" . ,symbolic-identifier=?)

collects/macro-debugger/view/gui.ss

@@ -179,10 +179,10 @@
                        (pair? (cdr (append derivs-prefix derivs))))
               (send super-navigator add-child updown-navigator)
               (send updown-navigator show #t))
-            (when (null? (cdr derivs))
+            (if (null? (cdr derivs))
-              ;; There is nothing currently displayed
+                ;; There is nothing currently displayed
-              (refresh))
+                (refresh)
-            (update))
+                (update)))
 
           (define/public (get-controller) sbc)
           (define/public (get-view) sbview)
@@ -321,30 +321,21 @@
                   (let ([result (lift/deriv-e2 synth-deriv)])
                     (when result
                       (send sbview add-text "Expansion finished\n")
-                      (send sbview add-syntax (lift/deriv-e2 synth-deriv)))
+                      (send sbview add-syntax result))
                     (unless result
                       (send sbview add-text "Error\n"))))
                 (when (step? step)
                   (when (pair? (step-lctx step))
                     (for-each (lambda (bc)
                                 (send sbview add-text "While executing macro transformer in:\n")
-                                (send sbview add-syntax (cdr bc) (car bc) "MistyRose"))
+                                (insert-syntax/redex (cdr bc) (car bc)))
                               (step-lctx step))
                     (send sbview add-text "\n"))
-                  (send sbview add-syntax
+                  (insert-syntax/redex (step-e1 step) (foci (step-redex step)))
-                        (step-e1 step)
-                        (foci (step-redex step))
-                        "MistyRose")
                   (insert-step-separator (step-note step))
-                  (send sbview add-syntax
+                  (insert-syntax/contractum (step-e2 step) (foci (step-contractum step))))
-                        (step-e2 step)
-                        (foci (step-contractum step))
-                        "LightCyan"))
                 (when (misstep? step)
-                  (send sbview add-syntax
+                  (insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step)))
-                        (misstep-e1 step)
-                        (foci (misstep-redex step))
-                        "MistyRose")
                   (insert-step-separator "Error")
                   (send sbview add-text (exn-message (misstep-exn step)))
                   (send sbview add-text "\n")
@@ -363,7 +354,16 @@
                   (send text last-position)
                   'start)
             (enable/disable-buttons))
+
+          ;; insert-syntax/redex : syntax syntaxes -> void
+          (define/private (insert-syntax/redex stx foci)
+            (send sbview add-syntax stx foci "MistyRose"))
           
+          ; insert-syntax/contractum : syntax syntaxes -> void
+          (define/private (insert-syntax/contractum stx foci)
+            (send sbview add-syntax stx foci "LightCyan"))
+          
+          ;; enable/disable-buttons : -> void
           (define/private (enable/disable-buttons)
             (send nav:start enable (and steps (cursor:can-move-previous? steps)))
             (send nav:previous enable (and steps (cursor:can-move-previous? steps)))
@@ -401,17 +401,10 @@
           ;; refresh/nontrivial : -> void
           (define/private (refresh/nontrivial)
             (let ([deriv (car derivs)])
-              (with-handlers ([(lambda (e) (catch-errors?))
+              (let ([d (synthesize deriv)])
-                               (lambda (e)
+                (let ([s (cursor:new (reduce d))])
-                                 (message-box 
+                  (set! synth-deriv d)
-                                  "Error"
+                  (set! steps s))))
-                                  "Internal error in macro stepper (reductions)")
-                                 (set! synth-deriv #f)
-                                 (set! steps (cursor:new null)))])
-                (let ([d (synthesize deriv)])
-                  (let ([s (cursor:new (reduce d))])
-                    (set! synth-deriv d)
-                    (set! steps s)))))
             (update))
 
           ;; synthesize : Derivation -> Derivation
@@ -440,13 +433,20 @@
               "Trying again with macro hiding disabled."))
             (send macro-hiding-prefs enable-hiding #f)
             (synthesize deriv))
-
+          
           ;; reduce : Derivation -> ReductionSequence
           (define/private (reduce d)
-            (if (show-rename-steps?)
+            (with-handlers ([(lambda (e) (catch-errors?))
-                (reductions d)
+                             (lambda (e)
-                (filter (lambda (x) (not (rename-step? x)))
+                               (message-box 
-                        (reductions d))))
+                                "Error"
+                                "Internal error in macro stepper (reductions)")
+                               (set! synth-deriv #f)
+                               (set! steps #f))])
+              (if (show-rename-steps?)
+                  (reductions d)
+                  (filter (lambda (x) (not (rename-step? x)))
+                          (reductions d)))))
           
           (define/private (foci x) (if (list? x) x (list x)))
 

collects/macro-debugger/view/hiding-panel.ss

@@ -100,6 +100,7 @@
       ;; enable-hiding : boolean -> void
       ;; Called only by stepper, which does it's own refresh
       (define/public (enable-hiding ok?)
+        (send enable-ctl set-value ok?)
         (set! enabled? ok?))
       
       ;; get-enabled?