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

misc repairs

Browse Source 
original commit: 0114b7a4a5966fea451c92c532bbb86bb638266e
This commit is contained in:
Matthew Flatt 2010-08-16 13:53:02 -06:00
parent a951888446
commit cb571363a9
16 changed files with 86 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
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) (inherit show set-get-outer-panel)
(rename [super-set-label set-label]) (rename [super-set-label set-label])
(private (private
[wx-object->proxy [wx-object->proxy
@ -131,12 +131,15 @@
top-level))]) top-level))])
(public (public
[do-create-status-line (lambda () [do-create-status-line (lambda ()
(set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) (unless status-message
(send status-message stretchable-in-x #t))] (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) [do-set-status-text (lambda (s)
(send status-message set-label s))]) (when status-message
(send status-message set-label s)))])
(sequence (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% (define frame%

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

@ -21,7 +21,9 @@
window<%> window<%>
(protect window%-keywords) (protect window%-keywords)
subwindow<%> subwindow<%>
(protect make-window%)) (protect make-window%)
(protect set-get-outer-panel))
(define area<%> (define area<%>
(interface () (interface ()
@ -36,6 +38,9 @@
[stretchable-width no-val] [stretchable-width no-val]
[stretchable-height no-val]) [stretchable-height no-val])
(define-local-member-name
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 mismatches prnt
;; for keyword use: ;; for keyword use:
@ -49,15 +54,16 @@
(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-panel get-wx-pan] [get-wx-outer-panel get-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-panel min-width)] [(minw min-width) (param get-wx-outer-panel min-width)]
[(minh min-height) (param get-wx-panel min-height)] [(minh min-height) (param get-wx-outer-panel min-height)]
[(sw stretchable-width) (param get-wx-panel stretchable-in-x)] [(sw stretchable-width) (param get-wx-outer-panel stretchable-in-x)]
[(sh stretchable-height) (param get-wx-panel stretchable-in-y)] [(sh stretchable-height) (param get-wx-outer-panel stretchable-in-y)]
[get-graphical-min-size (entry-point (lambda () [get-graphical-min-size (entry-point (lambda ()
(if (wx . is-a? . wx-basic-panel<%>) (if (wx . is-a? . wx-basic-panel<%>)
(apply values (send wx get-graphical-min-size)) (apply values (send wx get-graphical-min-size))

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

@ -39,7 +39,7 @@
(let ([cocoa (let ([cocoa
(as-objc-allocation (as-objc-allocation
(tell (tell MyButton alloc) (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))))]) (make-NSSize w h))))])
(when button-type (when button-type
(tellv cocoa setButtonType: #:type _int button-type)) (tellv cocoa setButtonType: #:type _int button-type))

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

@ -252,7 +252,7 @@
FrameView)] FrameView)]
[else NSView]) [else NSView])
alloc) 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)) (make-NSSize (max w (* 2 x-margin))
(max h (* 2 y-margin))))))] (max h (* 2 y-margin))))))]
[no-show? (memq 'deleted style)]) [no-show? (memq 'deleted style)])

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

