commit 8f08e40c41b47fae20b64e104c21b14046056afd
parent 90faf8966924b89905b4de02d0f02d597cd7e6e5
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 14 Jan 2009 06:04:57 +0000
macro stepper: converted more classes to use iop
svn: r13108
original commit: 2aeb50134d2775eb8d0a0a9e3faa18d570c2fd19
Diffstat:
11 files changed, 294 insertions(+), 329 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -1,50 +1,75 @@
#lang scheme/base
-(require scheme/unit)
+(require macro-debugger/util/class-iop)
(provide (all-defined-out))
-;; Signatures
-
-#;
-(define-signature view^
- (macro-stepper-frame%
- macro-stepper-widget%
- make-macro-stepper
- go
- go/deriv))
-
-#;
-(define-signature view-base^
- (base-frame%))
-
-#;
-(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?
+(define-interface widget<%> ()
+ (get-config
+ get-controller
+ get-macro-hiding-prefs
+ get-step-displayer
+
+ add-trace
+ add-deriv
+
+ update/preserve-view
+ refresh/resynth
+
+ 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
@@ -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
@@ -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
@@ -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
@@ -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))
-|#
