samples

diff --git a/Sound/EsounD/Controller.hs b/Sound/EsounD/Controller.hs
index 1353d065215d7ca8a02e70ef0becbffc39414639..aa9dabae40c9db883635d3049e37937cb20187b9 100644 (file)
--- a/Sound/EsounD/Controller.hs
+++ b/Sound/EsounD/Controller.hs
@@ -13,6 +13,16 @@ module Sound.EsounD.Controller
 
     , lock
     , unlock
 
     , lock
     , unlock

+
+    , standby
+    , resume
+
+    , Sample
+    , SampleSource(..)
+    , playSample
+    , loopSample
+    , stopSample
+    , killSample

     )
     where
 import Bindings.EsounD
     )
     where
 import Bindings.EsounD


@@ -22,10 +32,14 @@ import Control.Monad.IO.Peel
 import Control.Monad.Trans.Region
 import Control.Monad.Trans.Region.OnExit
 import Control.Monad.Unicode
 import Control.Monad.Trans.Region
 import Control.Monad.Trans.Region.OnExit
 import Control.Monad.Unicode

+import Data.Bits
+import Data.StorableVector.Lazy as L

 import Foreign.C.Types
 import Network
 import Foreign.C.Types
 import Network

+import Prelude.Unicode

 import Sound.EsounD.Internals
 import System.IO.SaferFileHandles.Unsafe
 import Sound.EsounD.Internals
 import System.IO.SaferFileHandles.Unsafe

+import System.Posix.IO hiding (dup)

 import System.Posix.Types
 import Text.Printf
 
 import System.Posix.Types
 import Text.Printf
 


@@ -83,7 +97,8 @@ lock co
     = liftIO $
       sanitizeIOError $
       c'esd_lock (fdToCInt $ coSocket co)
     = liftIO $
       sanitizeIOError $
       c'esd_lock (fdToCInt $ coSocket co)

-          ≫= failOnError "esd_lock(fd) returned an error"
+          ≫= failOnError "esd_lock(fd) returned an error" (≤ 0)
+          ≫  return ()

 
 -- | Unlock the ESD so that it will accept connections from remote
 -- hosts.
 
 -- | Unlock the ESD so that it will accept connections from remote
 -- hosts.


@@ -96,4 +111,212 @@ unlock co
     = liftIO $
       sanitizeIOError $
       c'esd_unlock (fdToCInt $ coSocket co)
     = liftIO $
       sanitizeIOError $
       c'esd_unlock (fdToCInt $ coSocket co)

