473 lines
16 KiB
Scheme
473 lines
16 KiB
Scheme
|
|
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/unit
|
|
scheme/list
|
|
scheme/match
|
|
scheme/gui
|
|
framework/framework
|
|
syntax/boundmap
|
|
"interfaces.ss"
|
|
"prefs.ss"
|
|
"extensions.ss"
|
|
"warning.ss"
|
|
"hiding-panel.ss"
|
|
(prefix-in s: "../syntax-browser/widget.ss")
|
|
(prefix-in 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-config.ss"
|
|
"../model/reductions.ss"
|
|
"../model/steps.ss"
|
|
"../util/notify.ss"
|
|
"cursor.ss"
|
|
"debug-format.ss")
|
|
|
|
(provide term-record%)
|
|
|
|
;; Struct for one-by-one stepping
|
|
|
|
(define-struct (prestep protostep) ())
|
|
(define-struct (poststep protostep) ())
|
|
|
|
(define (prestep-term1 s) (state-term (protostep-s1 s)))
|
|
(define (poststep-term2 s) (state-term (protostep-s1 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 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-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!))
|
|
|
|
;; 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!)
|
|
(recache-deriv!))
|
|
|
|
;; recache-raw-steps! : -> void
|
|
(define/private (recache-raw-steps!)
|
|
(unless (or raw-steps raw-steps-oops)
|
|
(recache-synth!)
|
|
(when deriv
|
|
(let ([show-macro? (or (send stepper get-show-macro?)
|
|
(lambda (id) #t))])
|
|
(with-handlers ([(lambda (e) #t)
|
|
(lambda (e)
|
|
(set! raw-steps-oops e))])
|
|
(let-values ([(raw-steps* definites* estx* error*)
|
|
(parameterize ((macro-policy show-macro?))
|
|
(reductions+ 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 (type s1 s2)) rs)
|
|
(list* (make prestep type s1)
|
|
(make poststep type s2)
|
|
(loop rs))]
|
|
[(cons (struct misstep (type s1 exn)) rs)
|
|
(list* (make prestep type s1)
|
|
(make misstep type s1 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)
|
|
;; FIXME: add back step numbers
|
|
(state-seq (protostep-s1 step)))
|
|
|
|
;; Warnings display
|
|
|
|
;; on-get-focus : -> void
|
|
(define/public (on-get-focus)
|
|
(recache-synth!))
|
|
|
|
;; on-lose-focus : -> void
|
|
(define/public (on-lose-focus)
|
|
(when steps (cursor:move-to-start steps))
|
|
(set! steps-position #f))
|
|
|
|
;; 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? raw-steps-estx)
|
|
(add-syntax raw-steps-estx binders definites)]
|
|
[(exn? error)
|
|
(add-error error)]
|
|
[raw-steps-oops
|
|
(add-internal-error "steps" raw-steps-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))]
|
|
[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"
|
|
(format "Internal error:\n~a" (exn-message exn))
|
|
"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)]
|
|
[(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 (or definites null)))
|
|
|
|
(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 state (protostep-s1 step))
|
|
(define lctx (state-lctx state))
|
|
(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
|
|
(state-uses state)
|
|
(state-frontier state)))
|
|
(reverse lctx))))
|
|
|
|
;; separator : Step -> void
|
|
(define/private (separator step)
|
|
(insert-step-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)
|
|
(show-state/redex (protostep-s1 step) binders)
|
|
(separator step)
|
|
(show-state/contractum (step-s2 step) binders)
|
|
(show-lctx step binders))
|
|
|
|
(define/private (show-state/redex state binders)
|
|
(insert-syntax/contractum (state-term state)
|
|
(state-foci state)
|
|
binders
|
|
(state-uses state)
|
|
(state-frontier state)))
|
|
|
|
(define/private (show-state/contractum state binders)
|
|
(insert-syntax/contractum (state-term state)
|
|
(state-foci state)
|
|
binders
|
|
(state-uses state)
|
|
(state-frontier state)))
|
|
|
|
;; show-prestep : Step -> void
|
|
(define/private (show-prestep step binders)
|
|
(separator/small step)
|
|
(show-state/redex (protostep-s1 step) binders)
|
|
(show-lctx step binders))
|
|
|
|
;; show-poststep : Step -> void
|
|
(define/private (show-poststep step binders)
|
|
(separator/small step)
|
|
(show-state/contractum (protostep-s1 step) binders)
|
|
(show-lctx step binders))
|
|
|
|
;; show-misstep : Step -> void
|
|
(define/private (show-misstep step binders)
|
|
(define state (protostep-s1 step))
|
|
(show-state/redex state binders)
|
|
(separator step)
|
|
(send sbview add-error-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 (or (state-uses state) null)))
|
|
(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 (or definites null)
|
|
'#: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"))
|
|
|
|
|
|
))
|