diff --git a/pulseaudio.cabal b/pulseaudio.cabal --- a/pulseaudio.cabal +++ b/pulseaudio.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.1.1 +version: 0.0.2.0 -- A short (one-line) description of the package. synopsis: A low-level (incomplete) wrapper around the pulseaudio client asynchronous api @@ -104,6 +104,7 @@ ,Sound.Pulse.Operation ,Sound.Pulse.Serverinfo ,Sound.Pulse.Volume + ,Sound.Pulse @@ -123,6 +124,9 @@ ,stm ,containers + if impl(ghc < 8.0) + build-depends: transformers + -- Directories containing source files. hs-source-dirs: src diff --git a/src/Sound/Pulse.hs b/src/Sound/Pulse.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Pulse.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE InstanceSigs #-} +-- {-# LANGUAGE ScopedTypeVariables #-} +module Sound.Pulse + ( Pulse (..) + , runPulse + , runPulse_ + , runGetPulse + + , pulseListM + ) +where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, newMVar, modifyMVar_) +import Sound.Pulse.Context (Context) + +data Pulse a = Pulse (Context -> (a -> IO ()) -> IO ()) + +instance Functor Pulse where + fmap :: (a -> b) -> Pulse a -> Pulse b + fmap f (Pulse x) = + let g cxt y = x cxt (y . f) + in Pulse g + +instance Applicative Pulse where + pure :: a -> Pulse a + pure x = Pulse (\_ f -> f x) + + (<*>) :: Pulse (a -> b) -> Pulse a -> Pulse b + (Pulse f0) <*> (Pulse g0) = + let g1 cxt h t = g0 cxt (h . t) + in Pulse (\cxt h -> f0 cxt (g1 cxt h)) + +instance Monad Pulse where + return :: a -> Pulse a + return = pure + + (>>=) :: Pulse a -> (a -> Pulse b) -> Pulse b + (Pulse a) >>= f = + Pulse (\cxt g -> a cxt (\v -> let Pulse h = f v in h cxt g)) + +instance MonadIO Pulse where + liftIO :: IO a -> Pulse a + liftIO a = Pulse (\_ f -> f =<< a) + +runPulse :: MonadIO m => Context -> Pulse a -> (a -> IO ()) -> m () +runPulse cxt (Pulse x) f = liftIO $ x cxt f + +runPulse_ :: MonadIO m => Context -> Pulse a -> m () +runPulse_ cxt (Pulse x) = liftIO $ x cxt (const $ return ()) + +runGetPulse :: MonadIO m => Context -> Pulse a -> m a +runGetPulse cxt x = liftIO $ do + var <- newEmptyMVar + runPulse cxt x (putMVar var) + takeMVar var + +pulseListM :: (Context -> (a -> IO ()) -> IO () -> IO ()) -> Pulse [a] +pulseListM fun = Pulse $ \cxt f -> do + var <- newMVar [] + let cb v = modifyMVar_ var $ return . (v:) + fun cxt cb (f . reverse =<< takeMVar var) + diff --git a/src/Sound/Pulse/Serverinfo.hsc b/src/Sound/Pulse/Serverinfo.hsc --- a/src/Sound/Pulse/Serverinfo.hsc +++ b/src/Sound/Pulse/Serverinfo.hsc @@ -26,6 +26,7 @@ module Sound.Pulse.Serverinfo ( ServerInfo(..) , getServerInfo + , getServerInfoM ) where @@ -36,6 +37,7 @@ import Control.Applicative ((<$>), (<*>)) import Data.Word (Word32, Word) +import Sound.Pulse import Sound.Pulse.SampleSpec import Sound.Pulse.ChannelPosition import Sound.Pulse.Context @@ -91,3 +93,6 @@ freeHaskellFunPtr (castPtrToFunPtr fP) _ <- ptrToOperation =<< pa_context_get_server_info cxt funP (castFunPtrToPtr funP) return () + +getServerInfoM :: Pulse ServerInfo +getServerInfoM = Pulse getServerInfo diff --git a/src/Sound/Pulse/Sinkinfo.hsc b/src/Sound/Pulse/Sinkinfo.hsc --- a/src/Sound/Pulse/Sinkinfo.hsc +++ b/src/Sound/Pulse/Sinkinfo.hsc @@ -32,6 +32,10 @@ , getContextSinks , getContextSinkByName , getContextSinkByIndex + + , getContextSinksM + , getContextSinkByNameM + , getContextSinkByIndexM ) where @@ -41,11 +45,13 @@ #include import Control.Applicative ((<$>), (<*>)) +import Sound.Pulse import Sound.Pulse.Volume import Sound.Pulse.Operation import Sound.Pulse.Userdata import Data.Word (Word32, Word8, Word) +import Control.Monad (void) import Foreign.Ptr (Ptr, FunPtr, freeHaskellFunPtr, castFunPtrToPtr, castPtrToFunPtr) import Foreign.C.Types (CInt(..), CUInt(..)) import Foreign.C.String (peekCString, withCString, CString) @@ -150,6 +156,9 @@ funP <- mkCallback fun endf ptrToOperation =<< pa_context_get_sink_info_list cxt funP (castFunPtrToPtr funP) +getContextSinksM :: Pulse [Sinkinfo] +getContextSinksM = pulseListM (\c cb e -> void $ getContextSinks c cb e) + -- |Get a sink by name getContextSinkByName :: Context @@ -160,6 +169,10 @@ funP <- mkCallback fun (return ()) ptrToOperation =<< withCString name (\ptr -> pa_context_get_sink_info_by_name cxt ptr funP (castFunPtrToPtr funP)) +getContextSinkByNameM :: String -> Pulse Sinkinfo +getContextSinkByNameM name = + Pulse (\cxt cb -> void $ getContextSinkByName cxt name cb) + -- |Get a sink by index getContextSinkByIndex :: Context @@ -169,3 +182,7 @@ getContextSinkByIndex cxt idx fun = do funP <- mkCallback fun (return ()) ptrToOperation =<< pa_context_get_sink_info_by_index cxt (fromIntegral idx) funP (castFunPtrToPtr funP) + +getContextSinkByIndexM :: Word32 -> Pulse Sinkinfo +getContextSinkByIndexM index = + Pulse (\cxt cb -> void $ getContextSinkByIndex cxt index cb) diff --git a/src/Sound/Pulse/Subscribe.hs b/src/Sound/Pulse/Subscribe.hs --- a/src/Sound/Pulse/Subscribe.hs +++ b/src/Sound/Pulse/Subscribe.hs @@ -29,6 +29,7 @@ , SubscriptionMask(..) , subscribeEvents + , subscribeEventsM ) where @@ -37,6 +38,7 @@ import Data.Bits ((.&.)) import Foreign.Ptr import Foreign.C.Types +import Sound.Pulse import Sound.Pulse.Context import Sound.Pulse.Userdata import Sound.Pulse.Def (SubscriptionEventFacility(..), SubscriptionEventType(..), subscriptionEventFacilityFromInt, subscriptionEventFacilityToInt, subscriptionEventTypeFromInt, subscriptionEventTypeToInt, SubscriptionMask(..), subscriptionMasksToInt) @@ -63,6 +65,9 @@ -> Ptr Userdata -> IO (Ptr UOperation) +type Subscription = + (SubscriptionEventFacility, SubscriptionEventType) -> Word32 -> IO () + -- |Currently the function given here is leaked! even if it's reset later on -- This is currently unavoidable, since we don't know when the last event -- occured. @@ -71,10 +76,7 @@ subscribeEvents :: Context -- ^The Context to subscribe on -> [SubscriptionMask] -- ^The events that should be reported - -> ((SubscriptionEventFacility, SubscriptionEventType) - -> Word32 - -> IO () - ) -- ^Callback function that will be called on every event received. + -> Subscription -- ^Callback function that will be called on every event received. -> IO Operation subscribeEvents cxt mask fun = do funP <- mkSubscribeCB $ \_ ival idx _ -> @@ -82,3 +84,8 @@ pa_context_set_subscribe_callback cxt funP nullPtr sucP <- wrapSuccess (\_ -> return ()) ptrToOperation =<< pa_context_subscribe cxt (subscriptionMasksToInt mask) sucP nullPtr + + +subscribeEventsM :: [SubscriptionMask] -> (Context -> Subscription) -> Pulse Operation +subscribeEventsM mask sub = + Pulse $ \cxt f -> f =<< subscribeEvents cxt mask (sub cxt)