-          ≫= failOnError "esd_unlock(fd) returned an error"
+          ≫= failOnError "esd_unlock(fd) returned an error" (≤ 0)
+          ≫  return ()
+
+-- | Let ESD stop playing sounds and release its connection to the
+-- audio device so that other processes may use it.
+standby ∷ ( AncestorRegion pr cr
+           , MonadIO cr
+           )
+        ⇒ Controller pr
+        → cr ()
+standby co
+    = liftIO $
+      sanitizeIOError $
+      c'esd_standby (fdToCInt $ coSocket co)
+          ≫= failOnError "esd_standby(fd) returned an error" (≤ 0)
+          ≫  return ()
+
+-- | Let ESD attempt to reconnect to the audio device and start
+-- playing sounds again.
+resume ∷ ( AncestorRegion pr cr
+          , MonadIO cr
+          )
+       ⇒ Controller pr
+       → cr ()
+resume co
+    = liftIO $
+      sanitizeIOError $
+      c'esd_resume (fdToCInt $ coSocket co)
+          ≫= failOnError "esd_resume(fd) returned an error" (≤ 0)
+          ≫  return ()
+
+-- | An opaque ESD sample handle.
+data Sample (r ∷ ★ → ★)
+    = Sample {
+        saID     ∷ !CInt
+      , saCtrl   ∷ !(Controller r)
+      , saCloseH ∷ !(FinalizerHandle r)
+      }
+
+instance Dup Sample where
+    dup sa = do ctrl' ← dup (saCtrl   sa)
+                ch'   ← dup (saCloseH sa)
+                return sa {
+                         saCtrl   = ctrl'
+                       , saCloseH = ch'
+                       }
+
+class (Frame fr, Channels ch) ⇒ SampleSource fr ch dvec where
+    -- | Cache a sample in the server.
+    cacheSample ∷ (MonadPeelIO pr)
+                ⇒ Controller (RegionT s pr)
+                → Maybe String  -- ^ name used to identify this sample to
+                → Int           -- ^ sample rate
+                → dvec          -- ^ frames in deinterleaved vectors
+                → RegionT s pr (Sample (RegionT s pr))
+
+instance Frame fr ⇒ SampleSource fr Mono (L.Vector fr) where
+    cacheSample co name rate v
+        = block $
+          do sa ← createSample
+                   co
+                   name
+                   rate
+                   ((⊥) ∷ fr  )
+                   ((⊥) ∷ Mono)
+                   (L.length v)
+             _  ← liftIO $
+                   sanitizeIOError $
+                   do h       ← fdToHandle $ coSocket co
+                      _       ← L.hPut h v
+                      (Fd fd) ← handleToFd h
+                      c'esd_confirm_sample_cache fd
+                          ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
+             return sa
+
+instance Frame fr ⇒ SampleSource fr Stereo (L.Vector fr, L.Vector fr) where
+    cacheSample co name rate (l, r)
+        = block $
+          do sa ← createSample
+                   co
+                   name
+                   rate
+                   ((⊥) ∷ fr  )
+                   ((⊥) ∷ Mono)
+                   (L.length l)
+             _  ← liftIO $
+                   sanitizeIOError $
+                   do h       ← fdToHandle $ coSocket co
+                      _       ← L.hPut h (interleave l r)
+                      (Fd fd) ← handleToFd h
+                      c'esd_confirm_sample_cache fd
+                          ≫= failOnError "esd_confirm_sample_cache(fd) returned an error" (< 0)
+             return sa
+
+createSample ∷ ∀fr ch s pr.
+                ( Frame fr
+                , Channels ch
+                , MonadPeelIO pr
+                )
+             ⇒ Controller (RegionT s pr)
+             → Maybe String
+             → Int
+             → fr
+             → ch
+             → Int
+             → RegionT s pr (Sample (RegionT s pr))
+createSample co name rate _ _ size
+    = block $
+      do sid ← liftIO newCache
+         ch  ← onExit $ sanitizeIOError $ deleteCache sid
+         return Sample {
+                      saID     = sid
+                    , saCtrl   = co
+                    , saCloseH = ch
+                    }
+    where
+      fmt ∷ C'esd_format_t
+      fmt = frameFmt   ((⊥) ∷ fr) .|.
+            channelFmt ((⊥) ∷ ch) .|.
+            c'ESD_SAMPLE
+
+      newCache ∷ IO CInt
+      newCache = withCStrOrNull name $ \namePtr →
+                     c'esd_sample_cache
+                     (fdToCInt $ coSocket co)
+                     fmt
+                     (fromIntegral rate)
+                     (fromIntegral size)
+                     namePtr
+                     ≫= failOnError ( printf "esd_sample_cache(%s, %s, %s, %s, %s) returned an error"
+                                              (show $ coSocket co)
+                                              (show fmt)
+                                              (show rate)
+                                              (show size)
+                                              (show name)
+                                     ) (< 0)
+
+      deleteCache ∷ CInt → IO ()
+      deleteCache sid
+          = c'esd_sample_free (fdToCInt $ coSocket co) sid
+            ≫= failOnError ( printf "esd_sample_free(%s) returned an error"
+                                     (show $ coSocket co)
+                                     (show sid)
+                            ) (< 0)
+            ≫  return ()
+
+-- | Play a cached sample once.
+playSample ∷ ( AncestorRegion pr cr
+              , MonadIO cr
+              )
+           ⇒ Sample pr
+           → cr ()
+playSample sa
+    = liftIO $
+      sanitizeIOError $
+      c'esd_sample_play (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
+          ≫= failOnError ( printf "esd_sample_play(%s, %s) returned an error"
+                                   (show $ coSocket $ saCtrl sa)
+                                   (show $ saID sa)
+                          ) (≤ 0)
+          ≫  return ()
+
+-- | Play a cached sample repeatedly.
+loopSample ∷ ( AncestorRegion pr cr
+              , MonadIO cr
+              )
+           ⇒ Sample pr
+           → cr ()
+loopSample sa
+    = liftIO $
+      sanitizeIOError $
+      c'esd_sample_loop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
+          ≫= failOnError ( printf "esd_sample_loop(%s, %s) returned an error"
+                                   (show $ coSocket $ saCtrl sa)
+                                   (show $ saID sa)
+                          ) (≤ 0)
+          ≫  return ()
+
+-- | Stop a looping sample at end.
+stopSample ∷ ( AncestorRegion pr cr
+              , MonadIO cr
+              )
+           ⇒ Sample pr
+           → cr ()
+stopSample sa
+    = liftIO $
+      sanitizeIOError $
+      c'esd_sample_stop (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
+          ≫= failOnError ( printf "esd_sample_stop(%s, %s) returned an error"
+                                   (show $ coSocket $ saCtrl sa)
+                                   (show $ saID sa)
+                          ) (≤ 0)
+          ≫  return ()
+
+-- | Stop a playing sample immediately.
+killSample ∷ ( AncestorRegion pr cr
+              , MonadIO cr
+              )
+           ⇒ Sample pr
+           → cr ()
+killSample sa
+    = liftIO $
+      sanitizeIOError $
+      c'esd_sample_kill (fdToCInt $ coSocket $ saCtrl sa) (saID sa)
+          ≫= failOnError ( printf "esd_sample_kill(%s, %s) returned an error"
+                                   (show $ coSocket $ saCtrl sa)
+                                   (show $ saID sa)
+                          ) (≤ 0)
+          ≫  return ()

