595 lines
24 KiB
Scheme
595 lines
24 KiB
Scheme
|
|
(module gui mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "unitsig.ss")
|
|
(lib "list.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "boundmap.ss" "syntax")
|
|
"interfaces.ss"
|
|
"prefs.ss"
|
|
"warning.ss"
|
|
"hiding-panel.ss"
|
|
(prefix sb: "../syntax-browser/embed.ss")
|
|
"../model/deriv-util.ss"
|
|
"../model/trace.ss"
|
|
"../model/hide.ss"
|
|
"../model/hiding-policies.ss"
|
|
"../model/steps.ss"
|
|
"cursor.ss"
|
|
"util.ss")
|
|
|
|
(provide catch-errors?
|
|
pre-stepper@
|
|
view@
|
|
context-menu-extension@
|
|
browser-extension@)
|
|
|
|
;; Configuration
|
|
|
|
(define catch-errors? (make-parameter #t))
|
|
(define show-rename-steps? (make-parameter #f))
|
|
|
|
;; Macro Stepper
|
|
|
|
(define view@
|
|
(unit/sig view^
|
|
(import prefs^
|
|
view-base^
|
|
(sb : sb:widget^))
|
|
|
|
(define (default-policy)
|
|
(let ([p (new-hiding-policy)])
|
|
(set-hiding-policy-opaque-kernel! p (pref:hide-primitives?))
|
|
(set-hiding-policy-opaque-libs! p (pref:hide-libs?))
|
|
p))
|
|
|
|
(define macro-stepper-frame%
|
|
(class base-frame%
|
|
(init (policy (default-policy))
|
|
(macro-hiding? (pref:macro-hiding?))
|
|
(show-hiding-panel? (pref:show-hiding-panel?))
|
|
(identifier=? (pref:identifier=?))
|
|
(width (pref:width))
|
|
(height (pref:height)))
|
|
(inherit get-menu%
|
|
get-menu-item%
|
|
get-menu-bar
|
|
get-file-menu
|
|
get-edit-menu
|
|
get-help-menu)
|
|
|
|
(super-new (label "Macro stepper")
|
|
(width width)
|
|
(height height))
|
|
|
|
(define/override (on-size w h)
|
|
(send widget update/preserve-view))
|
|
|
|
(define/augment (on-close)
|
|
(pref:width (send this get-width))
|
|
(pref:height (send this get-height))
|
|
(send widget shutdown)
|
|
(inner (void) on-close))
|
|
|
|
(override/return-false file-menu:create-new?
|
|
file-menu:create-open?
|
|
file-menu:create-open-recent?
|
|
file-menu:create-revert?
|
|
file-menu:create-save?
|
|
file-menu:create-save-as?
|
|
;file-menu:create-print?
|
|
edit-menu:create-undo?
|
|
edit-menu:create-redo?
|
|
;edit-menu:create-cut?
|
|
;edit-menu:create-paste?
|
|
edit-menu:create-clear?
|
|
;edit-menu:create-find?
|
|
;edit-menu:create-find-again?
|
|
edit-menu:create-replace-and-find-again?)
|
|
|
|
(define file-menu (get-file-menu))
|
|
(define edit-menu (get-edit-menu))
|
|
(define syntax-menu
|
|
(new (get-menu%) (parent (get-menu-bar)) (label "Syntax")))
|
|
(define stepper-menu
|
|
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
|
|
(define help-menu (get-help-menu))
|
|
|
|
(define (mk-register-action menu)
|
|
(lambda (label callback)
|
|
(if label
|
|
(new (get-menu-item%)
|
|
(label label) (parent menu) (callback (lambda _ (callback))))
|
|
(new separator-menu-item% (parent menu)))))
|
|
|
|
(define widget
|
|
(new macro-stepper-widget%
|
|
(parent (send this get-area-container))
|
|
(policy policy)
|
|
(macro-hiding? macro-hiding?)
|
|
(show-hiding-panel? show-hiding-panel?)))
|
|
(define/public (get-widget) widget)
|
|
|
|
(begin
|
|
(new (get-menu-item%) (label "Show/hide syntax properties") (parent syntax-menu)
|
|
(callback (lambda _ (send (send widget get-view) toggle-props))))
|
|
(define id-menu
|
|
(new (get-menu%) (label "Identifier=?") (parent syntax-menu)))
|
|
(for-each (lambda (p)
|
|
(let ([this-choice
|
|
(new checkable-menu-item%
|
|
(label (car p))
|
|
(parent id-menu)
|
|
(callback (lambda _
|
|
(send (send widget get-controller)
|
|
on-update-identifier=?
|
|
(car p)
|
|
(cdr p)))))])
|
|
(send (send widget get-controller)
|
|
add-identifier=?-listener
|
|
(lambda (new-name new-func)
|
|
(send this-choice check (eq? new-name (car p)))))))
|
|
(sb:identifier=-choices))
|
|
(new (get-menu-item%) (label "Clear selection") (parent syntax-menu)
|
|
(callback
|
|
(lambda _ (send (send widget get-controller) select-syntax #f))))
|
|
(new (get-menu-item%)
|
|
(label "Show/hide macro hiding configuration")
|
|
(parent stepper-menu)
|
|
(callback (lambda _ (send widget show/hide-macro-hiding-prefs)))))
|
|
|
|
(begin
|
|
(when identifier=?
|
|
(let ([p (assoc identifier=? (sb:identifier=-choices))])
|
|
(when p
|
|
(send (send widget get-controller)
|
|
on-update-identifier=?
|
|
(car p)
|
|
(cdr p))))))
|
|
|
|
(frame:reorder-menus this)
|
|
))
|
|
|
|
;; macro-stepper-widget%
|
|
(define macro-stepper-widget%
|
|
(class* object% ()
|
|
(init-field parent)
|
|
(init policy)
|
|
(init macro-hiding?)
|
|
(init show-hiding-panel?)
|
|
|
|
;; derivs : (list-of Derivation)
|
|
(define derivs null)
|
|
|
|
;; synth-deriv : Derivation
|
|
(define synth-deriv #f)
|
|
|
|
;; derivs-prefix : (list-of (cons Derivation Derivation))
|
|
(define derivs-prefix null)
|
|
|
|
(define steps #f)
|
|
|
|
(define warnings-frame #f)
|
|
|
|
(define/public (add-deriv d)
|
|
(set! derivs (append derivs (list d)))
|
|
(when (and (not (send updown-navigator is-shown?))
|
|
(pair? (cdr (append derivs-prefix derivs))))
|
|
(send super-navigator add-child updown-navigator)
|
|
(send updown-navigator show #t))
|
|
(if (null? (cdr derivs))
|
|
;; There is nothing currently displayed
|
|
(refresh)
|
|
(update)))
|
|
|
|
(define/public (get-controller) sbc)
|
|
(define/public (get-view) sbview)
|
|
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
|
|
|
(define area (new vertical-panel% (parent parent)))
|
|
(define super-navigator
|
|
(new horizontal-panel%
|
|
(parent area)
|
|
(stretchable-height #f)
|
|
(alignment '(center center))))
|
|
(define navigator
|
|
(new horizontal-panel%
|
|
(parent super-navigator)
|
|
(stretchable-height #f)
|
|
(alignment '(center center))))
|
|
(define updown-navigator
|
|
(new horizontal-panel%
|
|
(parent super-navigator)
|
|
(style '(deleted))
|
|
(stretchable-height #f)
|
|
(alignment '(center center))))
|
|
|
|
(define sbview (new sb:syntax-widget%
|
|
(parent area)
|
|
(macro-stepper this)
|
|
(pref:props-percentage pref:props-percentage)))
|
|
(define sbc (send sbview get-controller))
|
|
(define control-pane
|
|
(new vertical-panel% (parent area) (stretchable-height #f)))
|
|
(define macro-hiding-prefs
|
|
(new macro-hiding-prefs-widget%
|
|
(policy policy)
|
|
(parent control-pane)
|
|
(stepper this)
|
|
(enabled? macro-hiding?)))
|
|
(send sbc add-selection-listener
|
|
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
|
|
(unless show-hiding-panel?
|
|
(show/hide-macro-hiding-prefs))
|
|
|
|
(define nav:start
|
|
(new button% (label "<-- Start") (parent navigator)
|
|
(callback (lambda (b e) (navigate-to-start)))))
|
|
(define nav:previous
|
|
(new button% (label "<- Step") (parent navigator)
|
|
(callback (lambda (b e) (navigate-previous)))))
|
|
(define nav:next
|
|
(new button% (label "Step ->") (parent navigator)
|
|
(callback (lambda (b e) (navigate-next)))))
|
|
(define nav:end
|
|
(new button% (label "End -->") (parent navigator)
|
|
(callback (lambda (b e) (navigate-to-end)))))
|
|
|
|
(define nav:up
|
|
(new button% (label "Previous term") (parent updown-navigator)
|
|
(callback (lambda (b e) (navigate-up)))))
|
|
(define nav:down
|
|
(new button% (label "Next term") (parent updown-navigator)
|
|
(callback (lambda (b e) (navigate-down)))))
|
|
|
|
(define/public (show/hide-macro-hiding-prefs)
|
|
(send area change-children
|
|
(lambda (children)
|
|
(if (memq control-pane children)
|
|
(remq control-pane children)
|
|
(append children (list control-pane))))))
|
|
|
|
;; Navigate
|
|
|
|
(define/private (navigate-to-start)
|
|
(cursor:move-to-start steps)
|
|
(update))
|
|
(define/private (navigate-to-end)
|
|
(cursor:move-to-end steps)
|
|
(update))
|
|
(define/private (navigate-previous)
|
|
(cursor:move-previous steps)
|
|
(update))
|
|
(define/private (navigate-next)
|
|
(cursor:move-next steps)
|
|
(update))
|
|
|
|
(define/private (navigate-up)
|
|
(let ([d+sd (car derivs-prefix)])
|
|
(set! derivs (cons (car d+sd) derivs))
|
|
(set! synth-deriv (cdr d+sd))
|
|
(set! derivs-prefix (cdr derivs-prefix)))
|
|
(refresh))
|
|
(define/private (navigate-down)
|
|
(let ([d0 (car derivs)])
|
|
(set! derivs-prefix (cons (cons d0 synth-deriv) derivs-prefix))
|
|
(set! derivs (cdr derivs))
|
|
(set! synth-deriv #f))
|
|
(refresh))
|
|
|
|
(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"))
|
|
|
|
;; 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)))
|
|
|
|
;; update : -> void
|
|
;; Updates the terms in the syntax browser to the current step
|
|
(define/private (update)
|
|
(define text (send sbview get-text))
|
|
(define position-of-interest 0)
|
|
(send text begin-edit-sequence)
|
|
(send sbview erase-all)
|
|
(when (pair? derivs-prefix)
|
|
;; Show the final terms from the cached synth'd derivs
|
|
(for-each (lambda (d+sd)
|
|
(let ([e2 (lift/deriv-e2 (cdr d+sd))])
|
|
(if e2
|
|
(send sbview add-syntax e2)
|
|
(send sbview add-text "Error\n"))))
|
|
(reverse derivs-prefix))
|
|
(send sbview add-separator))
|
|
(set! position-of-interest (send text last-position))
|
|
(when steps
|
|
(let ([step (cursor:current steps)])
|
|
(unless step
|
|
(let ([result (lift/deriv-e2 synth-deriv)])
|
|
(when result
|
|
(send sbview add-text "Expansion finished\n")
|
|
(send sbview add-syntax result))
|
|
(unless result
|
|
(send sbview add-text "Error\n"))))
|
|
(when (step? step)
|
|
(when (pair? (step-lctx step))
|
|
(for-each (lambda (bc)
|
|
(send sbview add-text "While executing macro transformer in:\n")
|
|
(insert-syntax/redex (cdr bc) (car bc)))
|
|
(step-lctx step))
|
|
(send sbview add-text "\n"))
|
|
(insert-syntax/redex (step-e1 step) (foci (step-redex step)))
|
|
(insert-step-separator (step-note step))
|
|
(insert-syntax/contractum (step-e2 step) (foci (step-contractum step))))
|
|
(when (misstep? step)
|
|
(insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step)))
|
|
(insert-step-separator "Error")
|
|
(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))
|
|
(exn:fail:syntax-exprs (misstep-exn step)))))))
|
|
(when (and (pair? derivs) (pair? (cdr derivs)))
|
|
(send sbview add-separator)
|
|
(for-each (lambda (suffix-deriv)
|
|
(send sbview add-syntax (lift/deriv-e1 suffix-deriv)))
|
|
(cdr derivs)))
|
|
(send text end-edit-sequence)
|
|
(send text scroll-to-position
|
|
position-of-interest
|
|
#f
|
|
(send text last-position)
|
|
'start)
|
|
(enable/disable-buttons))
|
|
|
|
;; insert-syntax/redex : syntax syntaxes -> void
|
|
(define/private (insert-syntax/redex stx foci)
|
|
(send sbview add-syntax stx foci "MistyRose"))
|
|
|
|
; insert-syntax/contractum : syntax syntaxes -> void
|
|
(define/private (insert-syntax/contractum stx foci)
|
|
(send sbview add-syntax stx foci "LightCyan"))
|
|
|
|
;; enable/disable-buttons : -> void
|
|
(define/private (enable/disable-buttons)
|
|
(send nav:start enable (and steps (cursor:can-move-previous? steps)))
|
|
(send nav:previous enable (and steps (cursor:can-move-previous? steps)))
|
|
(send nav:next enable (and steps (cursor:can-move-next? steps)))
|
|
(send nav:end enable (and steps (cursor:can-move-next? steps)))
|
|
(send nav:up enable (and (pair? derivs-prefix)))
|
|
(send nav:down enable
|
|
(and (pair? derivs))))
|
|
;; --
|
|
|
|
;; refresh/resynth : -> void
|
|
;; Resynth all of the derivations in prefix and refresh
|
|
(define/public (refresh/resynth)
|
|
(with-handlers ([(lambda (e) (catch-errors?))
|
|
(lambda (e)
|
|
(message-box "Error"
|
|
"Internal error in macro stepper (prefixes)")
|
|
(send sbview erase-all))])
|
|
(let ([ds (map car derivs-prefix)])
|
|
(let ([sds (map (lambda (d) (synthesize d)) ds)])
|
|
(set! derivs-prefix (map cons ds sds)))))
|
|
(refresh))
|
|
|
|
;; refresh : -> void
|
|
;; Resynth current derivation,
|
|
;; Create reductions for current derivation,
|
|
;; Show first step
|
|
(define/private (refresh)
|
|
(if (pair? derivs)
|
|
(refresh/nontrivial)
|
|
(begin (set! synth-deriv #f)
|
|
(set! steps #f)
|
|
(update))))
|
|
|
|
;; refresh/nontrivial : -> void
|
|
(define/private (refresh/nontrivial)
|
|
(let ([deriv (car derivs)])
|
|
(let ([d (synthesize deriv)])
|
|
(let ([s (cursor:new (reduce d))])
|
|
(set! synth-deriv d)
|
|
(set! steps s))))
|
|
(update))
|
|
|
|
;; synthesize : Derivation -> Derivation
|
|
(define/private (synthesize deriv)
|
|
(let ([show-macro? (get-show-macro?)])
|
|
(if show-macro?
|
|
(with-handlers ([(lambda (e) (catch-errors?))
|
|
(lambda (e) (no-synthesize deriv))])
|
|
(parameterize ((current-hiding-warning-handler
|
|
(lambda (tag message)
|
|
(unless warnings-frame
|
|
(set! warnings-frame (new warnings-frame%)))
|
|
(send warnings-frame add-warning tag)
|
|
#;
|
|
(send warnings-frame add-text
|
|
(format "Warning: ~a~n" message)))))
|
|
(let-values ([(d s) (hide/policy deriv show-macro?)])
|
|
d)))
|
|
deriv)))
|
|
|
|
(define/private (no-synthesize deriv)
|
|
(message-box
|
|
"Macro Debugger"
|
|
(string-append
|
|
"This expansion triggers an error in the macro hiding code. "
|
|
"Trying again with macro hiding disabled."))
|
|
(send macro-hiding-prefs enable-hiding #f)
|
|
(synthesize deriv))
|
|
|
|
;; reduce : Derivation -> ReductionSequence
|
|
(define/private (reduce d)
|
|
(with-handlers ([(lambda (e) (catch-errors?))
|
|
(lambda (e)
|
|
(message-box
|
|
"Error"
|
|
"Internal error in macro stepper (reductions)")
|
|
(set! synth-deriv #f)
|
|
(set! steps #f))])
|
|
(if (show-rename-steps?)
|
|
(reductions d)
|
|
(filter (lambda (x) (not (rename-step? x)))
|
|
(reductions d)))))
|
|
|
|
(define/private (foci x) (if (list? x) x (list x)))
|
|
|
|
;; Hiding policy
|
|
|
|
(define/private (get-policy)
|
|
(and (send macro-hiding-prefs get-enabled?)
|
|
(send macro-hiding-prefs get-policy)))
|
|
|
|
(define/private (get-show-macro?)
|
|
(let ([policy (get-policy)])
|
|
(and policy (lambda (id) (policy-show-macro? policy id)))))
|
|
|
|
;; --
|
|
|
|
(define/public (shutdown)
|
|
(let ([policy (get-policy)])
|
|
(pref:macro-hiding? (and policy #t))
|
|
(pref:hide-primitives? (and policy (hiding-policy-opaque-kernel policy)))
|
|
(pref:hide-libs? (and policy (hiding-policy-opaque-libs policy))))
|
|
(pref:show-hiding-panel? (send control-pane is-shown?))
|
|
(when warnings-frame (send warnings-frame show #f)))
|
|
|
|
;; Initialization
|
|
|
|
(super-new)
|
|
(refresh)))
|
|
|
|
;; Main entry points
|
|
|
|
(define make-macro-stepper
|
|
(case-lambda
|
|
[(policy hiding?)
|
|
(let ([f (new macro-stepper-frame%
|
|
(policy policy)
|
|
(macro-hiding? hiding?))])
|
|
(send f show #t)
|
|
(send f get-widget))]
|
|
[(policy)
|
|
(make-macro-stepper policy #t)]
|
|
[()
|
|
(make-macro-stepper (new-hiding-policy) #f)]))
|
|
|
|
(define (go stx)
|
|
(let ([stepper (make-macro-stepper)])
|
|
(send stepper add-deriv (trace stx))))
|
|
|
|
(define (go/deriv deriv)
|
|
(let* ([f (new macro-stepper-frame%)]
|
|
[w (send f get-widget)])
|
|
(send w add-deriv deriv)
|
|
(send f show #t)
|
|
w))
|
|
))
|
|
|
|
|
|
(define context-menu-extension@
|
|
(unit/sig sb:context-menu^
|
|
(import (pre : sb:context-menu^))
|
|
|
|
(define context-menu%
|
|
(class pre:context-menu%
|
|
(init-field macro-stepper)
|
|
(inherit-field controller)
|
|
(inherit add-separator)
|
|
|
|
(define/private (get-prefs-panel)
|
|
(send macro-stepper get-macro-hiding-prefs))
|
|
|
|
(define show-macro #f)
|
|
(define hide-macro #f)
|
|
(define remove-macro #f)
|
|
|
|
(define/override (after-selection-items)
|
|
(super after-selection-items)
|
|
(add-separator)
|
|
(set! show-macro
|
|
(new menu-item% (label "Show this macro") (parent this)
|
|
(callback (lambda _ (do-show)))))
|
|
(set! hide-macro
|
|
(new menu-item% (label "Hide this macro") (parent this)
|
|
(callback (lambda _ (do-hide)))))
|
|
#;(set! remove-macro
|
|
(new menu-item% (label "Remove macro from policy") (parent this)
|
|
(callback (lambda _ (do-remove)))))
|
|
(void))
|
|
|
|
(define/private (do-show)
|
|
(send* (get-prefs-panel)
|
|
(add-show-identifier)
|
|
(refresh)))
|
|
|
|
(define/private (do-hide)
|
|
(send* (get-prefs-panel)
|
|
(add-hide-identifier)
|
|
(refresh)))
|
|
|
|
(define/override (on-demand)
|
|
(define-values (opaque transparent)
|
|
(let ([policy (send (get-prefs-panel) get-policy)])
|
|
(values (hiding-policy-opaque-ids policy)
|
|
(hiding-policy-transparent-ids policy))))
|
|
(define stx (send controller get-selected-syntax))
|
|
(define id? (identifier? stx))
|
|
(define transparent?
|
|
(and id? (module-identifier-mapping-get transparent stx (lambda () #f))))
|
|
(define opaque?
|
|
(and id? (module-identifier-mapping-get opaque stx (lambda () #f))))
|
|
(send show-macro enable (and id? (not transparent?)))
|
|
(send hide-macro enable (and id? (not opaque?)))
|
|
#;(send remove-macro enable (and id? (or opaque? transparent?)))
|
|
(super on-demand))
|
|
|
|
(super-new)))))
|
|
|
|
(define browser-extension@
|
|
(unit/sig sb:widget^
|
|
(import (pre : sb:widget^)
|
|
sb:context-menu^)
|
|
|
|
(define syntax-widget%
|
|
(class pre:syntax-widget%
|
|
(init-field macro-stepper)
|
|
|
|
(define/override (make-context-menu)
|
|
(new context-menu%
|
|
(widget this)
|
|
(macro-stepper macro-stepper)))
|
|
(super-new)))))
|
|
|
|
(define pre-stepper@
|
|
(compound-unit/sig
|
|
(import [BASE : view-base^])
|
|
(link [PREFS : prefs^ (prefs@)]
|
|
[SBKEYMAP : sb:keymap^ (sb:keymap@)]
|
|
[SBMENU : sb:context-menu^ (sb:context-menu@ SBSNIP)]
|
|
[SBSNIP : sb:snip^ (sb:global-snip@)]
|
|
[SBWMENU : sb:context-menu^ (sb:widget-context-menu-extension@ SBMENU)]
|
|
[VMENU : sb:context-menu^ (context-menu-extension@ SBWMENU)]
|
|
[SBWIDGET : sb:widget^ (sb:widget@ SBKEYMAP SBWMENU)]
|
|
[VWIDGET : sb:widget^ (browser-extension@ SBWIDGET VMENU)]
|
|
[VIEW : view^ (view@ PREFS BASE VWIDGET)])
|
|
(export (open VIEW))))
|
|
|
|
|
|
)
|