1050 lines
42 KiB
Racket
1050 lines
42 KiB
Racket
#lang racket/base
|
||
(require ffi/unsafe/objc
|
||
ffi/unsafe
|
||
racket/class
|
||
"queue.rkt"
|
||
"utils.rkt"
|
||
"const.rkt"
|
||
"types.rkt"
|
||
"keycode.rkt"
|
||
"pool.rkt"
|
||
"cursor.rkt"
|
||
"key-translate.rkt"
|
||
"../common/local.rkt"
|
||
"../../lock.rkt"
|
||
"../common/event.rkt"
|
||
"../common/queue.rkt"
|
||
"../common/delay.rkt"
|
||
"../../syntax.rkt"
|
||
"../common/freeze.rkt")
|
||
|
||
(provide
|
||
(protect-out window%
|
||
|
||
FocusResponder
|
||
KeyMouseResponder
|
||
KeyMouseTextResponder
|
||
CursorDisplayer
|
||
|
||
queue-window-event
|
||
queue-window-refresh-event
|
||
queue-window*-event
|
||
request-flush-delay
|
||
cancel-flush-delay
|
||
make-init-point
|
||
flush-display
|
||
|
||
special-control-key
|
||
special-option-key))
|
||
|
||
(define-local-member-name flip-client)
|
||
|
||
;; ----------------------------------------
|
||
|
||
(define special-control-key? #f)
|
||
(define special-control-key
|
||
(case-lambda
|
||
[() special-control-key?]
|
||
[(on?) (set! special-control-key? (and on? #t))]))
|
||
|
||
(define special-option-key? #f)
|
||
(define special-option-key
|
||
(case-lambda
|
||
[() special-option-key?]
|
||
[(on?) (set! special-option-key? (and on? #t))]))
|
||
|
||
;; ----------------------------------------
|
||
|
||
(define-objc-mixin (FocusResponder Superclass)
|
||
[wxb]
|
||
[-a _BOOL (acceptsFirstResponder)
|
||
(let ([wx (->wx wxb)])
|
||
(or (not wx)
|
||
(send wx can-be-responder?)))]
|
||
[-a _BOOL (becomeFirstResponder)
|
||
(and (super-tell becomeFirstResponder)
|
||
(let ([wx (->wx wxb)])
|
||
(when wx (send wx is-responder wx #t))
|
||
#t))]
|
||
[-a _BOOL (resignFirstResponder)
|
||
(and (super-tell resignFirstResponder)
|
||
(let ([wx (->wx wxb)])
|
||
(when wx
|
||
(send wx is-responder wx #f)
|
||
(send wx set-saved-marked #f #f))
|
||
#t))]
|
||
[-a _void (changeColor: [_id sender])
|
||
(let ([wx (->wx wxb)])
|
||
(when wx (send wx on-color-change)))])
|
||
|
||
(import-class NSArray NSPanel NSTextView)
|
||
(import-protocol NSTextInput)
|
||
|
||
(define current-insert-text (make-parameter #f))
|
||
(define current-set-mark (make-parameter #f))
|
||
|
||
(define NSDragOperationCopy 1)
|
||
|
||
(import-class NSAttributedString)
|
||
(define _NSStringOrAttributed
|
||
(make-ctype _id
|
||
(lambda (v)
|
||
(cast v _NSString _id))
|
||
(lambda (v)
|
||
(if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class))
|
||
(tell #:type _NSString v string)
|
||
(cast v _id _NSString)))))
|
||
|
||
(define-objc-mixin (KeyMouseResponder Superclass)
|
||
[wxb]
|
||
[-a _void (mouseDown: [_id event])
|
||
(unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down)
|
||
(super-tell #:type _void mouseDown: event)
|
||
(let ([wx (->wx wxb)])
|
||
(when wx
|
||
(send wx post-mouse-down))))]
|
||
[-a _void (mouseUp: [_id event])
|
||
(unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up)
|
||
(super-tell #:type _void mouseUp: event))]
|
||
[-a _void (mouseDragged: [_id event])
|
||
(unless (do-mouse-event wxb event 'motion #t #f #f)
|
||
(super-tell #:type _void mouseDragged: event))]
|
||
[-a _void (mouseMoved: [_id event])
|
||
;; This event is sent to the first responder, instead of the
|
||
;; view under the mouse.
|
||
(let* ([win (tell event window)]
|
||
[view (and win (tell win contentView))]
|
||
[hit (and view (tell view hitTest: #:type _NSPoint
|
||
(tell #:type _NSPoint event locationInWindow)))])
|
||
(let loop ([hit hit])
|
||
(when hit
|
||
(if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:))
|
||
(unless (tell #:type _BOOL hit doMouseMoved: event)
|
||
(super-tell #:type _void mouseMoved: event))
|
||
(loop (tell hit superview))))))]
|
||
[-a _BOOL (doMouseMoved: [_id event])
|
||
;; called by mouseMoved:
|
||
(and
|
||
;; Make sure we're in the right eventspace:
|
||
(let ([wx (->wx wxb)])
|
||
(and wx
|
||
(eq? (current-thread)
|
||
(eventspace-handler-thread
|
||
(send wx get-eventspace)))))
|
||
;; Right event space, so handle the event:
|
||
(do-mouse-event wxb event 'motion #f #f #f))]
|
||
[-a _void (mouseEntered: [_id event])
|
||
(unless (do-mouse-event wxb event 'enter 'check 'check 'check)
|
||
(super-tell #:type _void mouseEntered: event))]
|
||
[-a _void (mouseExited: [_id event])
|
||
(unless (do-mouse-event wxb event 'leave 'check 'check 'check)
|
||
(super-tell #:type _void mouseExited: event))]
|
||
[-a _void (rightMouseDown: [_id event])
|
||
(unless (do-mouse-event wxb event 'right-down #f #f #t)
|
||
(super-tell #:type _void rightMouseDown: event))]
|
||
[-a _void (rightMouseUp: [_id event])
|
||
(unless (do-mouse-event wxb event 'right-up #f #f #f)
|
||
(super-tell #:type _void rightMouseUp: event))]
|
||
[-a _void (rightMouseDragged: [_id event])
|
||
(unless (do-mouse-event wxb event 'motion #f #f #t)
|
||
(super-tell #:type _void rightMouseDragged: event))]
|
||
[-a _void (otherMouseDown: [_id event])
|
||
(unless (do-mouse-event wxb event 'middle-down #f #t #f)
|
||
(super-tell #:type _void otherMouseDown: event))]
|
||
[-a _void (otherMouseUp: [_id event])
|
||
(unless (do-mouse-event wxb event 'middle-up #f #f #f)
|
||
(super-tell #:type _void otherMouseUp: event))]
|
||
[-a _void (otherMouseDragged: [_id event])
|
||
(unless (do-mouse-event wxb event 'motion #f #t #f)
|
||
(super-tell #:type _void otherMouseDragged: event))]
|
||
|
||
[-a _void (scrollWheel: [_id event])
|
||
(let ([delta-y (tell #:type _CGFloat event deltaY)]
|
||
[delta-x (tell #:type _CGFloat event deltaX)])
|
||
(let ([evts (append (cond
|
||
[(zero? delta-y) '()]
|
||
[(positive? delta-y) '(wheel-up)]
|
||
[else '(wheel-down)])
|
||
(cond
|
||
[(zero? delta-x) '()]
|
||
[(positive? delta-x) '(wheel-left)]
|
||
[else '(wheel-right)]))])
|
||
(unless (and (pair? evts)
|
||
(do-key-event wxb event self #f #f evts))
|
||
(super-tell #:type _void scrollWheel: event))))]
|
||
|
||
[-a _void (keyDown: [_id event])
|
||
(unless (do-key-event wxb event self #t #f #f)
|
||
(super-tell #:type _void keyDown: event))]
|
||
[-a _void (keyUp: [_id event])
|
||
(unless (do-key-event wxb event self #f #f #f)
|
||
(super-tell #:type _void keyUp: event))]
|
||
[-a _void (flagsChanged: [_id event])
|
||
(unless (do-key-event wxb event self #f #t #f)
|
||
(super-tell #:type _void flagsChanged: event))]
|
||
[-a _void (insertText: [_NSStringOrAttributed str])
|
||
(set-saved-marked! wxb #f #f)
|
||
(let ([cit (current-insert-text)])
|
||
(if cit
|
||
(set-box! cit str)
|
||
(let ([wx (->wx wxb)])
|
||
(post-dummy-event) ;; to wake up in case of character palette insert
|
||
(when wx
|
||
(queue-window-event wx (lambda ()
|
||
(send wx key-event-as-string str)))))))]
|
||
|
||
;; for NSTextInput:
|
||
[-a _BOOL (hasMarkedText) (get-saved-marked wxb)]
|
||
[-a _id (validAttributesForMarkedText)
|
||
(tell NSArray array)]
|
||
[-a _void (unmarkText)
|
||
(set-saved-marked! wxb #f #f)]
|
||
[-a _NSRange (markedRange)
|
||
(let ([saved-marked (get-saved-marked wxb)])
|
||
(make-NSRange 0 (if saved-marked (string-length saved-marked) 0)))]
|
||
[-a _NSRange (selectedRange)
|
||
(or (let ([s (get-saved-selected wxb)])
|
||
(and s
|
||
(make-NSRange (car s) (cdr s))))
|
||
(make-NSRange 0 0))]
|
||
[-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange])
|
||
;; We interpreter a call to `setMarkedText:' as meaning that the
|
||
;; key is a dead key for composing some other character.
|
||
(let ([m (current-set-mark)]) (when m (set-box! m #t)))
|
||
;; At the same time, we need to remember the text:
|
||
(set-saved-marked! wxb aString (cons (NSRange-location selRange)
|
||
(NSRange-length selRange)))
|
||
(void)]
|
||
[-a _id (validAttributesForMarkedText) #f]
|
||
[-a _id (attributedSubstringFromRange: [_NSRange theRange])
|
||
(let ([saved-marked (get-saved-marked wxb)])
|
||
(and saved-marked
|
||
(let ([s (tell (tell NSAttributedString alloc)
|
||
initWithString: #:type _NSString
|
||
(range-substring saved-marked theRange))])
|
||
(tellv s autorelease)
|
||
s)))]
|
||
|
||
[-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0]
|
||
[-a _NSInteger (conversationIdentifier) 0]
|
||
[-a _void (doCommandBySelector: [_SEL aSelector]) (void)]
|
||
[-a _NSRect (firstRectForCharacterRange: [_NSRange r])
|
||
;; This location is used to place a window for multi-character
|
||
;; input, such as when typing Chinese with Pinyin
|
||
(let ([f (tell #:type _NSRect self frame)]
|
||
[pt (tell #:type _NSPoint (tell self window)
|
||
convertBaseToScreen:
|
||
#:type _NSPoint
|
||
(tell #:type _NSPoint self
|
||
convertPoint: #:type _NSPoint
|
||
(make-NSPoint 0 0)
|
||
toView: #f))])
|
||
(make-NSRect pt (NSRect-size f)))]
|
||
|
||
;; Dragging:
|
||
[-a _int (draggingEntered: [_id info])
|
||
NSDragOperationCopy]
|
||
[-a _BOOL (prepareForDragOperation: [_id info])
|
||
#t]
|
||
[-a _BOOL (performDragOperation: [_id info])
|
||
(let ([wx (->wx wxb)])
|
||
(when wx
|
||
(with-autorelease
|
||
(let ([pb (tell info draggingPasteboard)])
|
||
(let ([data (tell pb propertyListForType: NSFilenamesPboardType)])
|
||
(when data
|
||
(for ([i (in-range (tell #:type _NSUInteger data count))])
|
||
(let ([s (tell #:type _NSString data objectAtIndex: #:type _NSUInteger i)])
|
||
(queue-window-event wx
|
||
(lambda ()
|
||
(send wx do-on-drop-file s)))))))))))
|
||
#t])
|
||
(define (set-saved-marked! wxb str sel)
|
||
(let ([wx (->wx wxb)])
|
||
(when wx
|
||
(send wx set-saved-marked str sel))))
|
||
(define (get-saved-marked wxb)
|
||
(let ([wx (->wx wxb)])
|
||
(and wx
|
||
(send wx get-saved-marked))))
|
||
(define (get-saved-selected wxb)
|
||
(let ([wx (->wx wxb)])
|
||
(and wx
|
||
(send wx get-saved-selected))))
|
||
(define (range-substring s range)
|
||
(let ([start (min (max 0 (NSRange-location range)) (string-length s))])
|
||
(substring s start (max (+ start (NSRange-length range))
|
||
(string-length s)))))
|
||
|
||
(define-objc-class InputMethodPanel NSPanel
|
||
[]
|
||
[-a _BOOL (canBecomeKeyWindow) #f]
|
||
[-a _BOOL (canBecomeMainWindow) #f]
|
||
[-a _void (windowDidResize: [_id notification])
|
||
(reset-input-method-window-size)])
|
||
|
||
(define-objc-mixin (KeyMouseTextResponder Superclass)
|
||
#:mixins (KeyMouseResponder)
|
||
#:protocols (NSTextInput)
|
||
[wxb])
|
||
|
||
(define-objc-mixin (CursorDisplayer Superclass)
|
||
[wxb]
|
||
[-a _void (resetCursorRects)
|
||
(let ([wx (->wx wxb)])
|
||
(when wx
|
||
(send wx reset-cursor-rects)))])
|
||
|
||
(define dead-key-state (make-initial-dead-key-state))
|
||
|
||
(define << arithmetic-shift)
|
||
|
||
(define (do-key-event wxb event self down? mod-change? wheel)
|
||
(define type (tell #:type _ushort event type))
|
||
(define key-down? (= (bitwise-and type #b1111) NSKeyDown))
|
||
(let ([wx (->wx wxb)])
|
||
(and
|
||
wx
|
||
(let ([inserted-text (box #f)]
|
||
[set-mark (box #f)]
|
||
[had-saved-text? (and (send wx get-saved-marked) #t)])
|
||
(when down?
|
||
;; Calling `interpretKeyEvents:' allows key combinations to be
|
||
;; handled, such as option-e followed by e to produce é. The
|
||
;; call to `interpretKeyEvents:' typically calls `insertText:',
|
||
;; so we set `current-insert-text' to tell `insertText:' to just
|
||
;; give us back the text in the parameter. For now, we ignore the
|
||
;; text and handle the event as usual, though probably we should
|
||
;; be doing something with it.
|
||
(parameterize ([current-insert-text inserted-text]
|
||
[current-set-mark set-mark])
|
||
(let ([array (tell (tell NSArray alloc)
|
||
initWithObjects: #:type (_ptr i _id) event
|
||
count: #:type _NSUInteger 1)])
|
||
(tellv self interpretKeyEvents: array)
|
||
(tellv array release))))
|
||
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
|
||
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
|
||
[pos (tell #:type _NSPoint event locationInWindow)]
|
||
[str (cond
|
||
[wheel #f]
|
||
[mod-change? #f]
|
||
[(unbox set-mark) ""] ; => dead key for composing characters
|
||
[(unbox inserted-text)]
|
||
[else
|
||
(tell #:type _NSString event characters)])]
|
||
[dead-key? (unbox set-mark)]
|
||
[control? (bit? modifiers NSControlKeyMask)]
|
||
[option? (bit? modifiers NSAlternateKeyMask)]
|
||
[shift? (bit? modifiers NSShiftKeyMask)]
|
||
[cmd? (bit? modifiers NSCommandKeyMask)]
|
||
[caps? (bit? modifiers NSAlphaShiftKeyMask)]
|
||
[codes (cond
|
||
[wheel wheel]
|
||
[mod-change? (case (tell #:type _ushort event keyCode)
|
||
[(56) '(shift)]
|
||
[(59) '(control)]
|
||
[(60) '(rshift)]
|
||
[(62) '(rcontrol)]
|
||
[else '()])]
|
||
[had-saved-text? str]
|
||
[(map-key-code (tell #:type _ushort event keyCode))
|
||
=> list]
|
||
[(string=? "" str) '(#\nul)]
|
||
[(and (= 1 (string-length str))
|
||
(let ([c (string-ref str 0)])
|
||
(or (and control?
|
||
(char<=? #\u00 c #\u1F)
|
||
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
|
||
(and (string? alt-str)
|
||
(= 1 (string-length alt-str))
|
||
(string-ref alt-str 0)))))))
|
||
=> list]
|
||
[else str])])
|
||
(for/fold ([result dead-key?]) ([one-code codes])
|
||
(or
|
||
;; Handle one key event
|
||
(let-values ([(x y) (send wx window-point-to-view pos)])
|
||
(let ([k (new key-event%
|
||
[key-code one-code]
|
||
[shift-down shift?]
|
||
[control-down control?]
|
||
[meta-down cmd?]
|
||
[alt-down option?]
|
||
[x (->long x)]
|
||
[y (->long y)]
|
||
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
|
||
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
|
||
(unless (or wheel mod-change?)
|
||
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
|
||
(when (and (string? alt-str)
|
||
(= 1 (string-length alt-str)))
|
||
(let ([alt-code (string-ref alt-str 0)])
|
||
(unless (equal? alt-code (send k get-key-code))
|
||
(send k set-other-altgr-key-code alt-code)))))
|
||
(when key-down?
|
||
(let ()
|
||
(define (toggle flag m b) (if flag (- m b) (+ m b)))
|
||
(define prev-dks (copy-dead-key-state dead-key-state))
|
||
(define (old-dks-copy) (copy-dead-key-state prev-dks))
|
||
(define mask (+ modifier-shift-key modifier-option-key modifier-alpha-lock
|
||
modifier-cmd-key modifier-control-key))
|
||
(define kc (tell #:type _ushort event keyCode))
|
||
(define mods (bitwise-and (<< modifiers -8) mask))
|
||
(define s (key-translate kc #:modifier-key-state mods
|
||
#:dead-key-state dead-key-state))
|
||
(define dead? (= 0 (string-length s)))
|
||
(unless dead? (set! dead-key-state (make-initial-dead-key-state)))
|
||
;; actual char received
|
||
(define c (and (not dead?) (string-ref s 0)))
|
||
;; the other codes all assume that caps-lock is off, so make sure it is turned off
|
||
(set! mods (if caps? (toggle caps? mods modifier-alpha-lock) mods))
|
||
(define shift-mod (toggle shift? mods modifier-shift-key))
|
||
(define alt-mod (toggle option? mods modifier-option-key))
|
||
(define shift-alt-mod (toggle shift? (toggle option? mods modifier-option-key)
|
||
modifier-shift-key))
|
||
;; (define cmd-mod (toggle cmd? mods modifier-cmd-key))
|
||
;; (define ctrl-mod (toggle control? mods modifier-control-key))
|
||
(define (alternative who setter mod)
|
||
(define s (key-translate kc #:modifier-key-state mod #:dead-key-state (old-dks-copy)))
|
||
(setter (if (> (string-length s) 0) (string-ref s 0) #f))
|
||
(void))
|
||
(alternative 'shift (lambda (c) (send k set-other-shift-key-code c)) shift-mod)
|
||
(alternative 'alt (lambda (c) (send k set-other-altgr-key-code c)) alt-mod)
|
||
;; what exacly is shift+altgr supposed to hold ?
|
||
(alternative 'shift-alt (lambda (c) (send k set-other-shift-altgr-key-code c)) shift-alt-mod)))
|
||
|
||
;; If the Option key is disabled globally via
|
||
;; `special-option-key`, then swap the Option and
|
||
;; non-Option results when Option is pressed.
|
||
(when (and option?
|
||
special-option-key?
|
||
(send k get-other-altgr-key-code))
|
||
(let ([other (send k get-other-altgr-key-code)])
|
||
(send k set-other-altgr-key-code (send k get-key-code))
|
||
(send k set-key-code other)))
|
||
;; When a Ctl- combination produces
|
||
;; no key (such as with Ctl-space), it works ok to
|
||
;; use the mapping produced with Shift also down.
|
||
(when (and control?
|
||
(equal? (send k get-key-code) #\u00)
|
||
(send k get-other-shift-key-code))
|
||
(send k set-key-code (send k get-other-shift-key-code))))
|
||
(unless wheel
|
||
(unless (or down? (and mod-change?
|
||
(case (send k get-key-code)
|
||
[(shift rshift) (send k get-shift-down)]
|
||
[(control rcontrol) (send k get-control-down)]
|
||
[else #t])))
|
||
;; swap altenate with main
|
||
(send k set-key-release-code (send k get-key-code))
|
||
(send k set-key-code 'release)))
|
||
(if (send wx definitely-wants-event? k)
|
||
(begin
|
||
(queue-window-event wx (lambda ()
|
||
(send wx dispatch-on-char/sync k)))
|
||
#t)
|
||
(constrained-reply (send wx get-eventspace)
|
||
(lambda () (send wx dispatch-on-char k #t))
|
||
#t))))
|
||
result)))))))
|
||
|
||
(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind])
|
||
(let ([wx (->wx wxb)])
|
||
(and
|
||
wx
|
||
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
|
||
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
|
||
[pos (tell #:type _NSPoint event locationInWindow)])
|
||
(let-values ([(x y) (send wx window-point-to-view pos)]
|
||
[(control-down) (bit? modifiers NSControlKeyMask)]
|
||
[(l?) (if (eq? l? 'check)
|
||
(send wx get-last-left-button)
|
||
l?)]
|
||
[(m?) (if (eq? m? 'check)
|
||
(send wx get-last-middle-button)
|
||
m?)]
|
||
[(r?) (if (eq? r? 'check)
|
||
(send wx get-last-right-button)
|
||
r?)])
|
||
(let ([l? (and l? (not control-down))]
|
||
[r? (or r? (and l? control-down))])
|
||
(send wx set-last-buttons l? m? r?)
|
||
(let ([m (new mouse-event%
|
||
[event-type (if control-down ctl-kind kind)]
|
||
[left-down l?]
|
||
[middle-down m?]
|
||
[right-down r?]
|
||
[x (->long x)]
|
||
[y (->long y)]
|
||
[shift-down (bit? modifiers NSShiftKeyMask)]
|
||
[meta-down (bit? modifiers NSCommandKeyMask)]
|
||
[alt-down (bit? modifiers NSAlternateKeyMask)]
|
||
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
|
||
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
|
||
(cond
|
||
[(send m dragging?) (void)]
|
||
[(send m button-down?)
|
||
(send wx set-sticky-cursor)
|
||
(send wx start-no-cursor-rects)]
|
||
[(or l? m? r?) (void)]
|
||
[else (send wx end-no-cursor-rects)])
|
||
(if (send wx definitely-wants-event? m)
|
||
(begin
|
||
(queue-window-event wx (lambda ()
|
||
(send wx dispatch-on-event/sync m)))
|
||
#t)
|
||
(constrained-reply (send wx get-eventspace)
|
||
(lambda () (send wx dispatch-on-event m #t))
|
||
#t)))))))))
|
||
|
||
(define-cocoa NSFilenamesPboardType _id)
|
||
|
||
(define _CGError _int32)
|
||
(define-appserv CGWarpMouseCursorPosition (_fun _NSPoint -> _CGError))
|
||
(define-appserv CGAssociateMouseAndMouseCursorPosition (_fun _BOOL -> _CGError))
|
||
|
||
(define window%
|
||
(class object%
|
||
(init-field parent
|
||
cocoa
|
||
[no-show? #f])
|
||
|
||
(define is-on? #f)
|
||
(define accept-drag? #f)
|
||
(define accept-parent-drag? #f)
|
||
|
||
(super-new)
|
||
|
||
(queue-autorelease-flush)
|
||
|
||
(define eventspace (if parent
|
||
(send parent get-eventspace)
|
||
(current-eventspace)))
|
||
|
||
(when (eventspace-shutdown? eventspace)
|
||
(error '|GUI object initialization| "the eventspace has been shutdown"))
|
||
|
||
(set-ivar! cocoa wxb (->wxb this))
|
||
|
||
(unless no-show?
|
||
(show #t))
|
||
|
||
(define/public (focus-is-on on?)
|
||
(void))
|
||
|
||
(define is-responder? #f)
|
||
|
||
(define/public (is-responder wx on?)
|
||
(unless (eq? on? is-responder?)
|
||
(set! is-responder? (and on? #t))
|
||
(send parent is-responder wx on?)))
|
||
|
||
(define/public (hide-children)
|
||
(is-responder this #f)
|
||
(focus-is-on #f))
|
||
(define/public (show-children)
|
||
(void))
|
||
(define/public (fixup-locations-children)
|
||
(void))
|
||
(define/public (fix-dc)
|
||
(void))
|
||
(define/public (paint-children)
|
||
(void))
|
||
|
||
(define/public (get-cocoa) cocoa)
|
||
(define/public (get-cocoa-content) cocoa)
|
||
(define/public (get-cocoa-focus) (get-cocoa-content))
|
||
(define/public (get-cocoa-cursor-content) (get-cocoa-content))
|
||
(define/public (get-cocoa-window) (send parent get-cocoa-window))
|
||
(define/public (get-wx-window) (send parent get-wx-window))
|
||
|
||
(define/public (get-dialog-level)
|
||
;; called in event-pump thread
|
||
(send parent get-dialog-level))
|
||
|
||
(define/public (make-graphics-context)
|
||
(and parent
|
||
(send parent make-graphics-context)))
|
||
|
||
(define/public (get-parent)
|
||
parent)
|
||
|
||
(define/public (set-parent p)
|
||
(set! parent p))
|
||
|
||
(define/public (get-eventspace) eventspace)
|
||
|
||
(define/public (show on?)
|
||
(atomically
|
||
(unless (eq? (and on? #t) is-on?)
|
||
(if on?
|
||
(tellv (send parent get-cocoa-content) addSubview: cocoa)
|
||
(with-autorelease
|
||
(tellv cocoa removeFromSuperview)))
|
||
(set! is-on? (and on? #t))
|
||
(maybe-register-as-child parent on?)
|
||
(if on?
|
||
(show-children)
|
||
(begin
|
||
(hide-children)
|
||
(is-responder this #f))))))
|
||
(define/public (maybe-register-as-child parent on?)
|
||
;; override this to call register-as-child if the window
|
||
;; can have the focus or otherwise needs show-state notifications.
|
||
(void))
|
||
(define/public (register-as-child parent on?)
|
||
(send parent register-child this on?))
|
||
(define/public (register-child child on?)
|
||
(void))
|
||
|
||
(define/public (on-new-child child on?)
|
||
(if on?
|
||
(queue-window-event
|
||
child
|
||
(lambda ()
|
||
(atomically
|
||
(with-autorelease
|
||
(send child child-accept-drag (or accept-drag? accept-parent-drag?))))))
|
||
(send child child-accept-drag #f)))
|
||
|
||
(define/public (is-shown?)
|
||
(and (tell cocoa superview) #t))
|
||
|
||
(define/public (is-shown-to-root?)
|
||
(and (is-shown?)
|
||
(send parent is-shown-to-root?)))
|
||
|
||
(define/public (is-shown-to-before-root?)
|
||
(and (is-shown?)
|
||
(send parent is-shown-to-before-root?)))
|
||
|
||
(define enabled? #t)
|
||
(define/public (is-enabled-to-root?)
|
||
(and (is-window-enabled?/raw) (is-parent-enabled-to-root?)))
|
||
(define/public (is-parent-enabled-to-root?)
|
||
(send parent is-enabled-to-root?))
|
||
(define/public (is-window-enabled?/raw)
|
||
enabled?)
|
||
(define/public (is-window-enabled?)
|
||
(is-window-enabled?/raw))
|
||
(define/public (enable on?)
|
||
(atomically
|
||
(set! enabled? on?)
|
||
(when (is-parent-enabled-to-root?)
|
||
(enable-window on?))))
|
||
(define/public (enable-window on?)
|
||
;; in atomic mode
|
||
(void))
|
||
|
||
(define skip-enter-leave? #f)
|
||
(define/public (skip-enter-leave-events skip?)
|
||
(set! skip-enter-leave? skip?))
|
||
|
||
(define block-all-mouse-events? #f)
|
||
(define/public (block-mouse-events block?)
|
||
(set! block-all-mouse-events? block?))
|
||
|
||
(define/private (get-frame)
|
||
(let ([v (tell #:type _NSRect cocoa frame)])
|
||
v))
|
||
|
||
(define/public (flip y h)
|
||
(if parent
|
||
(let ([b (tell #:type _NSRect (send parent get-cocoa-content) bounds)])
|
||
(- (NSSize-height (NSRect-size b)) (+ y h)))
|
||
y))
|
||
|
||
(define/public (flip-client y)
|
||
(if (tell #:type _BOOL (get-cocoa-content) isFlipped)
|
||
y
|
||
(let ([r (tell #:type _NSRect (get-cocoa-content) bounds)])
|
||
(- (NSSize-height (NSRect-size r))
|
||
(- y (client-y-offset))))))
|
||
(define/public (client-y-offset) 0)
|
||
|
||
(define event-position-wrt-wx #f)
|
||
(define/public (set-event-positions-wrt wx)
|
||
(set! event-position-wrt-wx wx))
|
||
|
||
(define/public (is-view?) #t)
|
||
(define/public (window-point-to-view pos)
|
||
(let ([pos (if (is-view?)
|
||
(tell #:type _NSPoint (get-cocoa-content)
|
||
convertPoint: #:type _NSPoint pos
|
||
fromView: #f)
|
||
pos)])
|
||
(define x (NSPoint-x pos))
|
||
(define y (flip-client (NSPoint-y pos)))
|
||
(cond
|
||
[event-position-wrt-wx
|
||
(define xb (box (->long x)))
|
||
(define yb (box (->long y)))
|
||
(internal-client-to-screen xb yb)
|
||
(send event-position-wrt-wx internal-screen-to-client xb yb)
|
||
(values (unbox xb) (unbox yb))]
|
||
[else (values x y)])))
|
||
|
||
|
||
(define/public (get-x)
|
||
(->long (NSPoint-x (NSRect-origin (get-frame)))))
|
||
(define/public (get-y)
|
||
(let ([r (get-frame)])
|
||
(->long (flip (NSPoint-y (NSRect-origin r))
|
||
(NSSize-height (NSRect-size r))))))
|
||
(define/public (get-width)
|
||
(->long (NSSize-width (NSRect-size (get-frame)))))
|
||
(define/public (get-height)
|
||
(->long (NSSize-height (NSRect-size (get-frame)))))
|
||
(define/public (get-position x y)
|
||
(let* ([r (get-frame)]
|
||
[p (NSRect-origin r)])
|
||
(set-box! x (->long (NSPoint-x p)))
|
||
(set-box! y (->long (flip (NSPoint-y p) (NSSize-height (NSRect-size r)))))))
|
||
(define/public (get-size w h)
|
||
(let ([s (NSRect-size (get-frame))])
|
||
(set-box! w (->long (NSSize-width s)))
|
||
(set-box! h (->long (NSSize-height s)))))
|
||
|
||
(define/public (get-client-size w h)
|
||
;; May be called in Cocoa event-handling mode
|
||
(let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))])
|
||
(set-box! w (->long (NSSize-width s)))
|
||
(set-box! h (->long (NSSize-height s)))))
|
||
|
||
(define/public (set-size x y w h)
|
||
(let ([x (if (not x) (get-x) x)]
|
||
[y (if (not y) (get-y) y)])
|
||
;; old location will need refresh:
|
||
(tellv cocoa setNeedsDisplay: #:type _BOOL #t)
|
||
(tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h))
|
||
(make-NSSize w h)))
|
||
;; new location needs refresh:
|
||
(tellv cocoa setNeedsDisplay: #:type _BOOL #t))
|
||
(queue-on-size))
|
||
|
||
(define/public (internal-move x y)
|
||
(set-size x y (get-width) (get-height)))
|
||
(define/public (move x y)
|
||
(internal-move x y))
|
||
|
||
(define/public (on-drop-file f) (void))
|
||
(define/public (do-on-drop-file f)
|
||
(if accept-drag?
|
||
(on-drop-file (string->path f))
|
||
(when parent
|
||
(send parent do-on-drop-file f))))
|
||
|
||
(define/public (drag-accept-files on?)
|
||
(unless (eq? (and on? #t) accept-drag?)
|
||
(atomically
|
||
(with-autorelease
|
||
(set! accept-drag? (and on? #t))
|
||
(accept-drags-everywhere (or accept-drag? accept-parent-drag?))))))
|
||
|
||
(define/public (accept-drags-everywhere on?)
|
||
(if on?
|
||
(tellv (get-cocoa-content) registerForDraggedTypes:
|
||
(let ([a (tell NSArray arrayWithObjects: #:type (_list i _id) (list NSFilenamesPboardType)
|
||
count: #:type _NSUInteger 1)])
|
||
a))
|
||
(tellv (get-cocoa-content) unregisterDraggedTypes))
|
||
(children-accept-drag on?))
|
||
|
||
(define/public (children-accept-drag on?)
|
||
(void))
|
||
(define/public (child-accept-drag on?)
|
||
(unless (eq? (and on? #t) accept-parent-drag?)
|
||
(set! accept-parent-drag? (and on? #t))
|
||
(accept-drags-everywhere (or accept-drag? accept-parent-drag?))))
|
||
|
||
(define/public (set-focus)
|
||
(when (and (can-accept-focus?)
|
||
(is-enabled-to-root?))
|
||
(let ([w (tell cocoa window)])
|
||
(when w
|
||
(tellv w makeFirstResponder: (get-cocoa-focus))
|
||
;; Within a floating frame or when potentially taking
|
||
;; focus from a floating frame, also make the frame the
|
||
;; key window:
|
||
(let ([top (get-wx-window)])
|
||
(when (and (or (send top floating?)
|
||
(tell #:type _BOOL w isMainWindow))
|
||
(tell #:type _bool w isVisible))
|
||
(tellv w makeKeyAndOrderFront: #f)))))))
|
||
|
||
(define/public (on-set-focus) (void))
|
||
(define/public (on-kill-focus) (void))
|
||
|
||
(define/public (definitely-wants-event? e)
|
||
;; Called in Cocoa event-handling mode
|
||
#f)
|
||
|
||
(define/private (pre-event-refresh key?)
|
||
;; Since we break the connection between the
|
||
;; Cocoa queue and event handling, we
|
||
;; re-sync the display in case a stream of
|
||
;; events (e.g., key repeat) have a corresponding
|
||
;; stream of screen updates.
|
||
(try-to-sync-refresh)
|
||
(flush))
|
||
|
||
(define/public (flush)
|
||
(let ([cocoa-win (get-cocoa-window)])
|
||
(when cocoa-win
|
||
(tellv cocoa-win displayIfNeeded)
|
||
(tellv cocoa-win flushWindowIfNeeded))))
|
||
|
||
(define/public (dispatch-on-char/sync e)
|
||
(pre-event-refresh #t)
|
||
(dispatch-on-char e #f))
|
||
(define/public (dispatch-on-char e just-pre?)
|
||
(cond
|
||
[(other-modal? this) #t]
|
||
[(call-pre-on-char this e) #t]
|
||
[just-pre? #f]
|
||
[else (when enabled? (on-char e)) #t]))
|
||
|
||
(define/public (dispatch-on-event/sync e)
|
||
(pre-event-refresh #f)
|
||
(dispatch-on-event e #f))
|
||
(define/public (dispatch-on-event e just-pre?)
|
||
(cond
|
||
[(other-modal? this e) #t]
|
||
[(call-pre-on-event this e) #t]
|
||
[just-pre? block-all-mouse-events?]
|
||
[else (when enabled? (on-event e)) #t]))
|
||
|
||
(define/public (call-pre-on-event w e)
|
||
(or (send parent call-pre-on-event w e)
|
||
(pre-on-event w e)))
|
||
(define/public (call-pre-on-char w e)
|
||
(or (send parent call-pre-on-char w e)
|
||
(pre-on-char w e)))
|
||
(define/public (pre-on-event w e) #f)
|
||
(define/public (pre-on-char w e) #f)
|
||
|
||
(define/public (key-event-as-string s)
|
||
(dispatch-on-char (new key-event%
|
||
[key-code (string-ref s 0)]
|
||
[shift-down #f]
|
||
[control-down #f]
|
||
[meta-down #f]
|
||
[alt-down #f]
|
||
[x 0]
|
||
[y 0]
|
||
[time-stamp (current-milliseconds)] ; FIXME
|
||
[caps-down #f])
|
||
#f))
|
||
|
||
(define/public (post-mouse-down) (void))
|
||
|
||
(define/public (on-char s) (void))
|
||
(define/public (on-event m) (void))
|
||
(define/public (queue-on-size) (void))
|
||
|
||
(define last-l? #f)
|
||
(define last-m? #f)
|
||
(define last-r? #f)
|
||
(define/public (set-last-buttons l? m? r?)
|
||
(set! last-l? l?)
|
||
(set! last-m? m?)
|
||
(set! last-r? r?))
|
||
(define/public (get-last-left-button) last-l?)
|
||
(define/public (get-last-middle-button) last-m?)
|
||
(define/public (get-last-right-button) last-r?)
|
||
|
||
(define/public (set-sticky-cursor)
|
||
(set! sticky-cursor? #t))
|
||
|
||
(define/public (start-no-cursor-rects)
|
||
(send (get-parent) start-no-cursor-rects))
|
||
(define/public (end-no-cursor-rects)
|
||
(set! sticky-cursor? #f)
|
||
(send (get-parent) end-no-cursor-rects))
|
||
|
||
(define/public (get-handle) (get-cocoa))
|
||
(define/public (get-client-handle) (get-cocoa-content))
|
||
|
||
(define/public (popup-menu m x y)
|
||
(send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y)
|
||
(lambda (thunk)
|
||
(queue-window-event this thunk))))
|
||
|
||
(define/public (center a b) (void))
|
||
(define/public (refresh) (refresh-all-children))
|
||
|
||
(define/public (refresh-all-children) (void))
|
||
|
||
(define/public (screen-to-client xb yb)
|
||
(internal-screen-to-client xb yb))
|
||
(define/public (internal-screen-to-client xb yb)
|
||
(let ([p (tell #:type _NSPoint (get-cocoa-content)
|
||
convertPoint: #:type _NSPoint
|
||
(tell #:type _NSPoint (get-cocoa-window)
|
||
convertScreenToBase:
|
||
#:type _NSPoint (make-NSPoint (unbox xb)
|
||
(send (get-wx-window) flip-screen (unbox yb))))
|
||
fromView: #f)])
|
||
(set-box! xb (inexact->exact (floor (NSPoint-x p))))
|
||
(set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
|
||
|
||
(define/public (client-to-screen xb yb [flip-y? #t])
|
||
(internal-client-to-screen xb yb flip-y?))
|
||
(define/public (internal-client-to-screen xb yb [flip-y? #t])
|
||
(let* ([p (tell #:type _NSPoint (get-cocoa-window)
|
||
convertBaseToScreen:
|
||
#:type _NSPoint
|
||
(tell #:type _NSPoint (get-cocoa-content)
|
||
convertPoint: #:type _NSPoint
|
||
(make-NSPoint (unbox xb) (flip-client (unbox yb)))
|
||
toView: #f))])
|
||
(let ([new-y (if flip-y?
|
||
(send (get-wx-window) flip-screen (NSPoint-y p))
|
||
(NSPoint-y p))])
|
||
(set-box! xb (inexact->exact (floor (NSPoint-x p))))
|
||
(set-box! yb (inexact->exact (floor new-y))))))
|
||
|
||
(define cursor-handle #f)
|
||
(define sticky-cursor? #f)
|
||
(define/public (set-cursor c)
|
||
(let ([h (if c
|
||
(send (send c get-driver) get-handle)
|
||
#f)])
|
||
(unless (eq? h cursor-handle)
|
||
(atomically
|
||
(set! cursor-handle h)
|
||
(when sticky-cursor? (tellv h set))
|
||
(tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content))))))
|
||
(define/public (reset-cursor-rects)
|
||
;; called in event-pump thread
|
||
(when cursor-handle
|
||
(let ([content (get-cocoa-cursor-content)])
|
||
(let* ([r (tell #:type _NSRect content frame)]
|
||
[r (make-NSRect (make-NSPoint 0 0)
|
||
(make-NSSize
|
||
(- (NSSize-width (NSRect-size r))
|
||
(get-cursor-width-delta))
|
||
(NSSize-height (NSRect-size r))))])
|
||
(tellv content addCursorRect: #:type _NSRect r cursor: cursor-handle)))))
|
||
(define/public (get-cursor-width-delta) 0)
|
||
|
||
(define/public (can-accept-focus?) #f)
|
||
(define/public (gets-focus?) (can-accept-focus?))
|
||
(define/public (can-be-responder?) (is-enabled-to-root?))
|
||
|
||
(define/public (on-color-change)
|
||
(send parent on-color-change))
|
||
|
||
;; For multi-key character composition:
|
||
(define saved-marked #f)
|
||
(define saved-sel #f)
|
||
(define/public (set-saved-marked v sel)
|
||
(set! saved-marked v)
|
||
(set! saved-sel sel)
|
||
(if (and v
|
||
(not (string=? v ""))
|
||
;; Don't show the window for an empty string or certain
|
||
;; simple combinations (probably a better way than this);
|
||
(not (member v '("¨" "ˆ" "´" "`" "˜"))))
|
||
(create-compose-window)
|
||
(when compose-cocoa
|
||
(tellv compose-cocoa orderOut: #f))))
|
||
(define/public (get-saved-marked) saved-marked)
|
||
(define/public (get-saved-selected) saved-sel)
|
||
|
||
(define/public (warp-pointer x y)
|
||
(define xb (box x))
|
||
(define yb (box y))
|
||
(client-to-screen xb yb)
|
||
(void (CGWarpMouseCursorPosition (make-NSPoint (unbox xb) (unbox yb))))
|
||
(void (CGAssociateMouseAndMouseCursorPosition #t)))
|
||
|
||
(define/private (create-compose-window)
|
||
(unless compose-cocoa
|
||
(set! compose-cocoa (tell (tell InputMethodPanel alloc)
|
||
initWithContentRect: #:type _NSRect (make-NSRect
|
||
(make-NSPoint 0 20)
|
||
(make-NSSize 300 20))
|
||
styleMask: #:type _int (bitwise-ior NSUtilityWindowMask
|
||
NSResizableWindowMask
|
||
NSClosableWindowMask)
|
||
backing: #:type _int NSBackingStoreBuffered
|
||
defer: #:type _BOOL NO))
|
||
(set! compose-text (tell (tell NSTextView alloc)
|
||
initWithFrame: #:type _NSRect (make-NSRect
|
||
(make-NSPoint 0 0)
|
||
(make-NSSize 10 10))))
|
||
(tellv compose-cocoa setFloatingPanel: #:type _BOOL #t)
|
||
(tellv (tell compose-cocoa contentView) addSubview: compose-text)
|
||
(tellv compose-text sizeToFit)
|
||
(tellv compose-cocoa setContentBorderThickness: #:type _CGFloat 5.0 forEdge: #:type _int 1)
|
||
(let ([h (+ (NSSize-height
|
||
(NSRect-size
|
||
(tell #:type _NSRect
|
||
compose-cocoa frameRectForContentRect:
|
||
#:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
||
(make-NSSize 0 0)))))
|
||
(NSSize-height (NSRect-size (tell #:type _NSRect compose-text frame))))])
|
||
(tellv compose-cocoa setMinSize: #:type _NSSize (make-NSSize 1 h))
|
||
(tellv compose-cocoa setMaxSize: #:type _NSSize (make-NSSize 32000 h))
|
||
(tellv compose-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 20)
|
||
(make-NSSize 300 h))
|
||
display: #:type _BOOL #t))
|
||
(reset-input-method-window-size)
|
||
(tellv compose-cocoa setDelegate: compose-cocoa))
|
||
(tellv compose-text
|
||
setMarkedText: #:type _NSString saved-marked
|
||
selectedRange: #:type _NSRange (make-NSRange (car saved-sel) (cdr saved-sel)))
|
||
(tellv compose-cocoa orderFront: #f))))
|
||
|
||
(define (reset-input-method-window-size)
|
||
(when compose-text
|
||
(tell compose-text setFrame: #:type _NSRect
|
||
(tell #:type _NSRect (tell compose-cocoa contentView) frame))))
|
||
|
||
(define compose-cocoa #f)
|
||
(define compose-text #f)
|
||
|
||
;; ----------------------------------------
|
||
|
||
(define (queue-window-event wx thunk)
|
||
(queue-event (send wx get-eventspace) thunk))
|
||
|
||
(define (queue-window-refresh-event wx thunk)
|
||
(queue-refresh-event (send wx get-eventspace) thunk))
|
||
|
||
(define (queue-window*-event wxb proc)
|
||
(let ([wx (->wx wxb)])
|
||
(when wx
|
||
(queue-event (send wx get-eventspace) (lambda () (proc wx))))))
|
||
|
||
(define (request-flush-delay wx-win)
|
||
(do-request-flush-delay
|
||
wx-win
|
||
(lambda (wx-win)
|
||
(and (tell #:type _bool (send wx-win get-cocoa-window) isVisible)
|
||
(send wx-win disable-flush-window)
|
||
#t))
|
||
(lambda (wx-win)
|
||
(send wx-win enable-flush-window))))
|
||
|
||
(define (cancel-flush-delay req)
|
||
(do-cancel-flush-delay
|
||
req
|
||
(lambda (wx-win)
|
||
(send wx-win enable-flush-window))))
|
||
|
||
(define (make-init-point x y)
|
||
(make-NSPoint (if (not x)
|
||
0
|
||
x)
|
||
(if (not y)
|
||
0
|
||
y)))
|
||
|
||
(define (flush-display)
|
||
(try-to-sync-refresh)
|
||
(for ([win (in-list (get-top-level-windows))])
|
||
(send win flush)))
|