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.
1025 lines
40 KiB
Racket
1025 lines
40 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe/objc
|
|
ffi/unsafe
|
|
racket/class
|
|
racket/draw
|
|
racket/draw/private/gl-context
|
|
(except-in racket/draw/private/color
|
|
color% make-color)
|
|
(only-in racket/draw/private/bitmap quartz-bitmap%)
|
|
"pool.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"window.rkt"
|
|
"frame.rkt"
|
|
"dc.rkt"
|
|
"cg.rkt"
|
|
"queue.rkt"
|
|
"item.rkt"
|
|
"gc.rkt"
|
|
"image.rkt"
|
|
"panel.rkt"
|
|
"../common/backing-dc.rkt"
|
|
"../common/canvas-mixin.rkt"
|
|
"../common/event.rkt"
|
|
"../common/queue.rkt"
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/freeze.rkt")
|
|
|
|
(provide
|
|
(protect-out canvas%
|
|
canvas-panel%))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow
|
|
NSImageView NSTextFieldCell
|
|
NSOpenGLView NSOpenGLContext NSOpenGLPixelFormat)
|
|
|
|
(import-protocol NSComboBoxDelegate)
|
|
|
|
(define NSWindowAbove 1)
|
|
|
|
(define gc-via-gl? (version-10.11-or-later?))
|
|
|
|
;; Called when a canvas has no backing store ready
|
|
(define (clear-background wxb)
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(let ([bg (send wx get-canvas-background-for-clearing)])
|
|
(when bg
|
|
(let ([ctx (tell NSGraphicsContext currentContext)])
|
|
(tellv ctx saveGraphicsState)
|
|
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
|
|
[adj (lambda (v) (/ v 255.0))])
|
|
(CGContextSetRGBFillColor cg
|
|
(adj (color-red bg))
|
|
(adj (color-blue bg))
|
|
(adj (color-green bg))
|
|
1.0)
|
|
(CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize 32000 32000))))
|
|
(tellv ctx restoreGraphicsState)))))))
|
|
|
|
(define-objc-mixin (RacketViewMixin Superclass)
|
|
#:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder)
|
|
[wxb]
|
|
(-a #:async-apply (box (void))
|
|
_void (drawRect: [_NSRect r])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx drawing-requested)
|
|
(unless (send wx paint-or-queue-paint)
|
|
(clear-background wxb)
|
|
;; ensure that `nextEventMatchingMask:' returns
|
|
(post-dummy-event))))))
|
|
(-a _void (viewWillMoveToWindow: [_id w])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(queue-window-event wx (lambda () (send wx fix-dc)))))))
|
|
(-a _void (onHScroll: [_id scroller])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx (send wx do-scroll 'horizontal scroller)))))
|
|
(-a _void (onVScroll: [_id scroller])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx (send wx do-scroll 'vertical scroller))))))
|
|
|
|
(define-objc-class RacketView NSView
|
|
#:mixins (RacketViewMixin)
|
|
[wxb])
|
|
|
|
(define-objc-class RacketGLView NSOpenGLView
|
|
#:mixins (RacketViewMixin)
|
|
[wxb])
|
|
|
|
(define-objc-class RacketGCGLView NSOpenGLView
|
|
#:mixins (KeyMouseResponder)
|
|
[wxb])
|
|
|
|
(define-objc-class RacketGCWindow NSWindow
|
|
#:mixins (RacketEventspaceMethods)
|
|
[wxb])
|
|
|
|
(install-RacketGCWindow! RacketGCWindow)
|
|
|
|
(define-objc-class CornerlessFrameView NSView
|
|
[]
|
|
(-a #:async-apply (box (void))
|
|
_void (drawRect: [_NSRect r])
|
|
(let ([ctx (tell NSGraphicsContext currentContext)])
|
|
(tellv ctx saveGraphicsState)
|
|
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
|
|
[r (tell #:type _NSRect self bounds)])
|
|
(CGContextSetRGBFillColor cg 0 0 0 1.0)
|
|
(let* ([l (NSPoint-x (NSRect-origin r))]
|
|
[t (NSPoint-y (NSRect-origin r))]
|
|
[b (+ t (NSSize-height (NSRect-size r)))]
|
|
[r (+ l (NSSize-width (NSRect-size r)))])
|
|
(CGContextAddLines cg
|
|
(vector
|
|
(make-NSPoint r (+ t scroll-width))
|
|
(make-NSPoint r b)
|
|
(make-NSPoint l b)
|
|
(make-NSPoint l t)
|
|
(make-NSPoint (- r scroll-width) t))))
|
|
(CGContextStrokePath cg))
|
|
(tellv ctx restoreGraphicsState))))
|
|
|
|
(define-cocoa NSSetFocusRingStyle (_fun _int -> _void))
|
|
(define-cocoa NSRectFill (_fun _NSRect -> _void))
|
|
|
|
(define bezel-cell
|
|
(tell (tell NSTextFieldCell alloc) initTextCell: #:type _NSString ""))
|
|
(tellv bezel-cell setBezeled: #:type _BOOL #t)
|
|
|
|
(define-objc-class FocusView NSView
|
|
[on?]
|
|
(-a _void (setFocusState: [_BOOL is-on?])
|
|
(set! on? is-on?))
|
|
(-a #:async-apply (box (void))
|
|
_void (drawRect: [_NSRect r])
|
|
(let ([f (tell #:type _NSRect self frame)])
|
|
(tellv bezel-cell
|
|
drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2)
|
|
(let ([s (NSRect-size r)])
|
|
(make-NSSize (- (NSSize-width s) 4)
|
|
(- (NSSize-height s) 4))))
|
|
inView: self))
|
|
(when on?
|
|
(let ([ctx (tell NSGraphicsContext currentContext)])
|
|
(tellv ctx saveGraphicsState)
|
|
(NSSetFocusRingStyle 0)
|
|
(let ([r (tell #:type _NSRect self bounds)])
|
|
(NSRectFill (make-NSRect (make-NSPoint
|
|
(+ (NSPoint-x (NSRect-origin r)) 2)
|
|
(+ (NSPoint-y (NSRect-origin r)) 2))
|
|
(make-NSSize
|
|
(- (NSSize-width (NSRect-size r)) 4)
|
|
(- (NSSize-height (NSRect-size r)) 4)))))
|
|
(tellv ctx restoreGraphicsState)))))
|
|
|
|
(define-objc-class RacketComboBox NSComboBox
|
|
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
|
|
#:protocols (NSComboBoxDelegate)
|
|
[wxb]
|
|
(-a #:async-apply (box (void))
|
|
_void (drawRect: [_NSRect r])
|
|
(super-tell #:type _void drawRect: #:type _NSRect r)
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(unless (send wx paint-or-queue-paint)
|
|
(unless (send wx during-menu-click?)
|
|
(clear-background wxb)
|
|
;; ensure that `nextEventMatchingMask:' returns
|
|
(post-dummy-event))))))
|
|
(-a _void (comboBoxWillPopUp: [_id notification])
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx starting-combo))))
|
|
(-a _void (comboBoxWillDismiss: [_id notification])
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx ending-combo))))
|
|
(-a _void (viewWillMoveToWindow: [_id w])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(queue-window-event wx (lambda () (send wx fix-dc))))))))
|
|
|
|
(define NSOpenGLPFADoubleBuffer 5)
|
|
(define NSOpenGLPFAStereo 6)
|
|
(define NSOpenGLPFAColorSize 8)
|
|
(define NSOpenGLPFAAlphaSize 11)
|
|
(define NSOpenGLPFADepthSize 12)
|
|
(define NSOpenGLPFAStencilSize 13)
|
|
(define NSOpenGLPFAAccumSize 14)
|
|
(define NSOpenGLPFAOffScreen 53)
|
|
(define NSOpenGLPFASampleBuffers 55)
|
|
(define NSOpenGLPFASamples 56)
|
|
(define NSOpenGLPFAMultisample 59)
|
|
(define NSOpenGLPFAOpenGLProfile 99)
|
|
|
|
(define NSOpenGLProfileVersionLegacy #x1000)
|
|
(define NSOpenGLProfileVersion3_2Core #x3200)
|
|
|
|
(define (gl-config->pixel-format conf)
|
|
(let ([conf (or conf (new gl-config%))])
|
|
(tell (tell NSOpenGLPixelFormat alloc)
|
|
initWithAttributes: #:type (_list i _int)
|
|
(append
|
|
(if (version-10.7-or-later?)
|
|
(list NSOpenGLPFAOpenGLProfile
|
|
(if (send conf get-legacy?)
|
|
NSOpenGLProfileVersionLegacy
|
|
NSOpenGLProfileVersion3_2Core))
|
|
null)
|
|
(if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null)
|
|
(if (send conf get-stereo) (list NSOpenGLPFAStereo) null)
|
|
(list
|
|
NSOpenGLPFADepthSize (send conf get-depth-size)
|
|
NSOpenGLPFAStencilSize (send conf get-stencil-size)
|
|
NSOpenGLPFAAccumSize (send conf get-accum-size))
|
|
(let ([ms (send conf get-multisample-size)])
|
|
(if (zero? ms)
|
|
null
|
|
(list NSOpenGLPFAMultisample
|
|
NSOpenGLPFASampleBuffers 1
|
|
NSOpenGLPFASamples ms)))
|
|
(list 0)))))
|
|
|
|
|
|
(define-struct scroller (cocoa [range #:mutable] [page #:mutable]))
|
|
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
|
|
|
|
;; Customizing by version is a terrible idea, but I can't figure
|
|
;; out the right way to get the content area of an NSComboBox
|
|
(define combo-dx (if (version-10.7-or-later?)
|
|
2
|
|
2))
|
|
(define combo-dy (if (version-10.7-or-later?)
|
|
4
|
|
2))
|
|
(define combo-dw (if (version-10.7-or-later?)
|
|
24
|
|
22))
|
|
(define combo-dh (if (version-10.7-or-later?)
|
|
6
|
|
5))
|
|
;; extra height shaved off drawing; we can't just increase
|
|
;; combo-dh, because that just creates a request for an even taller
|
|
;; combo box whose primitive drawing overlaps the focus ring
|
|
(define combo-backing-dh 1)
|
|
|
|
(define canvas%
|
|
(canvas-mixin
|
|
(class (canvas-autoscroll-mixin window%)
|
|
(init parent
|
|
x y w h
|
|
style
|
|
[ignored-name #f]
|
|
[gl-config #f])
|
|
|
|
(inherit get-cocoa get-cocoa-window
|
|
get-eventspace
|
|
make-graphics-context
|
|
is-shown-to-root?
|
|
is-shown-to-before-root?
|
|
is-enabled-to-root?
|
|
is-window-enabled?
|
|
block-mouse-events
|
|
move get-x get-y
|
|
register-as-child
|
|
get-size get-position
|
|
set-focus
|
|
client-to-screen
|
|
is-auto-scroll? is-disabled-scroll?
|
|
get-virtual-width get-virtual-height
|
|
reset-auto-scroll
|
|
refresh-for-autoscroll
|
|
refresh-all-children
|
|
flush)
|
|
|
|
(define vscroll-ok? (and (or (memq 'vscroll style)
|
|
(memq 'auto-vscroll style)) ; 'auto variant falls through from panel
|
|
#t))
|
|
(define vscroll? vscroll-ok?)
|
|
(define hscroll-ok? (and (or (memq 'hscroll style)
|
|
(memq 'auto-hscroll style))
|
|
#t))
|
|
(define hscroll? hscroll-ok?)
|
|
|
|
(define wants-focus? (and (not (memq 'no-focus style))
|
|
(not (is-panel?))))
|
|
(define is-combo? (memq 'combo style))
|
|
(define has-control-border? (and (not is-combo?)
|
|
(memq 'control-border style)))
|
|
|
|
(define-values (x-margin y-margin x-sb-margin y-sb-margin)
|
|
(cond
|
|
[has-control-border? (values 3 3 3 3)]
|
|
[(memq 'border style) (values 1 1 0 0)]
|
|
[else (values 0 0 0 0)]))
|
|
|
|
(define canvas-style style)
|
|
|
|
(define/override (focus-is-on on?)
|
|
(when has-control-border?
|
|
(tellv cocoa setFocusState: #:type _BOOL on?)
|
|
(tellv cocoa setNeedsDisplay: #:type _BOOL #t))
|
|
(super focus-is-on on?))
|
|
|
|
;; The `queue-paint' and `paint-children' methods
|
|
;; are defined by `canvas-mixin' from ../common/canvas-mixin
|
|
(define/public (queue-paint) (void))
|
|
(define/public (request-canvas-flush-delay)
|
|
(unless is-gl?
|
|
(request-flush-delay (get-cocoa-window))))
|
|
(define/public (cancel-canvas-flush-delay req)
|
|
(unless is-gl?
|
|
(cancel-flush-delay req)))
|
|
(define/public (queue-canvas-refresh-event thunk)
|
|
(queue-window-refresh-event this thunk))
|
|
(define/public (skip-pre-paint?)
|
|
(cond
|
|
[is-gl?
|
|
;; We can't use GL on the window until it is ready,
|
|
;; as indicated by a request to draw.
|
|
(unless drawing-requested?
|
|
(sync/timeout 0.1 drawing-requested-sema))
|
|
(not drawing-requested?)]
|
|
[else #f]))
|
|
|
|
(define drawing-requested? #f)
|
|
(define drawing-requested-sema (make-semaphore))
|
|
(define/public (drawing-requested)
|
|
(unless drawing-requested?
|
|
(set! drawing-requested? #t)
|
|
(semaphore-post drawing-requested-sema)))
|
|
|
|
(define/public (paint-or-queue-paint)
|
|
(cond
|
|
[is-gl? (do-canvas-backing-flush #f)
|
|
(queue-paint)
|
|
#t]
|
|
[(do-canvas-backing-flush #f) #t]
|
|
[else (queue-paint)
|
|
#f]))
|
|
|
|
(define/public (do-canvas-backing-flush ctx)
|
|
(do-backing-flush this dc (tell NSGraphicsContext currentContext)
|
|
(if is-combo? combo-dx 0) (if is-combo? combo-dy 0)))
|
|
|
|
;; not used, because Cocoa canvas refreshes do not go through
|
|
;; the eventspace queue:
|
|
(define/public (schedule-periodic-backing-flush)
|
|
(void))
|
|
|
|
(define/public (begin-refresh-sequence)
|
|
(send dc suspend-flush))
|
|
(define/public (end-refresh-sequence)
|
|
(send dc resume-flush))
|
|
|
|
(define/public (get-flush-window)
|
|
(get-cocoa-window))
|
|
|
|
(define/private (refresh-one)
|
|
(when is-gl?
|
|
(tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
|
|
(queue-paint))
|
|
(define/override (refresh)
|
|
;; can be called from any thread, including the event-pump thread
|
|
(refresh-one)
|
|
(refresh-all-children))
|
|
|
|
(define/public (queue-backing-flush)
|
|
(unless is-gl?
|
|
;; called atomically (not expecting exceptions)
|
|
(tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)))
|
|
|
|
(define/override (get-cocoa-content) content-cocoa)
|
|
|
|
(define is-gl? (and (not is-combo?) (memq 'gl style)))
|
|
(define/public (can-gl?) is-gl?)
|
|
|
|
(define dc #f)
|
|
(define blits null)
|
|
(define reg-blits null)
|
|
|
|
(super-new
|
|
[parent parent]
|
|
[cocoa
|
|
(as-objc-allocation
|
|
(tell (tell (cond
|
|
[is-combo? NSView]
|
|
[has-control-border? FocusView]
|
|
[(memq 'border style) (if (memq 'vscroll style)
|
|
CornerlessFrameView
|
|
FrameView)]
|
|
[else NSView])
|
|
alloc)
|
|
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)])
|
|
|
|
(define cocoa (get-cocoa))
|
|
|
|
(define content-cocoa
|
|
(let ([r (make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize (max 0 (- w (if vscroll? scroll-width 0) (* 2 x-margin)))
|
|
(max 0 (- h (if hscroll? scroll-width 0) (* 2 y-margin)))))])
|
|
(as-objc-allocation
|
|
(if (or is-combo? (not (memq 'gl style)))
|
|
(tell (tell (if is-combo? RacketComboBox RacketView)
|
|
alloc)
|
|
initWithFrame: #:type _NSRect r)
|
|
(let* ([share-context (and gl-config (send gl-config get-share-context))]
|
|
[context-handle (and share-context (send share-context get-handle))]
|
|
[pf (gl-config->pixel-format gl-config)]
|
|
[new-context (and
|
|
context-handle
|
|
(tell (tell NSOpenGLContext alloc)
|
|
initWithFormat: pf
|
|
shareContext: context-handle))]
|
|
[gl-view (tell (tell RacketGLView alloc)
|
|
initWithFrame: #:type _NSRect r
|
|
pixelFormat: pf)])
|
|
(when (and gl-config (send gl-config get-hires-mode))
|
|
(tellv gl-view setWantsBestResolutionOpenGLSurface: #:type _uint 1))
|
|
(when new-context
|
|
(tellv gl-view setOpenGLContext: new-context)
|
|
;; We're supposed to sync via `setView:' but it fails,
|
|
;; perhaps because the view isn't yet visible:
|
|
;; (tellv new-context setView: gl-view)
|
|
(tellv new-context release))
|
|
(tellv pf release)
|
|
gl-view)))))
|
|
(tell #:type _void cocoa addSubview: content-cocoa)
|
|
(set-ivar! content-cocoa wxb (->wxb this))
|
|
|
|
(when is-combo?
|
|
(tellv content-cocoa setEditable: #:type _BOOL #f)
|
|
(tellv content-cocoa setDelegate: content-cocoa)
|
|
(install-control-font content-cocoa #f))
|
|
|
|
(set! dc (make-object dc% this (memq 'transparent canvas-style)))
|
|
|
|
(send dc start-backing-retained)
|
|
|
|
(queue-paint)
|
|
|
|
(define/public (is-panel?) #f)
|
|
|
|
(define/public (get-dc) dc)
|
|
|
|
(define/public (make-compatible-bitmap w h)
|
|
(make-window-bitmap w h (get-cocoa-window)))
|
|
|
|
(define/override (fix-dc [refresh? #t])
|
|
(when (pair? blits)
|
|
(atomically
|
|
(suspend-all-reg-blits)
|
|
(resume-all-reg-blits)))
|
|
(when (dc . is-a? . dc%)
|
|
(send dc reset-backing-retained)
|
|
(send dc set-auto-scroll
|
|
(if (is-auto-scroll?) (scroll-pos h-scroller) 0)
|
|
(if (is-auto-scroll?) (scroll-pos v-scroller) 0)))
|
|
(when refresh? (refresh-one)))
|
|
|
|
(define/override (get-client-size xb yb)
|
|
(super get-client-size xb yb)
|
|
(when is-combo?
|
|
(set-box! xb (max 0 (- (unbox xb) combo-dw)))
|
|
(set-box! yb (max 0 (- (unbox yb) combo-dh)))))
|
|
|
|
(define/override (maybe-register-as-child parent on?)
|
|
(register-as-child parent on?))
|
|
|
|
(define/public (on-paint) (void))
|
|
|
|
(define/override (set-size x y w h)
|
|
(do-set-size x y w h))
|
|
|
|
(define tr 0)
|
|
|
|
(define/override (show on?)
|
|
;; FIXME: what if we're in the middle of an on-paint?
|
|
(super show on?))
|
|
|
|
(define/override (hide-children)
|
|
(super hide-children)
|
|
(fix-dc #f)
|
|
(suspend-all-reg-blits))
|
|
|
|
(define/override (show-children)
|
|
(super show-children)
|
|
;; (fix-dc) ; inteferes with `paint-children''
|
|
(resume-all-reg-blits))
|
|
|
|
(define/override (fixup-locations-children)
|
|
;; in atomic mode
|
|
(when (is-shown-to-root?)
|
|
(suspend-all-reg-blits)
|
|
(resume-all-reg-blits)))
|
|
|
|
(define/private (do-set-size x y w h)
|
|
(when (pair? blits)
|
|
(atomically (suspend-all-reg-blits)))
|
|
(super set-size x y w h)
|
|
(when tr
|
|
(tellv content-cocoa removeTrackingRect: #:type _NSInteger tr)
|
|
(set! tr #f))
|
|
(let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin)
|
|
(- h (if hscroll? scroll-width 0) y-margin y-margin))]
|
|
[pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))])
|
|
(tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz))
|
|
(set! tr (tell #:type _NSInteger
|
|
content-cocoa
|
|
addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz)
|
|
owner: content-cocoa
|
|
userData: #f
|
|
assumeInside: #:type _BOOL #f)))
|
|
(when v-scroller
|
|
(tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect
|
|
(make-NSRect
|
|
(make-NSPoint (- w scroll-width x-sb-margin)
|
|
(+ (if hscroll?
|
|
scroll-width
|
|
0)
|
|
y-sb-margin))
|
|
(make-NSSize scroll-width
|
|
(max 0 (- h (if hscroll? scroll-width 0)
|
|
x-sb-margin x-sb-margin))))))
|
|
(when h-scroller
|
|
(tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect
|
|
(make-NSRect
|
|
(make-NSPoint x-sb-margin y-sb-margin)
|
|
(make-NSSize (max 0 (- w (if vscroll? scroll-width 0)
|
|
x-sb-margin x-sb-margin))
|
|
scroll-width))))
|
|
(when (and (pair? blits)
|
|
(is-shown-to-root?))
|
|
(atomically (resume-all-reg-blits)))
|
|
(fix-dc)
|
|
(when (and (is-auto-scroll?)
|
|
(not (is-panel?)))
|
|
(reset-auto-scroll))
|
|
(on-size))
|
|
|
|
;; this `on-size' method is for `editor-canvas%', only:
|
|
(define/public (on-size) (void))
|
|
|
|
(define/public (show-scrollbars h? v?)
|
|
(let ([h? (and h? hscroll-ok?)]
|
|
[v? (and v? vscroll-ok?)])
|
|
(unless (and (eq? h? hscroll?)
|
|
(eq? v? vscroll?))
|
|
(cond
|
|
[(and h? (not hscroll?))
|
|
(tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))]
|
|
[(and hscroll? (not h?))
|
|
(tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)])
|
|
(set! hscroll? h?)
|
|
(cond
|
|
[(and v? (not vscroll?))
|
|
(tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))]
|
|
[(and vscroll? (not v?))
|
|
(tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)])
|
|
(set! vscroll? v?)
|
|
(let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)])
|
|
(get-position x y)
|
|
(get-size w h)
|
|
(do-set-size (unbox x) (unbox y) (unbox w) (unbox h))))))
|
|
|
|
(define/override (do-set-scrollbars h-step v-step
|
|
h-len v-len
|
|
h-page v-page
|
|
h-pos v-pos)
|
|
(scroll-range h-scroller h-len)
|
|
(scroll-page h-scroller h-page)
|
|
(unless (= h-pos -1)
|
|
(scroll-pos h-scroller h-pos))
|
|
(when h-scroller
|
|
(tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
|
|
(scroll-range v-scroller v-len)
|
|
(scroll-page v-scroller v-page)
|
|
(unless (= v-pos -1)
|
|
(scroll-pos v-scroller v-pos))
|
|
(when v-scroller
|
|
(tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
|
|
|
|
(define/override (reset-dc-for-autoscroll)
|
|
(fix-dc))
|
|
|
|
(define/private (update which scroll- v)
|
|
(if (eq? which 'vertical)
|
|
(scroll- v-scroller v)
|
|
(scroll- h-scroller v)))
|
|
|
|
(define/public (set-scroll-page which v)
|
|
(update which scroll-page v))
|
|
(define/public (set-scroll-range which v)
|
|
(update which scroll-range v))
|
|
(define/public (set-scroll-pos which v)
|
|
(update which scroll-pos v))
|
|
|
|
(define/private (guard-scroll skip-guard? which get-v)
|
|
(if skip-guard?
|
|
(get-v)
|
|
(if (or (if (eq? which 'vertical)
|
|
(not vscroll-ok?)
|
|
(not hscroll-ok?))
|
|
(is-disabled-scroll?)
|
|
(is-auto-scroll?))
|
|
0
|
|
(get-v))))
|
|
|
|
(define/public (get-scroll-page which [skip-guard? #f])
|
|
(guard-scroll skip-guard?
|
|
which
|
|
(lambda ()
|
|
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))))
|
|
(define/public (get-scroll-range which [skip-guard? #f])
|
|
(guard-scroll skip-guard?
|
|
which
|
|
(lambda ()
|
|
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))))
|
|
(define/public (get-scroll-pos which [skip-guard? #f])
|
|
(guard-scroll skip-guard?
|
|
which
|
|
(lambda ()
|
|
(scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))))
|
|
|
|
(define v-scroller
|
|
(and vscroll-ok?
|
|
(make-scroller
|
|
(as-objc-allocation
|
|
(tell (tell NSScroller alloc) initWithFrame:
|
|
#:type _NSRect (make-NSRect
|
|
(make-NSPoint (- w scroll-width x-sb-margin)
|
|
(+ (if hscroll?
|
|
scroll-width
|
|
0)
|
|
y-sb-margin))
|
|
(make-NSSize scroll-width
|
|
(max (- h (if hscroll? scroll-width 0)
|
|
y-sb-margin y-sb-margin)
|
|
(+ scroll-width 10))))))
|
|
1
|
|
1)))
|
|
(define h-scroller
|
|
(and hscroll-ok?
|
|
(make-scroller
|
|
(as-objc-allocation
|
|
(tell (tell NSScroller alloc) initWithFrame:
|
|
#:type _NSRect (make-NSRect
|
|
(make-NSPoint x-sb-margin y-sb-margin)
|
|
(make-NSSize (max (- w (if vscroll? scroll-width 0)
|
|
x-sb-margin x-sb-margin)
|
|
(+ scroll-width 10))
|
|
scroll-width))))
|
|
1
|
|
1)))
|
|
|
|
(when v-scroller
|
|
(tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))
|
|
(tellv (scroller-cocoa v-scroller) setTarget: content-cocoa)
|
|
(tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:)))
|
|
(when h-scroller
|
|
(tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))
|
|
(tellv (scroller-cocoa h-scroller) setTarget: content-cocoa)
|
|
(tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:)))
|
|
|
|
(define scroll-pos
|
|
(case-lambda
|
|
[(scroller val)
|
|
(when scroller
|
|
(tellv (scroller-cocoa scroller) setFloatValue:
|
|
#:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller))))
|
|
0.0)))]
|
|
[(scroller)
|
|
(if scroller
|
|
(->long (round (* (tell #:type _float (scroller-cocoa scroller) floatValue)
|
|
(scroller-range scroller))))
|
|
0)]))
|
|
|
|
(define scroll-range
|
|
(case-lambda
|
|
[(scroller val)
|
|
(when scroller
|
|
(let ([pos (scroll-pos scroller)]
|
|
[page (scroll-page scroller)])
|
|
(set-scroller-range! scroller val)
|
|
(tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val))
|
|
(scroll-pos scroller pos)
|
|
(scroll-page scroller page)))]
|
|
[(scroller)
|
|
(if scroller
|
|
(scroller-range scroller)
|
|
1)]))
|
|
|
|
(define scroll-page
|
|
(case-lambda
|
|
[(scroller val)
|
|
(when scroller
|
|
(set-scroller-page! scroller val)
|
|
(let ([proportion
|
|
(max (min 1.0 (/ val
|
|
(+ val (exact->inexact (scroller-range scroller)))))
|
|
0.0)])
|
|
(if old-cocoa?
|
|
(tellv (scroller-cocoa scroller)
|
|
setFloatValue: #:type _float (tell #:type _float (scroller-cocoa scroller)
|
|
floatValue)
|
|
knobProportion: #:type _CGFloat proportion)
|
|
(tellv (scroller-cocoa scroller) setKnobProportion:
|
|
#:type _CGFloat proportion))))]
|
|
[(scroller)
|
|
(if scroller
|
|
(scroller-page scroller)
|
|
1)]))
|
|
|
|
(define/override (enable-window on?)
|
|
;; in atomic mode
|
|
(let ([on? (and on? (is-window-enabled?))])
|
|
(let ([w (tell content-cocoa window)])
|
|
(when (ptr-equal? content-cocoa (tell w firstResponder))
|
|
(tellv w makeFirstResponder: #f)))
|
|
(block-mouse-events (not on?))
|
|
(when is-combo?
|
|
(tellv content-cocoa setEnabled: #:type _BOOL on?))))
|
|
|
|
(define/public (clear-combo-items)
|
|
(tellv content-cocoa removeAllItems))
|
|
(define/public (append-combo-item str)
|
|
(tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
|
|
#t)
|
|
(define/public (on-combo-select i) (void))
|
|
(define/public (popup-combo)
|
|
;; Pending refresh events interfere with combo popups
|
|
;; for some reason, so flush them:
|
|
(yield-refresh)
|
|
(flush)
|
|
;; Beware that the `popUp:' method is undocumented:
|
|
(atomically
|
|
(tellv (tell content-cocoa cell) popUp: #f)))
|
|
|
|
(define clear-bg? (and (not (memq 'transparent canvas-style))
|
|
(not (memq 'no-autoclear canvas-style))))
|
|
(define bg-col (make-object color% "white"))
|
|
(define/public (get-canvas-background) (if (memq 'transparent canvas-style)
|
|
#f
|
|
bg-col))
|
|
(define/public (set-canvas-background col) (set! bg-col col))
|
|
(define/public (get-canvas-background-for-backing) (and clear-bg? bg-col))
|
|
(define/public (get-canvas-background-for-clearing)
|
|
(and clear-bg?
|
|
bg-col))
|
|
|
|
(define/public (reject-partial-update r)
|
|
;; Called in the event-pump thread.
|
|
;; A transparent canvas cannot handle a partial update.
|
|
(and (or
|
|
;; Multiple clipping rects?
|
|
(let ([i (malloc _NSInteger)]
|
|
[r (malloc 'atomic _pointer)])
|
|
(tellv content-cocoa getRectsBeingDrawn: #:type _pointer r
|
|
count: #:type _pointer i)
|
|
((ptr-ref i _NSInteger) . > . 1))
|
|
;; Single clipping not whole area?
|
|
(let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))]
|
|
[s2 (NSRect-size r)])
|
|
(or ((NSSize-width s2) . < . (NSSize-width s1))
|
|
((NSSize-height s2) . < . (NSSize-height s1)))))
|
|
(begin
|
|
(queue-window-event this (lambda () (refresh-one)))
|
|
#t)))
|
|
|
|
(define/public (do-scroll direction scroller)
|
|
;; Called from the Cocoa handler thread
|
|
(let ([part (tell #:type _int scroller hitPart)])
|
|
(queue-window-event
|
|
this
|
|
(lambda ()
|
|
(let ([kind
|
|
(cond
|
|
[(= part NSScrollerDecrementPage)
|
|
(set-scroll-pos direction (- (get-scroll-pos direction #t)
|
|
(get-scroll-page direction #t)))
|
|
'page-up]
|
|
[(= part NSScrollerIncrementPage)
|
|
(set-scroll-pos direction (+ (get-scroll-pos direction #t)
|
|
(get-scroll-page direction #t)))
|
|
'page-down]
|
|
[(= part NSScrollerDecrementLine)
|
|
(set-scroll-pos direction (- (get-scroll-pos direction #t) 1))
|
|
'line-up]
|
|
[(= part NSScrollerIncrementLine)
|
|
(set-scroll-pos direction (+ (get-scroll-pos direction #t) 1))
|
|
'line-down]
|
|
[(= part NSScrollerKnob)
|
|
'thumb]
|
|
[else #f])])
|
|
(when kind
|
|
(if (is-auto-scroll?)
|
|
(refresh-for-autoscroll)
|
|
(on-scroll (new scroll-event%
|
|
[event-type kind]
|
|
[direction direction]
|
|
[position (get-scroll-pos direction)]))))))))
|
|
(constrained-reply (get-eventspace)
|
|
(lambda ()
|
|
(let loop () (pre-event-sync #t) (when (yield/no-sync) (loop))))
|
|
(void)))
|
|
(define/public (on-scroll e) (void))
|
|
|
|
(define/override (definitely-wants-event? e)
|
|
;; Called in Cocoa event-handling mode
|
|
(when (and wants-focus?
|
|
(e . is-a? . mouse-event%)
|
|
(send e button-down? 'left))
|
|
(set-focus))
|
|
(and (not (is-panel?))
|
|
(or (not is-combo?)
|
|
(e . is-a? . key-event%)
|
|
(not (send e button-down? 'left))
|
|
(not (on-menu-click? e)))))
|
|
|
|
(define/override (can-accept-focus?)
|
|
wants-focus?)
|
|
(define/override (can-be-responder?)
|
|
(and wants-focus? (is-enabled-to-root?)))
|
|
|
|
(define/private (on-menu-click? e)
|
|
;; Called in Cocoa event-handling mode
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(get-client-size xb yb)
|
|
((send e get-x) . > . (unbox xb))))
|
|
|
|
(define/public (on-popup) (void))
|
|
|
|
(define/public (starting-combo)
|
|
(set! in-menu-click? #t)
|
|
(tellv content-cocoa setStringValue: #:type _NSString current-text)
|
|
(constrained-reply (get-eventspace)
|
|
(lambda () (on-popup))
|
|
(void)))
|
|
|
|
(define/public (ending-combo)
|
|
(set! in-menu-click? #f)
|
|
(let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)])
|
|
(when (pos . > . -1)
|
|
(queue-window-event this (lambda () (on-combo-select pos)))))
|
|
(refresh-one))
|
|
|
|
(define current-text "")
|
|
(define/public (set-combo-text t)
|
|
(set! current-text t))
|
|
|
|
(define in-menu-click? #f)
|
|
|
|
(define/public (during-menu-click?)
|
|
;; Called in Cocoa event-handling mode
|
|
in-menu-click?)
|
|
|
|
(define/public (scroll x y)
|
|
(when (is-auto-scroll?)
|
|
(when (x . >= . 0) (scroll-pos h-scroller (floor (* x (scroll-range h-scroller)))))
|
|
(when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller)))))
|
|
(refresh-for-autoscroll)))
|
|
|
|
(define/override (get-virtual-h-pos)
|
|
(scroll-pos h-scroller))
|
|
|
|
(define/override (get-virtual-v-pos)
|
|
(scroll-pos v-scroller))
|
|
|
|
(define/public (set-resize-corner on?)
|
|
(void))
|
|
|
|
(define/public (get-backing-size xb yb)
|
|
(get-client-size xb yb)
|
|
(when is-combo?
|
|
(set-box! yb (max 0 (- (unbox yb) combo-backing-dh)))))
|
|
|
|
(define/public (get-scaled-client-size)
|
|
(define bsr (tell #:type _NSRect (get-cocoa-content) bounds))
|
|
(define csr
|
|
(tell #:type _NSRect (get-cocoa-content)
|
|
convertRectToBacking:
|
|
#:type _NSRect bsr))
|
|
(define cs (NSRect-size csr))
|
|
(define cw (->long (NSSize-width cs)))
|
|
(define ch (->long (NSSize-height cs)))
|
|
(values cw ch))
|
|
|
|
(define/public (get-gl-client-size)
|
|
(if (or (not is-gl?)
|
|
(tell #:type _BOOL content-cocoa wantsBestResolutionOpenGLSurface))
|
|
(get-scaled-client-size)
|
|
(let ([x (box 0)]
|
|
[y (box 0)])
|
|
(get-client-size x y)
|
|
(values (unbox x) (unbox y)))))
|
|
|
|
(define/override (get-cursor-width-delta)
|
|
0)
|
|
|
|
(define/public (is-flipped?)
|
|
(tell #:type _BOOL (get-cocoa-content) isFlipped))
|
|
|
|
(define/private (suspend-all-reg-blits)
|
|
(let ([cocoa-win (get-cocoa-window)])
|
|
(for ([r (in-list reg-blits)])
|
|
(tellv cocoa-win removeChildWindow: (car r))
|
|
(release (car r))
|
|
(scheme_remove_gc_callback (cdr r))))
|
|
(set! reg-blits null))
|
|
|
|
(define/public (resume-all-reg-blits)
|
|
(unless (pair? reg-blits)
|
|
(when (pair? blits)
|
|
(set! reg-blits
|
|
(for/list ([b (in-list blits)])
|
|
(let-values ([(x y w h s img) (apply values b)])
|
|
(register-one-blit x y w h s img)))))))
|
|
|
|
(define/private (register-one-blit x y w h s img)
|
|
(let ([xb (box x)]
|
|
[yb (box y)])
|
|
(client-to-screen xb yb #f)
|
|
(let* ([cocoa-win (get-cocoa-window)])
|
|
(atomically
|
|
(let ([win (as-objc-allocation
|
|
(tell (tell (if gc-via-gl? RacketGCWindow NSWindow) alloc)
|
|
initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb)
|
|
(- (unbox yb)
|
|
h))
|
|
(make-NSSize w h))
|
|
styleMask: #:type _int NSBorderlessWindowMask
|
|
backing: #:type _int NSBackingStoreBuffered
|
|
defer: #:type _BOOL NO))]
|
|
[glv (and gc-via-gl?
|
|
(let ([pf (gl-config->pixel-format #f)])
|
|
(begin0
|
|
(tell (tell RacketGCGLView alloc)
|
|
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize w h))
|
|
pixelFormat: pf)
|
|
(tellv pf release))))]
|
|
[iv (and (not gc-via-gl?)
|
|
(tell (tell NSImageView alloc) init))])
|
|
(cond
|
|
[gc-via-gl?
|
|
(tellv win setAcceptsMouseMovedEvents: #:type _BOOL #t)
|
|
(set-ivar! win wxb (->wxb this))
|
|
(set-ivar! glv wxb (->wxb this))
|
|
(tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1)
|
|
(tellv (tell win contentView) addSubview: glv)]
|
|
[else
|
|
(tellv win setAlphaValue: #:type _CGFloat 0.0)
|
|
(tellv iv setImage: img)
|
|
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize w h)))
|
|
(tellv (tell win contentView) addSubview: iv)
|
|
(tellv iv release)])
|
|
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
|
|
(when gc-via-gl?
|
|
(tellv win orderWindow: #:type _int NSWindowAbove
|
|
relativeTo: #:type _NSInteger (tell #:type _NSInteger cocoa-win windowNumber)))
|
|
(let ([r (scheme_add_gc_callback
|
|
(if gc-via-gl?
|
|
(make-gl-install win glv w h img s)
|
|
(make-gc-action-desc win (selector setAlphaValue:) 1.0))
|
|
(if gc-via-gl?
|
|
(make-gl-uninstall win glv w h)
|
|
(make-gc-action-desc win (selector setAlphaValue:) 0.0)))])
|
|
(when gc-via-gl?
|
|
(tellv glv release))
|
|
(cons win r)))))))
|
|
|
|
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
|
(let ([on (fix-bitmap-size on w h on-x on-y)]
|
|
[s (send on get-backing-scale)])
|
|
(let ([img (if gc-via-gl?
|
|
(let* ([xw (inexact->exact (ceiling (* s w)))]
|
|
[xh (inexact->exact (ceiling (* s h)))]
|
|
[rgba (make-bytes (* xw xh 4))])
|
|
(send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t)
|
|
rgba)
|
|
(bitmap->image on))])
|
|
(atomically
|
|
(set! blits (cons (list x y w h s img) blits))
|
|
(when (is-shown-to-root?)
|
|
(set! reg-blits (cons (register-one-blit x y w h s img) reg-blits)))))))
|
|
|
|
(define/public (unregister-collecting-blits)
|
|
(atomically
|
|
(suspend-all-reg-blits)
|
|
(set! blits null))))))
|
|
|
|
(define canvas-panel%
|
|
(class (panel-mixin canvas%)
|
|
(inherit get-virtual-h-pos
|
|
get-virtual-v-pos
|
|
get-cocoa-content)
|
|
|
|
(define/override (is-panel?) #t)
|
|
|
|
(define/override (reset-dc-for-autoscroll)
|
|
(let* ([content-cocoa (get-cocoa-content)])
|
|
(tellv content-cocoa setBoundsOrigin: #:type _NSPoint
|
|
(make-NSPoint (get-virtual-h-pos)
|
|
(- (get-virtual-v-pos)))))
|
|
(super reset-dc-for-autoscroll))
|
|
|
|
(super-new)))
|