diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 81906dad..7cce598b 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -107,17 +107,15 @@ (send bold-check set-value (eq? (send style get-weight) 'bold)) (send underline-check set-value (send style get-underlined)))) - (define add/mult-set - (lambda (m v) - (send m set (car v) (cadr v) (caddr v)))) + (define (add/mult-set m v) + (send m set (car v) (cadr v) (caddr v))) - (define add/mult-get - (lambda (m) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)]) - (send m get b1 b2 b3) - (map unbox (list b1 b2 b3))))) + (define (add/mult-get m) + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)]) + (send m get b1 b2 b3) + (map unbox (list b1 b2 b3)))) (define style-delta-get/set (list (cons (lambda (x) (send x get-alignment-off)) @@ -166,22 +164,19 @@ sym code-style (lambda (x) - (is-a? x style-delta%))) - (preferences:set-un/marshall sym marshall-style unmarshall-style)) - + (is-a? x style-delta%)))) ; a symbol naming the style and a delta to set it to - (define set-slatex-style - (lambda (sym delta) - (let* ([style-list (editor:get-standard-style-list)] - [name (symbol->string sym)] - [style (send style-list find-named-style name)]) - (if style - (send style set-delta delta) - (send style-list new-named-style name - (send style-list find-or-create-style - (send style-list find-named-style "Standard") - delta)))))) + (define (set-slatex-style sym delta) + (let* ([style-list (editor:get-standard-style-list)] + [name (symbol->string sym)] + [style (send style-list find-named-style name)]) + (if style + (send style set-delta delta) + (send style-list new-named-style name + (send style-list find-or-create-style + (send style-list find-named-style "Standard") + delta))))) (define (make-style-delta color bold? underline? italic?) @@ -221,11 +216,14 @@ (define (add tab-name symbols/defaults) (let* ((prefix (string->symbol (format "syntax-coloring:~a" tab-name))) - (active-pref (string->symbol (format "~a:active" prefix)))) + (active-pref (string->symbol (format "~a:active" prefix))) + (syms (map (lambda (s/d) (string->symbol (format "~a:~a" prefix (car s/d)))) + symbols/defaults))) + (for-each set-default syms (map cadr symbols/defaults)) (for-each (lambda (s) - (set-default (string->symbol (format "~a:~a" prefix (car s))) - (cadr s))) - symbols/defaults) + (preferences:set-un/marshall s marshall-style unmarshall-style)) + syms) + (for-each set-slatex-style syms (map preferences:get syms)) (preferences:set-default active-pref #t (lambda (x) #t)) (preferences:add-panel `("Editing" "Colors" ,tab-name) (lambda (p) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 8227e112..2a656e70 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -139,15 +139,17 @@ (set! current-pos (+ len current-pos)) (sync-invalid) (when (and should-color? (not (eq? 'white-space type))) - (set! colors (cons - (let ((color (preferences:get (string->symbol (format "syntax-coloring:~a:~a" - prefix - type)))) - (sp (+ in-start-pos (sub1 new-token-start))) - (ep (+ in-start-pos (sub1 new-token-end)))) - (lambda () - (change-style color sp ep #f))) - colors))) + (set! colors + (cons + (let ((color (send (get-style-list) find-named-style + (format "syntax-coloring:~a:~a" + prefix + type))) + (sp (+ in-start-pos (sub1 new-token-start))) + (ep (+ in-start-pos (sub1 new-token-end)))) + (lambda () + (change-style color sp ep #f))) + colors))) (insert-last! tokens (new token-tree% (length len) (data data))) (send parens add-token data len) (cond diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index defd249d..b5b94337 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -16,7 +16,8 @@ [exit : framework:exit^] [group : framework:group^] [handler : framework:handler^] - [editor : framework:editor^]) + [editor : framework:editor^] + [color-prefs : framework:color-prefs^]) (application-preferences-handler (lambda () (preferences:show-dialog))) @@ -215,4 +216,16 @@ (preferences:set 'framework:file-dialogs 'std) (preferences:set 'framework:exit-when-no-frames #t) + ;; This adds the preferences that scheme:text% needs for coloring + (color-prefs:add + "Scheme Color" + `((keyword ,(color-prefs:make-style-delta "Black" #f #f #f)) + (string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f)) + (literal ,(color-prefs:make-style-delta "ForestGreen" #f #f #f)) + (comment ,(color-prefs:make-style-delta "DimGray" #f #f #f)) + (error ,(color-prefs:make-style-delta "Red" #f #f #f)) + (identifier ,(color-prefs:make-style-delta "Navy" #f #f #f)) + (other ,(color-prefs:make-style-delta "brown" #f #f #f)))) + + (void)))) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 4b8fb6db..fa61dc07 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -40,17 +40,6 @@ [-text% text%]) - - (color-prefs:add - "Scheme Color" - `((keyword ,(color-prefs:make-style-delta "Black" #f #f #f)) - (string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f)) - (literal ,(color-prefs:make-style-delta "ForestGreen" #f #f #f)) - (comment ,(color-prefs:make-style-delta "DimGray" #f #f #f)) - (error ,(color-prefs:make-style-delta "Red" #f #f #f)) - (identifier ,(color-prefs:make-style-delta "Navy" #f #f #f)) - (other ,(color-prefs:make-style-delta "brown" #f #f #f)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Sexp Snip ;;