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

Remove the position-location cache that check syntax used to maintain for

Browse Source 
the purpose of drawing arrows.

The computation to fill in the cache seems to actually be pretty quick and
the work to clear the cache when it is out of date (via a call to on-change)
can be substantial on big files, so just not maintaining the cache seems better.
(there are 7254 arrows in drracket/private/unit.rkt, stored in an interval map,
and iterating over the interval-map in a for loop seems to be time consuming)

Also, DrRacket could get into a state where switching tabs would trigger a
call to on-change, which means that switching tabs would take a few seconds.
This commit is contained in:
Robby Findler 2011-12-23 16:07:56 -06:00
parent 5bfaea25fe
commit 188f868a28
1 changed files with 35 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -204,7 +204,7 @@ If the namespace does not, they are colored the unbound color.
(define-struct graphic (pos* locs->thunks draw-fn click-fn)) (define-struct graphic (pos* locs->thunks draw-fn click-fn))
(define-struct arrow (start-x start-y end-x end-y) #:mutable #:transparent) (define-struct arrow () #:mutable #:transparent)
(define-struct (var-arrow arrow) (define-struct (var-arrow arrow)
(start-text start-pos-left start-pos-right (start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
@ -420,12 +420,12 @@ If the namespace does not, they are colored the unbound color.
xr xr
yr)))) yr))))
(define/private (update-arrow-poss arrow) (define/private (get-arrow-poss arrow)
(cond (cond
[(var-arrow? arrow) (update-var-arrow-poss arrow)] [(var-arrow? arrow) (get-var-arrow-poss arrow)]
[(tail-arrow? arrow) (update-tail-arrow-poss arrow)])) [(tail-arrow? arrow) (get-tail-arrow-poss arrow)]))
(define/private (update-var-arrow-poss arrow) (define/private (get-var-arrow-poss arrow)
(let-values ([(start-x start-y) (find-poss (let-values ([(start-x start-y) (find-poss
(var-arrow-start-text arrow) (var-arrow-start-text arrow)
(var-arrow-start-pos-left arrow) (var-arrow-start-pos-left arrow)
@ -434,12 +434,9 @@ If the namespace does not, they are colored the unbound color.
(var-arrow-end-text arrow) (var-arrow-end-text arrow)
(var-arrow-end-pos-left arrow) (var-arrow-end-pos-left arrow)
(var-arrow-end-pos-right arrow))]) (var-arrow-end-pos-right arrow))])
(set-arrow-start-x! arrow start-x) (values start-x start-y end-x end-y)))
(set-arrow-start-y! arrow start-y)
(set-arrow-end-x! arrow end-x)
(set-arrow-end-y! arrow end-y)))
(define/private (update-tail-arrow-poss arrow) (define/private (get-tail-arrow-poss arrow)
;; If the item is an embedded editor snip, redirect ;; If the item is an embedded editor snip, redirect
;; the arrow to point at the left edge rather than the ;; the arrow to point at the left edge rather than the
;; midpoint. ;; midpoint.
@ -458,16 +455,14 @@ If the namespace does not, they are colored the unbound color.
[(end-x end-y) (find-poss/embedded [(end-x end-y) (find-poss/embedded
(tail-arrow-to-text arrow) (tail-arrow-to-text arrow)
(tail-arrow-to-pos arrow))]) (tail-arrow-to-pos arrow))])
(set-arrow-start-x! arrow start-x) (values start-x start-y end-x end-y)))
(set-arrow-start-y! arrow start-y)
(set-arrow-end-x! arrow end-x) (define xlb (box 0))
(set-arrow-end-y! arrow end-y))) (define ylb (box 0))
(define xrb (box 0))
(define yrb (box 0))
(define/private (find-poss text left-pos right-pos) (define/private (find-poss text left-pos right-pos)
(let ([xlb (box 0)]
[ylb (box 0)]
[xrb (box 0)]
[yrb (box 0)])
(send text position-location left-pos xlb ylb #t) (send text position-location left-pos xlb ylb #t)
(send text position-location right-pos xrb yrb #f) (send text position-location right-pos xrb yrb #f)
(let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
@ -475,7 +470,7 @@ If the namespace does not, they are colored the unbound color.
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
[(xr yr) (dc-location-to-editor-location xr-off yr-off)]) [(xr yr) (dc-location-to-editor-location xr-off yr-off)])
(values (/ (+ xl xr) 2) (values (/ (+ xl xr) 2)
(/ (+ yl yr) 2))))) (/ (+ yl yr) 2))))
;; syncheck:init-arrows : -> void ;; syncheck:init-arrows : -> void
(define/public (syncheck:init-arrows) (define/public (syncheck:init-arrows)
@ -701,8 +696,7 @@ If the namespace does not, they are colored the unbound color.
(when (add-to-bindings-table (when (add-to-bindings-table
start-text start-pos-left start-pos-right start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right) end-text end-pos-left end-pos-right)
(let ([arrow (make-var-arrow #f #f #f #f (let ([arrow (make-var-arrow start-text start-pos-left start-pos-right
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level)]) actual? level)])
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
@ -711,7 +705,7 @@ If the namespace does not, they are colored the unbound color.
;; syncheck:add-tail-arrow : text number text number -> void ;; syncheck:add-tail-arrow : text number text number -> void
(define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos)
(when arrow-records (when arrow-records
(let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)]) (let ([tail-arrow (make-tail-arrow to-text to-pos from-text from-pos)])
(add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f) (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
(add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f)))) (add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))))
@ -761,7 +755,6 @@ If the namespace does not, they are colored the unbound color.
(define/augment (on-change) (define/augment (on-change)
(inner (void) on-change) (inner (void) on-change)
(when arrow-records (when arrow-records
(flush-arrow-coordinates-cache)
(let ([any-tacked? #f]) (let ([any-tacked? #f])
(when tacked-hash-table (when tacked-hash-table
(let/ec k (let/ec k
@ -773,18 +766,6 @@ If the namespace does not, they are colored the unbound color.
(when any-tacked? (when any-tacked?
(invalidate-bitmap-cache))))) (invalidate-bitmap-cache)))))
;; flush-arrow-coordinates-cache : -> void
;; pre-condition: arrow-records is not #f.
(define/private (flush-arrow-coordinates-cache)
(for ([(text arrow-record) (in-hash arrow-records)])
(for ([(start+end eles) (in-dict arrow-record)])
(for ([ele (in-list eles)])
(when (arrow? ele)
(set-arrow-start-x! ele #f)
(set-arrow-start-y! ele #f)
(set-arrow-end-x! ele #f)
(set-arrow-end-y! ele #f))))))
(define view-corner-hash (make-weak-hasheq)) (define view-corner-hash (make-weak-hasheq))
(define (get-last-view-corner admin) (define (get-last-view-corner admin)
@ -835,12 +816,8 @@ If the namespace does not, they are colored the unbound color.
(start-arrow-draw-timer syncheck-arrow-delay))) (start-arrow-draw-timer syncheck-arrow-delay)))
(let ([draw-arrow2 (let ([draw-arrow2
(λ (arrow) (λ (arrow)
(unless (arrow-start-x arrow) (define-values (start-x start-y end-x end-y)
(update-arrow-poss arrow)) (get-arrow-poss arrow))
(let ([start-x (arrow-start-x arrow)]
[start-y (arrow-start-y arrow)]
[end-x (arrow-end-x arrow)]
[end-y (arrow-end-y arrow)])
(unless (and (= start-x end-x) (unless (and (= start-x end-x)
(= start-y end-y)) (= start-y end-y))
(drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy (drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy
@ -849,7 +826,7 @@ If the namespace does not, they are colored the unbound color.
(let-values ([(fw fh _d _v) (send dc get-text-extent "x")]) (let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
(send dc draw-text "?" (send dc draw-text "?"
(+ end-x dx fw) (+ end-x dx fw)
(+ end-y dy (- fh))))))))] (+ end-y dy (- fh)))))))]
[old-brush (send dc get-brush)] [old-brush (send dc get-brush)]
[old-pen (send dc get-pen)] [old-pen (send dc get-pen)]
[old-font (send dc get-font)] [old-font (send dc get-font)]
@ -1014,11 +991,6 @@ If the namespace does not, they are colored the unbound color.
(update-tooltip-frame) (update-tooltip-frame)
(update-docs-background 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)) (invalidate-bitmap-cache))
(define popup-menu #f) (define popup-menu #f)