macro stepper: converted more classes to use iop
svn: r13108 original commit: 2aeb50134d2775eb8d0a0a9e3faa18d570c2fd19
This commit is contained in:
Ryan Culpepper
parent
90faf89669
commit
8f08e40c41
|
|
@ -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<%>
|
||||
(define-interface controller<%> (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=?))
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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,8 +136,8 @@
|
|||
(parent id-menu)
|
||||
(callback
|
||||
(lambda _
|
||||
(send controller set-identifier=? p))))])
|
||||
(send controller listen-identifier=?
|
||||
(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)))))))
|
||||
|
|
@ -143,13 +146,14 @@
|
|||
(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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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]"
|
||||
(send: sbview sb:syntax-browser<%> add-text " ")
|
||||
(send: sbview sb:syntax-browser<%> 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 ". ")
|
||||
(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,7 +96,7 @@
|
|||
#:binders [binders #f]
|
||||
#:shift-table [shift-table #f]
|
||||
#:definites [definites null])
|
||||
(send sbview add-syntax stx
|
||||
(send: sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:binder-table binders
|
||||
#:shift-table shift-table
|
||||
#:definites definites))
|
||||
|
|
@ -120,11 +106,12 @@
|
|||
#:shift-table [shift-table #f]
|
||||
#:definites definites)
|
||||
(when stx
|
||||
(send sbview add-text "Expansion finished\n")
|
||||
(send sbview add-syntax stx
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(add-text "Expansion finished\n")
|
||||
(add-syntax stx
|
||||
#:binder-table binders
|
||||
#:shift-table shift-table
|
||||
#:definites definites))
|
||||
#: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
|
||||
(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)))
|
||||
(reverse lctx))))
|
||||
(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
|
||||
(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)))
|
||||
(exn:fail:syntax-exprs (misstep-exn step))))
|
||||
#:definites (or (state-uses state) null))))
|
||||
(show-lctx step binders shift-table))
|
||||
|
||||
;; insert-syntax/color
|
||||
|
|
@ -210,7 +196,7 @@
|
|||
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
|
||||
(send: sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:definites (or definites null)
|
||||
#:binder-table binders
|
||||
#:shift-table 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
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(add-text "\n ")
|
||||
(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"))
|
||||
(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
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(add-text " ")
|
||||
(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"))
|
||||
(add-text " ")
|
||||
(add-text text)
|
||||
(add-text "\n\n")))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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%
|
||||
(define: sbview sb:syntax-browser<%>
|
||||
(new stepper-syntax-widget%
|
||||
(parent area)
|
||||
(macro-stepper this)))
|
||||
(define step-displayer (new step-display%
|
||||
(define: step-displayer step-display<%>
|
||||
(new step-display%
|
||||
(config config)
|
||||
(syntax-widget sbview)))
|
||||
(define sbc (send sbview get-controller))
|
||||
(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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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,10 +296,10 @@
|
|||
(cond [steps
|
||||
(let ([step (cursor:next steps)])
|
||||
(if step
|
||||
(send displayer add-step step
|
||||
(send: displayer step-display<%> add-step step
|
||||
#:binders binders
|
||||
#: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
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)))]
|
||||
|
|
@ -306,12 +308,12 @@
|
|||
;; display-oops : boolean -> void
|
||||
(define/private (display-oops show-syntax?)
|
||||
(cond [raw-steps-oops
|
||||
(send displayer add-internal-error
|
||||
(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
|
||||
(send: displayer step-display<%> add-internal-error
|
||||
"derivation" raw-deriv-oops #f events)]
|
||||
[else
|
||||
(error 'term-record::display-oops "internal error")]))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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)
|
||||
(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))
|
||||
|#
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user