Syncing up to trunk.
svn: r13115
This commit is contained in:
Stevie Strickland
commit
4ca79e31ff
|
|
@ -68,9 +68,10 @@
|
|||
(super-new)))
|
||||
|
||||
(define controller%
|
||||
(class (secondary-partition-mixin
|
||||
(selection-manager-mixin
|
||||
(mark-manager-mixin
|
||||
(displays-manager-mixin
|
||||
object%))))
|
||||
(class* (secondary-partition-mixin
|
||||
(selection-manager-mixin
|
||||
(mark-manager-mixin
|
||||
(displays-manager-mixin
|
||||
object%))))
|
||||
(controller<%>)
|
||||
(super-new)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
define:
|
||||
lambda:
|
||||
init:
|
||||
init-field:
|
||||
init-private:)
|
||||
|
||||
;; Configuration
|
||||
|
|
@ -25,10 +26,13 @@
|
|||
;; Defines NAME as an interface.
|
||||
(define-syntax (define-interface stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:id (mname:id ...))
|
||||
#'(define-interface/dynamic name
|
||||
(let ([name (interface () mname ...)]) name)
|
||||
(mname ...))]))
|
||||
[(_ name:id (super:static-interface ...) (mname:id ...))
|
||||
(with-syntax ([((super-method ...) ...)
|
||||
(map static-interface-members
|
||||
(syntax->datum #'(super.value ...)))])
|
||||
#'(define-interface/dynamic name
|
||||
(let ([name (interface (super ...) mname ...)]) name)
|
||||
(super-method ... ... mname ...)))]))
|
||||
|
||||
;; define-interface/dynamic SYNTAX
|
||||
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
|
||||
|
|
@ -181,7 +185,7 @@
|
|||
(syntax-parse stx
|
||||
[(_ init name:id iface:static-interface)
|
||||
(with-syntax ([(name-internal) (generate-temporaries #'(name))])
|
||||
#'(begin (init (name name-internal))
|
||||
#'(begin (init ((name-internal name)))
|
||||
(void (check-object<:interface init: name-internal iface))
|
||||
(define-syntax name
|
||||
(make-checked-binding
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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,77 @@
|
|||
|
||||
#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
|
||||
(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")))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
@ -231,36 +237,36 @@
|
|||
(list navigator)))))
|
||||
|
||||
;; 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,6 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
macro-debugger/util/class-iop
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/match
|
||||
|
|
@ -30,11 +30,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 +129,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 +152,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 +275,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 +295,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")]))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
macro-debugger/util/class-iop
|
||||
scheme/pretty
|
||||
scheme/gui
|
||||
framework/framework
|
||||
|
|
@ -13,7 +14,7 @@
|
|||
go)
|
||||
|
||||
(define macro-stepper-director%
|
||||
(class object%
|
||||
(class* object% (director<%>)
|
||||
(define stepper-frames (make-hasheq))
|
||||
|
||||
;; Flags is a subset(list) of '(no-obsolete no-new-traces)
|
||||
|
|
@ -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))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -1,196 +1,171 @@
|
|||
(module size-snip mzscheme
|
||||
(require (lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"matcher.ss")
|
||||
#lang scheme/base
|
||||
(require scheme/gui/base
|
||||
scheme/class
|
||||
framework
|
||||
scheme/pretty
|
||||
"matcher.ss")
|
||||
|
||||
(provide reflowing-snip<%>
|
||||
size-editor-snip%
|
||||
default-pretty-printer
|
||||
initial-char-width
|
||||
resizing-pasteboard-mixin)
|
||||
(provide reflowing-snip<%>
|
||||
size-editor-snip%
|
||||
size-text%
|
||||
default-pretty-printer
|
||||
initial-char-width
|
||||
resizing-pasteboard-mixin)
|
||||
|
||||
(define initial-char-width (make-parameter 30))
|
||||
(define initial-char-width (make-parameter 30))
|
||||
|
||||
(define (default-pretty-printer v port w spec)
|
||||
(parameterize ([pretty-print-columns w]
|
||||
[pretty-print-size-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val) 4]
|
||||
[(eq? val 'hole) 6]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val)
|
||||
(display "hole" op)]
|
||||
[(eq? val 'hole)
|
||||
(display ",'hole" op)]))])
|
||||
(pretty-print v port)))
|
||||
(define (default-pretty-printer v port w spec)
|
||||
(parameterize ([pretty-print-columns w]
|
||||
[pretty-print-size-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val) 4]
|
||||
[(eq? val 'hole) 6]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (val display? op)
|
||||
(cond
|
||||
[(hole? val)
|
||||
(display "hole" op)]
|
||||
[(eq? val 'hole)
|
||||
(display ",'hole" op)]))])
|
||||
(pretty-print v port)))
|
||||
|
||||
(define reflowing-snip<%>
|
||||
(interface ()
|
||||
reflow-program))
|
||||
(define reflowing-snip<%>
|
||||
(interface ()
|
||||
reflow-program))
|
||||
|
||||
(define (resizing-pasteboard-mixin pb%)
|
||||
(class pb%
|
||||
(init-field shrink-down?)
|
||||
(define (resizing-pasteboard-mixin pb%)
|
||||
(class pb%
|
||||
|
||||
(define/augment (on-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) on-interactive-resize snip))
|
||||
(define/augment (on-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) on-interactive-resize snip))
|
||||
|
||||
(define/augment (after-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) after-interactive-resize snip))
|
||||
(define/augment (after-interactive-resize snip)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program))
|
||||
(inner (void) after-interactive-resize snip))
|
||||
|
||||
(define/override (interactive-adjust-resize snip w h)
|
||||
(super interactive-adjust-resize snip w h)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program)))
|
||||
(define/override (interactive-adjust-resize snip w h)
|
||||
(super interactive-adjust-resize snip w h)
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip reflow-program)))
|
||||
|
||||
(inherit get-snip-location
|
||||
begin-edit-sequence
|
||||
end-edit-sequence)
|
||||
(inherit get-snip-location
|
||||
begin-edit-sequence
|
||||
end-edit-sequence
|
||||
find-first-snip
|
||||
get-dc)
|
||||
|
||||
(define/augment (on-insert snip before x y)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-insert snip before x y))
|
||||
(define/augment (after-insert snip before x y)
|
||||
(inner (void) after-insert snip before x y)
|
||||
(when (is-a? snip size-editor-snip%)
|
||||
(let ([cw (send snip get-char-width)]
|
||||
[woc (send snip get-width-of-char)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-snip-location snip #f bt #f)
|
||||
(get-snip-location snip #f bb #t)
|
||||
(send snip resize
|
||||
(* cw woc)
|
||||
(- (unbox bb) (unbox bt)))
|
||||
(when shrink-down?
|
||||
(send snip shrink-down))))
|
||||
(end-edit-sequence))
|
||||
(super-new)))
|
||||
(super-new)))
|
||||
|
||||
(define size-editor-snip%
|
||||
(class* editor-snip% (reflowing-snip<%>)
|
||||
(init-field expr)
|
||||
(init pp)
|
||||
(init-field char-width)
|
||||
(define real-pp
|
||||
(if (procedure-arity-includes? pp 4)
|
||||
pp
|
||||
(lambda (v port w spec) (display (pp v) port))))
|
||||
(inherit get-admin)
|
||||
(define/public (get-expr) expr)
|
||||
(define/public (get-char-width) char-width)
|
||||
(define size-editor-snip%
|
||||
(class* editor-snip% (reflowing-snip<%>)
|
||||
(init-field expr)
|
||||
(init pp)
|
||||
(init-field char-width)
|
||||
(define real-pp
|
||||
(if (procedure-arity-includes? pp 4)
|
||||
pp
|
||||
(lambda (v port w spec) (display (pp v) port))))
|
||||
|
||||
(define/override (resize w h)
|
||||
(super resize w h)
|
||||
(reflow-program))
|
||||
(inherit get-admin)
|
||||
(define/public (get-expr) expr)
|
||||
(define/public (get-char-width) char-width)
|
||||
|
||||
(inherit get-editor)
|
||||
;; final
|
||||
(define/pubment (reflow-program)
|
||||
(let* ([tw (get-width-of-char)]
|
||||
[sw (get-snip-width)])
|
||||
(when (and tw sw)
|
||||
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
|
||||
(unless (equal? new-width char-width)
|
||||
(set! char-width new-width)
|
||||
(format-expr)
|
||||
(on-width-changed char-width))))))
|
||||
(define/override (resize w h)
|
||||
(super resize w h)
|
||||
(reflow-program))
|
||||
|
||||
;; final
|
||||
(define/pubment (shrink-down)
|
||||
(let ([ed (get-editor)]
|
||||
[bx (box 0)]
|
||||
[by (box 0)])
|
||||
(let ([max-line-width
|
||||
(let loop ([p 0]
|
||||
[max-w 0])
|
||||
(cond
|
||||
[(<= p (send ed last-paragraph))
|
||||
(send ed position-location
|
||||
(send ed paragraph-end-position p)
|
||||
bx by #t)
|
||||
(let ([this-w (unbox bx)])
|
||||
(loop (+ p 1)
|
||||
(max this-w max-w)))]
|
||||
[else max-w]))])
|
||||
(send ed position-location (send ed last-position) bx by #f)
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(super resize
|
||||
(+ max-line-width hms)
|
||||
(+ (unbox by) vms))))))
|
||||
(inherit get-editor)
|
||||
;; final
|
||||
(define/pubment (reflow-program)
|
||||
(let* ([tw (get-width-of-char)]
|
||||
[sw (get-snip-width)])
|
||||
(when (and tw sw)
|
||||
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
|
||||
(unless (equal? new-width char-width)
|
||||
(set! char-width new-width)
|
||||
(format-expr)
|
||||
(on-width-changed char-width))))))
|
||||
|
||||
(inherit get-margin)
|
||||
(define/public (get-snip-width)
|
||||
(let ([admin (get-admin)])
|
||||
(and admin
|
||||
(let ([containing-editor (send admin get-editor)]
|
||||
[bl (box 0)]
|
||||
[br (box 0)])
|
||||
(send containing-editor get-snip-location this bl #f #f)
|
||||
(send containing-editor get-snip-location this br #f #t)
|
||||
(let ([outer-w (- (unbox br) (unbox bl))])
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(- outer-w hms)))))))
|
||||
(inherit get-margin)
|
||||
(define/public (get-snip-width)
|
||||
(let ([admin (get-admin)])
|
||||
(and admin
|
||||
(let ([containing-editor (send admin get-editor)]
|
||||
[bl (box 0)]
|
||||
[br (box 0)])
|
||||
(send containing-editor get-snip-location this bl #f #f)
|
||||
(send containing-editor get-snip-location this br #f #t)
|
||||
(let ([outer-w (- (unbox br) (unbox bl))])
|
||||
(let-values ([(hms vms) (get-margin-space)])
|
||||
(- outer-w hms)))))))
|
||||
|
||||
(define/private (get-margin-space)
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-margin bl bt br bb)
|
||||
(values (+ (unbox bl) (unbox br) 2) ;; not sure what the 2 is for. Maybe caret space?
|
||||
(+ (unbox bt) (unbox bb)))))
|
||||
(define/private (get-margin-space)
|
||||
(let ([bl (box 0)]
|
||||
[br (box 0)]
|
||||
[bt (box 0)]
|
||||
[bb (box 0)])
|
||||
(get-margin bl bt br bb)
|
||||
(values (+ (unbox bl) (unbox br) 6) ;; not sure what the 2 is for. Maybe caret space?
|
||||
(+ (unbox bt) (unbox bb)))))
|
||||
|
||||
(define/public (get-width-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
tw))))))
|
||||
;; get-width-of-char : -> number or false
|
||||
;; depends on `dc' field
|
||||
(define/public (get-width-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([std-style (send (editor:get-standard-style-list) find-named-style "Standard")]
|
||||
[dc (send ed get-dc)])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
tw))))))
|
||||
|
||||
(define/public (get-height-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
th))))))
|
||||
;; depends on `dc' field
|
||||
(define/public (get-height-of-char)
|
||||
(let ([ed (get-editor)])
|
||||
(and ed
|
||||
(let ([dc (send ed get-dc)]
|
||||
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
|
||||
(and dc
|
||||
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
|
||||
(and std-style
|
||||
(send std-style get-font)))])
|
||||
th))))))
|
||||
|
||||
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
|
||||
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
|
||||
|
||||
(define/public (format-expr)
|
||||
(let* ([text (get-editor)]
|
||||
[port (open-output-text-editor text)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text thaw-colorer))
|
||||
(send text set-styles-sticky #f)
|
||||
(send text erase)
|
||||
(real-pp expr port char-width text)
|
||||
(unless (zero? (send text last-position))
|
||||
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
|
||||
(send text delete (- (send text last-position) 1) (send text last-position))))
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text freeze-colorer))
|
||||
(send text end-edit-sequence)))
|
||||
(define/public (format-expr)
|
||||
(let* ([text (get-editor)]
|
||||
[port (open-output-text-editor text)])
|
||||
(send text begin-edit-sequence)
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text thaw-colorer))
|
||||
(send text set-styles-sticky #f)
|
||||
(send text erase)
|
||||
(real-pp expr port char-width text)
|
||||
(unless (zero? (send text last-position))
|
||||
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
|
||||
(send text delete (- (send text last-position) 1) (send text last-position))))
|
||||
(when (is-a? text color:text<%>)
|
||||
(send text freeze-colorer))
|
||||
(send text end-edit-sequence)))
|
||||
|
||||
(super-new)
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t)))
|
||||
|
||||
(define size-text%
|
||||
(scheme:set-mode-mixin
|
||||
(scheme:text-mixin
|
||||
(color:text-mixin
|
||||
(text:autocomplete-mixin
|
||||
(mode:host-text-mixin
|
||||
(editor:standard-style-list-mixin
|
||||
text:basic%)))))))
|
||||
|
||||
(super-new)
|
||||
(inherit use-style-background)
|
||||
(use-style-background #t))))
|
||||
|
|
@ -77,7 +77,6 @@ todo:
|
|||
(define upper-hp (new horizontal-panel% [parent dp]))
|
||||
(define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
|
||||
(define pb (new columnar-pasteboard%
|
||||
[shrink-down? #f]
|
||||
[moved (λ (a b c d)
|
||||
(when (procedure? moved)
|
||||
(moved a b c d)))]))
|
||||
|
|
@ -801,7 +800,7 @@ todo:
|
|||
flat-to-remove)
|
||||
(for-each (λ (x) (insert x)) flat-to-insert)))
|
||||
|
||||
(inherit get-admin move-to resize)
|
||||
(inherit get-admin move-to)
|
||||
(define/public (update-heights)
|
||||
(let ([admin (get-admin)])
|
||||
(let-values ([(w h) (get-view-size)])
|
||||
|
|
@ -816,9 +815,11 @@ todo:
|
|||
;; if there is only a single snip in the column, we let it be as long as it wants to be.
|
||||
(let* ([snip (car column)]
|
||||
[sw (get-snip-width snip)]
|
||||
[sh (get-snip-max-height snip)])
|
||||
[sh (get-snip-max-height snip)]
|
||||
[new-height (- (max h sh) (get-border-height snip))])
|
||||
(move-to snip x 0)
|
||||
(resize snip sw (max h sh))
|
||||
(send snip set-min-height new-height)
|
||||
(send snip set-max-height new-height)
|
||||
(loop (cdr columns) (+ x sw)))]
|
||||
[else
|
||||
;; otherwise, we make all of the snips fit into the visible area
|
||||
|
|
@ -838,16 +839,39 @@ todo:
|
|||
0
|
||||
1))])
|
||||
(move-to snip x y)
|
||||
(resize snip sw h)
|
||||
(let ([border-height (get-border-height snip)])
|
||||
(send snip set-min-height (- h border-height))
|
||||
(send snip set-max-height (- h border-height)))
|
||||
(loop (cdr snips)
|
||||
(if (zero? extra-space)
|
||||
0
|
||||
(- extra-space 1))
|
||||
(+ y h)
|
||||
(max widest sw)))]))])
|
||||
(for-each (λ (snip)
|
||||
(let ([border-width (get-border-width snip)])
|
||||
(send snip set-min-width (- widest border-width))
|
||||
(send snip set-max-width (- widest border-width))))
|
||||
column)
|
||||
(loop (cdr columns)
|
||||
(+ x widest)))]))])))))
|
||||
|
||||
(define/private (get-border-height snip)
|
||||
(let ([lb (box 0)]
|
||||
[tb (box 0)]
|
||||
[rb (box 0)]
|
||||
[bb (box 0)])
|
||||
(send snip get-margin lb tb bb rb)
|
||||
(+ (unbox bb) (unbox tb))))
|
||||
|
||||
(define/private (get-border-width snip)
|
||||
(let ([lb (box 0)]
|
||||
[tb (box 0)]
|
||||
[rb (box 0)]
|
||||
[bb (box 0)])
|
||||
(send snip get-margin lb tb bb rb)
|
||||
(+ (unbox lb) (unbox rb))))
|
||||
|
||||
(inherit get-snip-location)
|
||||
(define/public (get-snip-width snip)
|
||||
(let ([lb (box 0)]
|
||||
|
|
|
|||
|
|
@ -1,15 +1,17 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; should cache the count of new snips -- dont
|
||||
;; use `count-snips'; use something associated with the
|
||||
;; equal hash-table
|
||||
|
||||
#lang scheme
|
||||
|
||||
(require mrlib/graph
|
||||
"reduction-semantics.ss"
|
||||
"matcher.ss"
|
||||
"size-snip.ss"
|
||||
"dot.ss"
|
||||
scheme/gui/base
|
||||
scheme/class
|
||||
scheme/file
|
||||
framework)
|
||||
|
||||
(preferences:set-default 'plt-reducer:show-bottom #t boolean?)
|
||||
|
|
@ -139,12 +141,83 @@
|
|||
#:scheme-colors? scheme-colors?
|
||||
#:colors colors
|
||||
#:layout layout)])
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file filename)
|
||||
(send ps-setup set-mode 'file)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(send graph-pb print #f #f 'postscript #f #f #t)))))
|
||||
(print-to-ps graph-pb filename)))
|
||||
|
||||
(define (print-to-ps graph-pb filename)
|
||||
(let ([admin (send graph-pb get-admin)]
|
||||
[printing-admin (new printing-editor-admin%)])
|
||||
(send graph-pb set-admin printing-admin)
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(send snip size-cache-invalid)
|
||||
(loop (send snip next))))
|
||||
(send graph-pb invalidate-bitmap-cache)
|
||||
|
||||
(send graph-pb re-run-layout)
|
||||
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file filename)
|
||||
(send ps-setup set-mode 'file)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(send graph-pb print #f #f 'postscript #f #f #t))))
|
||||
|
||||
(λ ()
|
||||
(send graph-pb set-admin admin)
|
||||
(send printing-admin shutdown) ;; do this early
|
||||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(send snip size-cache-invalid)
|
||||
(loop (send snip next))))
|
||||
(send graph-pb invalidate-bitmap-cache)
|
||||
(send graph-pb re-run-layout)))))
|
||||
|
||||
(define printing-editor-admin%
|
||||
(class editor-admin%
|
||||
|
||||
(define temp-file (make-temporary-file "redex-size-snip-~a"))
|
||||
|
||||
(define ps-dc
|
||||
(let ([ps-setup (make-object ps-setup%)])
|
||||
(send ps-setup copy-from (current-ps-setup))
|
||||
(send ps-setup set-file temp-file)
|
||||
(parameterize ([current-ps-setup ps-setup])
|
||||
(make-object post-script-dc% #f #f #f #t))))
|
||||
|
||||
(send ps-dc start-doc "fake dc")
|
||||
(send ps-dc start-page)
|
||||
(super-new)
|
||||
|
||||
(define/public (shutdown)
|
||||
(send ps-dc end-page)
|
||||
(send ps-dc end-doc)
|
||||
(delete-file temp-file))
|
||||
|
||||
|
||||
(define/override (get-dc [x #f] [y #f])
|
||||
(super get-dc x y)
|
||||
ps-dc)
|
||||
(define/override (get-max-view x y w h [full? #f])
|
||||
(get-view x y w h full?))
|
||||
(define/override (get-view x y w h [full? #f])
|
||||
(super get-view x y w h full?)
|
||||
(when (box? w) (set-box! w 500))
|
||||
(when (box? h) (set-box! h 500)))
|
||||
|
||||
;; the following methods are not overridden; they all default to doing nothing.
|
||||
;; grab-caret
|
||||
;; modified
|
||||
;; needs-update
|
||||
;; popup-menu
|
||||
;; refresh-delayed?
|
||||
;; resized
|
||||
;; scroll-to
|
||||
;; update-cursor
|
||||
))
|
||||
|
||||
(define (traces reductions pre-exprs
|
||||
#:multiple? [multiple? #f]
|
||||
|
|
@ -157,7 +230,7 @@
|
|||
(define exprs (if multiple? pre-exprs (list pre-exprs)))
|
||||
(define main-eventspace (current-eventspace))
|
||||
(define saved-parameterization (current-parameterization))
|
||||
(define graph-pb (new graph-pasteboard% [shrink-down? #t]))
|
||||
(define graph-pb (new graph-pasteboard% [layout layout]))
|
||||
(define f (instantiate red-sem-frame% ()
|
||||
(label "PLT Redex Reduction Graph")
|
||||
(style '(toolbar-button))
|
||||
|
|
@ -275,7 +348,7 @@
|
|||
(let loop ([snip (send graph-pb find-first-snip)])
|
||||
(when snip
|
||||
(when (is-a? snip reflowing-snip<%>)
|
||||
(send snip shrink-down))
|
||||
(send snip reflow-program))
|
||||
(loop (send snip next))))))
|
||||
|
||||
;; fill-out : (listof X) (listof X) -> (listof X)
|
||||
|
|
@ -338,7 +411,7 @@
|
|||
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
|
||||
(begin0
|
||||
(insert-into col y graph-pb new-snips)
|
||||
(layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
|
||||
(send graph-pb re-run-layout)
|
||||
(send graph-pb end-edit-sequence)
|
||||
(send status-message set-label
|
||||
(string-append (term-count (count-snips)) "...")))))])
|
||||
|
|
@ -469,7 +542,7 @@
|
|||
null)))
|
||||
(out-of-dot-state) ;; make sure the state is initialized right
|
||||
(insert-into init-rightmost-x 0 graph-pb frontier)
|
||||
(layout (map (lambda (y) (send y get-term-node)) frontier))
|
||||
(send graph-pb re-run-layout)
|
||||
(set-font-size (initial-font-size))
|
||||
(cond
|
||||
[no-show-frame?
|
||||
|
|
@ -507,6 +580,10 @@
|
|||
(define graph-pasteboard%
|
||||
(class (resizing-pasteboard-mixin
|
||||
(graph-pasteboard-mixin pasteboard%))
|
||||
|
||||
(init-field layout) ;; (-> (listof term-node) void)
|
||||
;; this is the function supplied by the :#layout argument to traces or traces/ps
|
||||
|
||||
(define dot-callback #f)
|
||||
(define/public (set-dot-callback cb) (set! dot-callback cb))
|
||||
(define/override (draw-edges dc left top right bottom dx dy)
|
||||
|
|
@ -521,6 +598,17 @@
|
|||
(define/augment (can-interactive-move? evt) mobile?)
|
||||
(define/augment (can-interactive-resize? evt) mobile?)
|
||||
|
||||
(inherit find-first-snip)
|
||||
(define/public (re-run-layout)
|
||||
(layout
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(cond
|
||||
[(not snip) '()]
|
||||
[(is-a? snip reflowing-snip<%>)
|
||||
(cons (send snip get-term-node)
|
||||
(loop (send snip next)))]
|
||||
[else (loop (send snip next))]))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define graph-editor-snip%
|
||||
|
|
@ -578,7 +666,7 @@
|
|||
(super-new)))
|
||||
|
||||
(define program-text%
|
||||
(class scheme:text%
|
||||
(class size-text%
|
||||
(define bad-color #f)
|
||||
(define/public (set-bad color) (set! bad-color color))
|
||||
|
||||
|
|
@ -688,6 +776,7 @@
|
|||
(pp pp)
|
||||
(expr expr))])
|
||||
(send text set-autowrap-bitmap #f)
|
||||
(send text set-max-width 'none)
|
||||
(send text freeze-colorer)
|
||||
(send text stop-colorer (not scheme-colors?))
|
||||
(send es format-expr)
|
||||
|
|
|
|||
|
|
@ -213,12 +213,13 @@ looking for a decomposition, it ignores any holes found in
|
|||
that @|pattern|.
|
||||
}
|
||||
|
||||
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern matches
|
||||
what the embedded @pattern matches, and then the guard expression is
|
||||
evaluated. If it returns @scheme[#f], the @pattern fails to match, and if it
|
||||
returns anything else, the @pattern matches. In addition, any
|
||||
occurrences of `name' in the @pattern are bound using @scheme[term-let]
|
||||
in the guard.
|
||||
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern
|
||||
matches what the embedded @pattern matches, and then the guard
|
||||
expression is evaluated. If it returns @scheme[#f], the @pattern fails
|
||||
to match, and if it returns anything else, the @pattern matches. Any
|
||||
occurrences of `name' in the @pattern (including those implicitly
|
||||
there via @tt{_} pattersn) are bound using @scheme[term-let] in the
|
||||
guard.
|
||||
}
|
||||
|
||||
@item{The @tt{(@defpattech[cross] symbol)} @pattern is used for the compatible
|
||||
|
|
@ -1095,7 +1096,7 @@ pattern does not match the @scheme[pattern].}
|
|||
[relation reduction-relation?]
|
||||
[property (-> any/c any/c)]
|
||||
[#:attempts attempts natural-number/c 100])
|
||||
(or/c true/c void?)]{
|
||||
void?]{
|
||||
Tests a @scheme[relation] as follows: for each case of @scheme[relation],
|
||||
@scheme[check-reduction-relation] generates @scheme[attempts] random
|
||||
terms that match that case's left-hand side and applies @scheme[property]
|
||||
|
|
@ -1367,9 +1368,18 @@ the stepper and traces.
|
|||
@defparam[dark-pen-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[dark-brush-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[light-pen-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}]]{
|
||||
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[dark-text-color color (or/c string? (is-a?/c color<%>))]{}
|
||||
@defparam[light-text-color color (or/c string? (is-a?/c color<%>))]{}]]{
|
||||
|
||||
These four parameters control the color of the edges in the graph.
|
||||
These six parameters control the color of the edges in the graph.
|
||||
|
||||
The dark colors are used when the mouse is over one of the nodes that
|
||||
is connected to this edge. The light colors are used when it isn't.
|
||||
|
||||
The pen colors control the color of the line. The brush colors control
|
||||
the color used to fill the arrowhead and the text colors control the
|
||||
color used to draw the label on the edge.
|
||||
}
|
||||
|
||||
@defproc[(default-pretty-printer [v any] [port output-port] [width number] [text (is-a?/c text%)]) void?]{
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "13jan2009")
|
||||
#lang scheme/base (provide stamp) (define stamp "14jan2009")
|
||||
|
|
|
|||
|
|
@ -127,4 +127,3 @@
|
|||
(ormap f l1 l2))]
|
||||
[(f . args) (apply ormap f args)])])
|
||||
ormap)))
|
||||
|
||||
|
|
@ -267,8 +267,8 @@ information@|details|, even if the editor currently has delayed refreshing (see
|
|||
|
||||
(define (edsnipsize a b c)
|
||||
@elem{An @scheme[editor-snip%] normally stretches to wrap around the size
|
||||
of the editor it contains. This method #1 of the snip
|
||||
(and if the editor is #2, #3).})
|
||||
of the editor it contains. This method @|a| of the snip
|
||||
(and if the editor is @|b|, @|c|).})
|
||||
(define (edsnipmax n)
|
||||
(edsnipsize @elem{limits the @|n|}
|
||||
@elem{larger}
|
||||
|
|
|
|||
|
|
@ -108,4 +108,3 @@
|
|||
(= 0 (list-length '()))
|
||||
(= 2 (list-length '(1 2)))
|
||||
(= 3 (list-length '(1 2 (1 2 3 4))))
|
||||
|
||||
|
|
@ -10,4 +10,3 @@
|
|||
[base64-decode (Bytes -> Bytes)])
|
||||
|
||||
(provide base64-encode-stream base64-decode-stream base64-encode base64-decode)
|
||||
|
||||
|
|
@ -40,5 +40,3 @@
|
|||
(require-typed-struct/provide (malformed-server-response pop3)
|
||||
([communicator : communicator]) net/pop3)
|
||||
|
||||
|
||||
|
||||
|
|
@ -7,4 +7,3 @@
|
|||
[qp-decode ( String -> String )]
|
||||
[qp-encode-stream (case-lambda (Input-Port Output-Port -> Void) (Input-Port Output-Port String -> Void) )]
|
||||
[qp-decode-stream ( Input-Port Output-Port -> Void )])
|
||||
|
||||
|
|
@ -9,4 +9,3 @@
|
|||
(String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)])
|
||||
|
||||
(provide send-mail-message/port send-mail-message #;no-mail-recipients)
|
||||
|
||||
|
|
@ -6,4 +6,3 @@
|
|||
[external-browser (-> (U Symbol #f (Pair String String)))])
|
||||
|
||||
(provide send-url unix-browser-list browser-preference? external-browser)
|
||||
|
||||
|
|
@ -7,5 +7,3 @@
|
|||
[smtp-sending-end-of-message (Parameter (-> Any))])
|
||||
|
||||
(provide smtp-send-message smtp-sending-end-of-message)
|
||||
|
||||
|
||||
|
|
@ -12,4 +12,3 @@
|
|||
[alist->form-urlencoded ( (Listof (cons Symbol String)) -> String )]
|
||||
[form-urlencoded->alist ( String -> (Listof (cons Symbol String)) )]
|
||||
[current-alist-separator-mode (Parameter Symbol)])
|
||||
|
||||
|
|
@ -968,7 +968,7 @@ void scheme_get_substring_indices(const char *name, Scheme_Object *str,
|
|||
|
||||
if (SCHEME_VECTORP(str))
|
||||
len = SCHEME_VEC_SIZE(str);
|
||||
if (SCHEME_CHAR_STRINGP(str))
|
||||
else if (SCHEME_CHAR_STRINGP(str))
|
||||
len = SCHEME_CHAR_STRTAG_VAL(str);
|
||||
else
|
||||
len = SCHEME_BYTE_STRTAG_VAL(str);
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user