*** empty log message ***
original commit: b1f68dd797b20271c7cd243e7bcf0303458a510e
This commit is contained in:
Scott Owens
parent
6759e693a6
commit
1a28cda103
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user