unbreak the contour window
A long time ago, I tried to improve the interactiveness of DrRacket when the contour window was open with the code that is removed in this commit. Looking at it today, it seems clear that this code was buggy (and, now that we've had lots of experience with it, it didn't actually help with interactivity either) The problem is that the code didn't record enough information about the change to the editor in the thunk put into the 'todo' field. It would remember that a particular range was out of date, but it woudln't remember which characters were in that range, so when it would go to copy the characters, it may be getting the wrong characters (since another edit may have happened since the thunk was stored in the todo field) This change also has the side benefit that the time it takes to change the contour window is now being tracked by the colorer, which means that it'll give up a bit sooner coloring less in each go, but hopefully maintaining the interactivity original commit: 052ee14afc748929f9195620c183f053d307ac21
This commit is contained in:
Robby Findler
parent
5963c92d63
commit
8311497772
|
|
@ -1431,6 +1431,7 @@
|
|||
(res dc x y)
|
||||
(send dc draw-line (+ x start) y (+ x start (- len 1)) y))))]))]))])))
|
||||
|
||||
|
||||
#;
|
||||
(let ()
|
||||
;; test cases for for-each/section
|
||||
|
|
@ -1445,16 +1446,18 @@
|
|||
0)
|
||||
calls))
|
||||
|
||||
(equal? (run-fe/s "") '())
|
||||
(equal? (run-fe/s "a") '((0 0)))
|
||||
(equal? (run-fe/s " ") '())
|
||||
(equal? (run-fe/s "ab") '((0 1)))
|
||||
(equal? (run-fe/s "ab c") '((0 1) (3 3)))
|
||||
(equal? (run-fe/s "a bc") '((0 0) (2 3)))
|
||||
(equal? (run-fe/s "a b c d") '((0 0) (2 2) (4 4) (6 6)))
|
||||
(equal? (run-fe/s "a b c d ") '((0 0) (2 2) (4 4) (6 6)))
|
||||
(equal? (run-fe/s "abc def ghi") '((0 2) (4 6) (8 10)))
|
||||
(equal? (run-fe/s "abc def ghi") '((0 2) (6 8) (12 14))))
|
||||
(printf "framework/private/text.rkt: ~s\n"
|
||||
(list
|
||||
(equal? (run-fe/s "") '())
|
||||
(equal? (run-fe/s "a") '((0 0)))
|
||||
(equal? (run-fe/s " ") '())
|
||||
(equal? (run-fe/s "ab") '((0 1)))
|
||||
(equal? (run-fe/s "ab c") '((0 1) (3 3)))
|
||||
(equal? (run-fe/s "a bc") '((0 0) (2 3)))
|
||||
(equal? (run-fe/s "a b c d") '((0 0) (2 2) (4 4) (6 6)))
|
||||
(equal? (run-fe/s "a b c d ") '((0 0) (2 2) (4 4) (6 6)))
|
||||
(equal? (run-fe/s "abc def ghi") '((0 2) (4 6) (8 10)))
|
||||
(equal? (run-fe/s "abc def ghi") '((0 2) (6 8) (12 14))))))
|
||||
|
||||
(define 1-pixel-tab-snip%
|
||||
(class tab-snip%
|
||||
|
|
@ -1532,34 +1535,10 @@
|
|||
(send new-snip set-style (send snip get-style))
|
||||
new-snip))
|
||||
|
||||
;; todo : (listof (-> void))
|
||||
;; actions that have happened to this editor, but that
|
||||
;; have not yet been propogated to the delegate
|
||||
(define todo '())
|
||||
|
||||
(define timer (new logging-timer%
|
||||
[notify-callback
|
||||
(λ ()
|
||||
;; it should be the case that todo is always '() when the delegate is #f
|
||||
(when delegate
|
||||
(send delegate begin-edit-sequence)
|
||||
(for ([th (in-list (reverse todo))])
|
||||
(th))
|
||||
(send delegate end-edit-sequence))
|
||||
(set! todo '()))]))
|
||||
|
||||
(define/private (to-delegate thunk)
|
||||
(when delegate
|
||||
(send timer stop)
|
||||
(send timer start 250 #t)
|
||||
(set! todo (cons thunk todo))))
|
||||
|
||||
(define delegate #f)
|
||||
(inherit get-highlighted-ranges)
|
||||
(define/public-final (get-delegate) delegate)
|
||||
(define/public-final (set-delegate _d)
|
||||
(set! todo '())
|
||||
|
||||
(when delegate
|
||||
;; the delegate may be in a bad state because we've killed the pending todo
|
||||
;; items; to clear out the bad state, end any edit sequences, and unhighlight
|
||||
|
|
@ -1584,7 +1563,8 @@
|
|||
(refresh-delegate))
|
||||
|
||||
(define/private (refresh-delegate)
|
||||
(to-delegate (λ () (refresh-delegate/do-work))))
|
||||
(when delegate
|
||||
(refresh-delegate/do-work)))
|
||||
|
||||
(define/private (refresh-delegate/do-work)
|
||||
(send delegate begin-edit-sequence)
|
||||
|
|
@ -1625,87 +1605,77 @@
|
|||
(send delegate end-edit-sequence))
|
||||
|
||||
(define/override (highlight-range start end color [caret-space? #f] [priority 'low] [style 'rectangle])
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate highlight-range start end color caret-space? priority style)))
|
||||
(when delegate
|
||||
(send delegate highlight-range start end color caret-space? priority style))
|
||||
(super highlight-range start end color caret-space? priority style))
|
||||
|
||||
(define/override (unhighlight-range start end color [caret-space? #f] [style 'rectangle])
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate unhighlight-range start end color caret-space? style)))
|
||||
(when delegate
|
||||
(send delegate unhighlight-range start end color caret-space? style))
|
||||
(super unhighlight-range start end color caret-space? style))
|
||||
|
||||
(inherit get-canvases get-active-canvas has-focus?)
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret?)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret?)
|
||||
(unless before?
|
||||
(let ([active-canvas (get-active-canvas)])
|
||||
(when active-canvas
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send (send active-canvas get-top-level-window) delegate-moved)))))))
|
||||
(when delegate
|
||||
(unless before?
|
||||
(let ([active-canvas (get-active-canvas)])
|
||||
(when active-canvas
|
||||
(send (send active-canvas get-top-level-window) delegate-moved))))))
|
||||
|
||||
(define/augment (on-edit-sequence)
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate begin-edit-sequence)))
|
||||
(when delegate
|
||||
(send delegate begin-edit-sequence))
|
||||
(inner (void) on-edit-sequence))
|
||||
|
||||
(define/augment (after-edit-sequence)
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate end-edit-sequence)))
|
||||
(when delegate
|
||||
(send delegate end-edit-sequence))
|
||||
(inner (void) after-edit-sequence))
|
||||
|
||||
(define/override (resized snip redraw-now?)
|
||||
(super resized snip redraw-now?)
|
||||
(when (and delegate
|
||||
(not (is-a? snip string-snip%)))
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(when linked-snips
|
||||
(let ([delegate-copy (hash-ref linked-snips snip (λ () #f))])
|
||||
(when delegate-copy
|
||||
(send delegate resized delegate-copy redraw-now?))))))))
|
||||
(when linked-snips
|
||||
(let ([delegate-copy (hash-ref linked-snips snip (λ () #f))])
|
||||
(when delegate-copy
|
||||
(send delegate resized delegate-copy redraw-now?))))))
|
||||
|
||||
(define/augment (after-insert start len)
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate begin-edit-sequence)
|
||||
(send delegate lock #f)
|
||||
(split-snip start)
|
||||
(split-snip (+ start len))
|
||||
(let loop ([snip (find-snip (+ start len) 'before-or-none)])
|
||||
(when snip
|
||||
(unless ((get-snip-position snip) . < . start)
|
||||
(send delegate insert (copy snip) start start)
|
||||
(loop (send snip previous)))))
|
||||
(send delegate lock #t)
|
||||
(send delegate end-edit-sequence)))
|
||||
(when delegate
|
||||
(send delegate begin-edit-sequence)
|
||||
(send delegate lock #f)
|
||||
(split-snip start)
|
||||
(split-snip (+ start len))
|
||||
(let loop ([snip (find-snip (+ start len) 'before-or-none)])
|
||||
(when snip
|
||||
(unless ((get-snip-position snip) . < . start)
|
||||
(send delegate insert (copy snip) start start)
|
||||
(loop (send snip previous)))))
|
||||
(send delegate lock #t)
|
||||
(send delegate end-edit-sequence))
|
||||
(inner (void) after-insert start len))
|
||||
|
||||
(define/augment (after-delete start len)
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate lock #f)
|
||||
(send delegate begin-edit-sequence)
|
||||
(send delegate delete start (+ start len))
|
||||
(send delegate end-edit-sequence)
|
||||
(send delegate lock #t)))
|
||||
(when delegate
|
||||
(send delegate lock #f)
|
||||
(send delegate begin-edit-sequence)
|
||||
(send delegate delete start (+ start len))
|
||||
(send delegate end-edit-sequence)
|
||||
(send delegate lock #t))
|
||||
(inner (void) after-delete start len))
|
||||
|
||||
(define/augment (after-change-style start len)
|
||||
(to-delegate
|
||||
(λ ()
|
||||
(send delegate begin-edit-sequence)
|
||||
(send delegate lock #f)
|
||||
(split-snip start)
|
||||
(let* ([snip (find-snip start 'after)]
|
||||
[style (send snip get-style)])
|
||||
(send delegate change-style style start (+ start len)))
|
||||
(send delegate lock #f)
|
||||
(send delegate end-edit-sequence)))
|
||||
(when delegate
|
||||
(send delegate begin-edit-sequence)
|
||||
(send delegate lock #f)
|
||||
(split-snip start)
|
||||
(let* ([snip (find-snip start 'after)]
|
||||
[style (send snip get-style)])
|
||||
(send delegate change-style style start (+ start len)))
|
||||
(send delegate lock #f)
|
||||
(send delegate end-edit-sequence))
|
||||
(inner (void) after-change-style start len))
|
||||
|
||||
(define/augment (after-load-file success?)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user