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

win32: combo and cursor fixes

Browse Source 
original commit: 736607c28051a070c656b19d6a30b9385bbef73c
This commit is contained in:
Matthew Flatt 2010-10-09 20:07:47 -06:00
parent 6698d00cbb
commit c9d4a32c60
11 changed files with 230 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

177
collects/mred/private/wx/win32/canvas.rkt
View File

@ -14,15 +14,28 @@
"const.rkt"
"wndclass.rkt"
"window.rkt"
"dc.rkt")
"dc.rkt"
"item.rkt"
"theme.rkt")
(provide canvas%)
(define WS_EX_STATICEDGE #x00020000)
(define WS_EX_CLIENTEDGE #x00000200)
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL)
-> (unless r (failed 'ShowScrollbar))))
(define _HRGN _pointer)
(define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC))
(define DCX_WINDOW #x00000001)
(define EP_EDITTEXT 1)
(define ETS_NORMAL 1)
(define ETS_DISABLE 4)
(define-cstruct _SCROLLINFO
([cbSize _UINT]
[fMask _UINT]
@ -43,9 +56,11 @@
-> (r : _BOOL)
-> (if r i (error 'GetScrollInfo "failed"))))
(define COMBO-WIDTH 18)
(define canvas%
(canvas-mixin
(class window%
(class (item-mixin window%)
(init parent
x y w h
style
@ -54,27 +69,72 @@
(inherit get-hwnd
get-client-size
get-eventspace)
get-eventspace
set-control-font
subclass-control)
(define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style))
(define panel-hwnd
(and (memq 'combo style)
(CreateWindowExW 0
"PLTTabPanel"
#f
(bitwise-ior WS_CHILD)
0 0 w h
(send parent get-client-hwnd)
#f
hInstance
#f)))
(define canvas-hwnd
(CreateWindowExW (cond
[(memq 'border style) WS_EX_STATICEDGE]
[(memq 'control-border style) WS_EX_CLIENTEDGE]
[else 0])
"PLTCanvas"
#f
(bitwise-ior WS_CHILD
(if panel-hwnd WS_VISIBLE 0)
(if hscroll? WS_HSCROLL 0)
(if vscroll? WS_VSCROLL 0))
0 0 w h
(or panel-hwnd (send parent get-hwnd))
#f
hInstance
#f))
(define combo-hwnd
(and panel-hwnd
(CreateWindowExW 0
"PLTCOMBOBOX"
""
(bitwise-ior WS_CHILD WS_VISIBLE
CBS_DROPDOWNLIST
WS_HSCROLL WS_VSCROLL
WS_BORDER WS_CLIPSIBLINGS)
0 0 w h
panel-hwnd
#f
hInstance
#f)))
(define hwnd (or panel-hwnd canvas-hwnd))
(super-new [parent parent]
[hwnd
(CreateWindowExW 0
"PLTCanvas"
#f
(bitwise-ior WS_CHILD WS_VISIBLE
(if hscroll? WS_HSCROLL 0)
(if vscroll? WS_VSCROLL 0))
0 0 w h
(send parent get-hwnd)
#f
hInstance
#f)]
[hwnd hwnd]
[extra-hwnds (if panel-hwnd
(list canvas-hwnd combo-hwnd)
null)]
[style style])
(define hwnd (get-hwnd))
(when combo-hwnd
(set-control-font #f combo-hwnd)
(subclass-control combo-hwnd))
(define control-border-theme
(and (memq 'control-border style)
(OpenThemeData canvas-hwnd "Edit")))
(define/override (wndproc w msg wParam lParam default)
(cond
@ -87,6 +147,23 @@
(do-backing-flush this dc hdc))
(EndPaint hdc ps))
0]
[(= msg WM_NCPAINT)
(if control-border-theme
(let* ([r (GetWindowRect canvas-hwnd)]
[res (default w msg wParam lParam)]
[hdc (GetDCEx canvas-hwnd #f DCX_WINDOW)]
[wr (make-RECT 0 0
(- (RECT-right r) (RECT-left r))
(- (RECT-bottom r) (RECT-top r)))])
(DrawThemeBackground control-border-theme
hdc
EP_EDITTEXT
ETS_NORMAL ;; or ETS_DISABLED?
wr
#f)
(ReleaseDC canvas-hwnd hdc)
1)
(default w msg wParam lParam))]
[(= msg WM_HSCROLL)
(on-scroll-change SB_HORZ (LOWORD wParam))
0]
@ -95,6 +172,9 @@
0]
[else (super wndproc w msg wParam lParam default)]))
(define/override (wndproc-for-ctlproc w msg wParam lParam default)
(default w msg wParam lParam))
(define dc (new dc% [canvas this]))
(send dc start-backing-retained)
@ -103,6 +183,19 @@
(define/override (on-resized)
(send dc reset-backing-retained))
(define/override (get-client-hwnd)
canvas-hwnd)
(define/override (set-size x y w h)
(super set-size x y w h)
(when panel-hwnd
(let* ([r (and (or (= w -1) (= h -1))
(GetWindowRect hwnd))]
[w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)]
[h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)])
(MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t)
(MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t))))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin
(define/public (queue-paint) (void))
@ -113,7 +206,7 @@
(define/public (queue-canvas-refresh-event thunk)
(queue-window-refresh-event this thunk))
(define/public (get-flush-window) hwnd)
(define/public (get-flush-window) canvas-hwnd)
(define/public (begin-refresh-sequence)
(send dc suspend-flush))
@ -124,7 +217,7 @@
(define/override (refresh) (queue-paint))
(define/public (queue-backing-flush)
(InvalidateRect hwnd #f #f))
(InvalidateRect canvas-hwnd #f #f))
(define/public (make-compatible-bitmap w h)
(send dc make-backing-bitmap w h))
@ -154,11 +247,11 @@
(when hscroll?
(atomically
(set! h-scroll-visible? (and h? #t))
(ShowScrollBar hwnd SB_HORZ h?)))
(ShowScrollBar canvas-hwnd SB_HORZ h?)))
(when vscroll?
(atomically
(set! v-scroll-visible? (and v? #t))
(ShowScrollBar hwnd SB_VERT v?))))
(ShowScrollBar canvas-hwnd SB_VERT v?))))
(define/public (set-scrollbars h-step v-step
h-len v-len
@ -173,27 +266,27 @@
SIF_PAGE)
0 (+ len page -1) page pos 0))
(when hscroll?
(SetScrollInfo hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t))
(SetScrollInfo canvas-hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t))
(when vscroll?
(SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)))
(SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)))
(def/public-unimplemented set-background-to-gray)
(define/public (get-scroll-pos which)
(GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))
(GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))
(define/public (get-scroll-range which)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(+ (- (SCROLLINFO-nMax i)
(SCROLLINFO-nPage i))
1)))
(define/public (get-scroll-page which)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(SCROLLINFO-nPage i)))
(define/public (set-scroll-pos which v)
(void (SetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t)))
(void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t)))
(define/public (set-scroll-range which v)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE
(if (if (eq? which 'vertical)
v-scroll-visible?
@ -201,9 +294,9 @@
SIF_DISABLENOSCROLL
0)))
(set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1))
(SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(define/public (set-scroll-page which v)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE
(if (if (eq? which 'vertical)
v-scroll-visible?
@ -213,11 +306,11 @@
(set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i))
v))
(set-SCROLLINFO-nPage! i v)
(SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(define/public (on-scroll e) (void))
(define/private (on-scroll-change dir part)
(let ([i (GetScrollInfo hwnd dir)])
(let ([i (GetScrollInfo canvas-hwnd dir)])
(let ([new-pos
(cond
[(= part SB_TOP) 0]
@ -231,7 +324,7 @@
(unless (= new-pos (SCROLLINFO-nPos i))
(set-SCROLLINFO-nPos! i new-pos)
(set-SCROLLINFO-fMask! i SIF_POS)
(SetScrollInfo hwnd dir i #t)
(SetScrollInfo canvas-hwnd dir i #t)
(queue-window-event
this
(lambda ()
@ -244,12 +337,26 @@
(let loop () (pre-event-sync #t) (when (yield) (loop))))
(void))))))
(define/override (definitely-wants-event? e)
#t)
(define/override (definitely-wants-event? w e)
(or (e . is-a? . key-event%)
(ptr-equal? w canvas-hwnd)))
(define/public (on-combo-select i) (void))
(define/public (set-combo-text s) (void))
(define/public (append-combo-item s) (void))
(define/public (append-combo-item s)
(SendMessageW/str combo-hwnd CB_ADDSTRING 0 s))
(define/override (is-command? cmd)
(= cmd CBN_SELENDOK))
(define/public (do-command control-hwnd)
(let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)])
(queue-window-event this (lambda () (on-combo-select i)))))
(define/override (is-hwnd? a-hwnd)
(or (ptr-equal? panel-hwnd a-hwnd)
(ptr-equal? canvas-hwnd a-hwnd)
(ptr-equal? combo-hwnd a-hwnd)))
(def/public-unimplemented scroll)
(def/public-unimplemented warp-pointer)

8
collects/mred/private/wx/win32/choice.rkt
View File

@ -14,14 +14,6 @@
(provide choice%)
(define CBS_DROPDOWNLIST #x0003)
(define CB_INSERTSTRING #x014A)
(define CB_SETCURSEL #x014E)
(define CB_GETCURSEL #x0147)
(define CBN_SELENDOK 9)
(define CB_ADDSTRING #x0143)
(define CB_RESETCONTENT #x014B)
(define choice%
(class item%
(init parent cb label

7
collects/mred/private/wx/win32/const.rkt
View File

@ -612,3 +612,10 @@
(define HORZRES 8)
(define VERTRES 10)
(define CBS_DROPDOWNLIST #x0003)
(define CB_INSERTSTRING #x014A)
(define CB_SETCURSEL #x014E)
(define CB_GETCURSEL #x0147)
(define CBN_SELENDOK 9)
(define CB_ADDSTRING #x0143)
(define CB_RESETCONTENT #x014B)

5
collects/mred/private/wx/win32/frame.rkt
View File

@ -209,7 +209,7 @@
(SetFocus child-hwnd)))
(define/private (set-frame-focus)
(when focus-window-path
(when (pair? focus-window-path)
(SetFocus (send (last focus-window-path) get-focus-hwnd))))
(define/override (child-can-accept-focus?)
@ -280,7 +280,8 @@
(unless on? (error 'register-child-in-frame "did not expect #f"))
(unless (or (not saved-child) (eq? child saved-child))
(error 'register-child-in-frame "expected only one child"))
(set! saved-child child))
(set! saved-child child)
(send child set-arrow-cursor))
(define/override (register-child-in-parent on?)
(void))

5
collects/mred/private/wx/win32/item.rkt
View File

@ -56,7 +56,10 @@
(queue-window-event this (lambda () (on-kill-focus)))
(default w msg wParam lParam)]
[else
(wndproc w msg wParam lParam default)])))
(wndproc-for-ctlproc w msg wParam lParam default)])))
(define/public (wndproc-for-ctlproc w msg wParam lParam default)
(wndproc w msg wParam lParam default))
(define/public (default-ctlproc w msg wParam lParam)
(let loop ([l old-control-procs])

22
collects/mred/private/wx/win32/panel.rkt
View File

@ -3,7 +3,8 @@
"../../syntax.rkt"
"window.rkt"
"wndclass.rkt"
"const.rkt")
"const.rkt"
"cursor.rkt")
(provide panel-mixin
panel%)
@ -35,10 +36,11 @@
(define mouse-in-child #f)
(define/override (generate-mouse-ins in-window mk)
(unless (eq? in-window mouse-in-child)
(when mouse-in-child
(send mouse-in-child send-leaves mk))
(set! mouse-in-child in-window))
(unless (eq? in-window this)
(unless (eq? in-window mouse-in-child)
(when mouse-in-child
(send mouse-in-child send-leaves mk))
(set! mouse-in-child in-window)))
(super generate-mouse-ins in-window mk))
(define/override (reset-cursor default)
@ -89,4 +91,12 @@
#f
hInstance
#f)]
[style style])))
[style style])
;; For panel in a frame, adjust default cursor to arrow:
(define arrow-cursor? #f)
(define/public (set-arrow-cursor) (set! arrow-cursor? #t))
(define/override (generate-parent-mouse-ins mk)
(or (super generate-parent-mouse-ins mk)
(and arrow-cursor?
(get-arrow-cursor))))))

5
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -44,7 +44,8 @@
(define callback void)
(inherit auto-size set-control-font
is-shown-to-root?)
is-shown-to-root?
subclass-control)
(define hwnd
(CreateWindowExW 0
@ -74,6 +75,8 @@
[hwnd hwnd]
[style style])
(subclass-control hwnd)
(define/override (get-client-hwnd)
client-hwnd)

17
collects/mred/private/wx/win32/theme.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/alloc
"utils.ss"
"const.ss"
"types.ss")
@ -8,7 +9,11 @@
get-theme-font-face
get-theme-font-size
_LOGFONT-pointer
OpenThemeData
CloseThemeData
DrawThemeParentBackground
DrawThemeBackground
DrawThemeEdge
EnableThemeDialogTexture)
(define _HTHEME (_cpointer 'HTHEME))
@ -45,10 +50,12 @@
[lfPitchAndFamily _BYTE]
[lfFaceName _FaceName])) ; 32 of them
(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME))
(define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT)
-> (when (negative? r)
(error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r)))))
(error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))
#:wrap (deallocator))
(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME)
#:wrap (allocator CloseThemeData))
(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT))
-> (r : _HRESULT)
-> (if (negative? r)
@ -61,9 +68,15 @@
(error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r))
f)))
(define-uxtheme DrawThemeBackground (_wfun _HTHEME _HDC _int _int _RECT-pointer (_or-null _RECT-pointer) -> (r : _HRESULT)
-> (when (negative? r)
(error 'DrawThemeBackground "failed: ~s" (bitwise-and #xFFFF r)))))
(define-uxtheme DrawThemeParentBackground (_wfun _HWND _HDC _pointer -> (r : _HRESULT)
-> (when (negative? r)
(error 'DrawThemeParentBackground "failed: ~s" (bitwise-and #xFFFF r)))))
(define-uxtheme DrawThemeEdge (_wfun _HWND _HDC _int _int _RECT-pointer _int _int _RECT-pointer -> (r : _HRESULT)
-> (when (negative? r)
(error 'DrawThemeEdge "failed: ~s" (bitwise-and #xFFFF r)))))
(define-uxtheme EnableThemeDialogTexture (_wfun _HWND _DWORD -> (r : _HRESULT)
-> (when (negative? r)

30
collects/mred/private/wx/win32/window.rkt
View File

@ -129,21 +129,21 @@
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key wParam lParam #f #f))]
(do-key w wParam lParam #f #f))]
[(= msg WM_KEYDOWN)
(do-key wParam lParam #f #f)
(do-key w wParam lParam #f #f)
0]
[(= msg WM_KEYUP)
(do-key wParam lParam #f #t)
(do-key w wParam lParam #f #t)
0]
[(and (= msg WM_SYSCHAR)
(= wParam VK_MENU))
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key wParam lParam #t #f))]
(do-key w wParam lParam #t #f))]
[(= msg WM_CHAR)
(do-key wParam lParam #t #f)
(do-key w wParam lParam #t #f)
0]
[(= msg WM_COMMAND)
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
@ -391,10 +391,10 @@
(define/public (get-top-frame)
(send parent get-top-frame))
(define/private (do-key wParam lParam is-char? is-up?)
(define/private (do-key w wParam lParam is-char? is-up?)
(let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])
(and e
(if (definitely-wants-event? e)
(if (definitely-wants-event? w e)
(begin
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
#t)
@ -495,10 +495,10 @@
c))))))
(when (memq type '(left-down right-down middle-down))
(set-focus))
(handle-mouse-event (make-e type)))))
(handle-mouse-event control-hwnd (make-e type)))))
(define (handle-mouse-event e)
(if (definitely-wants-event? e)
(define/private (handle-mouse-event w e)
(if (definitely-wants-event? w e)
(begin
(queue-window-event this (lambda () (dispatch-on-event/sync e)))
#t)
@ -513,8 +513,10 @@
(begin
(set! mouse-in? #t)
(let ([parent-cursor (generate-parent-mouse-ins mk)])
(handle-mouse-event (mk 'enter))
(or cursor-handle parent-cursor)))))
(handle-mouse-event #f (mk 'enter))
(let ([c (or cursor-handle parent-cursor)])
(set! effective-cursor-handle c)
c)))))
(define/public (generate-parent-mouse-ins mk)
(send parent generate-mouse-ins this mk))
@ -523,14 +525,14 @@
(set! mouse-in? #f)
(let ([e (mk 'leave)])
(if (eq? (current-eventspace) (get-eventspace))
(handle-mouse-event e)
(handle-mouse-event #f e)
(queue-window-event this
(lambda () (dispatch-on-event/sync e))))))
(define/public (send-child-leaves mk)
#f)
(define/public (definitely-wants-event? e)
(define/public (definitely-wants-event? w e)
#f)
(define/public (dispatch-on-char/sync e)

2
collects/mred/private/wx/win32/wndclass.rkt
View File

@ -100,7 +100,7 @@
#f ; menu
"PLTFrame")))
(void (RegisterClassW (make-WNDCLASS 0 ; not CS_OWNDC !
(void (RegisterClassW (make-WNDCLASS CS_OWNDC
wind-proc
0
0

40
collects/mred/private/wxme/editor-canvas.rkt
View File

@ -391,24 +391,28 @@
(send event button-down?))
(set-focus)
(on-focus #t))
(when (and media
(not (send media get-printing)))
(using-admin
(when media
(set-custom-cursor
(send media adjust-cursor event)))
(when media
(send media on-event event))))
(when (send event dragging?)
(let-boxes ([cw 0]
[ch 0])
(get-client-size cw ch)
(when (or (x . < . 0)
(y . < . 0)
(x . > . cw)
(y . > . ch))
(let ([out-of-client?
(let-boxes ([cw 0]
[ch 0])
(get-client-size cw ch)
(or (x . < . 0)
(y . < . 0)
(x . > . cw)
(y . > . ch)))])
(when (and media
(not (send media get-printing)))
(using-admin
(when media
(set-custom-cursor
(and (not out-of-client?)
(send media adjust-cursor event))))
(when media
(send media on-event event))))
(when (send event dragging?)
(when out-of-client?
;; Dragging outside the canvas: auto-generate more events because the buffer
;; is probably scrolling. But make sure we're shown.
(when (is-shown-to-root?)