797 lines
31 KiB
Racket
797 lines
31 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"
|
|
"cg.rkt"
|
|
"queue.rkt"
|
|
"item.rkt"
|
|
"gc.rkt"
|
|
"image.rkt"
|
|
"../common/backing-dc.rkt"
|
|
"../common/canvas-mixin.rkt"
|
|
"../common/event.rkt"
|
|
"../common/queue.rkt"
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/freeze.rkt")
|
|
|
|
(provide canvas%)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow
|
|
NSImageView NSTextFieldCell)
|
|
|
|
(import-protocol NSComboBoxDelegate)
|
|
|
|
(define NSWindowAbove 1)
|
|
|
|
(define o (current-error-port))
|
|
|
|
;; 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 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 _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 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%
|
|
(canvas-mixin
|
|
(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
|
|
client-to-screen)
|
|
|
|
(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 wants-focus? (not (memq 'no-focus style)))
|
|
(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)
|
|
(request-flush-delay (get-cocoa-window)))
|
|
(define/public (cancel-canvas-flush-delay req)
|
|
(cancel-flush-delay req))
|
|
(define/public (queue-canvas-refresh-event thunk)
|
|
(queue-window-refresh-event this thunk))
|
|
|
|
(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/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/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/public (make-compatible-bitmap w h)
|
|
(make-object quartz-bitmap% w h))
|
|
|
|
(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/override (hide-children)
|
|
(super hide-children)
|
|
(suspend-all-reg-blits))
|
|
|
|
(define/override (show-children)
|
|
(super show-children)
|
|
(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 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 wants-focus?
|
|
(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/override (gets-focus?)
|
|
wants-focus?)
|
|
(define/override (can-be-responder?)
|
|
wants-focus?)
|
|
|
|
(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)))
|
|
|
|
(define blits null)
|
|
(define reg-blits null)
|
|
|
|
(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 img) (apply values b)])
|
|
(register-one-blit x y w h img)))))))
|
|
|
|
(define/private (register-one-blit x y w h 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 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))]
|
|
[iv (tell (tell NSImageView alloc) init)])
|
|
(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 win setAlphaValue: #:type _CGFloat 0.0)
|
|
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
|
|
(tellv iv release)
|
|
(let ([r (scheme_add_gc_callback
|
|
(make-gc-action-desc win (selector setAlphaValue:) 1.0)
|
|
(make-gc-action-desc win (selector setAlphaValue:) 0.0))])
|
|
(cons win r)))))))
|
|
|
|
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
|
(let ([on (if (and (zero? on-x)
|
|
(zero? on-y)
|
|
(= (send on get-width) w)
|
|
(= (send on get-height) h))
|
|
on
|
|
(let ([bm (make-object bitmap% w h)])
|
|
(let ([dc (make-object bitmap-dc% on)])
|
|
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
|
|
(send dc set-bitmap #f)
|
|
bm)))])
|
|
(let ([img (bitmap->image on)])
|
|
(atomically
|
|
(set! blits (cons (list x y w h img) blits))
|
|
(when (is-shown-to-root?)
|
|
(set! reg-blits (cons (register-one-blit x y w h img) reg-blits)))))))
|
|
|
|
(define/public (unregister-collecting-blits)
|
|
(atomically
|
|
(suspend-all-reg-blits)
|
|
(set! blits null))))))
|