Macro stepper: better error handling

svn: r7890

collects/macro-debugger/model/debug.ss

@@ -2,6 +2,7 @@
 (module debug mzscheme
   (require (lib "plt-match.ss"))
   (require "trace.ss"
+           "reductions.ss"
            "deriv-util.ss"
            "deriv-find.ss"
            "hide.ss"
@@ -10,6 +11,7 @@
            "steps.ss")
 
   (provide (all-from "trace.ss")
+           (all-from "reductions.ss")
            (all-from "deriv.ss")
            (all-from "deriv-util.ss")
            (all-from "deriv-find.ss")

collects/macro-debugger/model/reductions.ss

@@ -8,7 +8,7 @@
            "reductions-engine.ss")
 
   (provide reductions
-           reductions+definites)
+           reductions+)
 
   ;; Setup for reduction-engines
 
@@ -46,13 +46,13 @@
       (when d (add-frontier (list (wderiv-e1 d))))
       (RS-steps (reductions* d))))
 
-  ;; reductions+definites : WDeriv -> (values ReductionSequence (list-of identifier))
+  ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
-  (define (reductions+definites d)
+  (define (reductions+ d)
     (parameterize ((current-definites null)
                    (current-frontier null))
       (when d (add-frontier (list (wderiv-e1 d))))
-      (let ([rs (RS-steps (reductions* d))])
+      (let-values ([(rs stx exn) (reductions* d)])
-        (values rs (current-definites)))))
+        (values rs (current-definites) stx exn))))
 
   ;; reductions* : WDeriv -> RS(stx)
   (define (reductions* d)
@@ -421,8 +421,8 @@
       [(struct local-lift-end (decl))
        (RSadd (list (walk/mono decl 'module-lift))
               RSzero)]
-      [(struct local-bind (deriv))
+      [(struct local-bind (bindrhs))
-       (reductions* deriv)]))
+       (bind-syntaxes-reductions bindrhs)]))
 
   ;; list-reductions : ListDerivation -> (RS Stxs)
   (define (list-reductions ld)

collects/macro-debugger/model/trace.ss

@@ -3,40 +3,57 @@
   (require (lib "lex.ss" "parser-tools"))
   (require "deriv.ss"
            "deriv-parser.ss"
-           "deriv-tokens.ss"
+           "deriv-tokens.ss")
-           "reductions.ss")
 
-  (provide trace-verbose?
+  (provide trace
-           trace
+           trace*
            trace/result
-           trace+reductions
+           trace-verbose?
-           current-expand-observe
+           events->token-generator
-           (all-from "reductions.ss"))
+           current-expand-observe)
 
   (define current-expand-observe
     (dynamic-require ''#%expobs 'current-expand-observe))
 
   (define trace-verbose? (make-parameter #f))
 
-  ;; trace : syntax -> Derivation
+  ;; trace : stx -> Deriv
   (define (trace stx)
-    (let-values ([(result tracer) (expand+tracer stx expand)])
+    (let-values ([(result events derivp) (trace* stx expand)])
-      (parse-derivation tracer)))
+      (force derivp)))
 
-  ;; trace/result : syntax -> (values syntax/exn Derivation)
+  ;; trace/result : stx -> stx/exn Deriv
   (define (trace/result stx)
-    (let-values ([(result tracer) (expand+tracer stx expand)])
+    (let-values ([(result events derivp) (trace* stx expand)])
       (values result
-              (parse-derivation tracer))))
+              (force derivp))))
 
-  ;; trace+reductions : syntax -> ReductionSequence
+  ;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
-  (define (trace+reductions stx)
+  (define (trace* stx expander)
-    (reductions (trace stx)))
+    (let-values ([(result events) (expand/events stx expander)])
+      (values result
+              events
+              (delay (parse-derivation
+                      (events->token-generator events))))))
 
-  ;; expand+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event))
+  ;; events->token-generator : (list-of event) -> (-> token)
-  (define (expand+tracer sexpr expander)
+  (define (events->token-generator events)
-    (let* ([events null]
+    (let ([pos 0])
-           [pos 0])
+      (lambda ()
+        (define sig+val (car events))
+        (set! events (cdr events))
+        (let* ([sig (car sig+val)]
+               [val (cdr sig+val)]
+               [t (tokenize sig val pos)])
+          (when (trace-verbose?)
+            (printf "~s: ~s~n" pos
+                    (token-name (position-token-token t))))
+          (set! pos (add1 pos))
+          t))))
+
+  ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
+  (define (expand/events sexpr expander)
+    (let ([events null])
       (define (add! x)
         (set! events (cons x events)))
       (parameterize ((current-expand-observe
@@ -50,19 +67,7 @@
                                   (add! (cons 'error exn))
                                   exn)])
                  (expander sexpr))])
-          (add! (cons 'EOF pos))
+          (add! (cons 'EOF #f))
           (values result
-                  (let ([events (reverse events)])
+                  (reverse events))))))
-                    (lambda ()
-                      (define sig+val (car events))
-                      (set! events (cdr events))
-                      (let* ([sig (car sig+val)]
-                             [val (cdr sig+val)]
-                             [t (tokenize sig val pos)])
-                        (when (trace-verbose?)
-                          (printf "~s: ~s~n" pos
-                                  (token-name (position-token-token t))))
-                        (set! pos (add1 pos))
-                        t))))))))
-
   )

collects/macro-debugger/stepper-text.ss

@@ -3,6 +3,7 @@
   (require (lib "list.ss")
            (lib "pretty.ss")
            "model/trace.ss"
+           "model/reductions.ss"
            "model/steps.ss"
            "model/hide.ss"
            "model/hiding-policies.ss"

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

@@ -48,6 +48,7 @@
              (editor -text)
              (widget this)))
 
+      (send -text set-styles-sticky #f)
       (send -text lock #t)
 
       (send -split-panel set-percentages 
@@ -92,6 +93,14 @@
         (with-unlock -text
           (send -text insert text)))
 
+      (define/public (add-clickback text handler)
+        (with-unlock -text
+          (let ([a (send -text last-position)])
+            (send -text insert text)
+            (let ([b (send -text last-position)])
+              (send -text set-clickback a b handler)
+              (send -text change-style clickback-style a b)))))
+
       (define/public add-syntax
         (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
                         hi2-color [hi2-stxs null])
@@ -185,6 +194,11 @@
       (super-new)
       (setup-keymap)))
 
+  (define clickback-style
+    (let ([sd (new style-delta%)])
+      (send sd set-delta 'change-toggle-underline)
+      (send sd set-delta-foreground "blue")
+      sd))
 
   ;; Specialized classes for widget
 

collects/macro-debugger/tool.ss

@@ -9,7 +9,11 @@
            (lib "tool.ss" "drscheme")
            (lib "bitmap-label.ss" "mrlib")
            (lib "string-constant.ss" "string-constants")
-           "view/drscheme-ext.ss")
+           "model/trace.ss"
+           "model/deriv.ss"
+           "model/deriv-util.ss"
+           "view/frame.ss"
+           "view/prefs.ss")
 
   (provide tool@
            language/macro-stepper<%>)
