From 1a28cda103fe9cc5b9e07351aa8c152a2c038af4 Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Sun, 14 Dec 2003 02:36:10 +0000 Subject: [PATCH] *** empty log message *** original commit: b1f68dd797b20271c7cd243e7bcf0303458a510e --- collects/framework/private/color.ss | 244 ++++++++++++++++++++++------ 1 file changed, 193 insertions(+), 51 deletions(-) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index a02e2b49..e94c3d54 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -56,9 +56,9 @@ ;; Some other tool wants to take over coloring the buffer, so the ;; colorer shouldn't color anything. (define frozen? #f) - ;; true iff the colorer should recolor from scratch when the freeze + ;; true iff the colorer must recolor from scratch when the freeze ;; is over. - (define restart-after-freeze #f) + (define force-recolor-after-freeze #f) ;; ---------------------- Lexing state ------------------------------ @@ -83,6 +83,7 @@ ;; ---------------------- Parnethesis matching ---------------------- + ;; The pairs of matching parens (define pairs '()) (define parens (new paren-tree% (matches pairs))) @@ -92,11 +93,14 @@ (define start-pos 0) (define end-pos 'end) + ;; Set the region of the text that is tokenized to start at start and + ;; end at end. (define/public (reset-region start end) (set! start-pos start) (set! end-pos end) (reset-tokens)) + ;; Modify the end of the region. (define/public (update-region-end end) (set! end-pos end)) @@ -116,27 +120,32 @@ (inherit change-style begin-edit-sequence end-edit-sequence highlight-range get-style-list in-edit-sequence? get-start-position get-end-position local-edit-sequence? get-styles-fixed has-focus?) - (define/public (reset-tokens) + + (define (reset-tokens) (send tokens reset-tree) (send invalid-tokens reset-tree) (set! invalid-tokens-start +inf.0) (set! up-to-date? #t) (set! restart-callback #f) + (set! force-recolor-after-freeze #f) (set! parens (new paren-tree% (matches pairs))) (set! current-pos start-pos) (set! colors null) (modify)) + ;; Let the background thread know the text has been modified. (define (modify) (when background-thread (break-thread background-thread))) + ;; Actually color the buffer. (define (color) (unless (null? colors) ((car colors)) (set! colors (cdr colors)) (color))) + ;; Discard extra tokens at the first of invalie-tokens (define (sync-invalid) (when (and (not (send invalid-tokens is-empty?)) (< invalid-tokens-start current-pos)) @@ -146,9 +155,9 @@ (set! invalid-tokens-start (+ invalid-tokens-start length))) (sync-invalid))) - ;; re-tokenize should be called with breaks enabled and exit with breaks disabled - ;; re-tokenize should be called when lock is not held. When it exits, the lock - ;; will be held. + ;; re-tokenize should be called with breaks enabled and exit with + ;; breaks disabled re-tokenize should be called when lock is not + ;; held. When it exits, the lock will be held. (define (re-tokenize in in-start-pos) (let-values (((type data new-token-start new-token-end) (get-token in))) ;; breaks must be disabled before the semaphore wait so we can't be @@ -171,13 +180,14 @@ (lambda () (change-style color sp ep #f))) colors))) - (insert-last! tokens (new token-tree% (length len) (data data))) + (insert-last! tokens (new token-tree% (length len) (data type))) (send parens add-token data len) (cond ((and (not (send invalid-tokens is-empty?)) (= invalid-tokens-start current-pos)) (send invalid-tokens search-max!) - (send parens merge-tree (send invalid-tokens get-root-end-position)) + (send parens merge-tree + (send invalid-tokens get-root-end-position)) (insert-last! tokens invalid-tokens) (set! invalid-tokens-start +inf.0)) (else @@ -187,16 +197,15 @@ (define (do-insert/delete edit-start-pos change-length) (unless (or stopped? force-stop?) - (when frozen? - (set! restart-after-freeze #t)) (when (> edit-start-pos start-pos) (set! edit-start-pos (sub1 edit-start-pos))) (modify) (cond (up-to-date? (send tokens search! (- edit-start-pos start-pos)) - (let-values (((orig-token-start orig-token-end valid-tree invalid-tree) - (send tokens split))) + (let-values + (((orig-token-start orig-token-end valid-tree invalid-tree) + (send tokens split))) (send parens split-tree orig-token-start) (set! invalid-tokens invalid-tree) (set! tokens valid-tree) @@ -212,7 +221,8 @@ (let-values (((tok-start tok-end valid-tree invalid-tree) (send invalid-tokens split))) (set! invalid-tokens invalid-tree) - (set! invalid-tokens-start (+ invalid-tokens-start tok-end change-length)))) + (set! invalid-tokens-start + (+ invalid-tokens-start tok-end change-length)))) ((>= edit-start-pos current-pos) (set! invalid-tokens-start (+ change-length invalid-tokens-start))) (else @@ -227,7 +237,7 @@ (inherit is-locked?) (define (colorer-driver) - (unless (or up-to-date? (in-edit-sequence?)) + (unless up-to-date? (thread-resume background-thread) (sleep .01) ;; This is when the background thread is working. (semaphore-wait mutex-lock) @@ -242,7 +252,8 @@ ((is-locked?) (set! restart-callback #t)) (else - (colorer-driver) + (unless (in-edit-sequence?) + (colorer-driver)) (unless up-to-date? (queue-callback colorer-callback #f))))) @@ -266,7 +277,8 @@ (printf "colorer thread: ~s\n" exn) (break-enabled #f) (semaphore-wait mutex-lock)))) - (re-tokenize (open-input-text-editor this current-pos end-pos (lambda (x) (values #f 1))) + (re-tokenize (open-input-text-editor this current-pos end-pos + (lambda (x) (values #f 1))) current-pos)) ;; Breaks should be disabled from exit of re-tokenize ;; lock will be held @@ -275,8 +287,7 @@ (thread-suspend (current-thread)))) (background-colorer)) - ;; Must not be called when the editor is locked or in an edit - ;; sequence + ;; Must not be called when the editor is locked (define (finish-now) (unless stopped? (let loop () @@ -284,6 +295,47 @@ (colorer-driver) (loop))))) + + ;; Starts tokenizing the buffer. + ;; + ;; token-sym-style- will be passed the first return symbol from get-token- + ;; and should return the style-name that the token should be colored. + ;; + ;; get-token- takes an input port and returns the next token as 4 values: + ;; first, a symbol describing the type of the token. This symbol + ;; is transformed into a style-name via the token-sym->style- + ;; argument. The symbols 'white-space and 'comment have special + ;; meaning and should always be returned for white-space and comment + ;; tokens respectively. + ;; second, a symbol indicating how the token should be treated by the paren + ;; matcher. This symbol should be in the pairs- argument. + ;; third and fourth, the starting and ending position of the token. + ;; get-token- will usually be implemented with a lexer using the + ;; (lib "lex.ss" "parser-tools") library. + ;; get-token- must obey the following invariants: + ;; 1) Every position in the buffer must be accounted for in exactly one token. + ;; 2) The token returned by get-token- must rely only on the contents of the + ;; input port argument. This means that the tokenization of some part + ;; of the input cannot depend on earlier parts of the input. + ;; 3) No edit to the buffer can change the tokenization of the buffer + ;; prior to the token immediately preceeding the edit. In the following + ;; example this invariant does not hold. If the buffer contains: + ;; " 1 2 3 + ;; and the tokenizer treats the unmatched " as its own token (a string error token), + ;; and separately tokenizes the 1 2 and 3, an edit to make the buffer look like: + ;; " 1 2 3" would result in a single string token modifying previous tokens. + ;; To handle these situations, get-token- must treat the first line as a single + ;; token. + ;; pairs- is a list of different kinds of matching parens. The second value returned + ;; by get-token- is compared to this list to see how the paren matcher should treat + ;; the token. An example: Suppose pairs is '((|(| |)|) (|[| |]|) (begin end)). + ;; This means that there are three kinds of parens. Any token which has 'begin as its + ;; second return value will act as an open for matching tokens with 'end. + ;; Similarly any token with '|]| will act as a closing match for tokens with '|[|. + ;; + ;; start-colorer: (symbol? -> string?) * + ;; (input-port? -> symbol? (union false? symbol?) natural-number? natural-number?) * + ;; (listof (list/p symbol? symbol?)) -> (define/public (start-colorer token-sym->style- get-token- pairs-) (unless force-stop? (set! stopped? #f) @@ -295,14 +347,16 @@ (set! parens (new paren-tree% (matches pairs))) (unless background-thread (break-enabled #f) - (set! background-thread (thread (lambda () (background-colorer-entry)))) + (set! background-thread + (thread (lambda () (background-colorer-entry)))) (break-enabled #t)) (do-insert/delete start-pos 0))) + ;; Stop coloring and paren matching the buffer. (define/public stop-colorer (opt-lambda ((clear-colors #t)) (set! stopped? #t) - (when clear-colors + (when (and clear-colors (not frozen?)) (change-style (send (get-style-list) find-named-style "Standard") start-pos end-pos #f)) (match-parens #t) @@ -311,41 +365,64 @@ (set! token-sym->style #f) (set! get-token #f))) + ;; Keep the buffer tokenized and paren matched, but stop altering the colors. (define/public (freeze-colorer) (when (is-locked?) (error 'freeze-colorer "called on a locked color:text<%>.")) - #| - (when (in-edit-sequence?) - (error 'freeze-colorer "called on a color:text<%> while in an edit sequence.")) - |# (unless frozen? (finish-now) (set! frozen? #t))) - (define/public (thaw-colorer) - (when frozen? - (set! frozen? #f) - (when restart-after-freeze - (let ((tn token-sym->style) - (gt get-token) - (p pairs)) - (stop-colorer (not should-color?)) - (start-colorer tn gt p))))) - + ;; Start coloring the buffer again. If recolor? is #t, the buffer is re-colored. If it is #f + ;; the buffer is not recolored. When recolor? is #t, retokenize? controls how the buffer + ;; is recolored. #f causes the buffer to be entirely recolored before thaw returns using + ;; the existing tokenization. #t causes the entire buffer to be retokenized and recolored + ;; from scratch. This will happen in the background after the call to that-colorer returns. + (define/public thaw-colorer + (opt-lambda ((recolor? #t) + (retokenize? #f)) + (when frozen? + (set! frozen? #f) + (cond + (stopped? + (stop-colorer)) + ((or force-recolor-after-freeze recolor?) + (cond + (retokenize? + (let ((tn token-sym->style) + (gt get-token) + (p pairs)) + (stop-colorer (not should-color?)) + (start-colorer tn gt p))) + (else + (begin-edit-sequence #f #f) + (finish-now) + (send tokens for-each + (lambda (start len type) + (when (and should-color? (not (eq? 'white-space type))) + (let ((color (send (get-style-list) find-named-style + (token-sym->style type))) + (sp (+ start-pos start)) + (ep (+ start-pos (+ start len)))) + (change-style color sp ep #f))))) + (end-edit-sequence)))))))) + + (define/private (toggle-color on?) (cond ((and frozen? (not (equal? on? should-color?))) - (set! restart-after-freeze #t)) + (set! should-color? on?) + (set! force-recolor-after-freeze #t)) ((and (not should-color?) on?) - (set! should-color? #t) + (set! should-color? on?) (reset-tokens) (do-insert/delete start-pos 0)) ((and should-color? (not on?)) - (set! should-color? #f) + (set! should-color? on?) (change-style (send (get-style-list) find-named-style "Standard") start-pos end-pos #f)))) - + ;; Causes the entire tokenizing system to become inactive. (define/public (force-stop-colorer x) (set! force-stop? x) (when x @@ -366,7 +443,8 @@ (define (highlight start end caret-pos error?) (let ([off (highlight-range (+ start-pos start) (+ start-pos end) (if error? mismatch-color (get-match-color)) - (and (send (icon:get-paren-highlight-bitmap) ok?) + (and (send (icon:get-paren-highlight-bitmap) + ok?) (icon:get-paren-highlight-bitmap)) (= caret-pos (+ start-pos start)))]) (set! clear-old-locations @@ -377,6 +455,10 @@ (define in-match-parens? #f) + ;; the forward matcher signaled an error because not enough of the + ;; tree has been built. + (define (f-match-false-error start end error) + (and error (<= (+ start-pos error) current-pos) (not up-to-date?))) ;; If there is no match because the buffer isn't lexed yet, this will ;; do nothing, but the edit sequence for changing color the colors @@ -397,16 +479,82 @@ (unless just-clear? (let* ((here (get-start-position))) (when (= here (get-end-position)) - (let-values (((start-f end-f error-f) (send parens match-forward (- here start-pos))) - ((start-b end-b error-b) (send parens match-backward (- here start-pos)))) - (when (and start-f end-f - (not (and error-f (<= (+ start-pos error-f) current-pos) (not up-to-date?)))) + (let-values (((start-f end-f error-f) + (send parens match-forward (- here start-pos))) + ((start-b end-b error-b) + (send parens match-backward (- here start-pos)))) + (when (and start-f end-f + (not (f-match-false-error start-f end-f error-f))) (highlight start-f end-f here error-f)) (when (and start-b end-b) (highlight start-b end-b here error-b))))))) (end-edit-sequence) (set! in-match-parens? #f)))) + + (define/public (forward-match position cutoff) + (do-forward-match position cutoff #f)) + + (define (do-forward-match position cutoff skip-whitespace?) + (let ((position + (if skip-whitespace? + (skip-whitespace position 'forward #t) + position))) + (let-values (((start end error) + (send parens match-forward (- position start-pos)))) + (cond + ((f-match-false-error start end error) + (colorer-driver) + (do-forward-match position cutoff #f)) + ((and start end (not error)) + (let ((match-pos (+ start-pos end))) + (cond + ((<= match-pos cutoff) match-pos) + (else #f)))) + (else #f))))) + + + (define/public (backward-match position cutoff) + (let ((position (skip-whitespace position 'backward #t))) + (let-values (((start end error) + (send parens match-backward (- position start-pos)))) + (cond + ((and start end (not error)) + (let ((match-pos (+ start-pos end))) + (cond + ((>= match-pos cutoff) match-pos) + (else #f)))) + (else #f))))) + + (define (tokenize-to-pos position) + (when (and (not up-to-date?) (<= current-pos position)) + (colorer-driver) + (tokenize-to-pos position))) + + (inherit last-position) + + (define/public (skip-whitespace position direction comments?) + (cond + ((and (eq? direction 'forward) + (>= position (if (eq? 'end end-pos) (last-position) end-pos))) + position) + ((and (eq? direction 'backward) (<= position start-pos)) + position) + (else + (let ((p (if (eq? direction 'backward) (sub1 position) position))) + (tokenize-to-pos p) + (send tokens search! (- p start-pos)) + (cond + ((or (eq? 'white-space (send tokens get-root-data)) + (and comments? (eq? 'comment (send tokens get-root-data)))) + (skip-whitespace (+ start-pos + (if (eq? direction 'forward) + (send tokens get-root-end-position) + (send tokens get-root-start-position))) + direction)) + (else p)))))) + + ;; ------------------------- Callbacks to Override ---------------------- (rename (super-lock lock)) @@ -483,14 +631,8 @@ (define text-mode-mixin (mixin (mode:surrogate-text<%>) (-text-mode<%>) - ;; get-token takes an input port and returns 4 values: - ;; A symbol in `(keyword string literal comment error identifier default) - ;; Data to be kept with the token - ;; The token's starting offset - ;; The token's ending offset - ;; - ;; matches is a list of lists of matching paren types. - ;; For example, '((|(| |)|) (|[| |]|)) + ;; The arguments here are only used to be passed to start-colorer. Refer to its + ;; documentation. (init-field (get-token default-lexer) (token-sym->style (lambda (x) "Standard")) (matches null))