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

fix frame size enforcement and gtk/cocoa positioning

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-11 10:30:06 -06:00
parent b444555b6b
commit e32475fbbf
9 changed files with 44 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/mrcanvas.rkt
View File

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

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

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

2
collects/mred/private/mritem.rkt
View File

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

4
collects/mred/private/mrpanel.rkt
View File

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

7
collects/mred/private/mrtop.rkt
View File

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

13
collects/mred/private/mrwindow.rkt
View File

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

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

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

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

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

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

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