diff --git a/collects/drscheme/private/font.ss b/collects/drscheme/private/font.ss index 004a7511ad..0cb5979a4a 100644 --- a/collects/drscheme/private/font.ss +++ b/collects/drscheme/private/font.ss @@ -21,7 +21,7 @@ (define (setup-preferences) (preferences:add-panel (list (string-constant font-prefs-panel-title) - (string-constant drscheme)) + #;(string-constant drscheme)) ;; thre is no help desk font configuration anymore ... (λ (panel) (letrec ([main (make-object vertical-panel% panel)] [min-size 1] diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index f03ac6f5f5..4d2059b1df 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -9,7 +9,9 @@ (import [prefix preferences: framework:preferences^] [prefix editor: framework:editor^] [prefix panel: framework:panel^] - [prefix canvas: framework:canvas^]) + [prefix canvas: framework:canvas^] + [prefix scheme: framework:scheme^] + [prefix color: framework:color^]) (export framework:color-prefs^) (init-depend framework:editor^) @@ -290,11 +292,11 @@ (list (string-constant preferences-colors) (string-constant background-color)) (λ (parent) - (let ([vp (new vertical-panel% (parent parent))]) + (let ([vp (new vertical-panel% (parent parent) (alignment '(left top)))]) (add-solid-color-config (string-constant background-color) vp 'framework:basic-canvas-background) - (add-solid-color-config (string-constant paren-match-color) + (add-solid-color-config (string-constant basic-gray-paren-match-color) vp 'framework:paren-match-color) (build-text-foreground-selection-panel vp @@ -302,6 +304,27 @@ (editor:get-default-color-style-name) (string-constant default-text-color)) + (let* ([choice (new choice% + [label (string-constant parenthesis-color-scheme)] + [parent vp] + [choices (map (λ (x) (list-ref x 1)) + (color:get-parenthesis-colors-table))] + [callback + (λ (choice _) + (preferences:set 'framework:paren-color-scheme + (car (list-ref (color:get-parenthesis-colors-table) + (send choice get-selection)))))])] + [update-choice + (lambda (v) + (send choice set-string-selection + (cadr (or (assoc v (color:get-parenthesis-colors-table)) + (car (color:get-parenthesis-colors-table))))))]) + (preferences:add-callback + 'framework:paren-color-scheme + (λ (p v) + (update-choice v))) + (update-choice (preferences:get 'framework:paren-color-scheme))) + (let ([hp (new horizontal-panel% [parent vp] [alignment '(center top)])]) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 1eaebb0165..9cd797da09 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -6,6 +6,7 @@ (lib "token-tree.ss" "syntax-color") (lib "paren-tree.ss" "syntax-color") (lib "default-lexer.ss" "syntax-color") + string-constants/string-constant "../preferences.ss" "sig.ss") @@ -749,50 +750,48 @@ (define (pref-callback k v) (toggle-color v)) (preferences:add-callback 'framework:coloring-active pref-callback #t))) - (define parenthesis-colors #f) - (define (get-parenthesis-colors) - (unless parenthesis-colors - (set! parenthesis-colors - - (vector (preferences:get 'framework:paren-match-color)) - - ;; shades of blue - #; - (between 204 204 255 - 153 153 255) - - ;; shades of yellow (too pale) - #; - (between 255 255 204 - 255 255 153) - - ;; springtime - #; - (between 255 255 153 - 204 255 153) - - ;; fall - #; - (between 255 204 153 - 204 153 102) - - - ;; shades of grey - #; - (let ([size 4]) - (build-vector - 4 - (lambda (x) - (let* ([grey-amount (floor (+ 180 (* 40 (/ x size))))]) - (make-object color% grey-amount grey-amount grey-amount))))))) - parenthesis-colors) + (define parenthesis-color-table #f) + (define (get-parenthesis-colors-table) + (unless parenthesis-color-table + (set! parenthesis-color-table + (list + (list 'shades-of-gray + (string-constant paren-color-shades-of-gray) + (between 180 180 180 + 220 220 220)) + (list 'shades-of-blue + (string-constant paren-color-shades-of-blue) + (between 204 204 255 + 153 153 255)) + (list 'spring + (string-constant paren-color-spring) + (between 255 255 153 + 204 255 153)) + (list 'fall + (string-constant paren-color-fall) + (between 255 204 153 + 204 153 102)) + (list 'winter + (string-constant paren-color-winter) + (between 204 205 255 + 255 255 255))))) + (cons (list 'basic-grey + (string-constant paren-color-basic-grey) + (vector (preferences:get 'framework:paren-match-color))) + parenthesis-color-table)) + (define (get-parenthesis-colors) + (let ([choice (or (assoc (preferences:get 'framework:paren-color-scheme) + (get-parenthesis-colors-table)) + (car (get-parenthesis-colors-table)))]) + (caddr choice))) + (define (between start-r start-g start-b end-r end-g end-b) (let ([size 4]) (build-vector 4 (lambda (x) - (let ([between (λ (start end) (+ start (* (- end start) (/ x (- size 1)))))]) + (let ([between (λ (start end) (floor (+ start (* (- end start) (/ x (- size 1))))))]) (make-object color% (between start-r end-r) (between start-g end-g) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 066c765566..4eb80fc278 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -20,6 +20,8 @@ (application-preferences-handler (λ () (preferences:show-dialog))) + (preferences:set-default 'framework:paren-color-scheme 'basic-grey symbol?) + (preferences:set-default 'framework:square-bracket:cond/offset '(("case-lambda" 0) ("cond" 0) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index e77818c3bd..a7d7977136 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -365,7 +365,7 @@ text-mode-mixin text-mode%)) (define-signature color^ extends color-class^ - ()) + (get-parenthesis-colors-table)) (define-signature color-prefs-class^ ()) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index c50106b916..2aae10fb67 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -256,6 +256,16 @@ please adhere to these guidelines: (syntax-coloring-choose-color "Choose a color for ~a") (preferences-colors "Colors") ;; used in the preferences dialog + ;; parenthesis color scheme string constants + (parenthesis-color-scheme "Parenthesis color scheme") ;; label for the choice% menu in the preferences dialog + (paren-color-basic-grey "Basic grey") + (paren-color-shades-of-gray "Shades of grey") + (paren-color-shades-of-blue "Shades of blue") + (paren-color-spring "Spring") + (paren-color-fall "Fall") + (paren-color-winter "Winter") + + (url: "URL:") (open-url... "Open URL...") (open-url "Open URL") @@ -410,7 +420,7 @@ please adhere to these guidelines: (separate-dialog-for-searching "Use separate dialog for searching") (reuse-existing-frames "Reuse existing frames when opening new files") (default-fonts "Default Fonts") - (paren-match-color "Parenthesis highlight color") ; in prefs dialog + (basic-gray-paren-match-color "Basic gray parenthesis highlight color") ; in prefs dialog (online-coloring-active "Color syntax interactively") (open-files-in-tabs "Open files in separate tabs (not separate windows)") (show-interactions-on-execute "Automatically open interactions window when running a program")