added a something to the preferences pane to be able to pick the parenthesis color scheme

svn: r7885

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]

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)])])

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 parenthesis-color-table #f)
-  (define (get-parenthesis-colors)
+  (define (get-parenthesis-colors-table)
-    (unless parenthesis-colors
+    (unless parenthesis-color-table
-      (set! parenthesis-colors
+      (set! parenthesis-color-table
-            
+            (list
-            (vector (preferences:get 'framework:paren-match-color))
+             (list 'shades-of-gray  
-            
+                   (string-constant paren-color-shades-of-gray)
-            ;; shades of blue
+                   (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)
+                            153 153 255))
-            
+             (list 'spring
-            ;; shades of yellow (too pale)
+                   (string-constant paren-color-spring)
-            #;
-            (between 255 255 204
-                     255 255 153)
-            
-            ;; springtime
-            #;
                    (between 255 255 153
-                     204 255 153)
+                            204 255 153))
-            
+             (list 'fall
-            ;; fall
+                   (string-constant paren-color-fall)
-            #;
                    (between 255 204 153
-                     204 153 102)
+                            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) 
-            ;; shades of grey
+    (let ([choice (or (assoc (preferences:get 'framework:paren-color-scheme)
-            #;
+                             (get-parenthesis-colors-table))
-            (let ([size 4])
+                      (car (get-parenthesis-colors-table)))])
-              (build-vector
+      (caddr choice)))
-               4 
-               (lambda (x) 
-                 (let* ([grey-amount (floor (+ 180 (* 40 (/ x size))))])
-                   (make-object color% grey-amount grey-amount grey-amount)))))))
-    parenthesis-colors)
       
   (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)

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)

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^
     ())

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")