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

clean up the way check syntax handles the various callbacks that tell it

Browse Source 
that things have changed and it needs to show different stuff in the editor.

(hopefully tooltips now come and go properly)
This commit is contained in:
Robby Findler 2011-09-27 16:19:38 -05:00
parent a5b729421a
commit 086ff122f9
1 changed files with 82 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -476,19 +476,17 @@ If the namespace does not, they are colored the unbound color.
;; 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 (or arrow-records cursor-location cursor-text)
(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)
(set! cursor-location #f)
(set! cursor-text #f)
(set! cursor-eles #f)
(when cleanup-texts (when cleanup-texts
(for-each (λ (text) (send text thaw-colorer)) (for-each (λ (text) (send text thaw-colorer))
cleanup-texts)) cleanup-texts))
(set! cleanup-texts #f) (set! cleanup-texts #f)
(set! style-mapping #f) (set! style-mapping #f)
(invalidate-bitmap-cache) (syncheck:update-drawn-arrows)
(update-docs-background #f) (invalidate-bitmap-cache)))
(clear-tooltips)))
;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void ;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void
(define/public (syncheck:apply-style/remember txt start finish style mode) (define/public (syncheck:apply-style/remember txt start finish style mode)
@ -896,13 +894,7 @@ If the namespace does not, they are colored the unbound color.
(if arrow-records (if arrow-records
(cond (cond
[(send event leaving?) [(send event leaving?)
(update-docs-background #f) (syncheck:update-drawn-arrows)
(when (and cursor-location cursor-text)
(set! cursor-location #f)
(set! cursor-text #f)
(set! cursor-eles #f)
(clear-tooltips)
(invalidate-bitmap-cache))
(super on-event event)] (super on-event event)]
[(or (send event moving?) [(or (send event moving?)
(send event entering?)) (send event entering?))
@ -923,36 +915,34 @@ If the namespace does not, they are colored the unbound color.
(super on-event event))) (super on-event event)))
(define/public (syncheck:update-drawn-arrows) (define/public (syncheck:update-drawn-arrows)
(let-values ([(pos text) (if (and last-known-mouse-x last-known-mouse-y) (define-values (pos text)
(if (and last-known-mouse-x last-known-mouse-y arrow-records)
(get-pos/text-dc-location last-known-mouse-x last-known-mouse-y) (get-pos/text-dc-location last-known-mouse-x last-known-mouse-y)
(values #f #f))]) (values #f #f)))
(cond (define eles
[(and pos (is-a? text text%)) (let ([arrow-record (and text
(unless (and (equal? pos cursor-location) 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)) (eq? cursor-text text))
(set! cursor-location pos) (set! cursor-location pos)
(set! cursor-text text) (set! cursor-text text)
(let* ([arrow-record (hash-ref arrow-records cursor-text #f)]
[eles (and arrow-record (interval-map-ref arrow-record cursor-location null))])
(unless (equal? cursor-eles eles) (unless (equal? cursor-eles eles)
(set! cursor-eles eles) (set! cursor-eles eles)
(update-docs-background eles) (update-tooltips cursor-eles)
(when eles (update-docs-background cursor-eles)
(update-tooltips eles) (when cursor-eles
(for ([ele (in-list eles)]) (for ([ele (in-list cursor-eles)])
(cond [(arrow? ele) (when (arrow? ele)
(update-arrow-poss ele)])) (update-arrow-poss ele))))
(invalidate-bitmap-cache)))))] (invalidate-bitmap-cache)))
[else
(update-docs-background #f) (unless tooltips-in-sync-with-cursor-eles?
(when (or cursor-location cursor-text) ;; must be called before cursor-eles is set!'d to be eles
(set! cursor-location #f) (update-tooltips cursor-eles)))
(set! cursor-text #f)
(set! cursor-eles #f)
(clear-tooltips)
(invalidate-bitmap-cache))])))
(define/public (syncheck:build-popup-menu pos text) (define/public (syncheck:build-popup-menu pos text)
(and pos (and pos
@ -1037,13 +1027,29 @@ If the namespace does not, they are colored the unbound color.
menu)])))))) menu)]))))))
(define tooltip-frame #f) (define tooltip-frame #f)
(define tooltips-in-sync-with-cursor-eles? #f)
(define/private (update-tooltips eles) (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'
;; 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 (send tooltip-frame show #f))
(set! tooltips-in-sync-with-cursor-eles? #t)]
[else
(define tooltip-infos (filter tooltip-info? eles)) (define tooltip-infos (filter tooltip-info? eles))
(cond (cond
[(null? tooltip-infos) [(null? tooltip-infos)
(send tooltip-frame show #f)] (when tooltip-frame (send tooltip-frame show #f))
(set! tooltips-in-sync-with-cursor-eles? #t)]
[else [else
(unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
(let/ec k
(let loop ([tooltip-infos tooltip-infos] (let loop ([tooltip-infos tooltip-infos]
[l #f] [l #f]
[t #f] [t #f]
@ -1054,11 +1060,15 @@ If the namespace does not, they are colored the unbound color.
[(null? tooltip-infos) [(null? tooltip-infos)
(send tooltip-frame set-tooltip (send tooltip-frame set-tooltip
(sort (set->list strings) string<=?)) (sort (set->list strings) string<=?))
(set! tooltips-in-sync-with-cursor-eles? #t)
(if (and l t r b) (if (and l t r b)
(send tooltip-frame show-over l t (- r l) (- b t)) (send tooltip-frame show-over l t (- r l) (- b t))
(send tooltip-frame show #f))] (send tooltip-frame show #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)
(set! tooltips-in-sync-with-cursor-eles? #f)
(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)
@ -1066,10 +1076,7 @@ If the namespace does not, they are colored the unbound color.
(min/f tt t) (min/f tt t)
(max/f tr r) (max/f tr r)
(max/f tb b) (max/f tb b)
(set-add strings (tooltip-info-msg (car tooltip-infos))))]))])) (set-add strings (tooltip-info-msg (car tooltip-infos))))])))])]))
(define/private (clear-tooltips)
(when tooltip-frame (send tooltip-frame show #f)))
(define/private (tooltip-info->ltrb tooltip) (define/private (tooltip-info->ltrb tooltip)
(define xlb (box 0)) (define xlb (box 0))
@ -1411,6 +1418,8 @@ If the namespace does not, they are colored the unbound color.
(define/augment (on-tab-change old-tab new-tab) (define/augment (on-tab-change old-tab new-tab)
(inner (void) on-tab-change old-tab new-tab) (inner (void) on-tab-change old-tab new-tab)
(send (send old-tab get-defs) syncheck:update-drawn-arrows)
(send (send new-tab get-defs) syncheck:update-drawn-arrows)
(if (send new-tab get-error-report-visible?) (if (send new-tab get-error-report-visible?)
(show-error-report) (show-error-report)
(hide-error-report)) (hide-error-report))