commit cbc04f4ea3eca371d09bf8ec99e1031d1dbc2bab
parent 35bae395154f59f9b05e043ade2d04d731860fd3
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 4 Nov 2010 16:24:54 -0600
macro-stepper: faster rendering, async improvements
added async stop button (and disable breaks around editor operations)
eliminated redundant calls to refresh in display<%>
original commit: 0d3b092097973fa0f5824a20a80b172b24185320
Diffstat:
10 files changed, 252 insertions(+), 208 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt
@@ -2,7 +2,7 @@
(require racket/class
racket/gui/base
racket/list
- racket/block
+ racket/pretty
framework
unstable/class-iop
"pretty-printer.rkt"
@@ -12,46 +12,52 @@
(provide print-syntax-to-editor
code-style)
-(define TIME-PRINTING? #f)
-
-(define-syntax-rule (now)
- (if TIME-PRINTING?
- (current-inexact-milliseconds)
- 0))
+(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 (now) (current-inexact-milliseconds))
;; FIXME: assumes text never moves
;; print-syntax-to-editor : syntax text controller<%> config number number
;; -> display<%>
+;; Note: must call display<%>::refresh to finish styling.
(define (print-syntax-to-editor stx text controller config columns
[insertion-point (send text last-position)])
- (block
- (define output-port (open-output-string/count-lines))
- (define range
- (pretty-print-syntax stx output-port
- (send/i controller controller<%> get-primary-partition)
- (length (send/i config config<%> get-colors))
- (send/i config config<%> get-suffix-option)
- (send config get-pretty-styles)
- columns))
- (define output-string (get-output-string output-port))
- (define output-length (sub1 (string-length output-string))) ;; skip final newline
- (fixup-parentheses output-string range)
- (send text begin-edit-sequence #f)
- (send text insert output-length output-string insertion-point)
- (define display
- (new display%
- (text text)
- (controller controller)
- (config config)
- (range range)
- (start-position insertion-point)
- (end-position (+ insertion-point output-length))))
- (send display initialize)
- (send text end-edit-sequence)
- display))
+ (define output-port (open-output-string/count-lines))
+ (define range
+ (pretty-print-syntax stx output-port
+ (send/i controller controller<%> get-primary-partition)
+ (length (send/i config config<%> get-colors))
+ (send/i config config<%> get-suffix-option)
+ (send config get-pretty-styles)
+ columns))
+ (define output-string (get-output-string output-port))
+ (define output-length (sub1 (string-length output-string))) ;; skip final newline
+ (fixup-parentheses output-string range)
+ (with-unlock text
+ (uninterruptible
+ (send text insert output-length output-string insertion-point))
+ (new display%
+ (text text)
+ (controller controller)
+ (config config)
+ (range range)
+ (start-position insertion-point)
+ (end-position (+ insertion-point output-length)))))
;; display%
+;; Note: must call refresh method to finish styling.
(define display%
(class* object% (display<%>)
(init-field/i [controller controller<%>]
@@ -66,12 +72,15 @@
(define extra-styles (make-hasheq))
+ (define auto-refresh? #f) ;; FIXME: delete or make init arg
+
;; initialize : -> void
- (define/public (initialize)
- (send text change-style base-style start-position end-position #f)
- (apply-primary-partition-styles)
- (add-clickbacks)
- (refresh))
+ (define/private (initialize)
+ (uninterruptible
+ (send text change-style base-style start-position end-position #f))
+ (uninterruptible (apply-primary-partition-styles))
+ (uninterruptible (add-clickbacks))
+ (when auto-refresh? (refresh)))
;; add-clickbacks : -> void
(define/private (add-clickbacks)
@@ -103,18 +112,15 @@
;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh)
- (with-unlock text
- (send* text
- (begin-edit-sequence #f)
- (change-style (unhighlight-d) start-position end-position))
- (apply-extra-styles)
- (let ([selected-syntax
- (send/i controller selection-manager<%>
- get-selected-syntax)])
- (apply-secondary-relation-styles selected-syntax)
- (apply-selection-styles selected-syntax))
- (send* text
- (end-edit-sequence))))
+ (uninterruptible
+ (with-unlock text
+ (send text change-style (unhighlight-d) start-position end-position)
+ (apply-extra-styles)
+ (let ([selected-syntax
+ (send/i controller selection-manager<%>
+ get-selected-syntax)])
+ (apply-secondary-relation-styles selected-syntax)
+ (apply-selection-styles selected-syntax)))))
;; get-range : -> range<%>
(define/public (get-range) range)
@@ -130,13 +136,13 @@
(let ([style-delta (highlight-style-delta hi-color #f)])
(for ([stx stxs])
(add-extra-styles stx (list style-delta))))
- (refresh))
+ (when auto-refresh? (refresh)))
;; underline-syntaxes : (listof syntax) -> void
(define/public (underline-syntaxes stxs)
(for ([stx stxs])
(add-extra-styles stx (list underline-style-delta)))
- (refresh))
+ (when auto-refresh? (refresh)))
;; add-extra-styles : syntax (listof style) -> void
(define/public (add-extra-styles stx styles)
@@ -236,7 +242,8 @@
;; Initialize
(super-new)
- (send/i controller controller<%> add-syntax-display this)))
+ (send/i controller controller<%> add-syntax-display this)
+ (initialize)))
;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range)
diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt
@@ -4,6 +4,7 @@
framework
unstable/class-iop
"interfaces.rkt"
+ "util.rkt"
"../util/mpi.rkt"
"../util/stxobj.rkt")
(provide properties-view%
@@ -58,17 +59,12 @@
;; refresh : -> void
(define/public (refresh)
- (send* text
- (lock #f)
- (begin-edit-sequence #f)
- (erase))
- (if (syntax? selected-syntax)
- (refresh/mode mode)
- (refresh/mode #f))
- (send* text
- (end-edit-sequence)
- (lock #t)
- (scroll-to-position 0)))
+ (with-unlock text
+ (send text erase)
+ (if (syntax? selected-syntax)
+ (refresh/mode mode)
+ (refresh/mode #f)))
+ (send text scroll-to-position 0))
;; refresh/mode : symbol -> void
(define/public (refresh/mode mode)
diff --git a/collects/macro-debugger/syntax-browser/snip-decorated.rkt b/collects/macro-debugger/syntax-browser/snip-decorated.rkt
@@ -7,6 +7,7 @@
"controller.rkt"
"properties.rkt"
"prefs.rkt"
+ "util.rkt"
(except-in "snip.rkt"
snip-class))
@@ -47,26 +48,21 @@
(define open? #f)
(define/public (refresh-contents)
- (send* -outer
- (begin-edit-sequence)
- (lock #f)
- (erase))
- (do-style (if open? open-style closed-style))
- (outer:insert (if open? (hide-icon) (show-icon))
- style:hyper
- (if open?
- (lambda _
- (set! open? #f)
- (refresh-contents))
- (lambda _
- (set! open? #t)
- (refresh-contents))))
- (for-each (lambda (s) (outer:insert s))
- (if open? (open-contents) (closed-contents)))
- (send* -outer
- (change-style top-aligned 0 (send -outer last-position))
- (lock #t)
- (end-edit-sequence)))
+ (with-unlock -outer
+ (send -outer erase)
+ (do-style (if open? open-style closed-style))
+ (outer:insert (if open? (hide-icon) (show-icon))
+ style:hyper
+ (if open?
+ (lambda _
+ (set! open? #f)
+ (refresh-contents))
+ (lambda _
+ (set! open? #t)
+ (refresh-contents))))
+ (for-each (lambda (s) (outer:insert s))
+ (if open? (open-contents) (closed-contents)))
+ (send -outer change-style top-aligned 0 (send -outer last-position))))
(define/private (do-style style)
(show-border (memq 'border style))
diff --git a/collects/macro-debugger/syntax-browser/snip.rkt b/collects/macro-debugger/syntax-browser/snip.rkt
@@ -7,6 +7,7 @@
"display.rkt"
"controller.rkt"
"keymap.rkt"
+ "util.rkt"
"prefs.rkt")
(provide syntax-snip%
@@ -34,12 +35,10 @@
;;(set-margin 2 2 2 2)
(set-inset 0 0 0 0)
- (send text begin-edit-sequence)
- (send text change-style (make-object style-delta% 'change-alignment 'top))
(define display
- (print-syntax-to-editor stx text controller config columns))
- (send text lock #t)
- (send text end-edit-sequence)
+ (with-unlock text
+ (send text change-style (make-object style-delta% 'change-alignment 'top))
+ (print-syntax-to-editor stx text controller config columns)))
(send text hide-caret #t)
(setup-keymap text)
diff --git a/collects/macro-debugger/syntax-browser/util.rkt b/collects/macro-debugger/syntax-browser/util.rkt
@@ -10,13 +10,16 @@
[(with-unlock text . body)
(let* ([t text]
[locked? (send t is-locked?)])
- (send* t
- (lock #f)
- (begin-edit-sequence #f))
- (begin0 (let () . body)
- (send* t
- (end-edit-sequence)
- (lock locked?))))]))
+ (dynamic-wind
+ (lambda ()
+ (send* t
+ (begin-edit-sequence #f)
+ (lock #f)))
+ (lambda () . body)
+ (lambda ()
+ (send* t
+ (lock locked?)
+ (end-edit-sequence)))))]))
;; make-text-port : text (-> number) -> port
;; builds a port from a text object.
diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt
@@ -112,21 +112,25 @@
#:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null]
#:substitutions [substitutions null])
- (let ([display (internal-add-syntax stx)]
- [definite-table (make-hasheq)])
+ (with-unlock -text
+ (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)]
[offset (send/i display display<%> get-start-position)])
(for ([subst substitutions])
(for ([r (send/i range range<%> get-ranges (car subst))])
- (with-unlock -text
- (send -text insert (cdr subst)
- (+ offset (car r))
- (+ offset (cdr r))
- #f)
- (send -text change-style
- (code-style -text (send/i config config<%> get-syntax-font-size))
- (+ offset (car r))
- (+ offset (cdr r)))))))
+ (send -text insert (cdr subst)
+ (+ offset (car r))
+ (+ offset (cdr r))
+ #f)
+ (send -text change-style
+ (code-style -text (send/i config config<%> get-syntax-font-size))
+ (+ offset (car r))
+ (+ offset (cdr r))))))
(for ([hi-stxs hi-stxss] [hi-color hi-colors])
(send/i display display<%> highlight-syntaxes hi-stxs hi-color))
(for ([definite definites])
@@ -151,6 +155,7 @@
(send/i display display<%> underline-syntaxes
(append (apply append (map get-shifted binders))
binders))
+ (send display refresh)
;; Make arrows (& billboards, when enabled)
(for ([id (send/i range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
@@ -203,19 +208,6 @@
(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 style (code-style -text (send/i config config<%> get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
diff --git a/collects/macro-debugger/view/gui-util.rkt b/collects/macro-debugger/view/gui-util.rkt
@@ -3,13 +3,13 @@
racket/gui/base)
(provide status-area%)
-(define SHOW-DELAY 1000)
-(define FADE-DELAY 400)
-(define NAP-TIME 0.1)
+(define FADE-DELAY 1000)
+(define NAP-TIME 0.01)
(define status-area%
(class* object% (#| status-area<%> |#)
- (init parent)
+ (init parent
+ stop-callback)
(define lock (make-semaphore 1))
@@ -18,7 +18,7 @@
(lambda () . body)
(lambda () (semaphore-post lock))))
- (define timer (new timer% (notify-callback (lambda () (update)))))
+ (define timer (new timer% (notify-callback (lambda () (fade-out)))))
(define pane
(new horizontal-pane%
@@ -29,69 +29,78 @@
(parent pane)
(label "")
(auto-resize #t)
+ (stretchable-width #t)
(style '(deleted))))
+ (define stop-button
+ (new button%
+ (parent pane)
+ (label "Stop")
+ (enabled #f)
+ (callback stop-callback)
+ (style '(deleted))))
+
+ (define visible? #t)
+
+ (define/public (set-visible new-visible?)
+ (with-lock
+ (set! visible? new-visible?)
+ (show (memq state '(shown fade)))))
#|
- Four states:
- - 'none = no message displayed, none pending
- - 'pending = no message displayed, message pending
+ Three states:
+ - 'none = no message displayed
- 'shown = message displayed
- 'fade = message displayed, waiting to erase
+
+ Timer is only started during 'fade state.
|#
(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
- (when immediate? (send timer stop))
(cond [msg
(case state
((none)
- (cond [#f ;; immediate?
- (set! state 'shown)
- (send pane change-children (lambda _ (list message)))
- (send message set-label msg)
- (set! pending #f)
- (sleep/yield NAP-TIME)]
- [else
- (set! state 'pending)
- (set! pending msg)
- (unless immediate? (send timer start SHOW-DELAY #t))]))
- ((pending)
- (set! pending msg))
+ (send message set-label msg)
+ (send message enable #t)
+ (show #t)
+ (sleep/yield NAP-TIME)
+ (set! state 'shown))
((shown)
(send message set-label msg))
((fade)
(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)
(case state
- ((none) (void))
- ((pending)
- (send timer stop) ;; but (update) may already be waiting
- (set! state 'none)
- (set! pending #f))
((shown)
- (set! state 'fade)
- (unless immediate? (send timer start FADE-DELAY #t))))])
- (when immediate? (update*) (sleep/yield NAP-TIME))))
+ (send timer start FADE-DELAY #t)
+ (send message enable #f)
+ (set! state 'fade)))])))
- (define/private (update)
- (with-lock (update*)))
+ (define/private (fade-out)
+ (with-lock (fade-out*)))
- (define/private (update*)
+ (define/private (fade-out*)
(case state
- ((pending)
- (set! state 'shown)
- (send pane change-children (lambda _ (list message)))
- (send message set-label pending)
- (set! pending #f))
((fade)
- (set! state 'none)
- (send pane change-children (lambda _ null)))
- ((none shown)
+ (show #f)
+ (send message set-label "")
+ (set! state 'none))
+ (else
;; timer not stopped in time; do nothing
(void))))
+ (define/public (enable-stop ?)
+ (send stop-button enable ?))
+
(super-new)))
diff --git a/collects/macro-debugger/view/step-display.rkt b/collects/macro-debugger/view/step-display.rkt
@@ -31,9 +31,13 @@
(define/public (add-internal-error part exn stx events)
(send/i sbview sb:syntax-browser<%> add-text
- (if part
- (format "Macro stepper error (~a)" part)
- "Macro stepper error"))
+ (string-append
+ (if (exn:break? exn)
+ "Macro stepper was interrupted"
+ "Macro stepper error")
+ (if part
+ (format " (~a)" part)
+ "")))
(when (exn? exn)
(send/i sbview sb:syntax-browser<%> add-text " ")
(send/i sbview sb:syntax-browser<%> add-clickback "[details]"
@@ -44,7 +48,9 @@
(when stx (send/i sbview sb:syntax-browser<%> add-syntax stx)))
(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))
"Show error"
"Dump debugging file"
diff --git a/collects/macro-debugger/view/stepper.rkt b/collects/macro-debugger/view/stepper.rkt
@@ -4,6 +4,7 @@
racket/list
racket/match
racket/gui/base
+ racket/pretty
unstable/class-iop
"interfaces.rkt"
"extensions.rkt"
@@ -15,6 +16,7 @@
"../model/deriv-util.rkt"
"cursor.rkt"
"gui-util.rkt"
+ "../syntax-browser/util.rkt"
unstable/gui/notify
(only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget%
@@ -108,7 +110,10 @@
(update/preserve-view))
(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
(new horizontal-panel%
(parent area)
@@ -148,7 +153,9 @@
(config config)))
(define status-area
- (new status-area% (parent superarea)))
+ (new status-area%
+ (parent superarea)
+ (stop-callback (lambda _ (stop-processing)))))
(send/i sbc sb:controller<%>
listen-selected-syntax
@@ -252,8 +259,8 @@
(list navigator extra-navigator)
(list navigator)))))
- (define/public (change-status msg [immediate? #f])
- (send status-area set-status msg immediate?))
+ (define/public (change-status msg)
+ (send status-area set-status msg))
;; Navigation
(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:text enable (and ? term #t))
(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
+ (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)
- (begin (enable/disable-buttons #f)
- (thread (lambda ()
- (let () . body)
- (enable/disable-buttons #t)))))
+ (call-with-update-thread (lambda () . body)))
+
+ (define/private (stop-processing)
+ (let ([t update-thread])
+ (when t (break-thread t))))
;; Update
@@ -362,30 +411,23 @@
(define text (send/i sbview sb:syntax-browser<%> get-text))
(define position-of-interest 0)
(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")
- ;;(sleep 1)
- (update:show-prefix)
- (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
- (set! position-of-interest (send text last-position))
- ;;(change-status "Showing current step")
- ;;(sleep 1)
- (update:show-current-step)
- (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)
+
+ (with-unlock text
+ (send/i sbview sb:syntax-browser<%> erase-all)
+ (update:show-prefix)
+ (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
+ (set! position-of-interest (send text last-position))
+ (update:show-current-step)
+ (when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
+ (update:show-suffix))
+
(send text scroll-to-position
position-of-interest
#f
(send text last-position)
'start)
(update-nav-index)
- (change-status #f)
- #| (enable/disable-buttons) |#)
+ (change-status #f))
;; --
@@ -436,7 +478,6 @@
(super-new)
(show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?))
(show-extra-navigation (send/i config config<%> get-extra-navigation?))
- ;;(refresh/move)
))
(define (macro-stepper-widget/process-mixin %)
diff --git a/collects/macro-debugger/view/term-record.rkt b/collects/macro-debugger/view/term-record.rkt
@@ -32,7 +32,7 @@
(send/i stepper widget<%> get-step-displayer))
;; Data
-
+
(init-field [events #f])
(init-field [raw-deriv #f])
@@ -52,19 +52,14 @@
(define steps #f)
;; --
-
+
(define steps-position #f)
(define/private (status msg)
(send stepper change-status msg))
- (define-syntax with-status
- (syntax-rules ()
- [(ws msg #:immediate . body)
- (begin (send stepper change-status msg #t)
- (begin0 (let () . body)))]
- [(ws msg . body)
- (begin (send stepper change-status msg)
- (begin0 (let () . body)))]))
+ (define-syntax-rule (with-status msg . body)
+ (begin (send stepper change-status msg)
+ (begin0 (let () . body))))
(super-new)
@@ -125,7 +120,7 @@
(with-handlers ([(lambda (e) #t)
(lambda (e)
(set! raw-deriv-oops e))])
- (with-status "Parsing expansion derivation" #:immediate
+ (with-status "Parsing expansion derivation"
(set! raw-deriv
(parse-derivation
(events->token-generator events)))))))
@@ -135,7 +130,7 @@
(unless (or deriv deriv-hidden?)
(recache-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 ([d (process raw-deriv)])
(when (not d)
@@ -153,7 +148,7 @@
(unless (or raw-steps raw-steps-oops)
(recache-synth!)
(when deriv
- (with-status "Computing reduction steps" #:immediate
+ (with-status "Computing reduction steps"
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
(lambda (id) #t))])
(with-handlers ([(lambda (e) #t)