@ -35,7 +35,7 @@
(let ([cocoa (let ([cocoa
(as-objc-allocation (as-objc-allocation
(tell (tell MyPopUpButton alloc) (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)) (make-NSSize w h))
pullsDown: #:type _BOOL #f))]) pullsDown: #:type _BOOL #f))])
(for ([lbl (in-list choices)] (for ([lbl (in-list choices)]

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

@ -92,12 +92,6 @@
(and front (and front
(send front get-eventspace))))) (send front get-eventspace)))))
(define (init-pos x y)
(if (and (= x -11111)
(= y -11111))
(values 0 0)
(values x y)))
(define frame% (define frame%
(class window% (class window%
(init parent (init parent
@ -108,7 +102,8 @@
(inherit get-cocoa get-parent (inherit get-cocoa get-parent
get-eventspace get-eventspace
pre-on-char pre-on-event) pre-on-char pre-on-event
get-x get-y)
(super-new [parent parent] (super-new [parent parent]
[cocoa [cocoa
@ -116,13 +111,12 @@
is-dialog? is-dialog?
parent parent
(not (send parent frame-is-dialog?)))] (not (send parent frame-is-dialog?)))]
[init-rect (let-values ([(x y) (init-pos x y)]) [init-rect (make-NSRect (make-init-point x y)
(make-NSRect (make-NSPoint x y) (make-NSSize (max 30 w)
(make-NSSize (max 30 w) (max (if (memq 'no-caption style)
(max (if (memq 'no-caption style) 0
0 22)
22) h)))])
h))))])
(let ([c (as-objc-allocation (let ([c (as-objc-allocation
(tell (tell (if is-sheet? (tell (tell (if is-sheet?
MyPanel MyPanel
@ -151,6 +145,8 @@
(define cocoa (get-cocoa)) (define cocoa (get-cocoa))
(tellv cocoa setDelegate: cocoa) (tellv cocoa setDelegate: cocoa)
(move -11111 (if (= y -11111) 0 y))
(tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t)
(define/override (get-cocoa-content) (define/override (get-cocoa-content)
@ -319,7 +315,9 @@
(make-NSSize w h)) (make-NSSize w h))
display: #:type _BOOL #t))) display: #:type _BOOL #t)))
(define/override (move x y) (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) (define/override (center dir wrt)
(let ([f (tell #:type _NSRect cocoa frame)] (let ([f (tell #:type _NSRect cocoa frame)]
@ -366,7 +364,7 @@
(define/public (on-activate on?) (void)) (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) (define/override (call-pre-on-event w e)
(pre-on-event w e)) (pre-on-event w e))

38
collects/mred/private/wx/cocoa/menu-bar.rkt
View File

@ -4,6 +4,7 @@
ffi/unsafe/objc ffi/unsafe/objc
(only-in racket/list take drop) (only-in racket/list take drop)
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"const.rkt" "const.rkt"
@ -109,28 +110,38 @@
(tellv app setMainMenu: cocoa-mb) (tellv app setMainMenu: cocoa-mb)
(set! the-apple-menu apple))) (set! the-apple-menu apple)))
(tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f)
(defclass menu-bar% object% (defclass menu-bar% object%
(define menus null) (define menus null)
(def/public-unimplemented number) (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) (define/public (delete which pos)
(set! menus (let loop ([menus menus] (atomically
[pos pos]) (when (eq? current-mb this)
(cond (tellv cocoa-mb removeItem:
[(null? menus) menus] (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos))))
[(zero? pos) (cdr menus)] (set! menus (let loop ([menus menus]
[else (cons (car menus) [pos pos])
(loop (cdr menus) (cond
pos))])))) [(null? menus) menus]
[(zero? pos) (cdr menus)]
[else (cons (car menus)
(loop (cdr menus)
(sub1 pos)))])))))
(public [append-menu append]) (public [append-menu append])
(define (append-menu menu title) (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) (send menu set-parent this)
(when (eq? current-mb this) (when (eq? current-mb this)
(send menu install cocoa-mb title))) (send menu install cocoa-mb title #t)))
(define/public (install) (define/public (install)
(let loop () (let loop ()
@ -138,7 +149,7 @@
(tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)) (tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1))
(loop))) (loop)))
(for-each (lambda (menu) (for-each (lambda (menu)
(send (car menu) install cocoa-mb (cdr menu))) (send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu))))
menus) menus)
(set! current-mb this)) (set! current-mb this))
@ -151,7 +162,8 @@
(define/public (set-label-top pos str) (define/public (set-label-top pos str)
(set! menus (append (set! menus (append
(take menus pos) (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)))) (drop menus (add1 pos))))
(when (eq? current-mb this) (when (eq? current-mb this)
(tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)

2
collects/mred/private/wx/cocoa/menu-item.rkt
View File

@ -49,7 +49,7 @@
(define/public (install menu) (define/public (install menu)
(if submenu (if submenu
(send submenu install menu label) (send submenu install menu label enabled?)
(let ([item (as-objc-allocation (let ([item (as-objc-allocation
(tell (tell MyMenuItem alloc) (tell (tell MyMenuItem alloc)
initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "")

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

@ -49,9 +49,10 @@
(tellv cocoa-menu addItem: (tell NSMenuItem separatorItem)))) (tellv cocoa-menu addItem: (tell NSMenuItem separatorItem))))
items))) items)))
(define/public (install cocoa-parent label) (define/public (install cocoa-parent label enabled?)
(create-menu label) (create-menu label)
(tellv cocoa-parent addItem: cocoa)) (tellv cocoa-parent addItem: cocoa)
(tellv cocoa setEnabled: #:type _BOOL enabled?))
(define popup-box #f) (define popup-box #f)

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

@ -62,6 +62,6 @@
[cocoa [cocoa
(as-objc-allocation (as-objc-allocation
(tell (tell NSView alloc) (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))))] (make-NSSize w h))))]
[no-show? (memq 'deleted style)])) [no-show? (memq 'deleted style)]))

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

@ -65,7 +65,7 @@
(define-unimplemented special-control-key) (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-color-from-user)
(define-unimplemented get-font-from-user) (define-unimplemented get-font-from-user)
(define (get-panel-background) (make-object color% "gray")) (define (get-panel-background) (make-object color% "gray"))

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

@ -73,7 +73,7 @@
(let ([cocoa (let ([cocoa
(as-objc-allocation (as-objc-allocation
(tell (tell MyMatrix alloc) (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)) (make-NSSize w h))
mode: #:type _int NSRadioModeMatrix mode: #:type _int NSRadioModeMatrix
cellClass: (if (andmap string? labels) cellClass: (if (andmap string? labels)

2
collects/mred/private/wx/cocoa/tab-panel.rkt
View File

@ -41,7 +41,7 @@
(tellv cocoa addTabViewItem: item) (tellv cocoa addTabViewItem: item)
item))) item)))
(let ([sz (tell #:type _NSSize cocoa minimumSize)]) (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) (tellv cocoa setDelegate: cocoa)
(define content-cocoa (define content-cocoa

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

@ -24,7 +24,8 @@
queue-window-event queue-window-event
queue-window*-event queue-window*-event
request-flush-delay request-flush-delay
cancel-flush-delay) cancel-flush-delay
make-init-point)
(define-local-member-name flip-client) (define-local-member-name flip-client)
@ -313,8 +314,10 @@
(set-box! h (->long (NSSize-height s))))) (set-box! h (->long (NSSize-height s)))))
(define/public (set-size x y w h) (define/public (set-size x y w h)
(tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) (let ([x (if (= x -11111) 0 x)]
(make-NSSize w h)))) [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) (define/public (move x y)
(set-size x y (get-width) (get-height))) (set-size x y (get-width) (get-height)))
@ -449,3 +452,11 @@
(set! depth (sub1 depth)) (set! depth (sub1 depth))
(tellv cocoa-win enableFlushWindow) (tellv cocoa-win enableFlushWindow)
(remove-event-boundary-callback! req))))) (remove-event-boundary-callback! req)))))
(define (make-init-point x y)
(make-NSPoint (if (= x -11111)
0
x)
(if (= y -11111)
0
y)))

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

@ -260,7 +260,7 @@
(define/augment (is-enabled-to-root?) #t) (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) (define/override (call-pre-on-event w e)
(pre-on-event w e)) (pre-on-event w e))

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

@ -64,7 +64,7 @@
can-show-print-setup?) can-show-print-setup?)
(define-unimplemented special-control-key) (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-color-from-user)
(define-unimplemented get-font-from-user) (define-unimplemented get-font-from-user)
(define (get-panel-background) (make-object color% "gray")) (define (get-panel-background) (make-object color% "gray"))