module Sound.Pulse.Mainloop.Simple
( MainloopImpl
, getMainloopImpl
, doIteration
, doLoop
)
where
import Data.Word (Word)
import Control.Applicative ((<$>), (<*>))
import System.Timeout (timeout)
import Data.Maybe (listToMaybe, fromJust, isJust)
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad (void, join, when, filterM)
import Data.IORef
import Data.List (insertBy, delete, deleteBy)
import Data.Ord (comparing)
import System.Posix.IO (createPipe, fdWrite, fdRead)
import System.Posix.Types (Fd(..))
import Sound.Pulse.Mainloop
import Data.Time
#if MIN_VERSION_base(4,7,0)
#else
import Control.Concurrent.STM.TVar
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM fd = do
m <- newTVarIO False
_ <- forkIO $ do
threadWaitRead fd
atomically $ writeTVar m True
let waitAction = do b <- readTVar m
if b then return () else retry
let killAction = return ()
return (waitAction, killAction)
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM fd = do
m <- newTVarIO False
_ <- forkIO $ do
threadWaitWrite fd
atomically $ writeTVar m True
let waitAction = do b <- readTVar m
if b then return () else retry
let killAction = return ()
return (waitAction, killAction)
#endif
data IOEvent = IOEvent
{ ioCallback :: [PAIOEventFlags] -> IO ()
, ioFd :: Fd
, ioImpl :: MainloopImpl
, ioID :: Word
, ioEvents :: IORef ([PAIOEventFlags])
, ioDestroy :: IORef (IO ())
}
instance Eq IOEvent where
x == y = ioID x == ioID y
data TimeEvent = TimeEvent
{ timeCallback :: PATime -> IO ()
, timeImpl :: MainloopImpl
, timeID :: Word
, timeDeadline :: IORef(PATime)
, timeDestroy :: IORef(IO ())
}
instance Eq TimeEvent where
x == y = timeID x == timeID y
data DeferEvent = DeferEvent
{ deferCallback :: IO ()
, deferImpl :: MainloopImpl
, deferID :: Word
, deferEnabled :: IORef (Bool)
, deferDestroy :: IORef (IO ())
}
instance Eq DeferEvent where
x == y = deferID x == deferID y
data MainloopImpl = MainloopImpl
{ implIOEvents :: IORef [IOEvent]
, implTimeEvents :: IORef [(PATime, TimeEvent)]
, implTimeDisable :: IORef [TimeEvent]
, implDeferEvents :: IORef [DeferEvent]
, implIOCount :: IORef Word
, implTimeCount :: IORef Word
, implDeferCount :: IORef Word
, implRunning :: IORef (Maybe Int)
, implPipe :: (Fd, Fd)
}
waitReadEvent :: IOEvent -> IO (STM (PAIOEventFlags, IOEvent))
waitReadEvent evt = do
(wait, _) <- threadWaitReadSTM $ ioFd evt
return $ do
wait
return (PAIOEventInput, evt)
waitWriteEvent :: IOEvent -> IO (STM (PAIOEventFlags, IOEvent))
waitWriteEvent evt = do
(wait, _) <- threadWaitWriteSTM $ ioFd evt
return $ do
wait
return (PAIOEventOutput, evt)
splitEvents :: [IOEvent] -> IO ([IOEvent], [IOEvent])
splitEvents [] = return ([], [])
splitEvents (x:xs) = do
(tr, tw) <- splitEvents xs
events <- readIORef $ ioEvents x
let cr = if PAIOEventInput `elem` events then (x:) else id
let cw = if PAIOEventOutput `elem` events then (x:) else id
when (PAIOEventHangup `elem` events) (fail "PASimple does not support Hangup")
when (PAIOEventError `elem` events) (fail "PASimple does not support Error")
return (cr tr, cw tw)
waitEvents :: MainloopImpl -> IO (STM (PAIOEventFlags, IOEvent))
waitEvents impl = do
(readEvt, writeEvt) <- splitEvents =<< readIORef (implIOEvents impl)
readEvts <- mapM waitReadEvent readEvt
writeEvts <- mapM waitWriteEvent writeEvt
let readSTM = foldr (<|>) retry readEvts
let writeSTM = foldr (<|>) retry writeEvts
return (readSTM <|> writeSTM)
doRun :: MainloopImpl -> IO ()
doRun impl = do
(pipeWait, _) <- threadWaitReadSTM . fst . implPipe $ impl
wait <- waitEvents impl
nextT <- fmap snd . listToMaybe <$> readIORef (implTimeEvents impl)
capp <- case nextT of
Nothing -> return (fmap Just)
Just x -> do
now <- getTime
evt <- readIORef $ timeDeadline x
return . timeout $ if now > evt
then 0
else fromIntegral (timeToUS (getDiff evt now))
ret <- capp (atomically ((Right <$> wait) <|> (Left <$> pipeWait)))
case ret of
Nothing -> do
let evt = fromJust nextT
time <- readIORef $ timeDeadline evt
atomModifyIORef (implTimeEvents impl) tail
atomModifyIORef (implTimeDisable impl) (evt:)
timeCallback evt time
Just (Right (flag, evt)) -> do
ioCallback evt [flag]
Just (Left _) -> do
_ <- fdRead (fst . implPipe $ impl) 512
return ()
doIteration :: MainloopImpl -> IO ()
doIteration impl = do
defers <- readIORef $ implDeferEvents impl
actives <- filterM (readIORef . deferEnabled) defers
if null actives
then doRun impl
else do
mapM_ deferCallback actives
doLoop :: MainloopImpl -> IO Int
doLoop impl = do
doIteration impl
cont <- readIORef $ implRunning impl
if isJust cont
then return (fromJust cont)
else doLoop impl
getMainloopImpl :: IO MainloopImpl
getMainloopImpl = MainloopImpl
<$> newIORef []
<*> newIORef []
<*> newIORef []
<*> newIORef []
<*> newIORef 0
<*> newIORef 0
<*> newIORef 0
<*> newIORef Nothing
<*> createPipe
atomModifyIORef :: IORef a -> (a -> a) -> IO ()
atomModifyIORef ref fun = void $ atomicModifyIORef ref (fun &&& id)
removeTimeEvent :: TimeEvent -> IO ()
removeTimeEvent evt =
atomModifyIORef (implTimeEvents . timeImpl $ evt) (deleteBy (\x y -> snd x == snd y) (dummyTime, evt))
wakeImpl :: MainloopImpl -> IO ()
wakeImpl = void . flip fdWrite "wakeup" . snd . implPipe
instance PAMainloop MainloopImpl where
newtype PAIOEvent MainloopImpl = PAIOEvent IOEvent
newtype PATimeEvent MainloopImpl = PATimeEvent TimeEvent
newtype PADeferEvent MainloopImpl = PADeferEvent DeferEvent
ioNew :: MainloopImpl -> Fd -> [PAIOEventFlags] -> ([PAIOEventFlags] -> IO ()) -> IO (PAIOEvent MainloopImpl)
ioNew impl fd flags callback = do
count <- atomicModifyIORef (implIOCount impl) ((+1) &&& id)
evt <- IOEvent callback fd impl count <$> newIORef flags <*> newIORef (return ())
atomModifyIORef (implIOEvents impl) (evt:)
wakeImpl impl
return $ PAIOEvent evt
ioEnable :: (PAIOEvent MainloopImpl) -> [PAIOEventFlags] -> IO ()
ioEnable (PAIOEvent x) flags = do
atomicWriteIORef (ioEvents x) flags
wakeImpl $ ioImpl x
ioFree :: (PAIOEvent MainloopImpl) -> IO ()
ioFree (PAIOEvent x) = do
atomModifyIORef (implIOEvents . ioImpl $ x) (delete x)
join . readIORef . ioDestroy $ x
wakeImpl $ ioImpl x
ioSetDestroy :: (PAIOEvent MainloopImpl) -> IO () -> IO ()
ioSetDestroy (PAIOEvent x) = atomicWriteIORef (ioDestroy x)
timeNew :: MainloopImpl -> PATime -> (PATime -> IO ()) -> IO (PATimeEvent MainloopImpl)
timeNew impl time callback = do
count <- atomicModifyIORef (implTimeCount impl) ((+1) &&& id)
evt <- TimeEvent callback impl count <$> newIORef time <*> newIORef (return ())
atomModifyIORef (implTimeEvents impl) (insertBy (comparing fst) (time, evt))
wakeImpl impl
return $ PATimeEvent evt
timeRestart :: PATimeEvent MainloopImpl -> PATime -> IO ()
timeRestart (PATimeEvent evt) time = do
removeTimeEvent evt
writeIORef (timeDeadline evt) time
atomModifyIORef (implTimeEvents $ timeImpl evt) (insertBy (comparing fst) (time, evt) . (filter ((/= evt) . snd)))
atomModifyIORef (implTimeDisable $ timeImpl evt) (filter (/=evt))
wakeImpl $ timeImpl evt
timeFree :: PATimeEvent MainloopImpl -> IO ()
timeFree (PATimeEvent x) = do
removeTimeEvent x
atomicWriteIORef (timeDeadline x) dummyTime
join . readIORef . timeDestroy $ x
wakeImpl $ timeImpl x
timeSetDestroy :: PATimeEvent MainloopImpl -> IO () -> IO ()
timeSetDestroy (PATimeEvent x) = atomicWriteIORef (timeDestroy x)
deferNew :: MainloopImpl -> IO () -> IO (PADeferEvent MainloopImpl)
deferNew impl callback = do
count <- atomicModifyIORef (implDeferCount impl) ((+1) &&& id)
evt <- DeferEvent callback impl count <$> newIORef True <*> newIORef (return ())
atomModifyIORef (implDeferEvents impl) (evt:)
wakeImpl impl
return $ PADeferEvent evt
deferEnable :: PADeferEvent MainloopImpl -> Bool -> IO ()
deferEnable (PADeferEvent x) = atomicWriteIORef (deferEnabled x)
deferFree :: PADeferEvent MainloopImpl -> IO ()
deferFree (PADeferEvent x) = do
atomModifyIORef (implDeferEvents . deferImpl $ x) (delete x)
join . readIORef . deferDestroy $ x
deferSetDestroy :: PADeferEvent MainloopImpl -> IO () -> IO ()
deferSetDestroy (PADeferEvent x) = atomicWriteIORef (deferDestroy x)
quitLoop :: MainloopImpl -> Int -> IO ()
quitLoop impl val = do
atomicWriteIORef (implRunning impl) $ Just val
wakeImpl impl