diff --git a/Sound/EsounD/Filter.hs b/Sound/EsounD/Filter.hs
index 21413647b2fc5e728fc03a98c221d1ef46edbf03..26b6336fe417b52c1a4884d2a02c53632585e980 100644 (file)
--- a/Sound/EsounD/Filter.hs
+++ b/Sound/EsounD/Filter.hs
@@ -67,11 +67,17 @@ instance Frame fr ⇒ ReadableStream (Filter fr Stereo) (L.Vector fr, L.Vector f
 
 instance Frame fr ⇒ WritableStream (Filter fr Mono) (L.Vector fr) where 
     writeFrames fi v
 
 instance Frame fr ⇒ WritableStream (Filter fr Mono) (L.Vector fr) where 
     writeFrames fi v

-        = liftIO $ sanitizeIOError $ L.hPut (fiHandle fi) v
+        = liftIO $
+          sanitizeIOError $
+          do L.hPut (fiHandle fi) v
+             hFlush (fiHandle fi) 

 
 instance Frame fr ⇒ WritableStream (Filter fr Stereo) (L.Vector fr, L.Vector fr) where
     writeFrames fi (l, r)
 
 instance Frame fr ⇒ WritableStream (Filter fr Stereo) (L.Vector fr, L.Vector fr) where
     writeFrames fi (l, r)

-        = liftIO $ sanitizeIOError $ L.hPut (fiHandle fi) (interleave l r)
+        = liftIO $
+          sanitizeIOError $
+          do L.hPut (fiHandle fi) (interleave l r)
+             hFlush (fiHandle fi)

 
 -- | Open an ESD handle for filtering sound produced by ESD.
 --
 
 -- | Open an ESD handle for filtering sound produced by ESD.
 --

diff --git a/Sound/EsounD/Internals.hs b/Sound/EsounD/Internals.hs
index f4b067f0903cf30fc9a23b62ccb13dee41c5e4fe..735ce6324762dd14672a688df383b65515e6e727 100644 (file)
--- a/Sound/EsounD/Internals.hs
+++ b/Sound/EsounD/Internals.hs
@@ -28,7 +28,6 @@ import Foreign.C.String
 import Foreign.C.Types
 import Foreign.Ptr
 import Foreign.Storable
 import Foreign.C.Types
 import Foreign.Ptr
 import Foreign.Storable

-import Prelude.Unicode

 import System.IO
 import System.Posix.IO
 import System.Posix.Types
 import System.IO
 import System.Posix.IO
 import System.Posix.Types


@@ -99,7 +98,7 @@ withCStrOrNull ∷ Maybe String → (CString → IO a) → IO a
 withCStrOrNull Nothing  f = f nullPtr
 withCStrOrNull (Just s) f = withCString s f
 
 withCStrOrNull Nothing  f = f nullPtr
 withCStrOrNull (Just s) f = withCString s f
 

-failOnError ∷ Monad m ⇒ String → CInt → m ()
-failOnError msg rv
-    | rv ≤ 0   = fail msg
-    | otherwise = return ()
+failOnError ∷ Monad m ⇒ String → (CInt → Bool) → CInt → m CInt
+failOnError msg isErr rv
+    | isErr rv  = fail msg
+    | otherwise = return rv

diff --git a/Sound/EsounD/Player.hs b/Sound/EsounD/Player.hs
index 49740fc4167a57872f74b0c9a784b71f0dbb3c6d..56781da08f2753efc24178d2bcac28f9c0379af2 100644 (file)
--- a/Sound/EsounD/Player.hs
+++ b/Sound/EsounD/Player.hs
@@ -49,11 +49,17 @@ instance Stream (Player fr ch) where
 
 instance Frame fr ⇒ WritableStream (Player fr Mono) (L.Vector fr) where 
     writeFrames pl v
 
 instance Frame fr ⇒ WritableStream (Player fr Mono) (L.Vector fr) where 
     writeFrames pl v

-        = liftIO $ sanitizeIOError $ L.hPut (plHandle pl) v
+        = liftIO $
+          sanitizeIOError $
+          do L.hPut (plHandle pl) v
+             hFlush (plHandle pl)

 
 instance Frame fr ⇒ WritableStream (Player fr Stereo) (L.Vector fr, L.Vector fr) where
     writeFrames pl (l, r)
 
 instance Frame fr ⇒ WritableStream (Player fr Stereo) (L.Vector fr, L.Vector fr) where
     writeFrames pl (l, r)

-        = liftIO $ sanitizeIOError $ L.hPut (plHandle pl) (interleave l r)
+        = liftIO $
+          sanitizeIOError $
+          do L.hPut (plHandle pl) (interleave l r)
+             hFlush (plHandle pl)

 
 -- | Open an ESD handle for playing a stream.
 openPlayer ∷ ∀fr ch s pr.
 
 -- | Open an ESD handle for playing a stream.
 openPlayer ∷ ∀fr ch s pr.