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 (sequence
(as-entry (as-entry
(lambda () (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))) (define default-paint-cb (lambda (canvas dc) (void)))

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

@ -42,7 +42,7 @@
[alignment no-val]) [alignment no-val])
(define (make-container% %) ; % implements area<%> (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 ;; for keyword use
[border no-val] [border no-val]
[spacing no-val] [spacing no-val]
@ -122,7 +122,7 @@
(check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c) (check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c)
(send (get-wx-panel) delete-child (mred->wx c))))]) (send (get-wx-panel) delete-child (mred->wx c))))])
(sequence (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? border no-val) (bdr border))
(unless (eq? spacing no-val) (spc spacing)) (unless (eq? spacing no-val) (spc spacing))
(unless (eq? alignment no-val) (set-alignment . alignment))))) (unless (eq? alignment no-val) (set-alignment . alignment)))))
@ -131,9 +131,8 @@
(interface (window<%> area-container<%>))) (interface (window<%> area-container<%>)))
(define (make-area-container-window% %) ; % implements window<%> (and 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) (class100* % (area-container-window<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor)
(private-field [get-wx-panel get-wx-pan])
(sequence (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 (sequence
(when (string? label) (when (string? label)
(set! label (string->immutable-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?) (unless (hidden-child?)
(as-exit (lambda () (send parent after-new-child this))))))) (as-exit (lambda () (send parent after-new-child this)))))))

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

@ -53,6 +53,7 @@
#f)) #f))
wx) wx)
(lambda () wx) (lambda () wx)
(lambda () wx)
(lambda () (lambda ()
(check-container-ready cwho parent)) (check-container-ready cwho parent))
parent) parent)
@ -96,6 +97,7 @@
(get-initial-label))) (get-initial-label)))
wx) wx)
(lambda () wx) (lambda () wx)
(lambda () wx)
(lambda () (check-container-ready cwho parent)) (lambda () (check-container-ready cwho parent))
#f parent #f) #f parent #f)
(unless (memq 'deleted style) (unless (memq 'deleted style)

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

@ -49,7 +49,7 @@
(define basic-top-level-window% (define basic-top-level-window%
(class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>)
(mk-wx mismatches label parent) (mk-wx mismatches label parent)
(inherit show set-get-outer-panel) (inherit show)
(rename [super-set-label set-label]) (rename [super-set-label set-label])
(private (private
[wx-object->proxy [wx-object->proxy
@ -138,8 +138,9 @@
(when status-message (when status-message
(send status-message set-label s)))]) (send status-message set-label s)))])
(sequence (sequence
(super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor) (super-init (lambda () (set! wx (mk-wx finish)) wx)
(set-get-outer-panel (lambda () mid-panel))))) (lambda () wx-panel) (lambda () mid-panel)
mismatches label parent arrow-cursor))))
(define frame% (define frame%

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

@ -42,7 +42,7 @@
set-get-outer-panel) set-get-outer-panel)
(define area% (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: ;; for keyword use:
[min-width no-val] [min-width no-val]
[min-height no-val] [min-height no-val]
@ -54,10 +54,9 @@
(unless (eq? min-height no-val) (check-non#f-dimension cwho min-height))) (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height)))
(mismatches)) (mismatches))
(private-field (private-field
[get-wx-outer-panel get-wx-pan] [get-wx-outer-panel get-outer-wx-pan]
[parent prnt]) [parent prnt])
(public (public
[set-get-outer-panel (lambda (get-wx-outer-pan) (set! get-wx-outer-panel get-wx-outer-pan))]
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))] [get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))]
[(minw min-width) (param get-wx-outer-panel min-width)] [(minw min-width) (param get-wx-outer-panel min-width)]
@ -88,7 +87,7 @@
[vert-margin no-val]) [vert-margin no-val])
(define (make-subarea% %) ; % implements area<%> (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 ;; for keyword use
[horiz-margin no-val] [horiz-margin no-val]
[vert-margin no-val]) [vert-margin no-val])
@ -101,7 +100,7 @@
[(hm horiz-margin) (param get-wx-panel x-margin)] [(hm horiz-margin) (param get-wx-panel x-margin)]
[(vm vert-margin) (param get-wx-panel y-margin)]) [(vm vert-margin) (param get-wx-panel y-margin)])
(sequence (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? horiz-margin no-val) (hm horiz-margin))
(unless (eq? vert-margin no-val) (vm vert-margin))))) (unless (eq? vert-margin no-val) (vm vert-margin)))))
@ -125,7 +124,7 @@
(interface (window<%> subarea<%>))) (interface (window<%> subarea<%>)))
(define (make-window% top? %) ; % implements area<%> (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 ;; for keyword use
[enabled #t]) [enabled #t])
(private-field [label lbl][cursor crsr]) (private-field [label lbl][cursor crsr])
@ -234,5 +233,5 @@
(private-field (private-field
[wx #f]) [wx #f])
(sequence (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)))))) (unless enabled (enable #f))))))

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

@ -397,7 +397,12 @@
(+ px (/ (- pw w) 2))) (+ px (/ (- pw w) 2)))
;; keep current x position: ;; keep current x position:
(NSPoint-x (NSRect-origin f))) (NSPoint-x (NSRect-origin f)))
;; keep current y position:
(- (NSPoint-y (NSRect-origin f)) (- (NSPoint-y (NSRect-origin f))
;; we have to subtract add the titlebar height, for some reason:
(if caption?
(- 22)
0)
(- h (- h
(NSSize-height (NSRect-size f))))) (NSSize-height (NSRect-size f)))))
(make-NSSize w h)) (make-NSSize w h))

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

