suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

generalize editor selection mechanism to support Windows style

Browse Source 
original commit: ae05eddf1437b8ae465d9bdfe8a605f7db022765
This commit is contained in:
Matthew Flatt 2010-09-07 07:36:52 -06:00
parent 627a12a4f4
commit b4d34b0b32
21 changed files with 367 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mred/mred.rkt
View File

@ -132,7 +132,9 @@
font% font%
font-list% font-list%
font-name-directory<%> font-name-directory<%>
get-resource get-highlight-background-color
get-highlight-text-color
get-resource
get-the-editor-data-class-list get-the-editor-data-class-list
get-the-snip-class-list get-the-snip-class-list
image-snip% image-snip%
@ -271,7 +273,7 @@
get-display-left-top-inset get-display-left-top-inset
get-color-from-user get-color-from-user
get-font-from-user get-font-from-user
append-editor-operation-menu-items append-editor-operation-menu-items
append-editor-font-menu-items append-editor-font-menu-items
get-top-level-focus-window get-top-level-focus-window
get-top-level-edit-target-window get-top-level-edit-target-window

4
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -101,4 +101,6 @@
application-quit-handler application-quit-handler
application-file-handler application-file-handler
special-option-key special-option-key
special-control-key)) special-control-key
get-highlight-background-color
get-highlight-text-color))

27
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -55,7 +55,9 @@
get-the-x-selection get-the-x-selection
get-the-clipboard get-the-clipboard
show-print-setup show-print-setup
can-show-print-setup?) can-show-print-setup?
get-highlight-background-color
get-highlight-text-color)
(import-class NSScreen NSCursor) (import-class NSScreen NSCursor)
@ -117,3 +119,26 @@
(define-unimplemented get-the-clipboard) (define-unimplemented get-the-clipboard)
(define-unimplemented show-print-setup) (define-unimplemented show-print-setup)
(define (can-show-print-setup?) #t) (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)

21
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -275,24 +275,3 @@
(set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event
(_fun #:atomic? #t (_fun #:atomic? #t
_float _pointer -> _void)))) _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))))

2
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -173,8 +173,6 @@
(queue-window-event wx (lambda () (send wx do-scroll dir))))) (queue-window-event wx (lambda () (send wx do-scroll dir)))))
#t) #t)
(define-gtk gtk_entry_get_type (_fun -> _GType))
(define canvas% (define canvas%
(class (client-size-mixin window%) (class (client-size-mixin window%)
(init parent (init parent

4
collects/mred/private/wx/gtk/platform.rkt
View File

@ -101,4 +101,6 @@
application-quit-handler application-quit-handler
application-file-handler application-file-handler
special-option-key special-option-key
special-control-key)) special-control-key
get-highlight-background-color
get-highlight-text-color))

13
collects/mred/private/wx/gtk/procs.rkt
View File

@ -7,6 +7,7 @@
"filedialog.rkt" "filedialog.rkt"
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"style.rkt"
"widget.rkt" "widget.rkt"
"../common/handlers.rkt") "../common/handlers.rkt")
@ -58,7 +59,9 @@
get-the-x-selection get-the-x-selection
get-the-clipboard get-the-clipboard
show-print-setup 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-unimplemented special-control-key)
(define (special-option-key on?) (void)) (define (special-option-key on?) (void))
@ -125,3 +128,11 @@
(define-unimplemented get-the-clipboard) (define-unimplemented get-the-clipboard)
(define-unimplemented show-print-setup) (define-unimplemented show-print-setup)
(define (can-show-print-setup?) #f) (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)))

85
collects/mred/private/wx/gtk/style.rkt Normal file
View File

@ -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)))

1
collects/mred/private/wx/gtk/utils.rkt
View File

@ -15,6 +15,7 @@
define-mz define-mz
g_object_ref g_object_ref
g_object_ref_sink
g_object_unref g_object_unref
gobject-ref gobject-ref

4
collects/mred/private/wx/platform.rkt
View File

@ -79,5 +79,7 @@
application-quit-handler application-quit-handler
application-file-handler application-file-handler
special-option-key special-option-key
special-control-key) special-control-key
get-highlight-background-color
get-highlight-text-color)
((dynamic-require platform-lib 'platform-values))) ((dynamic-require platform-lib 'platform-values)))

4
collects/mred/private/wx/win32/platform.rkt
View File

