From 0723c4f647921b3d3342e531d017b414d0f5530e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 26 Jul 2010 15:53:47 -0500 Subject: [PATCH] default buttons and Cocoa clipboard --- collects/mred/private/wx/cocoa/button.rkt | 3 +- collects/mred/private/wx/cocoa/choice.rkt | 1 + collects/mred/private/wx/cocoa/clipboard.rkt | 71 +++++++++++++++++++- collects/mred/private/wx/cocoa/gauge.rkt | 1 + collects/mred/private/wx/cocoa/item.rkt | 6 +- collects/mred/private/wx/cocoa/menu-bar.rkt | 2 +- collects/mred/private/wx/cocoa/message.rkt | 1 + collects/mred/private/wx/cocoa/queue.rkt | 5 +- collects/mred/private/wx/cocoa/radio-box.rkt | 1 + collects/mred/private/wx/cocoa/slider.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 2 - collects/mred/private/wx/common/freeze.rkt | 11 +-- collects/mred/private/wx/gtk/button.rkt | 1 + collects/mred/private/wx/gtk/choice.rkt | 1 + collects/mred/private/wx/gtk/item.rkt | 7 +- collects/mred/private/wx/gtk/list-box.rkt | 1 + collects/mred/private/wx/gtk/radio-box.rkt | 1 + collects/mred/private/wx/gtk/slider.rkt | 1 + 18 files changed, 105 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 8410b59dd9..54b379a932 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -94,7 +94,8 @@ (super-new [parent parent] [cocoa cocoa] - [no-show? (memq 'deleted style)]) + [no-show? (memq 'deleted style)] + [callback cb]) (when (memq 'border style) (tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell))) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 8d6fbbc719..98b1f8692b 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -48,6 +48,7 @@ (tellv cocoa setTarget: cocoa) (tellv cocoa setAction: #:type _SEL (selector clicked:)) cocoa)] + [callback cb] [no-show? (memq 'deleted style)]) (define callback cb) diff --git a/collects/mred/private/wx/cocoa/clipboard.rkt b/collects/mred/private/wx/cocoa/clipboard.rkt index 76a531e5f5..c77307b272 100644 --- a/collects/mred/private/wx/cocoa/clipboard.rkt +++ b/collects/mred/private/wx/cocoa/clipboard.rkt @@ -1,12 +1,81 @@ #lang scheme/base (require scheme/class + ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt" + "../common/bstr.rkt" "../../syntax.rkt") (provide clipboard-driver% has-x-selection?) +(import-class NSPasteboard NSArray NSData) +(import-protocol NSPasteboardOwner) + (define (has-x-selection?) #f) +(define (map-type s) + (cond + [(string=? s "TEXT") "public.utf8-plain-text"] + [else (string-append "org.racket-lang." s)])) + +(define (unmap-type s) + (cond + [(string=? s "public.utf8-plain-text") "TEXT"] + [(regexp-match #rx"^org[.]racket-lang[.](.*)$" s) + => (lambda (m) (cadr m))] + [else s])) + (defclass clipboard-driver% object% (init x-selection?) ; always #f - (super-new)) + (super-new) + + (define client #f) + (define counter -1) + + (define/public (clear-client) + ;; called in event-pump thread + (set! client #f)) + + (define/public (get-client) + (and client + (let ([c (tell #:type _NSInteger (tell NSPasteboard generalPasteboard) + changeCount)]) + (if (= c counter) + client + (begin + (set! client #f) + #f))))) + + (define/public (set-client c types) + (let ([pb (tell NSPasteboard generalPasteboard)] + [a (tell NSArray arrayWithObjects: + #:type (_list i _NSString) (map map-type types) + count: #:type _NSUInteger (length types))]) + (set! counter (tell #:type _NSInteger pb clearContents)) + (set! client c) + (for ([type (in-list types)]) + (let* ([bstr (send c get-data type)] + [data (tell NSData + dataWithBytes: #:type _bytes bstr + length: #:type _NSUInteger (bytes-length bstr))]) + (tellv (tell NSPasteboard generalPasteboard) + setData: data + forType: #:type _NSString (map-type type)))))) + + (define/public (get-data-for-type type) + (log-error "didn't expect clipboard data request")) + + (define/public (get-text-data) + (let ([bstr (get-data "TEXT")]) + (and bstr + (bytes->string/utf-8 bstr #\?)))) + + (define/public (get-data type) + (let* ([pb (tell NSPasteboard generalPasteboard)] + [data (tell pb dataForType: #:type _NSString (map-type type))]) + (and data + (let ([len (tell #:type _NSUInteger data length)] + [bstr (tell #:type _pointer data bytes)]) + (scheme_make_sized_byte_string bstr len 1)))))) diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index adcbde13e4..db13bb784f 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -42,6 +42,7 @@ (if vert? 32 24)))) (tellv cocoa sizeToFit) cocoa)] + [callback void] [no-show? (memq 'deleted style)]) (define cocoa (get-cocoa)) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index bcc15110cd..ec6e7074f8 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -18,6 +18,8 @@ (defclass item% window% (inherit get-cocoa) + (init-field callback) + (define/public (get-cocoa-control) (get-cocoa)) (define/override (enable on?) @@ -28,9 +30,11 @@ (define/override (gets-focus?) (tell #:type _BOOL (get-cocoa) canBecomeKeyView)) + (define/public (command e) + (callback this e)) + (def/public-unimplemented set-label) (def/public-unimplemented get-label) - (def/public-unimplemented command) (super-new) (define/public (init-font cocoa font) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 68b09544c9..aa35cc651f 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -83,7 +83,7 @@ (tellv apple addItem: item) (tellv item release)))]) (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) - (std "Preferences..." #f) + (std "Preferences..." (selector openPreferences:)) (tellv apple addItem: (tell NSMenuItem separatorItem)) (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) (tellv app setServicesMenu: services) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 272a5cd08b..1d1f752684 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -81,6 +81,7 @@ (send label get-height)) (tell #:type _NSSize label size))))]) cocoa)] + [callback void] [no-show? (memq 'deleted style)]) (define/override (set-label label) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 08f9b7f834..3211db0590 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -35,7 +35,10 @@ [] [-a _BOOL (applicationShouldTerminate: [_id app]) (queue-quit-event) - #f]) + #f] + [-a _BOOL (openPreferences: [_id app]) + (log-error "prefs") + #t]) (tellv app finishLaunching) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index d2a6df580c..464259ad99 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -98,6 +98,7 @@ (tellv cocoa setTarget: cocoa) (tellv cocoa setAction: #:type _SEL (selector clicked:)) cocoa)] + [callback cb] [no-show? (memq 'deleted style)]) (define count (length labels)) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index d9c06a3148..45c03b5b2b 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -54,6 +54,7 @@ (tellv cocoa setContinuous: #:type _BOOL #t) ; (tellv cocoa sizeToFit) cocoa)] + [callback cb] [no-show? (memq 'deleted style)]) (define cocoa (get-cocoa)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index b6c07274d3..cde3f9e520 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -22,8 +22,6 @@ ;; ---------------------------------------- -(import-class NSArray) - (define-objc-mixin (FocusResponder Superclass) [wx] [-a _BOOL (acceptsFirstResponder) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 4c03a4c48b..d5dc26d02d 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -70,10 +70,13 @@ (lambda () (set! prev (scheme_set_on_atomic_timeout handler)) (set! ready? #t) - (begin0 - (parameterize ([freezer-box #f]) - (thunk)) - (scheme_restore_on_atomic_timeout prev))) + (dynamic-wind + void + (lambda () + (parameterize ([freezer-box #f]) + (thunk))) + (lambda () + (scheme_restore_on_atomic_timeout prev)))) freeze-tag)))))) (begin (log-error "internal error: wrong eventspace for constrained event handling\n") diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index dbcb1e03de..8277ffe0e4 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -52,6 +52,7 @@ gtk)] [else (gtk_new_with_mnemonic "")])] + [callback cb] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 8af7770de9..ccd5c549f8 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -59,6 +59,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks (list button-gtk)] + [callback cb] [no-show? (memq 'deleted style)]) (gtk_combo_box_set_active gtk 0) diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt index 556f5c940d..b2fa259ac5 100644 --- a/collects/mred/private/wx/gtk/item.rkt +++ b/collects/mred/private/wx/gtk/item.rkt @@ -8,6 +8,8 @@ (defclass item% window% (inherit get-client-gtk) + (init-field [callback void]) + (super-new) (let ([client-gtk (get-client-gtk)]) @@ -16,7 +18,10 @@ (def/public-unimplemented set-label) (def/public-unimplemented get-label) - (def/public-unimplemented command)) + + (define/public (command e) + (callback this e))) + diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index 6d6c3563c4..a744d4ae50 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -109,6 +109,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks (list client-gtk selection)] + [callback cb] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index f928be2e88..30952d0cee 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -66,6 +66,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks radio-gtks] + [callback cb] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index 337c043e32..3a273718d6 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -40,6 +40,7 @@ [gtk (if (memq 'vertical style) (gtk_vscale_new #f) (gtk_hscale_new #f))] + [callback cb] [no-show? (memq 'deleted style)]) (define gtk (get-gtk))