fix colorer handling of nonzero lexer backup deltas

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)

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))))