add set-get-token to color:text-mode<%>

gui-doc/scribblings/framework/color.scrbl

@@ -376,7 +376,15 @@
 
 @defclass[color:text% (color:text-mixin text:keymap%) ()]{}
 
-@definterface[color:text-mode<%> ()]{}
+@definterface[color:text-mode<%> ()]{
+ @defmethod[(set-get-token [get-token procedure?]) void?]{
+  Sets the @racket[get-token] function used to color the contents
+  of the editor.
+
+  See @method[color:text<%> start-colorer]'s @racket[get-token] argument
+  for the contract on this method's @racket[get-token] argument.
+ }
+}
 
 @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{
   This mixin adds coloring functionality to the mode.

gui-lib/framework/private/color.rkt

@@ -264,13 +264,13 @@ added get-regions
         (spell-checking-values-changed)))
     (define/private (spell-checking-values-changed)
       (reset-tokens)
-      (start-colorer token-sym->style get-token pairs))
+      (_start-colorer token-sym->style get-token pairs))
     (define current-dict (preferences:get 'framework:aspell-dict))
     (define/public (set-spell-current-dict d)
       (unless (equal? d current-dict)
         (set! current-dict d)
         (reset-tokens)
-        (start-colorer token-sym->style get-token pairs)))
+        (_start-colorer token-sym->style get-token pairs)))
     (define/public (get-spell-current-dict) current-dict)
     
     ;; ---------------------- Multi-threading ---------------------------
@@ -609,7 +609,7 @@ added get-regions
             (loop)))))
     
     ;; See docs
-    (define/public (start-colorer token-sym->style- get-token- pairs-)
+    (define/private (_start-colorer token-sym->style- get-token- pairs-)
       (unless force-stop?
         (set! stopped? #f)
         (reset-tokens)
@@ -631,6 +631,9 @@ added get-regions
         ;; (set! timer (current-milliseconds))
         (do-insert/delete-all)))
 
+    (define/public (start-colorer token-sym->style- get-token- pairs-)
+      (_start-colorer token-sym->style- get-token- pairs-))
+    
     ;; See docs
     (define/public stop-colorer
       (lambda ((clear-the-colors #t))
@@ -681,7 +684,7 @@ added get-regions
                       (gt get-token)
                       (p pairs))
                   (stop-colorer (not should-color?))
-                  (start-colorer tn gt p)))
+                  (_start-colorer tn gt p)))
                (else
                 (begin-edit-sequence #f #f)
                 (finish-now)
@@ -1319,7 +1322,7 @@ added get-regions
 
 (define -text% (text-mixin text:keymap%))
 
-(define -text-mode<%> (interface ()))
+(define -text-mode<%> (interface () set-get-token))
 
 (define text-mode-mixin
   (mixin (mode:surrogate-text<%>) (-text-mode<%>)
@@ -1337,6 +1340,9 @@ added get-regions
       (super on-enable-surrogate text)
       (send text start-colorer token-sym->style get-token matches))
 
+    (define/public (set-get-token _get-token)
+      (set! get-token _get-token))
+    
     (super-new)))
 
 (define text-mode% (text-mode-mixin mode:surrogate-text%))

gui-lib/framework/private/racket.rkt

@@ -1353,16 +1353,6 @@
     (preferences:add-callback
      'framework:tabify
      (lambda (k v) (set! tabify-pref v)))
-    (define/private (racket-lexer-wrapper in offset mode)
-      (define-values (lexeme type paren start end backup-delta new-mode) 
-        (module-lexer/waived in offset mode))
-      (cond
-        [(and (eq? type 'symbol)
-              (string? lexeme)
-              (get-head-sexp-type-from-prefs lexeme tabify-pref))
-         (values lexeme 'keyword paren start end backup-delta new-mode)]
-        [else
-         (values lexeme type paren start end backup-delta new-mode)]))
     
     (define/override (put-file text sup directory default-name)
       ;; don't call the surrogate's super, since it sets the default extension
@@ -1372,12 +1362,41 @@
            (sup directory default-name))]
         [else (sup directory default-name)]))
 
-    (super-new (get-token (lambda (in offset mode) (racket-lexer-wrapper in offset mode)))
+    (define/override (set-get-token get-token-)
+      (super set-get-token (wrap-get-token get-token- (λ () tabify-pref))))
+
+    (super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref)))
                (token-sym->style short-sym->style-name)
                (matches '((|(| |)|)
                           (|[| |]|)
                           (|{| |}|))))))
 
+(define (wrap-get-token get-token- get-tabify-pref)
+  (define wrapped-get-token
+    (cond
+      [(procedure-arity-includes? get-token- 3)
+       (λ (in offset mode)
+         (define-values (lexeme type paren start end backup-delta new-mode)
+           (get-token- in offset mode))
+         (cond
+           [(and (eq? type 'symbol)
+                 (string? lexeme)
+                 (get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
+            (values lexeme 'keyword paren start end backup-delta new-mode)]
+           [else
+            (values lexeme type paren start end backup-delta new-mode)]))]
+      [else
+       (λ (in)
+         (define-values (lexeme type paren start end) (get-token- in))
+         (cond
+           [(and (eq? type 'symbol)
+                 (string? lexeme)
+                 (get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
+            (values lexeme 'keyword paren start end)]
+           [else
+            (values lexeme type paren start end)]))]))
+  wrapped-get-token)
+
 ;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp)
 ;;                              -> (or/c #f 'lambda 'define 'begin 'for/fold)
 (define (get-head-sexp-type-from-prefs text pref)