From 5197649cb7556abd96282d3a838c4ba4f7c8de8c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 22 Nov 2012 09:28:11 -0600 Subject: [PATCH] improve the interactivity of DrRacket's search Changes the implementation of highlight-range so that it only recomputes all of the new locations from the positions when on-reflow is called (otherwise only computing the relevant ones) and make the on-reflow callback chop itself up, in case there are lots of highlighted ranges to avoid tying up the event loop. Changes searching so that it doesn't neccessarily compute the entire search results in a single event callback (but also make it start the computation more aggressively) Overall, this changes the strategy from one that, for any potentially long-running callback, just tried to push it off into the future, into a strategy that tries to avoid long-running callbacks by breaking the work up into chunks, but starting the first chunk immediately (in a low-priority callback). Also, misc other changes to make this work better and generally clean things up. --- collects/framework/private/coroutine.rkt | 120 ++ collects/framework/private/editor.rkt | 3 +- collects/framework/private/frame.rkt | 322 ++-- collects/framework/private/text.rkt | 1434 +++++++++-------- collects/scribblings/framework/text.scrbl | 57 +- collects/tests/drracket/follow-log.rkt | 22 +- collects/tests/framework/search.rkt | 182 ++- collects/tests/framework/test-suite-utils.rkt | 36 +- 8 files changed, 1217 insertions(+), 959 deletions(-) create mode 100644 collects/framework/private/coroutine.rkt diff --git a/collects/framework/private/coroutine.rkt b/collects/framework/private/coroutine.rkt new file mode 100644 index 0000000000..640b3fedc3 --- /dev/null +++ b/collects/framework/private/coroutine.rkt @@ -0,0 +1,120 @@ +#lang racket/base +(require racket/contract) + +(provide coroutine) +(provide + (contract-out + [coroutine-run (-> coroutine? any/c boolean?)] + [coroutine-runnable? (-> coroutine? boolean?)] + [coroutine-value (-> coroutine? any/c)])) + +(define-syntax-rule + (coroutine pause-id first-id exp1 exp2 ...) + (coroutine/proc (λ (pause-id first-id) exp1 exp2 ...))) + +(struct coroutine ([run-proc #:mutable] [val #:mutable] tag) + #:omit-define-syntaxes + #:extra-constructor-name + make-coroutine) + +(define (coroutine/proc cproc) + (define tag (make-continuation-prompt-tag 'coroutine)) + (define (pauser) + (call-with-composable-continuation + (λ (k) (abort-current-continuation tag k)) + tag)) + (make-coroutine (λ (first-val) (values (cproc pauser first-val) #t)) + #f + tag)) + +(define (coroutine-run a-coroutine val) + (cond + [(coroutine-run-proc a-coroutine) + => + (λ (proc) + (define-values (res done?) + (call-with-continuation-prompt + (λ () (proc val)) + (coroutine-tag a-coroutine) + (λ (k) + (set-coroutine-run-proc! + a-coroutine + (λ (next-val) + (k next-val))) + (values #f #f)))) + (cond + [done? + (set-coroutine-run-proc! a-coroutine #f) + (set-coroutine-val! a-coroutine res) + #t] + [else #f]))] + [else + (error 'coroutine-run "coroutine already terminated")])) + +(define (coroutine-runnable? a-coroutine) + (and (coroutine-run-proc a-coroutine) + #t)) + +(define (coroutine-value a-coroutine) + (when (coroutine-runnable? a-coroutine) + (error 'coroutine-value "coroutine not yet finished")) + (coroutine-val a-coroutine)) + +(module+ test + (require rackunit) + + (define c + (coroutine + pause + first + (begin + (printf "first ~s\n" first) + (let loop ([i 5]) + (printf "i ~a\n" i) + (when (zero? (modulo i 3)) + (printf ">> ~a\n" (pause))) + (cond + [(zero? i) '()] + [else + (cons i (loop (- i 1)))]))))) + + (define (with-stdout th) + (define sp (open-output-string)) + (list (parameterize ([current-output-port sp]) + (th)) + (get-output-string sp))) + + (check-equal? (with-stdout (λ () (coroutine-run c 123))) + (list #f "first 123\ni 5\ni 4\ni 3\n")) + + (check-equal? (with-stdout (λ () (coroutine-run c 456))) + (list #f ">> 456\ni 2\ni 1\ni 0\n")) + + (check-equal? (with-stdout (λ () (coroutine-run c 789))) + (list #t ">> 789\n")) + + (check-equal? (coroutine-value c) + '(5 4 3 2 1)) + + + (define c2 + (coroutine + pause first + (define x first) + (define (try-it) + (define new-x (pause)) + (printf "~a => ~a\n" x new-x) + (set! x new-x)) + (try-it) + (try-it) + x)) + + (check-equal? (with-stdout (λ () (coroutine-run c2 0))) + (list #f "")) + (check-equal? (with-stdout (λ () (coroutine-run c2 1))) + (list #f "0 => 1\n")) + (check-equal? (with-stdout (λ () (coroutine-run c2 2))) + (list #t "1 => 2\n")) + (check-equal? (coroutine-value c2) + 2)) + diff --git a/collects/framework/private/editor.rkt b/collects/framework/private/editor.rkt index 690c6bb5f0..836337a3da 100644 --- a/collects/framework/private/editor.rkt +++ b/collects/framework/private/editor.rkt @@ -40,7 +40,8 @@ close get-filename/untitled-name - get-pos/text)) + get-pos/text + get-pos/text-dc-location)) (define basic-mixin (mixin (editor<%>) (basic<%>) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index b97044771a..12cfbc8b17 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -1919,28 +1919,18 @@ (send text-to-search set-search-anchor (send text-to-search get-start-position))))))) (super on-focus on?)) - (define timer #f) - (define/private (update-search/trigger-jump/later) - (run-after-edit-sequence - (λ () - (unless timer - (set! timer (new timer% - [notify-callback - (λ () - (update-searching-str) - (trigger-jump))]))) - (send timer stop) - (send timer start 150 #t)) - 'framework:search-frame:changed-search-string)) - (define/augment (after-insert x y) - (update-search/trigger-jump/later) + (update-searching-str/trigger-jump) (inner (void) after-insert x y)) (define/augment (after-delete x y) - (update-search/trigger-jump/later) + (update-searching-str/trigger-jump) (inner (void) after-delete x y)) - - (define/private (trigger-jump) + (define/private (update-searching-str/trigger-jump) + (let ([tlw (get-top-level-window)]) + (when tlw + (send tlw search-string-changed))) + + ;; trigger-jump (when (preferences:get 'framework:anchored-search) (let ([frame (get-top-level-window)]) (when frame @@ -1953,6 +1943,7 @@ (send text-to-search set-position anchor-pos anchor-pos)] [else (search 'forward #t #t #f anchor-pos)]))))))))) + (define/private (get-searching-text) (let ([frame (get-top-level-window)]) @@ -2062,12 +2053,6 @@ (not-found found-edit #f))] [else (found found-edit first-pos)]))))))) - - (define callback-queued? #f) - (define/private (update-searching-str) - (let ([tlw (get-top-level-window)]) - (when tlw - (send tlw search-string-changed)))) (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?) @@ -2241,7 +2226,7 @@ (string-constant hide-replace-menu-item) (string-constant show-replace-menu-item)))) - (define/override (edit-menu:replace-callback a b) (search-replace)) + (define/override (edit-menu:replace-callback a b) (search-replace) #t) (define/override (edit-menu:create-replace?) #t) (define/override (edit-menu:replace-on-demand item) (send item enable (and (not hidden?) replace-visible?))) @@ -2278,12 +2263,13 @@ (unless hidden? (when find-edit (when old - (send old set-searching-state #f #f #f) + (send old set-searching-state #f #f #f #f) (send old set-search-anchor #f)) (when new (send new set-search-anchor (send new get-start-position)) (search-parameters-changed))))))) + ;; called by the text-to-search when it finishes the search (define/public-final (search-hits-changed) (when find-edit (when text-to-search @@ -2294,15 +2280,13 @@ (send find-canvas set-red is-red?)))))) (define/public-final (search-string-changed) (search-parameters-changed)) - (define/public-final (search-text-changed) (search-parameters-changed)) - (define/private (search-parameters-changed) (let ([str (send find-edit get-text)]) (send text-to-search set-searching-state (if (equal? str "") #f str) case-sensitive-search? - (and replace-visible? (send text-to-search get-start-position)))) - (search-hits-changed)) + replace-visible? + #t))) (define/public (search-hidden?) hidden?) @@ -2310,7 +2294,7 @@ (set! hidden? #t) (when search-gui-built? (when text-to-search - (send text-to-search set-searching-state #f #f #f)) + (send text-to-search set-searching-state #f #f #f #f)) (send super-root change-children (λ (l) (remove search/replace-panel l))) @@ -2377,28 +2361,8 @@ (send text-to-search set-position replacee-end replacee-end) (send text-to-search delete replacee-start replacee-end) (copy-over replace-edit 0 (send replace-edit last-position) text-to-search replacee-start) - (let ([str (send find-edit get-text)]) - (send text-to-search set-searching-state - (if (equal? str "") #f str) - case-sensitive-search? - - ;; the start position will have moved (but to the right place), - ;; if a relacement has happened. - (send text-to-search get-start-position)) - - - ;; set the selection to the next place to replace - (let-values ([(before-caret-hits hits) (send text-to-search get-search-hit-count)]) - (unless (zero? hits) - (unless (send text-to-search get-replace-search-hit) - (send text-to-search set-position 0 0)) - (let ([next-start (send text-to-search get-replace-search-hit)]) - (when next-start ;; this shouldn't ever matter ...? - (send text-to-search set-position next-start (+ next-start (send find-edit last-position))))))) - - (search-hits-changed)) - (send text-to-search end-edit-sequence) - #t)))))) + (search 'forward) + (send text-to-search end-edit-sequence))))))) (define/private (copy-over src-txt src-start src-end dest-txt dest-pos) (send src-txt split-snip src-start) @@ -2491,135 +2455,133 @@ (unless search-gui-built? (set! search-gui-built? #t) (begin-container-sequence) - (let () - (define _-2 (set! find-edit (new find-text%))) - (define _-1 (set! replace-edit (new replace-text%))) - (define _0 (set! search/replace-panel (new horizontal-panel% - [parent super-root] - [stretchable-height #f]))) - (define search-panel - (new horizontal-panel% - [parent search/replace-panel] - [stretchable-height #f])) - (define replace-panel - (new horizontal-panel% - [parent search/replace-panel] - [stretchable-height #f])) - (define _1 (set! find-canvas (new searchable-canvas% - [style '(hide-hscroll hide-vscroll)] - [vertical-inset 2] - [parent search-panel] - [editor find-edit] - [line-count 1] - [stretchable-height #f] - [stretchable-width #t]))) - - (define _3 (set! replace-canvas (new searchable-canvas% - [style '(hide-hscroll hide-vscroll)] - [vertical-inset 2] - [parent replace-panel] - [editor replace-edit] - [line-count 1] - [stretchable-height #f] - [stretchable-width #t]))) - - (define search-button (new button% - [label (string-constant search-next)] - [vert-margin 0] - [parent search-panel] - [callback (λ (x y) (search 'forward))] - [font small-control-font])) - (define search-prev-button (new button% - [label (string-constant search-previous)] - [vert-margin 0] - [parent search-panel] - [callback (λ (x y) (search 'backward))] - [font small-control-font])) - - (define hits-panel (new vertical-panel% - [parent search-panel] - [alignment '(left center)] + (set! find-edit (new find-text%)) + (set! replace-edit (new replace-text%)) + (set! search/replace-panel (new horizontal-panel% + [parent super-root] + [stretchable-height #f])) + (define search-panel + (new horizontal-panel% + [parent search/replace-panel] + [stretchable-height #f])) + (define replace-panel + (new horizontal-panel% + [parent search/replace-panel] + [stretchable-height #f])) + (set! find-canvas (new searchable-canvas% + [style '(hide-hscroll hide-vscroll)] + [vertical-inset 2] + [parent search-panel] + [editor find-edit] + [line-count 1] + [stretchable-height #f] + [stretchable-width #t])) + (set! replace-canvas (new searchable-canvas% + [style '(hide-hscroll hide-vscroll)] + [vertical-inset 2] + [parent replace-panel] + [editor replace-edit] + [line-count 1] [stretchable-height #f] - [stretchable-width #f])) - - (define num-msg (new message% - [label "0"] - [vert-margin 0] - [auto-resize #t] - [font tiny-control-font] - [parent hits-panel])) - (define matches-msg (new message% - [label (string-constant search-matches)] + [stretchable-width #t])) + + (define search-button (new button% + [label (string-constant search-next)] [vert-margin 0] - [font tiny-control-font] - [parent hits-panel])) - - (define _6 (set! update-matches - (λ (before-caret-m m) - (cond - [(zero? m) - (send num-msg set-label "0")] - [else - (let ([number (number->str/comma m)] - [bc-number (number->str/comma before-caret-m)]) - (send num-msg set-label (format "~a/~a" bc-number number)))]) - (send matches-msg set-label (if (= m 1) - (string-constant search-match) - (string-constant search-matches)))))) - - (define replace-button - (new button% - [label (string-constant search-replace)] - [vert-margin 0] - [parent replace-panel] - [font small-control-font] - [callback (λ (x y) (search-replace))])) - (define skip-button - (new button% - [label (string-constant search-skip)] - [vert-margin 0] - [parent replace-panel] - [font small-control-font] - [callback (λ (x y) (search 'forward))])) - - (define show-replace-button - (new button% - [label (string-constant search-show-replace)] - [font small-control-font] - [callback (λ (a b) (set-replace-visible? #t))] - [parent replace-panel])) - (define hide-replace-button - (new button% - [label (string-constant search-hide-replace)] - [font small-control-font] - [callback (λ (a b) (set-replace-visible? #f))] - [parent replace-panel])) - - (set! show/hide-replace - (λ () - (send replace-panel begin-container-sequence) - (cond - [replace-visible? - (send replace-panel change-children (λ (l) all-replace-children)) - (send replace-panel stretchable-width #t)] - [else - (send replace-panel change-children (λ (l) (list show-replace-button))) - (send replace-panel stretchable-width #f)]) - (send replace-panel end-container-sequence))) - - (define all-replace-children - (list replace-canvas - replace-button - skip-button - hide-replace-button)) - - (define hide-button - (new close-icon% - [callback (λ () (hide-search))] - [vertical-pad 0] - [parent search/replace-panel])) - - (show/hide-replace)) + [parent search-panel] + [callback (λ (x y) (search 'forward))] + [font small-control-font])) + (define search-prev-button (new button% + [label (string-constant search-previous)] + [vert-margin 0] + [parent search-panel] + [callback (λ (x y) (search 'backward))] + [font small-control-font])) + + (define hits-panel (new vertical-panel% + [parent search-panel] + [alignment '(left center)] + [stretchable-height #f] + [stretchable-width #f])) + + (define num-msg (new message% + [label "0"] + [vert-margin 0] + [auto-resize #t] + [font tiny-control-font] + [parent hits-panel])) + (define matches-msg (new message% + [label (string-constant search-matches)] + [vert-margin 0] + [font tiny-control-font] + [parent hits-panel])) + + (define _6 (set! update-matches + (λ (before-caret-m m) + (cond + [(zero? m) + (send num-msg set-label "0")] + [else + (let ([number (number->str/comma m)] + [bc-number (number->str/comma before-caret-m)]) + (send num-msg set-label (format "~a/~a" bc-number number)))]) + (send matches-msg set-label (if (= m 1) + (string-constant search-match) + (string-constant search-matches)))))) + + (define replace-button + (new button% + [label (string-constant search-replace)] + [vert-margin 0] + [parent replace-panel] + [font small-control-font] + [callback (λ (x y) (search-replace))])) + (define skip-button + (new button% + [label (string-constant search-skip)] + [vert-margin 0] + [parent replace-panel] + [font small-control-font] + [callback (λ (x y) (search 'forward))])) + + (define show-replace-button + (new button% + [label (string-constant search-show-replace)] + [font small-control-font] + [callback (λ (a b) (set-replace-visible? #t))] + [parent replace-panel])) + (define hide-replace-button + (new button% + [label (string-constant search-hide-replace)] + [font small-control-font] + [callback (λ (a b) (set-replace-visible? #f))] + [parent replace-panel])) + + (set! show/hide-replace + (λ () + (send replace-panel begin-container-sequence) + (cond + [replace-visible? + (send replace-panel change-children (λ (l) all-replace-children)) + (send replace-panel stretchable-width #t)] + [else + (send replace-panel change-children (λ (l) (list show-replace-button))) + (send replace-panel stretchable-width #f)]) + (send replace-panel end-container-sequence))) + + (define all-replace-children + (list replace-canvas + replace-button + skip-button + hide-replace-button)) + + (define hide-button + (new close-icon% + [callback (λ () (hide-search))] + [vertical-pad 0] + [parent search/replace-panel])) + + (show/hide-replace) (end-container-sequence))) (super-new))) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index ba26dc4277..d051876193 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -12,7 +12,10 @@ mred/mred-sig mrlib/interactive-value-port racket/list - "logging-timer.rkt") + "logging-timer.rkt" + "coroutine.rkt" + data/queue) + (require setup/xref scribble/xref scribble/manual-struct) @@ -33,9 +36,21 @@ (define original-output-port (current-output-port)) (define (oprintf . args) (apply fprintf original-output-port args)) -(define-struct range (start end caret-space? style color) #:inspector #f) +;; rectangles : (or/c #f (listof rectangle)) +;; #f => range information needs to be computed for this rectangle +(define-struct range (start end caret-space? style color [rectangles #:mutable]) #:inspector #f) (define-struct rectangle (left top right bottom style color) #:inspector #f) +(define (build-rectangle left top right bottom style color) + (when (right . < . left) + (error 'build-rectangle "found right to the right of left: ~s" + (list left top right bottom style color))) + (when (bottom . < . top) + (error 'build-rectangle "found bottom above top: ~s" + (list left top right bottom style color))) + (make-rectangle left top right bottom style color)) + + (define-values (register-port-name! lookup-port-name) ;; port-name->editor-ht: (hashof symbol (weakboxof editor:basic<%>)) ;; Maintains a mapping from port names back to their respective editors. @@ -62,6 +77,7 @@ (interface (editor:basic<%> (class->interface text%)) highlight-range unhighlight-range + unhighlight-ranges get-highlighted-ranges get-styles-fixed get-fixed-style @@ -72,233 +88,191 @@ port-name-matches? get-start-of-line)) -(define basic-mixin - (mixin (editor:basic<%> (class->interface text%)) (basic<%>) - (inherit get-canvas get-canvases get-admin split-snip get-snip-position - begin-edit-sequence end-edit-sequence - set-autowrap-bitmap last-position - delete find-snip invalidate-bitmap-cache - set-file-format get-file-format - get-style-list is-modified? change-style set-modified - position-location position-locations - position-line line-start-position line-end-position - get-extent get-filename run-after-edit-sequence) +(define highlight-range-mixin + (mixin (editor:basic<%> (class->interface text%)) () + + (inherit invalidate-bitmap-cache + last-position + position-locations + position-location + position-line + line-start-position + line-end-position + get-style-list + get-admin) - (define port-name-identifier #f) - (define/public (get-port-name) - (let* ([b (box #f)] - [n (get-filename b)]) - (cond - [(or (unbox b) (not n)) - (unless port-name-identifier - (set! port-name-identifier (gensym 'unsaved-editor)) - (register-port-name! port-name-identifier this)) - port-name-identifier] - [else n]))) - (define/public (port-name-matches? id) - (let ([filename (get-filename)]) - (or (and (path? id) - (path? filename) - (or (equal? id filename) ;; "fast path" check - (equal? (normal-case-path (normalize-path (get-filename))) - (normal-case-path (normalize-path id))))) - (and (symbol? port-name-identifier) - (symbol? id) - (equal? port-name-identifier id))))) - - (define highlight-tmp-color #f) + (define highlight-tmp-color (make-object color% 0 0 0)) - (define range-rectangles null) - (define ranges (make-hash)) - (define ranges-low 0) - (define ranges-high 0) - (define ranges-list #f) + (define ranges-deq (make-queue)) - (define/public-final (get-highlighted-ranges) - (unless ranges-list - (set! ranges-list - (map car (sort (apply append (hash-map ranges (λ (k vs) (map (λ (v) (cons k v)) vs)))) - (λ (x y) (> (cdr x) (cdr y)))))) - (hash-for-each ranges (λ (k v) (hash-remove! ranges k))) - (let loop ([ranges-list ranges-list] - [i 0]) - (cond - [(null? ranges-list) - (set! ranges-low i) - (set! ranges-high 1)] - [else - (hash-cons! ranges (car ranges-list) i) - (loop (cdr ranges-list) (- i 1))]))) - ranges-list) - (define/public (get-fixed-style) - (send (get-style-list) find-named-style "Standard")) + (define/public-final (get-highlighted-ranges) + (for/list ([x (in-queue ranges-deq)]) x)) - (define/private (invalidate-rectangles rectangles) + (define/private (recompute-range-rectangles) + (set! pending-ranges (queue->list ranges-deq)) + (unless recompute-callback-running? + (set! recompute-callback-running? #t) + (queue-callback (λ () (run-recompute-range-rectangles)) #f))) + + (define pending-ranges '()) + (define recompute-callback-running? #f) + + (define/private (run-recompute-range-rectangles) + (define done-time (+ (current-inexact-milliseconds) 20)) + (define did-something? #f) (let loop ([left #f] [top #f] [right #f] - [bottom #f] - [rectangles rectangles]) + [bottom #f]) (cond - [(null? rectangles) - (when left - (let ([width (if (number? right) (- right left) 'display-end)] - [height (if (number? bottom) (- bottom top) 'display-end)]) - (when (and (or (symbol? width) (> width 0)) - (or (symbol? height) (> height 0))) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - [adjust (λ (w f) - (+ w (f (case (rectangle-style r) - [(dot hollow-ellipse) 8] - [else 0]))))] - [this-left (if (number? (rectangle-left r)) - (adjust (rectangle-left r) -) - 0.0)] - [this-right (if (number? (rectangle-right r)) - (adjust (rectangle-right r) +) - 'display-end)] - [this-top (adjust (rectangle-top r) -)] - [this-bottom (adjust (rectangle-bottom r) +)]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (if (and (number? this-right) (number? right)) - (max this-right right) - 'display-end) - (max this-bottom bottom) - (cdr rectangles)) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles))))]))) + [(and did-something? ((current-inexact-milliseconds) . >= . done-time)) + (final-invalidate left top right bottom) + (queue-callback + (λ () (run-recompute-range-rectangles)) + #f)] + [(null? pending-ranges) + (final-invalidate left top right bottom) + (set! recompute-callback-running? #f)] + [else + (set! did-something? #t) + (define a-range (car pending-ranges)) + (set! pending-ranges (cdr pending-ranges)) + (define old-rectangles (range-rectangles a-range)) + (cond + [old-rectangles + (define new-rectangles (compute-rectangles a-range)) + (cond + [(equal? new-rectangles old-rectangles) + (loop left top right bottom)] + [else + (define-values (new-left new-right new-top new-bottom) + (for/fold ([left left] [top top] [right right] [bottom bottom]) + ([r (in-list new-rectangles)]) + (join-rectangles left top right bottom r))) + (define-values (both-left both-right both-top both-bottom) + (for/fold ([left new-left] [top new-top] [right new-right] [bottom new-bottom]) + ([r (in-list old-rectangles)]) + (join-rectangles left top right bottom r))) + (set-range-rectangles! a-range new-rectangles) + (loop both-left both-right both-top both-bottom)])] + [else + ;; when old-rectangles is #f, that means that this + ;; range has been removed from the ranges-deq, so + ;; can just skip over it here. + (loop left top right bottom)])]))) - (define/private (recompute-range-rectangles) - (let* ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [new-rectangles - (λ (range rst) - (let* ([start (range-start range)] - [end (range-end range)] - [caret-space? (range-caret-space? range)] - [style (range-style range)] - [color (range-color range)] - [lp (last-position)]) - (let*-values ([(start-eol? end-eol?) - (if (= start end) - (values #f #f) - (values #f #t))] - [(start-x top-start-y bottom-start-y) - (begin - (position-locations start b1 b2 #f b3 start-eol? #t) - (values (if caret-space? - (+ 1 (unbox b1)) - (unbox b1)) - (unbox b2) - (unbox b3)))] - [(end-x top-end-y bottom-end-y) - (begin (position-locations end b1 b2 #f b3 end-eol? #t) - (values (unbox b1) - (unbox b2) - (unbox b3)))]) - (cond - ;; the position-location values can be strange when - ;; this condition is true, so we just bail out. - [(or (> start lp) (> end lp)) '()] - [(= top-start-y top-end-y) - (cons - (make-rectangle start-x - top-start-y - (if (= end-x start-x) - (+ end-x 1) - end-x) - bottom-start-y - style - color) - rst)] - [(or (eq? style 'hollow-ellipse) - (eq? style 'ellipse)) - (let ([end-line (position-line end end-eol?)]) - (let loop ([l (min start-x end-x)] - [r (max start-x end-x)] - [line (position-line start start-eol?)]) - - (cond - [(> line end-line) - (cons - (make-rectangle l - top-start-y - r - bottom-end-y - style - color) - rst)] - [else - (let ([line-start (line-start-position line)] - [line-end (line-end-position line)]) - (position-location line-start b1 #f #t) - (position-location line-end b2 #f #t) - (loop (min (unbox b1) (unbox b2) l) - (max (unbox b1) (unbox b2) r) - (+ line 1)))])))] - [else - (list* - (make-rectangle start-x - top-start-y - 'right-edge - bottom-start-y - style - color) - (make-rectangle 'left-edge - bottom-start-y - 'right-edge - top-end-y - style - color) - (make-rectangle 'left-edge - top-end-y - end-x - bottom-end-y - style - color) - rst)]))))]) - - (set! range-rectangles - (foldl new-rectangles - null - (get-highlighted-ranges))))) + (define/private (join-rectangles left top right bottom r) + (define this-left + (if (number? (rectangle-left r)) + (adjust r (rectangle-left r) -) + 0.0)) + (define this-right + (if (number? (rectangle-right r)) + (adjust r (rectangle-right r) +) + 'display-end)) + (define this-top (adjust r (rectangle-top r) -)) + (define this-bottom (adjust r (rectangle-bottom r) +)) + (if (and left top right bottom) + (values (min this-left left) + (min this-top top) + (if (and (number? this-right) (number? right)) + (max this-right right) + 'display-end) + (max this-bottom bottom)) + (values this-left + this-top + this-right + this-bottom))) + + (define/private (final-invalidate left top right bottom) + (when left + (let ([width (if (number? right) (- right left) 'display-end)] + [height (if (number? bottom) (- bottom top) 'display-end)]) + (when (and (or (symbol? width) (> width 0)) + (or (symbol? height) (> height 0))) + (invalidate-bitmap-cache left top width height))))) + + (define/private (adjust r w f) + (+ w (f (case (rectangle-style r) + [(dot hollow-ellipse) 8] + [else 0])))) + + (define b1 (box 0)) + (define b2 (box 0)) + (define b3 (box 0)) + (define/private (compute-rectangles range) + (define start (range-start range)) + (define end (range-end range)) + (define caret-space? (range-caret-space? range)) + (define style (range-style range)) + (define color (range-color range)) + (define lp (last-position)) + (define-values (start-eol? end-eol?) (if (= start end) (values #f #f) (values #f #t))) + (define-values (start-x top-start-y bottom-start-y) + (begin + (position-locations start b1 b2 #f b3 start-eol? #t) + (values (if caret-space? + (+ 1 (unbox b1)) + (unbox b1)) + (unbox b2) + (unbox b3)))) + (define-values (end-x top-end-y bottom-end-y) + (begin (position-locations end b1 b2 #f b3 end-eol? #t) + (values (unbox b1) + (unbox b2) + (unbox b3)))) + (cond + ;; the position-location values can be strange when + ;; this condition is true, so we just bail out. + [(or (> start lp) (> end lp)) '()] + [(= top-start-y top-end-y) + (list (build-rectangle start-x + top-start-y + (if (= end-x start-x) + (+ end-x 1) + end-x) + bottom-start-y + style + color))] + [(or (eq? style 'hollow-ellipse) + (eq? style 'ellipse)) + (define end-line (position-line end end-eol?)) + (let loop ([l (min start-x end-x)] + [r (max start-x end-x)] + [line (position-line start start-eol?)]) + + (cond + [(> line end-line) + (list (build-rectangle l top-start-y + r bottom-end-y + style color))] + [else + (define line-start (line-start-position line)) + (define line-end (line-end-position line)) + (position-location line-start b1 #f #t) + (position-location line-end b2 #f #t) + (loop (min (unbox b1) (unbox b2) l) + (max (unbox b1) (unbox b2) r) + (+ line 1))]))] + [else + (list (build-rectangle start-x top-start-y + 'right-edge bottom-start-y + style color) + (build-rectangle 'left-edge bottom-start-y + 'right-edge top-end-y + style color) + (build-rectangle 'left-edge top-end-y + end-x bottom-end-y + style color))])) (define/augment (on-reflow) - (run-after-edit-sequence - (λ () (unless delayed-highlights? - (recompute-range-rectangles))) - 'framework:recompute-range-rectangles) + (recompute-range-rectangles) (inner (void) on-reflow)) - (define delayed-highlights? #f) - (define todo void) - - (define/augment (on-edit-sequence) - (set! delayed-highlights? #t) - (inner (void) on-edit-sequence)) - - (define/augment (after-edit-sequence) - (set! delayed-highlights? #f) - (unless (eq? todo void) - ;; don't redraw unless something changed - (redraw-highlights todo) - (set! todo void)) - (inner (void) after-edit-sequence)) - (define/augment (after-load-file success?) (inner (void) after-load-file success?) (when success? - (set! ranges (make-hash)) - (set! ranges-low 0) - (set! ranges-high 0) - (set! ranges-list #f))) + (set! ranges-deq (make-queue)))) (define/public (highlight-range start end color [caret-space? #f] [priority 'low] [style 'rectangle]) (unless (let ([exact-pos-int? @@ -332,150 +306,189 @@ (let* ([color (if (is-a? color color%) color (send the-color-database find-color color))] - [l (make-range start end caret-space? style color)] - [update-one - (λ () - (set! ranges-list #f) - (hash-cons! ranges l (if (eq? priority 'high) (+ ranges-high 1) (- ranges-low 1))) - (if (eq? priority 'high) - (set! ranges-high (+ ranges-high 1)) - (set! ranges-low (- ranges-low 1))))]) - (cond - [delayed-highlights? - (set! todo - (let ([old-todo todo]) - (λ () - (old-todo) - (update-one))))] - [else - (redraw-highlights update-one)]) + [l (make-range start end caret-space? style color #f)]) + (if (eq? priority 'high) + (enqueue! ranges-deq l) + (enqueue-front! ranges-deq l)) + (set-range-rectangles! l (compute-rectangles l)) + (invalidate-rectangles (range-rectangles l)) (λ () (unhighlight-range start end color caret-space? style)))) + + (define/public (unhighlight-range start end in-color [caret-space? #f] [style 'rectangle]) + (define color (if (is-a? in-color color%) + in-color + (send the-color-database find-color in-color))) + (unhighlight-ranges + (λ (r-start r-end r-color r-caret-space? r-style) + (and (equal? start r-start) + (equal? end r-end) + (equal? color r-color) + (equal? caret-space? r-caret-space?) + (equal? style r-style))))) - (define/private (redraw-highlights todo) - (let ([old-rectangles range-rectangles]) - (todo) - (recompute-range-rectangles) - (invalidate-rectangles (append old-rectangles range-rectangles)))) + (define/public (unhighlight-ranges pred) + (define left #f) + (define top #f) + (define right #f) + (define bottom #f) + (queue-filter! + ranges-deq + (λ (a-range) + (cond + [(pred (range-start a-range) + (range-end a-range) + (range-color a-range) + (range-caret-space? a-range) + (range-style a-range)) + (for ([rect (in-list (range-rectangles a-range))]) + (set!-values (left top right bottom) + (join-rectangles left top right bottom rect))) + (set-range-rectangles! a-range #f) + #f] + [else + #t]))) + (final-invalidate left top right bottom)) - (define/public (unhighlight-range start end color [caret-space? #f] [style 'rectangle]) - (let ([candidate (make-range start end - caret-space? - style - (if (is-a? color color%) - color - (send the-color-database find-color color)))]) - (let ([new-todo - (λ () - (let ([old-val (hash-ref ranges candidate #f)]) - (when old-val ;; may have been cleared by an earlier call to unhighlight-range - (let ([new-val (cdr old-val)]) - (cond - [(null? new-val) - (hash-remove! ranges candidate)] - [else - (hash-set! ranges candidate new-val)])) - (set! ranges-list #f))))]) - (cond - [delayed-highlights? - (set! todo - (let ([old-todo todo]) - (λ () - (old-todo) - (new-todo))))] - [else - (redraw-highlights new-todo)])))) + (define/private (invalidate-rectangles rectangles) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (final-invalidate left top right bottom)] + [else + (define-values (new-left new-top new-right new-bottom) + (join-rectangles left top right bottom (car rectangles))) + (loop new-left new-top new-right new-bottom + (cdr rectangles))]))) (define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (when before - (let-values ([(view-x view-y view-width view-height) - (let ([admin (get-admin)]) - (if admin - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)]) - (send admin get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4))) - (values left-margin top-margin right-margin bottom-margin)))]) - (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [old-smoothing (send dc get-smoothing)] - [last-color #f] - [color-rectangle - (λ (rectangle) - (let* ([left (if (number? (rectangle-left rectangle)) - (rectangle-left rectangle) - view-x)] - [top (rectangle-top rectangle)] - [right (if (number? (rectangle-right rectangle)) - (rectangle-right rectangle) - (+ view-x view-width))] - [bottom (rectangle-bottom rectangle)] - [width (max 0 (- right left))] - [height (max 0 (- bottom top))]) - (when (and (or (<= left-margin left right-margin) - (<= left-margin (+ left width) right-margin) - (<= left left-margin right-margin (+ left width))) - (or (<= top-margin top bottom-margin) - (<= top-margin (+ top height) bottom-margin) - (<= top top-margin bottom-margin (+ top height)))) - - (let ([color (let ([rc (rectangle-color rectangle)]) - (cond - [(and last-color (eq? last-color rc)) - rc] - [rc - (set! last-color #f) - (unless highlight-tmp-color - (set! highlight-tmp-color (make-object color% 0 0 0))) - (send dc try-color rc highlight-tmp-color) - (if (<= (color-model:rgb-color-distance - (send rc red) - (send rc green) - (send rc blue) - (send highlight-tmp-color red) - (send highlight-tmp-color green) - (send highlight-tmp-color blue)) - 18) - (begin (set! last-color rc) - rc) - #f)] - [else - (set! last-color #f) - rc]))]) - (when color - (case (rectangle-style rectangle) - [(dot) - (let ([cx left] - [cy bottom]) - (send dc set-pen "black" 1 'transparent) - (send dc set-brush color 'solid) - (send dc draw-ellipse (+ dx cx -3) (+ dy cy -3) 6 6))] - [(hollow-ellipse) - (send dc set-pen color 3 'solid) - (send dc set-brush "black" 'transparent) - (send dc draw-ellipse - (+ dx left -4) - (+ dy top -4) - (+ width 8) - (+ height 8))] - [(rectangle) - (send dc set-pen color 1 'transparent) - (send dc set-brush color 'solid) - (send dc draw-rectangle (+ left dx) (+ top dy) width height)] - [(ellipse) - (send dc set-pen color 1 'transparent) - (send dc set-brush color 'solid) - (send dc draw-ellipse (+ left dx) (+ top dy) width height)]))))))]) - (send dc set-smoothing 'aligned) - (for-each color-rectangle range-rectangles) + (define-values (view-x view-y view-width view-height) + (let ([admin (get-admin)]) + (if admin + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)]) + (send admin get-view b1 b2 b3 b4) + (values (unbox b1) + (unbox b2) + (unbox b3) + (unbox b4))) + (values left-margin top-margin right-margin bottom-margin)))) + (define old-pen (send dc get-pen)) + (define old-brush (send dc get-brush)) + (define old-smoothing (send dc get-smoothing)) + (define last-color #f) + (send dc set-smoothing 'aligned) + (for ([range (in-queue ranges-deq)]) + (for ([rectangle (in-list (range-rectangles range))]) + (define left (if (number? (rectangle-left rectangle)) + (rectangle-left rectangle) + view-x)) + (define top (rectangle-top rectangle)) + (define right (if (number? (rectangle-right rectangle)) + (rectangle-right rectangle) + (+ view-x view-width))) + (define bottom (rectangle-bottom rectangle)) + (when (and (or (<= left-margin left right-margin) + (<= left-margin right right-margin) + (<= left left-margin right-margin right)) + (or (<= top-margin top bottom-margin) + (<= top-margin bottom bottom-margin) + (<= top top-margin bottom-margin bottom))) + (define width (if (right . <= . left) 0 (- right left))) + (define height (if (bottom . <= . top) 0 (- bottom top))) + (define color (let ([rc (rectangle-color rectangle)]) + (cond + [(and last-color (eq? last-color rc)) + rc] + [rc + (set! last-color #f) + (send dc try-color rc highlight-tmp-color) + (if (<= (color-model:rgb-color-distance + (send rc red) + (send rc green) + (send rc blue) + (send highlight-tmp-color red) + (send highlight-tmp-color green) + (send highlight-tmp-color blue)) + 18) + (begin (set! last-color rc) + rc) + #f)] + [else + (set! last-color #f) + rc]))) + (when color + (case (rectangle-style rectangle) + [(dot) + (let ([cx left] + [cy bottom]) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush color 'solid) + (send dc draw-ellipse (+ dx cx -3) (+ dy cy -3) 6 6))] + [(hollow-ellipse) + (send dc set-pen color 3 'solid) + (send dc set-brush "black" 'transparent) + (send dc draw-ellipse + (+ dx left -4) + (+ dy top -4) + (+ width 8) + (+ height 8))] + [(rectangle) + (send dc set-pen color 1 'transparent) + (send dc set-brush color 'solid) + (send dc draw-rectangle (+ left dx) (+ top dy) width height)] + [(ellipse) + (send dc set-pen color 1 'transparent) + (send dc set-brush color 'solid) + (send dc draw-ellipse (+ left dx) (+ top dy) width height)]))))) (send dc set-smoothing old-smoothing) (send dc set-pen old-pen) - (send dc set-brush old-brush))))) + (send dc set-brush old-brush))) + + (super-new))) + +(define other-basics-mixin + (mixin (editor:basic<%> (class->interface text%)) () + (inherit get-canvas split-snip get-snip-position + begin-edit-sequence end-edit-sequence + set-autowrap-bitmap + delete find-snip + get-style-list change-style + position-line line-start-position + get-filename) + + (define/public (get-fixed-style) + (send (get-style-list) find-named-style "Standard")) + + (define port-name-identifier #f) + (define/public (get-port-name) + (let* ([b (box #f)] + [n (get-filename b)]) + (cond + [(or (unbox b) (not n)) + (unless port-name-identifier + (set! port-name-identifier (gensym 'unsaved-editor)) + (register-port-name! port-name-identifier this)) + port-name-identifier] + [else n]))) + (define/public (port-name-matches? id) + (let ([filename (get-filename)]) + (or (and (path? id) + (path? filename) + (or (equal? id filename) ;; "fast path" check + (equal? (normal-case-path (normalize-path (get-filename))) + (normal-case-path (normalize-path id))))) + (and (symbol? port-name-identifier) + (symbol? id) + (equal? port-name-identifier id))))) + (define styles-fixed? #f) (public get-styles-fixed set-styles-fixed) @@ -540,8 +553,9 @@ (super-new) (set-autowrap-bitmap (initial-autowrap-bitmap)))) - -(define (hash-cons! h k v) (hash-set! h k (cons v (hash-ref h k '())))) +(define (basic-mixin %) + (class* (highlight-range-mixin (other-basics-mixin %)) (basic<%>) + (super-new))) (define line-spacing<%> (interface ())) @@ -890,197 +904,111 @@ get-search-bubbles get-search-hit-count)) -(define dim-plum - (let ([plum (send the-color-database find-color "plum")] - [f (λ (x) (+ x (floor (* (- 255 x) 2/3))))]) +(define normal-search-color (send the-color-database find-color "plum")) +(define dark-search-color (send the-color-database find-color "mediumorchid")) +(define light-search-color + (let ([f (λ (x) (+ x (floor (* (- 255 x) 2/3))))]) (make-object color% - (f (send plum red)) - (f (send plum green)) - (f (send plum blue))))) - -(define (get-search-highlight-colors) - (values dim-plum - "plum" - "mediumorchid")) + (f (send normal-search-color red)) + (f (send normal-search-color green)) + (f (send normal-search-color blue))))) +(define white-on-black-yellow-bubble-color (make-object color% 50 50 5)) (define searching-mixin - (mixin (editor:keymap<%> basic<%>) (searching<%>) + (mixin (editor:basic<%> editor:keymap<%> basic<%>) (searching<%>) (inherit invalidate-bitmap-cache get-start-position get-end-position - unhighlight-range highlight-range + unhighlight-ranges unhighlight-range highlight-range run-after-edit-sequence begin-edit-sequence end-edit-sequence - find-string) - - (define/override (get-keymaps) - (editor:add-after-user-keymap (keymap:get-search) (super get-keymaps))) + find-string get-admin position-line + in-edit-sequence? get-pos/text-dc-location + get-canvas get-top-level-window) + (define has-focus? #f) + (define clear-yellow void) (define searching-str #f) (define case-sensitive? #f) + (define search-hit-count 0) + (define before-caret-search-hit-count 0) + (define search-coroutine #f) - ;; replace-start (or/c false/c number?) - ;; #f if replace isn't visible, otherwise the position just - ;; before a search hit where replacement should start - (define replace-start #f) + (define update-replace-bubble-callback-running? #f) + (define search-position-callback-running? #f) + + (define anchor-pos #f) - ;; search-bubble-table : hash-table[(cons number number) -o> (or/c color% string)] - (define search-bubble-table (make-hash)) + ;; replace-mode? : boolean? + ;; #t if the replace portion of the GUI is visible + ;; (and thus we have light/dark bubbles) + (define replace-mode? #f) - ;; to-replace-highlight : (or/c false/c (list/c number number (or/c color% string))) + ;; to-replace-highlight : (or/c #f (cons/c number number)) + ;; the location where the next replacement will happen, or #f + ;; if there isn't one (in case the insertion point is past + ;; the last search hit, or replace-mode? is #f) + ;; invariant: to-replace-highlight is not mapped in search-bubble-table + ;; (even though it is a legtimate hit) (define to-replace-highlight #f) + ;; search-bubble-table : hash-table[(cons number number) -o> #t] + (define search-bubble-table (make-hash)) + ;; get-replace-search-hit : -> (or/c number #f) ;; returns the nearest search hit after `replace-start' (define/public (get-replace-search-hit) - (and replace-start - searching-str - (do-search searching-str replace-start 'eof))) - - (define/public (set-replace-start n) - (cond - [(and (not n) (not replace-start)) - ;; nothing to do, since it didn't change - (void)] - [(not searching-str) - ;; there is no searching setup, so just do nothing - (void)] - [(equal? (get-replace-search-hit) - (do-search searching-str n 'eof)) - ;; the search reference changed, but the nearest search hit didn't. - ;; just record the new replace-start and do nothing else - ;; (possibly, even recording the new replace-start isn't even useful - (set! replace-start n)] - [else - ;; here the bubbles change - (begin-edit-sequence) - - (let-values ([(light-color normal-color dark-color) (get-search-highlight-colors)]) - - ;; remove search highlight when it was separate from a bubble - (when to-replace-highlight - (unhighlight-range (list-ref to-replace-highlight 0) - (list-ref to-replace-highlight 1) - (list-ref to-replace-highlight 2) - #f - 'hollow-ellipse) - (set! to-replace-highlight #f)) - - ;; remove old search highlight when it was a bubble - ;; (need to add in the dim color since the bubble needs to stay) - (let ([old-search-hit (get-replace-search-hit)]) - (when old-search-hit - (let* ([old-search-hit-end (+ old-search-hit (string-length searching-str))] - [color (hash-ref search-bubble-table (cons old-search-hit old-search-hit-end) #f)]) - (when color - (unhighlight-range old-search-hit - old-search-hit-end - color - #f - 'hollow-ellipse) - (highlight-range old-search-hit - old-search-hit-end - light-color - #f - 'low - 'hollow-ellipse) - (hash-set! search-bubble-table (cons old-search-hit old-search-hit-end) light-color))))) - - (set! replace-start n) - - (let ([new-search-hit (get-replace-search-hit)]) - (when new-search-hit - (let* ([new-search-hit-end (+ new-search-hit (string-length searching-str))] - [color (hash-ref search-bubble-table (cons new-search-hit new-search-hit-end) #f)]) - (cond - [color - (unhighlight-range new-search-hit - new-search-hit-end - color - #f - 'hollow-ellipse) - (hash-set! search-bubble-table (cons new-search-hit new-search-hit-end) dark-color) - (highlight-range new-search-hit - new-search-hit-end - dark-color - #f - 'low - 'hollow-ellipse)] - [else - (set! to-replace-highlight (list new-search-hit - new-search-hit-end - dark-color)) - (highlight-range (list-ref to-replace-highlight 0) - (list-ref to-replace-highlight 1) - (list-ref to-replace-highlight 2) - #f - 'low - 'hollow-ellipse)]))))) - (end-edit-sequence)])) + (and searching-str + to-replace-highlight + (car to-replace-highlight))) + + ;; NEW METHOD: used for test suites + (define/public (search-updates-pending?) + (or update-replace-bubble-callback-running? + search-position-callback-running? + search-coroutine)) - (define search-hit-count 0) - (define before-caret-search-hit-count 0) + ;; NOW IGNORED + (define/public (set-replace-start n) (void)) - (define anchor-pos #f) (define/public (get-anchor-pos) anchor-pos) - (define clear-anchor void) - + (define/public (set-search-anchor position) + (begin-edit-sequence) + (when anchor-pos (unhighlight-anchor)) (cond - [position - (when (preferences:get 'framework:anchored-search) - (clear-anchor) - (set! anchor-pos position) - (set! clear-anchor - (let ([t1 (highlight-range anchor-pos anchor-pos "red" #f 'low 'dot)] - [t2 (highlight-range anchor-pos anchor-pos "red")]) - (λ () (t1) (t2)))))] + [(and position + (preferences:get 'framework:anchored-search)) + (set! anchor-pos position) + (highlight-anchor)] [else - (clear-anchor) - (set! clear-anchor void) - (set! anchor-pos #f)])) + (set! anchor-pos #f)]) + (end-edit-sequence)) (define/public (get-search-hit-count) (values before-caret-search-hit-count search-hit-count)) - (define/public (set-searching-state s cs? rs) + ;; NOW JUST BOOLEAN: r? argument (used to be "rs") + (define/public (set-searching-state s in-cs? in-r? [notify-frame? #f]) + (define r? (and in-r? #t)) + (define cs? (and in-cs? #t)) (unless (and (equal? searching-str s) (equal? case-sensitive? cs?) - (equal? replace-start rs)) + (equal? r? replace-mode?)) (set! searching-str s) (set! case-sensitive? cs?) - (set! replace-start rs) - (redo-search))) + (set! replace-mode? r?) + (redo-search notify-frame?))) + + (define/override (get-keymaps) + (editor:add-after-user-keymap (keymap:get-search) (super get-keymaps))) (define/augment (after-insert start len) - (unless updating-search? - (content-changed)) + (when searching-str + (redo-search #t)) (inner (void) after-insert start len)) (define/augment (after-delete start len) - (unless updating-search? - (content-changed)) + (when searching-str + (redo-search #t)) (inner (void) after-delete start len)) - (define timer #f) - (define updating-search? #f) - (define/private (content-changed) - (when searching-str - (unless timer - (set! timer - (new logging-timer% - [notify-callback - (λ () - (run-after-edit-sequence - (λ () - (set! updating-search? #t) - (redo-search) - (let ([tlw (get-top-level-window)]) - (when (and tlw - (is-a? tlw frame:searchable<%>)) - (send tlw search-text-changed))) - (set! updating-search? #f)) - 'framework:search-results-changed))]))) - (send timer stop) - (send timer start 150 #f))) - - (inherit get-top-level-window) (define/override (on-focus on?) (let ([f (get-top-level-window)]) (when (is-a? f frame:searchable<%>) @@ -1093,43 +1021,73 @@ (update-yellow)]))) (super on-focus on?)) - (define has-focus? #f) - (define clear-yellow void) (define/augment (after-set-position) (update-yellow) - - (when replace-start - (set-replace-start (get-start-position))) - - (when searching-str - (maybe-queue-search-position-update)) - + (maybe-queue-update-replace-bubble) + (maybe-queue-search-position-update) (inner (void) after-set-position)) + (define/private (maybe-queue-update-replace-bubble) + (unless update-replace-bubble-callback-running? + (set! update-replace-bubble-callback-running? #t) + (queue-callback + (λ () + (set! update-replace-bubble-callback-running? #f) + (unless search-coroutine + ;; the search co-routine will update + ;; the replace bubble to its proper color + ;; before it finishes so we can just let + ;; do this job + + + (define (replace-highlight->normal-hit) + (when to-replace-highlight + (let ([old-to-replace-highlight to-replace-highlight]) + (unhighlight-replace) + (highlight-hit old-to-replace-highlight)))) + + (cond + [(or (not searching-str) + (not replace-mode?)) + (when to-replace-highlight + (unhighlight-replace))] + [else + (define next (do-search (get-start-position) 'eof)) + (begin-edit-sequence) + (cond + [next + (unless (and to-replace-highlight + (= (car to-replace-highlight) next) + (= (cdr to-replace-highlight) (+ next (string-length searching-str)))) + (replace-highlight->normal-hit) + (define pr (cons next (+ next (string-length searching-str)))) + (unhighlight-hit pr) + (highlight-replace pr))] + [else + (replace-highlight->normal-hit)]) + (end-edit-sequence)]))) + #f))) ;; maybe-queue-editor-position-update : -> void ;; updates the editor-position in the frame, ;; but delays it until the next low-priority event occurs. - (define callback-running? #f) (define/private (maybe-queue-search-position-update) - (run-after-edit-sequence - (λ () - (unless callback-running? - (set! callback-running? #t) - (queue-callback - (λ () - (let ([count 0] - [start-pos (get-start-position)]) - (hash-for-each - search-bubble-table - (λ (k v) - (when (<= (car k) start-pos) - (set! count (+ count 1))))) - (update-before-caret-search-hit-count count)) - (set! callback-running? #f)) - #f))) - 'framework:search-text:update-search-position)) - + (unless search-position-callback-running? + (set! search-position-callback-running? #t) + (queue-callback + (λ () + (when searching-str + (define count 0) + (define start-pos (get-start-position)) + (hash-for-each + search-bubble-table + (λ (k v) + (when (<= (car k) start-pos) + (set! count (+ count 1))))) + (update-before-caret-search-hit-count count)) + (set! search-position-callback-running? #f)) + #f))) + (define/private (update-before-caret-search-hit-count c) (unless (equal? before-caret-search-hit-count c) (set! before-caret-search-hit-count c) @@ -1155,10 +1113,10 @@ (clear-yellow) (set! clear-yellow void) (when (and searching-str (= (string-length searching-str) (- end start))) - (when (do-search searching-str start end) + (when (do-search start end) (set! clear-yellow (highlight-range start end (if (preferences:get 'framework:white-on-black?) - (make-object color% 50 50 5) + white-on-black-yellow-bubble-color "khaki") #f 'low 'ellipse)))) (end-edit-sequence)]))] @@ -1167,125 +1125,198 @@ (set! clear-yellow void)])) (define/public (get-search-bubbles) - (sort (hash-map search-bubble-table - (λ (x y) (if (is-a? y color%) - (list x (list (send y red) - (send y green) - (send y blue))) - (list x y)))) - (λ (x y) (string<=? (format "~s" (car x)) - (format "~s" (car y)))))) + (sort + (append + (if to-replace-highlight + (list (list to-replace-highlight 'dark-search-color)) + (list)) + (hash-map search-bubble-table + (λ (x true) + (list x (if replace-mode? 'light-search-color 'normal-search-color))))) + string<=? + #:key (λ (x) (format "~s" (car x))))) - (define/private (redo-search) - (begin-edit-sequence) - (set! search-hit-count 0) - (set! before-caret-search-hit-count 0) - (clear-all-regions) + + (define/private (redo-search notify-frame?) + (define old-search-coroutine search-coroutine) + (set! search-coroutine (create-search-coroutine notify-frame?)) + (unless old-search-coroutine + ;; when old-search-coroutine is not #f, then + ;; we know that there is already a callback + ;; pending; the set! above just change what + ;; it will be doing. + (queue-callback (λ () (run-search)) #f))) + + (define/private (run-search) + (define done? (coroutine-run search-coroutine (void))) (cond - [searching-str - (let ([to-replace (get-replace-search-hit)] - [found-to-replace? #f] - [first-hit (do-search searching-str 0 'eof)]) - (let-values ([(dim-color regular-color dark-color) (get-search-highlight-colors)]) - (when first-hit - (set! before-caret-search-hit-count 1) - (let loop ([bubble-start first-hit] - [bubble-end (+ first-hit (string-length searching-str))] - [pos (+ first-hit 1)]) - (set! search-hit-count (+ search-hit-count 1)) - (let ([next (do-search searching-str pos 'eof)]) - (when (and next (< next (get-start-position))) - (set! before-caret-search-hit-count (+ 1 before-caret-search-hit-count))) - (cond - [(and next ; a - (<= next bubble-end)) ; b - - ;; continue this bubble when - ;; a) there is a search hit and - ;; b) the hit overlaps or touches the previous part of the bubble - (loop bubble-start - (+ next (string-length searching-str)) - (+ next 1))] - [else - - ;; end this bubble - (let ([color (if replace-start - (if (and (equal? bubble-start to-replace) - (equal? bubble-end (+ to-replace (string-length searching-str)))) - (begin (set! found-to-replace? #t) - dark-color) - dim-color) - regular-color)]) - (highlight-range bubble-start bubble-end color #f 'low 'hollow-ellipse) - (hash-set! search-bubble-table (cons bubble-start bubble-end) color)) - - (when next - ;; start a new one if there is another hit - (loop next - (+ next (string-length searching-str)) - (+ next 1)))])))) - - (unless found-to-replace? - (when to-replace - (set! to-replace-highlight (list to-replace - (+ to-replace (string-length searching-str)) - dark-color)) - (highlight-range (list-ref to-replace-highlight 0) - (list-ref to-replace-highlight 1) - (list-ref to-replace-highlight 2) - #f - 'low - 'hollow-ellipse)))))] + [done? + (set! search-coroutine #f)] [else - (invalidate-bitmap-cache)]) - - (update-yellow) - (end-edit-sequence) - - ;; stopping the timer ensures that when there is both an edit to the buffer *and* - ;; there is a call to (something that calls) redo-search during a single edit - ;; sequence, that the search is only done once. - (when timer (send timer stop))) + (queue-callback + (λ () (run-search)) + #f)])) + + (define/private (create-search-coroutine notify-frame?) + (coroutine + pause + first-val + (define start-time (current-inexact-milliseconds)) + (define did-something? #f) + (define (maybe-pause) + (cond + [(not did-something?) + (set! did-something? #t)] + [((+ start-time 30) . < . (current-inexact-milliseconds)) + (define was-in-edit-sequence? (in-edit-sequence?)) + (when was-in-edit-sequence? + (end-edit-sequence)) + (pause) + (when was-in-edit-sequence? + (begin-edit-sequence)) + (set! did-something? #f) + (set! start-time (current-inexact-milliseconds)) + #t] + [else #f])) + + (cond + [searching-str + (define new-search-bubbles '()) + (define new-replace-bubble #f) + (define first-hit (do-search 0 'eof)) + (define-values (this-search-hit-count this-before-caret-search-hit-count) + (cond + [first-hit + (define sp (get-start-position)) + (let loop ([bubble-start first-hit] + [search-hit-count 0] + [before-caret-search-hit-count 1]) + (maybe-pause) + (define bubble-end (+ bubble-start (string-length searching-str))) + (define bubble (cons bubble-start bubble-end)) + (define this-bubble + (cond + [(and replace-mode? + (not new-replace-bubble) + (<= sp bubble-start)) + (set! new-replace-bubble bubble) + 'the-replace-bubble] + [else + bubble])) + (set! new-search-bubbles (cons this-bubble new-search-bubbles)) + + (define next (do-search bubble-end 'eof)) + (define next-before-caret-search-hit-count + (if (and next (< next sp)) + (+ 1 before-caret-search-hit-count) + before-caret-search-hit-count)) + (cond + [next + ;; start a new one if there is another hit + (loop next + (+ search-hit-count 1) + next-before-caret-search-hit-count)] + [else + (values (+ search-hit-count 1) + before-caret-search-hit-count)]))] + [else (values 0 0)])) + + (set! search-hit-count this-search-hit-count) + (set! before-caret-search-hit-count this-before-caret-search-hit-count) + + (maybe-pause) + + (begin-edit-sequence) + (clear-all-regions) + + (maybe-pause) + + (for ([search-bubble (in-list (reverse new-search-bubbles))]) + (cond + [(eq? search-bubble 'the-replace-bubble) + (highlight-replace new-replace-bubble)] + [else + (highlight-hit search-bubble)]) + (maybe-pause)) + + (update-yellow) + (end-edit-sequence)] + [else + (begin-edit-sequence) + (clear-all-regions) + (set! search-hit-count 0) + (set! before-caret-search-hit-count 0) + (update-yellow) + (end-edit-sequence)]) + (when notify-frame? + (define canvas (get-canvas)) + (when canvas + (let loop ([w canvas]) + (cond + [(is-a? w frame:searchable<%>) + (send w search-hits-changed)] + [(is-a? w area<%>) + (loop (send w get-parent))])))))) (define/private (clear-all-regions) - (when to-replace-highlight - (unhighlight-range (list-ref to-replace-highlight 0) - (list-ref to-replace-highlight 1) - (list-ref to-replace-highlight 2) - #f - 'hollow-ellipse) - (set! to-replace-highlight #f)) - - ;; this 'unless' is just here to avoid allocation in case this function is called a lot + (when to-replace-highlight + (unhighlight-replace)) (unless (zero? (hash-count search-bubble-table)) - (hash-for-each - search-bubble-table - (λ (k v) (unhighlight-range (car k) (cdr k) v #f 'hollow-ellipse))) + (unhighlight-ranges + (λ (r-start r-end r-color r-caret-space? r-style) + (and (not r-caret-space?) + (eq? r-style 'hollow-ellipse) + (or (eq? r-color light-search-color) + (eq? r-color normal-search-color)) + (hash-ref search-bubble-table (cons r-start r-end) #f)))) (set! search-bubble-table (make-hash)))) - (define/private (find-end pos to-replace searching-str) - (let loop ([pos pos] - [count 1]) - (cond - [(do-search searching-str - pos - (+ pos (string-length searching-str))) - => - (λ (next-pos) - ;; if find-string returns non-#f here, then we know that we've found - ;; two of the search strings in a row, so coalesce them (unless - ;; we are in replace mode and the next thing to be replaced is here). - (cond - [(and to-replace - (<= pos to-replace next-pos)) - (values pos pos count)] - [else - (loop (+ next-pos (string-length searching-str)) - (+ count 1))]))] - [else - (values pos pos count)]))) + (define/private (do-search start end) (find-string searching-str 'forward start end #t case-sensitive?)) - (define/private (do-search str start end) (find-string str 'forward start end #t case-sensitive?)) + ;; INVARIANT: when a search bubble is highlighted, + ;; the search-bubble-table has it mapped to #t + ;; the two methods below contribute to this, but + ;; so does the 'clear-all-regions' method above + (define/private (unhighlight-hit pair) + (hash-remove! search-bubble-table pair) + (unhighlight-range (car pair) (cdr pair) + (if replace-mode? light-search-color normal-search-color) + #f + 'hollow-ellipse)) + (define/private (highlight-hit pair) + (hash-set! search-bubble-table pair #t) + (highlight-range (car pair) (cdr pair) + (if replace-mode? light-search-color normal-search-color) + #f + 'low + 'hollow-ellipse)) + + ;; INVARIANT: the "next to replace" highlight is always + ;; saved in 'to-replace-highlight' + (define/private (unhighlight-replace) + (unhighlight-range (car to-replace-highlight) + (cdr to-replace-highlight) + dark-search-color + #f + 'hollow-ellipse) + (set! to-replace-highlight #f)) + + (define/private (highlight-replace new-to-replace) + (set! to-replace-highlight new-to-replace) + (highlight-range (car to-replace-highlight) + (cdr to-replace-highlight) + dark-search-color + #f + 'high + 'hollow-ellipse)) + + (define/private (unhighlight-anchor) + (unhighlight-range anchor-pos anchor-pos "red" #f 'dot) + (unhighlight-range anchor-pos anchor-pos "red")) + + (define/private (highlight-anchor) + (highlight-range anchor-pos anchor-pos "red" #f 'low 'dot) + (highlight-range anchor-pos anchor-pos "red")) (super-new))) @@ -1614,6 +1645,11 @@ (send delegate unhighlight-range start end color caret-space? style)) (super unhighlight-range start end color caret-space? style)) + (define/override (unhighlight-ranges pred) + (when delegate + (send delegate unhighlight-ranges pred)) + (super unhighlight-ranges pred)) + (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?) @@ -2359,11 +2395,11 @@ (thread (λ () (let loop (;; text-to-insert : (queue (cons (union snip bytes) style)) - [text-to-insert (empty-queue)] + [text-to-insert (empty-at-queue)] [last-flush (current-inexact-milliseconds)]) (sync - (if (queue-empty? text-to-insert) + (if (at-queue-empty? text-to-insert) never-evt (handle-evt (alarm-evt (+ last-flush msec-timeout)) @@ -2383,15 +2419,15 @@ (handle-evt clear-output-chan (λ (_) - (loop (empty-queue) (current-inexact-milliseconds)))) + (loop (empty-at-queue) (current-inexact-milliseconds)))) (handle-evt write-chan (λ (pr-pr) (define return-chan (car pr-pr)) (define pr (cdr pr-pr)) - (let ([new-text-to-insert (enqueue pr text-to-insert)]) + (let ([new-text-to-insert (at-enqueue pr text-to-insert)]) (cond - [((queue-size text-to-insert) . < . output-buffer-full) + [((at-queue-size text-to-insert) . < . output-buffer-full) (when return-chan (channel-put return-chan '())) (loop new-text-to-insert last-flush)] @@ -2560,16 +2596,16 @@ ;; extracts the viable bytes (and other stuff) from the front of the queue ;; and returns them as strings (and other stuff). (define/private (split-queue converter q) - (let ([lst (queue->list q)]) + (let ([lst (at-queue->list q)]) (let loop ([lst lst] [acc null]) (if (null? lst) (values (reverse acc) - (empty-queue)) + (empty-at-queue)) (let-values ([(front rest) (peel lst)]) (cond [(not front) (values (reverse acc) - (empty-queue))] + (empty-at-queue))] [(bytes? (car front)) (let ([the-bytes (car front)] [key (cdr front)]) @@ -2578,14 +2614,14 @@ (bytes-convert converter the-bytes)]) (if (eq? termination 'aborts) (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) - (enqueue + (at-enqueue (cons (subbytes the-bytes src-read-k (bytes-length the-bytes)) key) - (empty-queue))) + (empty-at-queue))) (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) - (empty-queue)))) + (empty-at-queue)))) (let-values ([(converted-bytes src-read-k termination) (bytes-convert converter the-bytes)] [(more-bytes more-termination) (bytes-convert-end converter)]) @@ -2697,7 +2733,7 @@ (define peekers '()) ;; waiting for a peek (define committers '()) ;; waiting for a commit (define positioners '()) ;; waiting for a position - (define data (empty-queue)) ;; (queue (cons (union byte snip eof) line-col-pos)) + (define data (empty-at-queue)) ;; (queue (cons (union byte snip eof) line-col-pos)) (define position #f) ;; loop : -> alpha @@ -2731,7 +2767,7 @@ (handle-evt read-chan (λ (ent) - (set! data (enqueue ent data)) + (set! data (at-enqueue ent data)) (unless position (set! position (cdr ent))) (loop))) @@ -2741,7 +2777,7 @@ (semaphore-post peeker-sema) (set! peeker-sema (make-semaphore 0)) (set! peeker-evt (semaphore-peek-evt peeker-sema)) - (set! data (empty-queue)) + (set! data (empty-at-queue)) (set! position #f) (loop))) (handle-evt @@ -2785,12 +2821,12 @@ (handle-evt done-evt (λ (v) - (let ([nth-pos (cdr (peek-n data (- kr 1)))]) + (let ([nth-pos (cdr (at-peek-n data (- kr 1)))]) (set! position (list (car nth-pos) (+ 1 (cadr nth-pos)) (+ 1 (caddr nth-pos))))) - (set! data (dequeue-n data kr)) + (set! data (at-dequeue-n data kr)) (semaphore-post peeker-sema) (set! peeker-sema (make-semaphore 0)) (set! peeker-evt (semaphore-peek-evt peeker-sema)) @@ -2836,7 +2872,7 @@ [(struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) - (let ([size (queue-size data)]) + (let ([size (at-queue-size data)]) (cond [(not (eq? peeker-evt commit-peeker-evt)) (choice-evt @@ -2859,8 +2895,8 @@ [(and pe (not (eq? pe peeker-evt))) (choice-evt (channel-put-evt resp-chan #f) nack-evt)] - [((queue-size data) . > . skip-count) - (let ([nth (car (peek-n data skip-count))]) + [((at-queue-size data) . > . skip-count) + (let ([nth (car (at-peek-n data skip-count))]) (choice-evt nack-evt (cond @@ -2991,66 +3027,66 @@ ;; ;; queues ;; -(define-struct queue (front back count) #:mutable) -(define (empty-queue) (make-queue '() '() 0)) -(define (enqueue e q) (make-queue - (cons e (queue-front q)) - (queue-back q) - (+ (queue-count q) 1))) -(define (queue-first q) - (flip-around q) - (let ([back (queue-back q)]) +(define-struct at-queue (front back count) #:mutable) +(define (empty-at-queue) (make-at-queue '() '() 0)) +(define (at-enqueue e q) (make-at-queue + (cons e (at-queue-front q)) + (at-queue-back q) + (+ (at-queue-count q) 1))) +(define (at-queue-first q) + (at-flip-around q) + (let ([back (at-queue-back q)]) (if (null? back) - (error 'queue-first "empty queue") + (error 'at-queue-first "empty queue") (car back)))) -(define (queue-rest q) - (flip-around q) - (let ([back (queue-back q)]) +(define (at-queue-rest q) + (at-flip-around q) + (let ([back (at-queue-back q)]) (if (null? back) (error 'queue-rest "empty queue") - (make-queue (queue-front q) - (cdr back) - (- (queue-count q) 1))))) -(define (flip-around q) - (when (null? (queue-back q)) - (set-queue-back! q (reverse (queue-front q))) - (set-queue-front! q '()))) + (make-at-queue (at-queue-front q) + (cdr back) + (- (at-queue-count q) 1))))) +(define (at-flip-around q) + (when (null? (at-queue-back q)) + (set-at-queue-back! q (reverse (at-queue-front q))) + (set-at-queue-front! q '()))) -(define (queue-empty? q) (zero? (queue-count q))) -(define (queue-size q) (queue-count q)) +(define (at-queue-empty? q) (zero? (at-queue-count q))) +(define (at-queue-size q) (at-queue-count q)) ;; queue->list : (queue x) -> (listof x) ;; returns the elements in the order that successive deq's would have -(define (queue->list q) - (let ([ans (append (queue-back q) (reverse (queue-front q)))]) - (set-queue-back! q ans) - (set-queue-front! q '()) +(define (at-queue->list q) + (let ([ans (append (at-queue-back q) (reverse (at-queue-front q)))]) + (set-at-queue-back! q ans) + (set-at-queue-front! q '()) ans)) ;; dequeue-n : queue number -> queue -(define (dequeue-n queue n) +(define (at-dequeue-n queue n) (let loop ([q queue] [n n]) (cond [(zero? n) q] - [(queue-empty? q) (error 'dequeue-n "not enough!")] - [else (loop (queue-rest q) (- n 1))]))) + [(at-queue-empty? q) (error 'dequeue-n "not enough!")] + [else (loop (at-queue-rest q) (- n 1))]))) ;; peek-n : queue number -> queue -(define (peek-n queue init-n) +(define (at-peek-n queue init-n) (let loop ([q queue] [n init-n]) (cond [(zero? n) - (when (queue-empty? q) + (when (at-queue-empty? q) (error 'peek-n "not enough; asked for ~a but only ~a available" init-n - (queue-size queue))) - (queue-first q)] + (at-queue-size queue))) + (at-queue-first q)] [else - (when (queue-empty? q) + (when (at-queue-empty? q) (error 'dequeue-n "not enough!")) - (loop (queue-rest q) (- n 1))]))) + (loop (at-queue-rest q) (- n 1))]))) ;; ;; end queue abstraction diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 45ef9a0507..6dd0346a63 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -11,8 +11,8 @@ (end exact-nonnegative-integer?) (color (or/c string? (is-a?/c color%))) (caret-space boolean? #f) - (priority (symbols 'high 'low) 'low) - (style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle)) + (priority (or/c 'high 'low) 'low) + (style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle)) (-> void?)))]{ This function highlights a region of text in the buffer. @@ -46,16 +46,33 @@ } @defmethod[(unhighlight-range - (start exact-nonnegative-integer?) - (end exact-nonnegative-integer?) - (color (or/c string? (is-a?/c color%))) - (caret-space boolean? #f) - (style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) - void?]{ + (start exact-nonnegative-integer?) + (end exact-nonnegative-integer?) + (color (or/c string? (is-a?/c color%))) + (caret-space boolean? #f) + (style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) + void?]{ This method removes the highlight from a region of text in the buffer. The region must match up to a region specified from an earlier call to @method[text:basic<%> highlight-range]. + + This method does a linear scan over all of the regions currently set. + If you expect to call this method many times (when there are many + ranges set) + consider instead calling @method[text:basic<%> unhighlight-ranges]. + } + + @defmethod[(unhighlight-ranges + [pred? (-> exact-nonnegative-integer? + exact-nonnegative-integer? + (is-a?/c color%) + boolean? + (or/c 'rectangle 'ellipse 'hollow-ellipse) + boolean?)]) + void?]{ + This method removes the highlight from regions in the buffer as + selected by @racket[pred?]. } @defmethod*[(((get-highlighted-ranges) (listof text:range?)))]{ @@ -353,11 +370,12 @@ @defmethod[(set-searching-state [str (or/c false/c string?)] [cs? boolean?] - [replace-start (or/c false/c number?)]) + [replace-start (or/c false/c number?)] + [notify-frame? boolean?]) void?]{ - If @racket[str] is not @racket[#f], then this method highlights every - occurrence of @racket[str] in the editor. If @racket[str] is @racket[#f], - then it clears all of the highlighting in the buffer. + If @racket[str] is not @racket[#f], then this method initiates a search for + every occurrence of @racket[str] in the editor. If @racket[str] is @racket[#f], + then it clears all of the search highlighting in the buffer. If @racket[cs?] is @racket[#f], the search is case-insensitive, and otherwise it is case-sensitive. @@ -365,6 +383,13 @@ If the @racket[replace-start] argument is @racket[#f], then the search is not in replacement mode. If it is a number, then the first search hit after that position in the editor is where the next replacement will take place. + + The search does not complete before @method[text:searching<%> set-searching-state] + returns. Accordingly, @method[text:searching<%> get-search-hit-count] may + have out-of-date results for a while, until the search process is finished. + If @racket[notify-frame?] is @racket[#t] then + @method[frame:searchable<%> search-hits-changed] + is called when the search completes. } @defmethod[(set-search-anchor [position (or/c false/c number?)]) void?]{ @@ -374,7 +399,7 @@ @defmethod[(get-search-hit-count) number?]{ Returns the number of hits for the search in the buffer, based on the count - found last time that a search happened. + found last time that a search completed. } @defmethod[(get-replace-search-hit) (or/c number? #f)]{ @@ -578,8 +603,8 @@ (end exact-nonnegative-integer?) (color (or/c string? (is-a?/c color%))) (caret-space boolean? #f) - (priority (symbols 'high 'low) 'low) - (style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle)) + (priority (or/c 'high 'low) 'low) + (style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle)) (-> void?)))]{ In addition to calling the super method, @method[text:basic<%> highlight-range], this method forwards the highlighting to the delegatee. @@ -591,7 +616,7 @@ (end exact-nonnegative-integer?) (color (or/c string? (is-a?/c color%))) (caret-space boolean? #f) - (style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) + (style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) void?]{ This method propagates the call to the delegate and calls the super method. } diff --git a/collects/tests/drracket/follow-log.rkt b/collects/tests/drracket/follow-log.rkt index ce2e324e87..9dfd6ba553 100644 --- a/collects/tests/drracket/follow-log.rkt +++ b/collects/tests/drracket/follow-log.rkt @@ -36,10 +36,10 @@ log message was reported. (define top-n-events 50) (define drop-gc? #f) -(define start-right-away? #f) ;; only applies if the 'main' module is loaded +(define start-right-away? #t) ;; only applies if the 'main' module is loaded (define show-hist? #t) -(define script-drr? #f) -(define interesting-range-start -inf.0) +(define script-drr? #t) +(define interesting-range-start 26) (define interesting-range-end +inf.0) (define log-done-chan (make-channel)) @@ -219,7 +219,9 @@ log message was reported. (printf "\nwith gc\n") (print-gui-event-hist has-gc-events) (printf "\nwithout gc\n") - (print-gui-event-hist no-gc-events)] + (print-gui-event-hist no-gc-events) + (printf "\nboth with and without gc\n") + (print-gui-event-hist gui-events)] [else (define interesting-gui-events (let ([candidate-events @@ -338,15 +340,19 @@ log message was reported. ;(wait-until online-syncheck-done) - (for ([x (in-range 20)]) + (for ([x (in-range 1)]) + - #; (let ([s "fdjafjdklafjkdalsfjdaklfjdkaslfdjafjdklafjkdalsfjdaklfjdkasl"]) (for ([c (in-string s)]) - (test:keystroke c)) + (test:keystroke c) + ;(test:keystroke #\return) + (sleep .3)) + #; (for ([c (in-string s)]) + (test:keystroke #\backspace) (test:keystroke #\backspace))) - + #; (begin (test:keystroke #\") (test:keystroke #\a) diff --git a/collects/tests/framework/search.rkt b/collects/tests/framework/search.rkt index ab2dc1e9ac..b1feb5b992 100644 --- a/collects/tests/framework/search.rkt +++ b/collects/tests/framework/search.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require (for-syntax racket/base)) -(require "test-suite-utils.rkt") +(require (for-syntax racket/base) + "test-suite-utils.rkt") (define-syntax (test-search stx) (syntax-case stx () @@ -8,53 +8,159 @@ (with-syntax ([line (syntax-line stx)]) #'(test-search/proc line args ...))])) -(define (test-search/proc line txt string cs? rs bubble-table) +;; creates a search text, binds it to 't' and then, +;; for each expression in 'commands', evaluates it in a let +;; binding 't'. In between each call to commands, it waits +;; for the search text to quiesce and then finally gets +;; the search bubbles, comparing them to 'bubble-table' +(define (test-search/proc line commands bubble-table) + ;(printf "running test on line ~s\n" line) (test - (string->symbol (format "search.rkt: line ~a" line)) + (string->symbol (format "search.rkt: line ~a pos immediately" line)) (lambda (x) (equal? bubble-table x)) (lambda () - (queue-sexp-to-mred - `(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))] - [normalize - (λ (ht) (sort (hash-table-map ht list) - (λ (x y) (string<=? (format "~s" (car x)) - (format "~s" (car y))))))]) - (send t insert ,txt) - (send t set-searching-state ,string ,cs? ,rs) - (send t get-search-bubbles)))))) + (send-sexp-to-mred + `(let ([c (make-channel)]) + (queue-callback + (λ () (channel-put c (new (text:searching-mixin (editor:keymap-mixin text:basic%)))))) + (define t (channel-get c)) + (define (wait) + (let loop () + (queue-callback + (λ () + (channel-put c (send t search-updates-pending?))) + #f) + (when (channel-get c) + (loop)))) + ,@(apply + append + (for/list ([command (in-list commands)]) + (list `(queue-callback (λ () ,command (channel-put c #f))) + '(channel-get c) + '(wait)))) + (queue-callback + (λ () + (channel-put c (send t get-search-bubbles))) + #f) + (channel-get c)))))) -(define default-color "plum") -(define light-color '(243 223 243)) -(define dark-color "mediumorchid") +(test-search (list '(begin (send t insert "") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0))) + '()) +(test-search (list '(begin (send t insert "") + (send t set-searching-state "aba" #t #f)) + '(send t set-position 0 0)) + '()) +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0))) + `(((0 . 3) normal-search-color))) +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #t #f) ) + '(send t set-position 0 0)) + `(((0 . 3) normal-search-color))) -(test-search "" "aba" #t #f '()) -(test-search "aba" "aba" #t #f - `(((0 . 3) ,default-color))) +(test-search (list '(begin (send t insert "aba aba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0))) + `(((0 . 3) normal-search-color) + ((4 . 7) normal-search-color))) +(test-search (list '(begin (send t insert "aba aba") + (send t set-searching-state "aba" #t #f)) + '(send t set-position 0 0)) + `(((0 . 3) normal-search-color) + ((4 . 7) normal-search-color))) -(test-search "aba aba" "aba" #t #f - `(((0 . 3) ,default-color) - ((4 . 7) ,default-color))) -(test-search "abaaba" "aba" #t #f - `(((0 . 6) ,default-color))) +(test-search (list '(begin (send t insert "abaaba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0))) + `(((0 . 3) normal-search-color) + ((3 . 6) normal-search-color))) +(test-search (list '(begin (send t insert "abaaba") + (send t set-searching-state "aba" #t #f)) + '(send t set-position 0 0)) + `(((0 . 3) normal-search-color) + ((3 . 6) normal-search-color))) -(test-search "abababa" "aba" #t #f - `(((0 . 7) ,default-color))) +(test-search (list '(begin (send t insert "abababa") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0))) + `(((0 . 3) normal-search-color) + ((4 . 7) normal-search-color))) +(test-search (list '(begin (send t insert "abababa") + (send t set-searching-state "aba" #t #f)) + '(send t set-position 0 0)) + `(((0 . 3) normal-search-color) + ((4 . 7) normal-search-color))) -(test-search "Aba" "aba" #t #f '()) -(test-search "Aba" "aba" #f #f `(((0 . 3) ,default-color))) +(test-search (list '(begin (send t insert "Aba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0))) + '()) +(test-search (list '(begin (send t insert "Aba") + (send t set-searching-state "aba" #t #f)) + '(send t set-position 0 0)) + '()) +(test-search (list '(begin (send t insert "Aba") + (send t set-searching-state "aba" #f #f) + (send t set-position 0 0))) + `(((0 . 3) normal-search-color))) +(test-search (list '(begin (send t insert "Aba") + (send t set-searching-state "aba" #f #f)) + '(send t set-position 0 0)) + `(((0 . 3) normal-search-color))) -(test-search "" "aba" #t 0 '()) +(test-search (list '(begin (send t set-searching-state "aba" #t 0) + (send t set-position 0))) + '()) -(test-search "aba" "aba" #f 0 `(((0 . 3) ,dark-color))) +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #f #t) + (send t set-position 0 0))) + `(((0 . 3) dark-search-color))) +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + '(send t set-position 0 0)) + `(((0 . 3) dark-search-color))) -(test-search "abababa" "aba" #f 0 - `(((0 . 7) ,light-color))) +(test-search (list '(begin (send t insert "abababa") + (send t set-searching-state "aba" #f #t) + (send t set-position 0 0))) + `(((0 . 3) dark-search-color) + ((4 . 7) light-search-color))) +(test-search (list '(begin (send t insert "abababa") + (send t set-searching-state "aba" #f #t)) + '(send t set-position 0 0)) + `(((0 . 3) dark-search-color) + ((4 . 7) light-search-color))) -(test-search "aba aba aba" "aba" #f 2 - `(((0 . 3) ,light-color) - ((4 . 7) ,dark-color) - ((8 . 11) ,light-color))) +(test-search (list '(begin (send t insert "aba aba aba") + (send t set-searching-state "aba" #f #t) + (send t set-position 1 1))) + `(((0 . 3) light-search-color) + ((4 . 7) dark-search-color) + ((8 . 11) light-search-color))) +(test-search (list '(begin (send t insert "aba aba aba") + (send t set-searching-state "aba" #f #t)) + '(send t set-position 1 1)) + `(((0 . 3) light-search-color) + ((4 . 7) dark-search-color) + ((8 . 11) light-search-color))) -(test-search "abababa" "aba" #f 2 - `(((0 . 7) ,light-color))) +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + '(send t set-position 0 0) + '(send t set-position 3 3)) + `(((0 . 3) light-search-color))) +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + '(send t set-position 0 0) + '(send t set-position 1 1)) + `(((0 . 3) light-search-color))) + +(test-search (list '(begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + '(send t set-searching-state #f #f #f)) + `()) diff --git a/collects/tests/framework/test-suite-utils.rkt b/collects/tests/framework/test-suite-utils.rkt index 67bb9c11fc..c217a89bc3 100644 --- a/collects/tests/framework/test-suite-utils.rkt +++ b/collects/tests/framework/test-suite-utils.rkt @@ -86,18 +86,21 @@ (shutdown-mred) (thread (lambda () - (system* - (path->string - (build-path - (let-values ([(dir exe _) - (split-path (find-system-path 'exec-file))]) - (if (eq? dir 'relative) - 'same - dir)) - (if (eq? 'windows (system-type)) "Racket.exe" "racket"))) - (path->string - (build-path (collection-path "tests" "framework") - "framework-test-engine.rkt"))))) + (define racket-bin + (path->string + (build-path + (let-values ([(dir exe _) + (split-path (find-system-path 'exec-file))]) + (if (eq? dir 'relative) + 'same + dir)) + (if (eq? 'windows (system-type)) "Racket.exe" "racket")))) + (unless (system* + racket-bin + (path->string + (build-path (collection-path "tests" "framework") + "framework-test-engine.rkt"))) + (eprintf "starting gracket failed; used path ~s\n" racket-bin)))) (debug-printf mz-tcp "accepting listener\n") (let-values ([(in out) (tcp-accept listener)]) (set! in-port in) @@ -133,11 +136,10 @@ (set! in-port #f) (set! in-port #f)))) -(define mred-running? - (lambda () - (if (char-ready? in-port) - (not (eof-object? (peek-char in-port))) - #t))) +(define (mred-running?) + (if (char-ready? in-port) + (not (eof-object? (peek-char in-port))) + #t)) (define queue-sexp-to-mred (lambda (sexp)