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

revise syntax colorer to use a list of colorers for dijoint ranges

Browse Source 
svn: r9655
This commit is contained in:
Matthew Flatt 2008-05-05 14:25:18 +00:00
parent 665e4c07bf
commit cf5dd35326
1 changed files with 440 additions and 427 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

625
collects/framework/private/color.ss
View File

@ -82,39 +82,64 @@ added get-regions
;; is over. ;; is over.
(define force-recolor-after-freeze #f) (define force-recolor-after-freeze #f)
;; ---------------------- Lexing state ------------------------------
;; The tree of valid tokens, starting at 0
(define tokens (new token-tree%))
;; If the tree is completed
(define up-to-date? #t)
(define/public (get-up-to-date?) up-to-date?)
;; The tree of tokens that have been invalidated by an edit
;; but might still be valid.
(define invalid-tokens (new token-tree%))
;; The position right before the invalid-tokens tree
(define invalid-tokens-start +inf.0)
;; The position right before the next token to be read
(define current-pos 0)
;; The lexer
(define get-token #f)
;; ---------------------- Parenethesis matching ---------------------- ;; ---------------------- Parenethesis matching ----------------------
;; The pairs of matching parens ;; The pairs of matching parens
(define pairs '()) (define pairs '())
(define parens (new paren-tree% (matches pairs)))
;; ---------------------- Lexing state ------------------------------
(define-struct lexer-state
(start-pos
end-pos
;; The tree of valid tokens, starting at start-pos
tokens ; = (new token-tree%)
;; If the tree is completed
up-to-date? ; #t
;; The tree of tokens that have been invalidated by an edit
;; but might still be valid.
invalid-tokens ; = (new token-tree%)
;; The position right before the ainvalid-tokens tree
invalid-tokens-start ; = +inf.0
;; The position right before the next token to be read
current-pos
;; Paren-matching
parens
)
#:mutable)
;; The lexer
(define get-token #f)
(define/private (make-new-lexer-state start end)
(make-lexer-state start
end
(new token-tree%)
#t
(new token-tree%)
+inf.0
0
(new paren-tree% (matches pairs))))
(define lexer-states (list (make-new-lexer-state 0 'end)))
(define/public (get-up-to-date?)
(andmap lexer-state-up-to-date? lexer-states))
(define/private (find-ls pos)
(ormap (lambda (ls)
(and (<= (lexer-state-start-pos ls)
pos
(let ([end (lexer-state-end-pos ls)])
(if (eq? end 'end)
+inf.0
end)))
ls))
lexer-states))
;; ---------------------- Interactions state ------------------------ ;; ---------------------- Interactions state ------------------------
;; regions : (listof (list number (union 'end number))) ;; The positions right before and right after the area to be tokenized
;; The range of editor positions that should be colored in the buffer
(define regions '((0 end)))
(inherit last-position) (inherit last-position)
(define/public (reset-region start end) (define/public (reset-region start end)
@ -145,8 +170,10 @@ added get-regions
(or (number? (list-ref region 1)) (or (number? (list-ref region 1))
(and (null? (cdr regions)) (and (null? (cdr regions))
(eq? 'end (list-ref region 1))))) (eq? 'end (list-ref region 1)))))
(error 'reset-regions "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e" region regions)) (error 'reset-regions
"got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e"
region
regions))
(unless (and (<= pos (list-ref region 0)) (unless (and (<= pos (list-ref region 0))
(or (eq? 'end (list-ref region 1)) (or (eq? 'end (list-ref region 1))
(<= (list-ref region 0) (list-ref region 1)))) (<= (list-ref region 0) (list-ref region 1))))
@ -155,24 +182,25 @@ added get-regions
[else [else
(error 'reset-regions "expected a list of regions, got ~e" regions)])) (error 'reset-regions "expected a list of regions, got ~e" regions)]))
(let ([old-regions regions]) (set! lexer-states
(set! regions _regions) (let loop ([old lexer-states]
(let loop ([old old-regions] [new _regions])
[new regions])
(cond (cond
[(and (null? old) (null? new)) (void)] [(null? new) null]
[(null? old) [(and (pair? old)
(do-insert/delete (list-ref (car new) 0) 0)] (equal? (caar new) (lexer-state-start-pos (car old)))
[(null? new) (equal? (cadar new) (lexer-state-end-pos (car old))))
(do-insert/delete (list-ref (car old) 0) 0)] (cons (car old)
[(equal? (car old) (car new)) (loop (cdr old) (cdr new)))]
(loop (cdr old) (cdr new))]
[else [else
(do-insert/delete (min (list-ref (car old) 0) (cons (make-new-lexer-state (caar new) (cadar new))
(list-ref (car new) 0)) (loop null (cdr new)))]))))
0)]))))
(define/public (get-regions) regions) (define/public (get-regions)
(map (lambda (ls)
(list (lexer-state-start-pos ls)
(lexer-state-end-pos ls)))
lexer-states))
;; ---------------------- Preferences ------------------------------- ;; ---------------------- Preferences -------------------------------
(define should-color? #t) (define should-color? #t)
@ -193,14 +221,17 @@ added get-regions
get-fixed-style) get-fixed-style)
(define/private (reset-tokens) (define/private (reset-tokens)
(send tokens reset-tree) (for-each
(send invalid-tokens reset-tree) (lambda (ls)
(set! invalid-tokens-start +inf.0) (send (lexer-state-tokens ls) reset-tree)
(set! up-to-date? #t) (send (lexer-state-invalid-tokens ls) reset-tree)
(set-lexer-state-invalid-tokens-start! ls +inf.0)
(set-lexer-state-up-to-date?! ls #t)
(set-lexer-state-current-pos! ls (lexer-state-start-pos ls))
(set-lexer-state-parens! ls (new paren-tree% (matches pairs))))
lexer-states)
(set! restart-callback #f) (set! restart-callback #f)
(set! force-recolor-after-freeze #f) (set! force-recolor-after-freeze #f)
(set! parens (new paren-tree% (matches pairs)))
(set! current-pos 0)
(set! colors null) (set! colors null)
(when tok-cor (when tok-cor
(coroutine-kill tok-cor)) (coroutine-kill tok-cor))
@ -215,136 +246,114 @@ added get-regions
(color))) (color)))
;; Discard extra tokens at the first of invalid-tokens ;; Discard extra tokens at the first of invalid-tokens
(define/private (sync-invalid) (define/private (sync-invalid ls)
(let ([invalid-tokens (lexer-state-invalid-tokens ls)]
[invalid-tokens-start (lexer-state-invalid-tokens-start ls)])
(when (and (not (send invalid-tokens is-empty?)) (when (and (not (send invalid-tokens is-empty?))
(< invalid-tokens-start current-pos)) (< invalid-tokens-start
(lexer-state-current-pos ls)))
(send invalid-tokens search-min!) (send invalid-tokens search-min!)
(let ((length (send invalid-tokens get-root-length))) (let ((length (send invalid-tokens get-root-length)))
(send invalid-tokens remove-root!) (send invalid-tokens remove-root!)
(set! invalid-tokens-start (+ invalid-tokens-start length))) (set-lexer-state-invalid-tokens-start! ls (+ invalid-tokens-start length)))
(sync-invalid))) (sync-invalid ls))))
(define/private (re-tokenize in-start-pos enable-suspend) (define/private (re-tokenize ls in in-start-pos enable-suspend)
(let port-loop ([regions (skip-early-regions in-start-pos)]
[previous-end in-start-pos])
(when previous-end
(let* ([next-start (if (null? regions)
(last-position)
(list-ref (car regions) 0))]
[len (- next-start previous-end)])
(unless (zero? len)
(insert-last-spec! tokens len #f)
(send parens add-token #f len))))
(unless (null? regions)
(let* ([start-pos (list-ref (car regions) 0)]
[end-pos (list-ref (car regions) 1)]
[in (open-input-text-editor this start-pos end-pos (λ (x) #f))])
(let loop ()
(let-values ([(lexeme type data new-token-start new-token-end) (let-values ([(lexeme type data new-token-start new-token-end)
(get-token in)]) (get-token in)])
(cond (unless (eq? 'eof type)
[(eq? 'eof type)
(port-loop (cdr regions)
(if (eq? 'end end-pos)
#f
end-pos))]
[else
(enable-suspend #f) (enable-suspend #f)
#;(printf "~a at ~a to ~a~n" #;(printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
lexeme (+ in-start-pos (sub1 new-token-end)))
(+ start-pos (sub1 new-token-start))
(+ start-pos (sub1 new-token-end)))
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
(set! current-pos (+ len current-pos)) (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
(sync-invalid) (sync-invalid ls)
(when (should-color-type? type) (when (and should-color? (should-color-type? type) (not frozen?))
(let* ([style-name (token-sym->style type)]
[color (send (get-style-list) find-named-style style-name)]
[sp (+ start-pos (sub1 new-token-start))]
[ep (+ start-pos (sub1 new-token-end))])
(add-color color sp ep)))
; Using the non-spec version takes 3 times as long as the spec
; version. In other words, the new greatly outweighs the tree
; operations.
;(insert-last! tokens (new token-tree% (length len) (data type)))
(insert-last-spec! tokens len 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))
(insert-last! tokens invalid-tokens)
(set! invalid-tokens-start +inf.0)
(enable-suspend #t)
(port-loop (cdr regions)
(if (eq? 'end end-pos)
#f
end-pos))]
[else
(enable-suspend #t)
(loop)]))])))))))
(define/private (add-color color sp ep)
(when (and should-color? (not frozen?))
(set! colors (set! colors
(cons (λ () (change-style color sp ep #f)) (cons
colors)))) (let* ([style-name (token-sym->style type)]
(color (send (get-style-list) find-named-style style-name))
(sp (+ in-start-pos (sub1 new-token-start)))
(ep (+ in-start-pos (sub1 new-token-end))))
(λ ()
(change-style color sp ep #f)))
colors)))
;; Using the non-spec version takes 3 times as long as the spec
;; version. In other words, the new greatly outweighs the tree
;; operations.
;;(insert-last! tokens (new token-tree% (length len) (data type)))
(insert-last-spec! (lexer-state-tokens ls) len type)
(send (lexer-state-parens ls) add-token data len)
(cond
((and (not (send (lexer-state-invalid-tokens ls) is-empty?))
(= (lexer-state-invalid-tokens-start ls)
(lexer-state-current-pos ls)))
(send (lexer-state-invalid-tokens ls) search-max!)
(send (lexer-state-parens ls) merge-tree
(send (lexer-state-invalid-tokens ls) get-root-end-position))
(insert-last! (lexer-state-tokens ls)
(lexer-state-invalid-tokens ls))
(set-lexer-state-invalid-tokens-start! ls +inf.0)
(enable-suspend #t))
(else
(enable-suspend #t)
(re-tokenize ls in in-start-pos enable-suspend)))))))
(define/private (skip-early-regions pos) (define/private (do-insert/delete/ls ls edit-start-pos change-length)
(let loop ([regions regions]) (unless (lexer-state-up-to-date? ls)
(sync-invalid ls))
(cond (cond
[(null? regions) null] ((lexer-state-up-to-date? ls)
[else (let ([reg (car regions)]) (let-values
(cond (((orig-token-start orig-token-end valid-tree invalid-tree)
[(<= pos (send (lexer-state-tokens ls) split (- edit-start-pos (lexer-state-start-pos ls)))))
(if (eq? 'end (list-ref reg 1)) (send (lexer-state-parens ls) split-tree orig-token-start)
(last-position) (set-lexer-state-invalid-tokens! ls invalid-tree)
(list-ref reg 1))) (set-lexer-state-tokens! ls valid-tree)
(cons (list (max pos (list-ref reg 0)) (set-lexer-state-invalid-tokens-start!
(list-ref reg 1)) ls
(cdr regions))] (if (send (lexer-state-invalid-tokens ls) is-empty?)
[else +inf.0
(loop (cdr regions))]))]))) (+ (lexer-state-start-pos ls) orig-token-end change-length)))
(set-lexer-state-current-pos! ls (+ (lexer-state-start-pos ls) orig-token-start))
(set-lexer-state-up-to-date?! ls #f)
(queue-callback (λ () (colorer-callback)) #f)))
((>= edit-start-pos (lexer-state-invalid-tokens-start ls))
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send (lexer-state-invalid-tokens ls) split
(- edit-start-pos (lexer-state-start-pos ls)))))
(set-lexer-state-invalid-tokens! ls invalid-tree)
(set-lexer-state-invalid-tokens-start!
ls
(+ (lexer-state-invalid-tokens-start ls) tok-end change-length))))
((> edit-start-pos (lexer-state-current-pos ls))
(set-lexer-state-invalid-tokens-start!
ls
(+ change-length (lexer-state-invalid-tokens-start ls))))
(else
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send (lexer-state-tokens ls) split
(- edit-start-pos (lexer-state-start-pos ls)))))
(send (lexer-state-parens ls) truncate tok-start)
(set-lexer-state-tokens! ls valid-tree)
(set-lexer-state-invalid-tokens-start! ls (+ change-length (lexer-state-invalid-tokens-start ls)))
(set-lexer-state-current-pos! ls (+ (lexer-state-start-pos ls) tok-start))))))
(define/private (do-insert/delete edit-start-pos change-length) (define/private (do-insert/delete edit-start-pos change-length)
(unless (or stopped? force-stop?) (unless (or stopped? force-stop?)
(unless up-to-date? (let ([ls (find-ls edit-start-pos)])
(sync-invalid)) (when ls
(cond (do-insert/delete/ls ls edit-start-pos change-length)))))
(up-to-date?
(let-values ([(orig-token-start orig-token-end valid-tree invalid-tree) (define/private (do-insert/delete-all)
(send tokens split edit-start-pos)]) (for-each (lambda (ls)
(send parens split-tree orig-token-start) (do-insert/delete/ls ls (lexer-state-start-pos ls) 0))
(set! invalid-tokens invalid-tree) lexer-states))
(set! tokens valid-tree)
(set! invalid-tokens-start
(if (send invalid-tokens is-empty?)
+inf.0
(+ orig-token-end change-length)))
(set! current-pos orig-token-start)
(set! up-to-date? #f)
(queue-callback (λ () (colorer-callback)) #f)))
((>= edit-start-pos invalid-tokens-start)
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send invalid-tokens split edit-start-pos)))
(set! invalid-tokens invalid-tree)
(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
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send tokens split edit-start-pos)))
(send parens truncate tok-start)
(set! tokens valid-tree)
(set! invalid-tokens-start (+ change-length invalid-tokens-start))
(set! current-pos tok-start))))))
(inherit is-locked? get-revision-number) (inherit is-locked? get-revision-number)
(define/private (colorer-driver) (define/private (colorer-driver)
(unless up-to-date? (unless (andmap lexer-state-up-to-date? lexer-states)
#;(printf "revision ~a~n" (get-revision-number)) #;(printf "revision ~a~n" (get-revision-number))
(unless (and tok-cor (= rev (get-revision-number))) (unless (and tok-cor (= rev (get-revision-number)))
(when tok-cor (when tok-cor
@ -354,7 +363,16 @@ added get-regions
(coroutine (coroutine
(λ (enable-suspend) (λ (enable-suspend)
(parameterize ((port-count-lines-enabled #t)) (parameterize ((port-count-lines-enabled #t))
(re-tokenize current-pos enable-suspend))))) (for-each
(lambda (ls)
(re-tokenize ls
(open-input-text-editor this
(lexer-state-current-pos ls)
(lexer-state-end-pos ls)
(λ (x) #f))
(lexer-state-current-pos ls)
enable-suspend))
lexer-states)))))
(set! rev (get-revision-number))) (set! rev (get-revision-number)))
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(λ (exn) (λ (exn)
@ -365,7 +383,9 @@ added get-regions
(set! tok-cor #f)))) (set! tok-cor #f))))
#;(printf "begin lexing~n") #;(printf "begin lexing~n")
(when (coroutine-run 10 tok-cor) (when (coroutine-run 10 tok-cor)
(set! up-to-date? #t))) (for-each (lambda (ls)
(set-lexer-state-up-to-date?! ls #t))
lexer-states)))
#;(printf "end lexing~n") #;(printf "end lexing~n")
#;(printf "begin coloring~n") #;(printf "begin coloring~n")
;; This edit sequence needs to happen even when colors is null ;; This edit sequence needs to happen even when colors is null
@ -382,14 +402,14 @@ added get-regions
(else (else
(unless (in-edit-sequence?) (unless (in-edit-sequence?)
(colorer-driver)) (colorer-driver))
(unless up-to-date? (unless (andmap lexer-state-up-to-date? lexer-states)
(queue-callback (λ () (colorer-callback)) #f))))) (queue-callback (λ () (colorer-callback)) #f)))))
;; Must not be called when the editor is locked ;; Must not be called when the editor is locked
(define/private (finish-now) (define/private (finish-now)
(unless stopped? (unless stopped?
(let loop () (let loop ()
(unless up-to-date? (unless (andmap lexer-state-up-to-date? lexer-states)
(colorer-driver) (colorer-driver)
(loop))))) (loop)))))
@ -402,9 +422,12 @@ added get-regions
(set! token-sym->style token-sym->style-) (set! token-sym->style token-sym->style-)
(set! get-token get-token-) (set! get-token get-token-)
(set! pairs pairs-) (set! pairs pairs-)
(set! parens (new paren-tree% (matches pairs))) (for-each
(lambda (ls)
(set-lexer-state-parens! ls (new paren-tree% (matches pairs))))
lexer-states)
;; (set! timer (current-milliseconds)) ;; (set! timer (current-milliseconds))
(do-insert/delete 0 0))) (do-insert/delete-all)))
;; See docs ;; See docs
(define/public stop-colorer (define/public stop-colorer
@ -421,9 +444,12 @@ added get-regions
(define/private (clear-colors) (define/private (clear-colors)
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(for-each (for-each
(λ (start/end) (λ (ls)
(change-style (get-fixed-style) (list-ref start/end 0) (list-ref start/end 1) #f)) (change-style (get-fixed-style)
regions) (lexer-state-start-pos ls)
(lexer-state-end-pos ls)
#f))
lexer-states)
(end-edit-sequence)) (end-edit-sequence))
(define/public (is-frozen?) frozen?) (define/public (is-frozen?) frozen?)
@ -457,14 +483,19 @@ added get-regions
(else (else
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(finish-now) (finish-now)
(for-each
(lambda (ls)
(let ([tokens (lexer-state-tokens ls)]
[start-pos (lexer-state-start-pos ls)])
(send tokens for-each (send tokens for-each
(λ (start len type) (λ (start len type)
(when (and should-color? (should-color-type? type)) (when (and should-color? (should-color-type? type))
(let ((color (send (get-style-list) find-named-style (let ((color (send (get-style-list) find-named-style
(token-sym->style type))) (token-sym->style type)))
(sp start) (sp (+ start-pos start))
(ep (+ start len))) (ep (+ start-pos (+ start len))))
(change-style color sp ep #f))))) (change-style color sp ep #f)))))))
lexer-states)
(end-edit-sequence)))))))) (end-edit-sequence))))))))
@ -476,7 +507,7 @@ added get-regions
((and (not should-color?) on?) ((and (not should-color?) on?)
(set! should-color? on?) (set! should-color? on?)
(reset-tokens) (reset-tokens)
(do-insert/delete 0 0)) (do-insert/delete-all))
((and should-color? (not on?)) ((and should-color? (not on?))
(set! should-color? on?) (set! should-color? on?)
(clear-colors)))) (clear-colors))))
@ -495,20 +526,14 @@ added get-regions
(define mismatch-color (make-object color% "PINK")) (define mismatch-color (make-object color% "PINK"))
(define/private (get-match-color) (preferences:get 'framework:paren-match-color)) (define/private (get-match-color) (preferences:get 'framework:paren-match-color))
;; higlight : number number number (or/c color any) (define/private (highlight ls start end caret-pos error?)
;; if color is a color, then it uses that color to higlight (let* ([start-pos (lexer-state-start-pos ls)]
;; Otherwise, it treats it like a boolean, where a true value [off (highlight-range (+ start-pos start) (+ start-pos end)
;; means the normal paren color and #f means an error color. (if error? mismatch-color (get-match-color))
;; numbers are expected to have zero be start-pos.
(define/private (highlight start end caret-pos color)
(let ([off (highlight-range start end
(if (is-a? color color%)
color
(if color mismatch-color (get-match-color)))
(and (send (icon:get-paren-highlight-bitmap) (and (send (icon:get-paren-highlight-bitmap)
ok?) ok?)
(icon:get-paren-highlight-bitmap)) (icon:get-paren-highlight-bitmap))
(= caret-pos start))]) (= caret-pos (+ start-pos start)))])
(set! clear-old-locations (set! clear-old-locations
(let ([old clear-old-locations]) (let ([old clear-old-locations])
(λ () (λ ()
@ -519,8 +544,11 @@ added get-regions
;; the forward matcher signaled an error because not enough of the ;; the forward matcher signaled an error because not enough of the
;; tree has been built. ;; tree has been built.
(define/private (f-match-false-error start end error) (define/private (f-match-false-error ls start end error)
(and error (<= error current-pos) (not up-to-date?))) (and error
(<= (+ (lexer-state-start-pos ls) error)
(lexer-state-current-pos ls))
(not (lexer-state-up-to-date? ls))))
;; If there is no match because the buffer isn't lexed far enough yet, ;; If there is no match because the buffer isn't lexed far enough yet,
@ -539,7 +567,9 @@ added get-regions
;; background thread is going slows it down. ;; background thread is going slows it down.
;; The random number slows down how often it ;; The random number slows down how often it
;; tries. ;; tries.
(or just-clear? up-to-date? (= 0 (random 5)))) (or just-clear?
(andmap lexer-state-up-to-date? lexer-states)
(= 0 (random 5))))
(set! in-match-parens? #t) (set! in-match-parens? #t)
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(clear-old-locations) (clear-old-locations)
@ -548,49 +578,22 @@ added get-regions
(not just-clear?)) (not just-clear?))
(let* ((here (get-start-position))) (let* ((here (get-start-position)))
(when (= here (get-end-position)) (when (= here (get-end-position))
(let ([ls (find-ls here)])
(when ls
(let-values (((start-f end-f error-f) (let-values (((start-f end-f error-f)
(send parens match-forward here))) (send (lexer-state-parens ls) match-forward
(when (and (not (f-match-false-error start-f end-f error-f)) (- here (lexer-state-start-pos ls)))))
(when (and (not (f-match-false-error ls start-f end-f error-f))
start-f end-f) start-f end-f)
(if error-f (highlight ls start-f end-f here error-f)))
(highlight start-f end-f here error-f)
(highlight-nested-region start-f end-f here))))
(let-values (((start-b end-b error-b) (let-values (((start-b end-b error-b)
(send parens match-backward here))) (send (lexer-state-parens ls) match-backward
(- here (lexer-state-start-pos ls)))))
(when (and start-b end-b) (when (and start-b end-b)
(if error-b (highlight ls start-b end-b here error-b))))))))
(highlight start-b end-b here error-b)
(highlight-nested-region start-b end-b here)))))))
(end-edit-sequence) (end-edit-sequence)
(set! in-match-parens? #f)))) (set! in-match-parens? #f))))
;; highlight-nested-region : number number number -> void
;; colors nested regions of parentheses.
(define/private (highlight-nested-region orig-start orig-end here)
(let paren-loop ([start orig-start]
[end orig-end]
[depth 0])
(when (< depth (vector-length (get-parenthesis-colors)))
;; when there is at least one more color in the vector we'll look
;; for regions to color at that next level
(when (< (+ depth 1) (vector-length (get-parenthesis-colors)))
(let seq-loop ([inner-sequence-start (+ start 1)])
(when (< inner-sequence-start end)
(let ([post-whitespace (skip-whitespace inner-sequence-start 'forward #t)])
(let-values ([(start-inner end-inner error-inner)
(send parens match-forward post-whitespace)])
(cond
[(and start-inner end-inner (not error-inner))
(paren-loop start-inner end-inner (+ depth 1))
(seq-loop end-inner)]
[(skip-past-token post-whitespace)
=>
(λ (after-non-paren-thing)
(seq-loop after-non-paren-thing))]))))))
(highlight start end here (vector-ref (get-parenthesis-colors) depth)))))
;; See docs ;; See docs
(define/public (forward-match position cutoff) (define/public (forward-match position cutoff)
(do-forward-match position cutoff #t)) (do-forward-match position cutoff #t))
@ -600,46 +603,36 @@ added get-regions
(if skip-whitespace? (if skip-whitespace?
(skip-whitespace position 'forward #t) (skip-whitespace position 'forward #t)
position))) position)))
(let ([ls (find-ls position)])
(and
ls
(let-values (((start end error) (let-values (((start end error)
(send parens match-forward position))) (send (lexer-state-parens ls) match-forward
(- position (lexer-state-start-pos ls)))))
(cond (cond
((f-match-false-error start end error) ((f-match-false-error ls start end error)
(colorer-driver) (colorer-driver)
(do-forward-match position cutoff #f)) (do-forward-match position cutoff #f))
((and start end (not error)) ((and start end (not error))
(let ((match-pos (+ (lexer-state-start-pos ls) end)))
(cond (cond
((<= end cutoff) end) ((<= match-pos cutoff) match-pos)
(else #f))) (else #f))))
((and start end error) #f) ((and start end error) #f)
(else (else
(skip-past-token position)
#;
(let-values (((tok-start tok-end) (let-values (((tok-start tok-end)
(begin (begin
(tokenize-to-pos position) (tokenize-to-pos ls position)
(send tokens search! (- position start-pos)) (send (lexer-state-tokens ls) search!
(values (send tokens get-root-start-position) (- position (lexer-state-start-pos ls)))
(send tokens get-root-end-position))))) (values (send (lexer-state-tokens ls) get-root-start-position)
(send (lexer-state-tokens ls) get-root-end-position)))))
(cond (cond
((or (send parens is-close-pos? tok-start) ((or (send (lexer-state-parens ls) is-close-pos? tok-start)
(= (+ start-pos tok-end) position)) (= (+ (lexer-state-start-pos ls) tok-end) position))
#f) #f)
(else (else
(+ start-pos tok-end))))))))) (+ (lexer-state-start-pos ls) tok-end)))))))))))
(define/private (skip-past-token position)
(let-values (((tok-start tok-end)
(begin
(tokenize-to-pos position)
(send tokens search! position)
(values (send tokens get-root-start-position)
(send tokens get-root-end-position)))))
(cond
((or (send parens is-close-pos? tok-start)
(= tok-end position))
#f)
(else
tok-end))))
;; See docs ;; See docs
@ -652,12 +645,16 @@ added get-regions
(define/private (internal-backward-match position cutoff) (define/private (internal-backward-match position cutoff)
(when stopped? (when stopped?
(error 'backward-match "called on a color:text<%> whose colorer is stopped.")) (error 'backward-match "called on a color:text<%> whose colorer is stopped."))
(let ((position (skip-whitespace position 'backward #t))) (let* ([position (skip-whitespace position 'backward #t)]
[ls (find-ls position)]
[start-pos (and ls (lexer-state-start-pos ls))])
(and
ls
(let-values (((start end error) (let-values (((start end error)
(send parens match-backward position))) (send (lexer-state-parens ls) match-backward (- position start-pos))))
(cond (cond
((and start end (not error)) ((and start end (not error))
(let ((match-pos start)) (let ((match-pos (+ start-pos start)))
(cond (cond
((>= match-pos cutoff) match-pos) ((>= match-pos cutoff) match-pos)
(else #f)))) (else #f))))
@ -665,18 +662,18 @@ added get-regions
(else (else
(let-values (((tok-start tok-end) (let-values (((tok-start tok-end)
(begin (begin
(send tokens search! (send (lexer-state-tokens ls) search!
(if (> position 0) (if (> position start-pos)
(- position 1) (- position start-pos 1)
0)) 0))
(values (send tokens get-root-start-position) (values (send (lexer-state-tokens ls) get-root-start-position)
(send tokens get-root-end-position))))) (send (lexer-state-tokens ls) get-root-end-position)))))
(cond (cond
((or (send parens is-open-pos? tok-start) ((or (send (lexer-state-parens ls) is-open-pos? tok-start)
(= tok-start position)) (= (+ start-pos tok-start) position))
'open) 'open)
(else (else
tok-start)))))))) (+ start-pos tok-start))))))))))
;; See docs ;; See docs
(define/public (backward-containing-sexp position cutoff) (define/public (backward-containing-sexp position cutoff)
@ -693,47 +690,49 @@ added get-regions
(define/public (classify-position position) (define/public (classify-position position)
(when stopped? (when stopped?
(error 'classify-position "called on a color:text<%> whose colorer is stopped.")) (error 'classify-position "called on a color:text<%> whose colorer is stopped."))
(tokenize-to-pos position) (let ([ls (find-ls position)])
(send tokens search! position) (and ls
(send tokens get-root-data)) (let ([tokens (lexer-state-tokens ls)])
(tokenize-to-pos ls position)
(send tokens search! (- position (lexer-state-start-pos ls)))
(send tokens get-root-data)))))
(define/private (tokenize-to-pos position) (define/private (tokenize-to-pos ls position)
(when (and (not up-to-date?) (<= current-pos position)) (when (and (not (lexer-state-up-to-date? ls))
(<= (lexer-state-current-pos ls) position))
(colorer-driver) (colorer-driver)
(tokenize-to-pos position))) (tokenize-to-pos ls position)))
;; See docs ;; See docs
(define/public (skip-whitespace position direction comments?) (define/public (skip-whitespace position direction comments?)
(when stopped? (when stopped?
(error 'skip-whitespace "called on a color:text<%> whose colorer is stopped.")) (error 'skip-whitespace "called on a color:text<%> whose colorer is stopped."))
(cond (let ([ls (find-ls position)])
[(and (eq? direction 'forward) (if (not ls)
(= position (last-position)))
position]
[(and (eq? direction 'backward) (= position 0))
position]
[(not (in-colored-region? position))
position]
[else
(tokenize-to-pos position)
(send tokens search! (if (eq? direction 'backward) (sub1 position) position))
(cond
[(or (eq? 'white-space (send tokens get-root-data))
(and comments? (eq? 'comment (send tokens get-root-data))))
(skip-whitespace (if (eq? direction 'forward)
(send tokens get-root-end-position)
(send tokens get-root-start-position))
direction
comments?)]
[else position])]))
(define/private (in-colored-region? position)
(ormap (λ (start/end) (<= (list-ref start/end 0)
position position
(if (eq? 'end (list-ref start/end 1)) (let ([start-pos (lexer-state-start-pos ls)]
(last-position) [end-pos (lexer-state-end-pos ls)]
(list-ref start/end 1)))) [tokens (lexer-state-tokens ls)])
regions)) (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
(tokenize-to-pos ls position)
(send tokens search! (- (if (eq? direction 'backward) (sub1 position) position)
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
comments?))
(else position))))))))
(define/private (get-close-paren pos closers) (define/private (get-close-paren pos closers)
(cond (cond
@ -741,17 +740,21 @@ added get-regions
(else (else
(let* ((c (car closers)) (let* ((c (car closers))
(l (string-length c))) (l (string-length c)))
(let ([ls (find-ls pos)])
(if ls
(let ([start-pos (lexer-state-start-pos ls)])
(insert c pos) (insert c pos)
(let ((m (backward-match (+ l pos) 0))) (let ((m (backward-match (+ l pos) start-pos)))
(cond (cond
((and m ((and m
(send parens is-open-pos? m) (send (lexer-state-parens ls) is-open-pos? (- m start-pos))
(send parens is-close-pos? pos)) (send (lexer-state-parens ls) is-close-pos? (- pos start-pos)))
(delete pos (+ l pos)) (delete pos (+ l pos))
c) c)
(else (else
(delete pos (+ l pos)) (delete pos (+ l pos))
(get-close-paren pos (cdr closers))))))))) (get-close-paren pos (cdr closers))))))
c))))))
(inherit insert delete flash-on on-default-char) (inherit insert delete flash-on on-default-char)
;; See docs ;; See docs
@ -768,21 +771,31 @@ added get-regions
(when flash? (when flash?
(unless stopped? (unless stopped?
(let ((to-pos (backward-match (+ (string-length insert-str) pos) 0))) (let ((to-pos (backward-match (+ (string-length insert-str) pos) 0)))
(when (and to-pos (when to-pos
(send parens is-open-pos? to-pos) (let ([ls (find-ls to-pos)])
(send parens is-close-pos? pos)) (when ls
(flash-on to-pos (+ 1 to-pos))))))))) (let ([start-pos (lexer-state-start-pos ls)]
[parens (lexer-state-parens ls)])
(when (and (send parens is-open-pos? (- to-pos start-pos))
(send parens is-close-pos? (- pos start-pos)))
(flash-on to-pos (+ 1 to-pos)))))))))))))
(define/public (debug-printout) (define/public (debug-printout)
(for-each
(lambda (ls)
(let* ((x null) (let* ((x null)
(f (λ (a b c) (set! x (cons (list a b c) x))))) (f (λ (a b c) (set! x (cons (list a b c) x)))))
(send tokens for-each f) (send (lexer-state-tokens ls) for-each f)
(printf "tokens: ~e~n" (reverse x)) (printf "tokens: ~e~n" (reverse x))
(set! x null) (set! x null)
(send invalid-tokens for-each f) (send (lexer-state-invalid-tokens ls) for-each f)
(printf "invalid-tokens: ~e~n" (reverse x)) (printf "invalid-tokens: ~e~n" (reverse x))
(printf "current-pos: ~a invalid-tokens-start ~a~n" current-pos invalid-tokens-start) (printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n"
(printf "parens: ~e~n" (car (send parens test))))) (lexer-state-start-pos ls)
(lexer-state-current-pos ls)
(lexer-state-invalid-tokens-start ls))
(printf "parens: ~e~n" (car (send (lexer-state-parens ls) test)))))
lexer-states))
;; ------------------------- Callbacks to Override ---------------------- ;; ------------------------- Callbacks to Override ----------------------