diff --git a/collects/mred/mred.rkt b/collects/mred/mred.rkt index 88477ae2..2fc3ba91 100644 --- a/collects/mred/mred.rkt +++ b/collects/mred/mred.rkt @@ -132,7 +132,9 @@ font% font-list% font-name-directory<%> - get-resource + get-highlight-background-color + get-highlight-text-color + get-resource get-the-editor-data-class-list get-the-snip-class-list image-snip% @@ -271,7 +273,7 @@ get-display-left-top-inset get-color-from-user get-font-from-user - append-editor-operation-menu-items + append-editor-operation-menu-items append-editor-font-menu-items get-top-level-focus-window get-top-level-edit-target-window diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index f6e408e8..345eefbe 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -101,4 +101,6 @@ application-quit-handler application-file-handler special-option-key - special-control-key)) + special-control-key + get-highlight-background-color + get-highlight-text-color)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 7210efd2..48d16a39 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -55,7 +55,9 @@ get-the-x-selection get-the-clipboard show-print-setup - can-show-print-setup?) + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color) (import-class NSScreen NSCursor) @@ -117,3 +119,26 @@ (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) + +;; ------------------------------------------------------------ +;; Text & highlight color + +(import-class NSColor) + +(define-cocoa NSCalibratedRGBColorSpace _id) + +(define (get-highlight-background-color) + (let ([hi (tell (tell NSColor selectedTextBackgroundColor) + colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] + [as-color (lambda (v) + (inexact->exact (floor (* 255.0 v))))]) + (make-object color% + (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent))))) + +(define (get-highlight-text-color) + #f) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index adf70a51..9210d293 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -275,24 +275,3 @@ (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event (_fun #:atomic? #t _float _pointer -> _void)))) - -;; ------------------------------------------------------------ -;; Set highlight color - -(define-cocoa NSCalibratedRGBColorSpace _id) - -(define (install-system-highlight-color! r g b a) - (void)) - -(let ([hi (tell (tell NSColor selectedTextBackgroundColor) - colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] - [as-color (lambda (v) - (inexact->exact (floor (* 255.0 v))))]) - (install-system-highlight-color! (as-color - (tell #:type _CGFloat hi redComponent)) - (as-color - (tell #:type _CGFloat hi greenComponent)) - (as-color - (tell #:type _CGFloat hi blueComponent)) - (as-color - (tell #:type _CGFloat hi alphaComponent)))) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index c96d3144..6e11e437 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -173,8 +173,6 @@ (queue-window-event wx (lambda () (send wx do-scroll dir))))) #t) -(define-gtk gtk_entry_get_type (_fun -> _GType)) - (define canvas% (class (client-size-mixin window%) (init parent diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 00ccbd0e..c398f82b 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -101,4 +101,6 @@ application-quit-handler application-file-handler special-option-key - special-control-key)) + special-control-key + get-highlight-background-color + get-highlight-text-color)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 229e4d2a..1fe3242d 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -7,6 +7,7 @@ "filedialog.rkt" "types.rkt" "utils.rkt" + "style.rkt" "widget.rkt" "../common/handlers.rkt") @@ -58,7 +59,9 @@ get-the-x-selection get-the-clipboard show-print-setup - can-show-print-setup?) + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color) (define-unimplemented special-control-key) (define (special-option-key on?) (void)) @@ -125,3 +128,11 @@ (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) + +(define (get-highlight-background-color) + (let-values ([(r g b) (get-selected-background-color)]) + (make-object color% r g b))) + +(define (get-highlight-text-color) + (let-values ([(r g b) (get-selected-text-color)]) + (make-object color% r g b))) diff --git a/collects/mred/private/wx/gtk/style.rkt b/collects/mred/private/wx/gtk/style.rkt new file mode 100644 index 00000000..6d8550f5 --- /dev/null +++ b/collects/mred/private/wx/gtk/style.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require ffi/unsafe + "types.rkt" + "utils.rkt" + "init.rkt") + +(provide get-selected-text-color + get-selected-background-color) + +(define-cstruct _GdkColor + ([pixel _uint32] + [red _uint16] + [green _uint16] + [blue _uint16])) + +(define-cstruct _GtkStyle + ([fg1 _GdkColor] + [fg2 _GdkColor] + [fg3 _GdkColor] + [fg4 _GdkColor] + [fg5 _GdkColor] + [bg1 _GdkColor] + [bg2 _GdkColor] + [bg3 _GdkColor] + [bg4 _GdkColor] + [bg5 _GdkColor] + [light1 _GdkColor] + [light2 _GdkColor] + [light3 _GdkColor] + [light4 _GdkColor] + [light5 _GdkColor] + [dark1 _GdkColor] + [dark2 _GdkColor] + [dark3 _GdkColor] + [dark4 _GdkColor] + [dark5 _GdkColor] + [mid1 _GdkColor] + [mid2 _GdkColor] + [mid3 _GdkColor] + [mid4 _GdkColor] + [mid5 _GdkColor] + [text1 _GdkColor] + [text2 _GdkColor] + [text3 _GdkColor] + [text4 _GdkColor] + [text5 _GdkColor] + [base1 _GdkColor] + [base2 _GdkColor] + [base3 _GdkColor] + [base4 _GdkColor] + [base5 _GdkColor] + [text_aa1 _GdkColor] + [text_aa2 _GdkColor] + [text_aa3 _GdkColor] + [text_aa4 _GdkColor] + [text_aa5 _GdkColor] + [black _GdkColor] + [white _GdkColor] + [font_desc _pointer] ; PangoFontDescription * + ; ... + )) + +(define-gtk gtk_widget_get_style (_fun _GtkWidget -> _GtkStyle-pointer)) +(define-gtk gtk_text_view_new (_fun -> _GtkWidget)) + +(define the-text-style + (let ([w (gtk_text_view_new)]) + (let ([style (gtk_widget_get_style w)]) + (g_object_ref style) + (begin0 + style + (g_object_ref_sink w) + (g_object_unref w))))) + +(define (extract-color-values c) + (define (s v) (bitwise-and #xFF (arithmetic-shift v -8))) + (values (s (GdkColor-red c)) + (s (GdkColor-green c)) + (s (GdkColor-blue c)))) + +(define (get-selected-text-color) + (extract-color-values (GtkStyle-text4 the-text-style))) + +(define (get-selected-background-color) + (extract-color-values (GtkStyle-base4 the-text-style))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 1785cb1e..6fa2987b 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -15,6 +15,7 @@ define-mz g_object_ref + g_object_ref_sink g_object_unref gobject-ref diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 729f2393..69690c98 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -79,5 +79,7 @@ application-quit-handler application-file-handler special-option-key - special-control-key) + special-control-key + get-highlight-background-color + get-highlight-text-color) ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index ba59b565..9e8ccdfa 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -100,4 +100,6 @@ application-quit-handler application-file-handler special-option-key - special-control-key)) + special-control-key + get-highlight-background-color + get-highlight-text-color)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index d4d7d4ad..120851f6 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -49,7 +49,9 @@ get-the-x-selection get-the-clipboard show-print-setup - can-show-print-setup?) + can-show-print-setup? + get-highlight-background-color + get-highlight-text-color) (define-unimplemented special-control-key) @@ -102,4 +104,6 @@ (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) -(define-unimplemented can-show-print-setup?) \ No newline at end of file +(define-unimplemented can-show-print-setup?) +(define-unimplemented get-highlight-background-color) +(define-unimplemented get-highlight-text-color) diff --git a/collects/mred/private/wxme/editor-snip.rkt b/collects/mred/private/wxme/editor-snip.rkt index 63657249..0c74ec30 100644 --- a/collects/mred/private/wxme/editor-snip.rkt +++ b/collects/mred/private/wxme/editor-snip.rkt @@ -284,7 +284,7 @@ (def/override (draw [dc<%> dc] [real? x] [real? y] [real? left] [real? top] [real? right] [real? bottom] - [real? dx] [real? dy] [symbol? caret]) + [real? dx] [real? dy] [caret-status? caret]) (send my-admin with-dc dc x y @@ -320,6 +320,7 @@ (let ([bg-color (cond + [(pair? caret) #f] [(not use-style-bg?) (make-object color% 255 255 255)] [(send s-style get-transparent-text-backing) @@ -357,34 +358,40 @@ caret bg-color)) (when with-border? - (let* ([l (+ orig-x left-inset)] - [t (+ orig-y top-inset)] - [r (+ l w left-margin right-margin - (- (+ left-inset right-inset)) - -1)] - [b (+ t h top-margin bottom-margin - (- (+ top-inset bottom-inset)) - -1)]) - (let ([ml (max (min l right) left)] - [mr (max (min r right) left)] - [mt (max (min t bottom) top)] - [mb (max (min b bottom) top)]) - (when (and (l . >= . left) - (l . < . right) - (mt . < . mb)) - (send dc draw-line l mt l mb)) - (when (and (r . >= . left) - (r . < . right) - (mt . < . mb)) - (send dc draw-line r mt r mb)) - (when (and (t . >= . top) - (t . < . bottom) - (ml . < . mr)) - (send dc draw-line ml t mr t)) - (when (and (b . >= . top) - (b . < . bottom) - (ml . < . mr)) - (send dc draw-line ml b mr b))))))))))) + (let ([pen (send dc get-pen)]) + (when (and (pair? caret) + selected-text-color) + (send dc set-pen selected-text-color 1 'solid)) + (let* ([l (+ orig-x left-inset)] + [t (+ orig-y top-inset)] + [r (+ l w left-margin right-margin + (- (+ left-inset right-inset)) + -1)] + [b (+ t h top-margin bottom-margin + (- (+ top-inset bottom-inset)) + -1)]) + (let ([ml (max (min l right) left)] + [mr (max (min r right) left)] + [mt (max (min t bottom) top)] + [mb (max (min b bottom) top)]) + (when (and (l . >= . left) + (l . < . right) + (mt . < . mb)) + (send dc draw-line l mt l mb)) + (when (and (r . >= . left) + (r . < . right) + (mt . < . mb)) + (send dc draw-line r mt r mb)) + (when (and (t . >= . top) + (t . < . bottom) + (ml . < . mr)) + (send dc draw-line ml t mr t)) + (when (and (b . >= . top) + (b . < . bottom) + (ml . < . mr)) + (send dc draw-line ml b mr b)))) + (when (pair? caret) + (send dc set-pen pen)))))))))) (def/override (copy) (let* ([mb (and editor diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 4c88b64c..27138274 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -1266,14 +1266,14 @@ #f)) (def/public (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [caret-status? show-caret] [(make-or-false color%) bg-color]) (void)) (def/public (on-paint [any? pre?] [dc<%> dc] [real? l] [real? t] [real? r] [real? b] [real? dx] [real? dy] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret]) + [caret-status? show-caret]) (void)) (def/public (can-save-file? [path-string? filename] diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 42f2a300..3736bda0 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -47,8 +47,8 @@ (define caret-pen (send the-pen-list find-or-create-pen "BLACK" 1 'xor)) (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) -(define outline-inactive-pen (send the-pen-list find-or-create-pen "BLACK" 1 'hilite)) -(define outline-brush (send the-brush-list find-or-create-brush "BLACK" 'hilite)) +(define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) +(define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) (define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") (define outline-nonowner-brush (let ([b (new brush%)]) (send b set-color "BLACK") @@ -4933,7 +4933,7 @@ ;; called by the administrator to trigger a redraw (def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] - [(symbol-in no-caret show-inactive-caret show-caret) show-caret] + [caret-status? show-caret] [(make-or-false color%) bg-color]) (cond [(or (width . <= . 0) (height . <= . 0)) (void)] @@ -4955,6 +4955,7 @@ (let ([show-caret (if (and caret-blinked? + (not (pair? show-caret)) (not (eq? show-caret 'no-caret)) (not s-caret-snip)) ;; maintain caret-blinked invariant @@ -4979,7 +4980,9 @@ (dc . is-a? . printer-dc%))] [show-xsel? (and ALLOW-X-STYLE-SELECTION? - (or (not (eq? 'show-caret show-caret)) s-caret-snip) + (or (not (eq? 'show-caret show-caret)) + (not (pair? show-caret)) + s-caret-snip) (eq? this editor-x-selection-owner) (not flash?) (not (= endpos startpos)))]) @@ -5078,7 +5081,8 @@ (let ([line (mline-find-location (unbox line-root-box) starty)]) - (when bg-color + (when (and bg-color + (not (pair? show-caret))) (let ([lsave-pen (send dc get-pen)] [lsave-brush (send dc get-brush)]) (let ([wb (if (and (= 255 (send bg-color red)) @@ -5099,7 +5103,8 @@ (let* ([call-on-paint (lambda (pre?) (on-paint pre? dc leftx starty rightx endy dx dy - (if (not s-caret-snip) + (if (or (pair? show-caret) + (not s-caret-snip)) show-caret 'no-caret)))] [paint-done @@ -5123,7 +5128,8 @@ (cond [(not line) (send (send s-style-list basic-style) switch-to dc old-style) - (when (and (eq? 'show-caret show-caret) (not s-caret-snip) + (when (and (eq? 'show-caret show-caret) + (not s-caret-snip) extra-line? (not pos-at-eol?) (= len -startpos) @@ -5142,106 +5148,123 @@ [last (snip->next (mline-last-snip line))] [bottombase (+ ycounter (mline-bottombase line))] [topbase (+ ycounter (mline-topbase line))]) - (let-values ([(hilite-some? hsxs hsxe hsys hsye old-style) - (let sloop ([snip first] - [p pcounter] - [x (mline-get-left-location line max-width)] - [hilite-some? #f] - [hsxs 0.0] - [hsxe 0.0] - [hsys 0.0] - [hsye 0.0] - [old-style old-style]) - (if (eq? snip last) - (values hilite-some? hsxs hsxe hsys hsye old-style) - (begin - (send (snip->style snip) switch-to dc old-style) - (let ([old-style (snip->style snip)]) - (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) - (send snip get-extent dc x ycounter w h descent space #f #f) - (let* ([align (send (snip->style snip) get-alignment)] - [down - (cond - [(eq? 'bottom align) - (+ (- bottombase h) descent)] - [(eq? 'top align) - (- topbase space)] - [else - (- (/ (+ topbase bottombase) 2) - (/ (- h descent space) 2) - space)])]) + (define (process-snips draw? maybe-hilite? old-style) + (let sloop ([snip first] + [p pcounter] + [x (mline-get-left-location line max-width)] + [hilite-some? #f] + [hsxs 0.0] + [hsxe 0.0] + [hsys 0.0] + [hsye 0.0] + [old-style old-style]) + (if (eq? snip last) + (values hilite-some? hsxs hsxe hsys hsye old-style) + (begin + (send (snip->style snip) switch-to dc old-style) + (let ([old-style (snip->style snip)]) + (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) + (send snip get-extent dc x ycounter w h descent space #f #f) + (let* ([align (send (snip->style snip) get-alignment)] + [down + (cond + [(eq? 'bottom align) + (+ (- bottombase h) descent)] + [(eq? 'top align) + (- topbase space)] + [else + (- (/ (+ topbase bottombase) 2) + (/ (- h descent space) 2) + space)])]) - (when (and (x . <= . rightx) - ((+ x w) . >= . leftx)) - (send snip draw dc (+ x dx) (+ down dy) - tleftx tstarty trightx tendy - dx dy - (if (eq? snip s-caret-snip) - show-caret - 'no-caret))) + (when draw? + (when (and (x . <= . rightx) + ((+ x w) . >= . leftx)) + (send snip draw dc (+ x dx) (+ down dy) + tleftx tstarty trightx tendy + dx dy + (if (pair? show-caret) + (cons p (+ p (snip->count snip))) + (if (eq? snip s-caret-snip) + show-caret + (if (and maybe-hilite? + (endpos . > . p) + (startpos . < . (+ p (snip->count snip)))) + (cons (max 0 (- startpos p)) + (min (snip->count snip) (- endpos p))) + 'no-caret)))))) - ;; the rules for hiliting are surprisingly complicated: - (let ([hilite? - (and - hilite-on? - (or show-xsel? - (and (not s-caret-snip) - (or (eq? 'show-caret show-caret) - (and (show-caret . showcaret>= . s-inactive-caret-threshold) - (not (= -endpos -startpos)))))) - (if pos-at-eol? - (= -startpos (+ p (snip->count snip))) - (or (and (-startpos . < . (+ p (snip->count snip))) - (-endpos . >= . p) - (or (= -endpos -startpos) (-endpos . > . p))) - (and (= (+ p (snip->count snip)) len) - (= len -startpos)))) - (or (not (has-flag? (snip->flags snip) NEWLINE)) - ;; end of line: - (or (not (= -startpos (+ p (snip->count snip)))) - (and (= -endpos -startpos) pos-at-eol?) - (and (not (= -endpos -startpos)) - (-startpos . < . (+ p (snip->count snip)))))) - (or (not (eq? snip first)) - ;; beginning of line: - (or (not (= p -endpos)) - (and (= -endpos -startpos) (not pos-at-eol?)) - (and (not (= -endpos -startpos)) - (-endpos . > . p)))))]) - - (if hilite? - (let*-values ([(bottom) (+ down h)] - [(hxs) (if (-startpos . <= . p) - (if (-startpos . < . p) - 0 - x) - (+ x (send snip partial-offset dc x ycounter - (- -startpos p))))] - [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) - (if (has-flag? (snip->flags snip) NEWLINE) - (if (= -startpos -endpos) - (values hxs bottom) - (values rightx - (+ ycounter (mline-h line)))) - (values (+ x w) bottom)) - (values (+ x (send snip partial-offset dc x ycounter - (- -endpos p))) - bottom))]) - - (let-values ([(hsxs hsxe hsys hsye) - (if (not hilite-some?) - (values hxs hxe down bottom) - (values hsxs hxe (min down hsys) (max hsye bottom)))]) - (sloop (snip->next snip) - (+ p (snip->count snip)) - (+ x w) - #t hsxs hsxe hsys hsye - old-style))) - (sloop (snip->next snip) - (+ p (snip->count snip)) - (+ x w) - hilite-some? hsxs hsxe hsys hsye - old-style)))))))))]) + ;; the rules for hiliting are surprisingly complicated: + (let ([hilite? + (and + hilite-on? + (or show-xsel? + (and (not s-caret-snip) + (or (eq? 'show-caret show-caret) + (and (show-caret . showcaret>= . s-inactive-caret-threshold) + (not (= -endpos -startpos)))))) + (if pos-at-eol? + (= -startpos (+ p (snip->count snip))) + (or (and (-startpos . < . (+ p (snip->count snip))) + (-endpos . >= . p) + (or (= -endpos -startpos) (-endpos . > . p))) + (and (= (+ p (snip->count snip)) len) + (= len -startpos)))) + (or (not (has-flag? (snip->flags snip) NEWLINE)) + ;; end of line: + (or (not (= -startpos (+ p (snip->count snip)))) + (and (= -endpos -startpos) pos-at-eol?) + (and (not (= -endpos -startpos)) + (-startpos . < . (+ p (snip->count snip)))))) + (or (not (eq? snip first)) + ;; beginning of line: + (or (not (= p -endpos)) + (and (= -endpos -startpos) (not pos-at-eol?)) + (and (not (= -endpos -startpos)) + (-endpos . > . p)))))]) + + (if hilite? + (let*-values ([(bottom) (+ down h)] + [(hxs) (if (-startpos . <= . p) + (if (-startpos . < . p) + 0 + x) + (+ x (send snip partial-offset dc x ycounter + (- -startpos p))))] + [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) + (if (has-flag? (snip->flags snip) NEWLINE) + (if (= -startpos -endpos) + (values hxs bottom) + (values rightx + (+ ycounter (mline-h line)))) + (values (+ x w) bottom)) + (values (+ x (send snip partial-offset dc x ycounter + (- -endpos p))) + bottom))]) + + (let-values ([(hsxs hsxe hsys hsye) + (if (not hilite-some?) + (values hxs hxe down bottom) + (values hsxs hxe (min down hsys) (max hsye bottom)))]) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + #t hsxs hsxe hsys hsye + old-style))) + (sloop (snip->next snip) + (+ p (snip->count snip)) + (+ x w) + hilite-some? hsxs hsxe hsys hsye + old-style)))))))))) + (let*-values ([(draw-first?) + (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?) + (= -startpos -endpos) + (endpos . < . pcounter) + (startpos . > . (+ pcounter (mline-len line))))] + [(hilite-some? hsxs hsxe hsys hsye old-style) + (process-snips draw-first? #f old-style)]) (when (and (positive? wrap-bitmap-width) (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) last @@ -5314,11 +5337,17 @@ (send dc set-pen save-pen)))) prevwasfirst)) prevwasfirst)]) - (lloop (mline-next line) - old-style - (+ ycounter (mline-h line)) - (+ pcounter (mline-len line)) - prevwasfirst))))]))))))))) + (let ([old-style + (if draw-first? + old-style + (let-values ([(_hilite-some? _hsxs _hsxe _hsys _hsye old-style) + (process-snips #t #t old-style)]) + old-style))]) + (lloop (mline-next line) + old-style + (+ ycounter (mline-h line)) + (+ pcounter (mline-len line)) + prevwasfirst)))))]))))))))) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index 97d3d6d4..1be64b3f 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -52,7 +52,9 @@ family-symbol? style-symbol? weight-symbol? - smoothing-symbol?) + smoothing-symbol? + get-highlight-background-color + get-highlight-text-color) (define (get-double-click-threshold) (get-double-click-time)) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index cf630721..4720f272 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1549,7 +1549,9 @@ Returns @scheme[(make-object image-snip% filename kind relative-path? inline?)]. [bottom real?] [dx real?] [dy real?] - [draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)]) + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))]) void?]{ @methspec{ @@ -1888,7 +1890,9 @@ See also @method[editor<%> add-undo]. [y real?] [width (and/c real? (not/c negative?))] [height (and/c real? (not/c negative?))] - [draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)] + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))] [background (or/c (is-a?/c color%) #f)]) void?]{ diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 7bfd5d60..6558dc3a 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -601,8 +601,8 @@ When an editor contains other editors, it keeps track of caret appropriate sub-editor. When an editor or snip is drawn, an argument to the drawing method - specifies whether the caret should be drawn with the data. This - argument can be any of (in increasing order): + specifies whether the caret should be drawn with the data or whether + a selection spans the data. This argument can be any of: @itemize[ @@ -616,6 +616,11 @@ When an editor or snip is drawn, an argument to the drawing method @item{@indexed-scheme['show-caret] --- The caret should be drawn to show keyboard focus ownership.} + @item{@racket[(cons _start _end)] --- The caret is owned by an + enclosing region, and its selection spans the current editor or snip; + in the case of the snip, the selection spans elements @racket[_start] + through @racket[_end] positions within the snip.} + ] The @scheme['show-inactive-caret] display mode is useful for showing diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index c32cf3a2..a0291113 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -115,6 +115,18 @@ Returns the background color of a panel (usually some shade of gray) } + +@defproc[(get-highlight-background-color) (is-a?/c color%)]{ + +Returns the color drawn behind selected text.} + + +@defproc[(get-highlight-text-color) (or/c (is-a?/c color%) #f)]{ + +Returns the color used to draw selected text or @racket[#f] if +selected text is drawn with its usual color.} + + @defproc[(get-resource [section string?] [entry string?] [value (box/c (or/c string? exact-integer?))] diff --git a/collects/scribblings/gui/snip-class.scrbl b/collects/scribblings/gui/snip-class.scrbl index dd590f4a..33b5c46c 100644 --- a/collects/scribblings/gui/snip-class.scrbl +++ b/collects/scribblings/gui/snip-class.scrbl @@ -170,7 +170,9 @@ Called when the snip's editor's method is called, [bottom real?] [dx real?] [dy real?] - [draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)]) + [draw-caret (or/c (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?))]) void?]{ @methspec{ @@ -187,7 +189,11 @@ The @scheme[dx] and @scheme[dy] argument provide numbers that can be editor coordinates (as opposed to DC coordinates, which are used for drawing). -See @|drawcaretdiscuss| for information about @scheme[draw-caret]. +See @|drawcaretdiscuss| for information about +@scheme[draw-caret]. When @racket[draw-caret] is a pair, refrain from +drawing a background for the selected region, and use +@racket[get-highlight-text-color] when it is not @racket[#f] for +drawing text and other ``foreground'' elements. Before this method is called, the correct font, text color, and pen color for the snip's style will have been set in the drawing context diff --git a/doc/release-notes/racket/Draw_and_GUI_5_5.txt b/doc/release-notes/racket/Draw_and_GUI_5_5.txt index e70af0de..5ac70809 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_5.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_5.txt @@ -64,6 +64,14 @@ Changes to the drawing toolbox: * The old 'xor mode for pens and brushes is no longer available (since it is not supported by Cairo). + * The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or + `refresh' method can be a pair, which indicates that the caret is + owned by an enclosing display and the selection spans the snip or + editor. In that case, the snip or editor should refrain from + drawing a background for the selected region, and it should draw + the foreground in the color specified by + `get-highlight-text-color', if any. + Changes to the GUI toolbox: [Nothing to report, yet.]