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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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