From 8f08e40c41b47fae20b64e104c21b14046056afd Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 14 Jan 2009 06:04:57 +0000 Subject: [PATCH] macro stepper: converted more classes to use iop svn: r13108 original commit: 2aeb50134d2775eb8d0a0a9e3faa18d570c2fd19 --- .../syntax-browser/interfaces.ss | 57 +++---- .../macro-debugger/syntax-browser/keymap.ss | 1 - .../macro-debugger/syntax-browser/widget.ss | 2 +- collects/macro-debugger/view/extensions.ss | 25 +-- collects/macro-debugger/view/frame.ss | 36 ++-- collects/macro-debugger/view/hiding-panel.ss | 10 +- collects/macro-debugger/view/interfaces.ss | 107 +++++++----- collects/macro-debugger/view/step-display.ss | 161 ++++++++---------- collects/macro-debugger/view/stepper.ss | 126 ++++++-------- collects/macro-debugger/view/term-record.ss | 50 +++--- collects/macro-debugger/view/view.ss | 42 +---- 11 files changed, 291 insertions(+), 326 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 49096d5..32cbf6d 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -1,11 +1,10 @@ - #lang scheme/base (require scheme/class macro-debugger/util/class-iop) (provide (all-defined-out)) ;; displays-manager<%> -(define-interface displays-manager<%> +(define-interface displays-manager<%> () (;; add-syntax-display : display<%> -> void add-syntax-display @@ -13,7 +12,7 @@ remove-all-syntax-displays)) ;; selection-manager<%> -(define-interface selection-manager<%> +(define-interface selection-manager<%> () (;; selected-syntax : syntax/#f set-selected-syntax get-selected-syntax @@ -21,12 +20,15 @@ ;; mark-manager<%> ;; Manages marks, mappings from marks to colors -(define-interface mark-manager<%> +(define-interface mark-manager<%> () (;; get-primary-partition : -> partition - get-primary-partition)) + get-primary-partition + + ;; reset-primary-partition : -> void + reset-primary-partition)) ;; secondary-partition<%> -(define-interface secondary-partition<%> +(define-interface secondary-partition<%> () (;; get-secondary-partition : -> partition<%> get-secondary-partition @@ -46,27 +48,15 @@ listen-identifier=?)) ;; controller<%> -(define-interface/dynamic controller<%> - (interface (displays-manager<%> - selection-manager<%> - mark-manager<%> - secondary-partition<%>)) - (add-syntax-display - remove-all-syntax-displays - set-selected-syntax - get-selected-syntax - listen-selected-syntax - get-primary-partition - get-secondary-partition - set-secondary-partition - listen-secondary-partition - get-identifier=? - set-identifier=? - listen-identifier=?)) +(define-interface controller<%> (displays-manager<%> + selection-manager<%> + mark-manager<%> + secondary-partition<%>) + ()) ;; host<%> -(define-interface host<%> +(define-interface host<%> () (;; get-controller : -> controller<%> get-controller @@ -74,7 +64,7 @@ add-keymap)) ;; display<%> -(define-interface display<%> +(define-interface display<%> () (;; refresh : -> void refresh @@ -94,7 +84,7 @@ get-range)) ;; range<%> -(define-interface range<%> +(define-interface range<%> () (;; get-ranges : datum -> (list-of (cons number number)) get-ranges @@ -111,14 +101,14 @@ ;; syntax-prefs<%> -(define-interface syntax-prefs<%> +(define-interface syntax-prefs<%> () (pref:width pref:height pref:props-percentage pref:props-shown?)) ;; widget-hooks<%> -(define-interface widget-hooks<%> +(define-interface widget-hooks<%> () (;; setup-keymap : -> void setup-keymap @@ -126,7 +116,7 @@ shutdown)) ;; keymap-hooks<%> -(define-interface keymap-hooks<%> +(define-interface keymap-hooks<%> () (;; make-context-menu : -> context-menu<%> make-context-menu @@ -134,7 +124,7 @@ get-context-menu%)) ;; context-menu-hooks<%> -(define-interface context-menu-hooks<%> +(define-interface context-menu-hooks<%> () (add-edit-items after-edit-items add-selection-items @@ -146,15 +136,16 @@ ;;---------- ;; Convenience widget, specialized for displaying stx and not much else -(define-interface syntax-browser<%> +(define-interface syntax-browser<%> () (add-syntax add-text + add-error-text + add-clickback add-separator erase-all - select-syntax get-text)) -(define-interface partition<%> +(define-interface partition<%> () (;; get-partition : any -> number get-partition diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss index 40c29d4..7bc7c8f 100644 --- a/collects/macro-debugger/syntax-browser/keymap.ss +++ b/collects/macro-debugger/syntax-browser/keymap.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require scheme/class scheme/gui diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index d7eba23..51ab11e 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -21,7 +21,7 @@ ;; widget% ;; A syntax widget creates its own syntax-controller. (define widget% - (class* object% (widget-hooks<%>) + (class* object% (syntax-browser<%> widget-hooks<%>) (init parent) (init-field config) diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss index d28ed57..64a8779 100644 --- a/collects/macro-debugger/view/extensions.ss +++ b/collects/macro-debugger/view/extensions.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/unit scheme/list scheme/match @@ -13,6 +14,7 @@ "hiding-panel.ss" (prefix-in s: "../syntax-browser/widget.ss") (prefix-in s: "../syntax-browser/keymap.ss") + (prefix-in s: "../syntax-browser/interfaces.ss") "../model/deriv.ss" "../model/deriv-util.ss" "../model/trace.ss" @@ -26,7 +28,7 @@ (define stepper-keymap% (class s:syntax-keymap% - (init-field macro-stepper) + (init-field: (macro-stepper widget<%>)) (inherit-field config controller the-context-menu) @@ -39,17 +41,17 @@ (super-new) (define/public (get-hiding-panel) - (send macro-stepper get-macro-hiding-prefs)) + (send: macro-stepper widget<%> get-macro-hiding-prefs)) (add-function "hiding:show-macro" (lambda (i e) - (send* (get-hiding-panel) + (send*: (get-hiding-panel) hiding-prefs<%> (add-show-identifier) (refresh)))) (add-function "hiding:hide-macro" (lambda (i e) - (send* (get-hiding-panel) + (send*: (get-hiding-panel) hiding-prefs<%> (add-hide-identifier) (refresh)))) @@ -75,26 +77,27 @@ (send show-macro enable ?) (send hide-macro enable ?)) - (send controller listen-selected-syntax - (lambda (stx) - (enable/disable-hide/show (identifier? stx)))))) + (send: controller s:controller<%> listen-selected-syntax + (lambda (stx) + (enable/disable-hide/show (identifier? stx)))))) (define stepper-syntax-widget% (class s:widget% - (init-field macro-stepper) + (init-field: (macro-stepper widget<%>)) (inherit get-text) (inherit-field controller) (define/override (setup-keymap) (new stepper-keymap% (editor (get-text)) - (config (send macro-stepper get-config)) + (config (send: macro-stepper widget<%> get-config)) (controller controller) (macro-stepper macro-stepper))) (define/override (show-props show?) (super show-props show?) - (send macro-stepper update/preserve-view)) + (send: macro-stepper widget<%> update/preserve-view)) (super-new - (config (send macro-stepper get-config))))) + (config (send: macro-stepper widget<%> get-config))))) + diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 29688ba..856c5bb 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/unit scheme/list scheme/file @@ -14,6 +15,7 @@ "warning.ss" "hiding-panel.ss" (prefix-in sb: "../syntax-browser/embed.ss") + (prefix-in sb: "../syntax-browser/interfaces.ss") "../model/deriv.ss" "../model/deriv-util.ss" "../model/trace.ss" @@ -23,7 +25,7 @@ (provide macro-stepper-frame-mixin) (define (macro-stepper-frame-mixin base-frame%) - (class base-frame% + (class* base-frame% (stepper-frame<%>) (init-field config) (init-field director) (init-field (filename #f)) @@ -54,7 +56,7 @@ (define/override (on-size w h) (send config set-width w) (send config set-height h) - (send widget update/preserve-view)) + (send: widget widget<%> update/preserve-view)) (define warning-panel (new horizontal-panel% @@ -65,12 +67,13 @@ (define/public (get-macro-stepper-widget%) macro-stepper-widget%) - (define widget + (define: widget widget<%> (new (get-macro-stepper-widget%) (parent (get-area-container)) (director director) (config config))) - (define controller (send widget get-controller)) + (define: controller sb:controller<%> + (send: widget widget<%> get-controller)) (define/public (get-widget) widget) (define/public (get-controller) controller) @@ -112,11 +115,11 @@ (new (get-menu-item%) (label "Duplicate stepper") (parent file-menu) - (callback (lambda _ (send widget duplicate-stepper)))) + (callback (lambda _ (send: widget widget<%> duplicate-stepper)))) (new (get-menu-item%) (label "Duplicate stepper (current term only)") (parent file-menu) - (callback (lambda _ (send widget show-in-new-frame))))) + (callback (lambda _ (send: widget widget<%> show-in-new-frame))))) (menu-option/notify-box stepper-menu "View syntax properties" @@ -133,23 +136,24 @@ (parent id-menu) (callback (lambda _ - (send controller set-identifier=? p))))]) - (send controller listen-identifier=? - (lambda (name+func) - (send this-choice check - (eq? (car name+func) (car p))))))) + (send: controller sb:controller<%> set-identifier=? p))))]) + (send: controller sb:controller<%> listen-identifier=? + (lambda (name+func) + (send this-choice check + (eq? (car name+func) (car p))))))) (sb:identifier=-choices))) (let ([identifier=? (send config get-identifier=?)]) (when identifier=? (let ([p (assoc identifier=? (sb:identifier=-choices))]) - (send controller set-identifier=? p)))) + (send: controller sb:controller<%> set-identifier=? p)))) (new (get-menu-item%) (label "Clear selection") (parent stepper-menu) (callback - (lambda _ (send controller set-selected-syntax #f)))) + (lambda _ (send: controller sb:controller<%> + set-selected-syntax #f)))) (new separator-menu-item% (parent stepper-menu)) @@ -160,11 +164,11 @@ (new (get-menu-item%) (label "Remove selected term") (parent stepper-menu) - (callback (lambda _ (send widget remove-current-term)))) + (callback (lambda _ (send: widget widget<%> remove-current-term)))) (new (get-menu-item%) (label "Reset mark numbering") (parent stepper-menu) - (callback (lambda _ (send widget reset-primary-partition)))) + (callback (lambda _ (send: widget widget<%> reset-primary-partition)))) (let ([extras-menu (new (get-menu%) (label "Extra options") @@ -178,7 +182,7 @@ (if (send i is-checked?) 'always 'over-limit)) - (send widget update/preserve-view)))) + (send: widget widget<%> update/preserve-view)))) (menu-option/notify-box extras-menu "Highlight redex/contractum" (get-field highlight-foci? config)) diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index def4189..9933549 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -1,9 +1,11 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/gui scheme/list syntax/boundmap + "interfaces.ss" "../model/hiding-policies.ss" "../util/mpi.ss" "../util/notify.ss") @@ -16,9 +18,9 @@ ;; macro-hiding-prefs-widget% (define macro-hiding-prefs-widget% - (class object% + (class* object% (hiding-prefs<%>) (init parent) - (init-field stepper) + (init-field: (stepper widget<%>)) (init-field config) (define/public (get-policy) @@ -173,11 +175,11 @@ ;; refresh : -> void (define/public (refresh) (when (macro-hiding-enabled?) - (send stepper refresh/resynth))) + (send: stepper widget<%> refresh/resynth))) ;; force-refresh : -> void (define/private (force-refresh) - (send stepper refresh/resynth)) + (send: stepper widget<%> refresh/resynth)) ;; set-syntax : syntax/#f -> void (define/public (set-syntax lstx) diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss index e374aaa..4d9e19a 100644 --- a/collects/macro-debugger/view/interfaces.ss +++ b/collects/macro-debugger/view/interfaces.ss @@ -1,50 +1,75 @@ #lang scheme/base -(require scheme/unit) +(require macro-debugger/util/class-iop) (provide (all-defined-out)) -;; Signatures +(define-interface widget<%> () + (get-config + get-controller + get-macro-hiding-prefs + get-step-displayer -#; -(define-signature view^ - (macro-stepper-frame% - macro-stepper-widget% - make-macro-stepper - go - go/deriv)) + add-trace + add-deriv -#; -(define-signature view-base^ - (base-frame%)) + update/preserve-view + refresh/resynth -#; -(define-signature prefs^ - (pref:width - pref:height - pref:props-shown? - pref:props-percentage - pref:macro-hiding-mode - pref:show-syntax-properties? - pref:show-hiding-panel? - pref:identifier=? - pref:show-rename-steps? - pref:highlight-foci? - pref:highlight-frontier? - pref:suppress-warnings? - pref:one-by-one? - pref:extra-navigation? - pref:debug-catch-errors? - pref:force-letrec-transformation? + reset-primary-partition + remove-current-term + duplicate-stepper + show-in-new-frame + + get-preprocess-deriv + get-show-macro? +)) + +(define-interface stepper-frame<%> () + (get-widget + get-controller + add-obsoleted-warning)) + +(define-interface hiding-prefs<%> () + (add-show-identifier + add-hide-identifier + set-syntax + get-policy + refresh)) + + +(define-interface step-display<%> () + (add-syntax + add-step + add-error + add-final + add-internal-error)) + + +(define-interface term-record<%> () + (get-raw-deriv + get-deriv-hidden? + get-step-index + invalidate-synth! + invalidate-steps! + + has-prev? + has-next? + at-start? + at-end? + navigate-to-start + navigate-to-end + navigate-previous + navigate-next + navigate-to + + on-get-focus + on-lose-focus + + display-initial-term + display-final-term + display-step )) -;; macro-stepper-config% -;; all fields are notify-box% objects -;; width -;; height -;; macro-hiding? -;; hide-primitives? -;; hide-libs? -;; show-syntax-properties? -;; show-hiding-panel? -;; show-rename-steps? -;; highlight-foci? +(define-interface director<%> () + (add-deriv + new-stepper)) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index 5894078..d1af9a8 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/unit scheme/list scheme/match @@ -21,8 +22,10 @@ "../model/reductions.ss" "../model/steps.ss" "../util/notify.ss" + (prefix-in sb: "../syntax-browser/interfaces.ss") "cursor.ss" "debug-format.ss") + #; (provide step-display% step-display<%>) @@ -35,24 +38,6 @@ (define (prestep-term1 s) (state-term (protostep-s1 s))) (define (poststep-term2 s) (state-term (protostep-s1 s))) - -(define step-display<%> - (interface () - ;; add-syntax - add-syntax - - ;; add-step - add-step - - ;; add-error - add-error - - ;; add-final - add-final - - ;; add-internal-error - add-internal-error)) - (define step-display% (class* object% (step-display<%>) @@ -61,18 +46,18 @@ (super-new) (define/public (add-internal-error part exn stx events) - (send sbview add-text - (if part - (format "Macro stepper error (~a)" part) - "Macro stepper error")) + (send: sbview sb:syntax-browser<%> 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 events)))) - (send sbview add-text ". ") - (when stx (send sbview add-text "Original syntax:")) - (send sbview add-text "\n") - (when stx (send sbview add-syntax stx))) + (send: sbview sb:syntax-browser<%> add-text " ") + (send: sbview sb:syntax-browser<%> add-clickback "[details]" + (lambda _ (show-internal-error-details exn events)))) + (send: sbview sb:syntax-browser<%> add-text ". ") + (when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:")) + (send: sbview sb:syntax-browser<%> add-text "\n") + (when stx (send: sbview sb:syntax-browser<%> add-syntax stx))) (define/private (show-internal-error-details exn events) (case (message-box/custom "Macro stepper internal error" @@ -91,8 +76,9 @@ ((3 #f) (void)))) (define/public (add-error exn) - (send sbview add-error-text (exn-message exn)) - (send sbview add-text "\n")) + (send*: sbview sb:syntax-browser<%> + (add-error-text (exn-message exn)) + (add-text "\n"))) (define/public (add-step step #:binders binders @@ -110,21 +96,22 @@ #:binders [binders #f] #:shift-table [shift-table #f] #:definites [definites null]) - (send sbview add-syntax stx - #:binder-table binders - #:shift-table shift-table - #:definites definites)) + (send: sbview sb:syntax-browser<%> add-syntax stx + #:binder-table binders + #:shift-table shift-table + #:definites definites)) (define/public (add-final stx error #:binders binders #:shift-table [shift-table #f] #:definites definites) (when stx - (send sbview add-text "Expansion finished\n") - (send sbview add-syntax stx - #:binder-table binders - #:shift-table shift-table - #:definites definites)) + (send*: sbview sb:syntax-browser<%> + (add-text "Expansion finished\n") + (add-syntax stx + #:binder-table binders + #:shift-table shift-table + #:definites definites))) (when error (add-error error))) @@ -133,17 +120,16 @@ (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 - shift-table - (state-uses state) - (state-frontier state))) - (reverse lctx)))) + (send: sbview sb:syntax-browser<%> add-text "\n") + (for ([bf (reverse lctx)]) + (send: sbview sb:syntax-browser<%> add-text + "while executing macro transformer in:\n") + (insert-syntax/redex (bigframe-term bf) + (bigframe-foci bf) + binders + shift-table + (state-uses state) + (state-frontier state))))) ;; separator : Step -> void (define/private (separator step) @@ -194,15 +180,15 @@ (define state (protostep-s1 step)) (show-state/redex state binders shift-table) (separator step) - (send sbview add-error-text (exn-message (misstep-exn step))) - (send sbview add-text "\n") + (send*: sbview sb:syntax-browser<%> + (add-error-text (exn-message (misstep-exn step))) + (add-text "\n")) (when (exn:fail:syntax? (misstep-exn step)) - (for-each (lambda (e) - (send sbview add-syntax e - #:binder-table binders - #:shift-table shift-table - #:definites (or (state-uses state) null))) - (exn:fail:syntax-exprs (misstep-exn step)))) + (for ([e (exn:fail:syntax-exprs (misstep-exn step))]) + (send: sbview sb:syntax-browser<%> add-syntax e + #:binder-table binders + #:shift-table shift-table + #:definites (or (state-uses state) null)))) (show-lctx step binders shift-table)) ;; insert-syntax/color @@ -210,14 +196,14 @@ definites frontier hi-color) (define highlight-foci? (send config get-highlight-foci?)) (define highlight-frontier? (send config get-highlight-frontier?)) - (send sbview add-syntax stx - #:definites (or definites null) - #:binder-table binders - #:shift-table shift-table - #:hi-colors (list hi-color - "WhiteSmoke") - #:hi-stxss (list (if highlight-foci? foci null) - (if highlight-frontier? frontier null)))) + (send: sbview sb:syntax-browser<%> add-syntax stx + #:definites (or definites null) + #:binder-table binders + #:shift-table shift-table + #:hi-colors (list hi-color + "WhiteSmoke") + #:hi-stxss (list (if highlight-foci? foci null) + (if highlight-frontier? frontier null)))) ;; insert-syntax/redex (define/private (insert-syntax/redex stx foci binders shift-table @@ -233,29 +219,32 @@ ;; 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")) + (send*: sbview sb:syntax-browser<%> + (add-text "\n ") + (add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (add-text " ") + (add-text text) + (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")) + (send*: sbview sb:syntax-browser<%> + (add-text "\n ") + (add-text text) + (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")) + (send*: sbview sb:syntax-browser<%> + (add-text " ") + (add-text + (make-object image-snip% + (build-path (collection-path "icons") + "red-arrow.bmp"))) + (add-text " ") + (add-text text) + (add-text "\n\n"))) )) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 640e06e..c731972 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/unit scheme/list scheme/match @@ -14,6 +15,7 @@ "hiding-panel.ss" "term-record.ss" "step-display.ss" + (prefix-in sb: "../syntax-browser/interfaces.ss") "../model/deriv.ss" "../model/deriv-util.ss" "../model/deriv-find.ss" @@ -29,10 +31,10 @@ ;; macro-stepper-widget% (define macro-stepper-widget% - (class* object% () + (class* object% (widget<%>) (init-field parent) (init-field config) - (init-field director) + (init-field: (director director<%>)) ;; Terms @@ -65,7 +67,7 @@ (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?)]) + [invisible? (send: trec term-record<%> get-deriv-hidden?)]) (unless invisible? (cursor:add-to-end! terms (list trec)) (trim-navigator) @@ -83,15 +85,16 @@ (define/public (show-in-new-frame) (let ([term (focused-term)]) (when term - (let ([new-stepper (send director new-stepper '(no-new-traces))]) - (send new-stepper add-deriv (send term get-raw-deriv)) + (let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))]) + (send: new-stepper widget<%> add-deriv (send term get-raw-deriv)) (void))))) ;; duplicate-stepper : -> void (define/public (duplicate-stepper) - (let ([new-stepper (send director new-stepper)]) + (let ([new-stepper (send: director director<%> new-stepper)]) (for ([term (cursor->list terms)]) - (send new-stepper add-deriv (send term get-raw-deriv))))) + (send: new-stepper widget<%> add-deriv + (send: term term-record<%> get-raw-deriv))))) (define/public (get-config) config) (define/public (get-controller) sbc) @@ -101,7 +104,7 @@ (define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define/public (reset-primary-partition) - (send sbc reset-primary-partition) + (send: sbc sb:controller<%> reset-primary-partition) (update/preserve-view)) (define area (new vertical-panel% (parent parent))) @@ -126,16 +129,19 @@ (define warnings-area (new stepper-warnings% (parent area))) - (define sbview (new stepper-syntax-widget% - (parent area) - (macro-stepper this))) - (define step-displayer (new step-display% - (config config) - (syntax-widget sbview))) - (define sbc (send sbview get-controller)) + (define: sbview sb:syntax-browser<%> + (new stepper-syntax-widget% + (parent area) + (macro-stepper this))) + (define: step-displayer step-display<%> + (new step-display% + (config config) + (syntax-widget sbview))) + (define: sbc sb:controller<%> + (send sbview get-controller)) (define control-pane (new vertical-panel% (parent area) (stretchable-height #f))) - (define macro-hiding-prefs + (define: macro-hiding-prefs hiding-prefs<%> (new macro-hiding-prefs-widget% (parent control-pane) (stepper this) @@ -144,7 +150,7 @@ (send config listen-show-hiding-panel? (lambda (show?) (show-macro-hiding-panel show?))) (send sbc listen-selected-syntax - (lambda (stx) (send macro-hiding-prefs set-syntax stx))) + (lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx))) (send config listen-highlight-foci? (lambda (_) (update/preserve-view))) (send config listen-highlight-frontier? @@ -233,34 +239,34 @@ ;; Navigation (define/public-final (at-start?) - (send (focused-term) at-start?)) + (send: (focused-term) term-record<%> at-start?)) (define/public-final (at-end?) - (send (focused-term) at-end?)) + (send: (focused-term) term-record<%> at-end?)) (define/public-final (navigate-to-start) - (send (focused-term) navigate-to-start) + (send: (focused-term) term-record<%> navigate-to-start) (update/save-position)) (define/public-final (navigate-to-end) - (send (focused-term) navigate-to-end) + (send: (focused-term) term-record<%> navigate-to-end) (update/save-position)) (define/public-final (navigate-previous) - (send (focused-term) navigate-previous) + (send: (focused-term) term-record<%> navigate-previous) (update/save-position)) (define/public-final (navigate-next) - (send (focused-term) navigate-next) + (send: (focused-term) term-record<%> navigate-next) (update/save-position)) (define/public-final (navigate-to n) - (send (focused-term) navigate-to n) + (send: (focused-term) term-record<%> navigate-to n) (update/save-position)) (define/public-final (navigate-up) (when (focused-term) - (send (focused-term) on-lose-focus)) + (send: (focused-term) term-record<%> on-lose-focus)) (cursor:move-prev terms) (refresh/move)) (define/public-final (navigate-down) (when (focused-term) - (send (focused-term) on-lose-focus)) + (send: (focused-term) term-record<%> on-lose-focus)) (cursor:move-next terms) (refresh/move)) @@ -272,7 +278,7 @@ ;; update/preserve-lines-view : -> void (define/public (update/preserve-lines-view) - (define text (send sbview get-text)) + (define text (send: sbview sb:syntax-browser<%> get-text)) (define start-box (box 0)) (define end-box (box 0)) (send text get-visible-line-range start-box end-box) @@ -285,7 +291,7 @@ ;; update/preserve-view : -> void (define/public (update/preserve-view) - (define text (send sbview get-text)) + (define text (send: sbview sb:syntax-browser<%> get-text)) (define start-box (box 0)) (define end-box (box 0)) (send text get-visible-position-range start-box end-box) @@ -295,17 +301,17 @@ ;; update : -> void ;; Updates the terms in the syntax browser to the current step (define/private (update) - (define text (send sbview get-text)) + (define text (send: sbview sb:syntax-browser<%> get-text)) (define position-of-interest 0) (define multiple-terms? (> (length (cursor->list terms)) 1)) (send text begin-edit-sequence) - (send sbview erase-all) + (send: sbview sb:syntax-browser<%> erase-all) (update:show-prefix) - (when multiple-terms? (send sbview add-separator)) + (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator)) (set! position-of-interest (send text last-position)) (update:show-current-step) - (when multiple-terms? (send sbview add-separator)) + (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator)) (update:show-suffix) (send text end-edit-sequence) (send text scroll-to-position @@ -319,35 +325,35 @@ ;; update:show-prefix : -> void (define/private (update:show-prefix) ;; Show the final terms from the cached synth'd derivs - (for-each (lambda (trec) (send trec display-final-term)) + (for-each (lambda (trec) (send: trec term-record<%> display-final-term)) (cursor:prefix->list terms))) ;; update:show-current-step : -> void (define/private (update:show-current-step) (when (focused-term) - (send (focused-term) display-step))) + (send: (focused-term) term-record<%> 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 trec display-initial-term)) + (send: trec term-record<%> display-initial-term)) (cdr suffix0))))) ;; update-nav-index : -> void (define/private (update-nav-index) (define term (focused-term)) (set-current-step-index - (and term (send term get-step-index)))) + (and term (send: term term-record<%> get-step-index)))) ;; enable/disable-buttons : -> void (define/private (enable/disable-buttons) (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:start enable (and term (send: term term-record<%> has-prev?))) + (send nav:previous enable (and term (send: term term-record<%> has-prev?))) + (send nav:next enable (and term (send: term term-record<%> has-next?))) + (send nav:end enable (and term (send: term term-record<%> has-next?))) (send nav:text enable (and term #t)) (send nav:up enable (cursor:has-prev? terms)) (send nav:down enable (cursor:has-next? terms))) @@ -357,14 +363,14 @@ ;; refresh/resynth : -> void ;; Macro hiding policy has changed; invalidate cached parts of trec (define/public (refresh/resynth) - (for-each (lambda (trec) (send trec invalidate-synth!)) + (for-each (lambda (trec) (send: trec term-record<%> 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 (lambda (trec) (send trec invalidate-steps!)) + (for-each (lambda (trec) (send: trec term-record<%> invalidate-steps!)) (cursor->list terms)) (refresh)) @@ -377,47 +383,15 @@ (define/public (refresh) (send warnings-area clear) (when (focused-term) - (send (focused-term) on-get-focus)) + (send: (focused-term) term-record<%> on-get-focus)) (update)) -#| - ;; delayed-recache-errors : (list-of (cons exn string)) - (define delayed-recache-errors null) - - ;; handle-recache-error : exception string -> void - (define/private (handle-recache-error exn part) - (if (send config get-debug-catch-errors?) - (begin - (set! delayed-recache-errors - (cons (cons exn part) delayed-recache-errors)) - (queue-callback - (lambda () - (when (pair? delayed-recache-errors) - (message-box - "Error" - (string-append - "Internal errors in macro stepper:\n" - (if (memq 'macro-hiding (map cdr delayed-recache-errors)) - (string-append - "Macro hiding failed on one or more terms. " - "The macro stepper is showing the terms " - "with macro hiding disabled.\n") - "") - (if (memq 'reductions (map cdr delayed-recache-errors)) - (string-append - "The macro stepper failed to compute the reduction sequence " - "for one or more terms.\n") - ""))) - (set! delayed-recache-errors null))))) - (raise exn))) -|# - (define/private (foci x) (if (list? x) x (list x))) ;; Hiding policy (define/public (get-show-macro?) - (send macro-hiding-prefs get-policy)) + (send: macro-hiding-prefs hiding-prefs<%> get-policy)) ;; Derivation pre-processing diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index e924a05..4c1fdf9 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/unit scheme/list scheme/match @@ -30,11 +31,12 @@ ;; TermRecords (define term-record% - (class object% - (init-field stepper) + (class* object% (term-record<%>) + (init-field: (stepper widget<%>)) (define config (send stepper get-config)) - (define displayer (send stepper get-step-displayer)) + (define: displayer step-display<%> + (send: stepper widget<%> get-step-displayer)) ;; Data @@ -128,7 +130,7 @@ (unless (or deriv deriv-hidden?) (recache-raw-deriv!) (when raw-deriv - (let ([process (send stepper get-preprocess-deriv)]) + (let ([process (send: stepper widget<%> get-preprocess-deriv)]) (let ([d (process raw-deriv)]) (when (not d) (set! deriv-hidden? #t)) @@ -151,7 +153,7 @@ (unless (or raw-steps raw-steps-oops) (recache-synth!) (when deriv - (let ([show-macro? (or (send stepper get-show-macro?) + (let ([show-macro? (or (send: stepper widget<%> get-show-macro?) (lambda (id) #t))]) (with-handlers ([(lambda (e) #t) (lambda (e) @@ -274,18 +276,18 @@ ;; display-initial-term : -> void (define/public (display-initial-term) - (send displayer add-syntax (wderiv-e1 deriv))) + (send: displayer step-display<%> add-syntax (wderiv-e1 deriv))) ;; display-final-term : -> void (define/public (display-final-term) (recache-steps!) (cond [(syntax? raw-steps-estx) - (send displayer add-syntax raw-steps-estx - #:binders binders - #:shift-table shift-table - #:definites raw-steps-definites)] + (send: displayer step-display<%> add-syntax raw-steps-estx + #:binders binders + #:shift-table shift-table + #:definites raw-steps-definites)] [(exn? raw-steps-exn) - (send displayer add-error raw-steps-exn)] + (send: displayer step-display<%> add-error raw-steps-exn)] [else (display-oops #f)])) ;; display-step : -> void @@ -294,25 +296,25 @@ (cond [steps (let ([step (cursor:next steps)]) (if step - (send displayer add-step step - #:binders binders - #:shift-table shift-table) - (send displayer add-final raw-steps-estx raw-steps-exn - #:binders binders - #:shift-table shift-table - #:definites raw-steps-definites)))] + (send: displayer step-display<%> add-step step + #:binders binders + #:shift-table shift-table) + (send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn + #:binders binders + #:shift-table shift-table + #:definites raw-steps-definites)))] [else (display-oops #t)])) ;; display-oops : boolean -> void (define/private (display-oops show-syntax?) (cond [raw-steps-oops - (send displayer add-internal-error - "steps" raw-steps-oops - (and show-syntax? (wderiv-e1 deriv)) - events)] + (send: displayer step-display<%> add-internal-error + "steps" raw-steps-oops + (and show-syntax? (wderiv-e1 deriv)) + events)] [raw-deriv-oops - (send displayer add-internal-error - "derivation" raw-deriv-oops #f events)] + (send: displayer step-display<%> add-internal-error + "derivation" raw-deriv-oops #f events)] [else (error 'term-record::display-oops "internal error")])) )) diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.ss index 47150cf..be4451a 100644 --- a/collects/macro-debugger/view/view.ss +++ b/collects/macro-debugger/view/view.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop scheme/pretty scheme/gui framework/framework @@ -27,23 +28,23 @@ (hash-for-each stepper-frames (lambda (stepper-frame flags) (unless (memq 'no-obsolete flags) - (send stepper-frame add-obsoleted-warning))))) + (send: stepper-frame stepper-frame<%> add-obsoleted-warning))))) (define/public (add-trace events) (hash-for-each stepper-frames (lambda (stepper-frame flags) (unless (memq 'no-new-traces flags) - (send (send stepper-frame get-widget) - add-trace events))))) + (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%> + add-trace events))))) (define/public (add-deriv deriv) (hash-for-each stepper-frames (lambda (stepper-frame flags) (unless (memq 'no-new-traces flags) - (send (send stepper-frame get-widget) - add-deriv deriv))))) + (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%> + add-deriv deriv))))) (define/public (new-stepper [flags '()]) (define stepper-frame (new-stepper-frame)) - (define stepper (send stepper-frame get-widget)) + (define stepper (send: stepper-frame stepper-frame<%> get-widget)) (send stepper-frame show #t) (add-stepper! stepper-frame flags) stepper) @@ -64,31 +65,6 @@ (define (go stx) (define director (new macro-stepper-director%)) - (define stepper (send director new-stepper)) - (send director add-deriv (trace stx)) + (define stepper (send: director director<%> new-stepper)) + (send: director director<%> add-deriv (trace stx)) (void)) - -#| -(define (make-macro-stepper) - (let ([f (new macro-stepper-frame% - (config (new macro-stepper-config/prefs%)))]) - (send f show #t) - (send f get-widget))) - -(define (go stx) - (let ([stepper (make-macro-stepper)]) - (send stepper add-deriv (trace stx)) - stepper)) - -(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/trace events) - (let* ([w (make-macro-stepper)]) - (send w add-trace events) - w)) -|#