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

some fixes prompted by the test suite

Browse Source 
original commit: 4f2e59e7a654c9724d546f619589ca68cc334d59
This commit is contained in:
Matthew Flatt 2010-10-25 18:22:30 -06:00
parent 53cf23d378
commit aee9c4da25
23 changed files with 228 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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))

2
collects/mred/private/wx/cocoa/choice.rkt
View File

@ -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)

12
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -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))

8
collects/mred/private/wx/cocoa/gauge.rkt
View File

@ -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))

5
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -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))

3
collects/mred/private/wx/cocoa/menu.rkt
View File

@ -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)

2
collects/mred/private/wx/cocoa/panel.rkt
View File

@ -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)]))

1
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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)

10
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -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)

21
collects/mred/private/wx/cocoa/utils.rkt
View File

@ -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"))

2
collects/mred/private/wx/common/backing-dc.rkt
View File

@ -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)

26
collects/mred/private/wx/common/queue.rkt
View File

@ -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?

11
collects/mred/private/wx/common/timer.rkt
View File

@ -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))

26
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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))

17
collects/mred/private/wx/gtk/frame.rkt
View File

@ -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)

9
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -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)]

2
collects/mred/private/wx/gtk/menu.rkt
View File

@ -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))

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

@ -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)

25
collects/mred/private/wxitem.rkt
View File

@ -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)

32
collects/mred/private/wxlitem.rkt
View File

@ -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)

34
collects/mred/private/wxpanel.rkt
View File

@ -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%

61
collects/tests/gracket/dc.rktl
View File

@ -20,7 +20,11 @@
(send-generic mdc (make-generic (object-interface mdc) m) . args)
(error 'bad-dc "~a shouldn't succeed" `(send <bad-dc> ,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)

12
collects/tests/gracket/paramz.rktl
View File

@ -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)