suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

default buttons and Cocoa clipboard

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-26 15:53:47 -05:00
parent ac6139345d
commit 0723c4f647
18 changed files with 105 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/wx/cocoa/button.rkt
View File

@ -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)))

1
collects/mred/private/wx/cocoa/choice.rkt
View File

@ -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)

71
collects/mred/private/wx/cocoa/clipboard.rkt
View File

@ -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))))))

1
collects/mred/private/wx/cocoa/gauge.rkt
View File

@ -42,6 +42,7 @@
(if vert? 32 24))))
(tellv cocoa sizeToFit)
cocoa)]
[callback void]
[no-show? (memq 'deleted style)])
(define cocoa (get-cocoa))

6
collects/mred/private/wx/cocoa/item.rkt
View File

@ -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)

2
collects/mred/private/wx/cocoa/menu-bar.rkt
View File

@ -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)

1
collects/mred/private/wx/cocoa/message.rkt
View File

@ -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)

5
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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)

1
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -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))

1
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -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))

2
collects/mred/private/wx/cocoa/window.rkt
View File

@ -22,8 +22,6 @@
;; ----------------------------------------
(import-class NSArray)
(define-objc-mixin (FocusResponder Superclass)
[wx]
[-a _BOOL (acceptsFirstResponder)

11
collects/mred/private/wx/common/freeze.rkt
View File

@ -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")

1
collects/mred/private/wx/gtk/button.rkt
View File

@ -52,6 +52,7 @@
gtk)]
[else
(gtk_new_with_mnemonic "<bad>")])]
[callback cb]
[no-show? (memq 'deleted style)])
(define gtk (get-gtk))

1
collects/mred/private/wx/gtk/choice.rkt
View File

@ -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)

7
collects/mred/private/wx/gtk/item.rkt
View File

@ -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)))

1
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -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)

1
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -66,6 +66,7 @@
(super-new [parent parent]
[gtk gtk]
[extra-gtks radio-gtks]
[callback cb]
[no-show? (memq 'deleted style)])
(set-auto-size)

1
collects/mred/private/wx/gtk/slider.rkt
View File

@ -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))