diff --git a/collects/framework/private/color-prefs.rkt b/collects/framework/private/color-prefs.rkt index 502642a848..27854ac338 100644 --- a/collects/framework/private/color-prefs.rkt +++ b/collects/framework/private/color-prefs.rkt @@ -341,6 +341,11 @@ (editor:get-default-color-style-name) (string-constant default-text-color)) + (build-text-foreground-selection-panel vp + 'framework:misspelled-text-color + color:misspelled-text-color-style-name + (string-constant misspelled-text-color)) + (let* ([choice (new choice% [label (string-constant parenthesis-color-scheme)] [parent vp] diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 9c852ef264..357de38c51 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -363,28 +363,32 @@ added get-regions (define color (send (get-style-list) find-named-style style-name)) (cond [(and spell-check-strings? (eq? type 'string)) - (define misspelled-color (send (get-style-list) find-named-style "Standard")) - (define strs (regexp-split #rx"\n" (get-text sp ep))) - (let loop ([strs strs] - [pos sp]) - (unless (null? strs) - (define str (car strs)) - (let loop ([spellos (query-aspell str)] - [lp 0]) - (cond - [(null? spellos) - (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) - colorings))] - [else - (define err (car spellos)) - (define err-start (list-ref err 0)) - (define err-len (list-ref err 1)) - (set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) - (vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) - colorings)) - (loop (cdr spellos) (+ err-start err-len))])) - (loop (cdr strs) - (+ pos (string-length str) 1))))] + (define misspelled-color (send (get-style-list) find-named-style misspelled-text-color-style-name)) + (cond + [misspelled-color + (define strs (regexp-split #rx"\n" (get-text sp ep))) + (let loop ([strs strs] + [pos sp]) + (unless (null? strs) + (define str (car strs)) + (let loop ([spellos (query-aspell str)] + [lp 0]) + (cond + [(null? spellos) + (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) + colorings))] + [else + (define err (car spellos)) + (define err-start (list-ref err 0)) + (define err-len (list-ref err 1)) + (set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) + (vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) + colorings)) + (loop (cdr spellos) (+ err-start err-len))])) + (loop (cdr strs) + (+ pos (string-length str) 1))))] + [else + (set! colorings (cons (vector color sp ep) colorings))])] [else (set! colorings (cons (vector color sp ep) colorings))])) @@ -1141,3 +1145,5 @@ added get-regions (super-new))) (define text-mode% (text-mode-mixin mode:surrogate-text%)) + +(define misspelled-text-color-style-name "Misspelled Text") diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index f91a6289dc..43b8ef7004 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -12,7 +12,8 @@ [prefix editor: framework:editor^] [prefix color-prefs: framework:color-prefs^] [prefix racket: framework:racket^] - [prefix early-init: framework:early-init^]) + [prefix early-init: framework:early-init^] + [prefix color: framework:color^]) (export framework:main^) (init-depend framework:preferences^ framework:exit^ framework:editor^ framework:color-prefs^ framework:racket^ framework:early-init^) @@ -371,10 +372,34 @@ (editor:set-default-font-color v))) (editor:set-default-font-color (preferences:get 'framework:default-text-color)) +(color-prefs:set-default/color-scheme 'framework:misspelled-text-color "black" "white") + (color-prefs:set-default/color-scheme 'framework:delegatee-overview-color "light blue" (make-object color% 62 67 155)) + +(let ([delta (make-object style-delta%)] + [style (send (editor:get-standard-style-list) find-named-style color:misspelled-text-color-style-name)]) + (if style + (send style set-delta delta) + (send (editor:get-standard-style-list) new-named-style color:misspelled-text-color-style-name + (send (editor:get-standard-style-list) find-or-create-style + (send (editor:get-standard-style-list) find-named-style "Standard") + delta)))) +(let ([update-style-list + (λ (v) + (define sl (editor:get-standard-style-list)) + (define style (send sl find-named-style color:misspelled-text-color-style-name)) + (define delta (new style-delta%)) + (send style get-delta delta) + (send delta set-delta-foreground v) + (send style set-delta delta))]) + (preferences:add-callback + 'framework:misspelled-text-color + (λ (p v) (update-style-list v))) + (update-style-list + (preferences:get 'framework:misspelled-text-color))) ;; groups diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 5cf1d3e333..e4f9511d94 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -400,7 +400,8 @@ text-mode-mixin text-mode%)) (define-signature color^ extends color-class^ - (get-parenthesis-colors-table)) + (get-parenthesis-colors-table + misspelled-text-color-style-name)) (define-signature color-prefs-class^ ()) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 2a8ea92a45..f7626e31e2 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1685,5 +1685,5 @@ please adhere to these guidelines: ;; menu item in the 'edit' menu; applies to editors with programs in them ;; (technically, editors that implement color:text<%>) (spell-check-string-constants "Spell Check String Constants") - + (misspelled-text-color "Misspelled Text Color") ;; in the preferences dialog )