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

299
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,69 +936,112 @@ 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))]))
(if arrow-records ;; Given a mouse position, updates latent-* variables and tooltips
(define (update-latent-arrows x y)
(define-values (pos text eles tooltip)
(cond (cond
[(send event leaving?) ;; need to check this first so syncheck:clear-arrows will work
(syncheck:update-drawn-arrows) [(not arrow-records)
(super on-event event)] (values #f #f #f #f)]
[(or (send event moving?) [(and popup-menu (send popup-menu get-popup-target))
(send event entering?)) (values latent-pos latent-text latent-eles latent-tooltip)]
(syncheck:update-drawn-arrows) [(and x y)
(super on-event event)] (define-values (pos text) (get-pos/text-dc-location x y))
[(send event button-down? 'right) (define arrow-record (and text pos (hash-ref arrow-records text #f)))
(define menu (define eles (and arrow-record (interval-map-ref arrow-record pos null)))
(let-values ([(pos text) (get-pos/text event)]) (define tooltip (cond [(equal? latent-eles eles) latent-tooltip]
(syncheck:build-popup-menu pos text))) [else (get-tooltip eles)]))
(cond (values pos text eles tooltip)]
[menu
(send (get-canvas) popup-menu menu
(+ 1 (inexact->exact (floor (send event get-x))))
(+ 1 (inexact->exact (floor (send event get-y)))))]
[else [else
(super on-event event)])] (values #f #f #f #f)]))
[else (super on-event event)]) (define text-changed? (not (eq? latent-text text)))
(super on-event event))) (define eles-changed? (not (equal? latent-eles eles)))
(define/public (syncheck:update-drawn-arrows) (set! latent-pos pos)
(define-values (pos text) (set! latent-text text)
(if (and last-known-mouse-x last-known-mouse-y arrow-records) (set! latent-eles eles)
(get-pos/text-dc-location last-known-mouse-x last-known-mouse-y) (set! latent-tooltip tooltip)
(values #f #f)))
(define eles
(let ([arrow-record (and text
pos
(hash-ref arrow-records text #f))])
(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) (or text-changed? eles-changed?))
(set! cursor-eles eles)
(update-tooltips cursor-eles) (define (update-drawn-arrows)
(set! cursor-pos latent-pos)
(set! cursor-text latent-text)
(set! cursor-eles latent-eles)
(set! cursor-tooltip latent-tooltip)
(update-tooltip-frame)
(update-docs-background cursor-eles) (update-docs-background cursor-eles)
(when cursor-eles (when cursor-eles
(for ([ele (in-list cursor-eles)]) (for ([ele (in-list cursor-eles)])
(when (arrow? ele) (when (arrow? ele)
(update-arrow-poss ele)))) (update-arrow-poss ele))))
(invalidate-bitmap-cache)))
(unless tooltips-in-sync-with-cursor-eles? (invalidate-bitmap-cache))
;; must be called before cursor-eles is set!'d to be eles
(update-tooltips cursor-eles))) (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)
;; This will ensure on-paint is called, once for each canvas that
;; is displaying the editor. In the on-paint call for the canvas
;; that the mouse is over, arrows will be updated, arrow-draw-timer
;; will be set, etc.
;; If this were done more directly, the tooltip would show up in
;; the wrong canvas half the time - when the current admin isn't
;; the admin for the canvas the mouse is over.
(invalidate-bitmap-cache))
(define/public (syncheck:build-popup-menu pos text) (define/public (syncheck:build-popup-menu pos text)
(and pos (and pos
@ -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)
;; update-tooltips has to do its own check to compare 'eles'
;; with 'cursor-eles' because sometimes when it is called,
;; the calls to 'tooltip-info->ltrb' fail and we get
;; no information back. when that happens, we set
;; tooltips-in-sync-with-cursor-eles? to #f and hope that there
;; will be another callback in good time to update us
;; (generally there is because this is called from on-paint
;; and on-paint gets called each time the cursor blinks...)
(cond
[(not eles)
(when tooltip-frame
(when (send tooltip-frame is-shown?)
(send tooltip-frame show #f)))
(set! tooltips-in-sync-with-cursor-eles? #t)]
[else
(define tooltip-infos (filter tooltip-info? eles))
(cond
[(null? tooltip-infos)
(when tooltip-frame
(when (send tooltip-frame is-shown?)
(send tooltip-frame show #f)))
(set! tooltips-in-sync-with-cursor-eles? #t)]
[else
(unless tooltip-frame (set! tooltip-frame (new tooltip-frame%))) (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
(let/ec k (match cursor-tooltip
[(tooltip-spec strings x y w h)
;; hiding keeps it from flashing the new tooltip in the old location
(send tooltip-frame show #f)
(send tooltip-frame set-tooltip strings)
(send tooltip-frame show-over x y w h)]
;; #f or 'out-of-sync
[_ (send tooltip-frame show #f)]))
;; Sometimes when this is called, the calls to 'tooltip-info->ltrb'
;; fail and we get no information back. When that happens, we return
;; 'out-of-sync and try again in on-paint (which happens every time
;; the caret blinks).
(define/private (get-tooltip eles)
(define tooltip-infos (if eles (filter tooltip-info? eles) null))
(let loop ([tooltip-infos tooltip-infos] (let loop ([tooltip-infos tooltip-infos]
[l #f] [l #f] [t #f] [r #f] [b #f]
[t #f]
[r #f]
[b #f]
[strings (set)]) [strings (set)])
(cond (cond
[(null? tooltip-infos) [(null? tooltip-infos)
(send tooltip-frame set-tooltip
(sort (set->list strings) string<=?))
(set! tooltips-in-sync-with-cursor-eles? #t)
(cond (cond
[(and l t r b) [(and l t r b)
(define-values (dx dy) (get-display-left-top-inset)) (define-values (dx dy) (get-display-left-top-inset))
(send tooltip-frame show-over (- l dx) (- t dy) (- r l) (- b t))] (tooltip-spec (sort (set->list strings) string<=?)
[else (- l dx) (- t dy) (- r l) (- b t))]
(send tooltip-frame show #f)])] [else #f])]
[else [else
(define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos))) (define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos)))
(unless (and tl tt tr tb) (cond
(set! tooltips-in-sync-with-cursor-eles? #f) [(and tl tt tr tb)
(k (void)))
(define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f])) (define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f]))
(define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f])) (define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f]))
(loop (cdr tooltip-infos) (loop (cdr tooltip-infos)
(min/f tl l) (min/f tl l) (min/f tt t) (max/f tr r) (max/f tb b)
(min/f tt t) (set-add strings (tooltip-info-msg (car tooltip-infos))))]
(max/f tr r) [else
(max/f tb b) ;(printf "~a: out of sync~n" (current-milliseconds))
(set-add strings (tooltip-info-msg (car tooltip-infos))))])))])])) 'out-of-sync])])))
;; Given an editor, returns the canvas that the mouse is currently over,
;; as opposed to the one with keyboard focus (which get-canvas usually returns)
(define (find-mouse-canvas ed)
(define current-admin (send ed get-admin))
(let/ec return
(for ([canvas (in-list (send ed get-canvases))])
(define admin (send canvas call-as-primary-owner
(λ () (send ed get-admin))))
(when (eq? admin current-admin)
(return canvas)))
(send ed get-canvas)))
(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<%>)