macro-debugger: internal debugging improvements

collects/macro-debugger/stepper-text.rkt

@@ -1,30 +1,29 @@
 #lang racket/base
 (require racket/pretty
+         racket/promise
          "model/trace.rkt"
          "model/reductions.rkt"
          "model/reductions-config.rkt"
          "model/steps.rkt"
          "syntax-browser/partition.rkt"
-         "syntax-browser/pretty-helper.rkt")
+         "syntax-browser/pretty-helper.rkt"
+         "view/debug-format.rkt")
 (provide expand/step-text
          stepper-text)
 
-(define expand/step-text
+(define (expand/step-text stx [show #f]
-  (case-lambda 
+                          #:internal-error-file [error-file #f])
-   [(stx) (expand/step-text stx #f)]
+  (let ([s (stepper-text stx (->show-function show) #:internal-error-file error-file)])
-   [(stx show)
+    (s 'all)))
-    (define s (stepper-text stx (->show-function show)))
-    (s 'all)]))
 
-(define stepper-text
+(define (stepper-text stx [show #f]
-  (case-lambda
+                      #:internal-error-file [error-file #f])
-   [(stx) (internal-stepper stx #f)]
+  (internal-stepper stx (->show-function show) error-file))
-   [(stx show) (internal-stepper stx (->show-function show))]))
 
 ;; internal procedures
 
-(define (internal-stepper stx show?)
+(define (internal-stepper stx show? error-file)
-  (define steps (get-steps stx show?))
+  (define steps (get-steps stx show? error-file))
   (define used-steps null)
   (define partition (new-bound-partition))
   (define dispatch
@@ -50,14 +49,20 @@
            (dispatch 'all))))]))
   dispatch)
 
-(define (get-steps stx show?)
+(define (get-steps stx show? error-file)
-  (define deriv (trace stx))
+  (let-values ([(_result events derivp) (trace* stx)])
+    (with-handlers ([exn:fail?
+                     (lambda (exn)
+                       (when error-file
+                         (write-debug-file error-file exn events))
+                       (raise exn))])
+      (define deriv (force derivp))
       (define steps
         (parameterize ((macro-policy show?))
           (reductions deriv)))
       (define (ok? x)
         (or (rewrite-step? x) (misstep? x)))
-  (filter ok? steps))
+      (filter ok? steps))))
 
 (define (show-step step partition)
   (cond [(step? step)

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

@@ -2,16 +2,21 @@
 (require racket/pretty)
 (provide write-debug-file
          load-debug-file
-         serialize-datum)
+         serialize-datum
+         approx-parse-state)
 
 (define (write-debug-file file exn events)
   (with-output-to-file file
     (lambda ()
-      (pretty-write (serialize-datum events))
+      (write-string "`(\n")
+      (for ([event (in-list events)])
+        (let ([event (list (car event) (cdr event))])
+          (pretty-write (serialize-datum* event))))
+      (write-string ")\n")
       (newline)
       (write (exn-message exn))
       (newline)
-      (pretty-print
+      (pretty-write
        (map serialize-context-frame
             (continuation-mark-set->context
              (exn-continuation-marks exn)))))
@@ -77,5 +82,27 @@
         (let* ([events-expr (read)]
                [exnmsg (read)]
                [ctx (read)])
-          (let ([events (eval events-expr)])
+          (let* ([events (eval events-expr)]
+                 [events
+                  (if (andmap (lambda (e) (and (list? e) (= 2 (length e)))) events)
+                      (map (lambda (l) (cons (car l) (cadr l))) events)
+                      events)])
             (values events exnmsg ctx)))))))
+
+(define (approx-parse-state events N)
+  (for/fold ([state null]) ([event (in-list events)] [index (in-range N)])
+    (define (pop expect)
+      (let ([top (car state)])
+        (unless (eq? (cadr top) expect)
+          (error "bad state on ~e: ~e" (car event) state))
+        (cdr state)))
+    (case (car event)
+      ((enter-macro enter-prim enter-local)
+       (cons (cons index event) state))
+      ((exit-macro)
+       (pop 'enter-macro))
+      ((exit-prim)
+       (pop 'enter-prim))
+      ((exit-local)
+       (pop 'enter-local))
+      (else state))))