diff --git a/gui-doc/scribblings/framework/color.scrbl b/gui-doc/scribblings/framework/color.scrbl index 92afeccf..16ba2377 100644 --- a/gui-doc/scribblings/framework/color.scrbl +++ b/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. diff --git a/gui-lib/framework/private/color.rkt b/gui-lib/framework/private/color.rkt index 5fa8a3e4..be11ae74 100644 --- a/gui-lib/framework/private/color.rkt +++ b/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) @@ -630,6 +630,9 @@ added get-regions lexer-states) ;; (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 @@ -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<%>) @@ -1336,6 +1339,9 @@ added get-regions (define/override (on-enable-surrogate text) (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))) diff --git a/gui-lib/framework/private/racket.rkt b/gui-lib/framework/private/racket.rkt index d2eba673..1844d4c7 100644 --- a/gui-lib/framework/private/racket.rkt +++ b/gui-lib/framework/private/racket.rkt @@ -475,7 +475,7 @@ position-location get-dc) (define private-racket-container-keymap (new keymap:aug-keymap%)) - (define/public (get-private-racket-container-keymap) private-racket-container-keymap) + (define/public (get-private-racket-container-keymap) private-racket-container-keymap) (define/override (get-keymaps) (editor:add-after-user-keymap private-racket-container-keymap @@ -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 @@ -1371,13 +1361,42 @@ (parameterize ([finder:default-extension "rkt"]) (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)