module Sound.ALSA.Sequencer.Concurrent
  ( threadWaitInput
  , threadWaitOutput
  , threadWaitDuplex

  , input
  , output
  , drainOutput
  ) where

import qualified Sound.ALSA.Sequencer.Poll as AlsaPoll
import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq
import qualified Sound.ALSA.Sequencer.Event as Event
import Sound.ALSA.Exception (code, )

import qualified Control.Exception as Exc
import qualified System.Posix.Poll as Poll
import qualified Data.EnumBitSet as EnumSet
import Control.Concurrent (yield, threadWaitRead, threadWaitWrite, forkIO, killThread, )
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, )
import Control.Exception (catchJust, )
import Control.Monad (guard, when, )
import Data.Function (fix, )
import Data.Word (Word, )
import Foreign.C.Error (eINTR, )
import System.IO.Error (isFullError, )
import System.Posix.Types (Fd, )


data WaitFd
  = WaitRead Fd
  | WaitWrite Fd

pollWaits :: Poll.Fd -> [WaitFd]
pollWaits :: Fd -> [WaitFd]
pollWaits (Poll.Fd Fd
f Events
e Events
_) =
  (if forall a w. (Enum a, Bits w) => T w a -> T w a -> Bool
EnumSet.subset Events
Poll.inp Events
e then [Fd -> WaitFd
WaitRead  Fd
f] else []) forall a. [a] -> [a] -> [a]
++
  (if forall a w. (Enum a, Bits w) => T w a -> T w a -> Bool
EnumSet.subset Events
Poll.out Events
e then [Fd -> WaitFd
WaitWrite Fd
f] else [])

-- | Wait for any of the given events, like poll, and return the one that is ready
threadWaitPolls :: [WaitFd] -> IO WaitFd
threadWaitPolls :: [WaitFd] -> IO WaitFd
threadWaitPolls [] = IO ()
yield forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. HasCallStack => a
undefined
threadWaitPolls [p :: WaitFd
p@(WaitRead Fd
f)] = Fd -> IO ()
threadWaitRead Fd
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return WaitFd
p
threadWaitPolls [p :: WaitFd
p@(WaitWrite Fd
f)] = Fd -> IO ()
threadWaitWrite Fd
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return WaitFd
p
threadWaitPolls [WaitFd]
l = do
  MVar (Either IOError WaitFd)
w <- forall a. IO (MVar a)
newEmptyMVar
  let poll1 :: WaitFd -> IO ()
poll1 WaitFd
p =
         forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exc.catch
            ([WaitFd] -> IO WaitFd
threadWaitPolls [WaitFd
p] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Either IOError WaitFd)
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right)
            (forall a. MVar a -> a -> IO ()
putMVar MVar (Either IOError WaitFd)
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
  [ThreadId]
t <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO () -> IO ThreadId
forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaitFd -> IO ()
poll1) [WaitFd]
l
  Either IOError WaitFd
r <- forall a. MVar a -> IO a
takeMVar MVar (Either IOError WaitFd)
w
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
t
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. IOError -> IO a
ioError forall (m :: * -> *) a. Monad m => a -> m a
return Either IOError WaitFd
r

threadWaitEvents :: Poll.Events -> Seq.T mode -> IO ()
threadWaitEvents :: forall mode. Events -> T mode -> IO ()
threadWaitEvents Events
e T mode
sh =
  forall mode. T mode -> Events -> IO [Fd]
AlsaPoll.descriptors T mode
sh Events
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  [WaitFd] -> IO WaitFd
threadWaitPolls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Fd -> [WaitFd]
pollWaits forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Wait for new input to be available from the sequencer (even if there is already input in the buffer)
threadWaitInput :: Seq.AllowInput mode => Seq.T mode -> IO ()
threadWaitInput :: forall mode. AllowInput mode => T mode -> IO ()
threadWaitInput = forall mode. Events -> T mode -> IO ()
threadWaitEvents Events
Poll.inp

-- | Wait until new output may be drained from the buffer to the sequencer (even if the output buffer is already empty)
threadWaitOutput :: Seq.AllowOutput mode => Seq.T mode -> IO ()
threadWaitOutput :: forall mode. AllowOutput mode => T mode -> IO ()
threadWaitOutput = forall mode. Events -> T mode -> IO ()
threadWaitEvents Events
Poll.out

