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

2
collects/mred/mred.rkt
View File

@ -132,6 +132,8 @@
font%
font-list%
font-name-directory<%>
get-highlight-background-color
get-highlight-text-color
get-resource
get-the-editor-data-class-list
get-the-snip-class-list

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

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

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

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

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
(_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))))

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

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

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

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

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

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

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
g_object_ref
g_object_ref_sink
g_object_unref
gobject-ref

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

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

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

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

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

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

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

@ -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,6 +358,10 @@
caret bg-color))
(when with-border?
(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
@ -384,7 +389,9 @@
(when (and (b . >= . top)
(b . < . bottom)
(ml . < . mr))
(send dc draw-line ml b mr b)))))))))))
(send dc draw-line ml b mr b))))
(when (pair? caret)
(send dc set-pen pen))))))))))
(def/override (copy)
(let* ([mb (and editor

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

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

51
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 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,7 +5148,7 @@
[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)
(define (process-snips draw? maybe-hilite? old-style)
(let sloop ([snip first]
[p pcounter]
[x (mline-get-left-location line max-width)]
@ -5171,14 +5177,22 @@
(/ (- h descent space) 2)
space)])])
(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
'no-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?
@ -5241,7 +5255,16 @@
(+ p (snip->count snip))
(+ x w)
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)
(not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE))
last
@ -5314,11 +5337,17 @@
(send dc set-pen save-pen))))
prevwasfirst))
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))))])))))))))
prevwasfirst)))))])))))))))
;; ----------------------------------------

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

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

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?]
[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?]{

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.
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

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?]
[entry string?]
[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?]
[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

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
(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.]