commit 5f02ff4a7d04d0227f6218037189f23415fcd115
parent f9c94375e9d1a0fd3b417d251ae3213459d2b206
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 3 Dec 2007 13:38:20 +0000
Macro stepper: better error handling
svn: r7890
original commit: c68035079f05d893e2a44663f58ad3058f0a557a
Diffstat:
11 files changed, 766 insertions(+), 476 deletions(-)
diff --git a/collects/macro-debugger/model/debug.ss b/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")
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -8,7 +8,7 @@
"reductions-engine.ss")
(provide reductions
- reductions+definites)
+ reductions+)
;; Setup for reduction-engines
@@ -46,14 +46,14 @@
(when d (add-frontier (list (wderiv-e1 d))))
(RS-steps (reductions* d))))
- ;; reductions+definites : WDeriv -> (values ReductionSequence (list-of identifier))
- (define (reductions+definites d)
+ ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
+ (define (reductions+ d)
(parameterize ((current-definites null)
(current-frontier null))
(when d (add-frontier (list (wderiv-e1 d))))
- (let ([rs (RS-steps (reductions* d))])
- (values rs (current-definites)))))
-
+ (let-values ([(rs stx exn) (reductions* d)])
+ (values rs (current-definites) stx exn))))
+
;; reductions* : WDeriv -> RS(stx)
(define (reductions* d)
(match d
@@ -421,8 +421,8 @@
[(struct local-lift-end (decl))
(RSadd (list (walk/mono decl 'module-lift))
RSzero)]
- [(struct local-bind (deriv))
- (reductions* deriv)]))
+ [(struct local-bind (bindrhs))
+ (bind-syntaxes-reductions bindrhs)]))
;; list-reductions : ListDerivation -> (RS Stxs)
(define (list-reductions ld)
diff --git a/collects/macro-debugger/model/trace.ss b/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"
- "reductions.ss")
+ "deriv-tokens.ss")
- (provide trace-verbose?
- trace
+ (provide trace
+ trace*
trace/result
- trace+reductions
- current-expand-observe
- (all-from "reductions.ss"))
+ trace-verbose?
+ events->token-generator
+ 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)])
- (parse-derivation tracer)))
+ (let-values ([(result events derivp) (trace* stx expand)])
+ (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
- (define (trace+reductions stx)
- (reductions (trace stx)))
+ ;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
+ (define (trace* stx expander)
+ (let-values ([(result events) (expand/events stx expander)])
+ (values result
+ events
+ (delay (parse-derivation
+ (events->token-generator events))))))
+
+ ;; events->token-generator : (list-of event) -> (-> token)
+ (define (events->token-generator events)
+ (let ([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+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event))
- (define (expand+tracer sexpr expander)
- (let* ([events null]
- [pos 0])
+ ;; 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)])
- (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))))))))
-
+ (reverse events))))))
)
diff --git a/collects/macro-debugger/stepper-text.ss b/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"
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/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
diff --git a/collects/macro-debugger/view/debug-format.ss b/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)))))))
+ )
diff --git a/collects/macro-debugger/view/debug.ss b/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)))
+
+ )
diff --git a/collects/macro-debugger/view/frame.ss b/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)))
diff --git a/collects/macro-debugger/view/stepper.ss b/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)])
- (when term (recache term))
- term))
-
- ;; focused-steps : -> (Cursor-of Step) or #f
- (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)
+ (cursor:next terms))
- ;; add-deriv : Derivation -> void
+ ;; add-deriv : Deriv -> void
(define/public (add-deriv d)
- (let ([needs-display? (cursor:at-end? terms)])
- (for-each (lambda (id) (module-identifier-mapping-put! alpha-table id id))
- (extract-all-fresh-names d))
- (cursor:add-to-end! terms (list (new-trec d)))
- (trim-navigator)
- (if needs-display?
- (refresh/move)
- (update))))
+ (let ([trec (new term-record% (stepper this) (raw-deriv d))])
+ (add trec)))
+
+ ;; 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 display-new-term?
+ (refresh)
+ (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)
- (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
;; 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)
@@ -356,255 +270,63 @@
(send text last-position)
'start)
(enable/disable-buttons))
-
+
;; update:show-prefix : -> void
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
- (for-each (lambda (trec)
- (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"))))
+ (for-each (lambda (trec) (send trec display-final-term))
(cursor:prefix->list terms)))
;; update:show-current-step : -> void
(define/private (update:show-current-step)
- (define steps (focused-steps))
(when (focused-term)
- (when steps
- (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")))
+ (send (focused-term) display-step)))
;; 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
- (wderiv-e1 (trec-deriv trec))
- #:alpha-table alpha-table))
+ (send trec display-initial-term))
(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))
- (send nav:start enable (and steps (cursor:has-prev? steps)))
- (send nav:previous enable (and steps (cursor:has-prev? steps)))
- (send nav:next enable (and steps (cursor:has-next? steps)))
- (send nav:end enable (and steps (cursor:has-next? steps)))
+ (define term (focused-term))
+ (send nav:start enable (and term (send term has-prev?)))
+ (send nav:previous enable (and term (send term has-prev?)))
+ (send nav:next enable (and term (send term has-next?)))
+ (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)))
;; --
-
+
;; 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)
- (display-warnings (focused-term))
+ (send warnings-area clear)
+ (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,94 +358,19 @@
(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)
(send sbview show-props (send config get-show-syntax-properties?))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
diff --git a/collects/macro-debugger/view/term-record.ss b/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"))
+
+
+ ))
+
+ )
diff --git a/collects/macro-debugger/view/view.ss b/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))
+
)
