some improvements to color schemes

- better overview docs (now in the drracket manual)
- something inside the drracket gui to get the list of the
  available style names and to send you to the new docs

pkgs/drracket-pkgs/drracket/drracket/private/main.rkt

@@ -3,6 +3,7 @@
 (require string-constants
          racket/contract
          racket/class
+         racket/pretty
          drracket/private/drsig
          "frame-icon.rkt"
          mred
@@ -13,7 +14,12 @@
          racket/dict
          racket/set
          browser/external
-         setup/plt-installer)
+         setup/plt-installer
+         
+         scribble/tag
+         setup/xref
+         scribble/xref
+         net/url)
 
 (import [prefix drracket:app: drracket:app^]
         [prefix drracket:unit: drracket:unit^]
@@ -33,7 +39,9 @@
 (define (drr:set-default name val predicate)
   (preferences:set-default 
    name val predicate 
-   #:aliases (list (string->symbol (regexp-replace #rx"^drracket:" (symbol->string name) "drscheme:")))))
+   #:aliases (list (string->symbol (regexp-replace #rx"^drracket:" 
+                                                   (symbol->string name)
+                                                   "drscheme:")))))
 
 (frame:current-icon todays-icon)
   
@@ -76,10 +84,13 @@
                                          (listof (listof symbol?)))))
 (preferences:set-default 'drracket:defs/ints-labels #t boolean?)
 
-(drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
+(drr:set-default 'drracket:language-dialog:hierlist-default #f 
-(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
+                 (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
+(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f
+                         (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
 
-(drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution))))
+(drr:set-default 'drracket:create-executable-gui-type 'stand-alone 
+                 (λ (x) (memq x '(launcher stand-alone distribution))))
 (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket))))
 
 (drr:set-default 'drracket:logger-gui-tab-panel-level 0 (λ (x) (and (exact-integer? x) (<= 0 x 5)))) 
@@ -263,7 +274,50 @@
   
 
 (drracket:font:setup-preferences)
-(color-prefs:add-color-scheme-preferences-panel)
+(color-prefs:add-color-scheme-preferences-panel
+ #:extras
+ (λ (parent)
+   (define hp (new horizontal-panel% 
+                   [alignment '(center center)]
+                   [parent parent]
+                   [stretchable-height #f]))
+   (new button% 
+        [label (string-constant design-your-own-color-schemes)]
+        [callback 
+         (λ args
+           
+           (define xref (load-collections-xref))
+           (define-values (path tag)
+             (xref-tag->path+anchor
+              xref
+              (make-section-tag "color-scheme"
+                                #:doc '(lib "scribblings/drracket/drracket.scrbl"))))
+           (define url (path->url path))
+           (define url2 (if tag
+                            (make-url (url-scheme url)
+                                      (url-user url)
+                                      (url-host url)
+                                      (url-port url)
+                                      (url-path-absolute? url)
+                                      (url-path url)
+                                      (url-query url)
+                                      tag)
+                            url))
+           (send-url (url->string url2)))]
+        [parent hp])
+   (new button% 
+        [label (string-constant style-and-color-names)]
+        [callback 
+         (λ args
+           (define sp (open-output-string))
+           (define-values (color-names style-names) (color-prefs:get-color-scheme-names))
+           (fprintf sp "color names:\n")
+           (pretty-write (sort (set->list color-names) symbol<?) sp)
+           (fprintf sp "style names:\n")
+           (pretty-write (sort (set->list style-names) symbol<?) sp)
+           (message-box (string-constant drracket)
+                        (get-output-string sp)))]
+        [parent hp])))
 (color-prefs:add-background-preferences-panel)
 (racket:add-preferences-panel)
 (racket:add-coloring-preferences-panel)
@@ -385,17 +439,17 @@
                                        (or/c false/c string?)
                                        #f)
 
-(drracket:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)
+(drracket:language:register-capability 'drscheme:special:insert-fraction boolean? #t)
-(drracket:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)
+(drracket:language:register-capability 'drscheme:special:insert-large-letters boolean? #t)
-(drracket:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)
+(drracket:language:register-capability 'drscheme:special:insert-lambda boolean? #t)
-(drracket:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)
+(drracket:language:register-capability 'drscheme:special:insert-image boolean? #t)
-(drracket:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)
+(drracket:language:register-capability 'drscheme:special:insert-comment-box boolean? #t)
 (drracket:language:register-capability 'drscheme:language-menu-title 
                                        (flat-contract string?)
                                        (string-constant scheme-menu-name))
 
 (drracket:language:register-capability 'drscheme:teachpack-menu-items
-                                       (or/c false/c (flat-contract drracket:unit:teachpack-callbacks?))
+                                       (or/c #f (flat-contract drracket:unit:teachpack-callbacks?))
                                        #f)
 
 (handler:current-create-new-window
@@ -439,10 +493,13 @@
         (when exprs-pref
           (trim (second exprs-pref)
                 (λ (trimmed)
-                  (put-preferences (list 'plt:framework-prefs)
+                  (put-preferences
-                                   (list (dict-set framework-prefs 'drscheme:console-previous-exprs (list trimmed)))
+                   (list 'plt:framework-prefs)
-                                   void)))))))
+                   (list (dict-set framework-prefs 'drscheme:console-previous-exprs (list trimmed)))
-  (trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs #:timeout-lock-there (λ (x) #f))
+                   void)))))))
+  (trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs
+                        #:timeout-lock-there
+                        (λ (x) #f))
         (λ (trimmed)
           (put-preferences (list 'plt:framework-pref:drscheme:console-previous-exprs)
                            (list trimmed)

pkgs/drracket-pkgs/drracket/scribblings/drracket/interface-essentials.scrbl

@@ -1,7 +1,8 @@
 #lang scribble/doc
 @(require "common.rkt"
           scribble/decode scribble/eval scribble/struct scribble/racket
-          (for-label racket/gui/base))
+          (for-label racket/gui/base framework)
+          setup/getinfo racket/pretty string-constants)
 
 @(define (ioinputfont . s)
    (apply tt s))
@@ -765,6 +766,74 @@ A module browser window contains a square for each
   what you type will turn green in the module window. This bar is only visible
   in the stand alone module browser window (via the @onscreen{Racket} menu)
 
+@section[#:tag "color-scheme"]{Color Schemes}
+
+DrRacket comes with three different color schemes, available in the preferences dialog's
+@onscreen{color} panel.
+
+You can add your own color schemes to DrRacket, too. The first step is to
+create a pkg (see @secref["how-to-create" #:doc '(lib "pkg/scribblings/pkg.scrbl")])
+and add an @filepath{info.rkt} file to it. The file should define
+@racket[framework:color-schemes] as a list of hashes that describe the color schemes.
+
+@(define example-key #f)
+
+As an example, this is the specification of the @racket["Modern"] style:
+@(let ()
+   (define pth (collection-file-path "info.rkt" "drracket"))
+   (define-values (base name dir?) (split-path pth))
+   (define info (get-info/full base))
+   (unless info (error 'framework/main.rkt "could not find example for modern color scheme"))
+   (define key 'framework:color-schemes)
+   (define datum (info key))
+   (define name-as-string-datum
+     (let loop ([datum datum])
+       (cond
+         [(list? datum)
+          (for/list ([datum (in-list datum)])
+            (loop datum))]
+         [(hash? datum)
+          (for/hash ([(k v) (in-hash datum)])
+            (if (and (equal? k 'name) (string-constant? v))
+                (values k (dynamic-string-constant v))
+                (values k (loop v))))]
+         [(and (symbol? datum)
+               (regexp-match #rx"framework:" (symbol->string datum)))
+          (unless example-key (set! example-key datum))
+          datum]
+         [else datum])))
+   (define sp (open-output-string))
+   (parameterize ([pretty-print-columns 60]
+                  [current-output-port sp])
+     (pretty-write
+      `(define ,key 
+         ',name-as-string-datum)))
+   (codeblock 
+    (string-append "#lang info\n"
+                   (get-output-string sp))))
+
+Each of the keys, e.g., @code[(format "~s" `',example-key)], maps to a color and possibly to
+some style information. All keys accept colors (the vectors shown
+above represent colors in r/g/b format), but only some accept style information. To
+find out which are which and to get a complete list of the possible keys, click the button
+labeled @onscreen[(regexp-replace #rx"&&" (string-constant style-and-color-names) "&")]
+at the bottom of the 
+@onscreen[(string-constant color-schemes)] tab of the
+@onscreen[(string-constant preferences-colors)] tab in the preferences dialog.
+If one can accept style information, then you may include any of the symbols @racket['bold],
+@racket['underline], or @racket['italic] in the list with the color.
+
+Full details on the specification of the info files can be found in the documentation
+for the function @racket[color-prefs:register-info-based-color-schemes].
+
+You may have to restart DrRacket (and, at least the first time after you add the @filepath{info.rkt}
+file, re-run @tt{raco setup}) to see changes to your color scheme.
+
+Color schemes are not limited only to the colors that DrRacket already knows about.
+If you are adding your own plugin to DrRacket, you can add new names that can be 
+mapped in the color scheme. See @racket[color-prefs:register-color-preference] for
+more information.
+
 @section[#:tag "create-exe"]{Creating Executables}
 
 DrRacket's @onscreen{Create Executable...} menu item lets you create

pkgs/gui-pkgs/gui-lib/framework/main.rkt

@@ -4,6 +4,7 @@
          racket/unit
          racket/class
          racket/gui/base
+         racket/set
          mred/mred-unit
          framework/framework-unit
          framework/private/sig
@@ -1871,10 +1872,15 @@
     If @racket[style] is provided, a new style is registered; if not a color is
     registered.})
  
- (proc-doc
+ (proc-doc/names
   color-prefs:add-color-scheme-preferences-panel
-  (-> void?)
+  (->* () (#:extras (-> (is-a?/c panel%) any)) void?)
-  @{Adds a panel for choosing a color-scheme to the preferences dialog.})
+  (() ((extras void)))
+  @{Adds a panel for choosing a color-scheme to the preferences dialog.
+    
+    The @racket[extras] argument is called after the color schemes have been added
+    to the preferences panel. It is passed the panel containing the color schemes
+    and can add items to it.})
  
  (proc-doc
   color-prefs:register-info-based-color-schemes
@@ -1913,37 +1919,7 @@
     is called, it logs the active set of color names and style names to the @tt{color-scheme}
     logger at the info level. So, for example, starting up DrRacket like this:
     @tt{racket -W info@"@"color-scheme -l drracket} will print out the styles used in your
-    version of DrRacket.
+    version of DrRacket.})
-    
-    As an example, this is the specification of the @racket["Modern"] style:
-    @(let ()
-       (define pth (collection-file-path "info.rkt" "drracket"))
-       (define-values (base name dir?) (split-path pth))
-       (define info (get-info/full base))
-       (unless info (error 'framework/main.rkt "could not find example for modern color scheme"))
-       (define key 'framework:color-schemes)
-       (define datum (info key))
-       (define name-as-string-datum
-         (let loop ([datum datum])
-           (cond
-             [(list? datum)
-              (for/list ([datum (in-list datum)])
-                (loop datum))]
-             [(hash? datum)
-              (for/hash ([(k v) (in-hash datum)])
-                (if (and (equal? k 'name) (string-constant? v))
-                    (values k (dynamic-string-constant v))
-                    (values k (loop v))))]
-             [else datum])))
-       (define sp (open-output-string))
-       (parameterize ([pretty-print-columns 60]
-                      [current-output-port sp])
-         (pretty-write
-          `(define ,key 
-             ',name-as-string-datum)))
-       (codeblock 
-        (string-append "#lang info\n"
-                       (get-output-string sp))))})
  
  (proc-doc/names
   color-prefs:set-current-color-scheme
@@ -2020,6 +1996,14 @@
     
     If @racket[weak?] is @racket[#t], the @racket[fn] argument is held
     onto weakly; otherwise it is held onto strongly.})
+ 
+ (proc-doc
+  color-prefs:get-color-scheme-names
+  (-> (values set? set?))
+  @{Returns two sets; the first is the known color scheme names that are just colors
+    and the second is the known color scheme names that are styles.
+    
+    These are all of the names that have been passed to @racket[color-prefs:add-color-scheme-entry].})
  )
 
 

pkgs/gui-pkgs/gui-lib/framework/private/color-prefs.rkt

@@ -622,6 +622,8 @@
 (define known-color-names (set))
 (define known-style-names (set))
 
+(define (get-color-scheme-names) (values known-color-names known-style-names))
+
 (define-logger color-scheme)
 
 (define (register-info-based-color-schemes)
@@ -972,7 +974,7 @@
        (editor:set-standard-style-list-delta style-name sd)))
     (editor:set-standard-style-list-delta style-name (lookup-in-color-scheme name))))
 
-(define (add-color-scheme-preferences-panel)
+(define (add-color-scheme-preferences-panel #:extras [extras void])
   (preferences:add-panel
    (list (string-constant preferences-colors)
          (string-constant color-schemes))
@@ -1011,7 +1013,9 @@
                            (color-scheme-name color-scheme)))])))
      (define wid (apply max (map (λ (x) (send x get-width)) buttons)))
      (for ([b (in-list buttons)])
-       (send b min-width wid)))))
+       (send b min-width wid))
+     (extras vp)
+     (void))))
 
 (define (color-scheme->style-list color-scheme)
   (define style-list (new style-list%))

pkgs/gui-pkgs/gui-lib/framework/private/sig.rkt

@@ -440,7 +440,8 @@
      set-in-color-scheme
      register-color-scheme-entry-change-callback
      add-color-scheme-entry
-     register-info-based-color-schemes))
+     register-info-based-color-schemes
+     get-color-scheme-names))
   
   (define-signature racket-class^
     (text<%>

pkgs/string-constants/string-constants-lib/string-constants/private/english-string-constants.rkt

@@ -558,6 +558,9 @@ please adhere to these guidelines:
   (classic-color-scheme "Classic") ;; formerly called 'black on white'
   (modern-color-scheme "Modern")   ;; an attempt to be more color-blind friendly
   (white-on-black-color-scheme "White on Black") ;; clicking the buttons changes the color schemes to some defaults that've been set up.
+  ; drracket additions to the color scheme dialog; two buttons
+  (design-your-own-color-schemes "Design Your Own Color Schemes") ; pointer to (english-only) docs
+  (style-and-color-names "Style && Color Names")
   
   (add-spacing-between-lines "Add one pixel of extra space between lines")