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

155
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)
(get-pos/text-dc-location last-known-mouse-x last-known-mouse-y) (if (and last-known-mouse-x last-known-mouse-y arrow-records)
(values #f #f))]) (get-pos/text-dc-location last-known-mouse-x last-known-mouse-y)
(cond (values #f #f)))
[(and pos (is-a? text text%)) (define eles
(unless (and (equal? pos cursor-location) (let ([arrow-record (and text
(eq? cursor-text text)) pos
(set! cursor-location pos) (hash-ref arrow-records text #f))])
(set! cursor-text text) (and arrow-record
(interval-map-ref arrow-record pos null))))
(let* ([arrow-record (hash-ref arrow-records cursor-text #f)] (unless (and (equal? cursor-location pos)
[eles (and arrow-record (interval-map-ref arrow-record cursor-location null))]) (eq? cursor-text text))
(set! cursor-location pos)
(unless (equal? cursor-eles eles) (set! cursor-text text)
(set! cursor-eles eles)
(update-docs-background eles) (unless (equal? cursor-eles eles)
(when eles (set! cursor-eles eles)
(update-tooltips eles) (update-tooltips cursor-eles)
(for ([ele (in-list eles)]) (update-docs-background cursor-eles)
(cond [(arrow? ele) (when cursor-eles
(update-arrow-poss ele)])) (for ([ele (in-list cursor-eles)])
(invalidate-bitmap-cache)))))] (when (arrow? ele)
[else (update-arrow-poss ele))))
(update-docs-background #f) (invalidate-bitmap-cache)))
(when (or cursor-location cursor-text)
(set! cursor-location #f) (unless tooltips-in-sync-with-cursor-eles?
(set! cursor-text #f) ;; must be called before cursor-eles is set!'d to be eles
(set! cursor-eles #f) (update-tooltips cursor-eles)))
(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,40 +1027,57 @@ 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'
(define tooltip-infos (filter tooltip-info? 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 (cond
[(null? tooltip-infos) [(not eles)
(send tooltip-frame show #f)] (when tooltip-frame (send tooltip-frame show #f))
(set! tooltips-in-sync-with-cursor-eles? #t)]
[else [else
(let loop ([tooltip-infos tooltip-infos] (define tooltip-infos (filter tooltip-info? eles))
[l #f] (cond
[t #f] [(null? tooltip-infos)
[r #f] (when tooltip-frame (send tooltip-frame show #f))
[b #f] (set! tooltips-in-sync-with-cursor-eles? #t)]
[strings (set)]) [else
(cond (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
[(null? tooltip-infos) (let/ec k
(send tooltip-frame set-tooltip (let loop ([tooltip-infos tooltip-infos]
(sort (set->list strings) string<=?)) [l #f]
(if (and l t r b) [t #f]
(send tooltip-frame show-over l t (- r l) (- b t)) [r #f]
(send tooltip-frame show #f))] [b #f]
[else [strings (set)])
(define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos))) (cond
(define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f])) [(null? tooltip-infos)
(define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f])) (send tooltip-frame set-tooltip
(loop (cdr tooltip-infos) (sort (set->list strings) string<=?))
(min/f tl l) (set! tooltips-in-sync-with-cursor-eles? #t)
(min/f tt t) (if (and l t r b)
(max/f tr r) (send tooltip-frame show-over l t (- r l) (- b t))
(max/f tb b) (send tooltip-frame show #f))]
(set-add strings (tooltip-info-msg (car tooltip-infos))))]))])) [else
(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 (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f]))
(loop (cdr tooltip-infos)
(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 (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))
(define ylb (box 0)) (define ylb (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))