diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index ed52b544..7063ffeb 100644 --- a/collects/framework/main.rkt +++ b/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 - structure in the parens.}) + in a GUI, the color to use, and the @racket[_priority] argument to + 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 diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 94f8fa25..e78cf4f3 100644 --- a/collects/framework/private/color.rkt +++ b/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 - 220 220 220)) + (reverse-vec + (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 - 153 153 255)) + (between .4 153 153 255 + .4 153 153 255) + 'high) (list 'spring (string-constant paren-color-spring) - (between 255 255 153 - 204 255 153)) + (between 1 255 255 153 + 1 204 255 153) + 'low) (list 'fall (string-constant paren-color-fall) - (between 255 204 153 - 204 153 102)) + (between 1 255 204 153 + 1 204 153 102) + 'low) (list 'winter (string-constant paren-color-winter) - (between 204 205 255 - 238 238 255))))) + (between 1 204 205 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))))))]) - (make-object color% - (between start-r end-r) - (between start-g end-g) - (between start-b end-b))))))) + (define (between start end) (+ start (* (- end start) (/ x (- size 1))))) + (make-object color% + (floor (between start-r end-r)) + (floor (between start-g end-g)) + (floor (between start-b end-b)) + (between start-a end-a)))))) (define -text% (text-mixin text:keymap%)) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index d84cb1ef..d6bc9635 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -157,15 +157,33 @@ (editor:set-standard-style-list-pref-callbacks) -(color-prefs:set-default/color-scheme - '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)) - (make-object color% 50 50 50)) +(let ([gray-level + ;; old gray-level 192 + (if (eq? (system-type) 'windows) + (* 3/4 256) + (- (* 7/8 256) 1))]) + (define default-color (make-object color% 0 0 0 (- 1. (/ gray-level 255)))) + (define w-o-b-default-color (make-object color% 255 255 255 (/ 50 255))) + (color-prefs:set-default/color-scheme 'framework:paren-match-color + 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 diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 3f8888c8..45fe22bf 100644 --- a/collects/framework/private/text.rkt +++ b/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