Macro stepper: better error handling
svn: r7890
This commit is contained in:
Ryan Culpepper
parent
5fdaeea963
commit
c68035079f
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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*))
|
||||
|
||||
)
|
||||
|
|
|
|||
55
collects/macro-debugger/view/debug-format.ss
Normal file
55
collects/macro-debugger/view/debug-format.ss
Normal file
|
|
@ -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)))))))
|
||||
)
|
||||
14
collects/macro-debugger/view/debug.ss
Normal file
14
collects/macro-debugger/view/debug.ss
Normal file
|
|
@ -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)))
|
||||
|
||||
)
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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?))
|
||||
|
|
|
|||
542
collects/macro-debugger/view/term-record.ss
Normal file
542
collects/macro-debugger/view/term-record.ss
Normal file
|
|
@ -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"))
|
||||
|
||||
|
||||
))
|
||||
|
||||
)
|
||||
|
|
@ -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))
|
||||
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user