diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index 68d64b98b2..1d52b224c3 100644 --- a/collects/macro-debugger/expand.ss +++ b/collects/macro-debugger/expand.ss @@ -1,6 +1,7 @@ (module expand mzscheme - (require "view/gui.ss") + (require (lib "unitsig.ss")) + (require "view/view.ss") (provide expand/step) (define (expand/step stx) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index 8ae3c5f8d8..c899506ccf 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -13,6 +13,19 @@ (lib "bitmap-label.ss" "mrlib") (lib "string-constant.ss" "string-constants")) + (define view-base/tool@ + (unit/sig view:view-base^ + (import) + (define base-frame% + (frame:standard-menus-mixin frame:basic%)))) + + (define-values/invoke-unit/sig view:view^ + (compound-unit/sig + (import) + (link (BASE : view:view-base^ (view-base/tool@)) + (VIEW : view:view^ (view:view@ BASE))) + (export (open VIEW)))) + (provide tool@) (define tool@ @@ -117,7 +130,7 @@ (current-module-name-resolver mnr))))) (define/private (make-handlers original-eval-handler original-module-name-resolver) - (let ([stepper (delay (view:make-macro-stepper (new-standard-hiding-policy)))] + (let ([stepper (delay (make-macro-stepper (new-standard-hiding-policy)))] [debugging? debugging?]) (values (lambda (expr) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index dda83560f7..6f9949a392 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -1,6 +1,7 @@ (module gui mzscheme (require (lib "class.ss") + (lib "unitsig.ss") (lib "list.ss") (lib "mred.ss" "mred") (lib "framework.ss" "framework") @@ -19,683 +20,714 @@ "cursor.ss" "util.ss") - (provide (all-defined)) + (provide view^ + view-base^ + catch-errors? + view-base@ + view@) + + ;; Signatures + + (define-signature view^ + (macro-stepper-frame% + macro-stepper-widget% + make-macro-stepper + go + go/deriv)) + + (define-signature view-base^ + (base-frame%)) + ;; Configuration (define catch-errors? (make-parameter #f)) + (define show-rename-steps? (make-parameter #f)) ;; Macro Stepper - (define base-frame% - (frame:standard-menus-mixin frame:basic%) - #;(frame:standard-menus-mixin (frame:basic-mixin frame%))) - - (define macro-stepper-frame% - (class base-frame% - (init policy - macro-hiding?) - (inherit get-menu% - get-menu-item% - get-menu-bar - get-file-menu - get-edit-menu - get-help-menu) - - (super-new (label "Macro stepper") - (width (sb:pref:width)) - (height (sb:pref:height))) - - (define/override (on-size w h) - (send widget update/preserve-view)) - - (define/augment (on-close) - (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))))) - - (begin - (new (get-menu-item%) (label "Show properties") (parent syntax-menu) - (callback (lambda _ (send (send widget get-view) show-props)))) - (new (get-menu-item%) (label "Hide properties") (parent syntax-menu) - (callback (lambda _ (send (send widget get-view) hide-props)))) - (define id-menu - (new (get-menu%) (label "Identifier=?") (parent syntax-menu))) - (for-each (lambda (p) - (new (get-menu-item%) (label (car p)) (parent id-menu) - (callback (lambda _ - (send (send widget get-controller) - on-update-identifier=? - (cdr p)))))) - (sb:identifier=-choices)) - (new (get-menu-item%) (label "Clear selection") (parent syntax-menu) - (callback - (lambda _ (send (send widget get-controller) select-syntax #f))))) - - (define widget - (new macro-stepper-widget% - (register-syntax-action (mk-register-action syntax-menu)) - (register-stepper-action (mk-register-action stepper-menu)) - (parent (send this get-area-container)) - (policy policy) - (macro-hiding? macro-hiding?))) - - (define/public (get-widget) widget) - (frame:reorder-menus this) - )) - - ;; macro-stepper-widget% - (define macro-stepper-widget% - (class* object% () - (init-field parent) - (init-field register-syntax-action) - (init-field register-stepper-action) - (init policy) - (init macro-hiding?) - - ;; 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)) - (when (null? (cdr derivs)) - ;; There is nothing currently displayed - (refresh)) - (update)) - - (define/public (get-controller) sbc) - (define/public (get-view) sbview) - - (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))) - (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))) - - (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 view-base@ + (unit/sig view-base^ + (import) - (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 base-frame% + (frame:standard-menus-mixin (frame:basic-mixin frame%))))) - (register-stepper-action "Show/hide macro hiding configuration" - (lambda () (show/hide-macro-hiding-prefs))) - - (define/private (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)))))) + (define view@ + (unit/sig view^ + (import view-base^) - ;; Navigate + (define macro-stepper-frame% + (class base-frame% + (init policy + macro-hiding?) + (init (show-hiding-panel? #t)) + (inherit get-menu% + get-menu-item% + get-menu-bar + get-file-menu + get-edit-menu + get-help-menu) + + (super-new (label "Macro stepper") + (width (sb:pref:width)) + (height (sb:pref:height))) + + (define/override (on-size w h) + (send widget update/preserve-view)) + + (define/augment (on-close) + (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))))) + + (begin + (new (get-menu-item%) (label "Show properties") (parent syntax-menu) + (callback (lambda _ (send (send widget get-view) show-props)))) + (new (get-menu-item%) (label "Hide properties") (parent syntax-menu) + (callback (lambda _ (send (send widget get-view) hide-props)))) + (define id-menu + (new (get-menu%) (label "Identifier=?") (parent syntax-menu))) + (for-each (lambda (p) + (new (get-menu-item%) (label (car p)) (parent id-menu) + (callback (lambda _ + (send (send widget get-controller) + on-update-identifier=? + (cdr p)))))) + (sb:identifier=-choices)) + (new (get-menu-item%) (label "Clear selection") (parent syntax-menu) + (callback + (lambda _ (send (send widget get-controller) select-syntax #f))))) - (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 widget + (new macro-stepper-widget% + (register-syntax-action (mk-register-action syntax-menu)) + (register-stepper-action (mk-register-action stepper-menu)) + (parent (send this get-area-container)) + (policy policy) + (macro-hiding? macro-hiding?) + (show-hiding-panel? show-hiding-panel?))) - (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")) + (define/public (get-widget) widget) + (frame:reorder-menus this) + )) - ;; 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))) + ;; macro-stepper-widget% + (define macro-stepper-widget% + (class* object% () + (init-field parent) + (init-field register-syntax-action) + (init-field register-stepper-action) + (init policy) + (init macro-hiding?) + (init show-hiding-panel?) - ;; 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 - (send sbview add-text "Normal form\n") - (send sbview add-syntax (lift/deriv-e2 synth-deriv))) - (when (step? step) - (when (pair? (step-lctx step)) - (for-each (lambda (bc) - (send sbview add-text "While executing macro transformer in:\n") - (send sbview add-syntax (cdr bc) (car bc) "MistyRose")) - (step-lctx step)) - (send sbview add-text "\n")) - (send sbview add-syntax - (step-e1 step) - (foci (step-redex step)) - "MistyRose") - (insert-step-separator (step-note step)) - (send sbview add-syntax - (step-e2 step) - (foci (step-contractum step)) - "LightCyan")) - (when (misstep? step) - (send sbview add-syntax - (misstep-e1 step) - (foci (misstep-redex step)) - "MistyRose") - (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)) - - (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) - #;(or (not steps) (not (cursor:can-move-previous? steps))))) - (send nav:down enable - (and (pair? derivs) - #;(or (not steps) (not (cursor:can-move-next? steps)))))) + ;; derivs : (list-of Derivation) + (define derivs null) - ;; -- + ;; synth-deriv : Derivation + (define synth-deriv #f) - ;; 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)) + ;; derivs-prefix : (list-of (cons Derivation Derivation)) + (define derivs-prefix null) - ;; 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)))) + (define steps #f) - ;; refresh/nontrivial : -> void - (define/private (refresh/nontrivial) - (let ([deriv (car derivs)]) - (with-handlers ([(lambda (e) (catch-errors?)) - (lambda (e) - (message-box - "Error" - "Internal error in macro stepper (reductions)") - (set! synth-deriv #f) - (set! steps (cursor:new null)))]) - (let ([d (synthesize deriv)]) - (let ([s (cursor:new (reduce d))]) - (set! synth-deriv d) - (set! steps s))))) - #;(navigate-to-start) - (update)) + (define warnings-frame #f) - ;; synthesize : Derivation -> Derivation - (define/private (synthesize deriv) - (let ([show-macro? (get-show-macro?)]) - (if show-macro? + (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)) + (when (null? (cdr derivs)) + ;; There is nothing currently displayed + (refresh)) + (update)) + + (define/public (get-controller) sbc) + (define/public (get-view) sbview) + + (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))) + (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))))) + + (register-stepper-action "Show/hide macro hiding configuration" + (lambda () (show/hide-macro-hiding-prefs))) + + (define/private (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 "Normal form\n") + (send sbview add-syntax (lift/deriv-e2 synth-deriv))) + (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") + (send sbview add-syntax (cdr bc) (car bc) "MistyRose")) + (step-lctx step)) + (send sbview add-text "\n")) + (send sbview add-syntax + (step-e1 step) + (foci (step-redex step)) + "MistyRose") + (insert-step-separator (step-note step)) + (send sbview add-syntax + (step-e2 step) + (foci (step-contractum step)) + "LightCyan")) + (when (misstep? step) + (send sbview add-syntax + (misstep-e1 step) + (foci (misstep-redex step)) + "MistyRose") + (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)) + + (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)]) (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)))) - (let-values ([(d s) (hide/policy deriv show-macro?)]) - d))) - deriv))) + (lambda (e) + (message-box + "Error" + "Internal error in macro stepper (reductions)") + (set! synth-deriv #f) + (set! steps (cursor:new null)))]) + (let ([d (synthesize deriv)]) + (let ([s (cursor:new (reduce d))]) + (set! synth-deriv d) + (set! steps s))))) + (update)) - (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)) + ;; 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)))) + (let-values ([(d s) (hide/policy deriv show-macro?)]) + d))) + deriv))) - ;; reduce : Derivation -> ReductionSequence - (define/private (reduce d) - (if (get-show-macro?) - (filter (lambda (x) (not (rename-step? x))) - (reductions d)) - (reductions d))) - - (define/private (foci x) (if (list? x) x (list x))) + (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)) - ;; Hiding policy + ;; reduce : Derivation -> ReductionSequence + (define/private (reduce d) + (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))) - (define/private (get-show-macro?) - (let ([policy (send macro-hiding-prefs get-policy)]) - (and policy (lambda (id) (policy-show-macro? policy id))))) + ;; Hiding policy - ;; -- + (define/private (get-show-macro?) + (let ([policy (send macro-hiding-prefs get-policy)]) + (and policy (lambda (id) (policy-show-macro? policy id))))) - (define/public (shutdown) - (when warnings-frame (send warnings-frame show #f))) + ;; -- - ;; Initialization - - (super-new) - (refresh))) + (define/public (shutdown) + (when warnings-frame (send warnings-frame show #f))) - ;; macro-hiding-prefs-widget% - (define macro-hiding-prefs-widget% - (class object% - (init parent) - (init-field stepper) - (init-field policy) - (init-field (enabled? #f)) + ;; Initialization + + (super-new) + (refresh))) - (define stx #f) - (define stx-name #f) - (define stx-module #f) + ;; macro-hiding-prefs-widget% + (define macro-hiding-prefs-widget% + (class object% + (init parent) + (init-field stepper) + (init-field policy) + (init-field (enabled? #f)) - (define super-pane - (new horizontal-pane% - (parent parent) - (stretchable-height #f))) - (define left-pane - (new vertical-pane% - (parent super-pane) - (stretchable-width #f) - (alignment '(left top)))) - (define right-pane - (new vertical-pane% - (parent super-pane))) + (define stx #f) + (define stx-name #f) + (define stx-module #f) - (define enable-ctl - (new check-box% - (label "Enable macro hiding?") - (parent left-pane) - (value enabled?) - (callback - (lambda _ - (set! enabled? (send enable-ctl get-value)) - (force-refresh))))) + (define super-pane + (new horizontal-pane% + (parent parent) + (stretchable-height #f))) + (define left-pane + (new vertical-pane% + (parent super-pane) + (stretchable-width #f) + (alignment '(left top)))) + (define right-pane + (new vertical-pane% + (parent super-pane))) - (define kernel-ctl - (new check-box% - (label "Hide mzscheme syntax") - (parent left-pane) - (value (hiding-policy-opaque-kernel policy)) - (callback (lambda _ - (if (send kernel-ctl get-value) - (policy-hide-kernel policy) - (policy-unhide-kernel policy)) - (refresh))))) - (define libs-ctl - (new check-box% - (label "Hide library syntax") - (parent left-pane) - (value (hiding-policy-opaque-libs policy)) - (callback (lambda _ - (if (send libs-ctl get-value) - (policy-hide-libs policy) - (policy-unhide-libs policy)) - (refresh))))) + (define enable-ctl + (new check-box% + (label "Enable macro hiding?") + (parent left-pane) + (value enabled?) + (callback + (lambda _ + (set! enabled? (send enable-ctl get-value)) + (force-refresh))))) - (define look-pane - (new horizontal-pane% (parent right-pane) (stretchable-height #f))) - (define look-ctl - (new list-box% (parent look-pane) (label "") (choices null))) - (define delete-ctl - (new button% (parent look-pane) (label "Delete") - (callback - (lambda _ - (delete-selected) - (refresh))))) + (define kernel-ctl + (new check-box% + (label "Hide mzscheme syntax") + (parent left-pane) + (value (hiding-policy-opaque-kernel policy)) + (callback (lambda _ + (if (send kernel-ctl get-value) + (policy-hide-kernel policy) + (policy-unhide-kernel policy)) + (refresh))))) + (define libs-ctl + (new check-box% + (label "Hide library syntax") + (parent left-pane) + (value (hiding-policy-opaque-libs policy)) + (callback (lambda _ + (if (send libs-ctl get-value) + (policy-hide-libs policy) + (policy-unhide-libs policy)) + (refresh))))) - (define add-pane - (new horizontal-pane% (parent right-pane) (stretchable-height #f))) - (define add-text - (new text-field% - (label "") - (parent add-pane) - #;(enabled #f) - (stretchable-width #t))) - (define add-editor (send add-text get-editor)) - (define add-hide-module-button - (new button% (parent add-pane) (label "Hide module") (enabled #f) - (callback (lambda _ (add-hide-module) (refresh))))) - (define add-hide-id-button - (new button% (parent add-pane) (label "Hide macro") (enabled #f) - (callback (lambda _ (add-hide-identifier) (refresh))))) - (define add-show-id-button - (new button% (parent add-pane) (label "Show macro") (enabled #f) - (callback (lambda _ (add-show-identifier) (refresh))))) + (define look-pane + (new horizontal-pane% (parent right-pane) (stretchable-height #f))) + (define look-ctl + (new list-box% (parent look-pane) (label "") (choices null))) + (define delete-ctl + (new button% (parent look-pane) (label "Delete") + (callback + (lambda _ + (delete-selected) + (refresh))))) - (send add-editor lock #t) - - ;; Methods + (define add-pane + (new horizontal-pane% (parent right-pane) (stretchable-height #f))) + (define add-text + (new text-field% + (label "") + (parent add-pane) + (stretchable-width #t))) + (define add-editor (send add-text get-editor)) + (define add-hide-module-button + (new button% (parent add-pane) (label "Hide module") (enabled #f) + (callback (lambda _ (add-hide-module) (refresh))))) + (define add-hide-id-button + (new button% (parent add-pane) (label "Hide macro") (enabled #f) + (callback (lambda _ (add-hide-identifier) (refresh))))) + (define add-show-id-button + (new button% (parent add-pane) (label "Show macro") (enabled #f) + (callback (lambda _ (add-show-identifier) (refresh))))) - ;; enable-hiding : boolean -> void - ;; Called only by stepper, which does it's own refresh - (define/public (enable-hiding ?) - (set! enabled? ?)) + (send add-editor lock #t) + + ;; Methods - ;; get-policy - (define/public (get-policy) (and enabled? policy)) + ;; enable-hiding : boolean -> void + ;; Called only by stepper, which does it's own refresh + (define/public (enable-hiding ?) + (set! enabled? ?)) - ;; refresh - (define/private (refresh) - (when enabled? - (send stepper refresh/resynth))) + ;; get-policy + (define/public (get-policy) (and enabled? policy)) - ;; force-refresh - (define/private (force-refresh) - (send stepper refresh/resynth)) + ;; refresh + (define/private (refresh) + (when enabled? + (send stepper refresh/resynth))) - ;; set-syntax : syntax/#f -> void - (define/public (set-syntax lstx) - (set! stx lstx) - (send add-editor lock #f) - (send add-editor erase) - (unless (identifier? stx) - (send add-hide-module-button enable #f)) - (when (identifier? stx) - (let ([binding (identifier-binding stx)]) - (send add-hide-module-button enable (pair? binding)) - (if (pair? binding) - (begin - (set! stx-name (cadr binding)) - (set! stx-module (car binding))) - (begin - (set! stx-name (syntax-e stx)) - (set! stx-module #f))) - (update-add-text))) - (send add-editor lock #t) - (send add-show-id-button enable (identifier? lstx)) - (send add-hide-id-button enable (identifier? lstx))) + ;; force-refresh + (define/private (force-refresh) + (send stepper refresh/resynth)) - (define/private (update-add-text) - (send add-editor lock #f) - (when (identifier? stx) - (send add-editor insert (identifier-text "" stx))) - (send add-editor lock #t)) + ;; set-syntax : syntax/#f -> void + (define/public (set-syntax lstx) + (set! stx lstx) + (send add-editor lock #f) + (send add-editor erase) + (unless (identifier? stx) + (send add-hide-module-button enable #f)) + (when (identifier? stx) + (let ([binding (identifier-binding stx)]) + (send add-hide-module-button enable (pair? binding)) + (if (pair? binding) + (begin + (set! stx-name (cadr binding)) + (set! stx-module (car binding))) + (begin + (set! stx-name (syntax-e stx)) + (set! stx-module #f))) + (update-add-text))) + (send add-editor lock #t) + (send add-show-id-button enable (identifier? lstx)) + (send add-hide-id-button enable (identifier? lstx))) - (define/private (add-hide-module) - (when stx-module - (policy-hide-module policy stx-module) - (update-list-view))) + (define/private (update-add-text) + (send add-editor lock #f) + (when (identifier? stx) + (send add-editor insert (identifier-text "" stx))) + (send add-editor lock #t)) - (define/private (add-hide-identifier) - (when (identifier? stx) - (policy-hide-id policy stx) - (update-list-view))) + (define/private (add-hide-module) + (when stx-module + (policy-hide-module policy stx-module) + (update-list-view))) - (define/private (add-show-identifier) - (when (identifier? stx) - (policy-show-id policy stx) - (update-list-view))) + (define/private (add-hide-identifier) + (when (identifier? stx) + (policy-hide-id policy stx) + (update-list-view))) - (define/private (delete-selected) - (for-each (lambda (n) - (let ([d (send look-ctl get-data n)]) - (case (car d) - ((identifier) (policy-unhide-id policy (cdr d))) - ((show-identifier) (policy-unshow-id policy (cdr d))) - ((module) (policy-unhide-module policy (cdr d)))))) - (send look-ctl get-selections)) - (update-list-view)) + (define/private (add-show-identifier) + (when (identifier? stx) + (policy-show-id policy stx) + (update-list-view))) - (define/private (identifier-text prefix id) - (let ([b (identifier-binding id)]) - (cond [(pair? b) - (let ([name (cadr b)] - [mod (car b)]) - (format "~a'~s' from module ~a" - prefix - name - (mpi->string mod)))] - [(eq? b 'lexical) - (format "~alexically bound '~s'" - prefix - (syntax-e id))] - [(not b) - (format "~aglobal or unbound '~s'" prefix (syntax-e id))]))) + (define/private (delete-selected) + (for-each (lambda (n) + (let ([d (send look-ctl get-data n)]) + (case (car d) + ((identifier) (policy-unhide-id policy (cdr d))) + ((show-identifier) (policy-unshow-id policy (cdr d))) + ((module) (policy-unhide-module policy (cdr d)))))) + (send look-ctl get-selections)) + (update-list-view)) - (define/private (update-list-view) - (let ([opaque-modules - (hash-table-map (hiding-policy-opaque-modules policy) - (lambda (k v) k))] - [opaque-ids - (filter values - (module-identifier-mapping-map - (hiding-policy-opaque-ids policy) - (lambda (k v) (and v k))))] - [transparent-ids - (filter values - (module-identifier-mapping-map - (hiding-policy-transparent-ids policy) - (lambda (k v) (and v k))))]) - (define (om s) - (cons (format "hide from module ~a" (mpi->string s)) - (cons 'module s))) - (define (*i prefix tag id) - (cons (identifier-text prefix id) - (cons tag id))) - (define (oid id) (*i "hide " 'identifier id)) - (define (tid id) (*i "show " 'show-identifier id)) - (let ([choices - (sort (append (map om opaque-modules) - (map oid opaque-ids) - (map tid transparent-ids)) - (lambda (a b) - (string<=? (car a) (car b))))]) - (send look-ctl clear) - (for-each (lambda (c) (send look-ctl append (car c) (cdr c))) - choices)))) + (define/private (identifier-text prefix id) + (let ([b (identifier-binding id)]) + (cond [(pair? b) + (let ([name (cadr b)] + [mod (car b)]) + (format "~a'~s' from module ~a" + prefix + name + (mpi->string mod)))] + [(eq? b 'lexical) + (format "~alexically bound '~s'" + prefix + (syntax-e id))] + [(not b) + (format "~aglobal or unbound '~s'" prefix (syntax-e id))]))) - (super-new))) + (define/private (update-list-view) + (let ([opaque-modules + (hash-table-map (hiding-policy-opaque-modules policy) + (lambda (k v) k))] + [opaque-ids + (filter values + (module-identifier-mapping-map + (hiding-policy-opaque-ids policy) + (lambda (k v) (and v k))))] + [transparent-ids + (filter values + (module-identifier-mapping-map + (hiding-policy-transparent-ids policy) + (lambda (k v) (and v k))))]) + (define (om s) + (cons (format "hide from module ~a" (mpi->string s)) + (cons 'module s))) + (define (*i prefix tag id) + (cons (identifier-text prefix id) + (cons tag id))) + (define (oid id) (*i "hide " 'identifier id)) + (define (tid id) (*i "show " 'show-identifier id)) + (let ([choices + (sort (append (map om opaque-modules) + (map oid opaque-ids) + (map tid transparent-ids)) + (lambda (a b) + (string<=? (car a) (car b))))]) + (send look-ctl clear) + (for-each (lambda (c) (send look-ctl append (car c) (cdr c))) + choices)))) - ;; warnings-frame% - (define warnings-frame% - (class frame% - (super-new (label "Macro stepper warnings") (width 400) (height 300)) + (super-new))) - (define text (new text% (auto-wrap #t))) - (define ec (new editor-canvas% (parent this) (editor text))) - (send text lock #t) + ;; warnings-frame% + (define warnings-frame% + (class frame% + (super-new (label "Macro stepper warnings") (width 400) (height 300)) - (define -nonlinearity-text #f) - (define -localactions-text #f) + (define text (new text% (auto-wrap #t))) + (define ec (new editor-canvas% (parent this) (editor text))) + (send text lock #t) - (define/private (add-nonlinearity-text) - (unless -nonlinearity-text - (set! -nonlinearity-text #t) - (add-text "An opaque macro duplicated one of its subterms. " - "Macro hiding requires opaque macros to use their subterms linearly. " - "The macro stepper is showing the expansion of that macro use."))) - (define/private (add-localactions-text) - (unless -localactions-text - (set! -localactions-text #t) - (add-text "An opaque macro called local-expand, syntax-local-lift-expression, " - "etc. Macro hiding cannot currently handle local actions. " - "The macro stepper is showing the expansion of that macro use."))) + (define -nonlinearity-text #f) + (define -localactions-text #f) - (define/private (add-text . strs) - (send text lock #f) - (for-each (lambda (s) (send text insert s)) strs) - (send text insert "\n\n") - (send text lock #t)) + (define/private (add-nonlinearity-text) + (unless -nonlinearity-text + (set! -nonlinearity-text #t) + (add-text "An opaque macro duplicated one of its subterms. " + "Macro hiding requires opaque macros to use their subterms linearly. " + "The macro stepper is showing the expansion of that macro use."))) + (define/private (add-localactions-text) + (unless -localactions-text + (set! -localactions-text #t) + (add-text "An opaque macro called local-expand, syntax-local-lift-expression, " + "etc. Macro hiding cannot currently handle local actions. " + "The macro stepper is showing the expansion of that macro use."))) - (define/public (add-warning tag) - (case tag - ((nonlinearity) - (add-nonlinearity-text)) - ((localactions) - (add-nonlinearity-text)))) + (define/private (add-text . strs) + (send text lock #f) + (for-each (lambda (s) (send text insert s)) strs) + (send text insert "\n\n") + (send text lock #t)) - (send this show #t))) + (define/public (add-warning tag) + (case tag + ((nonlinearity) + (add-nonlinearity-text)) + ((localactions) + (add-nonlinearity-text)))) - ;; Main entry points + (send this show #t))) - (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)])) + ;; Main entry points - (define (go stx) - (let ([stepper (make-macro-stepper)]) - (send stepper add-deriv (trace stx)))) + (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/deriv deriv) - (let* ([f (new macro-stepper-frame%)] - [w (send f get-widget)]) - (send w add-deriv deriv) - (send f show #t) - w)) + (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)) + )) + ) diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.ss new file mode 100644 index 0000000000..166e398c90 --- /dev/null +++ b/collects/macro-debugger/view/view.ss @@ -0,0 +1,13 @@ + +(module view mzscheme + (require (lib "unitsig.ss")) + (require "gui.ss") + (provide (all-defined)) + + (define-values/invoke-unit/sig view^ + (compound-unit/sig + (import) + (link (BASE : view-base^ (view-base@)) + (VIEW : view^ (view@ BASE))) + (export (open VIEW)))) + ) \ No newline at end of file