ac2d39e0e1
The old strategy of switching a transparent window to solid and back doesn't work on 10.11; it appears that queued messages must be handled for the window to become visible, but that's not allowed during a GC. The strategy for 10.11 and up create an OpenGL canvas, which acts as a direct-to-screen drawing area that a GC callback can affect without Racket-level allocation.
231 lines
7.8 KiB
Racket
231 lines
7.8 KiB
Racket
#lang racket/base
|
|
(require "../../syntax.rkt"
|
|
racket/class
|
|
racket/draw
|
|
(only-in racket/draw/private/bitmap quartz-bitmap%)
|
|
ffi/unsafe
|
|
ffi/unsafe/objc
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"frame.rkt"
|
|
"window.rkt"
|
|
"finfo.rkt" ; file-creator-and-type
|
|
"filedialog.rkt"
|
|
"colordialog.rkt"
|
|
"dc.rkt"
|
|
"printer-dc.rkt"
|
|
"menu-bar.rkt"
|
|
"cgl.rkt"
|
|
"sound.rkt"
|
|
"keycode.rkt"
|
|
"../../lock.rkt"
|
|
"../common/handlers.rkt"
|
|
(except-in "../common/default-procs.rkt"
|
|
special-control-key
|
|
special-option-key
|
|
file-creator-and-type))
|
|
|
|
|
|
(provide
|
|
(protect-out
|
|
color-from-user-platform-mode
|
|
font-from-user-platform-mode
|
|
get-font-from-user
|
|
find-graphical-system-path
|
|
register-collecting-blit
|
|
unregister-collecting-blit
|
|
shortcut-visible-in-label?
|
|
get-double-click-time
|
|
get-control-font-face
|
|
get-control-font-size
|
|
get-control-font-size-in-pixels?
|
|
cancel-quit
|
|
display-origin
|
|
display-size
|
|
display-count
|
|
bell
|
|
hide-cursor
|
|
get-display-depth
|
|
is-color-display?
|
|
id-to-menu-item
|
|
can-show-print-setup?
|
|
get-highlight-background-color
|
|
get-highlight-text-color
|
|
check-for-break)
|
|
display-bitmap-resolution
|
|
make-screen-bitmap
|
|
make-gl-bitmap
|
|
show-print-setup
|
|
get-color-from-user
|
|
get-panel-background
|
|
fill-private-color
|
|
flush-display
|
|
play-sound
|
|
file-creator-and-type
|
|
file-selector
|
|
key-symbol-to-menu-key
|
|
needs-grow-box-spacer?
|
|
get-current-mouse-state
|
|
graphical-system-type)
|
|
|
|
(import-class NSScreen NSCursor NSMenu NSEvent)
|
|
|
|
(define (find-graphical-system-path what)
|
|
#f)
|
|
|
|
(define (color-from-user-platform-mode) "Show Picker")
|
|
|
|
(define-unimplemented get-font-from-user)
|
|
(define (font-from-user-platform-mode) #f)
|
|
|
|
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
|
|
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
|
|
(define (unregister-collecting-blit canvas)
|
|
(send canvas unregister-collecting-blits))
|
|
(define (shortcut-visible-in-label? [x #f]) #f)
|
|
|
|
(define (get-double-click-time)
|
|
500)
|
|
(define (get-control-font-face)
|
|
;; Using `(tell NSFont systemFontOfSize: ...)` gives us an OS-determined
|
|
;; font, but my attempts to extract the name give something like ".LucidaGrandeUI"
|
|
;; instead of "Lucida Grande" have failed.
|
|
(cond
|
|
;; [(version-10.11-or-later?) "San Francisco"]
|
|
[(version-10.10-or-later?) "Helvetica Neue"]
|
|
[else "Lucida Grande"]))
|
|
(define (get-control-font-size) 13)
|
|
(define (get-control-font-size-in-pixels?) #f)
|
|
(define (cancel-quit) (void))
|
|
|
|
(define (check-for-break) #f)
|
|
|
|
(define (display-origin xb yb all? num fail)
|
|
(if (or all? (positive? num))
|
|
(unless (atomically
|
|
(with-autorelease
|
|
(let ([screens (tell NSScreen screens)])
|
|
(if (num . < . (tell #:type _NSUInteger screens count))
|
|
(let* ([screen (tell screens objectAtIndex: #:type _NSUInteger num)]
|
|
[f (if (zero? num)
|
|
(tell #:type _NSRect screen visibleFrame)
|
|
(tell #:type _NSRect screen frame))])
|
|
(set-box! xb ((if (and all? (zero? num)) + -) (->long (NSPoint-x (NSRect-origin f)))))
|
|
(unless (zero? num)
|
|
(let* ([screen0 (tell screens objectAtIndex: #:type _NSUInteger 0)]
|
|
[f0 (tell #:type _NSRect screen0 frame)])
|
|
(set-box! yb (->long (- (+ (NSPoint-y (NSRect-origin f))
|
|
(NSSize-height (NSRect-size f)))
|
|
(NSSize-height (NSRect-size f0)))))))
|
|
#t)
|
|
#f))))
|
|
(fail))
|
|
(set-box! xb 0))
|
|
(when (zero? num)
|
|
(set-box! yb 0))
|
|
(set-box! yb (+ (unbox yb) (get-menu-bar-height))))
|
|
|
|
(define (display-size xb yb all? num fail)
|
|
(unless (atomically
|
|
(with-autorelease
|
|
(let ([screens (tell NSScreen screens)])
|
|
(if (num . < . (tell #:type _NSUInteger screens count))
|
|
(let* ([screen (tell screens objectAtIndex: #:type _NSUInteger num)]
|
|
[f (if all?
|
|
(tell #:type _NSRect screen frame)
|
|
(tell #:type _NSRect screen visibleFrame))])
|
|
(set-box! xb (->long (NSSize-width (NSRect-size f))))
|
|
(set-box! yb (->long (- (NSSize-height (NSRect-size f))
|
|
(cond
|
|
[all? 0]
|
|
[(positive? num) 0]
|
|
[(tell #:type _BOOL NSMenu menuBarVisible) 0]
|
|
;; Make result consistent when menu bar is hidden:
|
|
[else
|
|
(get-menu-bar-height)]))))
|
|
#t)
|
|
#f))))
|
|
(fail)))
|
|
|
|
|
|
(define (display-count)
|
|
(atomically
|
|
(with-autorelease
|
|
(let ([screens (tell NSScreen screens)])
|
|
(tell #:type _NSUInteger screens count)))))
|
|
|
|
(define-appkit NSBeep (_fun -> _void))
|
|
(define (bell) (NSBeep))
|
|
|
|
(define (hide-cursor)
|
|
(tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t))
|
|
|
|
(define (get-display-depth) 32)
|
|
(define (is-color-display?) #t)
|
|
(define (id-to-menu-item id) id)
|
|
(define (can-show-print-setup?) #t)
|
|
|
|
(define/top (make-gl-bitmap [exact-positive-integer? w]
|
|
[exact-positive-integer? h]
|
|
[gl-config% c])
|
|
(create-gl-bitmap w h c))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Text & highlight color
|
|
|
|
(import-class NSColor)
|
|
|
|
(define-cocoa NSDeviceRGBColorSpace _id)
|
|
|
|
(define (get-highlight-background-color)
|
|
(let ([hi (as-objc-allocation-with-retain
|
|
(tell (tell NSColor selectedTextBackgroundColor)
|
|
colorUsingColorSpaceName: NSDeviceRGBColorSpace))]
|
|
[as-color (lambda (v)
|
|
(inexact->exact (floor (* 255.0 v))))])
|
|
(begin0
|
|
(make-object color%
|
|
(as-color
|
|
(tell #:type _CGFloat hi redComponent))
|
|
(as-color
|
|
(tell #:type _CGFloat hi greenComponent))
|
|
(as-color
|
|
(tell #:type _CGFloat hi blueComponent)))
|
|
(release hi))))
|
|
|
|
(define (get-highlight-text-color)
|
|
#f)
|
|
|
|
(define (needs-grow-box-spacer?)
|
|
(not (version-10.7-or-later?)))
|
|
|
|
(define (graphical-system-type) 'cocoa)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Mouse and modifier-key state
|
|
|
|
(define (get-current-mouse-state)
|
|
(define posn (tell #:type _NSPoint NSEvent mouseLocation))
|
|
(define buttons (if (version-10.6-or-later?)
|
|
(tell #:type _NSUInteger NSEvent pressedMouseButtons)
|
|
0))
|
|
(define mods (tell #:type _NSUInteger NSEvent modifierFlags))
|
|
(define (maybe v mask sym)
|
|
(if (zero? (bitwise-and v mask))
|
|
null
|
|
(list sym)))
|
|
(define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
|
|
(NSSize-height (NSRect-size f))))
|
|
(values (make-object point%
|
|
(->long (NSPoint-x posn))
|
|
(->long (- (- h (NSPoint-y posn)) (get-menu-bar-height))))
|
|
(append
|
|
(maybe buttons #x1 'left)
|
|
(maybe buttons #x2 'right)
|
|
(maybe mods NSShiftKeyMask 'shift)
|
|
(maybe mods NSCommandKeyMask 'meta)
|
|
(maybe mods NSAlternateKeyMask 'alt)
|
|
(maybe mods NSControlKeyMask 'control)
|
|
(maybe mods NSAlphaShiftKeyMask 'caps))))
|