587 lines
20 KiB
Racket
587 lines
20 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
racket/draw
|
|
"../../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%
|
|
queue-window-event
|
|
queue-window-refresh-event
|
|
|
|
CreateWindowExW
|
|
GetWindowRect)
|
|
|
|
(define (unhide-cursor) (void))
|
|
|
|
(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
|
|
_UDWORD
|
|
_int _int _int _int
|
|
_HWND _HMENU _HINSTANCE _pointer
|
|
-> _HWND))
|
|
(define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) ->
|
|
(if r rect (failed 'GetWindowRect))))
|
|
(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))))
|
|
|
|
(define-cstruct _NMHDR
|
|
([hwndFrom _HWND]
|
|
[idFrom _pointer]
|
|
[code _UINT]))
|
|
|
|
(define-user32 GetDialogBaseUnits (_fun -> _LONG))
|
|
(define measure-dc #f)
|
|
|
|
(define theme-hfont #f)
|
|
|
|
(define-values (dlu-x dlu-y)
|
|
(let ([v (GetDialogBaseUnits)])
|
|
(values (* 1/4 (bitwise-and v #xFFFF))
|
|
(* 1/8 (arithmetic-shift v -16)))))
|
|
|
|
(define-cstruct _LOGBRUSH
|
|
([lbStyle _UINT]
|
|
[lbColor _COLORREF]
|
|
[lbHatch _pointer]))
|
|
|
|
(define BS_NULL 1)
|
|
(define transparent-logbrush (make-LOGBRUSH BS_NULL 0 #f))
|
|
|
|
(define-gdi32 CreateBrushIndirect (_wfun _LOGBRUSH-pointer -> _HBRUSH))
|
|
|
|
(define TRANSPARENT 1)
|
|
(define-gdi32 SetBkMode (_wfun _HDC _int -> (r : _int)
|
|
-> (when (zero? r) (failed 'SetBkMode))))
|
|
|
|
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
|
|
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
|
|
|
|
(defclass window% object%
|
|
(init-field parent hwnd)
|
|
(init style
|
|
[extra-hwnds null])
|
|
|
|
(super-new)
|
|
|
|
(define eventspace (current-eventspace))
|
|
|
|
(set-hwnd-wx! hwnd this)
|
|
(for ([extra-hwnd (in-list extra-hwnds)])
|
|
(set-hwnd-wx! extra-hwnd this))
|
|
|
|
(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)
|
|
(ptr-equal? hwnd a-hwnd))
|
|
|
|
(define/public (wndproc 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)))
|
|
0]
|
|
[(= msg WM_KILLFOCUS)
|
|
(queue-window-event this (lambda () (on-kill-focus)))
|
|
0]
|
|
[(and (= msg WM_SYSKEYDOWN)
|
|
(or (= wParam VK_MENU) (= wParam VK_F4))) ;; F4 is close
|
|
(unhide-cursor)
|
|
(begin0
|
|
(default w msg wParam lParam)
|
|
(do-key w wParam lParam #f #f))]
|
|
[(= msg WM_KEYDOWN)
|
|
(do-key w wParam lParam #f #f)
|
|
0]
|
|
[(= msg WM_KEYUP)
|
|
(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 w wParam lParam #t #f))]
|
|
[(= msg WM_CHAR)
|
|
(do-key w 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)])
|
|
(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)]
|
|
[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)
|
|
|
|
(define/public (show on?)
|
|
(atomically (direct-show on?)))
|
|
|
|
(define shown? #f)
|
|
(define/public (direct-show on? [on-mode SW_SHOW])
|
|
;; atomic mode
|
|
(set! shown? (and on? #t))
|
|
(register-child-in-parent on?)
|
|
(unless on? (not-focus-child this))
|
|
(ShowWindow hwnd (if on? on-mode SW_HIDE)))
|
|
(unless (memq 'invisible style)
|
|
(show #t))
|
|
|
|
(def/public-unimplemented on-drop-file)
|
|
|
|
(define/public (on-size w h) (void))
|
|
|
|
(define/public (on-set-focus) (void))
|
|
(define/public (on-kill-focus) (void))
|
|
(define/public (get-handle) hwnd)
|
|
|
|
(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 enabled? parent-enabled?))
|
|
|
|
(define/public (is-shown-to-root?)
|
|
(and shown?
|
|
(send parent is-shown-to-root?)))
|
|
|
|
(define/public (is-shown?)
|
|
shown?)
|
|
|
|
(def/public-unimplemented set-phantom-size)
|
|
|
|
(define/public (paint-children) (void))
|
|
|
|
(define/public (get-x)
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(- (RECT-left r) (send parent get-x))))
|
|
(define/public (get-y)
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(- (RECT-top r) (send parent get-y))))
|
|
|
|
(define/public (get-width)
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(- (RECT-right r) (RECT-left r))))
|
|
(define/public (get-height)
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(- (RECT-bottom r) (RECT-top r))))
|
|
|
|
(define/public (set-size x y w h)
|
|
(if (or (= x -11111)
|
|
(= y -11111)
|
|
(= w -1)
|
|
(= h -1))
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(MoveWindow hwnd
|
|
(if (= x -11111) (RECT-left r) x)
|
|
(if (= y -11111) (RECT-right r) y)
|
|
(if (= w -1) (- (RECT-right r) (RECT-left r)) w)
|
|
(if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)
|
|
#t))
|
|
(MoveWindow hwnd x y w h #t))
|
|
(on-size w h)
|
|
(unless (and (= w -1) (= h -1))
|
|
(on-resized))
|
|
(refresh))
|
|
(define/public (move x y)
|
|
(set-size x y -1 -1))
|
|
|
|
(define/public (set-control-font font [hwnd hwnd])
|
|
(unless theme-hfont
|
|
(set! theme-hfont (CreateFontIndirectW (get-theme-logfont))))
|
|
(SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0))
|
|
|
|
(define/public (auto-size label min-w min-h dw dh
|
|
[resize
|
|
(lambda (w h) (set-size -11111 -11111 w h))]
|
|
#:combine-width [combine-w max]
|
|
#:combine-height [combine-h max])
|
|
(unless measure-dc
|
|
(let* ([bm (make-object bitmap% 1 1)]
|
|
[dc (make-object bitmap-dc% bm)]
|
|
[font (make-object font% 8 'system)])
|
|
(send dc set-font font)
|
|
(set! measure-dc dc)))
|
|
(let-values ([(w h d a) (let loop ([label label])
|
|
(cond
|
|
[(null? label) (values 0 0 0 0)]
|
|
[(label . is-a? . bitmap%)
|
|
(values (send label get-width)
|
|
(send label get-height)
|
|
0
|
|
0)]
|
|
[(pair? label)
|
|
(let-values ([(w1 h1 d1 a1)
|
|
(loop (car label))]
|
|
[(w2 h2 d2 a2)
|
|
(loop (cdr label))])
|
|
(values (combine-w w1 w2) (combine-h h1 h2)
|
|
(combine-h d1 d1) (combine-h a1 a2)))]
|
|
[else
|
|
(send measure-dc get-text-extent label #f #t)]))]
|
|
[(->int) (lambda (v) (inexact->exact (floor v)))])
|
|
(resize (max (->int (+ w dw)) (->int (* dlu-x min-w)))
|
|
(max (->int (+ h dh)) (->int (* dlu-y min-h))))))
|
|
|
|
(def/public-unimplemented popup-menu)
|
|
(def/public-unimplemented center)
|
|
|
|
(define/public (get-parent) parent)
|
|
(define/public (is-frame?) #f)
|
|
|
|
(define/public (refresh) (void))
|
|
(define/public (on-resized) (void))
|
|
|
|
(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))
|
|
|
|
(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))])
|
|
(set-box! w (- (RECT-right r) (RECT-left r)))
|
|
(set-box! h (- (RECT-bottom r) (RECT-top r)))))
|
|
|
|
(define/public (get-size w h)
|
|
(let ([r (GetWindowRect (get-client-hwnd))])
|
|
(set-box! w (- (RECT-right r) (RECT-left r)))
|
|
(set-box! h (- (RECT-bottom r) (RECT-top r)))))
|
|
|
|
(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 [child-hwnd hwnd])
|
|
(when (can-accept-focus?)
|
|
(set-top-focus this null child-hwnd)))
|
|
|
|
(define/public (can-accept-focus?)
|
|
(child-can-accept-focus?))
|
|
|
|
(define/public (child-can-accept-focus?)
|
|
(and shown?
|
|
(send parent child-can-accept-focus?)))
|
|
|
|
(define/public (set-top-focus win win-path hwnd)
|
|
(send parent set-top-focus win (cons this win-path) hwnd))
|
|
(define/public (not-focus-child v)
|
|
(send parent not-focus-child v))
|
|
|
|
(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 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? w e)
|
|
(begin
|
|
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
|
|
#t)
|
|
(constrained-reply (get-eventspace)
|
|
(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 control-hwnd (make-e type)))))
|
|
|
|
(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)
|
|
(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 #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))
|
|
|
|
(define/public (send-leaves mk)
|
|
(set! mouse-in? #f)
|
|
(let ([e (mk 'leave)])
|
|
(if (eq? (current-eventspace) (get-eventspace))
|
|
(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? w e)
|
|
#f)
|
|
|
|
(define/public (dispatch-on-char/sync e)
|
|
(pre-event-refresh #t)
|
|
(dispatch-on-char e #f))
|
|
(define/public (dispatch-on-char e just-pre?)
|
|
(cond
|
|
[(other-modal? this) #t]
|
|
[(call-pre-on-char this e) #t]
|
|
[just-pre? #f]
|
|
[else (when (is-enabled-to-root?) (on-char e)) #t]))
|
|
|
|
(define/public (dispatch-on-event/sync e)
|
|
(pre-event-refresh #f)
|
|
(dispatch-on-event e #f))
|
|
(define/public (dispatch-on-event e just-pre?)
|
|
(cond
|
|
[(other-modal? this) #t]
|
|
[(call-pre-on-event this e) #t]
|
|
[just-pre? #f]
|
|
[else (when (is-enabled-to-root?) (on-event e)) #t]))
|
|
|
|
(define/public (call-pre-on-event w e)
|
|
(or (send parent call-pre-on-event w e)
|
|
(pre-on-event w e)))
|
|
(define/public (call-pre-on-char w e)
|
|
(or (send parent call-pre-on-char w e)
|
|
(pre-on-char w e)))
|
|
(define/public (pre-on-event w e) #f)
|
|
(define/public (pre-on-char w e) #f)
|
|
|
|
(define/public (on-char e) (void))
|
|
(define/public (on-event e) (void))
|
|
|
|
(define/private (pre-event-refresh key?)
|
|
;; Since we break the connection between the
|
|
;; Cocoa queue and event handling, we
|
|
;; re-sync the display in case a stream of
|
|
;; events (e.g., key repeat) have a corresponding
|
|
;; stream of screen updates.
|
|
(void))
|
|
|
|
(define/public (get-dialog-level) (send parent get-dialog-level)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (queue-window-event win thunk)
|
|
(queue-event (send win get-eventspace) thunk))
|
|
|
|
(define (queue-window-refresh-event win thunk)
|
|
(queue-refresh-event (send win get-eventspace) thunk))
|