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

macro-stepper: faster rendering, async improvements

Browse Source 
added async stop button (and disable breaks around editor operations)
  eliminated redundant calls to refresh in display<%>

original commit: 0d3b092097973fa0f5824a20a80b172b24185320
This commit is contained in:
Ryan Culpepper 2010-11-04 16:24:54 -06:00
parent 35bae39515
commit cbc04f4ea3
10 changed files with 250 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
collects/macro-debugger/syntax-browser/display.rkt
View File

@ -2,7 +2,7 @@
(require racket/class (require racket/class
racket/gui/base racket/gui/base
racket/list racket/list
racket/block racket/pretty
framework framework
unstable/class-iop unstable/class-iop
"pretty-printer.rkt" "pretty-printer.rkt"
@ -12,46 +12,52 @@
(provide print-syntax-to-editor (provide print-syntax-to-editor
code-style) code-style)
(define TIME-PRINTING? #f) (define-syntax-rule (uninterruptible e ...)
;; (coarsely) prevent breaks within editor operations
(parameterize-break #f (begin e ...))
#|
(parameterize-break #f
(let ([ta (now)])
(begin0 (begin e ...)
(let ([tb (now)])
(eprintf "****\n")
(pretty-write '(begin e ...) (current-error-port))
(eprintf " -- ~s ms\n\n" (- tb ta))))))
|#)
(define-syntax-rule (now) (define (now) (current-inexact-milliseconds))
(if TIME-PRINTING?
(current-inexact-milliseconds)
0))
;; FIXME: assumes text never moves ;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number ;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%> ;; -> display<%>
;; Note: must call display<%>::refresh to finish styling.
(define (print-syntax-to-editor stx text controller config columns (define (print-syntax-to-editor stx text controller config columns
[insertion-point (send text last-position)]) [insertion-point (send text last-position)])
(block (define output-port (open-output-string/count-lines))
(define output-port (open-output-string/count-lines)) (define range
(define range (pretty-print-syntax stx output-port
(pretty-print-syntax stx output-port (send/i controller controller<%> get-primary-partition)
(send/i controller controller<%> get-primary-partition) (length (send/i config config<%> get-colors))
(length (send/i config config<%> get-colors)) (send/i config config<%> get-suffix-option)
(send/i config config<%> get-suffix-option) (send config get-pretty-styles)
(send config get-pretty-styles) columns))
columns)) (define output-string (get-output-string output-port))
(define output-string (get-output-string output-port)) (define output-length (sub1 (string-length output-string))) ;; skip final newline
(define output-length (sub1 (string-length output-string))) ;; skip final newline (fixup-parentheses output-string range)
(fixup-parentheses output-string range) (with-unlock text
(send text begin-edit-sequence #f) (uninterruptible
(send text insert output-length output-string insertion-point) (send text insert output-length output-string insertion-point))
(define display (new display%
(new display% (text text)
(text text) (controller controller)
(controller controller) (config config)
(config config) (range range)
(range range) (start-position insertion-point)
(start-position insertion-point) (end-position (+ insertion-point output-length)))))
(end-position (+ insertion-point output-length))))
(send display initialize)
(send text end-edit-sequence)
display))
;; display% ;; display%
;; Note: must call refresh method to finish styling.
(define display% (define display%
(class* object% (display<%>) (class* object% (display<%>)
(init-field/i [controller controller<%>] (init-field/i [controller controller<%>]
@ -66,12 +72,15 @@
(define extra-styles (make-hasheq)) (define extra-styles (make-hasheq))
(define auto-refresh? #f) ;; FIXME: delete or make init arg
;; initialize : -> void ;; initialize : -> void
(define/public (initialize) (define/private (initialize)
(send text change-style base-style start-position end-position #f) (uninterruptible
(apply-primary-partition-styles) (send text change-style base-style start-position end-position #f))
(add-clickbacks) (uninterruptible (apply-primary-partition-styles))
(refresh)) (uninterruptible (add-clickbacks))
(when auto-refresh? (refresh)))
;; add-clickbacks : -> void ;; add-clickbacks : -> void
(define/private (add-clickbacks) (define/private (add-clickbacks)
@ -103,18 +112,15 @@
;; refresh : -> void ;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles. ;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh) (define/public (refresh)
(with-unlock text (uninterruptible
(send* text (with-unlock text
(begin-edit-sequence #f) (send text change-style (unhighlight-d) start-position end-position)
(change-style (unhighlight-d) start-position end-position)) (apply-extra-styles)
(apply-extra-styles) (let ([selected-syntax
(let ([selected-syntax (send/i controller selection-manager<%>
(send/i controller selection-manager<%> get-selected-syntax)])
get-selected-syntax)]) (apply-secondary-relation-styles selected-syntax)
(apply-secondary-relation-styles selected-syntax) (apply-selection-styles selected-syntax)))))
(apply-selection-styles selected-syntax))
(send* text
(end-edit-sequence))))
;; get-range : -> range<%> ;; get-range : -> range<%>
(define/public (get-range) range) (define/public (get-range) range)
@ -130,13 +136,13 @@
(let ([style-delta (highlight-style-delta hi-color #f)]) (let ([style-delta (highlight-style-delta hi-color #f)])
(for ([stx stxs]) (for ([stx stxs])
(add-extra-styles stx (list style-delta)))) (add-extra-styles stx (list style-delta))))
(refresh)) (when auto-refresh? (refresh)))
;; underline-syntaxes : (listof syntax) -> void ;; underline-syntaxes : (listof syntax) -> void
(define/public (underline-syntaxes stxs) (define/public (underline-syntaxes stxs)
(for ([stx stxs]) (for ([stx stxs])
(add-extra-styles stx (list underline-style-delta))) (add-extra-styles stx (list underline-style-delta)))
(refresh)) (when auto-refresh? (refresh)))
;; add-extra-styles : syntax (listof style) -> void ;; add-extra-styles : syntax (listof style) -> void
(define/public (add-extra-styles stx styles) (define/public (add-extra-styles stx styles)
@ -236,7 +242,8 @@
;; Initialize ;; Initialize
(super-new) (super-new)
(send/i controller controller<%> add-syntax-display this))) (send/i controller controller<%> add-syntax-display this)
(initialize)))
;; fixup-parentheses : string range -> void ;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range) (define (fixup-parentheses string range)

18
collects/macro-debugger/syntax-browser/properties.rkt
View File

@ -4,6 +4,7 @@
framework framework
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"util.rkt"
"../util/mpi.rkt" "../util/mpi.rkt"
"../util/stxobj.rkt") "../util/stxobj.rkt")
(provide properties-view% (provide properties-view%
@ -58,17 +59,12 @@
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(send* text (with-unlock text
(lock #f) (send text erase)
(begin-edit-sequence #f) (if (syntax? selected-syntax)
(erase)) (refresh/mode mode)
(if (syntax? selected-syntax) (refresh/mode #f)))
(refresh/mode mode) (send text scroll-to-position 0))
(refresh/mode #f))
(send* text
(end-edit-sequence)
(lock #t)
(scroll-to-position 0)))
;; refresh/mode : symbol -> void ;; refresh/mode : symbol -> void
(define/public (refresh/mode mode) (define/public (refresh/mode mode)

36
collects/macro-debugger/syntax-browser/snip-decorated.rkt
View File

@ -7,6 +7,7 @@
"controller.rkt" "controller.rkt"
"properties.rkt" "properties.rkt"
"prefs.rkt" "prefs.rkt"
"util.rkt"
(except-in "snip.rkt" (except-in "snip.rkt"
snip-class)) snip-class))
@ -47,26 +48,21 @@
(define open? #f) (define open? #f)
(define/public (refresh-contents) (define/public (refresh-contents)
(send* -outer (with-unlock -outer
(begin-edit-sequence) (send -outer erase)
(lock #f) (do-style (if open? open-style closed-style))
(erase)) (outer:insert (if open? (hide-icon) (show-icon))
(do-style (if open? open-style closed-style)) style:hyper
(outer:insert (if open? (hide-icon) (show-icon)) (if open?
style:hyper (lambda _
(if open? (set! open? #f)
(lambda _ (refresh-contents))
(set! open? #f) (lambda _
(refresh-contents)) (set! open? #t)
(lambda _ (refresh-contents))))
(set! open? #t) (for-each (lambda (s) (outer:insert s))
(refresh-contents)))) (if open? (open-contents) (closed-contents)))
(for-each (lambda (s) (outer:insert s)) (send -outer change-style top-aligned 0 (send -outer last-position))))
(if open? (open-contents) (closed-contents)))
(send* -outer
(change-style top-aligned 0 (send -outer last-position))
(lock #t)
(end-edit-sequence)))
(define/private (do-style style) (define/private (do-style style)
(show-border (memq 'border style)) (show-border (memq 'border style))

9
collects/macro-debugger/syntax-browser/snip.rkt
View File

@ -7,6 +7,7 @@
"display.rkt" "display.rkt"
"controller.rkt" "controller.rkt"
"keymap.rkt" "keymap.rkt"
"util.rkt"
"prefs.rkt") "prefs.rkt")
(provide syntax-snip% (provide syntax-snip%
@ -34,12 +35,10 @@
;;(set-margin 2 2 2 2) ;;(set-margin 2 2 2 2)
(set-inset 0 0 0 0) (set-inset 0 0 0 0)
(send text begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top))
(define display (define display
(print-syntax-to-editor stx text controller config columns)) (with-unlock text
(send text lock #t) (send text change-style (make-object style-delta% 'change-alignment 'top))
(send text end-edit-sequence) (print-syntax-to-editor stx text controller config columns)))
(send text hide-caret #t) (send text hide-caret #t)
(setup-keymap text) (setup-keymap text)

17
collects/macro-debugger/syntax-browser/util.rkt
View File

@ -10,13 +10,16 @@
[(with-unlock text . body) [(with-unlock text . body)
(let* ([t text] (let* ([t text]
[locked? (send t is-locked?)]) [locked? (send t is-locked?)])
(send* t (dynamic-wind
(lock #f) (lambda ()
(begin-edit-sequence #f)) (send* t
(begin0 (let () . body) (begin-edit-sequence #f)
(send* t (lock #f)))
(end-edit-sequence) (lambda () . body)
(lock locked?))))])) (lambda ()
(send* t
(lock locked?)
(end-edit-sequence)))))]))
;; make-text-port : text (-> number) -> port ;; make-text-port : text (-> number) -> port
;; builds a port from a text object. ;; builds a port from a text object.

40
collects/macro-debugger/syntax-browser/widget.rkt
View File

@ -112,21 +112,25 @@
#:hi-colors [hi-colors null] #:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null] #:hi-stxss [hi-stxss null]
#:substitutions [substitutions null]) #:substitutions [substitutions null])
(let ([display (internal-add-syntax stx)] (with-unlock -text
[definite-table (make-hasheq)]) (define display
(print-syntax-to-editor stx -text controller config
(calculate-columns)
(send -text last-position)))
(define definite-table (make-hasheq))
(send -text insert "\n")
(let ([range (send/i display display<%> get-range)] (let ([range (send/i display display<%> get-range)]
[offset (send/i display display<%> get-start-position)]) [offset (send/i display display<%> get-start-position)])
(for ([subst substitutions]) (for ([subst substitutions])
(for ([r (send/i range range<%> get-ranges (car subst))]) (for ([r (send/i range range<%> get-ranges (car subst))])
(with-unlock -text (send -text insert (cdr subst)
(send -text insert (cdr subst) (+ offset (car r))
(+ offset (car r)) (+ offset (cdr r))
(+ offset (cdr r)) #f)
#f) (send -text change-style
(send -text change-style (code-style -text (send/i config config<%> get-syntax-font-size))
(code-style -text (send/i config config<%> get-syntax-font-size)) (+ offset (car r))
(+ offset (car r)) (+ offset (cdr r))))))
(+ offset (cdr r)))))))
(for ([hi-stxs hi-stxss] [hi-color hi-colors]) (for ([hi-stxs hi-stxss] [hi-color hi-colors])
(send/i display display<%> highlight-syntaxes hi-stxs hi-color)) (send/i display display<%> highlight-syntaxes hi-stxs hi-color))
(for ([definite definites]) (for ([definite definites])
@ -151,6 +155,7 @@
(send/i display display<%> underline-syntaxes (send/i display display<%> underline-syntaxes
(append (apply append (map get-shifted binders)) (append (apply append (map get-shifted binders))
binders)) binders))
(send display refresh)
;; Make arrows (& billboards, when enabled) ;; Make arrows (& billboards, when enabled)
(for ([id (send/i range range<%> get-identifier-list)]) (for ([id (send/i range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f)) (define definite? (hash-ref definite-table id #f))
@ -203,19 +208,6 @@
(define/public (get-text) -text) (define/public (get-text) -text)
;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx)
(with-unlock -text
(let ([display
(print-syntax-to-editor stx -text controller config
(calculate-columns)
(send -text last-position))])
(send* -text
(insert "\n")
;;(scroll-to-position current-position)
)
display)))
(define/private (calculate-columns) (define/private (calculate-columns)
(define style (code-style -text (send/i config config<%> get-syntax-font-size))) (define style (code-style -text (send/i config config<%> get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc))) (define char-width (send style get-text-width (send -ecanvas get-dc)))

97
collects/macro-debugger/view/gui-util.rkt
View File

@ -3,13 +3,13 @@
racket/gui/base) racket/gui/base)
(provide status-area%) (provide status-area%)
(define SHOW-DELAY 1000) (define FADE-DELAY 1000)
(define FADE-DELAY 400) (define NAP-TIME 0.01)
(define NAP-TIME 0.1)
(define status-area% (define status-area%
(class* object% (#| status-area<%> |#) (class* object% (#| status-area<%> |#)
(init parent) (init parent
stop-callback)
(define lock (make-semaphore 1)) (define lock (make-semaphore 1))
@ -18,7 +18,7 @@
(lambda () . body) (lambda () . body)
(lambda () (semaphore-post lock)))) (lambda () (semaphore-post lock))))
(define timer (new timer% (notify-callback (lambda () (update))))) (define timer (new timer% (notify-callback (lambda () (fade-out)))))
(define pane (define pane
(new horizontal-pane% (new horizontal-pane%
@ -29,69 +29,78 @@
(parent pane) (parent pane)
(label "") (label "")
(auto-resize #t) (auto-resize #t)
(stretchable-width #t)
(style '(deleted))))
(define stop-button
(new button%
(parent pane)
(label "Stop")
(enabled #f)
(callback stop-callback)
(style '(deleted)))) (style '(deleted))))
(define visible? #t)
(define/public (set-visible new-visible?)
(with-lock
(set! visible? new-visible?)
(show (memq state '(shown fade)))))
#| #|
Four states: Three states:
- 'none = no message displayed, none pending - 'none = no message displayed
- 'pending = no message displayed, message pending
- 'shown = message displayed - 'shown = message displayed
- 'fade = message displayed, waiting to erase - 'fade = message displayed, waiting to erase
Timer is only started during 'fade state.
|# |#
(define state 'none) (define state 'none)
(define pending #f)
(define/public (set-status msg [immediate? #f]) (define/private (show ?)
(send pane change-children
(lambda _
(if (and ? visible?)
(list message stop-button)
null))))
(define/public (set-status msg)
(with-lock (with-lock
(when immediate? (send timer stop))
(cond [msg (cond [msg
(case state (case state
((none) ((none)
(cond [#f ;; immediate? (send message set-label msg)
(set! state 'shown) (send message enable #t)
(send pane change-children (lambda _ (list message))) (show #t)
(send message set-label msg) (sleep/yield NAP-TIME)
(set! pending #f) (set! state 'shown))
(sleep/yield NAP-TIME)]
[else
(set! state 'pending)
(set! pending msg)
(unless immediate? (send timer start SHOW-DELAY #t))]))
((pending)
(set! pending msg))
((shown) ((shown)
(send message set-label msg)) (send message set-label msg))
((fade) ((fade)
(send timer stop) ;; but (update) may already be waiting (send timer stop) ;; but (update) may already be waiting
(set! state 'shown) (send message set-label msg)
(send message set-label msg)))] (send message enable #t)
(set! state 'shown)))]
[(not msg) [(not msg)
(case state (case state
((none) (void))
((pending)
(send timer stop) ;; but (update) may already be waiting
(set! state 'none)
(set! pending #f))
((shown) ((shown)
(set! state 'fade) (send timer start FADE-DELAY #t)
(unless immediate? (send timer start FADE-DELAY #t))))]) (send message enable #f)
(when immediate? (update*) (sleep/yield NAP-TIME)))) (set! state 'fade)))])))
(define/private (update) (define/private (fade-out)
(with-lock (update*))) (with-lock (fade-out*)))
(define/private (update*) (define/private (fade-out*)
(case state (case state
((pending)
(set! state 'shown)
(send pane change-children (lambda _ (list message)))
(send message set-label pending)
(set! pending #f))
((fade) ((fade)
(set! state 'none) (show #f)
(send pane change-children (lambda _ null))) (send message set-label "")
((none shown) (set! state 'none))
(else
;; timer not stopped in time; do nothing ;; timer not stopped in time; do nothing
(void)))) (void))))
(define/public (enable-stop ?)
(send stop-button enable ?))
(super-new))) (super-new)))

14
collects/macro-debugger/view/step-display.rkt
View File

@ -31,9 +31,13 @@
(define/public (add-internal-error part exn stx events) (define/public (add-internal-error part exn stx events)
(send/i sbview sb:syntax-browser<%> add-text (send/i sbview sb:syntax-browser<%> add-text
(if part (string-append
(format "Macro stepper error (~a)" part) (if (exn:break? exn)
"Macro stepper error")) "Macro stepper was interrupted"
"Macro stepper error")
(if part
(format " (~a)" part)
"")))
(when (exn? exn) (when (exn? exn)
(send/i sbview sb:syntax-browser<%> add-text " ") (send/i sbview sb:syntax-browser<%> add-text " ")
(send/i sbview sb:syntax-browser<%> add-clickback "[details]" (send/i sbview sb:syntax-browser<%> add-clickback "[details]"
@ -44,7 +48,9 @@
(when stx (send/i sbview sb:syntax-browser<%> add-syntax stx))) (when stx (send/i sbview sb:syntax-browser<%> add-syntax stx)))
(define/private (show-internal-error-details exn events) (define/private (show-internal-error-details exn events)
(case (message-box/custom "Macro stepper internal error" (case (message-box/custom (if (exn:break? exn)
"Macro stepper was interrupted"
"Macro stepper internal error")
(format "Internal error:\n~a" (exn-message exn)) (format "Internal error:\n~a" (exn-message exn))
"Show error" "Show error"
"Dump debugging file" "Dump debugging file"

95
collects/macro-debugger/view/stepper.rkt
View File

@ -4,6 +4,7 @@
racket/list racket/list
racket/match racket/match
racket/gui/base racket/gui/base
racket/pretty
unstable/class-iop unstable/class-iop
"interfaces.rkt" "interfaces.rkt"
"extensions.rkt" "extensions.rkt"
@ -15,6 +16,7 @@
"../model/deriv-util.rkt" "../model/deriv-util.rkt"
"cursor.rkt" "cursor.rkt"
"gui-util.rkt" "gui-util.rkt"
"../syntax-browser/util.rkt"
unstable/gui/notify unstable/gui/notify
(only-in mzscheme [#%top-interaction mz-top-interaction])) (only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget% (provide macro-stepper-widget%
@ -108,7 +110,10 @@
(update/preserve-view)) (update/preserve-view))
(define superarea (new vertical-pane% (parent parent))) (define superarea (new vertical-pane% (parent parent)))
(define area (new vertical-panel% (parent superarea))) (define area
(new vertical-panel%
(parent superarea)
(enabled #f)))
(define supernavigator (define supernavigator
(new horizontal-panel% (new horizontal-panel%
(parent area) (parent area)
@ -148,7 +153,9 @@
(config config))) (config config)))
(define status-area (define status-area
(new status-area% (parent superarea))) (new status-area%
(parent superarea)
(stop-callback (lambda _ (stop-processing)))))
(send/i sbc sb:controller<%> (send/i sbc sb:controller<%>
listen-selected-syntax listen-selected-syntax
@ -252,8 +259,8 @@
(list navigator extra-navigator) (list navigator extra-navigator)
(list navigator))))) (list navigator)))))
(define/public (change-status msg [immediate? #f]) (define/public (change-status msg)
(send status-area set-status msg immediate?)) (send status-area set-status msg))
;; Navigation ;; Navigation
(define/public-final (navigate-to-start) (define/public-final (navigate-to-start)
@ -295,15 +302,57 @@
(send nav:end enable (and ? term (send/i term term-record<%> has-next?))) (send nav:end enable (and ? term (send/i term term-record<%> has-next?)))
(send nav:text enable (and ? term #t)) (send nav:text enable (and ? term #t))
(send nav:up enable (and ? (cursor:has-prev? terms))) (send nav:up enable (and ? (cursor:has-prev? terms)))
(send nav:down enable (and ? (cursor:has-next? terms)))) (send nav:down enable (and ? (cursor:has-next? terms)))
(send status-area enable-stop (not ?)))
;; Async update & refresh ;; Async update & refresh
(define update-thread #f)
(define ASYNC-DELAY 500) ;; milliseconds
(define/private (call-with-update-thread thunk)
(send status-area set-visible #f)
(let* ([lock (make-semaphore 1)] ;; mutex for status variable
[status #f] ;; mutable: one of #f, 'done, 'async
[thd
(parameterize-break #f
(thread (lambda ()
(with-handlers ([exn:break?
(lambda (e)
(change-status "Interrupted")
(void))])
(parameterize-break #t
(thunk)
(change-status #f)))
(semaphore-wait lock)
(case status
((async)
(set! update-thread #f)
(with-eventspace
(enable/disable-buttons #t)))
(else
(set! status 'done)))
(semaphore-post lock))))])
(sync thd (alarm-evt (+ (current-inexact-milliseconds) ASYNC-DELAY)))
(semaphore-wait lock)
(case status
((done)
;; Thread finished; enable/disable skipped, so do it now to update.
(enable/disable-buttons #t))
(else
(set! update-thread thd)
(send status-area set-visible #t)
(enable/disable-buttons #f)
(set! status 'async)))
(semaphore-post lock)))
(define-syntax-rule (with-update-thread . body) (define-syntax-rule (with-update-thread . body)
(begin (enable/disable-buttons #f) (call-with-update-thread (lambda () . body)))
(thread (lambda ()
(let () . body) (define/private (stop-processing)
(enable/disable-buttons #t))))) (let ([t update-thread])
(when t (break-thread t))))
;; Update ;; Update
@ -362,30 +411,23 @@
(define text (send/i sbview sb:syntax-browser<%> get-text)) (define text (send/i sbview sb:syntax-browser<%> get-text))
(define position-of-interest 0) (define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1)) (define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence #f)
(send/i sbview sb:syntax-browser<%> erase-all)
;;(change-status "Showing prefix") (with-unlock text
;;(sleep 1) (send/i sbview sb:syntax-browser<%> erase-all)
(update:show-prefix) (update:show-prefix)
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator)) (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position)) (set! position-of-interest (send text last-position))
;;(change-status "Showing current step") (update:show-current-step)
;;(sleep 1) (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
(update:show-current-step) (update:show-suffix))
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
;;(change-status "Showing suffix")
;;(sleep 1)
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position (send text scroll-to-position
position-of-interest position-of-interest
#f #f
(send text last-position) (send text last-position)
'start) 'start)
(update-nav-index) (update-nav-index)
(change-status #f) (change-status #f))
#| (enable/disable-buttons) |#)
;; -- ;; --
@ -436,7 +478,6 @@
(super-new) (super-new)
(show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?)) (show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?))
(show-extra-navigation (send/i config config<%> get-extra-navigation?)) (show-extra-navigation (send/i config config<%> get-extra-navigation?))
;;(refresh/move)
)) ))
(define (macro-stepper-widget/process-mixin %) (define (macro-stepper-widget/process-mixin %)

17
collects/macro-debugger/view/term-record.rkt
View File

@ -57,14 +57,9 @@
(define/private (status msg) (define/private (status msg)
(send stepper change-status msg)) (send stepper change-status msg))
(define-syntax with-status (define-syntax-rule (with-status msg . body)
(syntax-rules () (begin (send stepper change-status msg)
[(ws msg #:immediate . body) (begin0 (let () . body))))
(begin (send stepper change-status msg #t)
(begin0 (let () . body)))]
[(ws msg . body)
(begin (send stepper change-status msg)
(begin0 (let () . body)))]))
(super-new) (super-new)
@ -125,7 +120,7 @@
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
(lambda (e) (lambda (e)
(set! raw-deriv-oops e))]) (set! raw-deriv-oops e))])
(with-status "Parsing expansion derivation" #:immediate (with-status "Parsing expansion derivation"
(set! raw-deriv (set! raw-deriv
(parse-derivation (parse-derivation
(events->token-generator events))))))) (events->token-generator events)))))))
@ -135,7 +130,7 @@
(unless (or deriv deriv-hidden?) (unless (or deriv deriv-hidden?)
(recache-raw-deriv!) (recache-raw-deriv!)
(when raw-deriv (when raw-deriv
(with-status "Processing expansion derivation" #:immediate (with-status "Processing expansion derivation"
(let ([process (send/i stepper widget<%> get-preprocess-deriv)]) (let ([process (send/i stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)]) (let ([d (process raw-deriv)])
(when (not d) (when (not d)
@ -153,7 +148,7 @@
(unless (or raw-steps raw-steps-oops) (unless (or raw-steps raw-steps-oops)
(recache-synth!) (recache-synth!)
(when deriv (when deriv
(with-status "Computing reduction steps" #:immediate (with-status "Computing reduction steps"
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?) (let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
(lambda (id) #t))]) (lambda (id) #t))])
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)