711 lines
26 KiB
Racket
711 lines
26 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe/objc
|
|
ffi/unsafe
|
|
racket/class
|
|
racket/draw
|
|
racket/draw/color
|
|
"pool.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"window.rkt"
|
|
"dc.rkt"
|
|
"queue.rkt"
|
|
"item.rkt"
|
|
"../common/backing-dc.rkt"
|
|
"../common/event.rkt"
|
|
"../common/queue.rkt"
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/freeze.rkt")
|
|
|
|
(provide canvas%)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSView NSGraphicsContext NSScroller NSComboBox)
|
|
|
|
(import-protocol NSComboBoxDelegate)
|
|
|
|
;; 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-class MyView NSView
|
|
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
|
|
[wxb]
|
|
(-a _void (drawRect: [_NSRect r])
|
|
(when wxb
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(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 FrameView NSView
|
|
[]
|
|
(-a _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)
|
|
(CGContextAddRect cg r)
|
|
(CGContextStrokePath cg))
|
|
(tellv ctx restoreGraphicsState))))
|
|
|
|
(define-objc-class CornerlessFrameView NSView
|
|
[]
|
|
(-a _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-objc-class FocusView NSView
|
|
[on?]
|
|
(-a _void (setFocusState: [_BOOL is-on?])
|
|
(set! on? is-on?))
|
|
(-a _void (drawRect: [_NSRect r])
|
|
(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 MyComboBox NSComboBox
|
|
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
|
|
#:protocols (NSComboBoxDelegate)
|
|
[wxb]
|
|
(-a _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-struct scroller (cocoa [range #:mutable] [page #:mutable]))
|
|
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
|
|
|
|
(define canvas%
|
|
(class 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?
|
|
move get-x get-y
|
|
on-size
|
|
register-as-child
|
|
get-size get-position
|
|
set-focus)
|
|
|
|
(define vscroll-ok? (and (memq 'vscroll style) #t))
|
|
(define vscroll? vscroll-ok?)
|
|
(define hscroll-ok? (and (memq 'hscroll style) #t))
|
|
(define hscroll? hscroll-ok?)
|
|
|
|
(define auto-scroll? #f)
|
|
(define virtual-height #f)
|
|
(define virtual-width #f)
|
|
|
|
(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?))
|
|
|
|
;; Avoid multiple queued paints, and also allow cancel
|
|
;; of queued paint:
|
|
(define paint-queued #f) ; #f or (box #t)
|
|
|
|
(define/public (queue-paint)
|
|
;; can be called from any thread, including the event-pump thread
|
|
(unless paint-queued
|
|
(let ([b (box #t)])
|
|
(set! paint-queued b)
|
|
(let ([req (request-flush-delay (get-cocoa-window))])
|
|
(queue-window-refresh-event
|
|
this
|
|
(lambda () (do-on-paint req b)))))))
|
|
|
|
(define/private (do-on-paint req b)
|
|
;; only called in the handler thread
|
|
(when (or (not b) (unbox b))
|
|
(let ([pq paint-queued])
|
|
(when pq (set-box! pq #f)))
|
|
(set! paint-queued #f)
|
|
(when (or (not b) (is-shown-to-root?))
|
|
(send dc ensure-ready)
|
|
(send dc erase) ; start with a clean slate
|
|
(let ([bg (get-canvas-background)])
|
|
(when bg
|
|
(let ([old-bg (send dc get-background)])
|
|
(send dc set-background bg)
|
|
(send dc clear)
|
|
(send dc set-background old-bg))))
|
|
(send dc suspend-flush)
|
|
(on-paint)
|
|
(send dc resume-flush)
|
|
(queue-backing-flush)))
|
|
(when req
|
|
(cancel-flush-delay req)))
|
|
|
|
(define/public (paint-or-queue-paint)
|
|
(or (do-backing-flush this dc (tell NSGraphicsContext currentContext)
|
|
(if is-combo? 2 0) (if is-combo? 2 0))
|
|
(begin
|
|
(queue-paint)
|
|
#f)))
|
|
|
|
(define/override (paint-children)
|
|
(when (or paint-queued
|
|
(not (send dc can-backing-flush?)))
|
|
(do-on-paint #f #f)))
|
|
|
|
(define/public (begin-refresh-sequence)
|
|
(send dc suspend-flush))
|
|
(define/public (end-refresh-sequence)
|
|
(send dc resume-flush))
|
|
|
|
(define/override (refresh)
|
|
;; can be called from any thread, including the event-pump thread
|
|
(queue-paint))
|
|
|
|
(define/public (queue-backing-flush)
|
|
;; called atomically (not expecting exceptions)
|
|
(tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
|
|
|
|
(define/override (get-cocoa-content) content-cocoa)
|
|
|
|
(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 (* 2 x-margin)))
|
|
(max 0 (- h (* 2 y-margin)))))])
|
|
(as-objc-allocation
|
|
(tell (tell (if is-combo? MyComboBox MyView) alloc)
|
|
initWithFrame: #:type _NSRect r))))
|
|
(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))
|
|
|
|
(define dc (make-object dc% this))
|
|
|
|
(send dc start-backing-retained)
|
|
|
|
(queue-paint)
|
|
|
|
(define/public (get-dc) dc)
|
|
|
|
(define/override (fix-dc [refresh? #t])
|
|
(when (dc . is-a? . dc%)
|
|
(send dc reset-backing-retained)
|
|
(send dc set-auto-scroll
|
|
(if auto-scroll? (scroll-pos h-scroller) 0)
|
|
(if auto-scroll? (scroll-pos v-scroller) 0)))
|
|
(when refresh? (refresh)))
|
|
|
|
(define/override (get-client-size xb yb)
|
|
(super get-client-size xb yb)
|
|
(when is-combo?
|
|
(set-box! yb (max 0 (- (unbox yb) 5)))))
|
|
|
|
(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?)
|
|
(fix-dc))
|
|
|
|
(define/private (do-set-size x y w h)
|
|
(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))))
|
|
(fix-dc)
|
|
(when auto-scroll?
|
|
(reset-auto-scroll 0 0))
|
|
(on-size 0 0))
|
|
|
|
(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/public (set-scrollbars h-step v-step
|
|
h-len v-len
|
|
h-page v-page
|
|
h-pos v-pos
|
|
auto?)
|
|
(cond
|
|
[auto?
|
|
(set! auto-scroll? #t)
|
|
(set! virtual-width (and (positive? h-len) h-len))
|
|
(set! virtual-height (and (positive? v-len) v-len))
|
|
(reset-auto-scroll h-pos v-pos)
|
|
(refresh-for-autoscroll)]
|
|
[else
|
|
(let ([a? auto-scroll?])
|
|
(set! auto-scroll? #f)
|
|
(when a? (fix-dc))) ; disable scroll offsets
|
|
(scroll-range h-scroller h-len)
|
|
(scroll-page h-scroller h-page)
|
|
(scroll-pos h-scroller h-pos)
|
|
(when h-scroller
|
|
(tell (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)
|
|
(scroll-pos v-scroller v-pos)
|
|
(when v-scroller
|
|
(tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))
|
|
(set! virtual-width #f)
|
|
(set! virtual-height #f)]))
|
|
|
|
(define/private (reset-auto-scroll h-pos v-pos)
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(get-client-size xb yb)
|
|
(let ([cw (unbox xb)]
|
|
[ch (unbox yb)])
|
|
(let ([h-len (if virtual-width
|
|
(max 0 (- virtual-width cw))
|
|
0)]
|
|
[v-len (if virtual-height
|
|
(max 0 (- virtual-height ch))
|
|
0)]
|
|
[h-page (if virtual-width
|
|
cw
|
|
0)]
|
|
[v-page (if virtual-height
|
|
ch
|
|
0)])
|
|
(scroll-range h-scroller h-len)
|
|
(scroll-page h-scroller h-page)
|
|
(scroll-pos h-scroller h-pos)
|
|
(when h-scroller
|
|
(tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len)))
|
|
(scroll-range v-scroller v-len)
|
|
(scroll-page v-scroller v-page)
|
|
(scroll-pos v-scroller v-pos)
|
|
(when v-scroller
|
|
(tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len)))))))
|
|
|
|
(define/private (refresh-for-autoscroll)
|
|
(fix-dc)
|
|
(refresh))
|
|
|
|
(define (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/public (get-scroll-page which)
|
|
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))
|
|
(define/public (get-scroll-range which)
|
|
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))
|
|
(define/public (get-scroll-pos which)
|
|
(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 _double (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)
|
|
(tellv (scroller-cocoa scroller) setKnobProportion:
|
|
#:type _CGFloat (max (min 1.0 (/ val
|
|
(+ val (exact->inexact (scroller-range scroller)))))
|
|
0.0)))]
|
|
[(scroller)
|
|
(if scroller
|
|
(scroller-page scroller)
|
|
1)]))
|
|
|
|
(define/public (append-combo-item str)
|
|
(tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
|
|
#t)
|
|
(define/public (on-combo-select i) (void))
|
|
|
|
(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-clearing)
|
|
(and (not (memq 'transparent canvas-style))
|
|
(not (memq 'no-autoclear canvas-style))
|
|
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)))
|
|
#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)
|
|
(get-scroll-page direction)))
|
|
'page-up]
|
|
[(= part NSScrollerIncrementPage)
|
|
(set-scroll-pos direction (+ (get-scroll-pos direction)
|
|
(get-scroll-page direction)))
|
|
'page-down]
|
|
[(= part NSScrollerDecrementLine)
|
|
(set-scroll-pos direction (- (get-scroll-pos direction) 1))
|
|
'line-up]
|
|
[(= part NSScrollerIncrementLine)
|
|
(set-scroll-pos direction (+ (get-scroll-pos direction) 1))
|
|
'line-down]
|
|
[(= part NSScrollerKnob)
|
|
'thumb]
|
|
[else #f])])
|
|
(when kind
|
|
(if 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) (loop))))
|
|
(void)))
|
|
(define/public (on-scroll e) (void))
|
|
|
|
(define/override (definitely-wants-event? e)
|
|
;; Called in Cocoa event-handling mode
|
|
(when (and (e . is-a? . mouse-event%)
|
|
(send e button-down? 'left))
|
|
(set-focus))
|
|
(or (not is-combo?)
|
|
(e . is-a? . key-event%)
|
|
(not (send e button-down? 'left))
|
|
(not (on-menu-click? e))))
|
|
|
|
(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) 22))))
|
|
|
|
(define/public (starting-combo)
|
|
(set! in-menu-click? #t)
|
|
(tellv content-cocoa setStringValue: #:type _NSString current-text))
|
|
|
|
(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))
|
|
|
|
(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?)
|
|
|
|
(def/public-unimplemented set-background-to-gray)
|
|
|
|
(define/public (scroll x y)
|
|
(when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller))))
|
|
(when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller))))
|
|
(when auto-scroll? (refresh-for-autoscroll)))
|
|
|
|
(def/public-unimplemented warp-pointer)
|
|
|
|
(define/public (view-start xb yb)
|
|
(if auto-scroll?
|
|
(begin
|
|
(set-box! xb (if virtual-width
|
|
(scroll-pos h-scroller)
|
|
0))
|
|
(set-box! yb (if virtual-height
|
|
(scroll-pos v-scroller)
|
|
0)))
|
|
(begin
|
|
(set-box! xb 0)
|
|
(set-box! yb 0))))
|
|
|
|
(define/public (set-resize-corner on?)
|
|
(void))
|
|
|
|
(define/public (get-backing-size xb yb)
|
|
(get-client-size xb yb)
|
|
(when is-combo?
|
|
(set-box! xb (- (unbox xb) 22))))
|
|
|
|
(define/override (get-cursor-width-delta)
|
|
(if is-combo? 22 0))
|
|
|
|
(define/public (is-flipped?)
|
|
(tell #:type _BOOL (get-cocoa-content) isFlipped))
|
|
|
|
(define/public (get-virtual-size xb yb)
|
|
(get-client-size xb yb)
|
|
(when virtual-width (set-box! xb virtual-width))
|
|
(when virtual-height (set-box! yb virtual-height)))))
|