From cb571363a96cda9e8accab2ed738c83b55e9e6a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Aug 2010 13:53:02 -0600 Subject: [PATCH] misc repairs original commit: 0114b7a4a5966fea451c92c532bbb86bb638266e --- collects/mred/private/mrtop.rkt | 13 ++++--- collects/mred/private/mrwindow.rkt | 18 ++++++---- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/canvas.rkt | 2 +- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 30 ++++++++-------- collects/mred/private/wx/cocoa/menu-bar.rkt | 38 +++++++++++++------- collects/mred/private/wx/cocoa/menu-item.rkt | 2 +- collects/mred/private/wx/cocoa/menu.rkt | 5 +-- collects/mred/private/wx/cocoa/panel.rkt | 2 +- collects/mred/private/wx/cocoa/procs.rkt | 2 +- collects/mred/private/wx/cocoa/radio-box.rkt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 2 +- collects/mred/private/wx/cocoa/window.rkt | 17 +++++++-- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/gtk/procs.rkt | 2 +- 16 files changed, 86 insertions(+), 55 deletions(-) diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index 2c1499ec..ca693a9b 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) + (inherit show set-get-outer-panel) (rename [super-set-label set-label]) (private [wx-object->proxy @@ -131,12 +131,15 @@ top-level))]) (public [do-create-status-line (lambda () - (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) - (send status-message stretchable-in-x #t))] + (unless status-message + (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) + (send status-message stretchable-in-x #t)))] [do-set-status-text (lambda (s) - (send status-message set-label s))]) + (when status-message + (send status-message set-label s)))]) (sequence - (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () mid-panel) mismatches label parent arrow-cursor)))) + (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor) + (set-get-outer-panel (lambda () mid-panel))))) (define frame% diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index 6572640e..318ae69d 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -21,7 +21,9 @@ window<%> (protect window%-keywords) subwindow<%> - (protect make-window%)) + (protect make-window%) + + (protect set-get-outer-panel)) (define area<%> (interface () @@ -36,6 +38,9 @@ [stretchable-width no-val] [stretchable-height no-val]) + (define-local-member-name + set-get-outer-panel) + (define area% (class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt ;; for keyword use: @@ -49,15 +54,16 @@ (unless (eq? min-height no-val) (check-non#f-dimension cwho min-height))) (mismatches)) (private-field - [get-wx-panel get-wx-pan] + [get-wx-outer-panel get-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-panel min-width)] - [(minh min-height) (param get-wx-panel min-height)] - [(sw stretchable-width) (param get-wx-panel stretchable-in-x)] - [(sh stretchable-height) (param get-wx-panel stretchable-in-y)] + [(minw min-width) (param get-wx-outer-panel min-width)] + [(minh min-height) (param get-wx-outer-panel min-height)] + [(sw stretchable-width) (param get-wx-outer-panel stretchable-in-x)] + [(sh stretchable-height) (param get-wx-outer-panel stretchable-in-y)] [get-graphical-min-size (entry-point (lambda () (if (wx . is-a? . wx-basic-panel<%>) (apply values (send wx get-graphical-min-size)) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index dbff38f0..924df485 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -39,7 +39,7 @@ (let ([cocoa (as-objc-allocation (tell (tell MyButton alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h))))]) (when button-type (tellv cocoa setButtonType: #:type _int button-type)) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 1c4467a1..99598d44 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -252,7 +252,7 @@ FrameView)] [else NSView]) alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize (max w (* 2 x-margin)) (max h (* 2 y-margin))))))] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 71b79707..b8dab3b9 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -35,7 +35,7 @@ (let ([cocoa (as-objc-allocation (tell (tell MyPopUpButton alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h)) pullsDown: #:type _BOOL #f))]) (for ([lbl (in-list choices)] diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 39510db6..d4f00a6d 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -92,12 +92,6 @@ (and front (send front get-eventspace))))) -(define (init-pos x y) - (if (and (= x -11111) - (= y -11111)) - (values 0 0) - (values x y))) - (define frame% (class window% (init parent @@ -108,7 +102,8 @@ (inherit get-cocoa get-parent get-eventspace - pre-on-char pre-on-event) + pre-on-char pre-on-event + get-x get-y) (super-new [parent parent] [cocoa @@ -116,13 +111,12 @@ is-dialog? parent (not (send parent frame-is-dialog?)))] - [init-rect (let-values ([(x y) (init-pos x y)]) - (make-NSRect (make-NSPoint x y) - (make-NSSize (max 30 w) - (max (if (memq 'no-caption style) - 0 - 22) - h))))]) + [init-rect (make-NSRect (make-init-point x y) + (make-NSSize (max 30 w) + (max (if (memq 'no-caption style) + 0 + 22) + h)))]) (let ([c (as-objc-allocation (tell (tell (if is-sheet? MyPanel @@ -151,6 +145,8 @@ (define cocoa (get-cocoa)) (tellv cocoa setDelegate: cocoa) + (move -11111 (if (= y -11111) 0 y)) + (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) (define/override (get-cocoa-content) @@ -319,7 +315,9 @@ (make-NSSize w h)) display: #:type _BOOL #t))) (define/override (move x y) - (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y)))) + (let ([x (if (= x -11111) (get-x) x)] + [y (if (= y -11111) (get-y) y)]) + (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (flip-screen y))))) (define/override (center dir wrt) (let ([f (tell #:type _NSRect cocoa frame)] @@ -366,7 +364,7 @@ (define/public (on-activate on?) (void)) - (define/public (set-icon bm1 bm2 mode) (void)) ;; FIXME + (define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME (define/override (call-pre-on-event w e) (pre-on-event w e)) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 1ca3d147..df57b133 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -4,6 +4,7 @@ ffi/unsafe/objc (only-in racket/list take drop) "../../syntax.rkt" + "../../lock.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -109,28 +110,38 @@ (tellv app setMainMenu: cocoa-mb) (set! the-apple-menu apple))) +(tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f) + (defclass menu-bar% object% (define menus null) (def/public-unimplemented number) - (def/public-unimplemented enable-top) + (define/public (enable-top pos on?) + (set-box! (cddr (list-ref menus pos)) on?) + (when (eq? current-mb this) + (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)) + setEnabled: #:type _BOOL on?))) (define/public (delete which pos) - (set! menus (let loop ([menus menus] - [pos pos]) - (cond - [(null? menus) menus] - [(zero? pos) (cdr menus)] - [else (cons (car menus) - (loop (cdr menus) - pos))])))) + (atomically + (when (eq? current-mb this) + (tellv cocoa-mb removeItem: + (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos)))) + (set! menus (let loop ([menus menus] + [pos pos]) + (cond + [(null? menus) menus] + [(zero? pos) (cdr menus)] + [else (cons (car menus) + (loop (cdr menus) + (sub1 pos)))]))))) (public [append-menu append]) (define (append-menu menu title) - (set! menus (append menus (list (cons menu title)))) + (set! menus (append menus (list (list* menu title (box #t))))) (send menu set-parent this) (when (eq? current-mb this) - (send menu install cocoa-mb title))) + (send menu install cocoa-mb title #t))) (define/public (install) (let loop () @@ -138,7 +149,7 @@ (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) (loop))) (for-each (lambda (menu) - (send (car menu) install cocoa-mb (cdr menu))) + (send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu)))) menus) (set! current-mb this)) @@ -151,7 +162,8 @@ (define/public (set-label-top pos str) (set! menus (append (take menus pos) - (list (cons (car (list-ref menus pos)) str)) + (let ([i (list-ref menus pos)]) + (list (cons (car i) (cons str (cddr i))))) (drop menus (add1 pos)))) (when (eq? current-mb this) (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 2356214c..fc8e75df 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -49,7 +49,7 @@ (define/public (install menu) (if submenu - (send submenu install menu label) + (send submenu install menu label enabled?) (let ([item (as-objc-allocation (tell (tell MyMenuItem alloc) initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index 2b64cc89..a671fffd 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -49,9 +49,10 @@ (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) items))) - (define/public (install cocoa-parent label) + (define/public (install cocoa-parent label enabled?) (create-menu label) - (tellv cocoa-parent addItem: cocoa)) + (tellv cocoa-parent addItem: cocoa) + (tellv cocoa setEnabled: #:type _BOOL enabled?)) (define popup-box #f) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 84423107..5602219a 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -62,6 +62,6 @@ [cocoa (as-objc-allocation (tell (tell NSView alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h))))] [no-show? (memq 'deleted style)])) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index f66c2ddd..e9e66c15 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -65,7 +65,7 @@ (define-unimplemented special-control-key) -(define-unimplemented special-option-key) +(define (special-option-key on?) (void)) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray")) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index fce42e5c..95b1ef46 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -73,7 +73,7 @@ (let ([cocoa (as-objc-allocation (tell (tell MyMatrix alloc) - initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) + initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h)) mode: #:type _int NSRadioModeMatrix cellClass: (if (andmap string? labels) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 9a11f8a4..cad55b78 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -41,7 +41,7 @@ (tellv cocoa addTabViewItem: item) item))) (let ([sz (tell #:type _NSSize cocoa minimumSize)]) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) sz))) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz))) (tellv cocoa setDelegate: cocoa) (define content-cocoa diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index cc2df439..059e1492 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -24,7 +24,8 @@ queue-window-event queue-window*-event request-flush-delay - cancel-flush-delay) + cancel-flush-delay + make-init-point) (define-local-member-name flip-client) @@ -313,8 +314,10 @@ (set-box! h (->long (NSSize-height s))))) (define/public (set-size x y w h) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) - (make-NSSize w h)))) + (let ([x (if (= x -11111) 0 x)] + [y (if (= y -11111) 0 y)]) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) + (make-NSSize w h))))) (define/public (move x y) (set-size x y (get-width) (get-height))) @@ -449,3 +452,11 @@ (set! depth (sub1 depth)) (tellv cocoa-win enableFlushWindow) (remove-event-boundary-callback! req))))) + +(define (make-init-point x y) + (make-NSPoint (if (= x -11111) + 0 + x) + (if (= y -11111) + 0 + y))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index b1dfd74b..d4b6cb68 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -260,7 +260,7 @@ (define/augment (is-enabled-to-root?) #t) - (define/public (set-icon bm mask mode) (void)) ;; FIXME + (define/public (set-icon bm mask [mode 'both]) (void)) ;; FIXME (define/override (call-pre-on-event w e) (pre-on-event w e)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 32639281..7f48f765 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -64,7 +64,7 @@ can-show-print-setup?) (define-unimplemented special-control-key) -(define-unimplemented special-option-key) +(define (special-option-key on?) (void)) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) (define (get-panel-background) (make-object color% "gray"))