From db4efcea84a2ae74e418519c2d849b14e5f32d6f Mon Sep 17 00:00:00 2001 From: Joel Dueck Date: Tue, 20 Oct 2026 11:38:07 -0500 Subject: [PATCH] fix colorer handling of nonzero lexer backup deltas When the token containing an edit has a nonzero backup delta, split-backward backs up over earlier tokens, but it returned the end and mode of the earliest token it removed while keeping the invalid tree that begins after the first token it removed. The colorer then treated the kept tokens as starting too early, so its stop check could splice them in at the wrong position. Also, at a token boundary split/data removes the token ending at the edit but reports only the later token's data, so the earlier token's backup delta was ignored. Fixes #376 Co-Authored-By: Claude Opus 5.5 (1M context) --- gui-lib/framework/private/color.rkt | 23 ++++--- gui-test/framework/tests/color-text.rkt | 81 +++++++++++++++++++++++++ 2 files changed, 94 insertions(+), 10 deletions(-) diff --git a/gui-lib/framework/private/color.rkt b/gui-lib/framework/private/color.rkt index cb2cefaf5..4a1ba4849 100644 --- a/gui-lib/framework/private/color.rkt +++ b/gui-lib/framework/private/color.rkt @@ -554,16 +554,19 @@ added get-regions (loop s))))) (define/private (split-backward ls valid-tree pos) - (let loop ([pos pos][valid-tree valid-tree][old-invalid-tree #f]) - (let-values (((orig-token-start orig-token-end valid-tree invalid-tree orig-data) - (send valid-tree split/data (- pos (lexer-state-start-pos ls))))) - (let ([backup-pos (- pos (data-backup-delta orig-data))] - [invalid-tree (or old-invalid-tree invalid-tree)]) - (if (backup-pos . < . pos) - ;; back up more: - (loop pos valid-tree invalid-tree) - ;; that was far enough: - (values orig-token-start orig-token-end valid-tree invalid-tree orig-data)))))) + (define rel (- pos (lexer-state-start-pos ls))) + (define ending-data + (and (positive? rel) + (not (send valid-tree is-empty?)) + (begin (send valid-tree search! (sub1 rel)) + (and (= rel (send valid-tree get-root-end-position)) + (send valid-tree get-root-data))))) + (define-values (start end valid invalid data) (send valid-tree split/data rel)) + (let loop ([start start] [valid valid] [earliest-data (or ending-data data)]) + (if (positive? (data-backup-delta earliest-data)) + (let-values ([(start _end valid _invalid earliest-data) (send valid split/data rel)]) + (loop start valid earliest-data)) + (values start end valid invalid data)))) (define/private (do-insert/delete/ls ls edit-start-pos edit-end-pos change-length) (unless (lexer-state-up-to-date? ls) diff --git a/gui-test/framework/tests/color-text.rkt b/gui-test/framework/tests/color-text.rkt index 735770ab3..af4a72d41 100644 --- a/gui-test/framework/tests/color-text.rkt +++ b/gui-test/framework/tests/color-text.rkt @@ -319,3 +319,84 @@ (check-equal? (send t get-matching-paren-string "} ") #f) (check-equal? (send t get-matching-paren-string "") #f) (check-equal? (send t get-matching-paren-string "abc") #f)) + +;; a change with old tokens after it, using a backup +(let () + (define t (new color:text%)) + (send t insert "aaabcaaabc") + (start-backing-up-colorer t) + (send t freeze-colorer) + (send t thaw-colorer) + (send t insert "a" 4 4) + (send t freeze-colorer) + (send t thaw-colorer) + + (check-equal? (get-colors t) + '((symbol 0 1) + (parenthesis 1 2) + (symbol 2 3) + (constant 3 4) + (symbol 4 7) + (parenthesis 7 8) + (constant 8 9) + (no-color 9 11)))) + +;; Tokenizes a line as a "..." string when it has a closing quote and as a +;; lone " error token otherwise, so each token's backup reaches back to the +;; start of its line. Line-ending whitespace has no backup. +(define (line-backup-lexer port offset mode) + (define-values (line col pos) (port-next-location port)) + (define (token type rx) + (define s (bytes->string/utf-8 (car (regexp-match rx port)))) + (values s type #f pos (+ pos (string-length s)) + (if (regexp-match? #rx"\n" s) 0 col) + 'line)) + (cond + [(eof-object? (peek-char port)) (values "eof" 'eof #f #f #f 0 mode)] + [(regexp-match-peek #rx"^\"[^\"\n]*\"" port) (token 'string #rx"^\"[^\"\n]*\"")] + [(regexp-match-peek #rx"^\"" port) (token 'error #rx"^\"")] + [(regexp-match-peek #rx"^[ \n]" port) (token 'white-space #rx"^[ \n]+")] + [else (token 'symbol #rx"^[^ \n\"]+")])) + +(define (start-line-backup-colorer t) + (send t start-colorer symbol->string line-backup-lexer '())) + +;; a change inside a token with a backup +(let () + (define t (new color:text%)) + (send t insert "x\naa bb cc\ndd\n") + (start-line-backup-colorer t) + (send t freeze-colorer) + (send t thaw-colorer) + (send t delete 6 7) + (send t freeze-colorer) + (send t thaw-colorer) + + (check-equal? (get-colors t) + '((symbol 0 1) + (white-space 1 2) + (symbol 2 4) + (white-space 4 5) + (symbol 5 6) + (white-space 6 7) + (symbol 7 9) + (white-space 9 10) + (symbol 10 12) + (white-space 12 13)))) + +;; a change at the end of a token with a backup +(let () + (define t (new color:text%)) + (send t insert "\" 1 2 3\nz\n") + (start-line-backup-colorer t) + (send t freeze-colorer) + (send t thaw-colorer) + (send t insert "\"" 7 7) + (send t freeze-colorer) + (send t thaw-colorer) + + (check-equal? (get-colors t) + '((string 0 8) + (white-space 8 9) + (symbol 9 10) + (white-space 10 11))))