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
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 (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)
(if TIME-PRINTING?
(current-inexact-milliseconds)
0))
(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)

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

@ -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)

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

@ -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))

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

@ -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)

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

@ -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.

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

@ -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)))

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

@ -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)))

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

@ -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"

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

@ -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 %)

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

@ -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)