From 46ae5ff086f721f7038c8b97833c68fafeccadd6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 15 Oct 2010 09:41:47 -0600 Subject: [PATCH] font-dialog clean up and cocoa: play-sound --- collects/mred/private/fontdialog.rkt | 2 +- collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 7 +++-- collects/mred/private/wx/cocoa/sound.rkt | 35 +++++++++++++++++++++ collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/gtk/procs.rkt | 5 ++- collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 5 ++- 9 files changed, 53 insertions(+), 5 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/sound.rkt diff --git a/collects/mred/private/fontdialog.rkt b/collects/mred/private/fontdialog.rkt index 5ba477a5db..035f1118c7 100644 --- a/collects/mred/private/fontdialog.rkt +++ b/collects/mred/private/fontdialog.rkt @@ -73,7 +73,7 @@ [(3) 'unsmoothed]) (send sip get-value)))))] [bp (instantiate horizontal-pane% (f) [stretchable-height #f])] - [ms-button (if (eq? (system-type) 'windows) + [ms-button (if (eq? (wx:font-from-user-platform-mode) 'dialog) (begin0 (make-object button% "Use System Dialog..." bp (lambda (b e) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 04bd876fe2..b53bfef32a 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -78,6 +78,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index d016756874..e7f614068c 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -16,6 +16,7 @@ "../common/printer.rkt" "menu-bar.rkt" "agl.rkt" + "sound.rkt" "../../lock.rkt" "../common/handlers.rkt" (except-in "../common/default-procs.rkt" @@ -31,6 +32,7 @@ application-pref-handler color-from-user-platform-mode get-color-from-user + font-from-user-platform-mode get-font-from-user get-panel-background play-sound @@ -67,8 +69,6 @@ (import-class NSScreen NSCursor) -(define-unimplemented get-font-from-user) -(define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented send-event) (define-unimplemented write-resource) @@ -76,6 +76,9 @@ (define (color-from-user-platform-mode) "Show Picker") +(define-unimplemented get-font-from-user) +(define (font-from-user-platform-mode) #f) + (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) diff --git a/collects/mred/private/wx/cocoa/sound.rkt b/collects/mred/private/wx/cocoa/sound.rkt new file mode 100644 index 0000000000..ac0a28ef55 --- /dev/null +++ b/collects/mred/private/wx/cocoa/sound.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt") + +(provide play-sound) + +(import-class NSSound) + +(define-objc-class MySound NSSound + [result + sema] + [-a _void (sound: [_id sound] didFinishPlaying: [_BOOL ok?]) + (set! result ok?) + (semaphore-post sema) + (tellv self release)]) + +(define (play-sound path async?) + (let ([s (as-objc-allocation + (tell (tell MySound alloc) + initWithContentsOfFile: #:type _NSString (if (path? path) + (path->string path) + path) + byReference: #:type _BOOL #t))] + [sema (make-semaphore)]) + (tellv s setDelegate: s) + (set-ivar! s sema sema) + (tellv s retain) ; don't use `retain', because we dont' want auto-release + (tellv s play) + (if async? + (begin + (semaphore-wait sema) + (get-ivar s result)) + #t))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 712f2f3f56..40eef1d49e 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -78,6 +78,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index e300a5c4ba..70d6504ff1 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -24,6 +24,7 @@ get-color-from-user color-from-user-platform-mode get-font-from-user + font-from-user-platform-mode get-panel-background play-sound find-graphical-system-path @@ -59,7 +60,6 @@ make-gl-bitmap check-for-break) -(define-unimplemented get-font-from-user) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented location->window) @@ -71,6 +71,9 @@ (define (color-from-user-platform-mode) 'dialog) +(define (font-from-user-platform-mode) #f) +(define-unimplemented get-font-from-user) + (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 4d63680b01..5cf54c11d2 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -63,6 +63,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 9caeea00f4..167ca364be 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -79,6 +79,7 @@ find-graphical-system-path play-sound get-panel-background + font-from-user-platform-mode get-font-from-user color-from-user-platform-mode get-color-from-user diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 824169ac2c..ada8bb7e44 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -23,6 +23,7 @@ get-color-from-user color-from-user-platform-mode get-font-from-user + font-from-user-platform-mode get-panel-background play-sound find-graphical-system-path @@ -57,7 +58,6 @@ make-gl-bitmap check-for-break) -(define-unimplemented get-font-from-user) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define-unimplemented location->window) @@ -68,6 +68,9 @@ (define (color-from-user-platform-mode) 'dialog) +(define (font-from-user-platform-mode) #f) +(define-unimplemented get-font-from-user) + (define (get-panel-background) (let ([c (GetSysColor COLOR_BTNFACE)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c))))