From aee9c4da2570ed645b3bd52d210aee80c9aa9f34 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 25 Oct 2010 18:22:30 -0600 Subject: [PATCH] some fixes prompted by the test suite original commit: 4f2e59e7a654c9724d546f619589ca68cc334d59 --- collects/mred/private/wx/cocoa/canvas.rkt | 29 ++++++--- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 12 ++-- collects/mred/private/wx/cocoa/gauge.rkt | 8 ++- collects/mred/private/wx/cocoa/list-box.rkt | 5 +- collects/mred/private/wx/cocoa/menu.rkt | 3 +- collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/cocoa/queue.rkt | 1 + collects/mred/private/wx/cocoa/radio-box.rkt | 10 +-- collects/mred/private/wx/cocoa/utils.rkt | 21 +++++-- .../mred/private/wx/common/backing-dc.rkt | 2 + collects/mred/private/wx/common/queue.rkt | 26 +++++--- collects/mred/private/wx/common/timer.rkt | 11 +++- collects/mred/private/wx/gtk/canvas.rkt | 26 +++++--- collects/mred/private/wx/gtk/frame.rkt | 17 +++++- collects/mred/private/wx/gtk/list-box.rkt | 9 +++ collects/mred/private/wx/gtk/menu.rkt | 2 +- collects/mred/private/wx/win32/list-box.rkt | 4 +- collects/mred/private/wxitem.rkt | 25 ++++---- collects/mred/private/wxlitem.rkt | 32 ++++++---- collects/mred/private/wxpanel.rkt | 34 ++++++----- collects/tests/gracket/dc.rktl | 61 ++++++++++++------- collects/tests/gracket/paramz.rktl | 12 ++-- 23 files changed, 228 insertions(+), 126 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 704c0469..638e1c56 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -331,9 +331,12 @@ (if (or is-combo? (not (memq 'gl style))) (tell (tell (if is-combo? MyComboBox MyView) alloc) initWithFrame: #:type _NSRect r) - (tell (tell MyGLView alloc) - initWithFrame: #:type _NSRect r - pixelFormat: (gl-config->pixel-format gl-config)))))) + (let ([pf (gl-config->pixel-format gl-config)]) + (begin0 + (tell (tell MyGLView alloc) + initWithFrame: #:type _NSRect r + pixelFormat: pf) + (tellv pf release))))))) (tell #:type _void cocoa addSubview: content-cocoa) (set-ivar! content-cocoa wxb (->wxb this)) @@ -462,12 +465,12 @@ (scroll-page h-scroller h-page) (scroll-pos h-scroller h-pos) (when h-scroller - (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) + (tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) (scroll-range v-scroller v-len) (scroll-page v-scroller v-page) (scroll-pos v-scroller v-pos) (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) + (tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) (define/override (reset-dc-for-autoscroll) (fix-dc)) @@ -484,12 +487,20 @@ (define/public (set-scroll-pos which v) (update which scroll-pos v)) + (define/private (guard-scroll which v) + (if (is-auto-scroll?) + 0 + v)) + (define/public (get-scroll-page which) - (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))) + (guard-scroll which + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))) (define/public (get-scroll-range which) - (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))) + (guard-scroll which + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))) (define/public (get-scroll-pos which) - (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))) + (guard-scroll which + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))) (define v-scroller (and vscroll-ok? @@ -703,7 +714,7 @@ (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) (when (is-auto-scroll?) (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (define/public (warp-pointer x y) (void)) (define/override (get-virtual-h-pos) (scroll-pos h-scroller)) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index b80f27d6..1974622d 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -58,7 +58,7 @@ [time-stamp (current-milliseconds)]))) (define/public (set-selection i) - (tell (get-cocoa) selectItemAtIndex: #:type _NSInteger i)) + (tellv (get-cocoa) selectItemAtIndex: #:type _NSInteger i)) (define/public (get-selection) (tell #:type _NSInteger (get-cocoa) indexOfSelectedItem)) (define/public (number) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 6f91dd18..4370a2ec 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -121,7 +121,7 @@ (inherit get-cocoa get-parent get-eventspace pre-on-char pre-on-event - get-x get-y + get-x on-new-child) (super-new [parent parent] @@ -168,7 +168,8 @@ (atomically (let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")]) (tellv cocoa setToolbar: tb) - (tellv tb setVisible: #:type _BOOL #f)))) + (tellv tb setVisible: #:type _BOOL #f) + (tellv tb release)))) (move -11111 (if (= y -11111) 0 y)) @@ -380,6 +381,9 @@ (define/override (flip y h) (flip-screen (+ y h))) + (define/override (get-y) + (- (super get-y) (if caption? 22 0))) + (define/override (set-size x y w h) (unless (and (= x -1) (= y -1)) (move x y)) @@ -399,10 +403,6 @@ (NSPoint-x (NSRect-origin f))) ;; keep current y position: (- (NSPoint-y (NSRect-origin f)) - ;; we have to subtract add the titlebar height, for some reason: - (if caption? - (- 22) - 0) (- h (NSSize-height (NSRect-size f))))) (make-NSSize w h)) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index d4eeb201..1dfa3fce 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -32,7 +32,10 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (as-objc-allocation + [cocoa (let ([cocoa (values ; as-objc-allocation + ;; We're leaving guages for now. There's some problem + ;; releasing gauges through a finalizer. My guess is that + ;; it has something to do with animation in a separate thread. (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setMaxValue: #:type _double* rng) @@ -60,7 +63,8 @@ (define/public (get-range) (inexact->exact (floor (tell #:type _double cocoa maxValue)))) (define/public (set-range rng) - (tellv cocoa setMaxValue: #:type _double* rng)) + (tellv cocoa setMaxValue: #:type _double* rng) + (tellv cocoa setDoubleValue: #:type _double* (min rng (tell #:type _double cocoa doubleValue)))) (define/public (set-value v) (tellv cocoa setDoubleValue: #:type _double* v)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 8163794e..40f635e5 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -92,7 +92,8 @@ (tellv cocoa setDocumentView: content-cocoa) (tellv cocoa setHasVerticalScroller: #:type _BOOL #t) (tellv content-cocoa setHeaderView: #f) - (unless (eq? kind 'single) + (define allow-multi? (not (eq? kind 'single))) + (when allow-multi? (tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t)) (define/override (get-cocoa-content) content-cocoa) @@ -174,7 +175,7 @@ (let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)]) (tellv content-cocoa selectRowIndexes: index - byExtendingSelection: #:type _BOOL extend?)))) + byExtendingSelection: #:type _BOOL (and extend? allow-multi?))))) (tellv content-cocoa deselectRow: #:type _NSInteger i))) (define/public (set-selection i) (select i #t #f)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 422554f9..4cc2ca0a 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -115,7 +115,8 @@ (def/public-unimplemented set-width) (def/public-unimplemented set-title) - (def/public-unimplemented set-help-string) + (define/public (set-help-string m s) (void)) + (def/public-unimplemented number) (define/private (find-pos item) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 46047d2c..b7903746 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -82,5 +82,5 @@ (as-objc-allocation (tell (tell MyPanelView alloc) initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) - (make-NSSize w h))))] + (make-NSSize (max 1 w) (max 1 h)))))] [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index a5b02f24..1dcc21fc 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -214,6 +214,7 @@ ;; Call this function only in atomic mode: (define (check-one-event wait? dequeue?) (pre-event-sync wait?) + (clean-up-deleted) (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (when (and events-suspended? wait?) (set! was-menu-bar #f) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 3a0e9b57..be329cb6 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -117,11 +117,13 @@ 0 (set-focus))) + (define/private (get-button i) + (tell (get-cocoa) + cellAtRow: #:type _NSUInteger (if horiz? 0 i) + column: #:type _NSUInteger (if horiz? i 0))) + (define/public (enable-button i on?) - (tellv (tell (get-cocoa) - cellAtRow: #:type _NSUInteger (if horiz? 0 i) - column: #:type _NSUInteger (if horiz? i 0)) - setEnabled: #:type _BOOL on?)) + (tellv (get-button i) setEnabled: #:type _BOOL on?)) (define/public (set-selection i) (if (= i -1) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index d6f50c12..b1553187 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -3,7 +3,8 @@ ffi/unsafe ffi/unsafe/alloc ffi/unsafe/define - "../common/utils.rkt") + "../common/utils.rkt" + "../../lock.rkt") (provide cocoa-lib cf-lib @@ -14,6 +15,7 @@ define-mz as-objc-allocation as-objc-allocation-with-retain + clean-up-deleted retain release with-autorelease clean-menu-label @@ -31,8 +33,19 @@ (define-ffi-definer define-appserv appserv-lib) (define-ffi-definer define-appkit appkit-lib) -(define (objc-delete v) - (tellv v release)) +(define delete-me null) + +(define (objc-delete o) + (atomically + (set! delete-me (cons o delete-me)))) + +(define (clean-up-deleted) + ;; called outside the event loop to actually delete objects + ;; that might otherwise be in use during a callback + (for ([o (in-list (begin0 + delete-me + (set! delete-me null)))]) + (tellv o release))) (define objc-allocator (allocator objc-delete)) @@ -59,7 +72,7 @@ (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (begin0 (thunk) - (release pool)))) + (tellv pool release)))) (define (clean-menu-label str) (regexp-replace* #rx"&(.)" str "\\1")) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index 7b848a55..1c4f9669 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -42,6 +42,8 @@ (super-new) + (define/override (ok?) #t) + ;; Override this method to get the right size (define/public (get-backing-size xb yb) (set-box! xb 1) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 042a9281..7882a650 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -383,6 +383,10 @@ [(and (eq? evt 'wait) (not handler?)) #t] + ;; `yield' is supposed to return immediately if the + ;; event is already ready: + [(and (evt? evt) (sync/timeout 0 (wrap-evt evt (lambda (v) (list v))))) + => (lambda (v) (car v))] [handler? (sync (if (eq? evt 'wait) (wrap-evt e (lambda (_) #t)) @@ -411,18 +415,24 @@ (eq? e main-eventspace)) (define (queue-callback thunk [high? #t]) - (queue-event (current-eventspace) thunk (cond - [(not high?) 'lo] - [(eq? high? middle-queue-key) 'med] - [else 'hi]))) + (let ([es (current-eventspace)]) + (when (eventspace-shutdown? es) + (error 'queue-callback "eventspace is shutdown: ~e" es)) + (queue-event es thunk (cond + [(not high?) 'lo] + [(eq? high? middle-queue-key) 'med] + [else 'hi])))) (define middle-queue-key (gensym 'middle)) -(define (add-timer-callback cb) - (queue-event (current-eventspace) cb 'timer-add)) -(define (remove-timer-callback cb) - (queue-event (current-eventspace) cb 'timer-remove)) +(define (add-timer-callback cb es) + ;; in atomic mode + (queue-event es cb 'timer-add)) +(define (remove-timer-callback cb es) + ;; in atomic mode + (unless (eventspace-shutdown? es) + (queue-event es cb 'timer-remove))) (define (register-frame-shown f on?) (queue-event (current-eventspace) f (if on? diff --git a/collects/mred/private/wx/common/timer.rkt b/collects/mred/private/wx/common/timer.rkt index 2f6301fd..0a950e86 100644 --- a/collects/mred/private/wx/common/timer.rkt +++ b/collects/mred/private/wx/common/timer.rkt @@ -15,11 +15,18 @@ (define current-interval ival) (define current-once? (and just-once? #t)) (define cb #f) + (define es (current-eventspace)) + + (when (eventspace-shutdown? es) + (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es)) + (def/public (interval) current-interval) (define/private (do-start msec once?) (as-entry (lambda () (do-stop) + (when (eventspace-shutdown? es) + (error (method-name 'timer% 'start) "current eventspace is shutdown: ~e" es)) (set! current-interval msec) (set! current-once? (and once? #t)) (letrec ([new-cb @@ -33,14 +40,14 @@ (when (eq? cb new-cb) (do-start msec #f))))))))]) (set! cb new-cb) - (add-timer-callback new-cb))))) + (add-timer-callback new-cb es))))) (def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]]) (do-start msec once?)) (define/private (do-stop) (as-entry (lambda () (when cb - (remove-timer-callback cb) + (remove-timer-callback cb es) (set! cb #f))))) (def/public (stop) (do-stop)) (def/public (notify) (notify-cb) (void)) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 52a94297..977ea3a5 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -476,14 +476,20 @@ (gtk_adjustment_set_value adj v)))))) (define/public (get-scroll-page which) - (->long (dispatch which gtk_adjustment_get_page_size 0))) + (if (is-auto-scroll?) + 0 + (->long (dispatch which gtk_adjustment_get_page_size 0)))) (define/public (get-scroll-range which) - (->long (dispatch which (lambda (adj) - (- (gtk_adjustment_get_upper adj) - (gtk_adjustment_get_page_size adj))) - 0))) + (if (is-auto-scroll?) + 0 + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0)))) (define/public (get-scroll-pos which) - (->long (dispatch which gtk_adjustment_get_value 0))) + (if (is-auto-scroll?) + 0 + (->long (dispatch which gtk_adjustment_get_value 0)))) (define clear-bg? (and (not (memq 'transparent style)) @@ -541,12 +547,12 @@ (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)))) (when (is-auto-scroll?) (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (define/public (warp-pointer x y) (void)) (define/override (get-virtual-h-pos) - (gtk_adjustment_get_value hscroll-adj)) - (define/override (get-virtual-v-pos) - (gtk_adjustment_get_value vscroll-adj)) + (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj)))) + (define/override (get-virtual-v-pos) + (inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj)))) (define/public (set-resize-corner on?) (void)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c9be2bc2..c76c3de6 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -53,6 +53,9 @@ (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) +(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) +(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) + (define-cstruct _GdkGeometry ([min_width _int] [min_height _int] [max_width _int] @@ -429,6 +432,7 @@ (send in-window enter-window))) (define maximized? #f) + (define is-iconized? #f) (define/public (is-maximized?) maximized?) @@ -437,11 +441,18 @@ (define/public (on-window-state changed value) (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED)) - (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))) + (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED)))) + (when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED)) + (set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED))))) - (def/public-unimplemented iconized?) + (define/public (iconized?) + is-iconized?) + (define/public (iconize on?) + (if on? + (gtk_window_iconify gtk) + (gtk_window_deiconify gtk))) + (def/public-unimplemented get-menu-bar) - (def/public-unimplemented iconize) (define/public (set-title s) (set! saved-title s) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 291ea5c3..3b18357a 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -25,6 +25,9 @@ (define _GtkCellRenderer (_cpointer 'GtkCellRenderer)) (define _GtkTreeViewColumn _GtkWidget) ; (_cpointer 'GtkTreeViewColumn) +(define GTK_SELECTION_SINGLE 1) +(define GTK_SELECTION_MULTIPLE 3) + (define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget)) (define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void)) @@ -38,6 +41,7 @@ (define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) (define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void)) (define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void)) (define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean)) (define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean)) (define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void)) @@ -112,6 +116,11 @@ (define selection (gtk_tree_view_get_selection client-gtk)) + (gtk_tree_selection_set_mode selection (if (or (eq? kind 'extended) + (eq? kind 'multiple)) + GTK_SELECTION_MULTIPLE + GTK_SELECTION_SINGLE)) + (super-new [parent parent] [gtk gtk] [extra-gtks (list client-gtk selection)] diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 42cd4e07..a4207ffa 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -220,7 +220,7 @@ (def/public-unimplemented set-width) (def/public-unimplemented set-title) - (def/public-unimplemented set-help-string) + (define/public (set-help-string m s) (void)) (define/public (number) (length items)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index ba12082f..c7ea846c 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -69,8 +69,8 @@ (if (memq 'hscroll style) WS_HSCROLL 0) (cond ;; Win32 sense of "multiple" and "extended" is backwards - [(memq 'extended style) LBS_MULTIPLESEL] - [(memq 'multiple style) LBS_EXTENDEDSEL] + [(eq? kind 'extended) LBS_MULTIPLESEL] + [(eq? kind 'multiple) LBS_EXTENDEDSEL] [else 0])) 0 0 0 0 (send parent get-client-hwnd) diff --git a/collects/mred/private/wxitem.rkt b/collects/mred/private/wxitem.rkt index e3b1dd62..0f84b39c 100644 --- a/collects/mred/private/wxitem.rkt +++ b/collects/mred/private/wxitem.rkt @@ -1,8 +1,8 @@ -(module wxitem mzscheme +(module wxitem racket/base (require mzlib/class mzlib/class100 mzlib/etc - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "helper.ss" "const.ss" @@ -10,12 +10,12 @@ "check.ss" "wxwindow.ss") - (provide (protect make-item% - make-control% - make-simple-control% - wx-button% - wx-check-box% - wx-message%)) + (provide (protect-out make-item% + make-control% + make-simple-control% + wx-button% + wx-check-box% + wx-message%)) ;; make-item%: creates items which are suitable for placing into ;; containers. @@ -61,8 +61,7 @@ (super set-size x y width height)))]) (public - [is-enabled? - (lambda () enabled?)]) + [is-enabled? (lambda () enabled?)]) (private-field ;; Store minimum size of item. @@ -207,10 +206,8 @@ (apply super-init args) (send (get-parent) set-item-cursor 0 0)))) - (define (make-simple-control% item%) - (make-control% item% - const-default-x-margin const-default-y-margin - #f #f)) + (define (make-simple-control% item% [x-m const-default-x-margin] [y-m const-default-y-margin]) + (make-control% item% x-m y-m #f #f)) (define wx-button% (make-window-glue% (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index ea947168..9b14bcac 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -55,12 +55,13 @@ ;; ---------------------------------------- (define wx-label-panel% - (class wx-horizontal-panel% + (class wx-control-horizontal-panel% (init proxy parent label style font halign valign) (inherit area-parent) (define c #f) (define/override (enable on?) (if c (send c enable on?) (void))) + (define/override (is-enabled?) (if c (send c is-enabled?) #t)) (define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t)) (super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f) @@ -83,7 +84,7 @@ ;; ---------------------------------------- (define wx-internal-choice% - (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) + (class100 (make-window-glue% (make-simple-control% wx:choice% 0 0)) (mred proxy parent cb label x y w h choices style font) (override [handles-key-code (lambda (x alpha? meta?) @@ -119,9 +120,7 @@ (define wx-internal-list-box% (make-window-glue% - (class100 (make-control% wx:list-box% - const-default-x-margin const-default-y-margin - #t #t) (parent cb label kind x y w h choices style font label-font) + (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font) (inherit get-first-item set-first-visible-item) (private @@ -194,7 +193,7 @@ (define wx-internal-radio-box% (make-window-glue% - (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font) + (class100 (make-simple-control% wx:radio-box% 0 0) (parent cb label x y w h choices major style font) (inherit number orig-enable set-selection command) (override [enable @@ -233,10 +232,21 @@ major (filter-style style) font)) (set-c c #t #t) + (define enable-vector (make-vector (length choices) #t)) + (define/override enable (case-lambda [(on?) (super enable on?)] - [(i on?) (send c enable-button i on?)])) + [(i on?) + (when (< -1 i (vector-length enable-vector)) + (vector-set! enable-vector i on?) + (send c enable-button i on?))])) + + (define/override is-enabled? + (case-lambda + [() (super is-enabled?)] + [(which) (and (< -1 which (vector-length enable-vector)) + (vector-ref enable-vector which))])) (bounce c @@ -250,9 +260,7 @@ (define wx-internal-gauge% (make-window-glue% - (class100 (make-control% wx:gauge% - const-default-x-margin const-default-y-margin - #f #f) + (class100 (make-control% wx:gauge% 0 0 #f #f) (parent label range style font) (inherit get-client-size get-width get-height set-size stretchable-in-x stretchable-in-y set-min-height set-min-width @@ -324,9 +332,7 @@ (define wx-internal-slider% (make-window-glue% - (class100 (make-control% wx:slider% - const-default-x-margin const-default-y-margin - #f #f) + (class100 (make-control% wx:slider% 0 0 #f #f) (parent func label value min-val max-val style font) (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y get-client-size get-width get-height get-parent) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index 29bd3e8c..99e2017e 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -1,8 +1,8 @@ -(module wxpanel mzscheme +(module wxpanel racket/base (require mzlib/class mzlib/class100 mzlib/list - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "const.ss" "helper.ss" @@ -12,15 +12,16 @@ "wxitem.ss" "wxcontainer.ss") - (provide (protect wx-panel% - wx-vertical-panel% - wx-vertical-tab-panel% - wx-vertical-group-panel% - wx-horizontal-panel% - wx-pane% - wx-vertical-pane% - wx-horizontal-pane% - wx-grow-box-pane%)) + (provide (protect-out wx-panel% + wx-vertical-panel% + wx-vertical-tab-panel% + wx-vertical-group-panel% + wx-horizontal-panel% + wx-control-horizontal-panel% + wx-pane% + wx-vertical-pane% + wx-horizontal-pane% + wx-grow-box-pane%)) (define wx:windowless-panel% (class100 object% (prnt x y w h style label) @@ -61,8 +62,8 @@ 0 2)) - (define (wx-make-basic-panel% wx:panel% stretch?) - (class100* (wx-make-container% (make-item% wx:panel% 0 0 stretch? stretch?)) (wx-basic-panel<%>) (parent style label) + (define (wx-make-basic-panel% wx:panel% stretch? [x-m 0] [y-m 0]) + (class100* (wx-make-container% (make-item% wx:panel% x-m y-m stretch? stretch?)) (wx-basic-panel<%>) (parent style label) (inherit get-x get-y get-width get-height min-width min-height set-min-width set-min-height x-margin y-margin @@ -476,8 +477,8 @@ (sequence (apply super-init args)))) - (define (wx-make-panel% wx:panel%) - (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t))) args + (define (wx-make-panel% wx:panel% [x-m 0] [y-m 0]) + (class100 (make-container-glue% (make-window-glue% (wx-make-basic-panel% wx:panel% #t x-m y-m))) args (rename [super-on-visible on-visible] [super-on-active on-active]) (inherit get-children) @@ -724,15 +725,18 @@ (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f)) (define wx-panel% (wx-make-panel% wx:panel%)) + (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin)) (define wx-tab-panel% (wx-make-panel% wx:tab-panel%)) (define wx-group-panel% (wx-make-panel% wx:group-panel%)) (define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) + (define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%)) (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%)) (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%)) (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%)) (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%)) + (define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%)) (define wx-pane% (wx-make-pane% wx:windowless-panel% #t)) (define wx-grow-box-pane% diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 2ce39dbe..5e7d0f6f 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -20,7 +20,11 @@ (send-generic mdc (make-generic (object-interface mdc) m) . args) (error 'bad-dc "~a shouldn't succeed" `(send ,m ...)))) -(define (test-all mdc try) +(define (good m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args)) + +(define (test-all mdc try try-ok) + (try 'erase) (try 'clear) (try 'draw-arc 0 0 10 10 0.1 0.2) (try 'draw-bitmap bm2 0 0) @@ -40,35 +44,46 @@ (try 'end-page) (try 'end-doc) - (try 'get-background) - (try 'get-brush) - (try 'get-clipping-region) - (try 'get-font) - (try 'get-pen) (try 'get-size) - (try 'get-text-background) - (try 'get-text-foreground) - (try 'get-text-mode) - (try 'set-background (make-object color% "Yellow")) - (try 'set-brush (make-object brush% "Yellow" 'solid)) - (try 'set-clipping-rect 0 0 10 10) - (try 'set-clipping-region (make-object region% mdc)) - (try 'set-font (make-object font% 12 'default 'normal 'normal)) - (try 'set-origin 0 0) - (try 'set-pen (make-object pen% "Yellow" 1 'solid)) - (try 'set-scale 2 2) - (try 'set-text-background (make-object color% "Yellow")) - (try 'set-text-foreground (make-object color% "Yellow")) - (try 'set-text-mode 'transparent) + (try-ok 'get-background) + (try-ok 'get-brush) + (try-ok 'get-clipping-region) + (try-ok 'get-font) + (try-ok 'get-pen) + (try-ok 'get-text-background) + (try-ok 'get-text-foreground) + (try-ok 'get-text-mode) + (try-ok 'get-alpha) + (try-ok 'get-scale) + (try-ok 'get-origin) + (try-ok 'get-rotation) + + (try-ok 'set-background (make-object color% "Yellow")) + (try-ok 'set-brush (make-object brush% "Yellow" 'solid)) + (try-ok 'set-clipping-rect 0 0 10 10) + (try-ok 'set-clipping-region (make-object region% mdc)) + (try-ok 'set-font (make-object font% 12 'default 'normal 'normal)) + (try-ok 'set-origin 0 0) + (try-ok 'set-pen (make-object pen% "Yellow" 1 'solid)) + (try-ok 'set-scale 2 2) + (try-ok 'set-alpha 0.75) + (try-ok 'set-text-background (make-object color% "Yellow")) + (try-ok 'set-text-foreground (make-object color% "Yellow")) + (try-ok 'set-text-mode 'transparent) + (try 'try-color (make-object color% "Yellow") (make-object color%))) (st #f mdc ok?) -(test-all mdc bad) +(test-all mdc bad good) (send mdc set-bitmap bm) -(test-all mdc (lambda (m . args) - (send-generic mdc (make-generic (object-interface mdc) m) . args))) + +(test-all mdc + (lambda (m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args)) + (lambda (m . args) + (send-generic mdc (make-generic (object-interface mdc) m) . args))) (send mdc set-bitmap #f) diff --git a/collects/tests/gracket/paramz.rktl b/collects/tests/gracket/paramz.rktl index 2aef912e..36e7697a 100644 --- a/collects/tests/gracket/paramz.rktl +++ b/collects/tests/gracket/paramz.rktl @@ -34,7 +34,7 @@ (define d (make-object dialog% "hello")) (thread (lambda () - (sleep 1) + (sync (system-idle-evt)) (queue-callback (lambda () (set! v 11))) (send d show #f))) (queue-callback (lambda () (set! v 10))) @@ -56,15 +56,17 @@ (st #f d is-shown?) (let ([t (thread (lambda () - (send d show #t)))]) - (let loop () (unless (send d is-shown?) (loop))) + (send d show #t)))]) + (let loop () (unless (send d is-shown?) (sleep) (loop))) (st #t d is-shown?) (thread-suspend t) (stv d show #f) + (st #f d is-shown?) (let ([t2 (thread (lambda () (send d show #t)))]) - (sleep 0.1) + (yield (system-idle-evt)) + (st #t d is-shown?) (thread-resume t) - (sleep 0.1) + (yield (system-idle-evt)) (st #t d is-shown?) (test #t 'thread2 (thread-running? t2)) (stv d show #f)