module Sound.SC3.Server.State.Monad.Request (
Request
, runRequest
, exec
, exec_
, Result
, extract
, AllocT
, after
, after_
, waitFor
, finally
, mkAsync
, mkAsync_
, mkSync
) where
import Control.Applicative (Applicative)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Trans.State as State
import Data.IORef (newIORef, readIORef, writeIORef)
import Sound.OSC.Transport.Monad (SendOSC(..))
import qualified Sound.SC3.Server.Command.Generic as C
import Sound.SC3.Server.Notification (Notification)
import qualified Sound.SC3.Server.Notification as N
import Sound.SC3.Server.State.Monad.Class (MonadIdAllocator(..), RequestOSC, MonadServer)
import qualified Sound.SC3.Server.State.Monad.Class as M
import Sound.OSC (Bundle(..), Message(..), OSC(..), Time, immediately, packetMessages)
data Builder =
BuildDone
| BuildSync Message Builder
| BuildAsync (Maybe Bundle -> Message) Builder
compile :: Time -> Builder -> Bundle
compile t rs = go t rs []
where
go t BuildDone ps = Bundle t ps
go t (BuildSync osc rs') ps = go t rs' (osc : ps)
go t (BuildAsync f rs') ps =
case ps of
[] -> let ps' = [f Nothing]
in go t rs' ps'
_ -> let ps' = [f (Just (Bundle t ps))]
in go immediately rs' ps'
data State m = State {
requests :: Builder
, notifications :: [Notification (m ())]
, cleanup :: m ()
, needsSync :: Bool
}
emptyState :: Monad m => State m
emptyState = State BuildDone [] (return ()) False
newtype Request m a = Request (State.StateT (State m) m a)
deriving (Applicative, Functor, Monad)
lift :: Monad m => m a -> Request m a
lift = Request . Trans.lift
gets :: Monad m => (State m -> a) -> Request m a
gets = Request . State.gets
modify :: Monad m => (State m -> State m) -> Request m ()
modify = Request . State.modify
instance MonadServer m => MonadServer (Request m) where
serverOptions = lift M.serverOptions
rootNodeId = lift M.rootNodeId
instance MonadIdAllocator m => MonadIdAllocator (Request m) where
newtype Allocator (Request m) a = Request_Allocator (Allocator m a)
nodeIdAllocator = Request_Allocator nodeIdAllocator
syncIdAllocator = Request_Allocator syncIdAllocator
bufferIdAllocator = Request_Allocator bufferIdAllocator
audioBusIdAllocator = Request_Allocator audioBusIdAllocator
controlBusIdAllocator = Request_Allocator controlBusIdAllocator
alloc (Request_Allocator a) = lift $ M.alloc a
free (Request_Allocator a) = lift . M.free a
statistics (Request_Allocator a) = lift $ M.statistics a
allocRange (Request_Allocator a) = lift . M.allocRange a
freeRange (Request_Allocator a) = lift . M.freeRange a
instance Monad m => SendOSC (Request m) where
sendOSC osc = modify $ \s ->
s { requests = build
(requests s)
(packetMessages (toPacket osc)) }
where build bs [] = bs
build bs (a:as) = build (BuildSync a bs) as
newtype AllocT m a = AllocT (m a)
deriving (Applicative, Functor, Monad)
instance MonadIdAllocator m => MonadIdAllocator (AllocT m) where
newtype Allocator (AllocT m) a = AllocT_Allocator (Allocator m a)
nodeIdAllocator = AllocT_Allocator nodeIdAllocator
syncIdAllocator = AllocT_Allocator syncIdAllocator
bufferIdAllocator = AllocT_Allocator bufferIdAllocator
audioBusIdAllocator = AllocT_Allocator audioBusIdAllocator
controlBusIdAllocator = AllocT_Allocator controlBusIdAllocator
alloc (AllocT_Allocator a) = AllocT $ M.alloc a
free (AllocT_Allocator a) = AllocT . M.free a
statistics (AllocT_Allocator a) = AllocT $ M.statistics a
allocRange (AllocT_Allocator a) = AllocT . M.allocRange a
freeRange (AllocT_Allocator a) = AllocT . M.freeRange a
newtype Result a = Result (IO a)
deriving (Applicative, Functor, Monad)
extract :: MonadIO m => Result a -> m a
extract (Result a) = liftIO a
after :: MonadIO m => Notification a -> AllocT m () -> Request m (Result a)
after n (AllocT m) = do
v <- lift $ liftIO $ newIORef (error "BUG: after: uninitialized IORef")
modify $ \s -> s { notifications = fmap (liftIO . writeIORef v) n : notifications s
, cleanup = cleanup s >> m }
return $ Result (readIORef v)
after_ :: Monad m => Notification a -> AllocT m () -> Request m ()
after_ n (AllocT m) =
modify $ \s -> s { notifications = fmap (const (return ())) n : notifications s
, cleanup = cleanup s >> m }
waitFor :: MonadIO m => Notification a -> Request m (Result a)
waitFor n = after n (return ())
finally :: Monad m => AllocT m () -> Request m ()
finally (AllocT m) = modify $ \s -> s { cleanup = cleanup s >> m }
mkAsync :: Monad m => AllocT m (a, (Maybe Bundle -> Message)) -> Request m a
mkAsync (AllocT m) = do
(a, f) <- lift m
modify $ \s -> s { requests = BuildAsync f (requests s)
, needsSync = True }
return a
mkAsync_ :: Monad m => (Maybe Bundle -> Message) -> Request m ()
mkAsync_ f = mkAsync $ return ((), f)
mkSync :: MonadIdAllocator m => Request m Message
mkSync = do
sid <- lift $ M.alloc M.syncIdAllocator
after_ (N.synced sid) (M.free M.syncIdAllocator sid)
return $ C.sync (fromIntegral sid)
finish :: MonadIdAllocator m => Request m a -> Request m a
finish m = do
a <- m
b <- gets needsSync
when b $ mkSync >>= sendOSC
return a
runRequest :: (MonadIdAllocator m, RequestOSC m) => Time -> Request m a -> m (a, Maybe (Bundle, [Notification (m ())]), m ())
runRequest t r = do
let Request m = finish r
(a, s) <- State.runStateT m emptyState
let osc = case requests s of
BuildDone -> Nothing
rs -> Just (compile t rs, notifications s)
return (a, osc, cleanup s)
exec :: (MonadIdAllocator m, RequestOSC m) => Time -> Request m a -> m a
exec t r = do
let Request m = finish r
(a, s) <- State.runStateT m emptyState
case requests s of
BuildDone -> return ()
rs -> let osc = compile t rs
ns = notifications s
in M.requestAll osc ns >>= sequence_
cleanup s
return a
exec_ :: (MonadIdAllocator m, RequestOSC m) => Request m a -> m a
exec_ = exec immediately