@ -100,4 +100,6 @@
application-quit-handler application-quit-handler
application-file-handler application-file-handler
special-option-key special-option-key
special-control-key)) special-control-key
get-highlight-background-color
get-highlight-text-color))

6
collects/mred/private/wx/win32/procs.rkt
View File

@ -49,7 +49,9 @@
get-the-x-selection get-the-x-selection
get-the-clipboard get-the-clipboard
show-print-setup 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-unimplemented special-control-key)
@ -103,3 +105,5 @@
(define-unimplemented get-the-clipboard) (define-unimplemented get-the-clipboard)
(define-unimplemented show-print-setup) (define-unimplemented show-print-setup)
(define-unimplemented can-show-print-setup?) (define-unimplemented can-show-print-setup?)
(define-unimplemented get-highlight-background-color)
(define-unimplemented get-highlight-text-color)

65
collects/mred/private/wxme/editor-snip.rkt
View File

@ -284,7 +284,7 @@
(def/override (draw [dc<%> dc] [real? x] [real? y] (def/override (draw [dc<%> dc] [real? x] [real? y]
[real? left] [real? top] [real? right] [real? bottom] [real? left] [real? top] [real? right] [real? bottom]
[real? dx] [real? dy] [symbol? caret]) [real? dx] [real? dy] [caret-status? caret])
(send my-admin (send my-admin
with-dc with-dc
dc x y dc x y
@ -320,6 +320,7 @@
(let ([bg-color (let ([bg-color
(cond (cond
[(pair? caret) #f]
[(not use-style-bg?) [(not use-style-bg?)
(make-object color% 255 255 255)] (make-object color% 255 255 255)]
[(send s-style get-transparent-text-backing) [(send s-style get-transparent-text-backing)
@ -357,34 +358,40 @@
caret bg-color)) caret bg-color))
(when with-border? (when with-border?
(let* ([l (+ orig-x left-inset)] (let ([pen (send dc get-pen)])
[t (+ orig-y top-inset)] (when (and (pair? caret)
[r (+ l w left-margin right-margin selected-text-color)
(- (+ left-inset right-inset)) (send dc set-pen selected-text-color 1 'solid))
-1)] (let* ([l (+ orig-x left-inset)]
[b (+ t h top-margin bottom-margin [t (+ orig-y top-inset)]
(- (+ top-inset bottom-inset)) [r (+ l w left-margin right-margin
-1)]) (- (+ left-inset right-inset))
(let ([ml (max (min l right) left)] -1)]
[mr (max (min r right) left)] [b (+ t h top-margin bottom-margin
[mt (max (min t bottom) top)] (- (+ top-inset bottom-inset))
[mb (max (min b bottom) top)]) -1)])
(when (and (l . >= . left) (let ([ml (max (min l right) left)]
(l . < . right) [mr (max (min r right) left)]
(mt . < . mb)) [mt (max (min t bottom) top)]
(send dc draw-line l mt l mb)) [mb (max (min b bottom) top)])
(when (and (r . >= . left) (when (and (l . >= . left)
(r . < . right) (l . < . right)
(mt . < . mb)) (mt . < . mb))
(send dc draw-line r mt r mb)) (send dc draw-line l mt l mb))
(when (and (t . >= . top) (when (and (r . >= . left)
(t . < . bottom) (r . < . right)
(ml . < . mr)) (mt . < . mb))
(send dc draw-line ml t mr t)) (send dc draw-line r mt r mb))
(when (and (b . >= . top) (when (and (t . >= . top)
(b . < . bottom) (t . < . bottom)
(ml . < . mr)) (ml . < . mr))
(send dc draw-line ml b mr b))))))))))) (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) (def/override (copy)
(let* ([mb (and editor (let* ([mb (and editor

4
collects/mred/private/wxme/editor.rkt
View File

@ -1266,14 +1266,14 @@
#f)) #f))
(def/public (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] (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]) [(make-or-false color%) bg-color])
(void)) (void))
(def/public (on-paint [any? pre?] [dc<%> dc] (def/public (on-paint [any? pre?] [dc<%> dc]
[real? l] [real? t] [real? r] [real? b] [real? l] [real? t] [real? r] [real? b]
[real? dx] [real? dy] [real? dx] [real? dy]
[(symbol-in no-caret show-inactive-caret show-caret) show-caret]) [caret-status? show-caret])
(void)) (void))
(def/public (can-save-file? [path-string? filename] (def/public (can-save-file? [path-string? filename]

245
collects/mred/private/wxme/text.rkt
View File

@ -47,8 +47,8 @@
(define caret-pen (send the-pen-list find-or-create-pen "BLACK" 1 'xor)) (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-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-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 "BLACK" 'hilite)) (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 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%)]) (define outline-nonowner-brush (let ([b (new brush%)])
(send b set-color "BLACK") (send b set-color "BLACK")
@ -4933,7 +4933,7 @@
;; called by the administrator to trigger a redraw ;; called by the administrator to trigger a redraw
(def/override (refresh [real? left] [real? top] [nonnegative-real? width] [nonnegative-real? height] (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]) [(make-or-false color%) bg-color])
(cond (cond
[(or (width . <= . 0) (height . <= . 0)) (void)] [(or (width . <= . 0) (height . <= . 0)) (void)]
@ -4955,6 +4955,7 @@
(let ([show-caret (let ([show-caret
(if (and caret-blinked? (if (and caret-blinked?
(not (pair? show-caret))
(not (eq? show-caret 'no-caret)) (not (eq? show-caret 'no-caret))
(not s-caret-snip)) (not s-caret-snip))
;; maintain caret-blinked invariant ;; maintain caret-blinked invariant
@ -4979,7 +4980,9 @@
(dc . is-a? . printer-dc%))] (dc . is-a? . printer-dc%))]
[show-xsel? [show-xsel?
(and ALLOW-X-STYLE-SELECTION? (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) (eq? this editor-x-selection-owner)
(not flash?) (not flash?)
(not (= endpos startpos)))]) (not (= endpos startpos)))])
@ -5078,7 +5081,8 @@
(let ([line (mline-find-location (unbox line-root-box) starty)]) (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)] (let ([lsave-pen (send dc get-pen)]
[lsave-brush (send dc get-brush)]) [lsave-brush (send dc get-brush)])
(let ([wb (if (and (= 255 (send bg-color red)) (let ([wb (if (and (= 255 (send bg-color red))
@ -5099,7 +5103,8 @@
(let* ([call-on-paint (let* ([call-on-paint
(lambda (pre?) (lambda (pre?)
(on-paint pre? dc leftx starty rightx endy dx dy (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 show-caret
'no-caret)))] 'no-caret)))]
[paint-done [paint-done
@ -5123,7 +5128,8 @@
(cond (cond
[(not line) [(not line)
(send (send s-style-list basic-style) switch-to dc old-style) (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? extra-line?
(not pos-at-eol?) (not pos-at-eol?)
(= len -startpos) (= len -startpos)
@ -5142,106 +5148,123 @@
[last (snip->next (mline-last-snip line))] [last (snip->next (mline-last-snip line))]
[bottombase (+ ycounter (mline-bottombase line))] [bottombase (+ ycounter (mline-bottombase line))]
[topbase (+ ycounter (mline-topbase line))]) [topbase (+ ycounter (mline-topbase line))])
(let-values ([(hilite-some? hsxs hsxe hsys hsye old-style) (define (process-snips draw? maybe-hilite? old-style)
(let sloop ([snip first] (let sloop ([snip first]
[p pcounter] [p pcounter]
[x (mline-get-left-location line max-width)] [x (mline-get-left-location line max-width)]
[hilite-some? #f] [hilite-some? #f]
[hsxs 0.0] [hsxs 0.0]
[hsxe 0.0] [hsxe 0.0]
[hsys 0.0] [hsys 0.0]
[hsye 0.0] [hsye 0.0]
[old-style old-style]) [old-style old-style])
(if (eq? snip last) (if (eq? snip last)
(values hilite-some? hsxs hsxe hsys hsye old-style) (values hilite-some? hsxs hsxe hsys hsye old-style)
(begin (begin
(send (snip->style snip) switch-to dc old-style) (send (snip->style snip) switch-to dc old-style)
(let ([old-style (snip->style snip)]) (let ([old-style (snip->style snip)])
(let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) (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) (send snip get-extent dc x ycounter w h descent space #f #f)
(let* ([align (send (snip->style snip) get-alignment)] (let* ([align (send (snip->style snip) get-alignment)]
[down [down
(cond (cond
[(eq? 'bottom align) [(eq? 'bottom align)
(+ (- bottombase h) descent)] (+ (- bottombase h) descent)]
[(eq? 'top align) [(eq? 'top align)
(- topbase space)] (- topbase space)]
[else [else
(- (/ (+ topbase bottombase) 2) (- (/ (+ topbase bottombase) 2)
(/ (- h descent space) 2) (/ (- h descent space) 2)
space)])]) space)])])
(when (and (x . <= . rightx) (when draw?
((+ x w) . >= . leftx)) (when (and (x . <= . rightx)
(send snip draw dc (+ x dx) (+ down dy) ((+ x w) . >= . leftx))
tleftx tstarty trightx tendy (send snip draw dc (+ x dx) (+ down dy)
dx dy tleftx tstarty trightx tendy
(if (eq? snip s-caret-snip) dx dy
show-caret (if (pair? show-caret)
'no-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: ;; the rules for hiliting are surprisingly complicated:
(let ([hilite? (let ([hilite?
(and (and
hilite-on? hilite-on?
(or show-xsel? (or show-xsel?
(and (not s-caret-snip) (and (not s-caret-snip)
(or (eq? 'show-caret show-caret) (or (eq? 'show-caret show-caret)
(and (show-caret . showcaret>= . s-inactive-caret-threshold) (and (show-caret . showcaret>= . s-inactive-caret-threshold)
(not (= -endpos -startpos)))))) (not (= -endpos -startpos))))))
(if pos-at-eol? (if pos-at-eol?
(= -startpos (+ p (snip->count snip))) (= -startpos (+ p (snip->count snip)))
(or (and (-startpos . < . (+ p (snip->count snip))) (or (and (-startpos . < . (+ p (snip->count snip)))
(-endpos . >= . p) (-endpos . >= . p)
(or (= -endpos -startpos) (-endpos . > . p))) (or (= -endpos -startpos) (-endpos . > . p)))
(and (= (+ p (snip->count snip)) len) (and (= (+ p (snip->count snip)) len)
(= len -startpos)))) (= len -startpos))))
(or (not (has-flag? (snip->flags snip) NEWLINE)) (or (not (has-flag? (snip->flags snip) NEWLINE))
;; end of line: ;; end of line:
(or (not (= -startpos (+ p (snip->count snip)))) (or (not (= -startpos (+ p (snip->count snip))))
(and (= -endpos -startpos) pos-at-eol?) (and (= -endpos -startpos) pos-at-eol?)
(and (not (= -endpos -startpos)) (and (not (= -endpos -startpos))
(-startpos . < . (+ p (snip->count snip)))))) (-startpos . < . (+ p (snip->count snip))))))
(or (not (eq? snip first)) (or (not (eq? snip first))
;; beginning of line: ;; beginning of line:
(or (not (= p -endpos)) (or (not (= p -endpos))
(and (= -endpos -startpos) (not pos-at-eol?)) (and (= -endpos -startpos) (not pos-at-eol?))
(and (not (= -endpos -startpos)) (and (not (= -endpos -startpos))
(-endpos . > . p)))))]) (-endpos . > . p)))))])
(if hilite? (if hilite?
(let*-values ([(bottom) (+ down h)] (let*-values ([(bottom) (+ down h)]
[(hxs) (if (-startpos . <= . p) [(hxs) (if (-startpos . <= . p)
(if (-startpos . < . p) (if (-startpos . < . p)
0 0
x) x)
(+ x (send snip partial-offset dc x ycounter (+ x (send snip partial-offset dc x ycounter
(- -startpos p))))] (- -startpos p))))]
[(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip))) [(hxe bottom) (if (-endpos . >= . (+ p (snip->count snip)))
(if (has-flag? (snip->flags snip) NEWLINE) (if (has-flag? (snip->flags snip) NEWLINE)
(if (= -startpos -endpos) (if (= -startpos -endpos)
(values hxs bottom) (values hxs bottom)
(values rightx (values rightx
(+ ycounter (mline-h line)))) (+ ycounter (mline-h line))))
(values (+ x w) bottom)) (values (+ x w) bottom))
(values (+ x (send snip partial-offset dc x ycounter (values (+ x (send snip partial-offset dc x ycounter
(- -endpos p))) (- -endpos p)))
bottom))]) bottom))])
(let-values ([(hsxs hsxe hsys hsye) (let-values ([(hsxs hsxe hsys hsye)
(if (not hilite-some?) (if (not hilite-some?)
(values hxs hxe down bottom) (values hxs hxe down bottom)
(values hsxs hxe (min down hsys) (max hsye bottom)))]) (values hsxs hxe (min down hsys) (max hsye bottom)))])
(sloop (snip->next snip) (sloop (snip->next snip)
(+ p (snip->count snip)) (+ p (snip->count snip))
(+ x w) (+ x w)
#t hsxs hsxe hsys hsye #t hsxs hsxe hsys hsye
old-style))) old-style)))
(sloop (snip->next snip) (sloop (snip->next snip)
(+ p (snip->count snip)) (+ p (snip->count snip))
(+ x w) (+ x w)
hilite-some? hsxs hsxe hsys hsye hilite-some? hsxs hsxe hsys hsye
old-style)))))))))]) 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) (when (and (positive? wrap-bitmap-width)
(not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE))
last last
@ -5314,11 +5337,17 @@
(send dc set-pen save-pen)))) (send dc set-pen save-pen))))
prevwasfirst)) prevwasfirst))
prevwasfirst)]) prevwasfirst)])
(lloop (mline-next line) (let ([old-style
old-style (if draw-first?
(+ ycounter (mline-h line)) old-style
(+ pcounter (mline-len line)) (let-values ([(_hilite-some? _hsxs _hsxe _hsys _hsye old-style)
prevwasfirst))))]))))))))) (process-snips #t #t old-style)])
old-style))])
(lloop (mline-next line)
old-style
(+ ycounter (mline-h line))
(+ pcounter (mline-len line))
prevwasfirst)))))])))))))))
;; ---------------------------------------- ;; ----------------------------------------

4
collects/mred/private/wxme/wx.rkt
View File

@ -52,7 +52,9 @@
family-symbol? family-symbol?
style-symbol? style-symbol?
weight-symbol? weight-symbol?
smoothing-symbol?) smoothing-symbol?
get-highlight-background-color
get-highlight-text-color)
(define (get-double-click-threshold) (define (get-double-click-threshold)
(get-double-click-time)) (get-double-click-time))

8
collects/scribblings/gui/editor-intf.scrbl
View File

@ -1549,7 +1549,9 @@ Returns @scheme[(make-object image-snip% filename kind relative-path? inline?)].
[bottom real?] [bottom real?]
[dx real?] [dx real?]
[dy 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?]{ void?]{
@methspec{ @methspec{
@ -1888,7 +1890,9 @@ See also @method[editor<%> add-undo].
[y real?] [y real?]
[width (and/c real? (not/c negative?))] [width (and/c real? (not/c negative?))]
[height (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)]) [background (or/c (is-a?/c color%) #f)])
void?]{ void?]{

9
collects/scribblings/gui/editor-overview.scrbl
View File

@ -601,8 +601,8 @@ When an editor contains other editors, it keeps track of caret
appropriate sub-editor. appropriate sub-editor.
When an editor or snip is drawn, an argument to the drawing method When an editor or snip is drawn, an argument to the drawing method
specifies whether the caret should be drawn with the data. This specifies whether the caret should be drawn with the data or whether
argument can be any of (in increasing order): a selection spans the data. This argument can be any of:
@itemize[ @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 @item{@indexed-scheme['show-caret] --- The caret should be drawn to show
keyboard focus ownership.} 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 The @scheme['show-inactive-caret] display mode is useful for showing

12
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -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?] @defproc[(get-resource [section string?]
[entry string?] [entry string?]
[value (box/c (or/c string? exact-integer?))] [value (box/c (or/c string? exact-integer?))]

10
collects/scribblings/gui/snip-class.scrbl
View File

@ -170,7 +170,9 @@ Called when the snip's editor's method is called,
[bottom real?] [bottom real?]
[dx real?] [dx real?]
[dy 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?]{ void?]{
@methspec{ @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 editor coordinates (as opposed to DC coordinates, which are used for
drawing). 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 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 color for the snip's style will have been set in the drawing context

8
doc/release-notes/racket/Draw_and_GUI_5_5.txt
View File

@ -64,6 +64,14 @@ Changes to the drawing toolbox:
* The old 'xor mode for pens and brushes is no longer available * The old 'xor mode for pens and brushes is no longer available
(since it is not supported by Cairo). (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: Changes to the GUI toolbox:
[Nothing to report, yet.] [Nothing to report, yet.]