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

Macro stepper: added support for extra nav tools (zoom, jump) but disabled

Browse Source 
svn: r5461
This commit is contained in:
Ryan Culpepper 2007-01-25 19:20:44 +00:00
parent 3fe785014a
commit f9dfebefa3
4 changed files with 110 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/macro-debugger/view/cursor.ss
View File

@ -89,6 +89,10 @@
(define (cursor:can-move-previous? c)
(pair? (cursor-prefix c)))
(define (cursor->list c)
(append (reverse (cursor-prefix c))
(cursor-suffix->list c)))
(define (cursor-suffix->list c) (cursor-suffix c))
)

113
collects/macro-debugger/view/gui.ss
View File

@ -69,6 +69,8 @@
(notify-box/pref pref:suppress-warnings?))
(field/notify one-by-one?
(notify-box/pref pref:one-by-one?))
(field/notify extra-navigation?
(notify-box/pref pref:extra-navigation?))
(super-new)))
(define macro-stepper-frame%
@ -186,6 +188,9 @@
(menu-option/notify-box extras-menu
"Suppress warnings"
(get-field suppress-warnings? config))
(menu-option/notify-box extras-menu
"Extra navigation"
(get-field extra-navigation? config))
(new checkable-menu-item%
(label "(Debug) Catch internal errors?")
(parent extras-menu)
@ -220,8 +225,16 @@
(define warnings-frame #f)
;; add-deriv : Derivation -> void
(define/public (add-deriv d)
(set! derivs (append derivs (list d)))
(ensure-nav:up+down-shown)
(if (null? (cdr derivs))
;; There is nothing currently displayed
(refresh/move/cached-prefix)
(update)))
(define/private (ensure-nav:up+down-shown)
(when (and (not (send nav:up is-shown?))
(pair? (cdr (append derivs-prefix derivs))))
(send navigator change-children
@ -231,30 +244,36 @@
nav:previous
nav:next
nav:end
nav:down))))
(if (null? (cdr derivs))
;; There is nothing currently displayed
(refresh/move/cached-prefix)
(update)))
nav:down)))))
(define/public (get-controller) sbc)
(define/public (get-view) sbview)
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define area (new vertical-panel% (parent parent)))
(define navigator
(define supernavigator
(new horizontal-panel%
(parent area)
(stretchable-height #f)
(alignment '(center center))))
(define navigator
(new horizontal-panel%
(parent supernavigator)
(stretchable-width #f)
(stretchable-height #f)
(alignment '(left center))))
(define extra-navigator
(new horizontal-panel%
(parent supernavigator)
(stretchable-width #f)
(stretchable-height #f)
(alignment '(left center))
(style '(deleted))))
(define sbview (new sb:syntax-widget%
(parent area)
(macro-stepper this)
(pref:props-percentage pref:props-percentage)))
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(define sbc (send sbview get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
@ -263,11 +282,16 @@
(parent control-pane)
(stepper this)
(config config)))
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-prefs show?)))
(send sbc add-selection-listener
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(lambda (stx)
(send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci?
(lambda (_) (update/preserve-view)))
@ -278,8 +302,12 @@
(send config listen-one-by-one?
(lambda (_) (refresh)))
(send config listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?)))
(define nav:up
(new button% (label "Previous term") (parent navigator) (style '(deleted))
(new button% (label "Previous term") (parent navigator)
(style '(deleted))
(callback (lambda (b e) (navigate-up)))))
(define nav:start
@ -298,6 +326,14 @@
(define nav:down
(new button% (label "Next term") (parent navigator) (style '(deleted))
(callback (lambda (b e) (navigate-down)))))
#;
(define nav:zoom
(new button% (label "Zoom in") (parent extra-navigator)
(callback (lambda (b e) (zoom)))))
#;
(define nav:jump-to
(new button% (label "Jump to") (parent extra-navigator)
(callback (lambda (b e) (jump-to)))))
(define/public (show-macro-hiding-prefs show?)
(send area change-children
@ -306,6 +342,13 @@
(append (remq control-pane children) (list control-pane))
(remq control-pane children)))))
(define/private (show-extra-navigation show?)
(send supernavigator change-children
(lambda (children)
(if show?
(list navigator extra-navigator)
(list navigator)))))
;; Navigate
(define/private (navigate-to-start)
@ -334,6 +377,50 @@
(set! synth-deriv #f))
(refresh/move/cached-prefix))
;; FIXME: selected stx must be in term1; doesn't work in term2
#;
(define/private (zoom)
(let* ([selected-syntax (send sbc get-selected-syntax)]
[step (and steps (cursor:current steps))]
[deriv (and step (protostep-deriv step))])
(when (and selected-syntax deriv)
(for-each go/deriv (seek/syntax selected-syntax deriv)))))
#;
(define/public (jump-to)
(let* ([selected-syntax (send sbc get-selected-syntax)]
[step (and steps (cursor:current steps))]
[deriv (and step (protostep-deriv step))])
(when (and selected-syntax deriv)
(let ([subderivs (seek/syntax selected-syntax deriv)])
(cond [(null? subderivs)
(message-box "Macro stepper - Jump to"
"Cannot find selected term in the expansion")]
[(and (pair? subderivs) (null? (cdr subderivs)))
(jump-to/deriv (car subderivs))]
[else
(message-box "Macro stepper - Jump to"
"Subterm occurs non-linearly in the expansion")])))))
#;
(define/private (jump-to/deriv subderiv)
(define all-step-derivs
(let ([ht (make-hash-table)])
(for-each (lambda (s) (hash-table-put! ht (protostep-deriv s) #t))
(cursor-suffix->list steps))
ht))
(define target-deriv
(find-deriv
(lambda (d) (hash-table-get all-step-derivs d (lambda () #f)))
(lambda (d) #f)
subderiv))
(unless target-deriv
(message-box "Macro stepper - Jump to"
"Could not find selected term in the expansion"))
(when target-deriv
(let loop ()
(unless (eq? (protostep-deriv (cursor:current steps)) target-deriv)
(cursor:move-next steps)))
(update/save-position)))
(define/private (insert-step-separator text)
(send sbview add-text "\n ")
(send sbview add-text
@ -499,8 +586,7 @@
(send nav:next enable (and steps (cursor:can-move-next? steps)))
(send nav:end enable (and steps (cursor:can-move-next? steps)))
(send nav:up enable (and (pair? derivs-prefix)))
(send nav:down enable
(and (pair? derivs))))
(send nav:down enable (and (pair? derivs))))
;; --
@ -661,6 +747,7 @@
(super-new)
(send sbview show-props (send config get-show-syntax-properties?))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?))
(refresh/move/cached-prefix)
))

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

@ -29,6 +29,7 @@
pref:highlight-foci?
pref:suppress-warnings?
pref:one-by-one?
pref:extra-navigation?
))
;; macro-stepper-config%

2
collects/macro-debugger/view/prefs.ss
View File

@ -31,6 +31,7 @@
(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
(preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
(pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height)
@ -45,6 +46,7 @@
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
))
)