@ -133,7 +133,8 @@
pre-on-char pre-on-event pre-on-char pre-on-event
get-client-delta get-size get-client-delta get-size
get-parent get-eventspace get-parent get-eventspace
adjust-client-delta) adjust-client-delta
queue-on-size)
(define gtk (as-gtk-window-allocation (define gtk (as-gtk-window-allocation
(gtk_window_new GTK_WINDOW_TOPLEVEL))) (gtk_window_new GTK_WINDOW_TOPLEVEL)))
@ -254,21 +255,15 @@
-11111))))) -11111)))))
(define/public (set-top-position x y) (define/public (set-top-position x y)
(when (and (vector? saved-enforcements) (unless (and (= x -11111) (= y -11111))
(or (x . < . (vector-ref saved-enforcements 0)) (gtk_widget_set_uposition gtk
(let ([max-x (vector-ref saved-enforcements 1)]) (if (= x -11111) -2 x)
(and (max-x . > . -1) (x . > . max-x))) (if (= y -11111) -2 y))))
(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 (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) (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?) (define/override (show on?)
(let ([es (get-eventspace)]) (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)) (unless (= h -1) (set! save-h h))
(set! save-w (max save-w client-delta-w)) (set! save-w (max save-w client-delta-w))
(set! save-h (max save-h client-delta-h)) (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) (define/public (save-size x y w h)
(set! save-w w) (set! save-w w)
(set! save-h h)) (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)) (send parent set-child-size gtk x y w h))
(define/public (set-child-size child-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_set_size_request child-gtk w h)
(gtk_widget_size_allocate child-gtk (make-GtkAllocation x y 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) (define/public (remember-size w h)
;; called in event-pump thread ;; called in event-pump thread
(unless (and (= save-w w) (unless (and (= save-w w)
(= save-h h)) (= save-h h))
(set! save-w w) (set! save-w w)
(set! save-h h) (set! save-h h)
(unless on-size-queued? (queue-on-size)))
(set! on-size-queued? #t)
(queue-window-event this (lambda () (define on-size-queued? #f)
(set! on-size-queued? #f) (define/public (queue-on-size)
(on-size w h)))))) (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-w 0)
(define client-delta-h 0) (define client-delta-h 0)