@@ -18,7 +22,24 @@
     (interface ()
       enable-macro-stepper?))
 
-  (define current-expand-observe (dynamic-require ''#%expobs 'current-expand-observe))
+  (define (ext-macro-stepper-frame-mixin %)
+    (class %
+      (define/override (get-macro-stepper-widget%)
+        (ext-macro-stepper-widget-mixin
+         (super get-macro-stepper-widget%)))
+      (super-new)))
+
+  (define (ext-macro-stepper-widget-mixin %)
+    (class %
+      (super-new)
+      (define/override (get-preprocess-deriv)
+        get-original-part)))
+
+  (define macro-stepper-frame%
+    (ext-macro-stepper-frame-mixin
+     (macro-stepper-frame-mixin
+      (frame:standard-menus-mixin
+       frame:basic%))))
 
   (define tool@
     (unit (import drscheme:tool^)
@@ -129,7 +150,9 @@
           (define/override (reset-console)
             (super reset-console)
             (when current-stepper
+              #;(message-box "obsoleting stepper" "before" #f '(ok))
               (send current-stepper add-obsoleted-warning)
+              #;(message-box "obsoleting stepper" "after" #f '(ok))
               (set! current-stepper #f))
             (run-in-evaluation-thread
              (lambda ()
@@ -150,13 +173,13 @@
           (define/private (make-handlers original-eval-handler original-module-name-resolver)
             (let* ([filename (send (send (get-top-level-window) get-definitions-text)
                                    get-filename/untitled-name)]
-                   [stepper (delay (make-stepper filename))]
+                   [stepperp (delay (make-stepper filename))]
                    [debugging? debugging?])
               (values
                (lambda (expr)
                  (if (and debugging? (syntax? expr))
-                     (let-values ([(e-expr deriv) (trace/result expr)])
+                     (let-values ([(e-expr events derivp) (trace* expr expand)])
-                       (show-deriv deriv stepper)
+                       (show-deriv stepperp events)
                        (if (syntax? e-expr)
                            (parameterize ((current-eval original-eval-handler))
                              (original-eval-handler e-expr))
@@ -175,11 +198,11 @@
                          (set! debugging? saved-debugging?)
                          (when eo (current-expand-observe eo)))))))))
 
-          (define/private (show-deriv deriv stepper-promise)
+          (define/private (show-deriv stepperp events)
             (parameterize ([current-eventspace drscheme-eventspace])
               (queue-callback
                (lambda ()
-                 (show-deriv/orig-parts deriv stepper-promise)))))
+                 (send (force stepperp) add-trace events)))))
           ))
 
       ;; Borrowed from mztake/debug-tool.ss
@@ -191,7 +214,7 @@
           (and (equal? main-group (string-constant legacy-languages))
                (or (member second 
                            (list (string-constant r5rs-lang-name)
-                                 "(module ...)"
+                                 "Module"
                                  "Swindle"))
                    (member third
                            (list (string-constant mzscheme-w/debug)
@@ -209,4 +232,46 @@
       (drscheme:get/extend:extend-tab
        macro-debugger-tab-mixin)
 
-      )))
+      ))
+
+  ;; 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 (get-original-part deriv)
+    ;; adjust-deriv/lift : Derivation -> (list-of Derivation)
+    (define (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 (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)
+                                (module-identifier=? x #'#%top-interaction))
+                              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])))
+    (let ([deriv* (adjust-deriv/lift deriv)])
+      deriv*))
+
+  )

collects/macro-debugger/view/debug-format.ss

@@ -0,0 +1,55 @@
+
+(module debug-format mzscheme
+  (require (lib "pretty.ss"))
+  (provide write-debug-file
+           load-debug-file)
+
+
+  (define (write-debug-file file exn events)
+    (with-output-to-file file
+      (lambda ()
+        (write `(list ,@(map (lambda (e) (serialize-datum e)) events)))
+        (newline)
+        (write (exn-message exn))
+        (newline)
+        (write (map serialize-context-frame
+                    (continuation-mark-set->context
+                     (exn-continuation-marks exn)))))
+      'replace))
+
+  (define (serialize-datum d)
+    (cond [(number? d) `(quote ,d)]
+          [(boolean? d) `(quote ,d)]
+          [(symbol? d) `(quote ,d)]
+          [(string? d) `(quote ,d)]
+          [(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
+          [(null? d) '()]
+          [(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
+          [(syntax? d) `(datum->syntax-object #f ',(syntax-object->datum d))]
+          #;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
+          [else (error 'serialize-datum "got ~s" d)]))
+
+  (define (serialize-context-frame frame)
+    (cons (car frame)
+          (if (cdr frame)
+              (serialize-srcloc (cdr frame))
+              null)))
+
+  (define (serialize-srcloc s)
+    (list (let ([src (srcloc-source s)])
+            (cond [(path? src) (path->string src)]
+                  [(string? src) src]
+                  [else '?]))
+          (srcloc-line s)
+          (srcloc-column s)))
+
+  (define (load-debug-file file)
+    (parameterize ((read-accept-compiled #t))
+      (with-input-from-file file
+        (lambda ()
+          (let* ([events-expr (read)]
+                 [exnmsg (read)]
+                 [ctx (read)])
+            (let ([events (eval events-expr)])
+              (values events exnmsg ctx)))))))
+  )

collects/macro-debugger/view/debug.ss

@@ -0,0 +1,14 @@
+
+(module debug mzscheme
+  (require (lib "pretty.ss")
+           "debug-format.ss"
+           "view.ss")
+  (provide debug-file)
+
+  (define (debug-file file)
+    (let-values ([(events msg ctx) (load-debug-file file)])
+      (pretty-print msg)
+      (pretty-print ctx)
+      (go/trace events)))
+  
+  )

collects/macro-debugger/view/frame.ss

@@ -85,8 +85,11 @@
              (stretchable-height #f)
              (style '(deleted))))
 
+      (define/public (get-macro-stepper-widget%)
+        macro-stepper-widget%)
+
       (define widget
-        (new macro-stepper-widget%
+        (new (get-macro-stepper-widget%)
              (parent (get-area-container))
              (config config)))
 

collects/macro-debugger/view/stepper.ss

@@ -12,49 +12,20 @@
            "extensions.ss"
            "warning.ss"
            "hiding-panel.ss"
+           "term-record.ss"
            (prefix s: "../syntax-browser/widget.ss")
            (prefix s: "../syntax-browser/params.ss")
            "../model/deriv.ss"
            "../model/deriv-util.ss"
            "../model/deriv-find.ss"
            "../model/trace.ss"
+           "../model/reductions.ss"
            "../model/hide.ss"
            "../model/steps.ss"
            "cursor.ss"
            "util.ss")
   (provide macro-stepper-widget%)
 
-  ;; Struct for one-by-one stepping
-
-  (define-struct (prestep protostep) (foci1 e1))
-  (define-struct (poststep protostep) (foci2 e2))
-
-  (define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
-  (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
-
-  ;; TermRecords
-
-  (define-struct trec (deriv synth-deriv estx raw-steps steps definites warnings) #f)
-
-  (define (new-trec deriv)
-    (make-trec deriv #f #f #f #f #f null))
-  
-  ;; trec:invalidate-synth! : TermRecord -> void
-  ;; Invalidates cached parts that depend on macro-hiding policy
-  (define (trec:invalidate-synth! trec)
-    (set-trec-synth-deriv! trec #f)
-    (set-trec-estx! trec #f)
-    (set-trec-raw-steps! trec #f)
-    (set-trec-definites! trec #f)
-    (set-trec-warnings! trec null)
-    (trec:invalidate-steps! trec))
-
-  ;; trec:invalidate-steps! : TermRecord -> void
-  ;; Invalidates cached parts that depend on reductions config
-  (define (trec:invalidate-steps! trec)
-    (set-trec-steps! trec #f))
-
-
   ;; Macro Stepper
 
   ;; macro-stepper-widget%
@@ -65,48 +36,50 @@
 
       ;; Terms
 
+      ;; all-terms : (list-of TermRecord)
+      ;; (Reversed)
+      (define all-terms null)
+
       ;; terms : (Cursor-of TermRecord)
+      ;; Contains visible terms of all-terms
       (define terms (cursor:new null))
 
       ;; focused-term : -> TermRecord or #f
       (define (focused-term)
-        (let ([term (cursor:next terms)])
+        (cursor:next terms))
-          (when term (recache term))
-          term))
 
-      ;; focused-steps : -> (Cursor-of Step) or #f
+      ;; add-deriv : Deriv -> void
-      (define/private (focused-steps)
-        (let ([term (focused-term)])
-          (and term 
-               (cursor? (trec-steps term))
-               (trec-steps term))))
-
-      ;; alpha-table : module-identifier-mapping[identifier => identifier]
-      (define alpha-table (make-module-identifier-mapping))
-
-      ;; saved-position : number/#f
-      (define saved-position #f)
-
-      ;; add-deriv : Derivation -> void
       (define/public (add-deriv d)
-        (let ([needs-display? (cursor:at-end? terms)])
+        (let ([trec (new term-record% (stepper this) (raw-deriv d))])
-          (for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id))
+          (add trec)))
-                    (extract-all-fresh-names d))
+
-          (cursor:add-to-end! terms (list (new-trec d)))
+      ;; add-trace : (list-of event) -> void
+      (define/public (add-trace events)
+        (let ([trec (new term-record% (stepper this) (events events))])
+          (add trec)))
+
+      ;; add : TermRecord -> void
+      (define/public (add trec)
+        (set! all-terms (cons trec all-terms))
+        (let ([display-new-term? (cursor:at-end? terms)]
+              [invisible? (send trec get-deriv-hidden?)])
+          (unless invisible?
+            (cursor:add-to-end! terms (list trec))
             (trim-navigator)
-          (if needs-display?
+            (if display-new-term?
-              (refresh/move)
+                (refresh)
-              (update))))
+                (update)))))
 
       ;; remove-current-term : -> void
       (define/public (remove-current-term)
         (cursor:remove-current! terms)
         (trim-navigator)
-        (refresh/move))
+        (refresh))
 
       (define/public (get-config) config)
       (define/public (get-controller) sbc)
       (define/public (get-view) sbview)
+      (define/public (get-warnings-area) warnings-area)
       (define/public (get-macro-hiding-prefs) macro-hiding-prefs)
 
       (define/public (reset-primary-partition)
@@ -133,7 +106,7 @@
              (alignment '(left center))
              (style '(deleted))))
       
-      (define warnings (new stepper-warnings% (parent area)))
+      (define warnings-area (new stepper-warnings% (parent area)))
       
       (define sbview (new stepper-syntax-widget% 
                           (parent area)
@@ -216,109 +189,41 @@
                     (list navigator extra-navigator)
                     (list navigator)))))
 
-      ;; Navigate
+      ;; Navigation
 
       (define/public-final (at-start?)
-        (cursor:at-start? (focused-steps)))
+        (send (focused-term) at-start?))
       (define/public-final (at-end?)
-        (cursor:at-end? (focused-steps)))
+        (send (focused-term) at-end?))
 
       (define/public-final (navigate-to-start)
-        (cursor:move-to-start (focused-steps))
+        (send (focused-term) navigate-to-start)
         (update/save-position))
       (define/public-final (navigate-to-end)
-        (cursor:move-to-end (focused-steps))
+        (send (focused-term) navigate-to-end)
         (update/save-position))
       (define/public-final (navigate-previous)
-        (cursor:move-prev (focused-steps))
+        (send (focused-term) navigate-previous)
         (update/save-position))
       (define/public-final (navigate-next)
-        (cursor:move-next (focused-steps))
+        (send (focused-term) navigate-next)
         (update/save-position))
 
-      (define/public-final (navigate-forward/count n)
-        (unless (integer? n)
-          (raise-type-error 'navigate-forward/count "integer" n))
-        (cond [(zero? n)
-               (update/save-position)]
-              [(positive? n)
-               (cursor:move-next (focused-steps))
-               (navigate-forward/count (sub1 n))]
-              [(negative? n)
-               (cursor:move-prev (focused-steps))
-               (navigate-forward/count (add1 n))]))
-
-      (define/public-final (navigate-forward/pred p)
-        (let* ([cursor (focused-steps)]
-               [steps (and cursor (cursor:suffix->list cursor))]
-               [pred (lambda (s)
-                       (and (rewrite-step? s)
-                            (ormap p (step-foci1 s))
-                            s))]
-               [step (ormap pred steps)])
-          (unless step
-            (error 'navigate-forward/pred "no step matching predicate"))
-          (cursor:skip-to cursor step)
-          (update/save-position)))
-
       (define/public-final (navigate-up)
+        (when (focused-term)
+          (send (focused-term) on-lose-focus))
         (cursor:move-prev terms)
         (refresh/move))
       (define/public-final (navigate-down)
+        (when (focused-term)
+          (send (focused-term) on-lose-focus))
         (cursor:move-next terms)
         (refresh/move))
 
-      (define/public-final (navigate-down/pred p)
+      ;; Update
-        (let* ([termlist (cursor:suffix->list terms)]
-               [pred (lambda (trec)
-                       (and (p (wderiv-e1 (trec-deriv trec)))
-                            trec))]
-               [term (ormap pred termlist)])
-          (unless term
-            (error 'navigate-down/pred "no term matching predicate"))
-          (cursor:skip-to terms term)
-          (refresh/move)))
-
-      ;; insert-step-separator : string -> void
-      (define/private (insert-step-separator text)
-        (send sbview add-text "\n    ")
-        (send sbview add-text
-              (make-object image-snip% 
-                           (build-path (collection-path "icons")
-                                       "red-arrow.bmp")))
-        (send sbview add-text "  ")
-        (send sbview add-text text)
-        (send sbview add-text "\n\n"))
-
-      ;; insert-as-separator : string -> void
-      (define/private (insert-as-separator text)
-        (send sbview add-text "\n    ")
-        (send sbview add-text text)
-        (send sbview add-text "\n\n"))
-
-      ;; insert-step-separator/small : string -> void
-      (define/private (insert-step-separator/small text)
-        (send sbview add-text "    ")
-        (send sbview add-text
-              (make-object image-snip% 
-                           (build-path (collection-path "icons")
-                                       "red-arrow.bmp")))
-        (send sbview add-text "  ")
-        (send sbview add-text text)
-        (send sbview add-text "\n\n"))
-
-      ;; update/preserve-view : -> void
-      (define/public (update/preserve-view)
-        (define text (send sbview get-text))
-        (define start-box (box 0))
-        (define end-box (box 0))
-        (send text get-visible-position-range start-box end-box)
-        (update)
-        (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
 
       ;; update/save-position : -> void
       (define/private (update/save-position)
-        (save-position)
         (update/preserve-lines-view))
 
       ;; update/preserve-lines-view : -> void
@@ -334,6 +239,15 @@
               (send text line-start-position (unbox end-box))
               'start))
       
+      ;; update/preserve-view : -> void
+      (define/public (update/preserve-view)
+        (define text (send sbview get-text))
+        (define start-box (box 0))
+        (define end-box (box 0))
+        (send text get-visible-position-range start-box end-box)
+        (update)
+        (send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
+
       ;; update : -> void
       ;; Updates the terms in the syntax browser to the current step
       (define/private (update)
@@ -360,172 +274,29 @@
       ;; update:show-prefix : -> void
       (define/private (update:show-prefix)
         ;; Show the final terms from the cached synth'd derivs
-        (for-each (lambda (trec)
+        (for-each (lambda (trec) (send trec display-final-term))
-                    (recache trec)
-                    (let ([e2 (trec-estx trec)]
-                          [definites
-                            (if (pair? (trec-definites trec))
-                                (trec-definites trec)
-                                null)])
-                      (if e2
-                          (send sbview add-syntax e2
-                                #:alpha-table alpha-table
-                                #:definites definites)
-                          (send sbview add-text "Error\n"))))
                   (cursor:prefix->list terms)))
 
       ;; update:show-current-step : -> void
       (define/private (update:show-current-step)
-        (define steps (focused-steps))
         (when (focused-term)
-          (when steps
+          (send (focused-term) display-step)))
-            (let ([step (cursor:next steps)])
-              (cond [(step? step)
-                     (update:show-step step)]
-                    [(mono? step)
-                     (update:show-mono step)]
-                    [(misstep? step)
-                     (update:show-misstep step)]
-                    [(prestep? step)
-                     (update:show-prestep step)]
-                    [(poststep? step)
-                     (update:show-poststep step)]
-                    [(not step)
-                     (update:show-final (focused-term))])))
-          (unless steps
-            (send sbview add-text
-                  "Internal error computing reductions. Original term:\n")
-            (send sbview add-syntax
-                  (wderiv-e1 (trec-deriv (focused-term)))))))
-
-      ;; update:show-lctx : Step -> void
-      (define/private (update:show-lctx step)
-        (define lctx (protostep-lctx step))
-        (when (pair? lctx)
-          (send sbview add-text "\n")
-          (for-each (lambda (bf)
-                      (send sbview add-text 
-                            "while executing macro transformer in:\n")
-                      (insert-syntax/redex (bigframe-term bf)
-                                           (bigframe-foci bf)
-                                           (protostep-definites step)
-                                           (protostep-frontier step)))
-                    (reverse lctx))))
-
-      ;; update:separator : Step -> void
-      (define/private (update:separator step)
-        (if (not (mono? step))
-            (insert-step-separator (step-type->string (protostep-type step)))
-            (insert-as-separator (step-type->string (protostep-type step)))))
-
-      ;; update:separator/small : Step -> void
-      (define/private (update:separator/small step)
-        (insert-step-separator/small
-         (step-type->string (protostep-type step))))
-      
-      ;; update:show-step : Step -> void
-      (define/private (update:show-step step)
-        (insert-syntax/redex (step-term1 step)
-                             (step-foci1 step)
-                             (protostep-definites step)
-                             (protostep-frontier step))
-        (update:separator step)
-        (insert-syntax/contractum (step-term2 step)
-                                  (step-foci2 step)
-                                  (protostep-definites step)
-                                  (protostep-frontier step))
-        (update:show-lctx step))
-
-      ;; update:show-mono : Step -> void
-      (define/private (update:show-mono step)
-        (update:separator step)
-        (insert-syntax/redex (mono-term1 step)
-                             null
-                             (protostep-definites step)
-                             (protostep-frontier step))
-        (update:show-lctx step))
-
-      ;; update:show-prestep : Step -> void
-      (define/private (update:show-prestep step)
-        (update:separator/small step)
-        (insert-syntax/redex (prestep-term1 step)
-                             (prestep-foci1 step)
-                             (protostep-definites step)
-                             (protostep-frontier step))
-        (update:show-lctx step))
-
-      ;; update:show-poststep : Step -> void
-      (define/private (update:show-poststep step)
-        (update:separator/small step)
-        (insert-syntax/contractum (poststep-term2 step)
-                                  (poststep-foci2 step)
-                                  (protostep-definites step)
-                                  (protostep-frontier step))
-        (update:show-lctx step))
-
-      ;; update:show-misstep : Step -> void
-      (define/private (update:show-misstep step)
-        (insert-syntax/redex (misstep-term1 step)
-                             (misstep-foci1 step)
-                             (protostep-definites step)
-                             (protostep-frontier step))
-        (update:separator step)
-        (send sbview add-text (exn-message (misstep-exn step)))
-        (send sbview add-text "\n")
-        (when (exn:fail:syntax? (misstep-exn step))
-          (for-each (lambda (e) (send sbview add-syntax e
-                                      #:alpha-table alpha-table
-                                      #:definites (protostep-definites step)))
-                    (exn:fail:syntax-exprs (misstep-exn step))))
-        (update:show-lctx step))
-
-      ;; update:show-final : TermRecord -> void
-      (define/private (update:show-final trec)
-        (define result (trec-estx trec))
-        (when result
-          (send sbview add-text "Expansion finished\n")
-          (send sbview add-syntax result
-                #:alpha-table alpha-table
-                #:definites (let ([definites (trec-definites trec)])
-                              (if (pair? definites) definites null))))
-        (unless result
-          (send sbview add-text "Error\n")))
 
       ;; update:show-suffix : -> void
       (define/private (update:show-suffix)
         (let ([suffix0 (cursor:suffix->list terms)])
           (when (pair? suffix0)
             (for-each (lambda (trec)
-                        (send sbview add-syntax
+                        (send trec display-initial-term))
-                              (wderiv-e1 (trec-deriv trec))
-                              #:alpha-table alpha-table))
                       (cdr suffix0)))))
 
-      ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
-      (define/private (insert-syntax/color stx foci definites frontier hi-color)
-        (send sbview add-syntax stx
-              #:definites definites
-              #:alpha-table alpha-table
-              #:hi-color hi-color
-              #:hi-stxs (if (send config get-highlight-foci?) foci null)
-              #:hi2-color "WhiteSmoke"
-              #:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
-
-      ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
-      (define/private (insert-syntax/redex stx foci definites frontier)
-        (insert-syntax/color stx foci definites frontier "MistyRose"))
-
-      ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
-      (define/private (insert-syntax/contractum stx foci definites frontier)
-        (insert-syntax/color stx foci definites frontier "LightCyan"))
-
       ;; enable/disable-buttons : -> void
       (define/private (enable/disable-buttons)
-        (define steps (focused-steps))
+        (define term (focused-term))
-        (send nav:start enable (and steps (cursor:has-prev? steps)))
+        (send nav:start enable (and term (send term has-prev?)))
-        (send nav:previous enable (and steps (cursor:has-prev? steps)))
+        (send nav:previous enable (and term (send term has-prev?)))
-        (send nav:next enable (and steps (cursor:has-next? steps)))
+        (send nav:next enable (and term (send term has-next?)))
-        (send nav:end enable (and steps (cursor:has-next? steps)))
+        (send nav:end enable (and term (send term has-next?)))
         (send nav:up enable (cursor:has-prev? terms))
         (send nav:down enable (cursor:has-next? terms)))
 
@@ -534,78 +305,29 @@
       ;; refresh/resynth : -> void
       ;; Macro hiding policy has changed; invalidate cached parts of trec
       (define/public (refresh/resynth)
-        (for-each trec:invalidate-synth! (cursor->list terms))
+        (for-each (lambda (trec) (send trec invalidate-synth!))
+                  (cursor->list terms))
         (refresh))
 
       ;; refresh/re-reduce : -> void
       ;; Reduction config has changed; invalidate cached parts of trec
       (define/private (refresh/re-reduce)
-        (for-each trec:invalidate-steps! (cursor->list terms))
+        (for-each (lambda (trec) (send trec invalidate-steps!))
+                  (cursor->list terms))
         (refresh))
 
       ;; refresh/move : -> void
       ;; Moving between terms; clear the saved position
       (define/private (refresh/move)
-        (clear-saved-position)
         (refresh))
 
       ;; refresh : -> void
       (define/public (refresh)
-        (restore-position)
+        (send warnings-area clear)
-        (display-warnings (focused-term))
+        (when (focused-term)
+          (send (focused-term) on-get-focus))
         (update))
 
-      ;; display-warnings : TermRecord -> void
-      (define/private (display-warnings trec)
-        (send warnings clear)
-        (when trec
-          (unless (send config get-suppress-warnings?)
-            (for-each (lambda (tag+args)
-                        (let ([tag (car tag+args)]
-                              [args (cdr tag+args)])
-                          (send warnings add-warning tag args)))
-                      (trec-warnings trec)))))
-      
-      ;; recache : TermRecord -> void
-      (define/private (recache trec)
-        (unless (trec-synth-deriv trec)
-          (set-trec-warnings! trec null)
-          (with-handlers ([(lambda (e) #t)
-                           (lambda (e)
-                             (handle-recache-error e 'macro-hiding)
-                             (set-trec-synth-deriv! trec 'error)
-                             (set-trec-estx! trec (wderiv-e2 (trec-deriv trec))))])
-            (recache-synth trec)))
-        (unless (trec-raw-steps trec)
-          (with-handlers ([(lambda (e) #t)
-                           (lambda (e)
-                             (handle-recache-error e 'reductions)
-                             (set-trec-raw-steps! trec 'error)
-                             (set-trec-definites! trec 'error))])
-            (let-values ([(steps definites)
-                          (reductions+definites
-                           (or (trec-synth-deriv trec) (trec-deriv trec)))])
-              (set-trec-raw-steps! trec steps)
-              (set-trec-definites! trec definites))))
-        (unless (trec-steps trec)
-          (with-handlers ([(lambda (e) #t)
-                           (lambda (e)
-                             (handle-recache-error e 'special-reductions)
-                             (set-trec-steps! trec 'error))])
-            (set-trec-steps!
-             trec
-             (let ([raw-steps (trec-raw-steps trec)])
-               (if (eq? raw-steps 'error)
-                   'error
-                   (let ([filtered-steps 
-                          (if (send config get-show-rename-steps?)
-                              raw-steps
-                              (filter (lambda (x) (not (rename-step? x))) raw-steps))])
-                     (cursor:new
-                      (if (send config get-one-by-one?)
-                          (reduce:one-by-one filtered-steps)
-                          filtered-steps)))))))))
-
       ;; delayed-recache-errors : (list-of (cons exn string))
       (define delayed-recache-errors null)
 
@@ -636,92 +358,17 @@
                    (set! delayed-recache-errors null)))))
             (raise exn)))
 
-      ;; update-saved-position : num -> void
-      (define/private (update-saved-position pos)
-        (when pos (set! saved-position pos)))
-
-      ;; clear-saved-position : -> void
-      (define/private (clear-saved-position)
-        (set! saved-position #f))
-
-      ;; save-position : -> void
-      (define/private (save-position)
-        (when (cursor? (focused-steps))
-          (let ([step (cursor:next (focused-steps))])
-            (cond [(not step)
-                   ;; At end; go to the end when restored
-                   (update-saved-position +inf.0)]
-                  [(protostep? step)
-                   (update-saved-position
-                    (extract-protostep-seq step))]))))
-
-      ;; restore-position : number -> void
-      (define/private (restore-position)
-        (define steps (focused-steps))
-        (define (advance)
-          (let ([step (cursor:next steps)])
-            (cond [(not step)
-                   ;; At end; stop
-                   (void)]
-                  [(protostep? step)
-                   (let ([step-pos (extract-protostep-seq step)])
-                     (cond [(not step-pos)
-                            (cursor:move-next steps)
-                            (advance)]
-                           [(< step-pos saved-position)
-                            (cursor:move-next steps)
-                            (advance)]
-                           [else (void)]))])))
-        (when saved-position
-          (when steps
-            (advance))))
-
-      (define/private (extract-protostep-seq step)
-        (match (protostep-deriv step)
-          [(Wrap mrule (_ _ (Wrap transformation (_ _ _ _ _ _ _ _ seq)) _))
-           seq]
-          [else #f]))
-
-      ;; recache-synth : TermRecord -> void
-      (define/private (recache-synth trec)
-        (define deriv (trec-deriv trec))
-        (define-values (synth-deriv estx)
-          (let ([show-macro? (get-show-macro?)])
-            (if show-macro?
-                (parameterize ((current-hiding-warning-handler
-                                (lambda (tag args)
-                                  (set-trec-warnings!
-                                   trec
-                                   (cons (cons tag args)
-                                         (trec-warnings trec)))))
-                               (force-letrec-transformation
-                                (send config get-force-letrec-transformation?)))
-                  (hide/policy deriv show-macro?))
-                (values deriv (wderiv-e2 deriv)))))
-        (set-trec-synth-deriv! trec synth-deriv)
-        (set-trec-estx! trec estx))
-      
-      (define/private (reduce:one-by-one rs)
-        (let loop ([rs rs])
-          (match rs
-            [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs)
-             (list* (make-prestep d l "Find redex" c df fr redex e1)
-                    (make-poststep d l t c df fr contractum e2)
-                    (loop rs))]
-            [(cons (struct misstep (d l t c df fr redex e1 exn)) rs)
-             (list* (make-prestep d l "Find redex" c df fr redex e1)
-                    (make-misstep d l t c df fr redex e1 exn)
-                    (loop rs))]
-            ['()
-             null])))
-      
       (define/private (foci x) (if (list? x) x (list x)))
 
       ;; Hiding policy
       
-      (define/private (get-show-macro?)
+      (define/public (get-show-macro?)
         (send macro-hiding-prefs get-policy))
 
+      ;; Derivation pre-processing
+
+      (define/public (get-preprocess-deriv) (lambda (d) d))
+
       ;; Initialization
 
       (super-new)

collects/macro-debugger/view/term-record.ss

@@ -0,0 +1,542 @@
+
+(module term-record mzscheme
+  (require (lib "class.ss")
+           (lib "unit.ss")
+           (lib "list.ss")
+           (lib "plt-match.ss")
+           (lib "mred.ss" "mred")
+           (lib "framework.ss" "framework")
+           (lib "boundmap.ss" "syntax")
+           "interfaces.ss"
+           "prefs.ss"
+           "extensions.ss"
+           "warning.ss"
+           "hiding-panel.ss"
+           (prefix s: "../syntax-browser/widget.ss")
+           (prefix s: "../syntax-browser/params.ss")
+           "../model/deriv.ss"
+           "../model/deriv-util.ss"
+           "../model/deriv-find.ss"
+           "../model/deriv-parser.ss"
+           "../model/trace.ss"
+           "../model/reductions.ss"
+           "../model/hide.ss"
+           "../model/steps.ss"
+           "debug-format.ss"
+           "cursor.ss"
+           "util.ss")
+
+  (provide term-record%)
+
+  ;; Struct for one-by-one stepping
+
+  (define-struct (prestep protostep) (foci1 e1))
+  (define-struct (poststep protostep) (foci2 e2))
+
+  (define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
+  (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
+
+  ;; TermRecords
+
+  (define term-record%
+    (class object%
+      (init-field stepper)
+      (init-field [events #f])
+
+      (define config (send stepper get-config))
+      (define sbview (send stepper get-view))
+
+      (init-field [raw-deriv #f])
+      (define raw-deriv-oops #f)
+
+      (define deriv #f)
+      (define deriv-hidden? #f)
+      (define binders #f)
+
+      (define synth-deriv #f)
+      (define synth-warnings null)
+      (define synth-estx #f)
+      (define synth-oops #f)
+
+      (define raw-steps #f)
+      (define raw-steps-estx #f)
+      (define definites #f)
+      (define error #f)
+      (define raw-steps-oops #f)
+
+      (define steps #f)
+
+      (define steps-position #f)
+
+      (super-new)
+
+      (define-syntax define-guarded-getters
+        (syntax-rules ()
+          [(define-guarded-getters guard (method expr) ...)
+           (begin (define/public (method) guard expr) ...)]))
+
+      (define-guarded-getters (recache-deriv!)
+        [get-deriv deriv]
+        [get-deriv-hidden? deriv-hidden?]
+        [get-binders binders])
+      (define-guarded-getters (recache-synth!)
+        [get-synth-deriv synth-deriv]
+        [get-synth-warnings synth-warnings]
+        [get-synth-estx synth-estx]
+        [get-synth-oops synth-oops])
+      (define-guarded-getters (recache-raw-steps!)
+        [get-definites definites]
+        [get-error error]
+        [get-raw-steps-oops raw-steps-oops])
+      (define-guarded-getters (recache-steps!)
+        [get-steps steps])
+
+      ;; invalidate-steps! : -> void
+      ;; Invalidates cached parts that depend on reductions config
+      (define/public (invalidate-steps!)
+        (set! steps #f))
+
+      ;; invalidate-raw-steps! : -> void
+      (define/public (invalidate-raw-steps!)
+        (invalidate-steps!)
+        (set! raw-steps #f)
+        (set! raw-steps-estx #f)
+        (set! definites #f)
+        (set! error #f)
+        (set! raw-steps-oops #f))
+
+      ;; invalidate-synth! : -> void
+      ;; Invalidates cached parts that depend on macro-hiding policy
+      (define/public (invalidate-synth!)
+        (invalidate-raw-steps!)
+        (set! synth-deriv #f)
+        (set! synth-warnings null)
+        (set! synth-oops #f)
+        (set! synth-estx #f))
+
+      ;; invalidate-deriv! : -> void
+      (define/public (invalidate-deriv!)
+        (invalidate-synth!)
+        (set! deriv #f)
+        (set! deriv-hidden? #f)
+        (set! binders #f))
+
+      ;; recache! : -> void
+      (define/public (recache!)
+        (recache-steps!))
+
+      ;; recache-raw-deriv! : -> void
+      (define/private (recache-raw-deriv!)
+        (unless (or raw-deriv raw-deriv-oops)
+          (with-handlers ([(lambda (e) #t)
+                           (lambda (e)
+                             (set! raw-deriv-oops e))])
+            (set! raw-deriv
+                  (parse-derivation
+                   (events->token-generator events))))))
+
+      ;; recache-deriv! : -> void
+      (define/private (recache-deriv!)
+        (unless (or deriv deriv-hidden?)
+          (recache-raw-deriv!)
+          (when raw-deriv
+            (let ([process (send stepper get-preprocess-deriv)])
+              (let ([d (process raw-deriv)])
+                (when (not d)
+                  (set! deriv-hidden? #t))
+                (when d
+                  (let ([alpha-table (make-module-identifier-mapping)])
+                    (for-each (lambda (id)
+                                (module-identifier-mapping-put! alpha-table id id))
+                              (extract-all-fresh-names d))
+                    (set! deriv d)
+                    (set! binders alpha-table))))))))
+
+      ;; recache-synth! : -> void
+      (define/private (recache-synth!)
+        (unless (or synth-deriv synth-oops)
+          (recache-deriv!)
+          (when deriv
+            (set! synth-warnings null)
+            (let ([show-macro? (send stepper get-show-macro?)]
+                  [force-letrec? (send config get-force-letrec-transformation?)])
+              (with-handlers ([(lambda (e) #t)
+                               (lambda (e)
+                                 (set! synth-oops e))])
+                (let ()
+                  (define-values (synth-deriv* estx*)
+                    (if show-macro?
+                        (parameterize ((current-hiding-warning-handler
+                                        (lambda (tag args)
+                                          (set! synth-warnings
+                                                (cons (cons tag args)
+                                                      synth-warnings))))
+                                       (force-letrec-transformation
+                                        force-letrec?))
+                          (hide/policy deriv show-macro?))
+                        (values deriv (wderiv-e2 deriv))))
+                  (set! synth-deriv synth-deriv*)
+                  (set! synth-estx estx*)))))))
+
+      ;; recache-raw-steps! : -> void
+      (define/private (recache-raw-steps!)
+        (unless (or raw-steps raw-steps-oops)
+          (recache-synth!)
+          (when synth-deriv
+            (with-handlers ([(lambda (e) #t)
+                             (lambda (e)
+                               (set! raw-steps-oops e))])
+              (let-values ([(raw-steps* definites* estx* error*)
+                            (reductions+ synth-deriv)])
+                (set! raw-steps raw-steps*)
+                (set! raw-steps-estx estx*)
+                (set! error error*)
+                (set! definites definites*))))))
+
+      ;; recache-steps! : -> void
+      (define/private (recache-steps!)
+        (unless (or steps)
+          (recache-raw-steps!)
+          (when raw-steps
+            (set! steps
+                  (and raw-steps
+                       (let* ([filtered-steps 
+                               (if (send config get-show-rename-steps?)
+                                   raw-steps
+                                   (filter (lambda (x) (not (rename-step? x)))
+                                           raw-steps))]
+                              [processed-steps
+                               (if (send config get-one-by-one?)
+                                   (reduce:one-by-one filtered-steps)
+                                   filtered-steps)])
+                         (cursor:new processed-steps))))
+            (restore-position))))
+
+      ;; reduce:one-by-one : (list-of step) -> (list-of step)
+      (define/private (reduce:one-by-one rs)
+        (let loop ([rs rs])
+          (match rs
+            [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs)
+             (list* (make-prestep d l "Find redex" c df fr redex e1)
+                    (make-poststep d l t c df fr contractum e2)
+                    (loop rs))]
+            [(cons (struct misstep (d l t c df fr redex e1 exn)) rs)
+             (list* (make-prestep d l "Find redex" c df fr redex e1)
+                    (make-misstep d l t c df fr redex e1 exn)
+                    (loop rs))]
+            ['()
+             null])))
+
+      ;; Navigation
+
+      (define/public-final (has-prev?)
+        (and (get-steps) (not (cursor:at-start? (get-steps)))))
+      (define/public-final (has-next?)
+        (and (get-steps) (not (cursor:at-end? (get-steps)))))
+
+      (define/public-final (navigate-to-start)
+        (cursor:move-to-start (get-steps))
+        (save-position))
+      (define/public-final (navigate-to-end)
+        (cursor:move-to-end (get-steps))
+        (save-position))
+      (define/public-final (navigate-previous)
+        (cursor:move-prev (get-steps))
+        (save-position))
+      (define/public-final (navigate-next)
+        (cursor:move-next (get-steps))
+        (save-position))
+
+      ;; save-position : -> void
+      (define/private (save-position)
+        (when (cursor? steps)
+          (let ([step (cursor:next steps)])
+            (cond [(not step)
+                   ;; At end; go to the end when restored
+                   (set! steps-position +inf.0)]
+                  [(protostep? step)
+                   (set! steps-position
+                         (extract-protostep-seq step))]))))
+
+      ;; restore-position : number -> void
+      (define/private (restore-position)
+        (define (seek)
+          (let ([step (cursor:next steps)])
+            (cond [(not step)
+                   ;; At end; stop
+                   (void)]
+                  [(protostep? step)
+                   (let ([step-pos (extract-protostep-seq step)])
+                     (cond [(not step-pos)
+                            (cursor:move-next steps)
+                            (seek)]
+                           [(< step-pos steps-position)
+                            (cursor:move-next steps)
+                            (seek)]
+                           [else (void)]))])))
+        (when steps-position
+          (seek)))
+
+      ;; extract-protostep-seq : step -> number/#f
+      (define/private (extract-protostep-seq step)
+        (match (protostep-deriv step)
+          [(Wrap mrule (_ _ (Wrap transformation (_ _ _ _ _ _ _ _ seq)) _))
+           seq]
+          [else #f]))
+
+      ;; Warnings display
+
+      ;; on-get-focus : -> void
+      (define/public (on-get-focus)
+        (recache-synth!)
+        (display-warnings))
+
+      ;; on-lose-focus : -> void
+      (define/public (on-lose-focus)
+        (when steps (cursor:move-to-start steps))
+        (set! steps-position #f))
+
+      ;; display-warnings : -> void
+      (define/private (display-warnings)
+        (let ([warnings-area (send stepper get-warnings-area)])
+          (unless (send config get-suppress-warnings?)
+            (for-each (lambda (tag+args)
+                        (let ([tag (car tag+args)]
+                              [args (cdr tag+args)])
+                          (send warnings-area add-warning tag args)))
+                      synth-warnings))))
+
+      ;; Rendering
+
+      ;; display-initial-term : -> void
+      (define/public (display-initial-term)
+        (add-syntax (wderiv-e1 deriv) #f null))
+
+      ;; display-final-term : -> void
+      (define/public (display-final-term)
+        (recache-synth!)
+        (cond [(syntax? synth-estx)
+               (add-syntax synth-estx binders definites)]
+              [(exn? error)
+               (add-error error)]
+              [raw-steps-oops
+               (add-internal-error "steps" raw-steps-oops #f)]
+              [synth-oops
+               (add-internal-error "hiding" synth-oops #f)]))
+
+      ;; display-step : -> void
+      (define/public (display-step)
+        (recache-steps!)
+        (cond [steps
+               (let ([step (cursor:next steps)])
+                 (if step
+                     (add-step step binders)
+                     (add-final raw-steps-estx error binders definites)))]
+              [raw-steps-oops
+               (add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))]
+              [synth-oops
+               (add-internal-error "hiding" synth-oops (wderiv-e1 deriv))]
+              [raw-deriv-oops
+               (add-internal-error "derivation" raw-deriv-oops #f)]
+              [else
+               (add-internal-error "derivation" #f)]))
+
+      (define/public (add-internal-error part exn stx)
+        (send sbview add-text
+              (if part
+                  (format "Macro stepper error (~a)" part)
+                  "Macro stepper error"))
+        (when (exn? exn)
+          (send sbview add-text " ")
+          (send sbview add-clickback "[details]"
+                (lambda _ (show-internal-error-details exn))))
+        (send sbview add-text ".  ")
+        (when stx (send sbview add-text "Original syntax:"))
+        (send sbview add-text "\n")
+        (when stx (send sbview add-syntax stx)))
+
+      (define/private (show-internal-error-details exn)
+        (case (message-box/custom "Macro stepper internal error"
+                                  "Show error or dump debugging file."
+                                  "Show error"
+                                  "Dump debugging file"
+                                  "Cancel")
+          ((1) (queue-callback
+                (lambda ()
+                  (raise exn))))
+          ((2) (queue-callback
+                (lambda ()
+                  (let ([file (put-file)])
+                    (when file
+                      (write-debug-file file exn events))))))
+          ((3 #f) (void))))
+
+      (define/public (add-error exn)
+        (send sbview add-error-text (exn-message exn))
+        (send sbview add-text "\n"))
+
+      (define/public (add-step step binders)
+        (cond [(step? step)
+               (show-step step binders)]
+              [(mono? step)
+               (show-mono step binders)]
+              [(misstep? step)
+               (show-misstep step binders)]
+              [(prestep? step)
+               (show-prestep step binders)]
+              [(poststep? step)
+               (show-poststep step binders)]))
+
+      (define/public (add-syntax stx binders definites)
+        (send sbview add-syntax stx
+              #:alpha-table binders
+              #:definites definites))
+
+      (define/private (add-final stx error binders definites)
+        (when stx
+          (send sbview add-text "Expansion finished\n")
+          (send sbview add-syntax stx
+                #:alpha-table binders
+                #:definites (or definites null)))
+        (when error
+          (add-error error)))
+
+      ;; show-lctx : Step -> void
+      (define/private (show-lctx step binders)
+        (define lctx (protostep-lctx step))
+        (when (pair? lctx)
+          (send sbview add-text "\n")
+          (for-each (lambda (bf)
+                      (send sbview add-text 
+                            "while executing macro transformer in:\n")
+                      (insert-syntax/redex (bigframe-term bf)
+                                           (bigframe-foci bf)
+                                           binders
+                                           (protostep-definites step)
+                                           (protostep-frontier step)))
+                    (reverse lctx))))
+
+      ;; separator : Step -> void
+      (define/private (separator step)
+        (if (not (mono? step))
+            (insert-step-separator (step-type->string (protostep-type step)))
+            (insert-as-separator (step-type->string (protostep-type step)))))
+
+      ;; separator/small : Step -> void
+      (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)
+        (insert-syntax/redex (step-term1 step)
+                             (step-foci1 step)
+                             binders
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (separator step)
+        (insert-syntax/contractum (step-term2 step)
+                                  (step-foci2 step)
+                                  binders
+                                  (protostep-definites step)
+                                  (protostep-frontier step))
+        (show-lctx step binders))
+
+      ;; show-mono : Step -> void
+      (define/private (show-mono step binders)
+        (separator step)
+        (insert-syntax/redex (mono-term1 step)
+                             null
+                             binders
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (show-lctx step binders))
+
+      ;; show-prestep : Step -> void
+      (define/private (show-prestep step binders)
+        (separator/small step)
+        (insert-syntax/redex (prestep-term1 step)
+                             (prestep-foci1 step)
+                             binders
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (show-lctx step binders))
+
+      ;; show-poststep : Step -> void
+      (define/private (show-poststep step binders)
+        (separator/small step)
+        (insert-syntax/contractum (poststep-term2 step)
+                                  (poststep-foci2 step)
+                                  binders
+                                  (protostep-definites step)
+                                  (protostep-frontier step))
+        (show-lctx step binders))
+
+      ;; show-misstep : Step -> void
+      (define/private (show-misstep step binders)
+        (insert-syntax/redex (misstep-term1 step)
+                             (misstep-foci1 step)
+                             binders
+                             (protostep-definites step)
+                             (protostep-frontier step))
+        (separator step)
+        (send sbview add-text (exn-message (misstep-exn step)))
+        (send sbview add-text "\n")
+        (when (exn:fail:syntax? (misstep-exn step))
+          (for-each (lambda (e) (send sbview add-syntax e
+                                      #:alpha-table binders
+                                      #:definites (protostep-definites step)))
+                    (exn:fail:syntax-exprs (misstep-exn step))))
+        (show-lctx step binders))
+
+
+      ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
+      (define/private (insert-syntax/color stx foci binders definites frontier hi-color)
+        (send sbview add-syntax stx
+              #:definites definites
+              #:alpha-table binders
+              #:hi-color hi-color
+              #:hi-stxs (if (send config get-highlight-foci?) foci null)
+              #:hi2-color "WhiteSmoke"
+              #:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
+
+      ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
+      (define/private (insert-syntax/redex stx foci binders definites frontier)
+        (insert-syntax/color stx foci binders definites frontier "MistyRose"))
+
+      ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
+      (define/private (insert-syntax/contractum stx foci binders definites frontier)
+        (insert-syntax/color stx foci binders definites frontier "LightCyan"))
+
+      ;; insert-step-separator : string -> void
+      (define/private (insert-step-separator text)
+        (send sbview add-text "\n    ")
+        (send sbview add-text
+              (make-object image-snip% 
+                           (build-path (collection-path "icons")
+                                       "red-arrow.bmp")))
+        (send sbview add-text "  ")
+        (send sbview add-text text)
+        (send sbview add-text "\n\n"))
+
+      ;; insert-as-separator : string -> void
+      (define/private (insert-as-separator text)
+        (send sbview add-text "\n    ")
+        (send sbview add-text text)
+        (send sbview add-text "\n\n"))
+
+      ;; insert-step-separator/small : string -> void
+      (define/private (insert-step-separator/small text)
+        (send sbview add-text "    ")
+        (send sbview add-text
+              (make-object image-snip% 
+                           (build-path (collection-path "icons")
+                                       "red-arrow.bmp")))
+        (send sbview add-text "  ")
+        (send sbview add-text text)
+        (send sbview add-text "\n\n"))
+
+
+      ))
+
+  )

collects/macro-debugger/view/view.ss

@@ -1,6 +1,7 @@
 
 (module view mzscheme
   (require (lib "class.ss")
+           (lib "pretty.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
            "interfaces.ss"
@@ -33,4 +34,10 @@
       (send w add-deriv deriv)
       (send f show #t)
       w))
+
+  (define (go/trace events)
+    (let* ([w (make-macro-stepper)])
+      (send w add-trace events)
+      w))
+
   )