-- | Wait until new input is available or new output may be drained
threadWaitDuplex :: (Seq.AllowInput mode, Seq.AllowOutput mode) => Seq.T mode -> IO ()
threadWaitDuplex :: forall mode. (AllowInput mode, AllowOutput mode) => T mode -> IO ()
threadWaitDuplex = forall mode. Events -> T mode -> IO ()
threadWaitEvents (Events
Poll.inp forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
EnumSet..|. Events
Poll.out)

catchFull :: IO a -> IO a -> IO a
catchFull :: forall a. IO a -> IO a -> IO a
catchFull IO a
f IO a
e = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isFullError) IO a
f (\() -> IO a
e)

catchIntr :: IO a -> IO a
catchIntr :: forall a. IO a -> IO a
catchIntr IO a
f = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Errno
eINTR forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> Errno
code) IO a
f (\() -> forall a. IO a -> IO a
catchIntr IO a
f)

-- | A thread-compatible version of @Sound.ALSA.Sequencer.Event.input@.
-- This call is always blocking (unless there are already event in the input
-- buffer) but will not block other threads.  The sequencer, however, must be
-- set non-blocking or this will not work as expected.
input :: Seq.AllowInput mode => Seq.T mode -> IO Event.T
input :: forall mode. AllowInput mode => T mode -> IO T
input T mode
sh = do
  Word
n <- forall a. IO a -> IO a
catchIntr forall a b. (a -> b) -> a -> b
$ forall mode. AllowInput mode => T mode -> Bool -> IO Word
Event.inputPending T mode
sh Bool
True
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
n forall a. Eq a => a -> a -> Bool
== Word
0) forall a b. (a -> b) -> a -> b
$ forall mode. AllowInput mode => T mode -> IO ()
threadWaitInput T mode
sh
  forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a -> IO a
catchFull (forall mode. AllowInput mode => T mode -> IO T
Event.input T mode
sh) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall mode. AllowInput mode => T mode -> IO ()
threadWaitInput T mode
sh forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>)

-- | A thread-compatible version of @Sound.ALSA.Sequencer.Event.output@.
-- This call is always blocking (unless there is space in the output
-- buffer) but will not block other threads.  The sequencer, however, must be
-- set non-blocking or this will not work as expected.
output :: Seq.AllowOutput mode => Seq.T mode -> Event.T -> IO Word
output :: forall mode. AllowOutput mode => T mode -> T -> IO Word
output T mode
sh T
ev =
  forall mode. AllowOutput mode => T mode -> T -> IO Word
Event.outputBuffer T mode
sh T
ev forall a. IO a -> IO a -> IO a
`catchFull` do
    forall mode. AllowOutput mode => T mode -> IO ()
threadWaitOutput T mode
sh
    Word
_ <- forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T mode
sh forall a. IO a -> IO a -> IO a
`catchFull` forall (m :: * -> *) a. Monad m => a -> m a
return (-Word
1)
    forall mode. AllowOutput mode => T mode -> T -> IO Word
output T mode
sh T
ev

-- | A thread-compatible version of @Sound.ALSA.Sequencer.Event.drainBuffer@.
-- This call is always blocking but will not block other threads.  The
-- sequencer, however, must be set non-blocking or this will not work as
-- expected.
drainOutput :: Seq.AllowOutput mode => Seq.T mode -> IO ()
drainOutput :: forall mode. AllowOutput mode => T mode -> IO ()
drainOutput T mode
sh = do
  Word
n <- forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T mode
sh forall a. IO a -> IO a -> IO a
`catchFull` forall (m :: * -> *) a. Monad m => a -> m a
return (-Word
1)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
n forall a. Eq a => a -> a -> Bool
/= Word
0) forall a b. (a -> b) -> a -> b
$ do
    forall mode. AllowOutput mode => T mode -> IO ()
threadWaitOutput T mode
sh
    forall mode. AllowOutput mode => T mode -> IO ()
drainOutput T mode
sh