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

UI fixes and improvements to Check Syntax

Browse Source 
- Delays drawing arrows until mouse hovers for a very short time
- Delays drawing arrows when scrolling
- Tooltips appear in the correct pane when the editor is split
- Fixes infinite event queue with scrolling a split editor while a tooltip is displayed
This commit is contained in:
Neil Toronto 2011-11-17 11:22:15 -07:00
parent 004afd88a3
commit 2d0fa3a60b
1 changed files with 215 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

343
collects/drracket/private/syncheck/gui.rkt
View File

@ -68,6 +68,16 @@ If the namespace does not, they are colored the unbound color.
(define cs-syncheck-running "Check Syntax Running") (define cs-syncheck-running "Check Syntax Running")
;; This delay should be long enough that the arrow timer doesn't go off if drawing
;; the editor hitches while scrolling:
(define syncheck-scroll-arrow-delay 1000)
;; This delay should be longer than the time it takes for a quick mouse motion
;; to pass vertically through an identifier
;; It should also be longer than the polling delay for mouse events (which should
;; be < 50ms)
(define syncheck-arrow-delay 100)
(preferences:set-default 'drracket:syncheck-mode 'default-mode (preferences:set-default 'drracket:syncheck-mode 'default-mode
(λ (x) (memq x '(default-mode (λ (x) (memq x '(default-mode
my-obligations-mode my-obligations-mode
@ -387,9 +397,6 @@ If the namespace does not, they are colored the unbound color.
(hash-set! bindings-table k (sort v compare-bindings))))) (hash-set! bindings-table k (sort v compare-bindings)))))
(define tacked-hash-table (make-hasheq)) (define tacked-hash-table (make-hasheq))
(define cursor-location #f)
(define cursor-text #f)
(define cursor-eles #f)
;; find-char-box : text number number -> (values number number number number) ;; find-char-box : text number number -> (values number number number number)
;; returns the bounding box (left, top, right, bottom) for the text range. ;; returns the bounding box (left, top, right, bottom) for the text range.
@ -477,18 +484,17 @@ If the namespace does not, they are colored the unbound color.
(set! style-mapping (make-hash))) (set! style-mapping (make-hash)))
(define/public (syncheck:arrows-visible?) (define/public (syncheck:arrows-visible?)
(or arrow-records cursor-location cursor-text)) (or arrow-records cursor-pos cursor-text cursor-eles cursor-tooltip))
;; syncheck:clear-arrows : -> void ;; syncheck:clear-arrows : -> void
(define/public (syncheck:clear-arrows) (define/public (syncheck:clear-arrows)
(when (or arrow-records cursor-location cursor-text) (when (syncheck:arrows-visible?)
(set! last-known-mouse-x #f)
(set! last-known-mouse-y #f)
(set! tacked-hash-table #f) (set! tacked-hash-table #f)
(set! arrow-records #f) (set! arrow-records #f)
(when (update-latent-arrows #f #f)
(update-drawn-arrows))
(syncheck:clear-coloring) (syncheck:clear-coloring)
(set! style-mapping #f) (set! style-mapping #f)
(syncheck:update-drawn-arrows)
(invalidate-bitmap-cache))) (invalidate-bitmap-cache)))
(define/public (syncheck:clear-coloring) (define/public (syncheck:clear-coloring)
@ -777,9 +783,50 @@ If the namespace does not, they are colored the unbound color.
(set-arrow-end-x! ele #f) (set-arrow-end-x! ele #f)
(set-arrow-end-y! ele #f)))))) (set-arrow-end-y! ele #f))))))
(define view-corner-hash (make-weak-hasheq))
(define (get-last-view-corner admin)
(hash-ref view-corner-hash admin (λ () (cons #f #f))))
(define (set-last-view-corner! admin corner)
(hash-set! view-corner-hash admin corner))
(define (get-view-corner admin)
(define new-x (box #f))
(define new-y (box #f))
(send admin get-view new-x new-y #f #f)
(cons (unbox new-x) (unbox new-y)))
(define (update-view-corner admin)
(define old-corner (get-last-view-corner admin))
(define new-corner (get-view-corner admin))
(define scrolled? (not (equal? old-corner new-corner)))
(set-last-view-corner! admin new-corner)
scrolled?)
(define/override (on-paint before dc left top right bottom dx dy draw-caret) (define/override (on-paint before dc left top right bottom dx dy draw-caret)
(when (and arrow-records (not before)) (when (and arrow-records (not before))
(syncheck:update-drawn-arrows) (define admin (get-admin))
;; update the known editor location for the upper-left corner
(define scrolled? (update-view-corner admin))
;; when painting on the canvas the mouse is over...
(when (eq? mouse-admin admin)
(define update-tooltip-frame?
(cond
;; turn off tooltips if scrolling
[scrolled? (set! cursor-tooltip #f)
#t]
;; try to update the tooltips if they're wrong
[(eq? cursor-tooltip 'out-of-sync)
(set! cursor-tooltip (get-tooltip cursor-eles))
(not (eq? cursor-tooltip 'out-of-sync))]
[else #f]))
(when update-tooltip-frame?
(update-tooltip-frame))
;; update on a timer if the arrows changed
(when (update-latent-arrows mouse-x mouse-y)
(start-arrow-draw-timer (cond [scrolled? syncheck-scroll-arrow-delay]
[else syncheck-arrow-delay]))))
(let ([draw-arrow2 (let ([draw-arrow2
(λ (arrow) (λ (arrow)
(unless (arrow-start-x arrow) (unless (arrow-start-x arrow)
@ -825,12 +872,12 @@ If the namespace does not, they are colored the unbound color.
(send dc set-pen tail-pen) (send dc set-pen tail-pen)
(send dc set-brush tacked-tail-brush)]) (send dc set-brush tacked-tail-brush)])
(draw-arrow2 arrow)))) (draw-arrow2 arrow))))
(when (and cursor-location (when (and cursor-pos
cursor-text) cursor-text)
(define arrow-record (hash-ref arrow-records cursor-text #f)) (define arrow-record (hash-ref arrow-records cursor-text #f))
(define tail-arrows '()) (define tail-arrows '())
(when arrow-record (when arrow-record
(for ([ele (in-list (interval-map-ref arrow-record cursor-location null))]) (for ([ele (in-list (interval-map-ref arrow-record cursor-pos null))])
(cond [(var-arrow? ele) (cond [(var-arrow? ele)
(if (var-arrow-actual? ele) (if (var-arrow-actual? ele)
(begin (send dc set-pen var-pen) (begin (send dc set-pen var-pen)
@ -889,70 +936,113 @@ If the namespace does not, they are colored the unbound color.
(for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text
tail-arrow-to-pos tail-arrow-to-text))) tail-arrow-to-pos tail-arrow-to-text)))
(define last-known-mouse-x #f) ;; after a short delay, current-* are set to latent-*, and arrows are drawn
(define last-known-mouse-y #f) (define latent-pos #f)
(define/override (on-event event) (define latent-text #f)
(define latent-eles #f)
(define latent-tooltip #f)
(define cursor-pos #f)
(define cursor-text #f)
(define cursor-eles #f)
(define cursor-tooltip #f)
(define arrow-draw-timer #f)
(define (stop-arrow-draw-timer)
(when arrow-draw-timer
(send arrow-draw-timer stop)))
(define (start-arrow-draw-timer delay-ms)
(cond (cond
[(send event leaving?) [arrow-draw-timer (send arrow-draw-timer start delay-ms #t)]
(set! last-known-mouse-x #f)
(set! last-known-mouse-y #f)]
[else [else
(set! last-known-mouse-x (send event get-x)) (set! arrow-draw-timer
(set! last-known-mouse-y (send event get-y))]) (make-object timer% update-drawn-arrows delay-ms #t))]))
;; Given a mouse position, updates latent-* variables and tooltips
(define (update-latent-arrows x y)
(define-values (pos text eles tooltip)
(cond
;; need to check this first so syncheck:clear-arrows will work
[(not arrow-records)
(values #f #f #f #f)]
[(and popup-menu (send popup-menu get-popup-target))
(values latent-pos latent-text latent-eles latent-tooltip)]
[(and x y)
(define-values (pos text) (get-pos/text-dc-location x y))
(define arrow-record (and text pos (hash-ref arrow-records text #f)))
(define eles (and arrow-record (interval-map-ref arrow-record pos null)))
(define tooltip (cond [(equal? latent-eles eles) latent-tooltip]
[else (get-tooltip eles)]))
(values pos text eles tooltip)]
[else
(values #f #f #f #f)]))
(define text-changed? (not (eq? latent-text text)))
(define eles-changed? (not (equal? latent-eles eles)))
(if arrow-records (set! latent-pos pos)
(cond (set! latent-text text)
[(send event leaving?) (set! latent-eles eles)
(syncheck:update-drawn-arrows) (set! latent-tooltip tooltip)
(super on-event event)]
[(or (send event moving?) (or text-changed? eles-changed?))
(send event entering?))
(syncheck:update-drawn-arrows) (define (update-drawn-arrows)
(super on-event event)] (set! cursor-pos latent-pos)
[(send event button-down? 'right) (set! cursor-text latent-text)
(define menu (set! cursor-eles latent-eles)
(let-values ([(pos text) (get-pos/text event)]) (set! cursor-tooltip latent-tooltip)
(syncheck:build-popup-menu pos text)))
(cond (update-tooltip-frame)
[menu (update-docs-background cursor-eles)
(send (get-canvas) popup-menu menu
(+ 1 (inexact->exact (floor (send event get-x)))) (when cursor-eles
(+ 1 (inexact->exact (floor (send event get-y)))))] (for ([ele (in-list cursor-eles)])
[else (when (arrow? ele)
(super on-event event)])] (update-arrow-poss ele))))
[else (super on-event event)])
(super on-event event))) (invalidate-bitmap-cache))
(define popup-menu #f)
(define mouse-admin #f) ; editor admin for the last mouse move
(define mouse-x #f) ; last known mouse position
(define mouse-y #f)
(define/override (on-event event)
(define-values (x y)
(cond [(send event leaving?) (values #f #f)]
[else (values (send event get-x) (send event get-y))]))
(set! mouse-admin (get-admin))
(set! mouse-x x)
(set! mouse-y y)
(when (update-latent-arrows x y)
(start-arrow-draw-timer syncheck-arrow-delay))
(let/ec break
(when (send event button-down? 'right)
(define menu
(let-values ([(pos text) (get-pos/text event)])
(syncheck:build-popup-menu pos text)))
(when menu
(set! popup-menu menu)
(send (get-canvas) popup-menu menu
(+ 1 (inexact->exact (floor x)))
(+ 1 (inexact->exact (floor y))))
(break (void))))
(super on-event event)))
(define/public (syncheck:update-drawn-arrows) (define/public (syncheck:update-drawn-arrows)
(define-values (pos text) ;; This will ensure on-paint is called, once for each canvas that
(if (and last-known-mouse-x last-known-mouse-y arrow-records) ;; is displaying the editor. In the on-paint call for the canvas
(get-pos/text-dc-location last-known-mouse-x last-known-mouse-y) ;; that the mouse is over, arrows will be updated, arrow-draw-timer
(values #f #f))) ;; will be set, etc.
(define eles ;; If this were done more directly, the tooltip would show up in
(let ([arrow-record (and text ;; the wrong canvas half the time - when the current admin isn't
pos ;; the admin for the canvas the mouse is over.
(hash-ref arrow-records text #f))]) (invalidate-bitmap-cache))
(and arrow-record
(interval-map-ref arrow-record pos null))))
(unless (and (equal? cursor-location pos)
(eq? cursor-text text))
(set! cursor-location pos)
(set! cursor-text text)
(unless (equal? cursor-eles eles)
(set! cursor-eles eles)
(update-tooltips cursor-eles)
(update-docs-background cursor-eles)
(when cursor-eles
(for ([ele (in-list cursor-eles)])
(when (arrow? ele)
(update-arrow-poss ele))))
(invalidate-bitmap-cache)))
(unless tooltips-in-sync-with-cursor-eles?
;; must be called before cursor-eles is set!'d to be eles
(update-tooltips cursor-eles)))
(define/public (syncheck:build-popup-menu pos text) (define/public (syncheck:build-popup-menu pos text)
(and pos (and pos
(is-a? text text%) (is-a? text text%)
@ -1035,64 +1125,61 @@ If the namespace does not, they are colored the unbound color.
menu)])))))) menu)]))))))
(struct tooltip-spec (strings x y w h) #:transparent)
(define tooltip-frame #f) (define tooltip-frame #f)
(define tooltips-in-sync-with-cursor-eles? #f) (define (update-tooltip-frame)
(define/private (update-tooltips eles) (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
;; update-tooltips has to do its own check to compare 'eles' (match cursor-tooltip
;; with 'cursor-eles' because sometimes when it is called, [(tooltip-spec strings x y w h)
;; the calls to 'tooltip-info->ltrb' fail and we get ;; hiding keeps it from flashing the new tooltip in the old location
;; no information back. when that happens, we set (send tooltip-frame show #f)
;; tooltips-in-sync-with-cursor-eles? to #f and hope that there (send tooltip-frame set-tooltip strings)
;; will be another callback in good time to update us (send tooltip-frame show-over x y w h)]
;; (generally there is because this is called from on-paint ;; #f or 'out-of-sync
;; and on-paint gets called each time the cursor blinks...) [_ (send tooltip-frame show #f)]))
(cond
[(not eles) ;; Sometimes when this is called, the calls to 'tooltip-info->ltrb'
(when tooltip-frame ;; fail and we get no information back. When that happens, we return
(when (send tooltip-frame is-shown?) ;; 'out-of-sync and try again in on-paint (which happens every time
(send tooltip-frame show #f))) ;; the caret blinks).
(set! tooltips-in-sync-with-cursor-eles? #t)] (define/private (get-tooltip eles)
[else (define tooltip-infos (if eles (filter tooltip-info? eles) null))
(define tooltip-infos (filter tooltip-info? eles)) (let loop ([tooltip-infos tooltip-infos]
(cond [l #f] [t #f] [r #f] [b #f]
[(null? tooltip-infos) [strings (set)])
(when tooltip-frame (cond
(when (send tooltip-frame is-shown?) [(null? tooltip-infos)
(send tooltip-frame show #f))) (cond
(set! tooltips-in-sync-with-cursor-eles? #t)] [(and l t r b)
[else (define-values (dx dy) (get-display-left-top-inset))
(unless tooltip-frame (set! tooltip-frame (new tooltip-frame%))) (tooltip-spec (sort (set->list strings) string<=?)
(let/ec k (- l dx) (- t dy) (- r l) (- b t))]
(let loop ([tooltip-infos tooltip-infos] [else #f])]
[l #f] [else
[t #f] (define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos)))
[r #f] (cond
[b #f] [(and tl tt tr tb)
[strings (set)]) (define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f]))
(cond (define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f]))
[(null? tooltip-infos) (loop (cdr tooltip-infos)
(send tooltip-frame set-tooltip (min/f tl l) (min/f tt t) (max/f tr r) (max/f tb b)
(sort (set->list strings) string<=?)) (set-add strings (tooltip-info-msg (car tooltip-infos))))]
(set! tooltips-in-sync-with-cursor-eles? #t) [else
(cond ;(printf "~a: out of sync~n" (current-milliseconds))
[(and l t r b) 'out-of-sync])])))
(define-values (dx dy) (get-display-left-top-inset))
(send tooltip-frame show-over (- l dx) (- t dy) (- r l) (- b t))] ;; Given an editor, returns the canvas that the mouse is currently over,
[else ;; as opposed to the one with keyboard focus (which get-canvas usually returns)
(send tooltip-frame show #f)])] (define (find-mouse-canvas ed)
[else (define current-admin (send ed get-admin))
(define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos))) (let/ec return
(unless (and tl tt tr tb) (for ([canvas (in-list (send ed get-canvases))])
(set! tooltips-in-sync-with-cursor-eles? #f) (define admin (send canvas call-as-primary-owner
(k (void))) (λ () (send ed get-admin))))
(define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f])) (when (eq? admin current-admin)
(define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f])) (return canvas)))
(loop (cdr tooltip-infos) (send ed get-canvas)))
(min/f tl l)
(min/f tt t)
(max/f tr r)
(max/f tb b)
(set-add strings (tooltip-info-msg (car tooltip-infos))))])))])]))
(define/private (tooltip-info->ltrb tooltip) (define/private (tooltip-info->ltrb tooltip)
(define xlb (box 0)) (define xlb (box 0))
@ -1109,7 +1196,7 @@ If the namespace does not, they are colored the unbound color.
(define window (define window
(let loop ([ed text]) (let loop ([ed text])
(cond (cond
[(send ed get-canvas) => values] [(find-mouse-canvas ed) => values]
[else [else
(define admin (send ed get-admin)) (define admin (send ed get-admin))
(if (is-a? admin editor-snip-editor-admin<%>) (if (is-a? admin editor-snip-editor-admin<%>)