diff --git a/.gitignore b/.gitignore index eadcf34d0a..33c54eb54f 100644 --- a/.gitignore +++ b/.gitignore @@ -11,6 +11,7 @@ /*.pdb /*.ilk /GRacket.exe.manifest +/Racket.exe.manifest # a common convenient place to set the PLTADDON directory to /add-on/ diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 01bcbf9ce4..36b3cad6ee 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -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)) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index b912d0f337..24805c7e45 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -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 diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index c25e380157..267be1c3d1 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -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) diff --git a/collects/mred/private/wx/common/cursor-draw.rkt b/collects/mred/private/wx/common/cursor-draw.rkt index 9eb6d4589e..7814955447 100644 --- a/collects/mred/private/wx/common/cursor-draw.rkt +++ b/collects/mred/private/wx/common/cursor-draw.rkt @@ -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)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index ae282ddac3..19a1bec572 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -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 diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 8455301bd8..a59ced41e9 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -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) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 222204a25c..14d6f126f2 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -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 diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 066e4f3d82..85e40db4a1 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 8e8fbf0d4e..0fd6d31297 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 1cf398dce9..ab62b61b6d 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -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))))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 075501ad82..7b0a5480dc 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/cursor.rkt b/collects/mred/private/wx/win32/cursor.rkt index e535128434..ab98a79f29 100644 --- a/collects/mred/private/wx/win32/cursor.rkt +++ b/collects/mred/private/wx/win32/cursor.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 36740fe4be..7154f10766 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index e3f085ac01..27ff1cc565 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 1233d3f215..44b8fc50e1 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 6aaa3475cd..6abea495e8 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index b03def3bff..c7d441c4d7 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -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))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index 0f6ca833ea..1365fdcc05 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -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)))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 9ca17008a4..1acd02b62d 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 7283e24634..96878af41a 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -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 diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index d7eb37f56a..4bfaf1fdbb 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 901345d624..b296025037 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 49d30a1ff3..0fcdfef778 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -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 "") @@ -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)))) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 8974e65819..51279d653c 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -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)) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 8582a056cf..ce62183af2 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -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 diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 814bea15b8..eff854b3a6 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -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)) + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index b91cfe6df3..1c311c2d9d 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -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) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index f446348fad..30dae5f0ef 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -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") diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index e8bd6f9a00..cff8412a28 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -6,7 +6,7 @@ (define my-txt #f) (define my-lb #f) -(define noisy? #f) +(define noisy? #t) (define mdi-frame #f) (define (mdi) diff --git a/src/gracket/grmain.c b/src/gracket/grmain.c index bb7f5b6cab..753ebb1229 100644 --- a/src/gracket/grmain.c +++ b/src/gracket/grmain.c @@ -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 diff --git a/src/racket/main.c b/src/racket/main.c index 5031c7fe79..ac5f93d941 100644 --- a/src/racket/main.c +++ b/src/racket/main.c @@ -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 */ /*========================================================================*/ diff --git a/src/worksp/gc2/make.rkt b/src/worksp/gc2/make.rkt index 19057f3782..2f7a0528e5 100644 --- a/src/worksp/gc2/make.rkt +++ b/src/worksp/gc2/make.rkt @@ -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") diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest new file mode 100644 index 0000000000..d4b2cf78f7 --- /dev/null +++ b/src/worksp/racket/racket.manifest @@ -0,0 +1,22 @@ + + + +Racket. + + + + + + diff --git a/src/worksp/racket/racket.rc b/src/worksp/racket/racket.rc index 897563f302..f9a847b2d5 100644 --- a/src/worksp/racket/racket.rc +++ b/src/worksp/racket/racket.rc @@ -60,3 +60,5 @@ BEGIN VALUE "Translation", 0x409, 1200 END END + +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "racket.manifest"