From 00f6f3ed978410b3338def179d3f6fc27a19eb10 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 23 Jan 2003 14:35:36 +0000
Subject: [PATCH] ..

original commit: 6e4991499292e5cc97d0dbd163db8603ac64827b
---
 collects/framework/private/main.ss        | 15 +++++++-
 collects/framework/private/preferences.ss | 46 ++++++++++++++++++++++-
 collects/framework/private/scheme.ss      | 10 +----
 3 files changed, 61 insertions(+), 10 deletions(-)

diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss
index d3790d35..9111c575 100644
--- a/collects/framework/private/main.ss
+++ b/collects/framework/private/main.ss
@@ -19,7 +19,20 @@
       
       (application-preferences-handler (lambda () (preferences:show-dialog)))
       
-      ;; preferences
+      (preferences:set-default 'framework:paren-match-color
+                               (let ([gray-level
+                                      ;; old gray-level 192
+                                      (if (eq? (system-type) 'windows)
+                                          (* 3/4 256)
+                                          (- (* 7/8 256) 1))])
+                                 (make-object color% gray-level gray-level gray-level))
+                               (lambda (x) (is-a? x color%)))
+      
+      (preferences:set-un/marshall
+       'framework:paren-match-color
+       (lambda (c) (list (send c red) (send c green) (send c blue)))
+       (lambda (l) (make-object color% (car l) (cadr l) (caddr l))))
+      
       (preferences:set-default 'framework:last-directory (find-system-path 'home-dir) string?)
       (preferences:set-default 'framework:recent-max-count 
                                50 
diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss
index 1c5646d9..7b4376bc 100644
--- a/collects/framework/private/preferences.ss
+++ b/collects/framework/private/preferences.ss
@@ -582,9 +582,53 @@
                                    'framework:paren-match
                                    (string-constant flash-paren-match)
                                    values values)
-                       (scheme-panel-procs scheme-panel))))])
+                       (scheme-panel-procs scheme-panel)
+                       (make-highlight-color-choice scheme-panel))))])
           (add-scheme-checkbox-panel)))
       
+      (define (make-highlight-color-choice panel)
+        (let* ([hp (instantiate horizontal-panel% ()
+                     (parent panel)
+                     (stretchable-height #f))]
+               [msg (make-object message% (string-constant paren-match-color) hp)]
+               [scheme-higlight-canvas (make-object scheme-highlight-canvas% hp)]
+               [button (make-object button% 
+                         (string-constant choose-color) 
+                         hp
+                         (lambda (x y) (change-highlight-color panel)))])
+          (void)))
+      
+      (define scheme-highlight-canvas%
+        (class canvas%
+          (inherit get-client-size get-dc)
+          (define/override (on-paint)
+            (let ([dc (get-dc)])
+              (send dc set-pen (send the-pen-list find-or-create-pen
+                                     (get 'framework:paren-match-color)
+                                     1
+                                     'solid))
+              (send dc set-brush (send the-brush-list find-or-create-brush
+                                       (get 'framework:paren-match-color) 
+                                       'solid))
+              (let-values ([(w h) (get-client-size)])
+                (send dc draw-rectangle 0 0 w h))))
+          (super-instantiate ())
+          (inherit stretchable-width min-width)
+          (stretchable-width #f)
+          (min-width 30)
+          (add-callback
+           'framework:paren-match-color
+           (lambda (p v)
+             (on-paint)))))
+      
+      (define (change-highlight-color parent)
+        (let ([new-color
+               (get-color-from-user (string-constant choose-paren-highlight-color)
+                                    (send parent get-top-level-window)
+                                    (get 'framework:paren-match-color))])
+          (when new-color
+            (set 'framework:paren-match-color new-color))))
+      
       (define (add-editor-checkbox-panel)
         (letrec ([add-editor-checkbox-panel
                   (lambda ()
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 9402ccd5..a1a7e471 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -315,13 +315,7 @@
                         (send style-list find-named-style "Basic")
                         delta))))
       
-      (define match-color 
-        (let ([gray-level
-               ;; old gray-level 192
-               (if (eq? (system-type) 'windows)
-                   (* 3/4 256)
-                   (- (* 7/8 256) 1))])
-          (make-object color% gray-level gray-level gray-level)))
+      (define (get-match-color) (preferences:get 'framework:paren-match-color))
       (define mismatch-color (make-object color% "PINK"))
       
       (define matching-parenthesis-style 
@@ -556,7 +550,7 @@
                                       [off (highlight-range 
                                             left
                                             right
-                                            (if error? mismatch-color match-color)
+                                            (if error? mismatch-color (get-match-color))
                                             (and (send (icon:get-paren-highlight-bitmap) ok?)
                                                  (icon:get-paren-highlight-bitmap))
                                             (= there here left))])