diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 78acf5f65c..376fc7f5d7 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -113,7 +113,8 @@ (inherit get-cocoa get-parent get-eventspace pre-on-char pre-on-event - get-x get-y) + get-x get-y + on-new-child) (super-new [parent parent] [cocoa @@ -293,6 +294,10 @@ (when saved-child (send saved-child show-children))) + (define/override (children-accept-drag on?) + (when saved-child + (send saved-child child-accept-drag on?))) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) @@ -314,7 +319,8 @@ (unless on? (error 'register-child-in-frame "did not expect #f")) (unless (or (not saved-child) (eq? child saved-child)) (error 'register-child-in-frame "expected only one child")) - (set! saved-child child)) + (set! saved-child child) + (on-new-child child #t)) (define/override (set-cursor c) (when saved-child diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 67ced26151..aad8308aa0 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -20,7 +20,7 @@ (define (panel-mixin %) (class % - (inherit register-as-child) + (inherit register-as-child on-new-child) (define lbl-pos 'horizontal) (define children null) @@ -45,6 +45,10 @@ (define/override (paint-children) (for ([child (in-list children)]) (send child paint-children))) + + (define/override (children-accept-drag on?) + (for ([child (in-list children)]) + (send child child-accept-drag on?))) (define/override (set-size x y w h) (super set-size x y w h) @@ -59,7 +63,8 @@ (set! children (if on? (cons child children) - (remq child children)))))) + (remq child children))) + (on-new-child child on?)))) (define/override (show on?) (super show on?) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 530d263a72..1ae62f730f 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require ffi/objc - scheme/foreign +(require ffi/unsafe/objc + ffi/unsafe scheme/class "queue.rkt" "utils.rkt" @@ -16,8 +16,6 @@ "../common/delay.rkt" "../../syntax.rkt" "../common/freeze.rkt") -(unsafe!) -(objc-unsafe!) (provide window% @@ -77,6 +75,8 @@ (define current-insert-text (make-parameter #f)) +(define NSDragOperationCopy 1) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -172,7 +172,26 @@ [-a _NSInteger (conversationIdentifier) 0] [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) - (make-NSSize 0 0))]) + (make-NSSize 0 0))] + + ;; 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-objc-mixin (KeyMouseTextResponder Superclass) #:mixins (KeyMouseResponder) @@ -315,6 +334,8 @@ (lambda () (send wx dispatch-on-event m #t)) #t))))))))) +(define-cocoa NSFilenamesPboardType _id) + (define window% (class object% (init-field parent @@ -400,6 +421,16 @@ (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)) @@ -483,8 +514,38 @@ (define/public (move x y) (set-size x y (get-width) (get-height))) + (define accept-drag? #f) + (define accept-parent-drag? #f) + + (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 (gets-focus?) @@ -579,7 +640,6 @@ (set! sticky-cursor? #f) (send (get-parent) end-no-cursor-rects)) - (def/public-unimplemented on-drop-file) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) diff --git a/collects/mrlib/name-message.rkt b/collects/mrlib/name-message.rkt index 488fa9b250..56cea33be8 100644 --- a/collects/mrlib/name-message.rkt +++ b/collects/mrlib/name-message.rkt @@ -262,8 +262,8 @@ circle-spacer border-inset)]) (values - (- tx (quotient (- ans-w tw) 2)) - (- ty (quotient (- ans-h th) 2)) + (- tx (quotient (ceiling (- ans-w tw)) 2)) + (- ty (quotient (ceiling (- ans-h th)) 2)) ans-w ans-h)))