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

win32: more menus and controls

Browse Source 
original commit: 912a2d515170698d61137dc9eecb25712065ff5e
This commit is contained in:
Matthew Flatt 2010-10-01 19:26:30 -06:00
parent 8c385a23bf
commit 428cf1577e
27 changed files with 386 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mred/private/wx/common/dialog.rkt Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require racket/class
"../../lock.rkt"
"queue.rkt")
(provide dialog-mixin)
(define dialog-level-counter 0)
(define (dialog-mixin %)
(class %
(super-new)
(define close-sema #f)
(define dialog-level 0)
(define/override (get-dialog-level) dialog-level)
(define/override (frame-relative-dialog-status win)
(let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other])))
(define/override (direct-show on?)
;; atomic mode
(when on?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(unless on?
(set! dialog-level 0))
(unless on?
(atomically
(when close-sema
(semaphore-post close-sema)
(set! close-sema #f))))
(super direct-show on?))
(define/override (show on?)
(if on?
(let ([s (atomically
(let ([s (or close-sema (make-semaphore))])
(unless close-sema (set! close-sema s))
(semaphore-peek-evt s)))])
(super show on?)
(yield s)
(void))
(super show on?)))))

72
collects/mred/private/wx/gtk/dialog.rkt
View File

@ -3,6 +3,7 @@
ffi/unsafe
"../../syntax.rkt"
"../common/queue.rkt"
"../common/dialog.rkt"
"../../lock.rkt"
"types.rkt"
"utils.rkt"
@ -19,60 +20,23 @@
(define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void))
(define dialog-level-counter 0)
(define dialog%
(class (dialog-mixin frame%)
(inherit get-gtk
get-parent)
(defclass dialog% frame%
(inherit get-gtk
get-parent)
(super-new [is-dialog? #t])
(super-new [is-dialog? #t])
(gtk_window_set_type_hint (get-gtk) GDK_WINDOW_TYPE_HINT_DIALOG)
(define close-sema #f)
(gtk_window_set_type_hint (get-gtk) GDK_WINDOW_TYPE_HINT_DIALOG)
(let ([p (get-parent)])
(when p
(gtk_window_set_transient_for (get-gtk) (send p get-gtk))))
(define dialog-level 0)
(define/override (get-dialog-level) dialog-level)
(define/override (frame-relative-dialog-status win)
(let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other])))
(define/override (direct-show on?)
(when on?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(unless on?
(set! dialog-level 0))
(unless on?
(atomically
(when close-sema
(semaphore-post close-sema)
(set! close-sema #f))))
(super direct-show on?))
(define/override (center dir wrt)
(if (eq? dir 'both)
(gtk_window_set_position (get-gtk)
(if (get-parent)
GTK_WIN_POS_CENTER_ON_PARENT
GTK_WIN_POS_CENTER))
(super center dir wrt)))
(define/override (show on?)
(if on?
(let ([s (atomically
(let ([s (or close-sema (make-semaphore))])
(unless close-sema (set! close-sema s))
(semaphore-peek-evt s)))])
(super show on?)
(yield s)
(void))
(super show on?))))
(let ([p (get-parent)])
(when p
(gtk_window_set_transient_for (get-gtk) (send p get-gtk))))
(define/override (center dir wrt)
(if (eq? dir 'both)
(gtk_window_set_position (get-gtk)
(if (get-parent)
GTK_WIN_POS_CENTER_ON_PARENT
GTK_WIN_POS_CENTER))
(super center dir wrt)))))

14
collects/mred/private/wx/gtk/window.rkt
View File

@ -475,15 +475,15 @@
(define shown? #f)
(define/public (direct-show on?)
(atomically
(if on?
(gtk_widget_show gtk)
(gtk_widget_hide gtk))
(set! shown? (and on? #t))
(register-child-in-parent on?))
(if on?
(gtk_widget_show gtk)
(gtk_widget_hide gtk))
(set! shown? (and on? #t))
(register-child-in-parent on?)
(when on? (reset-child-dcs)))
(define/public (show on?)
(direct-show on?))
(atomically
(direct-show on?)))
(define/public (reset-child-dcs) (void))
(define/public (is-shown?) shown?)
(define/public (is-shown-to-root?)

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

@ -33,7 +33,8 @@
(define/public (get-class) "PLTBUTTON")
(define/public (get-flags) BS_PUSHBUTTON)
(super-new [parent parent]
(super-new [callback cb]
[parent parent]
[hwnd
(CreateWindowExW 0
(get-class)

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

@ -18,11 +18,8 @@
(provide canvas%)
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
-> (unless r (failed 'InvalidateRect))))
(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL)
-> (unless r (failed 'ShowScrollbar))))

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

@ -51,7 +51,8 @@
(SendMessageW hwnd CB_SETCURSEL 0 0)
(super-new [parent parent]
(super-new [callback cb]
[parent parent]
[hwnd hwnd]
[style style])

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

@ -598,3 +598,7 @@
(define SW_SHOW 5)
(define SW_HIDE 0)
(define HORZRES 8)
(define VERTRES 10)

3
collects/mred/private/wx/win32/dc.rkt
View File

@ -17,9 +17,6 @@
request-flush-delay
cancel-flush-delay)
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int))
(define win32-bitmap%
(class bitmap%
(init w h hwnd)

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

@ -6,6 +6,7 @@
"../../lock.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"../common/dialog.rkt"
"utils.ss"
"const.ss"
"types.ss"
@ -50,13 +51,11 @@
(define dialog-proc (function-ptr dlgproc _DialogProc))
(define dialog-level-counter 0)
(define dialog%
(class frame%
(class (dialog-mixin frame%)
(super-new)
(define/override (create-frame parent label w h)
(define/override (create-frame parent label w h style)
(let ([hwnd
(CreateDialogIndirectParamW hInstance
(make-DLGTEMPLATE
@ -70,23 +69,4 @@
(MoveWindow hwnd 0 0 w h #t)
hwnd))
(define/override (is-dialog?) #t)
(define dialog-level 0)
(define/override (get-dialog-level) dialog-level)
(define/override (frame-relative-dialog-status win)
(let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other])))
(define/override (direct-show on?)
(when on?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(unless on?
(set! dialog-level 0))
(super direct-show on?))))
(define/override (is-dialog?) #t)))

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

@ -22,14 +22,38 @@
(define-user32 GetActiveWindow (_wfun -> _HWND))
(define-user32 SetFocus (_wfun _HWND -> _HWND))
(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int))
(define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL)
-> (unless r (failed 'SystemParametersInfo))))
(define SPI_GETWORKAREA #x0030)
(define (display-size xb yb ?)
(atomically
(let ([hdc (GetDC #f)])
(set-box! xb (GetDeviceCaps hdc HORZRES))
(set-box! yb (GetDeviceCaps hdc VERTRES))
(ReleaseDC #f hdc))))
(define (display-origin xb yb avoid-bars?)
(if avoid-bars?
(let ([r (make-RECT 0 0 0 0)])
(SystemParametersInfoW SPI_GETWORKAREA 0 r 0)
(set-box! xb (RECT-left r))
(set-box! yb (RECT-top r)))
(begin
(set-box! xb 0)
(set-box! yb 0))))
(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))
(define WS_EX_TOOLWINDOW #x00000080)
(define WS_EX_TOPMOST #x00000008)
(define WS_EX_WINDOWEDGE #x00000100)
(define WS_EX_PALETTEWINDOW (bitwise-ior WS_EX_WINDOWEDGE
WS_EX_TOOLWINDOW
WS_EX_TOPMOST))
(defclass frame% window%
(init parent
@ -46,11 +70,29 @@
pre-on-char pre-on-event
reset-cursor-in-child)
(define/public (create-frame parent label w h)
(CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED)
(define/public (create-frame parent label w h style)
(CreateWindowExW (if (memq 'float style)
(bitwise-ior WS_EX_TOOLWINDOW
(if (memq 'no-caption style)
WS_EX_TOPMOST
WS_EX_PALETTEWINDOW))
0)
"PLTFrame"
(if label label "")
WS_OVERLAPPEDWINDOW
(bitwise-ior
WS_POPUP
(if (memq 'no-resize-border style)
0
(bitwise-ior WS_THICKFRAME
WS_BORDER
WS_MAXIMIZEBOX))
(if (memq 'no-system-menu style)
0
WS_SYSMENU)
(if (memq 'no-caption style)
0
(bitwise-ior WS_CAPTION
WS_MINIMIZEBOX)))
0 0 w h
#f
#f
@ -58,7 +100,7 @@
#f))
(super-new [parent #f]
[hwnd (create-frame parent label w h)]
[hwnd (create-frame parent label w h style)]
[style (cons 'invisible style)])
(define hwnd (get-hwnd))
@ -79,6 +121,7 @@
(super show on?))
(define/override (direct-show on?)
;; atomic mode
(when (eq? mouse-frame this) (set! mouse-frame #f))
(register-frame-shown this on?)
(super direct-show on?))
@ -154,7 +197,7 @@
(define/private (set-frame-focus)
(when focus-window-path
(SetFocus (send (last focus-window-path) get-hwnd))))
(SetFocus (send (last focus-window-path) get-focus-hwnd))))
(define/override (child-can-accept-focus?)
#t)
@ -246,6 +289,10 @@
(define/override (is-frame?) #t)
(def/public-unimplemented set-icon)
(define/public (set-icon bm mask [mode 'both])
(void))
(def/public-unimplemented iconize)
(def/public-unimplemented set-title))
(define/public (set-title s)
(SetWindowTextW (get-hwnd) s)))

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

@ -44,7 +44,8 @@
hInstance
#f))
(super-new [parent parent]
(super-new [callback void]
[parent parent]
[hwnd hwnd]
[style style])

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

@ -46,7 +46,8 @@
hInstance
#f))
(super-new [parent parent]
(super-new [callback void]
[parent parent]
[hwnd hwnd]
[style style])

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

@ -15,8 +15,6 @@
(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL)
-> (unless r (failed 'DeleteDC))))
(define-gdi32 SelectObject (_wfun _HDC _HBITMAP -> _HBITMAP))
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int))
(define (bitmap->hbitmap bm)
(let* ([w (send bm get-width)]

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

@ -28,7 +28,12 @@
(class %
(inherit on-set-focus
on-kill-focus
try-mouse)
try-mouse
wndproc)
(init-field [callback void])
(define/public (command e)
(callback this e))
(define old-control-procs null)
@ -51,7 +56,7 @@
(queue-window-event this (lambda () (on-kill-focus)))
(default w msg wParam lParam)]
[else
(default w msg wParam lParam)])))
(wndproc w msg wParam lParam default)])))
(define/public (default-ctlproc w msg wParam lParam)
(let loop ([l old-control-procs])
@ -72,6 +77,6 @@
(define/public (set-label s)
(SetWindowTextW (get-hwnd) s))
(def/public-unimplemented get-label)
(def/public-unimplemented command)))
(def/public-unimplemented get-label)))

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

@ -217,7 +217,9 @@
[e (new key-event%
[key-code (if is-up?
'release
id)]
(if (equal? id #\033)
'escape
id))]
[shift-down shift-down?]
[control-down control-down?]
[meta-down #f]

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

@ -78,7 +78,8 @@
(for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
(super-new [parent parent]
(super-new [callback cb]
[parent parent]
[hwnd hwnd]
[style style])

7
collects/mred/private/wx/win32/menu-bar.rkt
View File

@ -23,10 +23,13 @@
(define menus null)
(def/public-unimplemented set-label-top)
(define/public (set-label-top pos str)
(void)) ;; FIXME
(def/public-unimplemented number)
(def/public-unimplemented enable-top)
(def/public-unimplemented delete)
(define/public (delete which pos)
(void)) ;; FIXME
(public [append-item append])
(define (append-item m lbl)

35
collects/mred/private/wx/win32/menu-item.rkt
View File

@ -1,6 +1,9 @@
#lang scheme/base
(require ffi/unsafe
scheme/class
"utils.rkt"
"types.rkt"
"const.rkt"
"../../syntax.rkt")
(provide menu-item%
@ -14,6 +17,12 @@
(let ([wb (hash-ref ids id #f)])
(and wb (weak-box-value wb))))
(define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT))
(define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD))
(define-user32 ModifyMenuW (_wfun _HMENU _UINT _UINT _UINT_PTR _string/utf-16
-> (r : _BOOL)
-> (unless r (failed 'ModifyMenuW))))
(defclass menu-item% object%
(define id
@ -30,13 +39,37 @@
(define parent #f)
(define label #f)
(define checkable? #f)
(define submenu #f)
(define/public (set-parent p lbl chkbl?)
(define/public (set-parent p lbl chkbl? subm)
(set! parent p)
(set! label lbl)
(set! checkable? chkbl?)
id)
(define/public (set-label hmenu pos str)
(if submenu
(ModifyMenuW hmenu pos
(bitwise-ior MF_BYPOSITION MF_STRING MF_POPUP)
(cast (send submenu get-hmenu) _HMENU _UINT_PTR)
str)
(ModifyMenuW hmenu pos
(bitwise-ior MF_BYPOSITION MF_STRING
(GetMenuState hmenu pos MF_BYPOSITION))
id
str)))
(define/public (set-check hmenu pos on?)
(void
(CheckMenuItem hmenu pos (bitwise-ior MF_BYPOSITION
(if on?
MF_CHECKED
MF_UNCHECKED)))))
(define/public (get-check hmenu pos)
(let ([s (GetMenuState hmenu pos MF_BYPOSITION)])
(not (zero? (bitwise-and s MF_CHECKED)))))
(public [get-id id])
(define (get-id) id)

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

@ -38,28 +38,57 @@
(def/public-unimplemented get-font)
(def/public-unimplemented set-width)
(def/public-unimplemented set-title)
(def/public-unimplemented set-label)
(define/private (with-item id proc)
(let loop ([items items] [pos 0])
(cond
[(null? items) (void)]
[(and (car items)
(eq? id (send (car items) id)))
(proc (car items) pos)]
[else (loop (cdr items) (add1 pos))])))
(define/public (set-label id str)
(with-item
id
(lambda (i pos)
(send i set-label hmenu pos str))))
(def/public-unimplemented set-help-string)
(def/public-unimplemented number)
(define/public (enable id on?)
(for ([i (in-list items)]
[pos (in-naturals)])
(when (and i (eq? id (send i id)))
(void
(EnableMenuItem hmenu pos (bitwise-ior MF_BYPOSITION
(if on? MF_ENABLED MF_GRAYED)))))))
(with-item
id
(lambda (i pos)
(void
(EnableMenuItem hmenu pos
(bitwise-ior MF_BYPOSITION
(if on? MF_ENABLED MF_GRAYED)))))))
(define/public (check id on?)
(with-item
id
(lambda (i pos)
(send i set-check hmenu pos on?))))
(define/public (checked? id)
(with-item
id
(lambda (i pos)
(send i get-check hmenu pos))))
(def/public-unimplemented check)
(def/public-unimplemented checked?)
(def/public-unimplemented delete-by-position)
(def/public-unimplemented delete)
(define/public (delete id)
(void))
(public [append-item append])
(define (append-item id label help-str-or-submenu chckable?)
(let ([i (id-to-menu-item id)])
(when i
(let ([id (send i set-parent this label chckable?)])
(let ([id (send i set-parent this label chckable?
(and (help-str-or-submenu . is-a? . menu%)
help-str-or-submenu))])
(atomically
(set! items (append items (list i)))
(AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label))))))

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

@ -60,7 +60,8 @@
(define/public (get-class) "PLTSTATIC")
(super-new [parent parent]
(super-new [callback void]
[parent parent]
[hwnd
(CreateWindowExW (if (string? label) WS_EX_TRANSPARENT 0)
(get-class)

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

@ -57,7 +57,7 @@
(define (get-panel-background) (make-object color% "gray"))
(define-unimplemented play-sound)
(define-unimplemented find-graphical-system-path)
(define-unimplemented register-collecting-blit)
(define (register-collecting-blit . args) (void))
(define-unimplemented unregister-collecting-blit)
(define (shortcut-visible-in-label? [? #f]) #t)
(define-unimplemented location->window)
@ -69,7 +69,7 @@
(define (get-control-font-size-in-pixels?) #t)
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)
(define-unimplemented flush-display)
(define (flush-display) (void))
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define-unimplemented bell)
@ -79,13 +79,13 @@
(define-unimplemented end-busy-cursor)
(define-unimplemented is-busy?)
(define-unimplemented begin-busy-cursor)
(define-unimplemented get-display-depth)
(define (get-display-depth) 32)
(define-unimplemented is-color-display?)
(define-unimplemented file-selector)
(define-unimplemented get-the-x-selection)
(define-unimplemented get-the-clipboard)
(define-unimplemented show-print-setup)
(define-unimplemented can-show-print-setup?)
(define (can-show-print-setup?) #f)
(define (get-highlight-background-color)
(let ([c (GetSysColor COLOR_HIGHLIGHT)])

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

@ -29,7 +29,8 @@
(inherit auto-size set-control-font
is-enabled-to-root?
subclass-control)
subclass-control
set-focus)
(define callback cb)
(define current-value val)
@ -84,7 +85,8 @@
(unless (= val -1)
(SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0))
(super-new [parent parent]
(super-new [callback cb]
[parent parent]
[hwnd hwnd]
[extra-hwnds radio-hwnds]
[style style])
@ -115,7 +117,19 @@
[time-stamp (current-milliseconds)])))))))
(def/public-unimplemented button-focus)
(define focused 0)
(define/public (button-focus i)
(if (= i -1)
(min focused (length radio-hwnds))
(begin
(set! focused i)
(set-focus (list-ref radio-hwnds i)))))
(define/override (get-focus-hwnd)
(if (= focused -1)
hwnd
(list-ref radio-hwnds focused)))
(define/public (set-selection val)
(atomically

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

@ -90,7 +90,8 @@
(define hwnd (or panel-hwnd slider-hwnd))
(super-new [parent parent]
(super-new [callback cb]
[parent parent]
[hwnd hwnd]
[extra-hwnds
(if panel-hwnd

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

@ -18,6 +18,12 @@
(define TCM_SETUNICODEFORMAT #x2005)
(define TCM_FIRST #x1300)
(define TCM_INSERTITEMW (+ TCM_FIRST 62))
(define TCM_SETITEMW (+ TCM_FIRST 61))
(define TCM_SETCURSEL (+ TCM_FIRST 12))
(define TCM_GETCURSEL (+ TCM_FIRST 11))
(define TCM_GETITEMCOUNT (+ TCM_FIRST 4))
(define TCM_DELETEITEM (+ TCM_FIRST 8))
(define TCM_DELETEALLITEMS (+ TCM_FIRST 9))
(define-cstruct _TCITEMW
([mask _UINT]
@ -37,7 +43,8 @@
(define callback void)
(inherit auto-size set-control-font)
(inherit auto-size set-control-font
is-shown-to-root?)
(define hwnd
(CreateWindowExW 0
@ -61,7 +68,9 @@
hInstance
#f))
(super-new [parent parent]
(super-new [callback (lambda (c) (callback c))]
[extra-hwnds (list client-hwnd)]
[parent parent]
[hwnd hwnd]
[style style])
@ -70,15 +79,17 @@
(SendMessageW hwnd TCM_SETUNICODEFORMAT 1 0)
(atomically
(let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)])
(set-TCITEMW-mask! item TCIF_TEXT)
(for ([i (in-list choices)]
[pos (in-naturals)])
(set-TCITEMW-pszText! item i)
(SendMessageW hwnd TCM_INSERTITEMW pos (cast item _pointer _LPARAM))
(free (TCITEMW-pszText item)))
(free item)))
(define/private (with-item proc)
(atomically
(let ([item (cast (malloc _TCITEMW 'raw) _pointer _TCITEMW-pointer)])
(set-TCITEMW-mask! item TCIF_TEXT)
(proc item
(lambda () (free (TCITEMW-pszText item)))
(lambda (msg w)
(SendMessageW hwnd msg w (cast item _pointer _LPARAM))))
(free item))))
(set choices)
(define tab-height 0)
@ -95,6 +106,64 @@
(unless (or (= w -1) (= h -1))
(MoveWindow client-hwnd 1 (+ tab-height 2) (- w 4) (- h tab-height 6) #t)))
(define/override (is-command? cmd)
(= cmd 64985))
(define/public (do-command control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%
[event-type 'tab-panel]
[time-stamp (current-milliseconds)])))))
;; Needed after some actions:
(define/private (refresh)
(InvalidateRect hwnd #f #f))
(define/public (set-label pos str)
(with-item
(lambda (item done-str send-msg)
(set-TCITEMW-pszText! item str)
(send-msg TCM_SETITEMW pos)
(done-str)))
(refresh))
(define/public (set-selection pos)
(SendMessageW hwnd TCM_SETCURSEL pos 0)
(refresh))
(define/public (get-selection)
(SendMessageW hwnd TCM_GETCURSEL 0 0))
(define/public (number)
(SendMessageW hwnd TCM_GETITEMCOUNT 0 0))
(define/public (delete pos)
(SendMessageW hwnd TCM_DELETEITEM pos 0)
(refresh))
(public [append* append])
(define (append* str)
(with-item
(lambda (item done-str send-msg)
(set-TCITEMW-pszText! item str)
(send-msg TCM_INSERTITEMW (number))
(done-str)))
(refresh))
(define/public (set choices)
(let ([sel (get-selection)])
(SendMessageW hwnd TCM_DELETEALLITEMS 0 0)
(with-item
(lambda (item done-str send-msg)
(for ([str (in-list choices)]
[pos (in-naturals)])
(set-TCITEMW-pszText! item str)
(send-msg TCM_INSERTITEMW pos)
(done-str))))
(let ([sel (max 0 (min (length choices) sel))])
(set-selection sel))))
(define/public (set-callback cb)
(set! callback cb))))

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

@ -4,12 +4,14 @@
(provide _wfun
_DWORD
_UDWORD
_ATOM
_WPARAM
_LPARAM
_LRESULT
_BOOL
_UINT
_UINT_PTR
_BYTE
_LONG
_SHORT
@ -45,12 +47,14 @@
(_fun #:abi 'stdcall . a))
(define _DWORD _int32)
(define _UDWORD _uint32)
(define _ATOM _int)
(define _WPARAM _long)
(define _LPARAM _long)
(define _LRESULT _long)
(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v)))))
(define _UINT _uint)
(define _UINT_PTR _ulong)
(define _BYTE _uint8)
(define _HRESULT _int32)
(define _WCHAR _int16)

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

@ -20,7 +20,10 @@
ShowWindow
EnableWindow
SetWindowTextW
SetCursor)
SetCursor
GetDC
ReleaseDC
InvalidateRect)
(define gdi32-lib (ffi-lib "gdi32.dll"))
(define user32-lib (ffi-lib "user32.dll"))
@ -64,3 +67,8 @@
(define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR))
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
-> (unless r (failed 'InvalidateRect))))

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

@ -43,7 +43,7 @@
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
_DWORD
_UDWORD
_int _int _int _int
_HWND _HMENU _HINSTANCE _pointer
-> _HWND))
@ -92,8 +92,6 @@
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
-> (unless r (failed 'InvalidateRect))))
(defclass window% object%
(init-field parent hwnd)
@ -110,6 +108,7 @@
(define/public (get-hwnd) hwnd)
(define/public (get-client-hwnd) hwnd)
(define/public (get-focus-hwnd) hwnd)
(define/public (get-eventspace) eventspace)
(define/public (is-hwnd? a-hwnd)
@ -125,24 +124,24 @@
[(= 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)))]
[(and (= msg WM_SYSKEYDOWN)
(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)))]
[(and (= msg WM_SYSCHAR)
(= 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]
@ -155,12 +154,14 @@
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]
[control-hwnd (NMHDR-hwndFrom nmhdr)]
[wx (any-hwnd->wx control-hwnd)])
(if (and wx (send wx is-command? (LOWORD (NMHDR-code nmhdr))))
(begin
(send wx do-command control-hwnd)
0)
(default w msg wParam lParam)))]
[(or (= msg WM_HSCROLL)
(= msg WM_VSCROLL))
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
@ -177,10 +178,11 @@
(define/public (control-scrolled) #f)
(define/public (show on?)
(direct-show on?))
(atomically (direct-show on?)))
(define shown? #f)
(define/public (direct-show on?)
;; atomic mode
(set! shown? (and on? #t))
(register-child-in-parent on?)
(unless on? (not-focus-child this))
@ -361,9 +363,9 @@
(define/public (no-cursor-handle-here)
(send parent cursor-updated-here))
(define/public (set-focus)
(define/public (set-focus [child-hwnd hwnd])
(when (can-accept-focus?)
(set-top-focus this null hwnd)))
(set-top-focus this null child-hwnd)))
(define/public (can-accept-focus?)
(child-can-accept-focus?))