505 lines
19 KiB
Racket
505 lines
19 KiB
Racket
#lang scheme/base
|
|
(require ffi/unsafe/objc
|
|
ffi/unsafe
|
|
scheme/class
|
|
"pool.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"window.rkt"
|
|
"queue.rkt"
|
|
"menu-bar.rkt"
|
|
"cursor.rkt"
|
|
"../../syntax.rkt"
|
|
"../common/queue.rkt"
|
|
"../../lock.rkt")
|
|
|
|
(provide frame%
|
|
location->window
|
|
get-front)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSWindow NSGraphicsContext NSMenu NSPanel
|
|
NSApplication NSAutoreleasePool NSScreen
|
|
NSToolbar)
|
|
|
|
(define NSWindowCloseButton 0)
|
|
(define NSWindowToolbarButton 3)
|
|
|
|
(define front #f)
|
|
|
|
(define (get-front) front)
|
|
|
|
(define empty-mb (new menu-bar%))
|
|
(define root-fake-frame #f)
|
|
|
|
(define all-windows (make-hash))
|
|
|
|
(define-objc-mixin (MyWindowMethods Superclass)
|
|
[wxb]
|
|
[-a _scheme (getEventspace)
|
|
(let ([wx (->wx wxb)])
|
|
(and wx (send wx get-eventspace)))]
|
|
[-a _BOOL (canBecomeKeyWindow)
|
|
(let ([wx (->wx wxb)])
|
|
(and wx
|
|
(not (other-modal? wx))))]
|
|
[-a _BOOL (canBecomeMainWindow) #t]
|
|
[-a _BOOL (windowShouldClose: [_id win])
|
|
(queue-window*-event wxb (lambda (wx)
|
|
(unless (other-modal? wx)
|
|
(when (send wx on-close)
|
|
(atomically
|
|
(send wx direct-show #f))))))
|
|
#f]
|
|
[-a _void (windowDidResize: [_id notification])
|
|
(when wxb
|
|
(queue-window*-event wxb (lambda (wx)
|
|
(send wx on-size 0 0)
|
|
(send wx clean-up))))]
|
|
[-a _void (windowDidMove: [_id notification])
|
|
(when wxb
|
|
(queue-window*-event wxb (lambda (wx)
|
|
(send wx on-size 0 0))))]
|
|
[-a _void (windowDidBecomeMain: [_id notification])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(set! front wx)
|
|
(send wx install-wait-cursor)
|
|
(send wx install-mb)
|
|
(send wx notify-responder #t)
|
|
(queue-window-event wx (lambda ()
|
|
(send wx on-activate #t))))))]
|
|
[-a _void (windowDidResignMain: [_id notification])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(when (eq? front wx)
|
|
(set! front #f)
|
|
(send wx uninstall-wait-cursor))
|
|
(send empty-mb install)
|
|
(send wx notify-responder #f)
|
|
(queue-window-event wx (lambda ()
|
|
(send wx on-activate #f))))))]
|
|
[-a _void (toggleToolbarShown: [_id sender])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(queue-window-event wx
|
|
(lambda () (send wx on-toolbar-click))))))
|
|
(void)])
|
|
|
|
(define-objc-class MyWindow NSWindow
|
|
#:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
|
|
[wxb])
|
|
|
|
(define-objc-class MyPanel NSPanel
|
|
#:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
|
|
[wxb])
|
|
|
|
(set-front-hook! (lambda () (values front
|
|
(and front (send front get-eventspace)))))
|
|
|
|
(set-eventspace-hook! (lambda (w)
|
|
(or (and w
|
|
(if (objc-is-a? w MyWindow)
|
|
(tell #:type _scheme w getEventspace)
|
|
#f))
|
|
(and front
|
|
(send front get-eventspace)))))
|
|
|
|
(define frame%
|
|
(class window%
|
|
(init parent
|
|
label
|
|
x y w h
|
|
style)
|
|
(init [is-dialog? #f])
|
|
|
|
(inherit get-cocoa get-parent
|
|
get-eventspace
|
|
pre-on-char pre-on-event
|
|
get-x get-y
|
|
on-new-child)
|
|
|
|
(super-new [parent parent]
|
|
[cocoa
|
|
(let ([is-sheet? (and #f
|
|
is-dialog?
|
|
parent
|
|
(not (send parent frame-is-dialog?)))]
|
|
[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
|
|
MyWindow)
|
|
alloc)
|
|
initWithContentRect: #:type _NSRect init-rect
|
|
styleMask: #:type _int (if (memq 'no-caption style)
|
|
NSBorderlessWindowMask
|
|
(bitwise-ior
|
|
NSTitledWindowMask
|
|
(if is-sheet? NSUtilityWindowMask 0)
|
|
(if is-dialog?
|
|
0
|
|
(bitwise-ior
|
|
NSClosableWindowMask
|
|
NSMiniaturizableWindowMask
|
|
(if (memq 'no-resize-border style)
|
|
0
|
|
NSResizableWindowMask)))))
|
|
backing: #:type _int NSBackingStoreBuffered
|
|
defer: #:type _BOOL NO))])
|
|
;; use init rect as frame size, not content size
|
|
(tellv c setFrame: #:type _NSRect init-rect display: #:type _BOOL #f)
|
|
c))]
|
|
[no-show? #t])
|
|
(define cocoa (get-cocoa))
|
|
(tellv cocoa setDelegate: cocoa)
|
|
|
|
(when (memq 'toolbar-button style)
|
|
(atomically
|
|
(let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")])
|
|
(tellv cocoa setToolbar: tb)
|
|
(tellv tb setVisible: #:type _BOOL #f))))
|
|
|
|
(move -11111 (if (= y -11111) 0 y))
|
|
|
|
(tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t)
|
|
|
|
(define/override (get-cocoa-content)
|
|
(tell cocoa contentView))
|
|
(define/override (get-cocoa-window) cocoa)
|
|
(define/override (get-wx-window) this)
|
|
|
|
(define/override (make-graphics-context)
|
|
(tell cocoa graphicsContext)
|
|
#;
|
|
(as-objc-allocation
|
|
(tell NSGraphicsContext graphicsContextWithWindow: cocoa)))
|
|
|
|
(define is-a-dialog? is-dialog?)
|
|
(define/public (frame-is-dialog?) is-a-dialog?)
|
|
|
|
(define/public (frame-relative-dialog-status win) #f)
|
|
(define/override (get-dialog-level) 0)
|
|
|
|
(define/public (clean-up)
|
|
;; When a window is resized, then any drawing that is in flight
|
|
;; might draw outside the canvas boundaries. Just refresh everything.
|
|
(tellv cocoa display))
|
|
|
|
(when label
|
|
(tellv cocoa setTitle: #:type _NSString label))
|
|
|
|
(define child-sheet #f)
|
|
(define/public (get-sheet) child-sheet)
|
|
(define/public (set-sheet s) (set! child-sheet s))
|
|
|
|
(define caption? (not (memq 'no-caption style)))
|
|
(define/public (can-have-sheet?) caption?)
|
|
|
|
(define/public (direct-show on?)
|
|
;; in atomic mode
|
|
(when (and (not on?)
|
|
(eq? front this))
|
|
(set! front #f)
|
|
(send empty-mb install))
|
|
(if on?
|
|
(show-children)
|
|
(hide-children))
|
|
(if on?
|
|
(if (and is-a-dialog?
|
|
(let ([p (get-parent)])
|
|
(and p
|
|
(send p can-have-sheet?)
|
|
(not (send p get-sheet)))))
|
|
(let ([p (get-parent)])
|
|
(send p set-sheet this)
|
|
(tell (tell NSApplication sharedApplication)
|
|
beginSheet: cocoa
|
|
modalForWindow: (send p get-cocoa)
|
|
modalDelegate: #f
|
|
didEndSelector: #:type _SEL #f
|
|
contextInfo: #f))
|
|
(tellv cocoa makeKeyAndOrderFront: #f))
|
|
(begin
|
|
(when is-a-dialog?
|
|
(let ([p (get-parent)])
|
|
(when (and p
|
|
(eq? this (send p get-sheet)))
|
|
(send p set-sheet #f)
|
|
(tell (tell NSApplication sharedApplication)
|
|
endSheet: cocoa))))
|
|
(tellv cocoa orderOut: #f)
|
|
(let ([next
|
|
(atomically
|
|
(with-autorelease
|
|
(let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)])
|
|
(begin0
|
|
(for/or ([i (in-range (tell #:type _NSUInteger wins count))])
|
|
(let ([win (tell wins objectAtIndex: #:type _NSUInteger i)])
|
|
(and (tell #:type _BOOL win isVisible)
|
|
win)))))))])
|
|
(cond
|
|
[next (tellv next makeKeyWindow)]
|
|
[root-fake-frame (send root-fake-frame install-mb)]
|
|
[else (void)]))))
|
|
(register-frame-shown this on?)
|
|
(let ([num (tell #:type _NSInteger cocoa windowNumber)])
|
|
(if on?
|
|
(hash-set! all-windows num this)
|
|
(hash-remove! all-windows num)))
|
|
(when on?
|
|
(let ([b (eventspace-wait-cursor-count (get-eventspace))])
|
|
(set-wait-cursor-mode (not (zero? b))))))
|
|
|
|
(define/override (show on?)
|
|
(let ([es (get-eventspace)])
|
|
(when on?
|
|
(when (eventspace-shutdown? es)
|
|
(error (string->symbol
|
|
(format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%)))
|
|
"the eventspace hash been shutdown"))
|
|
(when saved-child
|
|
(if (eq? (current-thread) (eventspace-handler-thread es))
|
|
(do-paint-children)
|
|
(let ([s (make-semaphore)])
|
|
(queue-callback (lambda ()
|
|
(do-paint-children)
|
|
(semaphore-post s)))
|
|
(sync/timeout 1 s))))))
|
|
(atomically
|
|
(direct-show on?)))
|
|
|
|
(define/private (do-paint-children)
|
|
(when saved-child
|
|
(send saved-child paint-children))
|
|
(yield-refresh)
|
|
(try-to-sync-refresh))
|
|
|
|
(define/public (destroy)
|
|
(when child-sheet (send child-sheet destroy))
|
|
(atomically
|
|
(direct-show #f)))
|
|
|
|
(define/override (hide-children)
|
|
(when saved-child
|
|
(send saved-child hide-children)))
|
|
(define/override (show-children)
|
|
(when saved-child
|
|
(send saved-child show-children)))
|
|
|
|
(define/override (children-accept-drag on?)
|
|
(when saved-child
|
|
(send saved-child child-accept-drag on?)))
|
|
|
|
(define/override (is-shown?)
|
|
(tell #:type _bool cocoa isVisible))
|
|
|
|
(define/override (is-shown-to-root?)
|
|
(is-shown?))
|
|
|
|
(define/override (is-shown-to-before-root?) #t)
|
|
|
|
(define/override (is-parent-enabled-to-root?)
|
|
#t)
|
|
|
|
(define/override (is-view?) #f)
|
|
|
|
(define is-main? #f)
|
|
(define first-responder #f)
|
|
|
|
(define saved-child #f)
|
|
(define/override (register-child child on?)
|
|
(unless on? (error 'register-child-in-frame "did not expect #f"))
|
|
(unless (or (not saved-child) (eq? child saved-child))
|
|
(error 'register-child-in-frame "expected only one child"))
|
|
(set! saved-child child)
|
|
(on-new-child child #t))
|
|
|
|
(define/override (set-cursor c)
|
|
(when saved-child
|
|
(send saved-child set-cursor c)))
|
|
|
|
(define/public (notify-responder on?)
|
|
(set! is-main? on?)
|
|
(when first-responder
|
|
(do-notify-responder first-responder on?)))
|
|
|
|
(define/private (do-notify-responder wx on?)
|
|
(send wx focus-is-on on?)
|
|
(queue-window-event wx
|
|
(if on?
|
|
(lambda () (send wx on-set-focus))
|
|
(lambda () (send wx on-kill-focus)))))
|
|
|
|
(define/override (is-responder wx on?)
|
|
(unless (and (not on?)
|
|
(not (eq? first-responder wx)))
|
|
(if on?
|
|
(set! first-responder wx)
|
|
(set! first-responder #f))
|
|
(when is-main?
|
|
(do-notify-responder wx on?))))
|
|
|
|
(define/public (install-wait-cursor)
|
|
(when (positive? (eventspace-wait-cursor-count (get-eventspace)))
|
|
(tellv (get-wait-cursor-handle) set)))
|
|
|
|
(define/public (uninstall-wait-cursor)
|
|
(when (positive? (eventspace-wait-cursor-count (get-eventspace)))
|
|
(tellv arrow-cursor-handle set)))
|
|
|
|
(define/public (set-wait-cursor-mode on?)
|
|
(if on?
|
|
(tell cocoa disableCursorRects)
|
|
(tell cocoa enableCursorRects))
|
|
(when (eq? this front)
|
|
(if on?
|
|
(install-wait-cursor)
|
|
(uninstall-wait-cursor))))
|
|
|
|
(define/override (start-no-cursor-rects)
|
|
(tell cocoa disableCursorRects))
|
|
|
|
(define/override (end-no-cursor-rects)
|
|
(unless (positive? (eventspace-wait-cursor-count (get-eventspace)))
|
|
(tell cocoa enableCursorRects)))
|
|
|
|
(define/public (flip-screen y)
|
|
(let ([f (tell #:type _NSRect (tell cocoa screen) frame)])
|
|
(- (NSSize-height (NSRect-size f)) y)))
|
|
|
|
(define/override (flip y h) (flip-screen (+ y h)))
|
|
|
|
(define/override (set-size x y w h)
|
|
(unless (and (= x -1) (= y -1))
|
|
(move x y))
|
|
(let ([f (tell #:type _NSRect cocoa frame)])
|
|
(tellv cocoa setFrame:
|
|
#:type _NSRect (make-NSRect
|
|
(make-NSPoint (if (and is-a-dialog?
|
|
(let ([p (get-parent)])
|
|
(and p
|
|
(eq? this (send p get-sheet)))))
|
|
;; need to re-center sheet:
|
|
(let* ([p (get-parent)]
|
|
[px (send p get-x)]
|
|
[pw (send p get-width)])
|
|
(+ px (/ (- pw w) 2)))
|
|
;; keep current x position:
|
|
(NSPoint-x (NSRect-origin f)))
|
|
(- (NSPoint-y (NSRect-origin f))
|
|
(- h
|
|
(NSSize-height (NSRect-size f)))))
|
|
(make-NSSize w h))
|
|
display: #:type _BOOL #t)))
|
|
(define/override (move x 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)
|
|
(get-menu-bar-height))))))
|
|
|
|
(define/override (center dir wrt)
|
|
(let ([f (tell #:type _NSRect cocoa frame)]
|
|
[s (tell #:type _NSRect (tell cocoa screen) frame)])
|
|
(tellv cocoa setFrame:
|
|
#:type _NSRect (make-NSRect (make-NSPoint
|
|
(if (or (eq? dir 'both)
|
|
(eq? dir 'horizontal))
|
|
(/ (- (NSSize-width (NSRect-size s))
|
|
(NSSize-width (NSRect-size f)))
|
|
2)
|
|
(NSPoint-x (NSRect-origin f)))
|
|
(if (or (eq? dir 'both)
|
|
(eq? dir 'vertical))
|
|
(/ (- (NSSize-height (NSRect-size s))
|
|
(NSSize-height (NSRect-size f)))
|
|
2)
|
|
(NSPoint-x (NSRect-origin f))))
|
|
(NSRect-size f))
|
|
display: #:type _BOOL #t)))
|
|
|
|
(define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
|
|
(define (adj v) (if (negative? v) 32000 v))
|
|
(tellv cocoa setMinSize: #:type _NSSize (make-NSSize (max min-x 1)
|
|
(max min-y 1)))
|
|
(tellv cocoa setMaxSize: #:type _NSSize (make-NSSize (adj max-x)
|
|
(adj max-y)))
|
|
(tellv cocoa setResizeIncrements: #:type _NSSize (make-NSSize inc-x inc-y)))
|
|
|
|
(define hide-mb? (and (memq 'hide-menu-bar style) #t))
|
|
(define mb #f)
|
|
(define/public (get-menu-bar) mb)
|
|
(define/public (set-menu-bar _mb)
|
|
(set! mb _mb)
|
|
(send mb set-top-window this)
|
|
(when (tell #:type _BOOL cocoa isMainWindow)
|
|
(install-mb)))
|
|
|
|
(define/public (install-mb)
|
|
(tellv NSMenu setMenuBarVisible: #:type _BOOL (not hide-mb?))
|
|
(if mb
|
|
(send mb install)
|
|
(send empty-mb install)))
|
|
|
|
(define/public (on-activate on?) (void))
|
|
|
|
(define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME
|
|
|
|
(define/override (call-pre-on-event w e)
|
|
(pre-on-event w e))
|
|
(define/override (call-pre-on-char w e)
|
|
(pre-on-char w e))
|
|
|
|
(define/public (on-menu-click) (void))
|
|
|
|
(define/public (on-toolbar-click) (void))
|
|
(def/public-unimplemented on-menu-command)
|
|
(def/public-unimplemented on-mdi-activate)
|
|
(def/public-unimplemented on-close)
|
|
(define/public (designate-root-frame)
|
|
(set! root-fake-frame this))
|
|
(def/public-unimplemented system-menu)
|
|
|
|
(define/public (set-modified on?)
|
|
(let ([b (tell cocoa standardWindowButton: #:type _NSInteger NSWindowCloseButton)])
|
|
(tellv b setDocumentEdited: #:type _BOOL on?)))
|
|
|
|
(define/public (create-status-line) (void))
|
|
(define/public (set-status-text s) (void))
|
|
(def/public-unimplemented status-line-exists?)
|
|
|
|
(define/public (is-maximized?)
|
|
(tell #:type _BOOL cocoa isZoomed))
|
|
(define/public (maximize on?)
|
|
(unless (eq? (tell #:type _BOOL cocoa isZoomed)
|
|
(and on? #t))
|
|
(tellv cocoa zoom: cocoa)))
|
|
|
|
(define/public (iconized?)
|
|
(tell #:type _BOOL cocoa isMiniaturized))
|
|
(define/public (iconize on?)
|
|
(tellv cocoa miniaturize: cocoa))
|
|
|
|
(define/public (set-title s)
|
|
(tellv cocoa setTitle: #:type _NSString s))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (location->window x y)
|
|
(let ([n (tell #:type _NSInteger NSWindow
|
|
windowNumberAtPoint: #:type _NSPoint
|
|
(let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
|
|
(make-NSPoint x (- (NSSize-height (NSRect-size f)) y)))
|
|
belowWindowWithWindowNumber: #:type _NSInteger 0)])
|
|
(atomically (hash-ref all-windows n #f))))
|