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

win32 menu and button callbacks

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-22 15:15:48 -06:00
parent dd9a0772b3
commit bc0869f43c
10 changed files with 181 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt"
"../common/event.rkt"
"item.rkt"
"utils.rkt"
"const.rkt"
@ -14,6 +15,8 @@
(init parent cb label x y w h style font)
(define callback cb)
(super-new [parent parent]
[hwnd
(CreateWindowExW 0
@ -29,4 +32,11 @@
(auto-size label 40 12 12 0)
(define/public (do-command)
(queue-window-event this (lambda ()
(callback this
(new control-event%
[event-type 'button]
[time-stamp (current-milliseconds)])))))
(def/public-unimplemented set-border))

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

@ -566,3 +566,26 @@
(define GW_HWNDPREV 3)
(define GW_OWNER 4)
(define GW_CHILD 5)
(define MF_INSERT #x00000000)
(define MF_CHANGE #x00000080)
(define MF_APPEND #x00000100)
(define MF_DELETE #x00000200)
(define MF_REMOVE #x00001000)
(define MF_BYCOMMAND #x00000000)
(define MF_BYPOSITION #x00000400)
(define MF_SEPARATOR #x00000800)
(define MF_ENABLED #x00000000)
(define MF_GRAYED #x00000001)
(define MF_DISABLED #x00000002)
(define MF_UNCHECKED #x00000000)
(define MF_CHECKED #x00000008)
(define MF_USECHECKBITMAPS #x00000200)
(define MF_STRING #x00000000)
(define MF_BITMAP #x00000004)
(define MF_OWNERDRAW #x00000100)
(define MF_POPUP #x00000010)
(define MF_MENUBARBREAK #x00000020)
(define MF_MENUBREAK #x00000040)
(define MF_UNHILITE #x00000000)
(define MF_HILITE #x00000080)

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

@ -3,6 +3,7 @@
(only-in racket/list last)
ffi/unsafe
"../../syntax.rkt"
"../../lock.rkt"
"../common/queue.rkt"
"utils.ss"
"const.ss"
@ -88,6 +89,10 @@
(when on? (set-frame-focus))
(queue-window-event this (lambda () (on-activate on?))))))
0]
[(and (= msg WM_COMMAND)
(zero? (HIWORD wParam)))
(queue-window-event this (lambda () (on-menu-command (LOWORD wParam))))
0]
[else (super wndproc w msg wParam lParam)]))
(define/public (on-close) (void))
@ -104,7 +109,9 @@
(def/public-unimplemented on-toolbar-click)
(def/public-unimplemented on-menu-click)
(def/public-unimplemented on-menu-command)
(define/public (on-menu-command i) (void))
(def/public-unimplemented on-mdi-activate)
(define/public (enforce-size min-x min-y max-x max-y step-x step-y)
@ -153,7 +160,11 @@
(def/public-unimplemented iconized?)
(def/public-unimplemented get-menu-bar)
(define/public (set-menu-bar mb) (void))
(define menu-bar #f)
(define/public (set-menu-bar mb)
(atomically
(set! menu-bar mb)
(send mb set-parent this)))
(def/public-unimplemented set-icon)
(def/public-unimplemented iconize)

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

@ -1,13 +1,40 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt")
ffi/unsafe
"../../lock.rkt"
"../../syntax.rkt"
"utils.rkt"
"types.rkt"
"const.rkt")
(provide menu-bar%)
(defclass menu-bar% object%
(def/public-unimplemented set-label-top)
(def/public-unimplemented number)
(def/public-unimplemented enable-top)
(def/public-unimplemented delete)
(define/public (append m l) (void))
(super-new))
(define-user32 CreateMenu (_wfun -> _HMENU))
(define-user32 SetMenu (_wfun _HWND _HMENU -> (r : _BOOL)
-> (unless r (failed 'SetMenu))))
(define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL)
-> (unless r (failed 'DrawMenuBar))))
(define menu-bar%
(class object%
(super-new)
(define hmenu (CreateMenu))
(define menus null)
(def/public-unimplemented set-label-top)
(def/public-unimplemented number)
(def/public-unimplemented enable-top)
(def/public-unimplemented delete)
(public [append-item append])
(define (append-item m lbl)
(let ([l (append menus (list m))])
(atomically
(set! menus l)
(send m set-parent this lbl hmenu))))
(define/public (set-parent f)
(SetMenu (send f get-hwnd) hmenu)
(DrawMenuBar (send f get-hwnd)))))

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

@ -1,9 +1,43 @@
#lang scheme/base
(require scheme/class
(require ffi/unsafe
scheme/class
"../../syntax.rkt")
(provide menu-item%)
(provide menu-item%
id-to-menu-item)
;; Menu itens are identified by 16-bit numbers, so we have
;; to keep a hash mapping them to menu items.
(define ids (make-hash))
(define (id-to-menu-item id)
(let ([wb (hash-ref ids id #f)])
(and wb (weak-box-value wb))))
(defclass menu-item% object%
(define/public (id) this)
(define id
(let loop ()
(let ([id (add1 (random #x7FFE))])
(let ([wb (hash-ref ids id #f)])
(if (and wb
(weak-box-value wb))
(loop)
(begin
(hash-set! ids id (make-weak-box this))
id))))))
(define parent #f)
(define label #f)
(define checkable? #f)
(define/public (set-parent p lbl chkbl?)
(set! parent p)
(set! label lbl)
(set! checkable? chkbl?)
id)
(public [get-id id])
(define (get-id) id)
(super-new))

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

@ -1,14 +1,38 @@
#lang scheme/base
(require scheme/class
"../../syntax.rkt")
ffi/unsafe
"../../lock.rkt"
"../../syntax.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"menu-item.rkt")
(provide menu%)
(define-user32 CreatePopupMenu (_wfun -> _HMENU))
(define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL)
-> (unless r (failed 'AppendMenuW))))
(defclass menu% object%
(init label
(init lbl
callback
font)
(define label lbl)
(define parent #f)
(define items null)
(define hmenu (CreatePopupMenu))
(define/public (set-parent p lbl parent-hmenu)
(set! label lbl)
(set! parent p)
(AppendMenuW parent-hmenu
(bitwise-ior MF_POPUP MF_STRING)
hmenu
lbl))
(def/public-unimplemented select)
(def/public-unimplemented get-font)
(def/public-unimplemented set-width)
@ -24,9 +48,14 @@
(public [append-item append])
(define (append-item i label help-str-or-submenu chckable?)
(void))
(let ([id (send (id-to-menu-item i) set-parent this label chckable?)])
(atomically
(set! items (append items (list i)))
(AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label))))
(define/public (append-separator)
(void))
(atomically
(set! items (append items (list #f)))
(AppendMenuW hmenu MF_SEPARATOR #f #f)))
(super-new))

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

@ -6,6 +6,7 @@
"types.rkt"
"utils.rkt"
"const.rkt"
"menu-item.rkt"
racket/draw)
(provide
@ -84,7 +85,6 @@
(define-unimplemented get-display-depth)
(define-unimplemented is-color-display?)
(define-unimplemented file-selector)
(define-unimplemented id-to-menu-item)
(define-unimplemented get-the-x-selection)
(define-unimplemented get-the-clipboard)
(define-unimplemented show-print-setup)

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

@ -10,7 +10,9 @@
define-comctl32
define-uxtheme
define-mz
failed)
failed
SendMessageW)
(define gdi32-lib (ffi-lib "gdi32.dll"))
(define user32-lib (ffi-lib "user32.dll"))
@ -30,3 +32,5 @@
(error who "call failed (~s)"
(GetLastError)))
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))

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

@ -36,8 +36,6 @@
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL)
-> (unless r (failed 'MoveWindow))))
@ -46,6 +44,11 @@
(define SW_SHOW 5)
(define SW_HIDE 0)
(define-cstruct _NMHDR
([hwndFrom _HWND]
[idFrom _pointer]
[code _UINT]))
(define-user32 GetDialogBaseUnits (_fun -> _LONG))
(define measure-dc #f)
@ -99,6 +102,20 @@
[(= 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 wx
(begin
(send wx do-command)
0)
(DefWindowProcW 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]
[else
(DefWindowProcW w msg wParam lParam)]))

16
collects/mred/private/wxtop.rkt
View File

@ -680,17 +680,11 @@
(when mb (set! menu-bar mb))
(super set-menu-bar mb))]
[on-menu-command
(entry-point
(lambda (id)
(let ([wx (wx:id-to-menu-item id)])
(let ([go (lambda ()
(do-command (wx->mred wx) (make-object wx:control-event% 'menu)))])
(if (eq? 'windows (system-type))
;; Windows: need trampoline
(wx:queue-callback
(entry-point (lambda () (go)))
wx:middle-queue-key)
(go))))))]
(entry-point
(lambda (id)
(let ([wx (wx:id-to-menu-item id)])
(when wx
(do-command (wx->mred wx) (make-object wx:control-event% 'menu))))))]
[on-menu-click
(entry-point
(lambda ()