make the paren highlight use non alpha=1 colors so that

the paren highlight composes with other highlighting in the editor

collects/framework/main.rkt

@@ -66,11 +66,16 @@
 
  (proc-doc
   color:get-parenthesis-colors-table 
-  (-> (listof (list/c symbol? string? (vectorof (is-a?/c color%)))))
+  (-> (listof (list/c symbol? string? (vectorof (is-a?/c color%)) (or/c 'low 'high))))
   @{Returns a table of colors that get used for parenthesis highlighting.
     Each entry in the table consists of a symbolic name, a name to show
-    in a GUI, and the color to use. The colors are used to show the nesting
+    in a GUI, the color to use, and the @racket[_priority] argument to
-    structure in the parens.})
+    pass to @racket[text:basic<%> highlight-range] when highlighting the parens.
+    Generally the priority should be @racket['low] if the color is solid
+    (α=1) but can be @racket['high] if the α component is small.
+    
+    When an entry in the table has multiple colors, they are used to show the nesting
+    structure in the parentheses.})
  
  (thing-doc
   color:misspelled-text-color-style-name

collects/framework/private/color.rkt

@@ -665,14 +665,14 @@ added get-regions
     ;;   Otherwise, it treats it like a boolean, where a true value  
     ;;   means the normal paren color and #f means an error color. 
     ;; numbers are expected to have zero be start-pos.
-    (define/private (highlight ls start end caret-pos color)
+    (define/private (highlight ls start end caret-pos color [priority 'low])
       (let* ([start-pos (lexer-state-start-pos ls)]
              [off (highlight-range (+ start-pos start) (+ start-pos end)
                                    (if (is-a? color color%)
                                        color
                                        (if color mismatch-color (get-match-color)))
                                    (= caret-pos (+ start-pos start))
-                                   'low)])
+                                   priority)])
         (set! clear-old-locations
               (let ([old clear-old-locations])
                 (λ ()
@@ -739,14 +739,16 @@ added get-regions
     ;; highlight-nested-region : lexer-state number number number -> void
     ;; colors nested regions of parentheses.
     (define/private (highlight-nested-region ls orig-start orig-end here)
+      (define priority (get-parenthesis-priority))
+      (define paren-colors (get-parenthesis-colors))
       (let paren-loop ([start orig-start]
                        [end orig-end]
                        [depth 0])
-        (when (< depth (vector-length (get-parenthesis-colors)))
+        (when (< depth (vector-length paren-colors))
           
           ;; when there is at least one more color in the vector we'll look
           ;; for regions to color at that next level
-          (when (< (+ depth 1) (vector-length (get-parenthesis-colors)))
+          (when (< (+ depth 1) (vector-length paren-colors))
             (let seq-loop ([inner-sequence-start (+ start 1)])
               (when (< inner-sequence-start end)
                 (let ([post-whitespace (skip-whitespace inner-sequence-start 'forward #t)])
@@ -761,7 +763,7 @@ added get-regions
                        (λ (after-non-paren-thing)
                          (seq-loop after-non-paren-thing))]))))))
           
-          (highlight ls start end here (vector-ref (get-parenthesis-colors) depth)))))
+          (highlight ls start end here (vector-ref paren-colors depth) priority))))
     
     ;; See docs
     (define/public (forward-match position cutoff)
@@ -1155,32 +1157,40 @@ added get-regions
 
 (define parenthesis-color-table #f)
 (define (get-parenthesis-colors-table)
+  (define (reverse-vec v) (list->vector (reverse (vector->list v))))
   (unless parenthesis-color-table
     (set! parenthesis-color-table
           (list
            (list 'shades-of-gray  
                  (string-constant paren-color-shades-of-gray)
-                 (between 180 180 180
+                 (reverse-vec
-                          220 220 220))
+                  (between .2 0 0 0
+                           .2 0 0 0))
+                 'high)
            (list 'shades-of-blue
                  (string-constant paren-color-shades-of-blue)
-                 (between 204 204 255
+                 (between .4 153 153 255
-                          153 153 255))
+                          .4 153 153 255)
+                 'high)
            (list 'spring
                  (string-constant paren-color-spring)
-                 (between 255 255 153
+                 (between 1 255 255 153
-                          204 255 153))
+                          1 204 255 153)
+                 'low)
            (list 'fall
                  (string-constant paren-color-fall)
-                 (between 255 204 153
+                 (between 1 255 204 153
-                          204 153 102))
+                          1 204 153 102)
+                 'low)
            (list 'winter
                  (string-constant paren-color-winter)
-                 (between 204 205 255
+                 (between 1 204 205 255
-                          238 238 255)))))
+                          1 238 238 255)
+                 'low))))
   (cons (list 'basic-grey
               (string-constant paren-color-basic-grey)
-              (vector (preferences:get 'framework:paren-match-color)))
+              (vector (preferences:get 'framework:paren-match-color))
+              'high)
         parenthesis-color-table))
 
 (define (get-parenthesis-colors) 
@@ -1189,16 +1199,23 @@ added get-regions
                     (car (get-parenthesis-colors-table)))])
     (caddr choice)))
 
-(define (between start-r start-g start-b end-r end-g end-b)
+(define (get-parenthesis-priority) 
+  (let ([choice (or (assoc (preferences:get 'framework:paren-color-scheme)
+                           (get-parenthesis-colors-table))
+                    (car (get-parenthesis-colors-table)))])
+    (list-ref choice 3)))
+
+(define (between start-a start-r start-g start-b end-a end-r end-g end-b)
   (let ([size 4])
     (build-vector
      4 
      (lambda (x) 
-       (let ([between (λ (start end) (floor (+ start (* (- end start) (/ x (- size 1))))))])
+       (define (between start end) (+ start (* (- end start) (/ x (- size 1)))))
-         (make-object color% 
+       (make-object color% 
-           (between start-r end-r)
+         (floor (between start-r end-r))
-           (between start-g end-g)
+         (floor (between start-g end-g))
-           (between start-b end-b)))))))
+         (floor (between start-b end-b))
+         (between start-a end-a))))))
 
 (define -text% (text-mixin text:keymap%))
 

collects/framework/private/main.rkt

@@ -157,15 +157,33 @@
 
 (editor:set-standard-style-list-pref-callbacks)
 
-(color-prefs:set-default/color-scheme
+(let ([gray-level
- 'framework:paren-match-color
+       ;; old gray-level 192
- (let ([gray-level
+       (if (eq? (system-type) 'windows)
-        ;; old gray-level 192
+           (* 3/4 256)
-        (if (eq? (system-type) 'windows)
+           (- (* 7/8 256) 1))])
-            (* 3/4 256)
+  (define default-color (make-object color% 0 0 0 (- 1. (/ gray-level 255))))
-            (- (* 7/8 256) 1))])
+  (define w-o-b-default-color (make-object color% 255 255 255 (/ 50 255)))
-   (make-object color% gray-level gray-level gray-level))
+  (color-prefs:set-default/color-scheme 'framework:paren-match-color
- (make-object color% 50 50 50))
+                                        default-color
+                                        w-o-b-default-color)
+  
+  ;; when the preference is currently set to the old color,
+  ;; then just update it to the new one (if someone really
+  ;; wants the old default, they can still have a color that is
+  ;; off by one from the old default which should be ok)
+  (define current-color (preferences:get 'framework:paren-match-color))
+  (cond
+    [(and (= (send current-color red) gray-level)
+          (= (send current-color green) gray-level)
+          (= (send current-color blue) gray-level)
+          (= (send current-color alpha) 1.0))
+     (preferences:set 'framework:paren-match-color default-color)]
+    [(and (= (send current-color red) 50)
+          (= (send current-color green) 50)
+          (= (send current-color blue) 50)
+          (= (send current-color alpha) 1.0))
+     (preferences:set 'framework:paren-match-color w-o-b-default-color)]))
 
 (preferences:set-default 'framework:recently-opened-files/pos 
                          null 

collects/framework/private/text.rkt

@@ -423,6 +423,7 @@
               (define height (if (bottom . <= . top) 0 (- bottom top)))
               (define color (let ([rc (rectangle-color rectangle)])
                               (cond
+                                [(not (= 1 (send rc alpha))) rc]
                                 [(and last-color (eq? last-color rc))
                                  rc]
                                 [rc

doc/release-notes/drracket/HISTORY.txt

@@ -11,34 +11,39 @@
   . Automatic-parenthesis mode improvements 
     (thanks to Nadeem Abdul Hamid)
 
-    - Added some "smart-skip" behavior to insert-close-paren,
+      - Added some "smart-skip" behavior to insert-close-paren,
-      described in the documentation.
+        described in the documentation.
-      - When auto-parens mode is enabled,
+        - When auto-parens mode is enabled,
-        the existing "balance-parens" keybinding invokes
+          the existing "balance-parens" keybinding invokes
-        insert-close-paren with a smart-skip argument of
+          insert-close-paren with a smart-skip argument of
-        'adjacent
+          'adjacent
-      - A new "balance-parens-forward" keybinding invokes
+        - A new "balance-parens-forward" keybinding invokes
-        insert-close-paren with a smart-skip argument of
+          insert-close-paren with a smart-skip argument of
-        'forward (whether or not auto-parens mode is
+          'forward (whether or not auto-parens mode is
-                        enabled)
+                          enabled)
-
+  
-    - Some basic smart-skip behavior is also enabled for
+      - Some basic smart-skip behavior is also enabled for
-      strings ("...") and |...| pairs, specifically, typing
+        strings ("...") and |...| pairs, specifically, typing
-      a double-quote or bar character when the cursor
+        a double-quote or bar character when the cursor
-      immediately precedes one causes the cursor to simply
+        immediately precedes one causes the cursor to simply
-      skip over the existing one
+        skip over the existing one
-
+  
-    - Tweaked insertion of block comment pairs in
+      - Tweaked insertion of block comment pairs in
-      auto-parens mode
+        auto-parens mode
-
+  
-    - In strings and line/block comments, auto-parens mode
+      - In strings and line/block comments, auto-parens mode
-      no longer has any effect (you can still use the M+..
+        no longer has any effect (you can still use the M+..
-      keybindings to force insertion of a particular brace
+        keybindings to force insertion of a particular brace
-      pair)
+        pair)
-
+  
-    - Detect when a character constant is being typed, and
+      - Detect when a character constant is being typed, and
-      don't insert brace pairs if so
+        don't insert brace pairs if so
+  
+  . DrRacket's window can now be substantially narrower
 
+  . DrRacket's paren highlighting uses alpha-blending to avoid having
+    the highlight disappear completely when completely inside an
+    error.
 
 ------------------------------
        Version 5.3.1