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

interactivity fix for online check syntax

Browse Source 
commit e503850f21 broke drracket's
interactivity (for some files it could take 2 seconds to do
that one line)

This changes the bindings-table so that it maps to sets instead of
lists. Now, instead of mutating all entries in the table right after
collecting everything, just leave them as sets until we need the info
and just sort a single entry, when it is needed
This commit is contained in:
Robby Findler 2013-02-18 16:31:01 -06:00
parent e720d1df92
commit 85f9fbbaee
4 changed files with 39 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -394,7 +394,7 @@ If the namespace does not, they are colored the unbound color.
;; cleanup-texts : (or/c #f (listof text)) ;; cleanup-texts : (or/c #f (listof text))
(define cleanup-texts #f) (define cleanup-texts #f)
;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))] ;; bindings-table : hash-table[(list text number number) -o> (setof (list text number number))]
;; this is a private field ;; this is a private field
(define bindings-table (make-hash)) (define bindings-table (make-hash))
@ -410,15 +410,15 @@ If the namespace does not, they are colored the unbound color.
(= start-right end-right)) (= start-right end-right))
#f] #f]
[else [else
(let* ([key (list start-text start-left start-right)] (define key (list start-text start-left start-right))
[priors (hash-ref bindings-table key (λ () '()))] (define priors (hash-ref bindings-table key (λ () (set))))
[new (list end-text end-left end-right)]) (define new (list end-text end-left end-right))
(cond (cond
[(member new priors) [(set-member? priors new)
#f] #f]
[else [else
(hash-set! bindings-table key (cons new priors)) (hash-set! bindings-table key (set-add priors new))
#t]))])) #t])]))
;; for use in the automatic test suite (both) ;; for use in the automatic test suite (both)
(define/public (syncheck:get-bindings-table [tooltips? #f]) (define/public (syncheck:get-bindings-table [tooltips? #f])
@ -452,29 +452,29 @@ If the namespace does not, they are colored the unbound color.
[else [else
bindings-table])) bindings-table]))
(define/public (syncheck:sort-bindings-table) ;; compare-bindings : (list text number number) (list text number number) -> boolean
;; compares two bindings in the sets inside the bindings table, returning
;; compare-bindings : (list text number number) (list text number number) -> boolean ;; #t if l1 appears earlier in the file than l2 does.
(define (compare-bindings l1 l2) (define/private (syncheck:compare-bindings l1 l2)
(let ([start-text (list-ref l1 0)]
[start-left (list-ref l1 1)]
[end-text (list-ref l2 0)]
[end-left (list-ref l2 1)])
(let-values ([(sx sy) (find-dc-location start-text start-left)]
[(ex ey) (find-dc-location end-text end-left)])
(cond
[(= sy ey) (< sx ex)]
[else (< sy ey)]))))
;; find-dc-location : text number -> (values number number) ;; find-dc-location : text number -> (values number number)
(define (find-dc-location text pos) (define (find-dc-location text pos)
(send text position-location pos xlb xrb) (send text position-location pos xlb xrb)
(send text editor-location-to-dc-location (unbox xlb) (unbox xrb))) (send text editor-location-to-dc-location (unbox xlb) (unbox xrb)))
(hash-for-each (let ([start-text (list-ref l1 0)]
bindings-table [start-left (list-ref l1 1)]
(λ (k v) [end-text (list-ref l2 0)]
(hash-set! bindings-table k (sort v compare-bindings))))) [end-left (list-ref l2 1)])
(cond
[(object=? start-text end-text)
(< start-left end-left)]
[else
(let-values ([(sx sy) (find-dc-location start-text start-left)]
[(ex ey) (find-dc-location end-text end-left)])
(cond
[(= sy ey) (< sx ex)]
[else (< sy ey)]))])))
(define tacked-hash-table (make-hasheq)) (define tacked-hash-table (make-hasheq))
@ -1446,12 +1446,15 @@ If the namespace does not, they are colored the unbound color.
(define/private (jump-to-next-callback pos txt input-arrows backwards?) (define/private (jump-to-next-callback pos txt input-arrows backwards?)
(unless (null? input-arrows) (unless (null? input-arrows)
(define arrow-key (car input-arrows)) (define arrow-key (car input-arrows))
(define orig-arrows (hash-ref bindings-table (define orig-arrows
(list (var-arrow-start-text arrow-key) (sort (set->list (hash-ref bindings-table
(var-arrow-start-pos-left arrow-key) (list (var-arrow-start-text arrow-key)
(var-arrow-start-pos-right arrow-key)) (var-arrow-start-pos-left arrow-key)
(λ () '()))) (var-arrow-start-pos-right arrow-key))
(when backwards? (set! orig-arrows (reverse orig-arrows))) (λ () '())))
(λ (x y) (if backwards?
(not (syncheck:compare-bindings x y))
(syncheck:compare-bindings x y)))))
(cond (cond
[(null? orig-arrows) (void)] [(null? orig-arrows) (void)]
[(null? (cdr orig-arrows)) (jump-to (car orig-arrows))] [(null? (cdr orig-arrows)) (jump-to (car orig-arrows))]
@ -1710,7 +1713,6 @@ If the namespace does not, they are colored the unbound color.
(send defs-text syncheck:update-blue-boxes) (send defs-text syncheck:update-blue-boxes)
(send defs-text syncheck:update-drawn-arrows) (send defs-text syncheck:update-drawn-arrows)
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(send defs-text syncheck:sort-bindings-table)
(set-syncheck-running-mode #f)] (set-syncheck-running-mode #f)]
[(and (i . > . 0) ;; check i just in case things are really strange [(and (i . > . 0) ;; check i just in case things are really strange
(20 . <= . (- (current-inexact-milliseconds) start-time))) (20 . <= . (- (current-inexact-milliseconds) start-time)))
@ -2004,8 +2006,7 @@ If the namespace does not, they are colored the unbound color.
definitions-text definitions-text
(λ () (λ ()
(parameterize ([current-annotations definitions-text]) (parameterize ([current-annotations definitions-text])
(expansion-completed)) (expansion-completed))))
(send definitions-text syncheck:sort-bindings-table)))
(cleanup) (cleanup)
(custodian-shutdown-all user-custodian))))] (custodian-shutdown-all user-custodian))))]
[else [else

1
collects/drracket/private/syncheck/intf.rkt
View File

@ -22,7 +22,6 @@
syncheck:init-arrows syncheck:init-arrows
syncheck:clear-arrows syncheck:clear-arrows
syncheck:arrows-visible? syncheck:arrows-visible?
syncheck:sort-bindings-table
syncheck:get-bindings-table syncheck:get-bindings-table
syncheck:jump-to-next-bound-occurrence syncheck:jump-to-next-bound-occurrence
syncheck:jump-to-binding-occurrence syncheck:jump-to-binding-occurrence

1
collects/drracket/private/syncheck/local-member-names.rkt
View File

@ -20,7 +20,6 @@
syncheck:add-mouse-over-status syncheck:add-mouse-over-status
syncheck:add-jump-to-definition syncheck:add-jump-to-definition
syncheck:sort-bindings-table
syncheck:jump-to-next-bound-occurrence syncheck:jump-to-next-bound-occurrence
syncheck:jump-to-binding-occurrence syncheck:jump-to-binding-occurrence
syncheck:jump-to-definition syncheck:jump-to-definition

3
collects/tests/drracket/syncheck-test.rkt
View File

@ -8,6 +8,7 @@
racket/class racket/class
racket/list racket/list
racket/file racket/file
racket/set
mred mred
framework framework
mrlib/text-string-style-desc mrlib/text-string-style-desc
@ -1334,7 +1335,7 @@
(hash-for-each raw-actual (hash-for-each raw-actual
(lambda (k v) (lambda (k v)
(hash-set! actual-ht (cdr k) (hash-set! actual-ht (cdr k)
(sort (map cdr v) (sort (map cdr (set->list v))
(lambda (x y) (< (car x) (car y)))))))) (lambda (x y) (< (car x) (car y))))))))
(define expected-ht (make-hash)) (define expected-ht (make-hash))
(define stupid-internal-define-syntax2 (define stupid-internal-define-syntax2