suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro stepper: converted more classes to use iop

Browse Source 
svn: r13108

original commit: 2aeb50134d2775eb8d0a0a9e3faa18d570c2fd19
This commit is contained in:
Ryan Culpepper 2009-01-14 06:04:57 +00:00
parent 90faf89669
commit 8f08e40c41
11 changed files with 291 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,11 +1,10 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop) macro-debugger/util/class-iop)
(provide (all-defined-out)) (provide (all-defined-out))
;; displays-manager<%> ;; displays-manager<%>
(define-interface displays-manager<%> (define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void (;; add-syntax-display : display<%> -> void
add-syntax-display add-syntax-display
@ -13,7 +12,7 @@
remove-all-syntax-displays)) remove-all-syntax-displays))
;; selection-manager<%> ;; selection-manager<%>
(define-interface selection-manager<%> (define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f (;; selected-syntax : syntax/#f
set-selected-syntax set-selected-syntax
get-selected-syntax get-selected-syntax
@ -21,12 +20,15 @@
;; mark-manager<%> ;; mark-manager<%>
;; Manages marks, mappings from marks to colors ;; Manages marks, mappings from marks to colors
(define-interface mark-manager<%> (define-interface mark-manager<%> ()
(;; get-primary-partition : -> partition (;; get-primary-partition : -> partition
get-primary-partition)) get-primary-partition
;; reset-primary-partition : -> void
reset-primary-partition))
;; secondary-partition<%> ;; secondary-partition<%>
(define-interface secondary-partition<%> (define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%> (;; get-secondary-partition : -> partition<%>
get-secondary-partition get-secondary-partition
@ -46,27 +48,15 @@
listen-identifier=?)) listen-identifier=?))
;; controller<%> ;; controller<%>
(define-interface/dynamic controller<%> (define-interface controller<%> (displays-manager<%>
(interface (displays-manager<%>
selection-manager<%> selection-manager<%>
mark-manager<%> mark-manager<%>
secondary-partition<%>)) 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=?))
;; host<%> ;; host<%>
(define-interface host<%> (define-interface host<%> ()
(;; get-controller : -> controller<%> (;; get-controller : -> controller<%>
get-controller get-controller
@ -74,7 +64,7 @@
add-keymap)) add-keymap))
;; display<%> ;; display<%>
(define-interface display<%> (define-interface display<%> ()
(;; refresh : -> void (;; refresh : -> void
refresh refresh
@ -94,7 +84,7 @@
get-range)) get-range))
;; range<%> ;; range<%>
(define-interface range<%> (define-interface range<%> ()
(;; get-ranges : datum -> (list-of (cons number number)) (;; get-ranges : datum -> (list-of (cons number number))
get-ranges get-ranges
@ -111,14 +101,14 @@
;; syntax-prefs<%> ;; syntax-prefs<%>
(define-interface syntax-prefs<%> (define-interface syntax-prefs<%> ()
(pref:width (pref:width
pref:height pref:height
pref:props-percentage pref:props-percentage
pref:props-shown?)) pref:props-shown?))
;; widget-hooks<%> ;; widget-hooks<%>
(define-interface widget-hooks<%> (define-interface widget-hooks<%> ()
(;; setup-keymap : -> void (;; setup-keymap : -> void
setup-keymap setup-keymap
@ -126,7 +116,7 @@
shutdown)) shutdown))
;; keymap-hooks<%> ;; keymap-hooks<%>
(define-interface keymap-hooks<%> (define-interface keymap-hooks<%> ()
(;; make-context-menu : -> context-menu<%> (;; make-context-menu : -> context-menu<%>
make-context-menu make-context-menu
@ -134,7 +124,7 @@
get-context-menu%)) get-context-menu%))
;; context-menu-hooks<%> ;; context-menu-hooks<%>
(define-interface context-menu-hooks<%> (define-interface context-menu-hooks<%> ()
(add-edit-items (add-edit-items
after-edit-items after-edit-items
add-selection-items add-selection-items
@ -146,15 +136,16 @@
;;---------- ;;----------
;; Convenience widget, specialized for displaying stx and not much else ;; Convenience widget, specialized for displaying stx and not much else
(define-interface syntax-browser<%> (define-interface syntax-browser<%> ()
(add-syntax (add-syntax
add-text add-text
add-error-text
add-clickback
add-separator add-separator
erase-all erase-all
select-syntax
get-text)) get-text))
(define-interface partition<%> (define-interface partition<%> ()
(;; get-partition : any -> number (;; get-partition : any -> number
get-partition get-partition

1
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
scheme/gui scheme/gui

2
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -21,7 +21,7 @@
;; widget% ;; widget%
;; A syntax widget creates its own syntax-controller. ;; A syntax widget creates its own syntax-controller.
(define widget% (define widget%
(class* object% (widget-hooks<%>) (class* object% (syntax-browser<%> widget-hooks<%>)
(init parent) (init parent)
(init-field config) (init-field config)

21
collects/macro-debugger/view/extensions.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/unit scheme/unit
scheme/list scheme/list
scheme/match scheme/match
@ -13,6 +14,7 @@
"hiding-panel.ss" "hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss") (prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/keymap.ss") (prefix-in s: "../syntax-browser/keymap.ss")
(prefix-in s: "../syntax-browser/interfaces.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/trace.ss" "../model/trace.ss"
@ -26,7 +28,7 @@
(define stepper-keymap% (define stepper-keymap%
(class s:syntax-keymap% (class s:syntax-keymap%
(init-field macro-stepper) (init-field: (macro-stepper widget<%>))
(inherit-field config (inherit-field config
controller controller
the-context-menu) the-context-menu)
@ -39,17 +41,17 @@
(super-new) (super-new)
(define/public (get-hiding-panel) (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" (add-function "hiding:show-macro"
(lambda (i e) (lambda (i e)
(send* (get-hiding-panel) (send*: (get-hiding-panel) hiding-prefs<%>
(add-show-identifier) (add-show-identifier)
(refresh)))) (refresh))))
(add-function "hiding:hide-macro" (add-function "hiding:hide-macro"
(lambda (i e) (lambda (i e)
(send* (get-hiding-panel) (send*: (get-hiding-panel) hiding-prefs<%>
(add-hide-identifier) (add-hide-identifier)
(refresh)))) (refresh))))
@ -75,26 +77,27 @@
(send show-macro enable ?) (send show-macro enable ?)
(send hide-macro enable ?)) (send hide-macro enable ?))
(send controller listen-selected-syntax (send: controller s:controller<%> listen-selected-syntax
(lambda (stx) (lambda (stx)
(enable/disable-hide/show (identifier? stx)))))) (enable/disable-hide/show (identifier? stx))))))
(define stepper-syntax-widget% (define stepper-syntax-widget%
(class s:widget% (class s:widget%
(init-field macro-stepper) (init-field: (macro-stepper widget<%>))
(inherit get-text) (inherit get-text)
(inherit-field controller) (inherit-field controller)
(define/override (setup-keymap) (define/override (setup-keymap)
(new stepper-keymap% (new stepper-keymap%
(editor (get-text)) (editor (get-text))
(config (send macro-stepper get-config)) (config (send: macro-stepper widget<%> get-config))
(controller controller) (controller controller)
(macro-stepper macro-stepper))) (macro-stepper macro-stepper)))
(define/override (show-props show?) (define/override (show-props show?)
(super show-props show?) (super show-props show?)
(send macro-stepper update/preserve-view)) (send: macro-stepper widget<%> update/preserve-view))
(super-new (super-new
(config (send macro-stepper get-config))))) (config (send: macro-stepper widget<%> get-config)))))

30
collects/macro-debugger/view/frame.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/unit scheme/unit
scheme/list scheme/list
scheme/file scheme/file
@ -14,6 +15,7 @@
"warning.ss" "warning.ss"
"hiding-panel.ss" "hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss") (prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/trace.ss" "../model/trace.ss"
@ -23,7 +25,7 @@
(provide macro-stepper-frame-mixin) (provide macro-stepper-frame-mixin)
(define (macro-stepper-frame-mixin base-frame%) (define (macro-stepper-frame-mixin base-frame%)
(class base-frame% (class* base-frame% (stepper-frame<%>)
(init-field config) (init-field config)
(init-field director) (init-field director)
(init-field (filename #f)) (init-field (filename #f))
@ -54,7 +56,7 @@
(define/override (on-size w h) (define/override (on-size w h)
(send config set-width w) (send config set-width w)
(send config set-height h) (send config set-height h)
(send widget update/preserve-view)) (send: widget widget<%> update/preserve-view))
(define warning-panel (define warning-panel
(new horizontal-panel% (new horizontal-panel%
@ -65,12 +67,13 @@
(define/public (get-macro-stepper-widget%) (define/public (get-macro-stepper-widget%)
macro-stepper-widget%) macro-stepper-widget%)
(define widget (define: widget widget<%>
(new (get-macro-stepper-widget%) (new (get-macro-stepper-widget%)
(parent (get-area-container)) (parent (get-area-container))
(director director) (director director)
(config config))) (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-widget) widget)
(define/public (get-controller) controller) (define/public (get-controller) controller)
@ -112,11 +115,11 @@
(new (get-menu-item%) (new (get-menu-item%)
(label "Duplicate stepper") (label "Duplicate stepper")
(parent file-menu) (parent file-menu)
(callback (lambda _ (send widget duplicate-stepper)))) (callback (lambda _ (send: widget widget<%> duplicate-stepper))))
(new (get-menu-item%) (new (get-menu-item%)
(label "Duplicate stepper (current term only)") (label "Duplicate stepper (current term only)")
(parent file-menu) (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 (menu-option/notify-box stepper-menu
"View syntax properties" "View syntax properties"
@ -133,8 +136,8 @@
(parent id-menu) (parent id-menu)
(callback (callback
(lambda _ (lambda _
(send controller set-identifier=? p))))]) (send: controller sb:controller<%> set-identifier=? p))))])
(send controller listen-identifier=? (send: controller sb:controller<%> listen-identifier=?
(lambda (name+func) (lambda (name+func)
(send this-choice check (send this-choice check
(eq? (car name+func) (car p))))))) (eq? (car name+func) (car p)))))))
@ -143,13 +146,14 @@
(let ([identifier=? (send config get-identifier=?)]) (let ([identifier=? (send config get-identifier=?)])
(when identifier=? (when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))]) (let ([p (assoc identifier=? (sb:identifier=-choices))])
(send controller set-identifier=? p)))) (send: controller sb:controller<%> set-identifier=? p))))
(new (get-menu-item%) (new (get-menu-item%)
(label "Clear selection") (label "Clear selection")
(parent stepper-menu) (parent stepper-menu)
(callback (callback
(lambda _ (send controller set-selected-syntax #f)))) (lambda _ (send: controller sb:controller<%>
set-selected-syntax #f))))
(new separator-menu-item% (parent stepper-menu)) (new separator-menu-item% (parent stepper-menu))
@ -160,11 +164,11 @@
(new (get-menu-item%) (new (get-menu-item%)
(label "Remove selected term") (label "Remove selected term")
(parent stepper-menu) (parent stepper-menu)
(callback (lambda _ (send widget remove-current-term)))) (callback (lambda _ (send: widget widget<%> remove-current-term))))
(new (get-menu-item%) (new (get-menu-item%)
(label "Reset mark numbering") (label "Reset mark numbering")
(parent stepper-menu) (parent stepper-menu)
(callback (lambda _ (send widget reset-primary-partition)))) (callback (lambda _ (send: widget widget<%> reset-primary-partition))))
(let ([extras-menu (let ([extras-menu
(new (get-menu%) (new (get-menu%)
(label "Extra options") (label "Extra options")
@ -178,7 +182,7 @@
(if (send i is-checked?) (if (send i is-checked?)
'always 'always
'over-limit)) 'over-limit))
(send widget update/preserve-view)))) (send: widget widget<%> update/preserve-view))))
(menu-option/notify-box extras-menu (menu-option/notify-box extras-menu
"Highlight redex/contractum" "Highlight redex/contractum"
(get-field highlight-foci? config)) (get-field highlight-foci? config))

10
collects/macro-debugger/view/hiding-panel.ss
View File

@ -1,9 +1,11 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/gui scheme/gui
scheme/list scheme/list
syntax/boundmap syntax/boundmap
"interfaces.ss"
"../model/hiding-policies.ss" "../model/hiding-policies.ss"
"../util/mpi.ss" "../util/mpi.ss"
"../util/notify.ss") "../util/notify.ss")
@ -16,9 +18,9 @@
;; macro-hiding-prefs-widget% ;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget% (define macro-hiding-prefs-widget%
(class object% (class* object% (hiding-prefs<%>)
(init parent) (init parent)
(init-field stepper) (init-field: (stepper widget<%>))
(init-field config) (init-field config)
(define/public (get-policy) (define/public (get-policy)
@ -173,11 +175,11 @@
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(when (macro-hiding-enabled?) (when (macro-hiding-enabled?)
(send stepper refresh/resynth))) (send: stepper widget<%> refresh/resynth)))
;; force-refresh : -> void ;; force-refresh : -> void
(define/private (force-refresh) (define/private (force-refresh)
(send stepper refresh/resynth)) (send: stepper widget<%> refresh/resynth))
;; set-syntax : syntax/#f -> void ;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx) (define/public (set-syntax lstx)

107
collects/macro-debugger/view/interfaces.ss
View File

@ -1,50 +1,75 @@
#lang scheme/base #lang scheme/base
(require scheme/unit) (require macro-debugger/util/class-iop)
(provide (all-defined-out)) (provide (all-defined-out))
;; Signatures (define-interface widget<%> ()
(get-config
get-controller
get-macro-hiding-prefs
get-step-displayer
#; add-trace
(define-signature view^ add-deriv
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
#; update/preserve-view
(define-signature view-base^ refresh/resynth
(base-frame%))
#; reset-primary-partition
(define-signature prefs^ remove-current-term
(pref:width duplicate-stepper
pref:height show-in-new-frame
pref:props-shown?
pref:props-percentage get-preprocess-deriv
pref:macro-hiding-mode get-show-macro?
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?
)) ))
;; macro-stepper-config% (define-interface stepper-frame<%> ()
;; all fields are notify-box% objects (get-widget
;; width get-controller
;; height add-obsoleted-warning))
;; macro-hiding?
;; hide-primitives? (define-interface hiding-prefs<%> ()
;; hide-libs? (add-show-identifier
;; show-syntax-properties? add-hide-identifier
;; show-hiding-panel? set-syntax
;; show-rename-steps? get-policy
;; highlight-foci? 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
))
(define-interface director<%> ()
(add-deriv
new-stepper))

101
collects/macro-debugger/view/step-display.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/unit scheme/unit
scheme/list scheme/list
scheme/match scheme/match
@ -21,8 +22,10 @@
"../model/reductions.ss" "../model/reductions.ss"
"../model/steps.ss" "../model/steps.ss"
"../util/notify.ss" "../util/notify.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"cursor.ss" "cursor.ss"
"debug-format.ss") "debug-format.ss")
#; #;
(provide step-display% (provide step-display%
step-display<%>) step-display<%>)
@ -35,24 +38,6 @@
(define (prestep-term1 s) (state-term (protostep-s1 s))) (define (prestep-term1 s) (state-term (protostep-s1 s)))
(define (poststep-term2 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% (define step-display%
(class* object% (step-display<%>) (class* object% (step-display<%>)
@ -61,18 +46,18 @@
(super-new) (super-new)
(define/public (add-internal-error part exn stx events) (define/public (add-internal-error part exn stx events)
(send sbview add-text (send: sbview sb:syntax-browser<%> add-text
(if part (if part
(format "Macro stepper error (~a)" part) (format "Macro stepper error (~a)" part)
"Macro stepper error")) "Macro stepper error"))
(when (exn? exn) (when (exn? exn)
(send sbview add-text " ") (send: sbview sb:syntax-browser<%> add-text " ")
(send sbview add-clickback "[details]" (send: sbview sb:syntax-browser<%> add-clickback "[details]"
(lambda _ (show-internal-error-details exn events)))) (lambda _ (show-internal-error-details exn events))))
(send sbview add-text ". ") (send: sbview sb:syntax-browser<%> add-text ". ")
(when stx (send sbview add-text "Original syntax:")) (when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:"))
(send sbview add-text "\n") (send: sbview sb:syntax-browser<%> add-text "\n")
(when stx (send sbview add-syntax stx))) (when stx (send: sbview sb:syntax-browser<%> add-syntax stx)))
(define/private (show-internal-error-details exn events) (define/private (show-internal-error-details exn events)
(case (message-box/custom "Macro stepper internal error" (case (message-box/custom "Macro stepper internal error"
@ -91,8 +76,9 @@
((3 #f) (void)))) ((3 #f) (void))))
(define/public (add-error exn) (define/public (add-error exn)
(send sbview add-error-text (exn-message exn)) (send*: sbview sb:syntax-browser<%>
(send sbview add-text "\n")) (add-error-text (exn-message exn))
(add-text "\n")))
(define/public (add-step step (define/public (add-step step
#:binders binders #:binders binders
@ -110,7 +96,7 @@
#:binders [binders #f] #:binders [binders #f]
#:shift-table [shift-table #f] #:shift-table [shift-table #f]
#:definites [definites null]) #:definites [definites null])
(send sbview add-syntax stx (send: sbview sb:syntax-browser<%> add-syntax stx
#:binder-table binders #:binder-table binders
#:shift-table shift-table #:shift-table shift-table
#:definites definites)) #:definites definites))
@ -120,11 +106,12 @@
#:shift-table [shift-table #f] #:shift-table [shift-table #f]
#:definites definites) #:definites definites)
(when stx (when stx
(send sbview add-text "Expansion finished\n") (send*: sbview sb:syntax-browser<%>
(send sbview add-syntax stx (add-text "Expansion finished\n")
(add-syntax stx
#:binder-table binders #:binder-table binders
#:shift-table shift-table #:shift-table shift-table
#:definites definites)) #:definites definites)))
(when error (when error
(add-error error))) (add-error error)))
@ -133,17 +120,16 @@
(define state (protostep-s1 step)) (define state (protostep-s1 step))
(define lctx (state-lctx state)) (define lctx (state-lctx state))
(when (pair? lctx) (when (pair? lctx)
(send sbview add-text "\n") (send: sbview sb:syntax-browser<%> add-text "\n")
(for-each (lambda (bf) (for ([bf (reverse lctx)])
(send sbview add-text (send: sbview sb:syntax-browser<%> add-text
"while executing macro transformer in:\n") "while executing macro transformer in:\n")
(insert-syntax/redex (bigframe-term bf) (insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf) (bigframe-foci bf)
binders binders
shift-table shift-table
(state-uses state) (state-uses state)
(state-frontier state))) (state-frontier state)))))
(reverse lctx))))
;; separator : Step -> void ;; separator : Step -> void
(define/private (separator step) (define/private (separator step)
@ -194,15 +180,15 @@
(define state (protostep-s1 step)) (define state (protostep-s1 step))
(show-state/redex state binders shift-table) (show-state/redex state binders shift-table)
(separator step) (separator step)
(send sbview add-error-text (exn-message (misstep-exn step))) (send*: sbview sb:syntax-browser<%>
(send sbview add-text "\n") (add-error-text (exn-message (misstep-exn step)))
(add-text "\n"))
(when (exn:fail:syntax? (misstep-exn step)) (when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send sbview add-syntax e (send: sbview sb:syntax-browser<%> add-syntax e
#:binder-table binders #:binder-table binders
#:shift-table shift-table #:shift-table shift-table
#:definites (or (state-uses state) null))) #:definites (or (state-uses state) null))))
(exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders shift-table)) (show-lctx step binders shift-table))
;; insert-syntax/color ;; insert-syntax/color
@ -210,7 +196,7 @@
definites frontier hi-color) definites frontier hi-color)
(define highlight-foci? (send config get-highlight-foci?)) (define highlight-foci? (send config get-highlight-foci?))
(define highlight-frontier? (send config get-highlight-frontier?)) (define highlight-frontier? (send config get-highlight-frontier?))
(send sbview add-syntax stx (send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null) #:definites (or definites null)
#:binder-table binders #:binder-table binders
#:shift-table shift-table #:shift-table shift-table
@ -233,29 +219,32 @@
;; insert-step-separator : string -> void ;; insert-step-separator : string -> void
(define/private (insert-step-separator text) (define/private (insert-step-separator text)
(send sbview add-text "\n ") (send*: sbview sb:syntax-browser<%>
(send sbview add-text (add-text "\n ")
(add-text
(make-object image-snip% (make-object image-snip%
(build-path (collection-path "icons") (build-path (collection-path "icons")
"red-arrow.bmp"))) "red-arrow.bmp")))
(send sbview add-text " ") (add-text " ")
(send sbview add-text text) (add-text text)
(send sbview add-text "\n\n")) (add-text "\n\n")))
;; insert-as-separator : string -> void ;; insert-as-separator : string -> void
(define/private (insert-as-separator text) (define/private (insert-as-separator text)
(send sbview add-text "\n ") (send*: sbview sb:syntax-browser<%>
(send sbview add-text text) (add-text "\n ")
(send sbview add-text "\n\n")) (add-text text)
(add-text "\n\n")))
;; insert-step-separator/small : string -> void ;; insert-step-separator/small : string -> void
(define/private (insert-step-separator/small text) (define/private (insert-step-separator/small text)
(send sbview add-text " ") (send*: sbview sb:syntax-browser<%>
(send sbview add-text (add-text " ")
(add-text
(make-object image-snip% (make-object image-snip%
(build-path (collection-path "icons") (build-path (collection-path "icons")
"red-arrow.bmp"))) "red-arrow.bmp")))
(send sbview add-text " ") (add-text " ")
(send sbview add-text text) (add-text text)
(send sbview add-text "\n\n")) (add-text "\n\n")))
)) ))

118
collects/macro-debugger/view/stepper.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/unit scheme/unit
scheme/list scheme/list
scheme/match scheme/match
@ -14,6 +15,7 @@
"hiding-panel.ss" "hiding-panel.ss"
"term-record.ss" "term-record.ss"
"step-display.ss" "step-display.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss" "../model/deriv.ss"
"../model/deriv-util.ss" "../model/deriv-util.ss"
"../model/deriv-find.ss" "../model/deriv-find.ss"
@ -29,10 +31,10 @@
;; macro-stepper-widget% ;; macro-stepper-widget%
(define macro-stepper-widget% (define macro-stepper-widget%
(class* object% () (class* object% (widget<%>)
(init-field parent) (init-field parent)
(init-field config) (init-field config)
(init-field director) (init-field: (director director<%>))
;; Terms ;; Terms
@ -65,7 +67,7 @@
(define/public (add trec) (define/public (add trec)
(set! all-terms (cons trec all-terms)) (set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? 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? (unless invisible?
(cursor:add-to-end! terms (list trec)) (cursor:add-to-end! terms (list trec))
(trim-navigator) (trim-navigator)
@ -83,15 +85,16 @@
(define/public (show-in-new-frame) (define/public (show-in-new-frame)
(let ([term (focused-term)]) (let ([term (focused-term)])
(when term (when term
(let ([new-stepper (send director new-stepper '(no-new-traces))]) (let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
(send new-stepper add-deriv (send term get-raw-deriv)) (send: new-stepper widget<%> add-deriv (send term get-raw-deriv))
(void))))) (void)))))
;; duplicate-stepper : -> void ;; duplicate-stepper : -> void
(define/public (duplicate-stepper) (define/public (duplicate-stepper)
(let ([new-stepper (send director new-stepper)]) (let ([new-stepper (send: director director<%> new-stepper)])
(for ([term (cursor->list terms)]) (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-config) config)
(define/public (get-controller) sbc) (define/public (get-controller) sbc)
@ -101,7 +104,7 @@
(define/public (get-macro-hiding-prefs) macro-hiding-prefs) (define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define/public (reset-primary-partition) (define/public (reset-primary-partition)
(send sbc reset-primary-partition) (send: sbc sb:controller<%> reset-primary-partition)
(update/preserve-view)) (update/preserve-view))
(define area (new vertical-panel% (parent parent))) (define area (new vertical-panel% (parent parent)))
@ -126,16 +129,19 @@
(define warnings-area (new stepper-warnings% (parent area))) (define warnings-area (new stepper-warnings% (parent area)))
(define sbview (new stepper-syntax-widget% (define: sbview sb:syntax-browser<%>
(new stepper-syntax-widget%
(parent area) (parent area)
(macro-stepper this))) (macro-stepper this)))
(define step-displayer (new step-display% (define: step-displayer step-display<%>
(new step-display%
(config config) (config config)
(syntax-widget sbview))) (syntax-widget sbview)))
(define sbc (send sbview get-controller)) (define: sbc sb:controller<%>
(send sbview get-controller))
(define control-pane (define control-pane
(new vertical-panel% (parent area) (stretchable-height #f))) (new vertical-panel% (parent area) (stretchable-height #f)))
(define macro-hiding-prefs (define: macro-hiding-prefs hiding-prefs<%>
(new macro-hiding-prefs-widget% (new macro-hiding-prefs-widget%
(parent control-pane) (parent control-pane)
(stepper this) (stepper this)
@ -144,7 +150,7 @@
(send config listen-show-hiding-panel? (send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?))) (lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax (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? (send config listen-highlight-foci?
(lambda (_) (update/preserve-view))) (lambda (_) (update/preserve-view)))
(send config listen-highlight-frontier? (send config listen-highlight-frontier?
@ -233,34 +239,34 @@
;; Navigation ;; Navigation
(define/public-final (at-start?) (define/public-final (at-start?)
(send (focused-term) at-start?)) (send: (focused-term) term-record<%> at-start?))
(define/public-final (at-end?) (define/public-final (at-end?)
(send (focused-term) at-end?)) (send: (focused-term) term-record<%> at-end?))
(define/public-final (navigate-to-start) (define/public-final (navigate-to-start)
(send (focused-term) navigate-to-start) (send: (focused-term) term-record<%> navigate-to-start)
(update/save-position)) (update/save-position))
(define/public-final (navigate-to-end) (define/public-final (navigate-to-end)
(send (focused-term) navigate-to-end) (send: (focused-term) term-record<%> navigate-to-end)
(update/save-position)) (update/save-position))
(define/public-final (navigate-previous) (define/public-final (navigate-previous)
(send (focused-term) navigate-previous) (send: (focused-term) term-record<%> navigate-previous)
(update/save-position)) (update/save-position))
(define/public-final (navigate-next) (define/public-final (navigate-next)
(send (focused-term) navigate-next) (send: (focused-term) term-record<%> navigate-next)
(update/save-position)) (update/save-position))
(define/public-final (navigate-to n) (define/public-final (navigate-to n)
(send (focused-term) navigate-to n) (send: (focused-term) term-record<%> navigate-to n)
(update/save-position)) (update/save-position))
(define/public-final (navigate-up) (define/public-final (navigate-up)
(when (focused-term) (when (focused-term)
(send (focused-term) on-lose-focus)) (send: (focused-term) term-record<%> on-lose-focus))
(cursor:move-prev terms) (cursor:move-prev terms)
(refresh/move)) (refresh/move))
(define/public-final (navigate-down) (define/public-final (navigate-down)
(when (focused-term) (when (focused-term)
(send (focused-term) on-lose-focus)) (send: (focused-term) term-record<%> on-lose-focus))
(cursor:move-next terms) (cursor:move-next terms)
(refresh/move)) (refresh/move))
@ -272,7 +278,7 @@
;; update/preserve-lines-view : -> void ;; update/preserve-lines-view : -> void
(define/public (update/preserve-lines-view) (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 start-box (box 0))
(define end-box (box 0)) (define end-box (box 0))
(send text get-visible-line-range start-box end-box) (send text get-visible-line-range start-box end-box)
@ -285,7 +291,7 @@
;; update/preserve-view : -> void ;; update/preserve-view : -> void
(define/public (update/preserve-view) (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 start-box (box 0))
(define end-box (box 0)) (define end-box (box 0))
(send text get-visible-position-range start-box end-box) (send text get-visible-position-range start-box end-box)
@ -295,17 +301,17 @@
;; update : -> void ;; update : -> void
;; Updates the terms in the syntax browser to the current step ;; Updates the terms in the syntax browser to the current step
(define/private (update) (define/private (update)
(define text (send sbview get-text)) (define text (send: sbview sb:syntax-browser<%> get-text))
(define position-of-interest 0) (define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1)) (define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence) (send text begin-edit-sequence)
(send sbview erase-all) (send: sbview sb:syntax-browser<%> erase-all)
(update:show-prefix) (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)) (set! position-of-interest (send text last-position))
(update:show-current-step) (update:show-current-step)
(when multiple-terms? (send sbview add-separator)) (when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(update:show-suffix) (update:show-suffix)
(send text end-edit-sequence) (send text end-edit-sequence)
(send text scroll-to-position (send text scroll-to-position
@ -319,35 +325,35 @@
;; update:show-prefix : -> void ;; update:show-prefix : -> void
(define/private (update:show-prefix) (define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs ;; 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))) (cursor:prefix->list terms)))
;; update:show-current-step : -> void ;; update:show-current-step : -> void
(define/private (update:show-current-step) (define/private (update:show-current-step)
(when (focused-term) (when (focused-term)
(send (focused-term) display-step))) (send: (focused-term) term-record<%> display-step)))
;; update:show-suffix : -> void ;; update:show-suffix : -> void
(define/private (update:show-suffix) (define/private (update:show-suffix)
(let ([suffix0 (cursor:suffix->list terms)]) (let ([suffix0 (cursor:suffix->list terms)])
(when (pair? suffix0) (when (pair? suffix0)
(for-each (lambda (trec) (for-each (lambda (trec)
(send trec display-initial-term)) (send: trec term-record<%> display-initial-term))
(cdr suffix0))))) (cdr suffix0)))))
;; update-nav-index : -> void ;; update-nav-index : -> void
(define/private (update-nav-index) (define/private (update-nav-index)
(define term (focused-term)) (define term (focused-term))
(set-current-step-index (set-current-step-index
(and term (send term get-step-index)))) (and term (send: term term-record<%> get-step-index))))
;; enable/disable-buttons : -> void ;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons) (define/private (enable/disable-buttons)
(define term (focused-term)) (define term (focused-term))
(send nav:start enable (and term (send term has-prev?))) (send nav:start enable (and term (send: term term-record<%> has-prev?)))
(send nav:previous enable (and term (send term has-prev?))) (send nav:previous enable (and term (send: term term-record<%> has-prev?)))
(send nav:next enable (and term (send term has-next?))) (send nav:next enable (and term (send: term term-record<%> has-next?)))
(send nav:end enable (and term (send term has-next?))) (send nav:end enable (and term (send: term term-record<%> has-next?)))
(send nav:text enable (and term #t)) (send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms)) (send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms))) (send nav:down enable (cursor:has-next? terms)))
@ -357,14 +363,14 @@
;; refresh/resynth : -> void ;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec ;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth) (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)) (cursor->list terms))
(refresh)) (refresh))
;; refresh/re-reduce : -> void ;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec ;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce) (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)) (cursor->list terms))
(refresh)) (refresh))
@ -377,47 +383,15 @@
(define/public (refresh) (define/public (refresh)
(send warnings-area clear) (send warnings-area clear)
(when (focused-term) (when (focused-term)
(send (focused-term) on-get-focus)) (send: (focused-term) term-record<%> on-get-focus))
(update)) (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))) (define/private (foci x) (if (list? x) x (list x)))
;; Hiding policy ;; Hiding policy
(define/public (get-show-macro?) (define/public (get-show-macro?)
(send macro-hiding-prefs get-policy)) (send: macro-hiding-prefs hiding-prefs<%> get-policy))
;; Derivation pre-processing ;; Derivation pre-processing

26
collects/macro-debugger/view/term-record.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/unit scheme/unit
scheme/list scheme/list
scheme/match scheme/match
@ -30,11 +31,12 @@
;; TermRecords ;; TermRecords
(define term-record% (define term-record%
(class object% (class* object% (term-record<%>)
(init-field stepper) (init-field: (stepper widget<%>))
(define config (send stepper get-config)) (define config (send stepper get-config))
(define displayer (send stepper get-step-displayer)) (define: displayer step-display<%>
(send: stepper widget<%> get-step-displayer))
;; Data ;; Data
@ -128,7 +130,7 @@
(unless (or deriv deriv-hidden?) (unless (or deriv deriv-hidden?)
(recache-raw-deriv!) (recache-raw-deriv!)
(when 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)]) (let ([d (process raw-deriv)])
(when (not d) (when (not d)
(set! deriv-hidden? #t)) (set! deriv-hidden? #t))
@ -151,7 +153,7 @@
(unless (or raw-steps raw-steps-oops) (unless (or raw-steps raw-steps-oops)
(recache-synth!) (recache-synth!)
(when deriv (when deriv
(let ([show-macro? (or (send stepper get-show-macro?) (let ([show-macro? (or (send: stepper widget<%> get-show-macro?)
(lambda (id) #t))]) (lambda (id) #t))])
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
(lambda (e) (lambda (e)
@ -274,18 +276,18 @@
;; display-initial-term : -> void ;; display-initial-term : -> void
(define/public (display-initial-term) (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 ;; display-final-term : -> void
(define/public (display-final-term) (define/public (display-final-term)
(recache-steps!) (recache-steps!)
(cond [(syntax? raw-steps-estx) (cond [(syntax? raw-steps-estx)
(send displayer add-syntax raw-steps-estx (send: displayer step-display<%> add-syntax raw-steps-estx
#:binders binders #:binders binders
#:shift-table shift-table #:shift-table shift-table
#:definites raw-steps-definites)] #:definites raw-steps-definites)]
[(exn? raw-steps-exn) [(exn? raw-steps-exn)
(send displayer add-error raw-steps-exn)] (send: displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)])) [else (display-oops #f)]))
;; display-step : -> void ;; display-step : -> void
@ -294,10 +296,10 @@
(cond [steps (cond [steps
(let ([step (cursor:next steps)]) (let ([step (cursor:next steps)])
(if step (if step
(send displayer add-step step (send: displayer step-display<%> add-step step
#:binders binders #:binders binders
#:shift-table shift-table) #:shift-table shift-table)
(send displayer add-final raw-steps-estx raw-steps-exn (send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders binders #:binders binders
#:shift-table shift-table #:shift-table shift-table
#:definites raw-steps-definites)))] #:definites raw-steps-definites)))]
@ -306,12 +308,12 @@
;; display-oops : boolean -> void ;; display-oops : boolean -> void
(define/private (display-oops show-syntax?) (define/private (display-oops show-syntax?)
(cond [raw-steps-oops (cond [raw-steps-oops
(send displayer add-internal-error (send: displayer step-display<%> add-internal-error
"steps" raw-steps-oops "steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv)) (and show-syntax? (wderiv-e1 deriv))
events)] events)]
[raw-deriv-oops [raw-deriv-oops
(send displayer add-internal-error (send: displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)] "derivation" raw-deriv-oops #f events)]
[else [else
(error 'term-record::display-oops "internal error")])) (error 'term-record::display-oops "internal error")]))

38
collects/macro-debugger/view/view.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/pretty scheme/pretty
scheme/gui scheme/gui
framework/framework framework/framework
@ -27,23 +28,23 @@
(hash-for-each stepper-frames (hash-for-each stepper-frames
(lambda (stepper-frame flags) (lambda (stepper-frame flags)
(unless (memq 'no-obsolete 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) (define/public (add-trace events)
(hash-for-each stepper-frames (hash-for-each stepper-frames
(lambda (stepper-frame flags) (lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags) (unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget) (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-trace events))))) add-trace events)))))
(define/public (add-deriv deriv) (define/public (add-deriv deriv)
(hash-for-each stepper-frames (hash-for-each stepper-frames
(lambda (stepper-frame flags) (lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags) (unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget) (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-deriv deriv))))) add-deriv deriv)))))
(define/public (new-stepper [flags '()]) (define/public (new-stepper [flags '()])
(define stepper-frame (new-stepper-frame)) (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) (send stepper-frame show #t)
(add-stepper! stepper-frame flags) (add-stepper! stepper-frame flags)
stepper) stepper)
@ -64,31 +65,6 @@
(define (go stx) (define (go stx)
(define director (new macro-stepper-director%)) (define director (new macro-stepper-director%))
(define stepper (send director new-stepper)) (define stepper (send: director director<%> new-stepper))
(send director add-deriv (trace stx)) (send: director director<%> add-deriv (trace stx))
(void)) (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))
|#