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

better frame sizing in gtk (but still not right)

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-30 19:12:54 -06:00
parent 37d4cfb148
commit a368362803
18 changed files with 278 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drracket/private/eb.rkt
View File

@ -56,7 +56,7 @@
(with-handlers ([exn:fail? (lambda (x)
(printf "~s\n" (exn-message x))
#f)])
(let ([b (make-object bitmap% (collection-file-path "recycle.gif" "icons"))])
(let ([b (make-object bitmap% (collection-file-path "recycle.png" "icons"))])
(cond
[(send b ok?)
(let ([gbdc (make-object bitmap-dc% b)]

8
collects/mred/private/mrtextfield.rkt
View File

@ -124,14 +124,6 @@
(send (as-entry (lambda () (mred->wx this)))
command
(make-object wx:control-event% 'text-field)))])
(override
[on-subwindow-event (lambda (w e)
(and (send e button-down?)
(let-values ([(cw) (send (mred->wx this) get-canvas-width)])
(and ((send e get-x) . >= . (- cw side-combo-width))
(begin
(on-popup e)
#t)))))])
(private-field
[menu (new popup-menu% [font font])])
(sequence

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

@ -11,6 +11,7 @@
"window.rkt"
"dc.rkt"
"queue.rkt"
"item.rkt"
"../common/event.rkt"
"../common/queue.rkt"
"../../syntax.rkt"
@ -21,7 +22,9 @@
;; ----------------------------------------
(import-class NSView NSGraphicsContext NSScroller)
(import-class NSView NSGraphicsContext NSScroller NSComboBox)
(import-protocol NSComboBoxDelegate)
(define-objc-class MyView NSView
#:mixins (FocusResponder KeyMouseResponder)
@ -52,6 +55,38 @@
(-a _void (onVScroll: [_id scroller])
(when wx (send wx do-scroll 'vertical scroller))))
(define-objc-class MyComboBox NSComboBox
#:mixins (FocusResponder KeyMouseResponder)
#:protocols (NSComboBoxDelegate)
[wx]
(-a _void (drawRect: [_NSRect r])
(super-tell #:type _void drawRect: #:type _NSRect r)
(unless (send wx during-menu-click?)
(let ([bg (send wx get-canvas-background-for-clearing)])
(when bg
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[adj (lambda (v) (/ v 255.0))])
(CGContextSetRGBFillColor cg
(adj (color-red bg))
(adj (color-blue bg))
(adj (color-green bg))
1.0)
(CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
(make-NSSize 32000 32000))))
(tellv ctx restoreGraphicsState))))
(send wx queue-paint)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event)))
(-a _void (comboBoxWillPopUp: [_id notification])
(send wx starting-combo))
(-a _void (comboBoxWillDismiss: [_id notification])
(send wx ending-combo))
(-a _void (viewWillMoveToWindow: [_id w])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc))))))
(define-struct scroller (cocoa [range #:mutable] [page #:mutable]))
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
@ -66,7 +101,6 @@
(inherit get-cocoa
get-eventspace
make-graphics-context
get-client-size
is-shown-to-root?
move get-x get-y
on-size
@ -103,10 +137,13 @@
(set! refresh-after-drawing? #f)
(refresh)))))))
(define/override (refresh)
;; can be called from any thread, including the event-pump thread
(tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
(define/override (get-cocoa-content) content-cocoa)
(define is-combo? (memq 'combo style))
(super-new
[parent parent]
[cocoa
@ -118,14 +155,20 @@
(define cocoa (get-cocoa))
(define content-cocoa
(as-objc-allocation
(tell (tell MyView alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h)))))
(define content-cocoa
(let ([r (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h))])
(as-objc-allocation
(tell (tell (if is-combo? MyComboBox MyView) alloc)
initWithFrame: #:type _NSRect r))))
(tell #:type _void cocoa addSubview: content-cocoa)
(set-ivar! content-cocoa wx this)
(when is-combo?
(tellv content-cocoa setEditable: #:type _BOOL #f)
(tellv content-cocoa setDelegate: content-cocoa)
(install-control-font content-cocoa #f))
(define dc (make-object dc% (make-graphics-context) 0 0 10 10))
(queue-paint)
@ -139,7 +182,16 @@
[xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
(send dc reset-bounds (NSPoint-x p) (NSPoint-y p) (unbox xb) (unbox yb))))
(send dc reset-bounds
(+ (NSPoint-x p) (if is-combo? 2 0))
(- (NSPoint-y p) (if is-combo? 22 0))
(max 1 (- (unbox xb) (if is-combo? 22 0)))
(unbox yb))))
(define/override (get-client-size xb yb)
(super get-client-size xb yb)
(when is-combo?
(set-box! yb (max 0 (- (unbox yb) 5)))))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
@ -330,7 +382,9 @@
(scroller-page scroller)
1)]))
(define/public (append-combo-item str) #f)
(define/public (append-combo-item str)
(tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
#t)
(define/public (on-combo-select i) (void))
(define bg-col (make-object color% "white"))
@ -383,9 +437,40 @@
(void)))
(define/public (on-scroll e) (void))
(define/override (wants-all-events?)
(define/override (definitely-wants-event? e)
;; Called in Cocoa event-handling mode
#t)
(or (not is-combo?)
(e . is-a? . key-event%)
(not (send e button-down? 'left))
(not (on-menu-click? e))))
(define/private (on-menu-click? e)
;; Called in Cocoa event-handling mode
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
((send e get-x) . > . (- (unbox xb) 22))))
(define/public (starting-combo)
(set! in-menu-click? #t)
(tellv content-cocoa setStringValue: #:type _NSString current-text))
(define/public (ending-combo)
(set! in-menu-click? #f)
(let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)])
(when (pos . > . -1)
(queue-window-event this (lambda () (on-combo-select pos)))))
(refresh))
(define current-text "")
(define/public (set-combo-text t)
(set! current-text t))
(define in-menu-click? #f)
(define/public (during-menu-click?)
;; Called in Cocoa event-handling mode
in-menu-click?)
(def/public-unimplemented set-background-to-gray)
(def/public-unimplemented scroll)

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

@ -9,12 +9,16 @@
(unsafe!)
(objc-unsafe!)
(provide item%)
(provide item%
install-control-font)
(import-class NSFont)
(define sys-font (tell NSFont
systemFontOfSize: #:type _CGFloat 13))
(define (install-control-font cocoa font)
(tellv cocoa setFont: sys-font))
(defclass item% window%
(inherit get-cocoa)
@ -38,4 +42,4 @@
(super-new)
(define/public (init-font cocoa font)
(tellv cocoa setFont: sys-font)))
(install-control-font cocoa font)))

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

@ -85,7 +85,8 @@
(super-new [parent parent]
[cocoa cocoa]
[no-show? (memq 'deleted style)])
[no-show? (memq 'deleted style)]
[callback cb])
(set-size 0 0 32 50)
; (tellv content-cocoa sizeToFit)

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

@ -34,7 +34,7 @@
(init parent label
x y
style font)
(inherit get-cocoa)
(inherit get-cocoa init-font)
(super-new [parent parent]
[cocoa (let* ([label (cond
@ -64,6 +64,7 @@
(tell (tell NSImageView alloc) init)))])
(cond
[(string? label)
(init-font cocoa font)
(tellv cocoa setSelectable: #:type _BOOL #f)
(tellv cocoa setEditable: #:type _BOOL #f)
(tellv cocoa setBordered: #:type _BOOL #f)

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

@ -94,7 +94,7 @@
(define-unimplemented draw-tab)
(define-unimplemented draw-tab-base)
(define-unimplemented key-symbol-to-integer)
(define (get-control-font-size) 14)
(define (get-control-font-size) 13)
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)
(define (flush-display) (void))

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

@ -64,7 +64,7 @@
val
style
font)
(inherit get-cocoa set-focus)
(inherit get-cocoa set-focus init-font)
(define horiz? (and (memq 'horizontal style) #t))
@ -91,9 +91,11 @@
(begin
(tellv button setTitle: #:type _NSString "")
(set-ivar! button img (bitmap->image label)))
(tellv button setTitleWithMnemonic: #:type _NSString (if (string? label)
label
"<bad>")))
(begin
(init-font button font)
(tellv button setTitleWithMnemonic: #:type _NSString (if (string? label)
label
"<bad>"))))
(tellv button setButtonType: #:type _int NSRadioButton)))
(tellv cocoa sizeToFit)
(tellv cocoa setTarget: cocoa)

15
collects/mred/private/wx/cocoa/window.rkt
View File

@ -58,12 +58,12 @@
(let loop ([hit hit])
(when hit
(if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:))
(tell hit doMouseMoved: event)
(unless (tell #:type _BOOL hit doMouseMoved: event)
(super-tell #:type _void mouseMoved: event))
(loop (tell hit superview))))))]
[-a _void (doMouseMoved: [_id event])
[-a _BOOL (doMouseMoved: [_id event])
;; called by mouseMoved:
(unless (do-mouse-event wx event 'motion #f #f #f)
(super-tell #:type _void mouseMoved: event))]
(do-mouse-event wx event 'motion #f #f #f)]
[-a _void (mouseEntered: [_id event])
(unless (do-mouse-event wx event 'enter #f #f #f)
(super-tell #:type _void mouseEntered: event))]
@ -116,7 +116,7 @@
[y (->long y)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(if (send wx wants-all-events?)
(if (send wx definitely-wants-event? k)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-char k #f)))
@ -143,7 +143,7 @@
[alt-down (bit? modifiers NSAlternateKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(if (send wx wants-all-events?)
(if (send wx definitely-wants-event? m)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f)))
@ -261,6 +261,7 @@
(set-box! h (->long (NSSize-height s)))))
(define/public (get-client-size w h)
;; May be called in Cocoa event-handling mode
(let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))])
(set-box! w (->long (NSSize-width s)))
(set-box! h (->long (NSSize-height s)))))
@ -281,7 +282,7 @@
(define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void))
(define/public (wants-all-events?)
(define/public (definitely-wants-event? e)
;; Called in Cocoa event-handling mode
#f)

6
collects/mred/private/wx/common/freeze.rkt
View File

@ -15,7 +15,7 @@
(define-mz scheme_restore_on_atomic_timeout (_fun _pointer -> _pointer)
#:c-id scheme_set_on_atomic_timeout)
(define freezer-box (make-parameter null))
(define freezer-box (make-parameter #f))
(define freeze-tag (make-continuation-prompt-tag))
;; Runs `thunk' atomically, but cooperates with
@ -70,6 +70,10 @@
(let ([b (freezer-box)])
(cond
[(not b)
;; Ideally, this would count as an error that we can fix. It seems that we
;; don't always have enough control to use the right eventspace with an
;; unfreeze point, though, so just bail out with the default.
#;
(internal-error (format "constrained-reply not within an unfreeze point for ~s"
thunk))
default]

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

@ -353,6 +353,8 @@
(queue-window-event this (lambda () (on-combo-select i))))))
(define/public (on-combo-select i) (void))
(define/public (set-combo-text t) (void))
(def/public-unimplemented set-background-to-gray)
(define/public (do-scroll direction)

11
collects/mred/private/wx/gtk/client-window.rkt
View File

@ -17,7 +17,7 @@
(_fun _GtkWidget _GtkAllocation-pointer -> _gboolean)
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(send wx remember-client-size
(send wx save-client-size
(GtkAllocation-x a)
(GtkAllocation-y a)
(GtkAllocation-width a)
@ -28,6 +28,8 @@
(class %
(init client-gtk)
(inherit remember-client-size)
(connect-size-allocate client-gtk)
(define client-w 0)
@ -37,12 +39,13 @@
(define/public (on-client-size w h) (void))
(define/public (remember-client-size x y w h)
(define/public (save-client-size x y w h)
;; Called in the Gtk event-loop thread
(set! client-x x)
(set! client-y y)
(set! client-w w)
(set! client-h h)
(remember-client-size w h)
(queue-window-event this (lambda ()
(internal-on-client-size w h)
(on-client-size w h))))
@ -50,6 +53,10 @@
(define/public (internal-on-client-size w h)
(void))
(define/override (tentative-client-size w h)
(set! client-w w)
(set! client-h h))
(define/override (get-client-size xb yb)
(set-box! xb client-w)
(set-box! yb client-h))

10
collects/mred/private/wx/gtk/const.rkt
View File

@ -120,3 +120,13 @@
(define GDK_WINDOW_STATE_FULLSCREEN (1 . << . 4))
(define GDK_WINDOW_STATE_ABOVE (1 . << . 5))
(define GDK_WINDOW_STATE_BELOW (1 . << . 6))
(define GDK_HINT_POS (1 . << . 0))
(define GDK_HINT_MIN_SIZE (1 . << . 1))
(define GDK_HINT_MAX_SIZE (1 . << . 2))
(define GDK_HINT_BASE_SIZE (1 . << . 3))
(define GDK_HINT_ASPECT (1 . << . 4))
(define GDK_HINT_RESIZE_INC (1 . << . 5))
(define GDK_HINT_WIN_GRAVITY (1 . << . 6))
(define GDK_HINT_USER_POS (1 . << . 7))
(define GDK_HINT_USER_SIZE (1 . << . 8))

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

@ -36,6 +36,22 @@
-> (values x y)))
(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void))
(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
(define-cstruct _GdkGeometry ([min_width _int]
[min_height _int]
[max_width _int]
[max_height _int]
[base_width _int]
[base_height _int]
[width_inc _int]
[height_inc _int]
[min_aspect _double]
[max_aspect _double]
[win_gravity _int]))
(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void))
(define (handle-delete gtk)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda ()
@ -45,14 +61,14 @@
(function-ptr handle-delete
(_fun #:atomic? #t _GtkWidget -> _gboolean)))
(define (handle-configure gtk)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda ()
(send wx on-size 0 0)))
(define-signal-handler connect-configure "configure-event"
(_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(send wx remember-size
(GdkEventConfigure-width a)
(GdkEventConfigure-height a)))
#f))
(define handle_configure
(function-ptr handle-configure
(_fun #:atomic? #t _GtkWidget -> _gboolean)))
(define-cstruct _GdkEventWindowState ([type _int]
[window _GtkWindow]
@ -80,7 +96,7 @@
(inherit get-gtk set-size on-size
pre-on-char pre-on-event
get-client-delta)
get-client-delta get-size)
(define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL))
(when (memq 'no-caption style)
@ -105,7 +121,7 @@
(set-size x y w h)
(g_signal_connect gtk "delete_event" handle_delete)
;; (g_signal_connect gtk "configure_event" handle_configure)
(connect-configure gtk)
(when label
(gtk_window_set_title gtk label))
@ -121,8 +137,21 @@
(gtk_box_pack_start vbox-gtk mb-gtk #t #t 0)
(gtk_widget_show mb-gtk)))
(define saved-enforcements (vector 0 0 -1 -1))
(define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
(void))
(define (to-max v) (if (= v -1) #x3FFFFFFF v))
(set! saved-enforcements (vector min-x min-y max-x max-y))
(gtk_window_set_geometry_hints gtk gtk
(make-GdkGeometry min-x min-y
(to-max max-x) (to-max max-y)
0 0
inc-x inc-y
0.0 0.0
0)
(bitwise-ior GDK_HINT_MIN_SIZE
GDK_HINT_MAX_SIZE
GDK_HINT_RESIZE_INC)))
(define/override (get-top-win) this)
@ -149,15 +178,22 @@
(quotient (- sh fh) 2)
-11111)))))
(define/override (set-top-position x y)
(define/public (set-top-position x y)
(when (and (vector? saved-enforcements)
(or (x . < . (vector-ref saved-enforcements 0))
(let ([max-x (vector-ref saved-enforcements 1)])
(and (max-x . > . -1) (x . > . max-x)))
(y . < . (vector-ref saved-enforcements 2))
(let ([max-y (vector-ref saved-enforcements 3)])
(and (max-y . > . -1) (y . > . max-y)))))
(enforce-size 0 0 -1 -1 1 1))
(gtk_widget_set_uposition gtk
(if (= x -11111) -2 x)
(if (= y -11111) -2 y)))
(define/override (get-size wb hb)
(let-values ([(w h) (gtk_window_get_size gtk)])
(set-box! wb w)
(set-box! hb h)))
(define/override (set-top-size x y w h)
(set-top-position x y)
(gtk_window_resize gtk w h))
(define/override (direct-show on?)
(super direct-show on?)

148
collects/mred/private/wx/gtk/subtype.rkt
View File

@ -1,148 +0,0 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/alloc
"utils.rkt"
"const.rkt"
"types.rkt")
(provide make-subclass
GtkWidgetClass-expose_event
set-GtkWidgetClass-expose_event!)
(define _GTypeClass _GType)
(define-cstruct _GObjectClass ([g_type_class _GTypeClass]
[construct_properties _pointer]
[constructor _fpointer]
[set_property _fpointer]
[get_property _fpointer]
[dispose _fpointer]
[finalize _fpointer]
[dispatch_properties _fpointer]
[notify _fpointer]
[constructed _fpointer]
[pdummy1 _pointer]
[pdummy2 _pointer]
[pdummy3 _pointer]
[pdummy4 _pointer]
[pdummy5 _pointer]
[pdummy6 _pointer]
[pdummy7 _pointer]))
(define-cstruct _GtkObjectClass ([parent_class _GObjectClass]
[set_arg _fpointer]
[get_arg _fpointer]
[destroy _fpointer]))
(define-cstruct _GtkWidgetClass ([parent_class _GtkObjectClass]
[activate_signal _uint]
[set_scroll_adjustments_signal _uint]
[dispatch_child_properties_changed _fpointer]
[show _fpointer]
[show_all _fpointer]
[hide _fpointer]
[hide_all _fpointer]
[map _fpointer]
[unmap _fpointer]
[realize _fpointer]
[unrealize _fpointer]
[size_request _fpointer]
[size_allocate _fpointer]
[parent_set _fpointer]
[hierarchy_changed _fpointer]
[style_set _fpointer]
[direction_changed _fpointer]
[grab_notify _fpointer]
[child_notify _fpointer]
[mnemonic_activate _fpointer]
[grab_focus _fpointer]
[focus _fpointer]
[event _fpointer]
[button_press_event _fpointer]
[button_release_event _fpointer]
[scroll_event _fpointer]
[motion_notify_event _fpointer]
[delete_event _fpointer]
[destroy_event _fpointer]
[whatever _pointer] ;;; HACK!!!!!! Something is wrong so that expose shows up in the wrong place
[expose_event (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _void)]
[key_press_event _fpointer]
[key_release_event _fpointer]
[enter_notify_event _fpointer]
[leave_notify_event _fpointer]
[configure_event _fpointer]
[focus_in_event _fpointer]
[focus_out_event _fpointer]
[map_event _fpointer]
[unmap_event _fpointer]
[property_notify_event _fpointer]
[selection_clear_event _fpointer]
[selection_request_event _fpointer]
[selection_notify_event _fpointer]
[proximity_in_event _fpointer]
[proximity_out_event _fpointer]
[visibility_notify_event _fpointer]
[client_event _fpointer]
[no_expose_event _fpointer]
[window_state_event _fpointer]
[selection_get _fpointer]
[selection_received _fpointer]
[drag_begin _fpointer]
[drag_end _fpointer]
[drag_data_get _fpointer]
[drag_data_delete _fpointer]
[drag_leave _fpointer]
[drag_motion _fpointer]
[drag_drop _fpointer]
[drag_data_received _fpointer]
[popup_menu _fpointer]
[show_help _fpointer]
[get_accessible _fpointer]
[screen_changed _fpointer]
[can_activate_accel _fpointer]
[grab_broken_event _fpointer]
[composited_changed _fpointer]
[query_tooltip _fpointer]
[gtk_reserved5 _fpointer]
[gtk_reserved6 _fpointer]
[gtk_reserved7 _fpointer]))
(define-cstruct _GTypeQuery ([type _GType]
[type_name _string]
[class_size _uint]
[instance_size _uint]))
(define-gobj g_type_query (_fun _GType _GTypeQuery-pointer -> _void))
(define-cstruct _GTypeInfo ([class_size _uint16]
[base_init _fpointer]
[base_finalize _fpointer]
[class_init (_fun #:atomic? #t _GtkWidgetClass-pointer _pointer -> _void)]
[class_finalize _fpointer]
[class_data _pointer]
[instance_size _uint16]
[n_preallocs _uint16]
[instance_init _fpointer]
[value_table _pointer]))
(define-gobj g_type_register_static (_fun _GType _string _GTypeInfo-pointer _int -> _GType))
(define saves null)
(define (make-subclass base-type name class-init-func)
(when class-init-func
(set! saves (cons class-init-func saves)))
(let ([q (make-GTypeQuery 0 #f 0 0)])
(g_type_query base-type q)
(let ([ti (make-GTypeInfo (GTypeQuery-class_size q)
#f
#f
class-init-func
#f
#f
(GTypeQuery-instance_size q)
0
#f
#f)])
(g_type_register_static base-type name ti 0))))

12
collects/mred/private/wx/gtk/types.rkt
View File

@ -19,7 +19,9 @@
_GdkEventMotion _GdkEventMotion-pointer
(struct-out GdkEventMotion)
_GdkEventCrossing _GdkEventCrossing-pointer
(struct-out GdkEventCrossing))
(struct-out GdkEventCrossing)
_GdkEventConfigure _GdkEventConfigure-pointer
(struct-out GdkEventConfigure))
(define _GType _long)
@ -89,3 +91,11 @@
[detail _int]
[focus _gboolean]
[state _uint]))
(define-cstruct _GdkEventConfigure ([type _GdkEventType]
[window _GdkWindow]
[send_event _byte]
[x _int]
[y _int]
[width _int]
[height _int]))

75
collects/mred/private/wx/gtk/window.rkt
View File

@ -210,6 +210,32 @@
;; ----------------------------------------
(define (internal-error str)
(log-error
(apply string-append
(format "internal error: ~a" str)
(append
(for/list ([c (continuation-mark-set->context (current-continuation-marks))])
(let ([name (car c)]
[loc (cdr c)])
(cond
[loc
(string-append
"\n"
(cond
[(srcloc-line loc)
(format "~a:~a:~a"
(srcloc-source loc)
(srcloc-line loc)
(srcloc-column loc))]
[else
(format "~a::~a"
(srcloc-source loc)
(srcloc-position loc))])
(if name (format " ~a" name) ""))]
[else (format "\n ~a" name)])))
'("\n")))))
(define window%
(class widget%
(init-field parent
@ -234,24 +260,47 @@
(define/public (get-window-gtk) (send parent get-window-gtk))
(define/public (move x y)
(set! save-x x)
(set! save-y y)
(when parent
(send parent set-child-position gtk x y)))
(set-size x y -1 -1))
(define/public (set-size x y w h)
(unless (= x -11111) (set! save-x x))
(unless (= y -11111) (set! save-y y))
(unless (= w -1) (set! save-w w))
(unless (= h -1) (set! save-h h))
(if parent
(send parent set-child-size gtk save-x save-y save-w save-h)
(set-child-size gtk save-x save-y save-w save-h))
(set-top-position save-x save-y))
(define/public (set-top-position x y) (void))
(unless (and (or (= x -11111) (= save-x x))
(or (= y -11111) (= save-y y))
(or (= w -1) (= save-w w))
(or (= h -1) (= save-h h)))
(unless (= x -11111) (set! save-x x))
(unless (= y -11111) (set! save-y y))
(unless (= w -1) (set! save-w w))
(unless (= h -1) (set! save-h h))
(tentative-client-size (+ save-w client-delta-w)
(+ save-h client-delta-h))
(if parent
(send parent set-child-size gtk save-x save-y save-w save-h)
(set-top-size save-x save-y save-w save-h))))
(define/public (set-child-size child-gtk x y w h)
(gtk_widget_set_size_request child-gtk w h)
(gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h)))
(define/public (set-top-size x y w h) (void))
(define/public (remember-size w h)
;; called in event-pump thread
(unless (and (= save-w w)
(= save-h h))
(set! save-w w)
(set! save-h h)
(queue-window-event this (lambda () (on-size w h)))))
(define client-delta-w 0)
(define client-delta-h 0)
(define/public (remember-client-size w h)
;; Called in the Gtk event-loop thread
(set! client-delta-w (max 0 (- save-w w)))
(set! client-delta-h (max 0 (- save-h h)))
(queue-window-event this (lambda () (on-size 0 0))))
(define/public (tentative-client-size w h)
(void))
(define/public (set-auto-size)
(let ([req (make-GtkRequisition 0 0)])
(gtk_widget_size_request gtk req)

9
collects/mred/private/wxtextfield.rkt
View File

@ -20,15 +20,16 @@
(provide (protect wx-text-field%))
(define text-field-text%
(class100 text% (cb ret-cb control set-cb-mgrs!)
(class100 text% (cb ret-cb control set-cb-mgrs! record-text)
(rename [super-on-char on-char])
(inherit get-text last-position set-max-undo-history)
(inherit get-text last-position set-max-undo-history get-flattened-text)
(private-field
[return-cb ret-cb])
(private-field
[block-callback 1]
[callback
(lambda (type)
(as-exit (lambda () (record-text (get-flattened-text))))
(when (zero? block-callback)
(let ([e (make-object wx:control-event% type)])
(as-exit (lambda ()
@ -88,7 +89,9 @@
this
(lambda (wc cr)
(set! without-callback wc)
(set! callback-ready cr)))])
(set! callback-ready cr))
(lambda (t)
(send c set-combo-text t)))])
(sequence
(as-exit
(lambda ()