From 436b0e7c3cde62362399f39742d25355167ce9aa Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 19 Apr 2007 15:15:23 +0000
Subject: [PATCH] improved color preferences; this is the change that requires
 people to rename their preferences as explained on plt-scheme

svn: r5996

original commit: e5698365c95ff97d34910efc59ef44c34362c772
---
 collects/framework/framework.ss           |   6 +-
 collects/framework/private/color-prefs.ss | 224 +++++++++++++++-------
 collects/framework/private/main.ss        |   9 +-
 collects/framework/private/scheme.ss      |   3 +-
 collects/framework/private/sig.ss         |   6 +-
 5 files changed, 171 insertions(+), 77 deletions(-)

diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss
index bc9d7af9..950af34a 100644
--- a/collects/framework/framework.ss
+++ b/collects/framework/framework.ss
@@ -1396,7 +1396,7 @@
      "@flink preferences:set-un/marshall"
      "with appropriate arguments to register the preference.")
     
-    (color-prefs:register-color-pref 
+    (color-prefs:register-color-preference 
      (opt->
       (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
       ((or/c string? (is-a?/c color%) false/c))
@@ -1461,12 +1461,12 @@
      "and \\var{example-text} is shown in the panel so users can see"
      "the results of their configuration.")
 
-    (color-prefs:marshall-style
+    (color-prefs:marshall-style-delta
      (-> (is-a?/c style-delta%) printable/c)
      (style-delta)
      "Builds a printed representation for a style-delta.")
     
-    (color-prefs:unmarshall-style
+    (color-prefs:unmarshall-style-delta
      (-> printable/c (or/c false/c (is-a?/c style-delta%)))
      (marshalled-style-delta)
      "Builds a style delta from its printed representation."
diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss
index d23a05d5..ca6f4e9b 100644
--- a/collects/framework/private/color-prefs.ss
+++ b/collects/framework/private/color-prefs.ss
@@ -27,10 +27,11 @@
                     (let ([delta (preferences:get pref-sym)])
                       (func delta)
                       (preferences:set pref-sym delta)))])
-      (define hp (new horizontal-panel% 
-                      (parent parent)
-                      (style '(border))
-                      (stretchable-height #f)))
+      (define hp (new horizontal-panel%
+                      [parent parent]
+                      [style '(border)]
+                      [stretchable-height #f]))
+      
       (define e (new (class standard-style-list-text%
                        (inherit change-style get-style-list)
                        (define/augment (after-insert pos offset)
@@ -41,17 +42,20 @@
                            (change-style style pos (+ pos offset) #f)))
                        (super-new))))
       (define c (new canvas:color%
-                     (parent hp)
-                     (editor e)
-                     (style '(hide-hscroll
-                              hide-vscroll))))
+                     [parent hp]
+                     [min-width 150]
+                     [editor e]
+                     [style '(hide-hscroll hide-vscroll)]))
       
       (define (make-check name on off)
         (let* ([c (λ (check command)
                     (if (send check get-value)
                         (update-style-delta on)
                         (update-style-delta off)))]
-               [check (make-object check-box% name hp c)])
+               [check (new check-box% 
+                           [label name]
+                           [parent hp]
+                           [callback c])])
           check))
       
       (define slant-check
@@ -78,26 +82,65 @@
                     (λ (delta)
                       (send delta set-underlined-off #f)
                       (send delta set-underlined-on #f))))
+      
+      (define smoothing-options
+        '(default
+          partly-smoothed
+          smoothed
+          unsmoothed))
+      (define smoothing-option-strings
+        '("Default"
+          "Partly smoothed"
+          "Smoothed"
+          "Unsmoothed"))
+      
+      (define (smoothing->index s)
+        (let loop ([i 0]
+                   [l smoothing-options])
+          (cond
+            [(null? l) 
+             ;; if it is something strange or it is 'base, we go with 'default (which is 0)
+             0]
+            [else
+             (if (eq? (car l) s)
+                 i
+                 (loop (+ i 1)
+                       (cdr l)))])))
+      
+      (define smoothing-menu
+        (new choice%
+             [label #f]
+             [parent hp]
+             [choices smoothing-option-strings]
+             [callback 
+              (λ (c e)
+                (update-style-delta
+                 (λ (delta)
+                   (send delta set-smoothing-on 
+                         (list-ref smoothing-options
+                                   (send c get-selection))))))]))
+
       (define color-button
         (and (>= (get-display-depth) 8)
-             (make-object button%
-               (string-constant cs-change-color)
-               hp
-               (λ (color-button evt)
-                 (let* ([add (send (preferences:get pref-sym) get-foreground-add)]
-                        [color (make-object color%
-                                 (send add get-r)
-                                 (send add get-g)
-                                 (send add get-b))]
-                        [users-choice
-                         (get-color-from-user
-                          (format (string-constant syntax-coloring-choose-color) example-text)
-                          (send color-button get-top-level-window)
-                          color)])
-                   (when users-choice
-                     (update-style-delta
-                      (λ (delta)
-                        (send delta set-delta-foreground users-choice)))))))))
+             (new button%
+                  [label (string-constant cs-change-color)]
+                  [parent hp]
+                  [callback
+                   (λ (color-button evt)
+                     (let* ([add (send (preferences:get pref-sym) get-foreground-add)]
+                            [color (make-object color%
+                                     (send add get-r)
+                                     (send add get-g)
+                                     (send add get-b))]
+                            [users-choice
+                             (get-color-from-user
+                              (format (string-constant syntax-coloring-choose-color) example-text)
+                              (send color-button get-top-level-window)
+                              color)])
+                       (when users-choice
+                         (update-style-delta
+                          (λ (delta)
+                            (send delta set-delta-foreground users-choice))))))])))
       (define style (send (send e get-style-list) find-named-style style-name))
       
       (send c set-line-count 1)
@@ -110,13 +153,15 @@
                                       (eq? (send style get-style) 'italic)))
       (send bold-check set-value (eq? (send style get-weight) 'bold))
       (send underline-check set-value (send style get-underlined))
+      (send smoothing-menu set-selection (smoothing->index (send style get-smoothing)))
       (preferences:add-callback
        pref-sym
        (λ (p sd)
          (send slant-check set-value (or (eq? (send style get-style) 'slant)
                                          (eq? (send style get-style) 'italic)))
          (send bold-check set-value (eq? (send sd get-weight-on) 'bold))
-         (send underline-check set-value (send sd get-underlined-on))))
+         (send underline-check set-value (send sd get-underlined-on))
+         (send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on)))))
       (void)))
   
   (define (add/mult-set m v)
@@ -130,45 +175,90 @@
       (map unbox (list b1 b2 b3))))
   
   (define style-delta-get/set
-    (list (cons (λ (x) (send x get-alignment-off))
-                (λ (x v) (send x set-alignment-off v)))
-          (cons (λ (x) (send x get-alignment-on))
-                (λ (x v) (send x set-alignment-on v)))
-          (cons (λ (x) (add/mult-get (send x get-background-add)))
-                (λ (x v) (add/mult-set (send x get-background-add) v)))
-          (cons (λ (x) (add/mult-get (send x get-background-mult)))
-                (λ (x v) (add/mult-set (send x get-background-mult) v)))
-          (cons (λ (x) (send x get-face))
-                (λ (x v) (send x set-face v)))
-          (cons (λ (x) (send x get-family))
-                (λ (x v) (send x set-family v)))
-          (cons (λ (x) (add/mult-get (send x get-foreground-add)))
-                (λ (x v) (add/mult-set (send x get-foreground-add) v)))
-          (cons (λ (x) (add/mult-get (send x get-foreground-mult)))
-                (λ (x v) (add/mult-set (send x get-foreground-mult) v)))
-          (cons (λ (x) (send x get-size-add))
-                (λ (x v) (send x set-size-add v)))
-          (cons (λ (x) (send x get-size-mult))
-                (λ (x v) (send x set-size-mult v)))
-          (cons (λ (x) (send x get-style-off))
-                (λ (x v) (send x set-style-off v)))
-          (cons (λ (x) (send x get-style-on))
-                (λ (x v) (send x set-style-on v)))
-          (cons (λ (x) (send x get-underlined-off))
-                (λ (x v) (send x set-underlined-off v)))
-          (cons (λ (x) (send x get-underlined-on))
-                (λ (x v) (send x set-underlined-on v)))
-          (cons (λ (x) (send x get-weight-off))
-                (λ (x v) (send x set-weight-off v)))
-          (cons (λ (x) (send x get-weight-on))
-                (λ (x v) (send x set-weight-on v)))))
+    (let ([lo3n (λ (x) (and (list? x) (= (length x) 3) (andmap number? x)))])
+      (list (list (λ (x) (send x get-alignment-off))
+                  (λ (x v) (send x set-alignment-off v))
+                  (λ (x) (memq x '(base top center bottom))))
+            
+            (list (λ (x) (send x get-alignment-on))
+                  (λ (x v) (send x set-alignment-on v))
+                  (λ (x) (memq x '(base top center bottom))))
+            
+            (list (λ (x) (add/mult-get (send x get-background-add)))
+                  (λ (x v) (add/mult-set (send x get-background-add) v))
+                  lo3n)
+            
+            (list (λ (x) (add/mult-get (send x get-background-mult)))
+                  (λ (x v) (add/mult-set (send x get-background-mult) v))
+                  lo3n)
+            
+            (list (λ (x) (send x get-face))
+                  (λ (x v) (send x set-face v))
+                  (λ (x) (or (string? x) (not x))))
+            
+            (list (λ (x) (send x get-family))
+                  (λ (x v) (send x set-family v))
+                  (λ (x) (memq x '(base default decorative roman script swiss modern symbol system))))
+            
+            (list (λ (x) (add/mult-get (send x get-foreground-add)))
+                  (λ (x v) (add/mult-set (send x get-foreground-add) v))
+                  lo3n)
+            
+            (list (λ (x) (add/mult-get (send x get-foreground-mult)))
+                  (λ (x v) (add/mult-set (send x get-foreground-mult) v))
+                  lo3n)
+            
+            (list (λ (x) (send x get-size-add))
+                  (λ (x v) (send x set-size-add v))
+                  (λ (x) (and (integer? x) (exact? x) (<= 0 x 255))))
+            
+            (list (λ (x) (send x get-size-mult))
+                  (λ (x v) (send x set-size-mult v))
+                  (λ (x) (and (number? x) (real? x))))
+            
+            (list (λ (x) (send x get-style-off))
+                  (λ (x v) (send x set-style-off v))
+                  (λ (x) (memq x '(base normal italic slant))))
+            
+            (list (λ (x) (send x get-style-on))
+                  (λ (x v) (send x set-style-on v))
+                  (λ (x) (memq x '(base normal italic slant))))
+            
+            (list (λ (x) (send x get-underlined-off))
+                  (λ (x v) (send x set-underlined-off v))
+                  boolean?)
+            
+            (list (λ (x) (send x get-underlined-on))
+                  (λ (x v) (send x set-underlined-on v))
+                  boolean?)
+            
+            (list (λ (x) (send x get-weight-off))
+                  (λ (x v) (send x set-weight-off v))
+                  (λ (x) (memq x '(base normal bold light))))
+            
+            (list (λ (x) (send x get-weight-on))
+                  (λ (x v) (send x set-weight-on v))
+                  (λ (x) (memq x '(base normal bold light)))))))
   
-  (define (marshall-style style)
+  (define (marshall-style-delta style)
     (map (λ (fs) ((car fs) style)) style-delta-get/set))
   
-  (define (unmarshall-style info)
+  (define (unmarshall-style-delta info)
     (let ([style (make-object style-delta%)])
-      (for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info)
+      
+      (when (list? info)
+        (let loop ([style-delta-get/set style-delta-get/set]
+                   [info info])
+          (cond
+            [(null? info) (void)]
+            [(null? style-delta-get/set) (void)]
+            [else (let ([v (car info)]
+                        [fs (car style-delta-get/set)])
+                    (when ((list-ref fs 2) v)
+                      ((list-ref fs 1) style v))
+                    (loop (cdr style-delta-get/set)
+                          (cdr info)))])))
+      
       style))
   
   (define (make-style-delta color bold? underline? italic?)
@@ -306,8 +396,10 @@
          panel))))
   
   ;; see docs
-  (define register-color-pref
-    (opt-lambda (pref-name style-name color/sd [white-on-black-color #f])
+  (define register-color-preference
+    (opt-lambda (pref-name style-name color/sd 
+                           [white-on-black-color #f]
+                           [use-old-marshalling? #t])
       (let ([sd (cond 
                   [(is-a? color/sd style-delta%)
                    color/sd]
@@ -322,7 +414,7 @@
                             color/sd
                             (to-color white-on-black-color))
                       color-scheme-colors)))
-        (preferences:set-un/marshall pref-name marshall-style unmarshall-style)
+        (preferences:set-un/marshall pref-name marshall-style-delta unmarshall-style-delta)
         (preferences:add-callback pref-name
                                   (λ (sym v)
                                     (editor:set-standard-style-list-delta style-name v)))
diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss
index b342c821..3d58fc73 100644
--- a/collects/framework/private/main.ss
+++ b/collects/framework/private/main.ss
@@ -255,10 +255,11 @@
               (let ([sym (car line)]
                     [color (cadr line)]
                     [white-on-black-color (cadr white-on-black-line)])
-                (color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
-                                                 (scheme:short-sym->style-name sym)
-                                                 color
-                                                 white-on-black-color)))
+                (color-prefs:register-color-preference
+                 (scheme:short-sym->pref-name sym)
+                 (scheme:short-sym->style-name sym)
+                 color
+                 white-on-black-color)))
             (scheme:get-color-prefs-table)
             (scheme:get-white-on-black-color-prefs-table))
   (preferences:set-default 'framework:coloring-active #t boolean?)
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 4cb0e8f6..4b26f0b1 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -310,7 +310,8 @@
       (define (short-sym->style-name sym)
 	(hash-table-get sn-hash sym
 			(λ ()
-			  (let ([s (format "framework:syntax-coloring:scheme:~a" (xlate-sym-style sym))])
+			  (let ([s (format "framework:syntax-color:scheme:~a"
+                                           (xlate-sym-style sym))])
 			    (hash-table-put! sn-hash sym s)
 			    s))))
       
diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss
index d0bf04e0..38981407 100644
--- a/collects/framework/private/sig.ss
+++ b/collects/framework/private/sig.ss
@@ -364,12 +364,12 @@
   (define-signature color-prefs-class^
     ())
   (define-signature color-prefs^ extends color-prefs-class^
-    (register-color-pref
+    (register-color-preference
      add-to-preferences-panel
      build-color-selection-panel
      add-background-preferences-panel
-     marshall-style
-     unmarshall-style
+     marshall-style-delta
+     unmarshall-style-delta
      set-default/color-scheme))  
   
   (define-signature scheme-class^