From c68035079f05d893e2a44663f58ad3058f0a557a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 3 Dec 2007 13:38:20 +0000 Subject: [PATCH] Macro stepper: better error handling svn: r7890 --- collects/macro-debugger/model/debug.ss | 2 + collects/macro-debugger/model/reductions.ss | 16 +- collects/macro-debugger/model/trace.ss | 73 +-- collects/macro-debugger/stepper-text.ss | 1 + .../macro-debugger/syntax-browser/widget.ss | 14 + collects/macro-debugger/tool.ss | 85 ++- collects/macro-debugger/view/debug-format.ss | 55 ++ collects/macro-debugger/view/debug.ss | 14 + collects/macro-debugger/view/frame.ss | 5 +- collects/macro-debugger/view/stepper.ss | 513 +++-------------- collects/macro-debugger/view/term-record.ss | 542 ++++++++++++++++++ collects/macro-debugger/view/view.ss | 7 + 12 files changed, 841 insertions(+), 486 deletions(-) create mode 100644 collects/macro-debugger/view/debug-format.ss create mode 100644 collects/macro-debugger/view/debug.ss create mode 100644 collects/macro-debugger/view/term-record.ss diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index 0d76b39cab..b39030faad 100644 --- 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 index 41f52570cc..f358e315bd 100644 --- 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 index 5898e8a0ad..94f06a4f28 100644 --- 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)))))) - ;; expand+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event)) - (define (expand+tracer sexpr expander) - (let* ([events null] - [pos 0]) + ;; 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/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 index 2ea35fca46..2c256be8ca 100644 --- 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 index 1983294b82..1843fe3239 100644 --- 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/tool.ss b/collects/macro-debugger/tool.ss index bc6c2167ff..f80fc018d0 100644 --- a/collects/macro-debugger/tool.ss +++ b/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)]) - (show-deriv deriv stepper) + (let-values ([(e-expr events derivp) (trace* expr expand)]) + (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,13 +214,13 @@ (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) (string-constant mred-w/debug) (string-constant pretty-big-scheme))))))) - + ;; Macro debugger code (drscheme:get/extend:extend-unit-frame @@ -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*)) + + ) diff --git a/collects/macro-debugger/view/debug-format.ss b/collects/macro-debugger/view/debug-format.ss new file mode 100644 index 0000000000..b2151f6746 --- /dev/null +++ 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 new file mode 100644 index 0000000000..cf10fee5df --- /dev/null +++ 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 index 3d32aa65bf..f48b51a656 100644 --- 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 index df541c9b61..816c3cc624 100644 --- 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)) + (cursor:next terms)) - ;; 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) - - ;; 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 new file mode 100644 index 0000000000..3331225248 --- /dev/null +++ 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 index bc33e2254f..64b6467898 100644 --- 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)) + )