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

win32 widgets, mouse events, and cursors

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-27 05:37:59 -06:00
parent 1402583ad2
commit 604afc1803
35 changed files with 907 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -11,6 +11,7 @@
/*.pdb
/*.ilk
/GRacket.exe.manifest
/Racket.exe.manifest
# a common convenient place to set the PLTADDON directory to
/add-on/

12
collects/mred/private/gdi.rkt
View File

@ -238,9 +238,15 @@
[(windows) 1]
[else 2]))
(define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system))
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system))
(define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system
'normal 'normal #f 'default
(wx:get-control-font-size-in-pixels?)))
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system
'normal 'normal #f 'default
(wx:get-control-font-size-in-pixels?)))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system
'normal 'normal #f 'default
(wx:get-control-font-size-in-pixels?)))
(define view-control-font (if (eq? 'macosx (system-type))
(make-object wx:font% (- (wx:get-control-font-size) 1) 'system)
normal-control-font))

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

@ -68,6 +68,7 @@
fill-private-color
cancel-quit
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type

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

@ -33,6 +33,7 @@
run-printout
get-double-click-time
get-control-font-size
get-control-font-size-in-pixels?
cancel-quit
fill-private-color
flush-display
@ -75,6 +76,7 @@
(define (get-double-click-time)
500)
(define (get-control-font-size) 13)
(define (get-control-font-size-in-pixels?) #f)
(define (cancel-quit) (void))
(define-unimplemented fill-private-color)
(define-unimplemented write-resource)

4
collects/mred/private/wx/common/cursor-draw.rkt
View File

@ -8,10 +8,10 @@
draw-ne/sw
draw-bullseye)
(define (make-cursor-image draw-proc)
(define (make-cursor-image draw-proc [smoothing 'aligned])
(let* ([bm (make-object bitmap% 16 16 #f #t)]
[dc (make-object bitmap-dc% bm)])
(send dc set-smoothing 'aligned)
(send dc set-smoothing smoothing)
(draw-proc dc 16 16)
(send dc set-bitmap #f)
bm))

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

@ -68,6 +68,7 @@
fill-private-color
cancel-quit
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type

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

@ -31,6 +31,7 @@
get-double-click-time
key-symbol-to-integer
get-control-font-size
get-control-font-size-in-pixels?
cancel-quit
fill-private-color
flush-display
@ -75,6 +76,7 @@
(define (get-double-click-time) 250)
(define-unimplemented key-symbol-to-integer)
(define (get-control-font-size) 10) ;; FIXME
(define (get-control-font-size-in-pixels?) #f) ;; FIXME
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)

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

@ -48,6 +48,7 @@
fill-private-color
cancel-quit
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type

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

@ -19,7 +19,8 @@
(define base-button%
(class item%
(inherit set-control-font auto-size get-hwnd)
(inherit set-control-font auto-size get-hwnd
subclass-control)
(init parent cb label x y w h style font)
@ -29,7 +30,7 @@
(and (label . is-a? . bitmap%)
(send label ok?)))
(define/public (get-class) "BUTTON")
(define/public (get-class) "PLTBUTTON")
(define/public (get-flags) BS_PUSHBUTTON)
(super-new [parent parent]
@ -64,6 +65,8 @@
(auto-size label 40 12 12 0)]))
(auto-size-button label)
(subclass-control (get-hwnd))
(define/override (is-command? cmd)
(= cmd BN_CLICKED))

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

@ -250,6 +250,10 @@
(define/override (definitely-wants-event? e)
#t)
(define/public (on-combo-select i) (void))
(define/public (set-combo-text s) (void))
(define/public (append-combo-item s) (void))
(def/public-unimplemented scroll)
(def/public-unimplemented warp-pointer)
(def/public-unimplemented view-start)

14
collects/mred/private/wx/win32/check-box.rkt
View File

@ -3,12 +3,17 @@
"../../syntax.rkt"
"button.rkt"
"item.rkt"
"utils.rkt"
"const.rkt")
(provide check-box%)
(define BM_GETCHECK #x00F0)
(define BM_SETCHECK #x00F1)
(defclass check-box% base-button%
(inherit auto-size)
(inherit auto-size
get-hwnd)
(super-new)
@ -17,5 +22,8 @@
(define/override (auto-size-button label)
(auto-size label 0 0 20 0))
(def/public-unimplemented set-value)
(def/public-unimplemented get-value))
(define/public (set-value v)
(void (SendMessageW (get-hwnd) BM_SETCHECK (if v 1 0) 0)))
(define/public (get-value)
(positive? (bitwise-and #x3 (SendMessageW (get-hwnd) BM_GETCHECK 0 0)))))

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

@ -25,13 +25,14 @@
x y w h
choices style font)
(inherit auto-size set-control-font
set-size)
set-size
subclass-control)
(define callback cb)
(define hwnd
(CreateWindowExW 0
"COMBOBOX"
"PLTCOMBOBOX"
label
(bitwise-ior WS_CHILD CBS_DROPDOWNLIST
WS_HSCROLL WS_VSCROLL
@ -61,6 +62,9 @@
(lambda (w h)
(set-size -11111 -11111 w (* h 8))))
(subclass-control hwnd)
(define/override (is-command? cmd)
(= cmd CBN_SELENDOK))
@ -75,7 +79,7 @@
(define/public (set-selection i)
(SendMessageW hwnd CB_SETCURSEL i 0))
(define/public (get-selection i)
(define/public (get-selection)
(SendMessageW hwnd CB_GETCURSEL 0 0))
(define/public (number) num-choices)

110
collects/mred/private/wx/win32/cursor.rkt
View File

@ -1,11 +1,113 @@
#lang scheme/base
(require scheme/class
#lang racket/base
(require ffi/unsafe
racket/class
"utils.rkt"
"types.rkt"
"const.rkt"
"wndclass.rkt"
"../common/cursor-draw.rkt"
"../../syntax.rkt")
(provide cursor-driver%)
(provide cursor-driver%
get-arrow-cursor
get-wait-cursor)
(define (MAKEINTRESOURCE v) v)
(define IDC_ARROW (MAKEINTRESOURCE 32512))
(define IDC_IBEAM (MAKEINTRESOURCE 32513))
(define IDC_WAIT (MAKEINTRESOURCE 32514))
(define IDC_APPSTARTING (MAKEINTRESOURCE 32650))
(define IDC_CROSS (MAKEINTRESOURCE 32515))
(define IDC_UPARROW (MAKEINTRESOURCE 32516))
(define IDC_SIZENWSE (MAKEINTRESOURCE 32642))
(define IDC_SIZENESW (MAKEINTRESOURCE 32643))
(define IDC_SIZEWE (MAKEINTRESOURCE 32644))
(define IDC_SIZENS (MAKEINTRESOURCE 32645))
(define IDC_SIZEALL (MAKEINTRESOURCE 32646))
(define IDC_NO (MAKEINTRESOURCE 32648))
(define IDC_HAND (MAKEINTRESOURCE 32649))
(define IDC_HELP (MAKEINTRESOURCE 32651))
(define-user32 LoadCursorW (_wfun _HINSTANCE _LONG -> _HCURSOR))
(define-user32 CreateCursor (_wfun _HINSTANCE
_int ; x
_int ; y
_int ; width
_int ; height
_pointer ; AND
_pointer ; XOR
-> _HCURSOR))
(define handles (make-hasheq))
(define (load-cursor num)
(or (hash-ref handles num #f)
(let ([h (LoadCursorW #f num)])
(hash-set! handles num h)
h)))
(define (get-arrow-cursor)
(load-cursor IDC_ARROW))
(define (get-wait-cursor)
(load-cursor IDC_APPSTARTING))
(defclass cursor-driver% object%
(define/public (set-standard c) (void))
(define handle #f)
(define/public (set-standard sym)
(case sym
[(arrow)
(set! handle (load-cursor IDC_ARROW))]
[(cross)
(set! handle (load-cursor IDC_CROSS))]
[(hand)
(set! handle (load-cursor IDC_HAND))]
[(ibeam)
(set! handle (load-cursor IDC_IBEAM))]
[(size-n/s)
(set! handle (load-cursor IDC_SIZENS))]
[(size-e/w)
(set! handle (load-cursor IDC_SIZEWE))]
[(size-nw/se)
(set! handle (load-cursor IDC_SIZENWSE))]
[(size-ne/sw)
(set! handle (load-cursor IDC_SIZENESW))]
[(watch)
(set! handle (load-cursor IDC_APPSTARTING))]
[(bullseye)
(set-image (make-cursor-image draw-bullseye 'unsmoothed) #f 8 8)]
[(blank)
(set-image #f #f 0 0)]))
(define/public (set-image image mask hot-spot-x hot-spot-y
[ai (make-bytes (/ (* 16 16) 8) 255)]
[xi (make-bytes (/ (* 16 16) 8) 0)])
(let ([s (make-bytes (* 16 16 4) 0)])
(when image
(send image get-argb-pixels 0 0 16 16 s)
(if mask
(send mask get-argb-pixels 0 0 16 16 s #t)
(send image get-argb-pixels 0 0 16 16 s #t)))
(for* ([i (in-range 16)]
[j (in-range 16)])
(let ([pos (* 4 (+ (* j 16) i))])
(when (positive? (bytes-ref s pos))
;; black bit in mask
(let ([bpos (+ (* j (/ 16 8)) (quotient i 8))]
[bit (arithmetic-shift 1 (- 7 (modulo i 8)))])
(bytes-set! ai bpos (- (bytes-ref ai bpos) bit))
(unless (and (zero? (bytes-ref s (+ 1 pos)))
(zero? (bytes-ref s (+ 2 pos)))
(zero? (bytes-ref s (+ 3 pos))))
;; white cursor pixel
(bytes-set! xi bpos (+ (bytes-ref xi bpos) bit)))))))
(set! handle
(CreateCursor hInstance hot-spot-x hot-spot-y
16 16
ai xi))))
(define/public (get-handle) handle)
(def/public-unimplemented ok?)
(super-new))

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

@ -11,14 +11,26 @@
"types.rkt"
"theme.rkt"
"window.rkt"
"wndclass.rkt")
"wndclass.rkt"
"cursor.rkt")
(provide frame%)
(provide frame%
display-size
display-origin)
(define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL))
(define-user32 GetActiveWindow (_wfun -> _HWND))
(define-user32 SetFocus (_wfun _HWND -> _HWND))
(define mouse-frame #f)
(define (display-origin xb yb ?)
(set-box! xb 0)
(set-box! yb 0))
(define (display-size xb yb ?)
(set-box! xb 1024)
(set-box! yb 768))
(defclass frame% window%
(init parent
label
@ -29,10 +41,13 @@
is-shown?
get-eventspace
on-size
pre-on-char pre-on-event)
get-size
get-position
pre-on-char pre-on-event
reset-cursor-in-child)
(define/public (create-frame parent label w h)
(CreateWindowExW (bitwise-ior WS_EX_LAYERED)
(CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED)
"PLTFrame"
(if label label "")
WS_OVERLAPPEDWINDOW
@ -64,6 +79,7 @@
(super show on?))
(define/override (direct-show on?)
(when (eq? mouse-frame this) (set! mouse-frame #f))
(register-frame-shown this on?)
(super direct-show on?))
@ -150,11 +166,70 @@
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define/override (generate-parent-mouse-ins mk)
;; assert: in-window is always the panel child
(unless (eq? mouse-frame this)
(when mouse-frame
(let ([win mouse-frame])
(set! mouse-frame #f)
(send win send-leaves mk)))
(set! mouse-frame this))
#f)
(define/override (reset-cursor default)
(if wait-cursor-on?
(void (SetCursor (get-wait-cursor)))
(when saved-child
(reset-cursor-in-child saved-child default))))
(define/override (get-dialog-level) 0)
(define/public (frame-relative-dialog-status win)
#f)
(define wait-cursor-on? #f)
(define/public (set-wait-cursor-mode on?)
(set! wait-cursor-on? on?)
(when (eq? mouse-frame this)
(if on?
(void (SetCursor (get-wait-cursor)))
(reset-cursor (get-arrow-cursor)))))
(define/public (is-wait-cursor-on?)
wait-cursor-on?)
(define/override (center mode wrt)
(let ([sw (box 0)]
[sh (box 0)]
[w (box 0)]
[h (box 0)]
[x (box 0)]
[y (box 0)])
(display-size sw sh #f)
(get-size w h)
(MoveWindow hwnd
(if (or (eq? mode 'both)
(eq? mode 'horizontal))
(quotient (- (unbox sw) (unbox w)) 2)
(get-x))
(if (or (eq? mode 'both)
(eq? mode 'vertical))
(quotient (- (unbox sh) (unbox h)) 2)
(get-x))
(unbox w)
(unbox h)
#t)))
(define saved-child #f)
(define/override (register-child child on?)
(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))
(define/override (register-child-in-parent on?)
(void))
(define/override (get-top-frame) this)
(def/public-unimplemented designate-root-frame)
(def/public-unimplemented system-menu)
(def/public-unimplemented set-modified)

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

@ -20,7 +20,8 @@
(define gauge%
(class item%
(inherit set-size)
(inherit set-size
subclass-control)
(init parent
label
@ -31,7 +32,7 @@
(define hwnd
(CreateWindowExW 0
"msctls_progress32"
"PLTmsctls_progress32"
label
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
(if (memq 'vertical style)
@ -53,6 +54,8 @@
(set-size -11111 -11111 100 24)
(set-size -11111 -11111 24 100))
(subclass-control hwnd)
(define/public (get-value)
(SendMessageW hwnd PBM_GETPOS 0 0))
(define/public (set-value v)

11
collects/mred/private/wx/win32/group-panel.rkt
View File

@ -15,17 +15,18 @@
(define group-panel%
(class (panel-mixin window%)
(class (item-mixin (panel-mixin window%))
(init parent
x y w h
style
label)
(inherit auto-size set-control-font)
(inherit auto-size set-control-font
subclass-control)
(define hwnd
(CreateWindowExW 0
"BUTTON"
"PLTBUTTON"
(or label "")
(bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0
@ -59,6 +60,10 @@
(lambda (w h)
(set! label-h h)
(set-size -11111 -11111 (+ w 10) (+ h 10))))
(subclass-control hwnd)
(define/public (set-label lbl)
(SetWindowTextW hwnd lbl))
(define/override (set-size x y w h)
(super set-size x y w h)

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

@ -11,17 +11,67 @@
"hbitmap.rkt"
"types.rkt")
(provide item%)
(provide item-mixin
item%)
(defclass item% window%
(inherit get-hwnd)
(define (control-proc w msg wParam lParam)
(let ([wx (hwnd->wx w)])
(if wx
(send wx ctlproc w msg wParam lParam
(lambda (w msg wParam lParam)
(send wx default-ctlproc w msg wParam lParam)))
(send wx default-ctlproc w msg wParam lParam))))
(super-new)
(define control_proc (function-ptr control-proc _WndProc))
(define/override (gets-focus?) #t)
(define (item-mixin %)
(class %
(inherit on-set-focus
on-kill-focus
try-mouse)
(define/public (set-label s)
(SetWindowTextW (get-hwnd) s))
(define old-control-procs null)
(super-new)
(define/public (subclass-control hwnd)
(let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
(set! old-control-procs (cons (cons hwnd old-control-proc)
old-control-procs))
(SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
(define/public (ctlproc w msg wParam lParam default)
(if (try-mouse w msg wParam lParam)
0
(cond
[(= msg WM_SETFOCUS)
(queue-window-event this (lambda () (on-set-focus)))
(default w msg wParam lParam)]
[(= msg WM_KILLFOCUS)
(queue-window-event this (lambda () (on-kill-focus)))
(default w msg wParam lParam)]
[else
(default w msg wParam lParam)])))
(define/public (default-ctlproc w msg wParam lParam)
(let loop ([l old-control-procs])
(cond
[(null? l) (error 'default-ctlproc "cannot find control in: ~e for: ~e" this w)]
[(ptr-equal? (caar l) w)
((cdar l) w msg wParam lParam)]
[else (loop (cdr l))])))))
(define item%
(class (item-mixin window%)
(inherit get-hwnd)
(super-new)
(define/override (gets-focus?) #t)
(define/public (set-label s)
(SetWindowTextW (get-hwnd) s))
(def/public-unimplemented get-label)
(def/public-unimplemented command)))
(def/public-unimplemented get-label)
(def/public-unimplemented command))

140
collects/mred/private/wx/win32/list-box.rkt
View File

@ -1,8 +1,10 @@
#lang racket/base
(require racket/class
racket/draw
(only-in racket/list take drop)
ffi/unsafe
"../../syntax.rkt"
"../../lock.rkt"
"../common/event.rkt"
"item.rkt"
"utils.rkt"
@ -23,7 +25,22 @@
(define LBS_EXTENDEDSEL #x0800)
(define LBS_DISABLENOSCROLL #x1000)
(define LB_ERR -1)
(define LB_ADDSTRING #x0180)
(define LB_RESETCONTENT #x0184)
(define LB_INSERTSTRING #x0181)
(define LB_DELETESTRING #x0182)
(define LB_GETTOPINDEX #x018E)
(define LB_SETTOPINDEX #x0197)
(define LB_GETITEMHEIGHT #x01A1)
(define LB_GETSELCOUNT #x0190)
(define LB_GETSELITEMS #x0191)
(define LB_GETCURSEL #x0188)
(define LB_SETSEL #x0185)
(define LB_SETCURSEL #x0186)
(define LB_GETSEL #x0187)
(define LB_SELITEMRANGE #x019B)
(define list-box%
(class item%
@ -32,11 +49,17 @@
choices style
font label-font)
(inherit set-size set-control-font)
(inherit set-size set-control-font
subclass-control
get-client-size)
(define single?
(and (not (memq 'extended style))
(not (memq 'mutiple style))))
(define hwnd
(CreateWindowExW WS_EX_CLIENTEDGE
"LISTBOX"
"PLTLISTBOX"
label
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
WS_VSCROLL
@ -60,22 +83,99 @@
[style style])
(set-control-font font)
(set-size -11111 -11111 40 40)
(set-size -11111 -11111 40 60)
(def/public-unimplemented get-label-font)
(def/public-unimplemented set-string)
(def/public-unimplemented set-first-visible-item)
(def/public-unimplemented set)
(def/public-unimplemented get-selections)
(def/public-unimplemented get-first-item)
(def/public-unimplemented number-of-visible-items)
(def/public-unimplemented number)
(def/public-unimplemented get-selection)
(def/public-unimplemented set-data)
(def/public-unimplemented get-data)
(def/public-unimplemented selected?)
(def/public-unimplemented set-selection)
(def/public-unimplemented select)
(def/public-unimplemented delete)
(def/public-unimplemented clear)
(def/public-unimplemented append)))
(subclass-control hwnd)
(define num (length choices))
(define/public (number) num)
(define data (map (lambda (x) (box #f)) choices))
(define/public (get-data i) (unbox (list-ref data i)))
(define/public (set-data i v) (set-box! (list-ref data i) v))
(define/public (set-string i str)
(atomically
(SendMessageW/str hwnd LB_INSERTSTRING i str)
(SendMessageW hwnd LB_DELETESTRING (add1 i) 0)))
(define/public (set-first-visible-item i)
(SendMessageW hwnd LB_SETTOPINDEX i 0))
(define/public (get-first-item)
(SendMessageW hwnd LB_GETTOPINDEX 0 0))
(define/public (number-of-visible-items)
(let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)])
(let ([w (box 0)]
[h (box 0)])
(get-client-size w h)
(quotient (unbox h) ih))))
(define/public (clear)
(atomically
(set! data null)
(set! num 0)
(SendMessageW hwnd LB_RESETCONTENT 0 0)))
(define/public (set choices)
(atomically
(ShowWindow hwnd SW_HIDE)
(clear)
(for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
(set! data (map (lambda (s) (box #f)) choices))
(set! num (length choices))
(ShowWindow hwnd SW_SHOW)))
(public [append* append])
(define (append* s [v #f])
(atomically
(SendMessageW/str hwnd LB_ADDSTRING 0 s)
(set! num (add1 num))
(set! data (append data (list (box v))))))
(define/public (delete i)
(atomically
(set! data (append (take data i) (drop data (add1 i))))
(set! num (sub1 num))
(SendMessageW hwnd LB_DELETESTRING i 0)))
(define/public (get-selections)
(atomically
(if single?
(let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)])
(if (= v LB_ERR)
null
(list v)))
(let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)])
(if (zero? n)
null
(let ([selections (malloc n _LONG 'raw)])
(SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM))
(begin0
(for/list ([i (in-range n)])
(ptr-ref selections _LONG i))
(free selections))))))))
(define/public (get-selection)
(let ([l (get-selections)])
(if (null? l)
-1
(car l))))
(define/public (selected? i)
(not (zero? (SendMessageW hwnd LB_GETSEL i 0))))
(define/public (select i [on? #t] [extend? #t])
(if single?
(SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0)
(begin
(when extend?
(SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num)))
(SendMessageW hwnd LB_SETSEL (if on? 1 0) i))))
(define/public (set-selection i)
(select i #t #f))
(def/public-unimplemented get-label-font)))

52
collects/mred/private/wx/win32/message.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/class
racket/draw
racket/promise
ffi/unsafe
"../../syntax.rkt"
"../common/event.rkt"
@ -18,10 +19,36 @@
(define SS_LEFT #x00000000)
(define SS_BITMAP #x0000000E)
(define SS_ICON #x00000003)
(define IDI_APPLICATION 32512)
(define IDI_HAND 32513)
(define IDI_QUESTION 32514)
(define IDI_EXCLAMATION 32515)
(define IDI_WARNING IDI_EXCLAMATION)
(define IDI_ERROR IDI_HAND)
(define IMAGE_ICON 1)
(define-user32 LoadIconW (_wfun _HINSTANCE _LONG -> _HICON))
(define app-icon
(delay
(let ()
;; GetModuleFileNameW(NULL, name, 1023);
;; icn = ExtractIconW(NULL, name, 0);
(LoadIconW #f IDI_APPLICATION))))
(define warning-icon
(delay
(LoadIconW #f IDI_WARNING)))
(define error-icon
(delay
(LoadIconW #f IDI_ERROR)))
(define message%
(class item%
(inherit auto-size set-control-font get-hwnd)
(inherit auto-size set-size set-control-font get-hwnd
subclass-control)
(init parent label
x y
@ -31,7 +58,7 @@
(and (label . is-a? . bitmap%)
(send label ok?)))
(define/public (get-class) "STATIC")
(define/public (get-class) "PLTSTATIC")
(super-new [parent parent]
[hwnd
@ -43,7 +70,9 @@
(bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS
(if bitmap?
SS_BITMAP
0))
(if (symbol? label)
SS_ICON
0)))
0 0 0 0
(send parent get-client-hwnd)
#f
@ -51,10 +80,21 @@
#f)]
[style style])
(subclass-control (get-hwnd))
(when bitmap?
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP
(cast (bitmap->hbitmap label) _HBITMAP _LPARAM)))
(when (symbol? label)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON
(cast (force (case label
[(caution) warning-icon]
[(stop) error-icon]
[else app-icon]))
_HICON _LPARAM)))
(set-control-font font)
(auto-size label 0 0 0 0)))
(if (symbol? label)
(set-size -11111 -11111 32 32)
(auto-size label 0 0 0 0))))

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

@ -10,8 +10,57 @@
(define (panel-mixin %)
(class %
(inherit is-enabled-to-root?
reset-cursor-in-child)
(super-new)
(define children null)
(define/override (register-child child on?)
(let ([now-on? (and (memq child children) #t)])
(unless (eq? on? now-on?)
(unless on?
(when (eq? child mouse-in-child)
(set! mouse-in-child #f)))
(set! children
(if on?
(cons child children)
(remq child children)))
(send child parent-enable (is-enabled-to-root?)))))
(define/override (internal-enable on?)
(super internal-enable on?)
(for ([c (in-list children)])
(send c parent-enable on?)))
(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))
(super generate-mouse-ins in-window mk))
(define/override (reset-cursor default)
(if mouse-in-child
(reset-cursor-in-child mouse-in-child default)
(super reset-cursor default)))
(define/override (send-leaves mk)
(when mouse-in-child
(let ([w mouse-in-child])
(set! mouse-in-child #f)
(send w send-leaves mk)))
(super send-leaves mk))
(define/override (send-child-leaves mk)
(if mouse-in-child
(let ([w mouse-in-child])
(set! mouse-in-child #f)
(send w send-leaves mk)
#t)
#f))
(define lbl-pos 'horizontal)
(define/public (get-label-position) lbl-pos)
(define/public (set-label-position pos) (set! lbl-pos pos))

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

@ -68,6 +68,7 @@
fill-private-color
cancel-quit
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type

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

@ -7,6 +7,7 @@
"utils.rkt"
"const.rkt"
"menu-item.rkt"
"frame.rkt"
racket/draw)
(provide
@ -26,6 +27,7 @@
run-printout
get-double-click-time
get-control-font-size
get-control-font-size-in-pixels?
cancel-quit
fill-private-color
flush-display
@ -64,17 +66,12 @@
(define-unimplemented run-printout)
(define (get-double-click-time) 500)
(define (get-control-font-size) (get-theme-font-size))
(define (get-control-font-size-in-pixels?) #t)
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)
(define-unimplemented flush-display)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define (display-origin xb yb ?)
(set-box! xb 0)
(set-box! yb 0))
(define (display-size xb yb ?)
(set-box! xb 1024)
(set-box! yb 768))
(define-unimplemented bell)
(define (hide-cursor) (void))

10
collects/mred/private/wx/win32/queue.rkt
View File

@ -112,10 +112,12 @@
(queue-message-dequeue (send wx get-eventspace)
hwnd)))
;; Not our window, so dispatch any available events
(let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)])
(when v
(TranslateMessage msg)
(DispatchMessageW msg))))
(let loop ()
(let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)])
(when v
(TranslateMessage msg)
(DispatchMessageW msg)
(loop)))))
#t))
(define check_window_event (function-ptr check-window-event _enum_proc))

20
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -27,7 +27,9 @@
style
font)
(inherit auto-size set-control-font)
(inherit auto-size set-control-font
is-enabled-to-root?
subclass-control)
(define callback cb)
(define current-value val)
@ -54,7 +56,7 @@
(send label ok?))]
[radio-hwnd
(CreateWindowExW WS_EX_TRANSPARENT
"BUTTON"
"PLTBUTTON"
(if (string? label)
label
"<image>")
@ -86,6 +88,9 @@
[hwnd hwnd]
[extra-hwnds radio-hwnds]
[style style])
(for ([radio-hwnd (in-list radio-hwnds)])
(subclass-control radio-hwnd))
(define/override (is-hwnd? a-hwnd)
(or (ptr-equal? hwnd a-hwnd)
@ -121,6 +126,17 @@
(SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0))
(set! current-value val))))
(define buttons-enabled (make-vector (length radio-hwnds) #t))
(define/public (enable-button i on?)
(unless (eq? (and on? #t) (vector-ref buttons-enabled i))
(vector-set! buttons-enabled i (and on? #t))
(when (is-enabled-to-root?)
(void (EnableWindow (list-ref radio-hwnds i) on?)))))
(define/override (internal-enable on?)
(for ([radio-hwnd (in-list radio-hwnds)]
[radio-on? (in-vector buttons-enabled)])
(void (EnableWindow radio-hwnd (and on? radio-on?)))))
(define/public (get-selection) current-value)
(define/public (number) (length radio-hwnds))))

19
collects/mred/private/wx/win32/slider.rkt
View File

@ -29,7 +29,7 @@
(define SS_CENTER #x00000001)
(define THICKNESS 24)
(define MIN_LENGTH 100)
(define MIN_LENGTH 80)
(defclass slider% item%
(init parent cb
@ -39,8 +39,10 @@
style
font)
(inherit set-control-font
auto-size)
auto-size
subclass-control)
(define callback cb)
(define vertical? (memq 'vertical style))
(define panel-hwnd
@ -58,7 +60,7 @@
(define slider-hwnd
(CreateWindowExW 0
"msctls_trackbar32"
"PLTmsctls_trackbar32"
label
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
(if vertical?
@ -124,6 +126,8 @@
(SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi))
(set-value val)
(subclass-control slider-hwnd)
(define/override (set-size x y w h)
(super set-size x y w h)
(when panel-hwnd
@ -139,7 +143,12 @@
(define/override (control-scrolled)
(when value-hwnd
(let ([val (get-value)])
(SetWindowTextW value-hwnd (format "~s" val)))))
(SetWindowTextW value-hwnd (format "~s" val))))
(queue-window-event this (lambda ()
(callback this
(new control-event%
[event-type 'slider]
[time-stamp (current-milliseconds)])))))
(define/public (set-value val)
(SendMessageW slider-hwnd TBM_SETPOS 1 val))

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

@ -29,7 +29,7 @@
[lParam _LPARAM]))
(define tab-panel%
(class (panel-mixin window%)
(class (item-mixin (panel-mixin window%))
(init parent
x y w h
style
@ -41,7 +41,7 @@
(define hwnd
(CreateWindowExW 0
"SysTabControl32"
"PLTSysTabControl32"
""
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0

14
collects/mred/private/wx/win32/utils.rkt
View File

@ -12,11 +12,15 @@
define-mz
failed
GetWindowLongW
SetWindowLongW
SendMessageW SendMessageW/str
GetSysColor GetRValue GetGValue GetBValue
MoveWindow
ShowWindow
SetWindowTextW)
EnableWindow
SetWindowTextW
SetCursor)
(define gdi32-lib (ffi-lib "gdi32.dll"))
(define user32-lib (ffi-lib "user32.dll"))
@ -36,6 +40,9 @@
(error who "call failed (~s)"
(GetLastError)))
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
(define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT)
#:c-id SendMessageW)
@ -50,7 +57,10 @@
-> (unless r (failed 'MoveWindow))))
(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void)))
(define-user32 EnableWindow (_wfun _HWND _BOOL -> _BOOL))
(define-user32 SetWindowTextW (_wfun _HWND _string/utf-16 -> (r : _BOOL)
-> (unless r (failed 'SetWindowText))))
(define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR))

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

@ -2,15 +2,19 @@
(require ffi/unsafe
racket/class
racket/draw
"../../syntax.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"wndclass.rkt"
"queue.rkt"
"theme.rkt"
"../../syntax.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"../common/event.rkt"
"../common/local.rkt"
"../../lock.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"wndclass.rkt"
"queue.rkt"
"theme.rkt"
"cursor.rkt"
"key.rkt")
(provide window%
@ -25,6 +29,17 @@
(define WM_PRINT #x0317)
(define WM_PRINTCLIENT #x0318)
(define MK_LBUTTON #x0001)
(define MK_RBUTTON #x0002)
(define MK_SHIFT #x0004)
(define MK_CONTROL #x0008)
(define MK_MBUTTON #x0010)
(define MK_XBUTTON1 #x0020)
(define MK_XBUTTON2 #x0040)
(define HTHSCROLL 6)
(define HTVSCROLL 7)
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
@ -37,6 +52,11 @@
(define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) ->
(if r rect (failed 'GetClientRect))))
(define-user32 ClientToScreen (_wfun _HWND _POINT-pointer -> (r : _BOOL)
-> (unless r (failed 'ClientToScreen))))
(define-user32 ScreenToClient (_wfun _HWND _POINT-pointer -> (r : _BOOL)
-> (unless r (failed 'ClientToScreen))))
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int)
-> (when (zero? r) (failed 'FillRect))))
@ -96,60 +116,62 @@
(ptr-equal? hwnd a-hwnd))
(define/public (wndproc w msg wParam lParam default)
(cond
[(= msg WM_SETFOCUS)
(queue-window-event this (lambda () (on-set-focus)))
0]
[(= msg WM_KILLFOCUS)
(queue-window-event this (lambda () (on-kill-focus)))
0]
[(= msg WM_SYSKEYDOWN)
(when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key wParam lParam #f #f)))]
[(= msg WM_KEYDOWN)
(do-key wParam lParam #f #f)
0]
[(= msg WM_KEYUP)
(do-key wParam lParam #f #t)
0]
[(= msg WM_SYSCHAR)
(when (= wParam VK_MENU)
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key wParam lParam #t #f)))]
[(= msg WM_CHAR)
(do-key wParam lParam #t #f)
0]
[(= msg WM_COMMAND)
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
[wx (any-hwnd->wx control-hwnd)])
(if (and wx (send wx is-command? (HIWORD wParam)))
(begin
(send wx do-command control-hwnd)
0)
(default w msg wParam lParam)))]
[(= msg WM_NOTIFY)
#;
(let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
[control-hwnd (NMHDR-hwndFrom nmhdr)]
[wx (any-hwnd->wx control-hwnd)])
(when wx (send wx do-command)))
0]
[(or (= msg WM_HSCROLL)
(= msg WM_VSCROLL))
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
[wx (any-hwnd->wx control-hwnd)])
(if wx
(begin
(send wx control-scrolled)
0)
(default w msg wParam lParam)))]
[else
(default w msg wParam lParam)]))
(if (try-mouse w msg wParam lParam)
0
(cond
[(= msg WM_SETFOCUS)
(queue-window-event this (lambda () (on-set-focus)))
0]
[(= msg WM_KILLFOCUS)
(queue-window-event this (lambda () (on-kill-focus)))
0]
[(= msg WM_SYSKEYDOWN)
(when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key wParam lParam #f #f)))]
[(= msg WM_KEYDOWN)
(do-key wParam lParam #f #f)
0]
[(= msg WM_KEYUP)
(do-key wParam lParam #f #t)
0]
[(= msg WM_SYSCHAR)
(when (= wParam VK_MENU)
(unhide-cursor)
(begin0
(default w msg wParam lParam)
(do-key wParam lParam #t #f)))]
[(= msg WM_CHAR)
(do-key wParam lParam #t #f)
0]
[(= msg WM_COMMAND)
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
[wx (any-hwnd->wx control-hwnd)])
(if (and wx (send wx is-command? (HIWORD wParam)))
(begin
(send wx do-command control-hwnd)
0)
(default w msg wParam lParam)))]
[(= msg WM_NOTIFY)
#;
(let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
[control-hwnd (NMHDR-hwndFrom nmhdr)]
[wx (any-hwnd->wx control-hwnd)])
(when wx (send wx do-command)))
0]
[(or (= msg WM_HSCROLL)
(= msg WM_VSCROLL))
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
[wx (any-hwnd->wx control-hwnd)])
(if wx
(begin
(send wx control-scrolled)
0)
(default w msg wParam lParam)))]
[else
(default w msg wParam lParam)])))
(define/public (is-command? cmd) #f)
(define/public (control-scrolled) #f)
@ -160,6 +182,7 @@
(define shown? #f)
(define/public (direct-show on?)
(set! shown? (and on? #t))
(register-child-in-parent on?)
(unless on? (not-focus-child this))
(ShowWindow hwnd (if on? SW_SHOW SW_HIDE)))
(unless (memq 'invisible style)
@ -173,12 +196,29 @@
(define/public (on-kill-focus) (void))
(define/public (get-handle) hwnd)
(define/public (is-window-enabled?)
#t)
(define enabled? #t)
(define parent-enabled? #t)
(define/public (enable on?)
(unless (eq? enabled? (and on? #t))
(atomically
(let ([prev? (and enabled? parent-enabled?)])
(set! enabled? (and on? #t))
(let ([now? (and parent-enabled? enabled?)])
(unless (eq? now? prev?)
(internal-enable now?)))))))
(define/public (parent-enable on?)
(unless (eq? on? parent-enabled?)
(let ([prev? (and enabled? parent-enabled?)])
(set! parent-enabled? (and on? #t))
(let ([now? (and parent-enabled? enabled?)])
(unless (eq? prev? now?)
(internal-enable now?))))))
(define/public (internal-enable on?)
(void (EnableWindow hwnd on?)))
(define/public (is-window-enabled?) enabled?)
(define/public (is-enabled-to-root?)
(and (is-window-enabled?)
(send parent is-enabled-to-root?)))
(and enabled? parent-enabled?))
(define/public (is-shown-to-root?)
(and shown?
@ -271,14 +311,23 @@
(define/public (refresh) (void))
(define/public (on-resized) (void))
(def/public-unimplemented screen-to-client)
(def/public-unimplemented client-to-screen)
(define/public (screen-to-client x y)
(let ([p (make-POINT (unbox x) (unbox y))])
(ScreenToClient (get-client-hwnd) p)
(set-box! x (POINT-x p))
(set-box! y (POINT-y p))))
(define/public (client-to-screen x y)
(let ([p (make-POINT (unbox x) (unbox y))])
(ClientToScreen (get-client-hwnd) p)
(set-box! x (POINT-x p))
(set-box! y (POINT-y p))))
(define/public (drag-accept-files on?)
(void))
(def/public-unimplemented enable)
(def/public-unimplemented get-position)
(define/public (get-position x y)
(set-box! x (get-x))
(set-box! y (get-y)))
(define/public (get-client-size w h)
(let ([r (GetClientRect (get-client-hwnd))])
@ -290,8 +339,27 @@
(set-box! w (- (RECT-right r) (RECT-left r)))
(set-box! h (- (RECT-bottom r) (RECT-top r)))))
(def/public-unimplemented fit)
(def/public-unimplemented set-cursor)
(define cursor-handle #f)
(define/public (set-cursor c)
(set! cursor-handle (and c (send (send c get-driver) get-handle)))
(when mouse-in?
(cursor-updated-here)))
(define/public (cursor-updated-here)
(when mouse-in?
(send (get-top-frame) reset-cursor (get-arrow-cursor))))
(define/public (reset-cursor-in-child child default)
(send child reset-cursor (or cursor-handle default)))
(define effective-cursor-handle #f)
(define/public (reset-cursor default)
(let ([c (or cursor-handle default)])
(set! effective-cursor-handle c)
(SetCursor c)))
(define/public (no-cursor-handle-here)
(send parent cursor-updated-here))
(define/public (set-focus)
(when (can-accept-focus?)
@ -312,6 +380,15 @@
(define/public (gets-focus?) #f)
(def/public-unimplemented centre)
(define/public (register-child child on?)
(void))
(define/public (register-child-in-parent on?)
(when parent
(send parent register-child this on?)))
(define/public (get-top-frame)
(send parent get-top-frame))
(define/private (do-key wParam lParam is-char? is-up?)
(let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])
(and e
@ -323,6 +400,134 @@
(lambda () (dispatch-on-char e #t))
#t)))))
(define/public (try-mouse w msg wParam lParam)
(cond
[(= msg WM_NCRBUTTONDOWN)
(do-mouse w #t 'right-down wParam lParam)]
[(= msg WM_NCRBUTTONUP)
(do-mouse w #t 'right-up wParam lParam)]
[(= msg WM_NCRBUTTONDBLCLK)
(do-mouse w #t 'right-down wParam lParam)]
[(= msg WM_NCMBUTTONDOWN)
(do-mouse w #t 'middle-down wParam lParam)]
[(= msg WM_NCMBUTTONUP)
(do-mouse w #t 'middle-up wParam lParam)]
[(= msg WM_NCMBUTTONDBLCLK)
(do-mouse w #t 'middle-down wParam lParam)]
[(= msg WM_NCLBUTTONDOWN)
(do-mouse w #t 'left-down wParam lParam)]
[(= msg WM_NCLBUTTONUP)
(do-mouse w #t 'left-up wParam lParam)]
[(= msg WM_NCLBUTTONDBLCLK)
(do-mouse w #t 'left-down wParam lParam)]
[(and (= msg WM_NCMOUSEMOVE)
(not (= wParam HTVSCROLL))
(not (= wParam HTHSCROLL)))
(do-mouse w #t 'motion wParam lParam)]
[(= msg WM_RBUTTONDOWN)
(do-mouse w #f 'right-down wParam lParam)]
[(= msg WM_RBUTTONUP)
(do-mouse w #f 'right-up wParam lParam)]
[(= msg WM_RBUTTONDBLCLK)
(do-mouse w #f 'right-down wParam lParam)]
[(= msg WM_MBUTTONDOWN)
(do-mouse w #f 'middle-down wParam lParam)]
[(= msg WM_MBUTTONUP)
(do-mouse w #f 'middle-up wParam lParam)]
[(= msg WM_MBUTTONDBLCLK)
(do-mouse w #f 'middle-down wParam lParam)]
[(= msg WM_LBUTTONDOWN)
(do-mouse w #f 'left-down wParam lParam)]
[(= msg WM_LBUTTONUP)
(do-mouse w #f 'left-up wParam lParam)]
[(= msg WM_LBUTTONDBLCLK)
(do-mouse w #f 'left-down wParam lParam)]
[(= msg WM_MOUSEMOVE)
(do-mouse w #f 'motion wParam lParam)]
[(= msg WM_MOUSELEAVE)
(do-mouse w #f 'leave wParam lParam)]
[else #f]))
(define/private (do-mouse control-hwnd nc? type wParam lParam)
(let ([x (LOWORD lParam)]
[y (HIWORD lParam)]
[flags (if nc? 0 wParam)]
[bit? (lambda (v b) (not (zero? (bitwise-and v b))))])
(let ([make-e
(lambda (type)
(new mouse-event%
[event-type type]
[left-down (case type
[(left-down) #t]
[(left-up) #f]
[else (bit? flags MK_LBUTTON)])]
[middle-down (case type
[(middle-down) #t]
[(middle-up) #f]
[else (bit? flags MK_MBUTTON)])]
[right-down (case type
[(right-down) #t]
[(right-up) #f]
[else (bit? flags MK_RBUTTON)])]
[x x]
[y y]
[shift-down (bit? flags MK_SHIFT)]
[control-down (bit? flags MK_CONTROL)]
[meta-down #f]
[alt-down #f]
[time-stamp 0]
[caps-down #f]))])
(if mouse-in?
(if (send-child-leaves (lambda (type) (make-e type)))
(cursor-updated-here)
(if (send (get-top-frame) is-wait-cursor-on?)
(void (SetCursor (get-wait-cursor)))
(when effective-cursor-handle
(void (SetCursor effective-cursor-handle)))))
(let ([c (generate-mouse-ins this (lambda (type) (make-e type)))])
(when c
(set! effective-cursor-handle c)
(void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?)
(get-wait-cursor)
c))))))
(when (memq type '(left-down right-down middle-down))
(set-focus))
(handle-mouse-event (make-e type)))))
(define (handle-mouse-event e)
(if (definitely-wants-event? e)
(begin
(queue-window-event this (lambda () (dispatch-on-event/sync e)))
#t)
(constrained-reply (get-eventspace)
(lambda () (dispatch-on-event e #t))
#t)))
(define mouse-in? #f)
(define/public (generate-mouse-ins in-window mk)
(if mouse-in?
effective-cursor-handle
(begin
(set! mouse-in? #t)
(let ([parent-cursor (generate-parent-mouse-ins mk)])
(handle-mouse-event (mk 'enter))
(or cursor-handle parent-cursor)))))
(define/public (generate-parent-mouse-ins mk)
(send parent generate-mouse-ins this mk))
(define/public (send-leaves mk)
(set! mouse-in? #f)
(let ([e (mk 'leave)])
(if (eq? (current-eventspace) (get-eventspace))
(handle-mouse-event e)
(queue-window-event this
(lambda () (dispatch-on-event/sync e))))))
(define/public (send-child-leaves mk)
#f)
(define/public (definitely-wants-event? e)
#f)

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

@ -12,13 +12,11 @@
hwnd->wx
any-hwnd->wx
set-hwnd-wx!
MessageBoxW)
MessageBoxW
_WndProc)
;; ----------------------------------------
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
(define all-cells (make-hash))
(define (hwnd->wx hwnd)
@ -95,7 +93,7 @@
0
hInstance
(LoadIconW #f IDI_APPLICATION)
(LoadCursorW #f IDC_ARROW)
#f
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
(cpointer-push-tag! p 'HBRUSH)
p)
@ -108,7 +106,7 @@
0
hInstance
#f
(LoadCursorW #f IDC_ARROW)
#f
(let ([p (ptr-add #f (+ COLOR_WINDOW 1))])
(cpointer-push-tag! p 'HBRUSH)
p)
@ -121,7 +119,7 @@
0
hInstance
#f
(LoadCursorW #f IDC_ARROW)
#f
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
(cpointer-push-tag! p 'HBRUSH)
p)
@ -136,7 +134,7 @@
0
hInstance
#f
(LoadCursorW #f IDC_ARROW)
#f
(if controls-are-transparent?
#f ; transparent
(let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
@ -146,3 +144,17 @@
"PLTTabPanel")))
(define-user32 MessageBoxW (_fun _HWND _string/utf-16 _string/utf-16 _UINT -> _int))
(define (register-no-cursor orig-name)
(let ([i (GetClassInfoW hInstance orig-name)])
(set-WNDCLASS-lpszClassName! i (string-append "PLT" orig-name))
(set-WNDCLASS-hCursor! i #f)
(void (RegisterClassW i))))
(register-no-cursor "BUTTON")
(register-no-cursor "STATIC")
(register-no-cursor "LISTBOX")
(register-no-cursor "COMBOBOX")
(register-no-cursor "msctls_trackbar32")
(register-no-cursor "msctls_progress32")
(register-no-cursor "SysTabControl32")

2
collects/tests/gracket/item.rkt
View File

@ -6,7 +6,7 @@
(define my-txt #f)
(define my-lb #f)
(define noisy? #f)
(define noisy? #t)
(define mdi-frame #f)
(define (mdi)

4
src/gracket/grmain.c
View File

@ -574,8 +574,4 @@ int APIENTRY WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR ignored
END_XFORM_SKIP;
# endif
#if _MSC_VER >= 1400
#pragma comment(linker,"/manifestdependency:\"type='win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'\"")
#endif
#endif

8
src/racket/main.c
View File

@ -369,6 +369,14 @@ static void do_scheme_rep(Scheme_Env *env, FinishArgs *fa)
}
}
/*========================================================================*/
/* win32 manifest */
/*========================================================================*/
#if _MSC_VER >= 1400
#pragma comment(linker,"/manifestdependency:\"type='win32' name='Microsoft.Windows.Common-Controls' version='6.0.0.0' processorArchitecture='*' publicKeyToken='6595b64144ccf1df' language='*'\"")
#endif
/*========================================================================*/
/* junk for testing */
/*========================================================================*/

2
src/worksp/gc2/make.rkt
View File

@ -297,7 +297,7 @@
(>= (file-or-directory-modify-seconds res)
(file-or-directory-modify-seconds rc)))
(system- (string-append
"rc /l 0x409 /I ../../wxwindow/include/msw /I ../../wxwindow/contrib/fafa "
"rc /l 0x409 "
(format "/fo~a ~a" res rc)))))
(check-rc "racket.res" "../racket/racket.rc")

22
src/worksp/racket/racket.manifest Normal file
View File

@ -0,0 +1,22 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="5.0.1.6"
processorArchitecture="X86"
name="Org.PLT-Scheme.Racket"
type="win32"
/>
<description>Racket.</description>
<dependency>
<dependentAssembly>
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"
version="6.0.0.0"
processorArchitecture="X86"
publicKeyToken="6595b64144ccf1df"
language="*"
/>
</dependentAssembly>
</dependency>
</assembly>

2
src/worksp/racket/racket.rc
View File

@ -60,3 +60,5 @@ BEGIN
VALUE "Translation", 0x409, 1200
END
END
CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "racket.manifest"