diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 2da1e17718..2cb7b02774 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -91,7 +91,7 @@ (sequence (as-entry (lambda () - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches #f parent #f)))))) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches #f parent #f)))))) (define default-paint-cb (lambda (canvas dc) (void))) diff --git a/collects/mred/private/mrcontainer.rkt b/collects/mred/private/mrcontainer.rkt index 44d584c29e..c5ff33ee70 100644 --- a/collects/mred/private/mrcontainer.rkt +++ b/collects/mred/private/mrcontainer.rkt @@ -42,7 +42,7 @@ [alignment no-val]) (define (make-container% %) ; % implements area<%> - (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan mismatches parent + (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches parent ;; for keyword use [border no-val] [spacing no-val] @@ -122,7 +122,7 @@ (check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c) (send (get-wx-panel) delete-child (mred->wx c))))]) (sequence - (super-init mk-wx get-wx-panel mismatches parent) + (super-init mk-wx get-wx-panel get-wx-outer-pan mismatches parent) (unless (eq? border no-val) (bdr border)) (unless (eq? spacing no-val) (spc spacing)) (unless (eq? alignment no-val) (set-alignment . alignment))))) @@ -131,9 +131,8 @@ (interface (window<%> area-container<%>))) (define (make-area-container-window% %) ; % implements window<%> (and area-container<%>) - (class100* % (area-container-window<%>) (mk-wx get-wx-pan mismatches label parent cursor) - (private-field [get-wx-panel get-wx-pan]) + (class100* % (area-container-window<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor) (sequence - (super-init mk-wx get-wx-panel mismatches label parent cursor))))) + (super-init mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor))))) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 6e8fa4704c..6d2a89f530 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -81,7 +81,7 @@ (sequence (when (string? label) (set! label (string->immutable-string label))) - (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches label parent cursor) + (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches label parent cursor) (unless (hidden-child?) (as-exit (lambda () (send parent after-new-child this))))))) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index b06dc92746..ca4c4d79da 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -52,7 +52,8 @@ this this (mred->wx-container parent) null #f)) wx) - (lambda () wx) + (lambda () wx) + (lambda () wx) (lambda () (check-container-ready cwho parent)) parent) @@ -96,6 +97,7 @@ (get-initial-label))) wx) (lambda () wx) + (lambda () wx) (lambda () (check-container-ready cwho parent)) #f parent #f) (unless (memq 'deleted style) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index f7a2dc97c3..f4153ebc09 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -49,7 +49,7 @@ (define basic-top-level-window% (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (mk-wx mismatches label parent) - (inherit show set-get-outer-panel) + (inherit show) (rename [super-set-label set-label]) (private [wx-object->proxy @@ -138,8 +138,9 @@ (when status-message (send status-message set-label s)))]) (sequence - (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor) - (set-get-outer-panel (lambda () mid-panel))))) + (super-init (lambda () (set! wx (mk-wx finish)) wx) + (lambda () wx-panel) (lambda () mid-panel) + mismatches label parent arrow-cursor)))) (define frame% diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index 318ae69d6c..2a4c4a1bed 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -42,7 +42,7 @@ set-get-outer-panel) (define area% - (class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt + (class100* mred% (area<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches prnt ;; for keyword use: [min-width no-val] [min-height no-val] @@ -54,10 +54,9 @@ (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height))) (mismatches)) (private-field - [get-wx-outer-panel get-wx-pan] + [get-wx-outer-panel get-outer-wx-pan] [parent prnt]) (public - [set-get-outer-panel (lambda (get-wx-outer-pan) (set! get-wx-outer-panel get-wx-outer-pan))] [get-parent (lambda () parent)] [get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))] [(minw min-width) (param get-wx-outer-panel min-width)] @@ -88,7 +87,7 @@ [vert-margin no-val]) (define (make-subarea% %) ; % implements area<%> - (class100* % (subarea<%>) (mk-wx get-wx-pan mismatches parent + (class100* % (subarea<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches parent ;; for keyword use [horiz-margin no-val] [vert-margin no-val]) @@ -101,7 +100,7 @@ [(hm horiz-margin) (param get-wx-panel x-margin)] [(vm vert-margin) (param get-wx-panel y-margin)]) (sequence - (super-init mk-wx get-wx-panel mismatches parent) + (super-init mk-wx get-wx-panel get-outer-wx-pan mismatches parent) (unless (eq? horiz-margin no-val) (hm horiz-margin)) (unless (eq? vert-margin no-val) (vm vert-margin))))) @@ -125,7 +124,7 @@ (interface (window<%> subarea<%>))) (define (make-window% top? %) ; % implements area<%> - (class100* % (window<%>) (mk-wx get-wx-panel mismatches lbl parent crsr + (class100* % (window<%>) (mk-wx get-wx-panel get-outer-wx-panel mismatches lbl parent crsr ;; for keyword use [enabled #t]) (private-field [label lbl][cursor crsr]) @@ -234,5 +233,5 @@ (private-field [wx #f]) (sequence - (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel mismatches parent) + (super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent) (unless enabled (enable #f)))))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index cd3fbcbb0b..b575f3bb97 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -397,7 +397,12 @@ (+ px (/ (- pw w) 2))) ;; keep current x position: (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/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 3077daaeba..74153f864c 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -133,7 +133,8 @@ pre-on-char pre-on-event get-client-delta get-size get-parent get-eventspace - adjust-client-delta) + adjust-client-delta + queue-on-size) (define gtk (as-gtk-window-allocation (gtk_window_new GTK_WINDOW_TOPLEVEL))) @@ -254,21 +255,15 @@ -11111))))) (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))) + (unless (and (= x -11111) (= y -11111)) + (gtk_widget_set_uposition gtk + (if (= x -11111) -2 x) + (if (= y -11111) -2 y)))) - (define/override (really-set-size gtk x y w h) + (define/override (really-set-size gtk x y processed-x processed-y w h) (set-top-position x y) - (gtk_window_resize gtk (max 1 w) (max 1 h))) + (gtk_window_resize gtk (max 1 w) (max 1 h)) + (queue-on-size)) (define/override (show on?) (let ([es (get-eventspace)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 85a0533370..36ef33f20a 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -416,31 +416,34 @@ (unless (= h -1) (set! save-h h)) (set! save-w (max save-w client-delta-w)) (set! save-h (max save-h client-delta-h)) - (really-set-size gtk save-x save-y save-w save-h))) + (really-set-size gtk x y save-x save-y save-w save-h))) (define/public (save-size x y w h) (set! save-w w) (set! save-h h)) - (define/public (really-set-size gtk x y w h) + (define/public (really-set-size gtk given-x given-y x y w h) (send parent set-child-size gtk x y w 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 on-size-queued? #f) (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) - (unless on-size-queued? - (set! on-size-queued? #t) - (queue-window-event this (lambda () - (set! on-size-queued? #f) - (on-size w h)))))) + (queue-on-size))) + + (define on-size-queued? #f) + (define/public (queue-on-size) + (unless on-size-queued? + (set! on-size-queued? #t) + (queue-window-event this (lambda () + (set! on-size-queued? #f) + (on-size 0 0))))) (define client-delta-w 0) (define client-delta-h 0)