a964f3effb
When restoring autodisplay, need to check whether a display was
lost since display was suspended.
(cherry picked from commit 9bf18505d5)
776 lines
30 KiB
Racket
776 lines
30 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe/objc
|
|
ffi/unsafe
|
|
racket/class
|
|
"pool.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"window.rkt"
|
|
"queue.rkt"
|
|
"menu-bar.rkt"
|
|
"cursor.rkt"
|
|
"../../syntax.rkt"
|
|
"../common/queue.rkt"
|
|
"../common/freeze.rkt"
|
|
"../../lock.rkt")
|
|
|
|
(provide
|
|
(protect-out frame%
|
|
location->window
|
|
get-front
|
|
|
|
RacketEventspaceMethods
|
|
install-RacketGCWindow!))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSWindow NSGraphicsContext NSMenu NSPanel
|
|
NSApplication NSAutoreleasePool NSScreen
|
|
NSToolbar NSArray)
|
|
|
|
(define NSWindowCloseButton 0)
|
|
(define NSWindowToolbarButton 3)
|
|
|
|
(define front #f)
|
|
|
|
(define (get-front) front)
|
|
|
|
(define empty-mb (new menu-bar%))
|
|
(define root-fake-frame #f)
|
|
|
|
;; Maps window numbers to weak boxes of frame objects;
|
|
;; the weak-box layer is needed to avoid GC-accounting
|
|
;; problems.
|
|
(define all-windows (make-hash))
|
|
|
|
;; called in atomic mode
|
|
(define (send-screen-change-notifications flags)
|
|
(when (zero? (bitwise-and flags 1)) ;; discard the "about to change" notifications
|
|
(for ([b (in-hash-values all-windows)])
|
|
(define f (weak-box-value b))
|
|
(when f
|
|
(define e (send f get-eventspace))
|
|
(unless (eventspace-shutdown? e)
|
|
(parameterize ([current-eventspace e])
|
|
(queue-callback
|
|
(λ ()
|
|
(send f display-changed)))))))))
|
|
|
|
(set-screen-changed-callback! send-screen-change-notifications)
|
|
|
|
(define RacketGCWindow #f)
|
|
(define (install-RacketGCWindow! c) (set! RacketGCWindow c))
|
|
|
|
(define-objc-mixin (RacketEventspaceMethods Superclass)
|
|
[wxb]
|
|
[-a _scheme (getEventspace)
|
|
(let ([wx (->wx wxb)])
|
|
(and wx (send wx get-eventspace)))])
|
|
|
|
(define-objc-mixin (RacketWindowMethods Superclass)
|
|
#:mixins (RacketEventspaceMethods)
|
|
[wxb]
|
|
[-a _BOOL (canBecomeKeyWindow)
|
|
(let ([wx (->wx wxb)])
|
|
(and wx
|
|
(not (other-modal? wx))))]
|
|
[-a _BOOL (canBecomeMainWindow)
|
|
(let ([wx (->wx wxb)])
|
|
(or (not wx)
|
|
(not (send wx floating?))))]
|
|
[-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
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(queue-window-event wx (lambda ()
|
|
(send wx queue-on-size)
|
|
(send wx clean-up)))
|
|
;; Live resize:
|
|
(constrained-reply (send wx get-eventspace)
|
|
(lambda ()
|
|
(pre-event-sync #t)
|
|
(let loop () (when (yield/no-sync) (loop))))
|
|
(void)))))]
|
|
[-a _void (windowDidMove: [_id notification])
|
|
(when wxb
|
|
(queue-window*-event wxb (lambda (wx)
|
|
(send wx queue-on-size))))]
|
|
[-a _void (windowDidBecomeMain: [_id notification])
|
|
;; We check whether the window is visible because
|
|
;; clicking the dock item tries to resurrect a hidden
|
|
;; frame. See also `setOneShot' below.
|
|
(when (tell #:type _BOOL self isVisible)
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
;; Sometimes, a sheet becomes the main window and the parent
|
|
;; still thinks that the parent is the main window. Tell
|
|
;; the parent otherwise.
|
|
(let ([p (send wx get-parent)])
|
|
(when p
|
|
(let ([s (send p get-sheet)])
|
|
(when (eq? s wx)
|
|
(let ([parent (send p get-cocoa)])
|
|
(when (tell #:type _BOOL parent isMainWindow)
|
|
;; The Cocoa docs say never to call this method directly,
|
|
;; but we're trying to fix up a case where Cocoa seems
|
|
;; to be confused:
|
|
(tellv parent resignMainWindow)))))))
|
|
(set! front wx)
|
|
(send wx install-wait-cursor)
|
|
(send wx install-mb)
|
|
(queue-window-event wx (lambda ()
|
|
(send wx on-activate #t)))))))]
|
|
[-a _void (windowDidBecomeKey: [_id notification])
|
|
(when (tell #:type _BOOL self isVisible)
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx notify-responder #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))
|
|
(if root-fake-frame
|
|
(send root-fake-frame install-mb)
|
|
(send empty-mb install))
|
|
(queue-window-event wx (lambda ()
|
|
(send wx on-activate #f))))))]
|
|
[-a _void (windowDidResignKey: [_id notification])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx notify-responder #f))))]
|
|
[-a _void (windowDidMiniaturize: [_id notification])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx force-window-focus))))]
|
|
[-a _void (windowDidEndSheet: [_id notification])
|
|
;; In some cases, the window that has a sheet
|
|
;; stays main even as its sheet becomes main, so
|
|
;; we need to make the containing window become main
|
|
;; when the sheet goes away.
|
|
(when (equal? self (tell app mainWindow))
|
|
(tell self windowDidBecomeMain: notification))]
|
|
[-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 RacketWindow NSWindow
|
|
#:mixins (FocusResponder KeyMouseResponder RacketWindowMethods)
|
|
[wxb])
|
|
|
|
(define-objc-class RacketPanel NSPanel
|
|
#:mixins (FocusResponder KeyMouseResponder RacketWindowMethods)
|
|
[wxb])
|
|
|
|
(set-front-hook! (lambda ()
|
|
(let ([f (or front
|
|
root-fake-frame)])
|
|
(values f
|
|
(and f (send f get-eventspace))))))
|
|
|
|
(set-eventspace-hook! (lambda (evt w)
|
|
(define (is-mouse-or-key?)
|
|
(bitwise-bit-set? MouseAndKeyEventMask
|
|
(tell #:type _NSInteger evt type)))
|
|
(cond
|
|
[w
|
|
(and (or (not root-fake-frame)
|
|
;; only mouse and key events in the root
|
|
;; frame need to be dispatched in the root
|
|
;; eventspace:
|
|
(not (ptr-equal? w (send root-fake-frame get-cocoa)))
|
|
(is-mouse-or-key?))
|
|
(or (objc-is-a? w RacketWindow)
|
|
(objc-is-a? w RacketPanel)
|
|
(and RacketGCWindow
|
|
(objc-is-a? w RacketGCWindow)))
|
|
(tell #:type _scheme w getEventspace))]
|
|
[front (send front get-eventspace)]
|
|
[root-fake-frame
|
|
(and (is-mouse-or-key?)
|
|
(send root-fake-frame get-eventspace))]
|
|
[else #f])))
|
|
|
|
(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
|
|
on-new-child
|
|
is-window-enabled?)
|
|
|
|
(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)
|
|
1
|
|
22)
|
|
h)))])
|
|
(let ([c (as-objc-allocation
|
|
(tell (tell (if (or is-sheet? (memq 'float style))
|
|
RacketPanel
|
|
RacketWindow)
|
|
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?
|
|
(bitwise-ior
|
|
(if (memq 'close-button style)
|
|
NSClosableWindowMask
|
|
0)
|
|
(if (memq 'resize-border style)
|
|
NSResizableWindowMask
|
|
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)
|
|
;; fullscreen variants:
|
|
(when (version-10.7-or-later?)
|
|
(cond
|
|
[(memq 'fullscreen-button style)
|
|
(tellv c setCollectionBehavior: #:type _int NSWindowCollectionBehaviorFullScreenPrimary)]
|
|
[(memq 'fullscreen-aux style)
|
|
(tellv c setCollectionBehavior: #:type _int NSWindowCollectionBehaviorFullScreenAuxiliary)]
|
|
[else (void)]))
|
|
c))]
|
|
[no-show? #t])
|
|
(define cocoa (get-cocoa))
|
|
(tellv cocoa setDelegate: cocoa)
|
|
|
|
(unless (version-10.7-or-later?)
|
|
(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)
|
|
(tellv tb release)))))
|
|
|
|
(internal-move #f (or y 0))
|
|
|
|
(tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t)
|
|
|
|
;; Setting the window in one-shot mode helps prevent the
|
|
;; frame from being resurrected by a click on the dock icon.
|
|
(tellv cocoa setOneShot: #: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 not-sheet? (and (memq 'no-sheet style) #t))
|
|
|
|
(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 float? (memq 'float style))
|
|
(define/public (can-have-sheet?) caption?)
|
|
(define/public (floating?) float?)
|
|
|
|
(when float?
|
|
(tell cocoa setFloatingPanel: #:type _BOOL #t))
|
|
|
|
(define/public (direct-show on?)
|
|
;; in atomic mode
|
|
(when on? (promote-to-gui!))
|
|
(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?
|
|
(not not-sheet?)
|
|
(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)
|
|
(tellv (tell NSApplication sharedApplication)
|
|
beginSheet: cocoa
|
|
modalForWindow: (send p get-cocoa)
|
|
modalDelegate: #f
|
|
didEndSelector: #:type _SEL #f
|
|
contextInfo: #f))
|
|
(if float?
|
|
(tellv cocoa orderFront: #f)
|
|
(begin
|
|
(tellv cocoa makeKeyAndOrderFront: #f)
|
|
(when unshown-fullscreen?
|
|
(set! unshown-fullscreen? #f)
|
|
(tellv cocoa toggleFullScreen: #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))))
|
|
(when (is-shown?) ; otherwise, `deminiaturize' can show the window
|
|
(tellv cocoa deminiaturize: #f)
|
|
(define fs? (fullscreened?))
|
|
(set! unshown-fullscreen? fs?)
|
|
(tellv cocoa orderOut: #f)
|
|
(when fs?
|
|
;; Need to select another window to get rid of
|
|
;; the window's screen:
|
|
(tellv (get-app-front-window) orderFront: #f)))
|
|
(force-window-focus)))
|
|
(register-frame-shown this on?)
|
|
(let ([num (tell #:type _NSInteger cocoa windowNumber)])
|
|
(if on?
|
|
(hash-set! all-windows num (make-weak-box 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 (version-10.11-or-later?)
|
|
;; Ensure that the basic window background is drawn before
|
|
;; we potentially suspend redrawing. Otherwise, the window
|
|
;; can start black and end up with a too-dark titlebar.
|
|
(tellv cocoa display))
|
|
(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 flush-disabled 0)
|
|
|
|
(define/public (disable-flush-window)
|
|
(when (zero? flush-disabled)
|
|
(when (version-10.11-or-later?)
|
|
(tellv cocoa setAutodisplay: #:type _BOOL #f))
|
|
(tellv cocoa disableFlushWindow))
|
|
(set! flush-disabled (add1 flush-disabled)))
|
|
|
|
(define/public (enable-flush-window)
|
|
(set! flush-disabled (sub1 flush-disabled))
|
|
(when (zero? flush-disabled)
|
|
(tellv cocoa enableFlushWindow)
|
|
(when (version-10.11-or-later?)
|
|
(tellv cocoa setAutodisplay: #:type _BOOL #t)
|
|
(tellv cocoa displayIfNeeded))))
|
|
|
|
(define/public (force-window-focus)
|
|
(let ([next (get-app-front-window)])
|
|
(cond
|
|
[next
|
|
(tellv next makeKeyWindow)]
|
|
[root-fake-frame
|
|
;; Make key focus shift to root frame:
|
|
(let ([root-cocoa (send root-fake-frame get-cocoa)])
|
|
(tellv root-cocoa orderFront: #f)
|
|
(tellv root-cocoa makeKeyWindow)
|
|
(tellv root-cocoa orderOut: #f))
|
|
;; Install root frame's menu bar:
|
|
(send root-fake-frame install-mb)]
|
|
[else (void)])))
|
|
|
|
(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 (fixup-locations-children)
|
|
(when saved-child
|
|
(send saved-child fixup-locations-children)))
|
|
|
|
(define/override (children-accept-drag on?)
|
|
(when saved-child
|
|
(send saved-child child-accept-drag on?)))
|
|
|
|
(define/override (enable-window on?)
|
|
(when saved-child
|
|
(send saved-child enable-window (and on? (is-window-enabled?)))))
|
|
|
|
(define/override (is-shown?)
|
|
(or (tell #:type _bool cocoa isVisible)
|
|
(tell #:type _bool cocoa isMiniaturized)))
|
|
|
|
(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 (refresh-all-children)
|
|
(when saved-child
|
|
(send saved-child refresh)))
|
|
|
|
(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))
|
|
(unless on?
|
|
(tellv cocoa makeFirstResponder: #f))
|
|
(when is-main?
|
|
(do-notify-responder wx on?))))
|
|
|
|
(define/public (get-focus-window [even-if-not-active? #f])
|
|
(let ([f-cocoa (tell cocoa firstResponder)])
|
|
(and f-cocoa
|
|
(or even-if-not-active?
|
|
(tell #:type _BOOL cocoa isKeyWindow))
|
|
(->wx (get-ivar f-cocoa wxb)))))
|
|
|
|
(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 NSScreen mainScreen) frame)])
|
|
(- (NSSize-height (NSRect-size f)) y)))
|
|
|
|
(define/override (flip y h) (flip-screen (+ y h)))
|
|
|
|
(define/override (get-y)
|
|
(- (super get-y) (get-menu-bar-height)))
|
|
|
|
(define/override (set-size x y w h)
|
|
(unless (and (equal? x -1) (equal? y -1))
|
|
(internal-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)))
|
|
;; keep current y position:
|
|
(- (NSPoint-y (NSRect-origin f))
|
|
(- h
|
|
(NSSize-height (NSRect-size f)))))
|
|
(make-NSSize w h))
|
|
display: #:type _BOOL #t)))
|
|
(define/override (internal-move x y)
|
|
(let ([x (if (not x) (get-x) x)]
|
|
[y (if (not y) (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)]
|
|
[w (if wrt
|
|
(tell #:type _NSRect (send wrt get-cocoa) frame)
|
|
(tell #:type _NSRect (tell cocoa screen) frame))])
|
|
(tellv cocoa setFrame:
|
|
#:type _NSRect (make-NSRect (make-NSPoint
|
|
(if (or (eq? dir 'both)
|
|
(eq? dir 'horizontal))
|
|
(+ (quotient (- (NSSize-width (NSRect-size w))
|
|
(NSSize-width (NSRect-size f)))
|
|
2)
|
|
(NSPoint-x (NSRect-origin w)))
|
|
(NSPoint-x (NSRect-origin f)))
|
|
(if (or (eq? dir 'both)
|
|
(eq? dir 'vertical))
|
|
(+ (quotient (- (NSSize-height (NSRect-size w))
|
|
(NSSize-height (NSRect-size f)))
|
|
2)
|
|
(NSPoint-y (NSRect-origin w)))
|
|
(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 (or (tell #:type _BOOL cocoa isMainWindow)
|
|
(and (eq? this root-fake-frame)
|
|
(not (get-app-front-window))))
|
|
(promote-to-gui!)
|
|
(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 #f] [mode 'both]) (void)) ;; FIXME
|
|
|
|
(define default-buttons (make-hasheq))
|
|
(define checking-default? #f)
|
|
(define/public (add-possible-default button)
|
|
(hash-set! default-buttons button #t)
|
|
(queue-default-button-check))
|
|
(define/public (remove-possible-default button)
|
|
(hash-remove! default-buttons button)
|
|
(queue-default-button-check))
|
|
(define/public (queue-default-button-check)
|
|
(when (atomically
|
|
(if checking-default?
|
|
#f
|
|
(begin
|
|
(set! checking-default? #t)
|
|
#t)))
|
|
(queue-window-event
|
|
this
|
|
(lambda ()
|
|
(set! checking-default? #f)
|
|
(for/or ([button (in-hash-keys default-buttons)])
|
|
(send button be-default))))))
|
|
|
|
(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))
|
|
(define/public (on-menu-command c) (void))
|
|
(def/public-unimplemented on-mdi-activate)
|
|
(define/public (on-close) #t)
|
|
(define/public (designate-root-frame)
|
|
(set! root-fake-frame this)
|
|
;; The first window shown is somehow sticky, so that it becomes
|
|
;; the main window if no windows are shown:
|
|
(tellv cocoa orderFront: #f)
|
|
(tellv cocoa orderOut: #f)
|
|
(sync-cocoa-events))
|
|
(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 (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?)
|
|
(if on?
|
|
(tellv cocoa miniaturize: cocoa)
|
|
(tellv cocoa deminiaturize: cocoa)))
|
|
|
|
(define unshown-fullscreen? #f)
|
|
(define/public (fullscreened?)
|
|
(and (version-10.7-or-later?)
|
|
(if (tell #:type _bool cocoa isVisible)
|
|
(positive? (bitwise-and (tell #:type _NSUInteger cocoa styleMask) NSFullScreenWindowMask))
|
|
unshown-fullscreen?)))
|
|
(define/public (fullscreen on?)
|
|
(when (version-10.7-or-later?)
|
|
(unless (eq? (and on? #t) (fullscreened?))
|
|
(if (tell #:type _bool cocoa isVisible)
|
|
(tellv cocoa toggleFullScreen: #f)
|
|
(set! unshown-fullscreen? (and on? #t))))))
|
|
|
|
|
|
(define/public (set-title s)
|
|
(tellv cocoa setTitle: #:type _NSString s))
|
|
|
|
(define color-callback void)
|
|
(define/public (set-color-callback cb)
|
|
(set! color-callback cb))
|
|
(define/override (on-color-change)
|
|
(queue-window-event this (lambda () (color-callback))))
|
|
|
|
(define/public (display-changed) (void))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (get-app-front-window)
|
|
(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)
|
|
(tell #:type _BOOL win canBecomeMainWindow)
|
|
(not (tell win parentWindow))
|
|
(or (not root-fake-frame)
|
|
(not (ptr-equal? win (send root-fake-frame get-cocoa))))
|
|
win))))))))
|
|
|
|
(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 (let ([b (hash-ref all-windows n #f)])
|
|
(and b (weak-box-value b))))))
|
|
|
|
(set-fixup-window-locations!
|
|
(lambda ()
|
|
;; in atomic mode
|
|
(for ([b (in-hash-values all-windows)])
|
|
(let ([f (weak-box-value b)])
|
|
(when f
|
|
(send f fixup-locations-children))))))
|
|
|