hsc3-server 0.3.2 → 0.4.0
raw patch · 12 files changed
+785/−658 lines, 12 filesdep +lifted-basedep +monad-controldep +resourcetdep −data-accessordep ~basedep ~bitsetdep ~containersnew-component:exe:hsc3-hellonew-component:exe:hsc3-sine-grains
Dependencies added: lifted-base, monad-control, resourcet, transformers-base, unix
Dependencies removed: data-accessor
Dependency ranges changed: base, bitset, containers, deepseq, failure, hosc, hsc3, hsc3-process, random, strict-concurrency, transformers
Files
- Sound/SC3/Server/Connection.hs +22/−94
- Sound/SC3/Server/Monad.hs +143/−52
- Sound/SC3/Server/Monad/Command.hs +48/−39
- Sound/SC3/Server/Monad/Process.hs +26/−0
- Sound/SC3/Server/Monad/Request.hs +345/−0
- Sound/SC3/Server/Monad/Send.hs +0/−347
- Sound/SC3/Server/Process/Monad.hs +0/−41
- Sound/SC3/Server/State.hs +20/−58
- examples/hello.hs +40/−0
- examples/sine-grains.hs +69/−0
- hsc3-server.cabal +72/−19
- include/Accessor.h +0/−8
Sound/SC3/Server/Connection.hs view
@@ -1,107 +1,56 @@ {-# LANGUAGE ExistentialQuantification , FlexibleContexts , GeneralizedNewtypeDeriving #-}--- | A 'Connection' encapsulates the transport needed for communicating with the synthesis server, the client-side state (e.g. resource id allocators) and various synchronisation primitives.+-- | A 'Connection' encapsulates the communication with the synthesis server.+-- This module provides functions for opening and closing connections, as well+-- as communication and synchronisation primitives. module Sound.SC3.Server.Connection ( Connection- , state- , new+ -- * Creation and termination+ , open , close- -- * Allocation- , alloc- , free- , allocMany- , freeMany- , allocRange- , freeRange -- * Communication and synchronisation , send , waitFor , waitFor_ , waitForAll , waitForAll_- , sync- , unsafeSync ) where import Control.Concurrent (forkIO) import Control.Concurrent.MVar import Control.Concurrent.Chan-import Control.Monad (liftM, replicateM, void)-import Data.Accessor-import Sound.OpenSoundControl (Datum(..), OSC(..), Transport, immediately)+import Control.Monad (replicateM, void)+import Sound.OpenSoundControl (OSC(..), Transport) import qualified Sound.OpenSoundControl as OSC-import Sound.SC3 (notify)-import Sound.SC3.Server.Notification (Notification(..), synced)-import Sound.SC3.Server.Allocator (Id, IdAllocator, Range, RangeAllocator)-import qualified Sound.SC3.Server.Allocator as Alloc+import Sound.SC3.Server.Notification (Notification(..)) import Sound.SC3.Server.Connection.ListenerMap (Listener, ListenerId, ListenerMap) import qualified Sound.SC3.Server.Connection.ListenerMap as ListenerMap-import Sound.SC3.Server.State (Allocator, State, SyncId)-import qualified Sound.SC3.Server.State as State -data Connection = forall t . Transport t => Connection t (MVar State) (MVar ListenerMap)--state :: Connection -> MVar State-state (Connection _ s _) = s+data Connection = forall t . Transport t => Connection t (MVar ListenerMap) listeners :: Connection -> MVar ListenerMap-listeners (Connection _ _ l) = l--initServer :: Connection -> IO ()-initServer c = sync c (Bundle immediately [notify True])+listeners (Connection _ l) = l recvLoop :: Connection -> IO ()-recvLoop c@(Connection t _ _) = do+recvLoop c@(Connection t ls) = do osc <- OSC.recv t- withMVar (listeners c) (ListenerMap.broadcast osc)+ withMVar ls (ListenerMap.broadcast osc) recvLoop c --- | Create a new connection given the initial server state and an OSC transport.-new :: Transport t => State -> t -> IO Connection-new s t = do- ios <- newMVar s- lm <- newMVar =<< ListenerMap.empty- let c = Connection t ios lm- _ <- forkIO $ recvLoop c- initServer c+-- | Create a new connection given an OSC transport.+open :: Transport t => t -> IO Connection+open t = do+ ls <- newMVar =<< ListenerMap.empty+ let c = Connection t ls+ void $ forkIO $ recvLoop c return c -- | Close the connection. -- -- The behavior of sending messages after closing the connection is undefined. close :: Connection -> IO ()-close (Connection t _ _) = OSC.close t---- ====================================================================--- Allocation--withAllocator :: Connection -> Allocator a -> (a -> IO (b, a)) -> IO b-withAllocator c a f = modifyMVar (state c) $ \s -> do- let x = s ^. a- (i, x') <- f x- return $ (a ^= x' $ s, i)--withAllocator_ :: Connection -> Allocator a -> (a -> IO a) -> IO ()-withAllocator_ c a f = withAllocator c a $ liftM ((,)()) . f--alloc :: IdAllocator a => Connection -> Allocator a -> IO (Id a)-alloc c a = withAllocator c a Alloc.alloc--free :: IdAllocator a => Connection -> Allocator a -> Id a -> IO ()-free c a = withAllocator_ c a . Alloc.free--allocMany :: IdAllocator a => Connection -> Allocator a -> Int -> IO [Id a]-allocMany c a = withAllocator c a . Alloc.allocMany--freeMany :: IdAllocator a => Connection -> Allocator a -> [Id a] -> IO ()-freeMany c a = withAllocator_ c a . Alloc.freeMany--allocRange :: RangeAllocator a => Connection -> Allocator a -> Int -> IO (Range (Id a))-allocRange c a = withAllocator c a . Alloc.allocRange--freeRange :: RangeAllocator a => Connection -> Allocator a -> Range (Id a) -> IO ()-freeRange c a = withAllocator_ c a . Alloc.freeRange+close (Connection t _) = OSC.close t -- ==================================================================== -- Communication and synchronization@@ -113,21 +62,19 @@ Nothing -> return () Just a -> f a --- | Add a listener.------ Listeners are entered in a hash table, although the allocation behavior may be more stack-like.+-- | Add a listener to the listener map. addListener :: Connection -> Listener -> IO ListenerId addListener c l = modifyMVar (listeners c) $ \lm -> do (uid, lm') <- ListenerMap.add l lm return (lm', uid) --- | Remove a listener.+-- | Remove a listener from the listener map. removeListener :: Connection -> ListenerId -> IO () removeListener c uid = modifyMVar_ (listeners c) (ListenerMap.delete uid) -- | Send an OSC packet asynchronously. send :: Connection -> OSC -> IO ()-send (Connection t _ _) = OSC.send t+send (Connection t _) = OSC.send t -- | Send an OSC packet and wait for a notification. --@@ -167,22 +114,3 @@ waitForAll_ :: Connection -> OSC -> [Notification a] -> IO () waitForAll_ c osc ns = void $ waitForAll c osc ns --- | Append a @\/sync@ message to an OSC packet.-appendSync :: OSC -> SyncId -> OSC-appendSync p i =- case p of- m@(Message _ _) -> Bundle immediately [m, s]- (Bundle t xs) -> Bundle t (xs ++ [s])- where s = Message "/sync" [Int (fromIntegral i)]---- | Send an OSC packet and wait for the synchronization barrier.-sync :: Connection -> OSC -> IO ()-sync c osc = do- i <- alloc c State.syncIdAllocator- waitFor_ c (osc `appendSync` i) (synced i)- free c State.syncIdAllocator i---- NOTE: This is only guaranteed to work with a transport that preserves--- packet order. NOTE 2: And not even then ;)-unsafeSync :: Connection -> IO ()-unsafeSync c = sync c (Bundle immediately [])
Sound/SC3/Server/Monad.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE FlexibleContexts+ , FlexibleInstances , GeneralizedNewtypeDeriving- , MultiParamTypeClasses #-}+ , MultiParamTypeClasses+ , TypeFamilies+ , UndecidableInstances #-} module Sound.SC3.Server.Monad ( -- * Server Monad ServerT , runServerT+ , capture , Server , runServer- , liftIO- , connection -- * Server options , MonadServer(..) , serverOption@@ -39,50 +41,110 @@ ) where import Control.Applicative-import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.Lifted (ThreadId)+import qualified Control.Concurrent.Lifted as CL import Control.Concurrent.MVar.Strict+import Control.DeepSeq (NFData) import Control.Monad (MonadPlus, liftM)+import Control.Monad.Base (MonadBase(..), liftBaseDefault) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Reader (ReaderT(..), ask, asks)-import Control.Monad.Trans.Class (MonadTrans)-import Data.Accessor-import Sound.OpenSoundControl (OSC)+import Control.Monad.Trans.Reader (ReaderT(..))+import qualified Control.Monad.Trans.Reader as R+import Control.Monad.Trans.Resource (MonadResource, MonadThrow)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control+import Sound.OpenSoundControl (Datum(..), OSC(..), immediately) import Sound.SC3.Server.Allocator (Id, IdAllocator, RangeAllocator, Range)+import qualified Sound.SC3.Server.Allocator as A+import Sound.SC3.Server.Command (notify) import Sound.SC3.Server.Connection (Connection) import qualified Sound.SC3.Server.Connection as C-import Sound.SC3.Server.Notification (Notification)-import Sound.SC3.Server.Options (ServerOptions)-import Sound.SC3.Server.State ( Allocator- , BufferId, BufferIdAllocator, bufferIdAllocator- , BusId, BusIdAllocator, audioBusIdAllocator, controlBusIdAllocator- , NodeId, NodeIdAllocator, nodeIdAllocator- , SyncId, SyncIdAllocator, syncIdAllocator- , State)+import Sound.SC3.Server.Notification (Notification, synced)+import Sound.SC3.Server.Process.Options (ServerOptions)+import Sound.SC3.Server.State ( BufferId, BufferIdAllocator + , BusId, BusIdAllocator+ , NodeId, NodeIdAllocator+ , SyncId, SyncIdAllocator+ ) import qualified Sound.SC3.Server.State as State -newtype ServerT m a = ServerT (ReaderT Connection m a)- deriving (Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadTrans)+data State = State {+ _serverOptions :: ServerOptions+ , _connection :: Connection+ , _syncIdAllocator :: MVar SyncIdAllocator+ , _nodeIdAllocator :: MVar NodeIdAllocator+ , _bufferIdAllocator :: MVar BufferIdAllocator+ , _controlBusIdAllocator :: MVar BusIdAllocator+ , _audioBusIdAllocator :: MVar BusIdAllocator+ } +newtype ServerT m a = ServerT { unServerT :: ReaderT State m a }+ deriving (Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadResource, MonadThrow, MonadTrans)+ type Server = ServerT IO -liftConn :: MonadIO m => (Connection -> IO a) -> ServerT m a-liftConn f = ServerT $ ask >>= \c -> liftIO (f c)+instance MonadBase b m => MonadBase b (ServerT m) where+ {-# INLINE liftBase #-}+ liftBase = liftBaseDefault -liftState :: MonadIO m => (State -> a) -> ServerT m a-liftState f = ServerT $ asks C.state >>= liftIO . readMVar >>= return . f+instance MonadTransControl ServerT where+ newtype StT ServerT a = StServerT {unStServerT::a}+ {-# INLINE liftWith #-}+ liftWith f = ServerT $ ReaderT $ \r -> f $ \t -> liftM StServerT $ runReaderT (unServerT t) r+ {-# INLINE restoreT #-}+ restoreT = ServerT . ReaderT . const . liftM unStServerT +instance MonadBaseControl b m => MonadBaseControl b (ServerT m) where+ newtype StM (ServerT m) a = StMT { unStMT :: ComposeSt ServerT m a }+ {-# INLINE liftBaseWith #-}+ liftBaseWith = defaultLiftBaseWith StMT+ {-# INLINE restoreM #-}+ restoreM = defaultRestoreM unStMT++newtype Allocator a = Allocator (State -> MVar a)++syncIdAllocator :: Allocator SyncIdAllocator+syncIdAllocator = Allocator _syncIdAllocator++nodeIdAllocator :: Allocator NodeIdAllocator+nodeIdAllocator = Allocator _nodeIdAllocator++bufferIdAllocator :: Allocator BufferIdAllocator+bufferIdAllocator = Allocator _bufferIdAllocator++controlBusIdAllocator :: Allocator BusIdAllocator+controlBusIdAllocator = Allocator _controlBusIdAllocator++audioBusIdAllocator :: Allocator BusIdAllocator+audioBusIdAllocator = Allocator _audioBusIdAllocator+ -- | Run a 'ServerT' computation given a connection and return the result.-runServerT :: ServerT m a -> Connection -> m a-runServerT (ServerT r) = runReaderT r+runServerT :: MonadIO m => ServerT m a -> ServerOptions -> Connection -> m a+runServerT (ServerT r) so c = do+ sa <- new State.syncIdAllocator+ na <- new State.nodeIdAllocator+ ba <- new State.bufferIdAllocator+ ca <- new State.controlBusIdAllocator+ aa <- new State.audioBusIdAllocator+ let s = State so c sa na ba ca aa+ runReaderT (init >> r) s+ where + as = State.mkAllocators so+ new :: (IdAllocator a, NFData a, MonadIO m) => (State.Allocators -> a) -> m (MVar a)+ new f = liftIO $ newMVar (f as)+ -- Register with server to receive notifications.+ (ServerT init) = sync (Bundle immediately [notify True]) -- | Run a 'Server' computation given a connection and return the result in the IO monad.-runServer :: Server a -> Connection -> IO a+runServer :: Server a -> ServerOptions -> Connection -> IO a runServer = runServerT --- | Return the connection.-connection :: MonadIO m => ServerT m Connection-connection = liftConn return+-- | Capture server state for later execution.+capture :: Monad m => ServerT m (ServerT m a -> m a)+capture = ServerT $ do+ s <- R.ask+ return $ \(ServerT m) -> R.runReaderT m s class Monad m => MonadServer m where -- | Return the server options.@@ -93,8 +155,8 @@ serverOption = flip liftM serverOptions -- serverOptions :: MonadIO m => ServerT m ServerOptions-instance MonadIO m => MonadServer (ServerT m) where- serverOptions = liftState (getVal State.serverOptions)+instance Monad m => MonadServer (ServerT m) where+ serverOptions = ServerT $ R.asks _serverOptions -- | Monadic resource id management interface. class Monad m => MonadIdAllocator m where@@ -102,37 +164,50 @@ rootNodeId :: m NodeId -- | Allocate an id using the given allocator.- alloc :: (IdAllocator a) => Allocator a -> m (Id a)+ alloc :: (IdAllocator a, NFData a) => Allocator a -> m (Id a) -- | Free an id using the given allocator.- free :: (IdAllocator a) => Allocator a -> Id a -> m ()+ free :: (IdAllocator a, NFData a) => Allocator a -> Id a -> m () -- | Allocate a number of ids using the given allocator.- allocMany :: (IdAllocator a) => Allocator a -> Int -> m [Id a]+ allocMany :: (IdAllocator a, NFData a) => Allocator a -> Int -> m [Id a] -- | Free a number of ids using the given allocator.- freeMany :: (IdAllocator a) => Allocator a -> [Id a] -> m ()+ freeMany :: (IdAllocator a, NFData a) => Allocator a -> [Id a] -> m () -- | Allocate a contiguous range of ids using the given allocator.- allocRange :: (RangeAllocator a) => Allocator a -> Int -> m (Range (Id a))+ allocRange :: (RangeAllocator a, NFData a) => Allocator a -> Int -> m (Range (Id a)) -- | Free a contiguous range of ids using the given allocator.- freeRange :: (RangeAllocator a) => Allocator a -> Range (Id a) -> m ()+ freeRange :: (RangeAllocator a, NFData a) => Allocator a -> Range (Id a) -> m () +withAllocator :: (IdAllocator a, NFData a, MonadIO m) => (a -> IO (b, a)) -> Allocator a -> ServerT m b+withAllocator f (Allocator a) = ServerT $ do+ mv <- R.asks a+ liftIO $ modifyMVar mv $ \s -> do+ (i, s') <- f s+ return $! (s', i)++withAllocator_ :: (IdAllocator a, NFData a, MonadIO m) => (a -> IO a) -> Allocator a -> ServerT m ()+withAllocator_ f = withAllocator (liftM ((,)()) . f)+ instance (MonadIO m) => MonadIdAllocator (ServerT m) where- rootNodeId = liftState State.rootNodeId- alloc a = liftConn $ \c -> C.alloc c a- free a i = liftConn $ \c -> C.free c a i- allocMany a n = liftConn $ \c -> C.allocMany c a n- freeMany a is = liftConn $ \c -> C.freeMany c a is- allocRange a n = liftConn $ \c -> C.allocRange c a n- freeRange a r = liftConn $ \c -> C.freeRange c a r+ rootNodeId = return (fromIntegral 0)+ alloc a = withAllocator A.alloc a+ free a i = withAllocator_ (A.free i) a+ allocMany a n = withAllocator (A.allocMany n) a+ freeMany a is = withAllocator_ (A.freeMany is) a+ allocRange a n = withAllocator (A.allocRange n) a+ freeRange a r = withAllocator_ (A.freeRange r) a class Monad m => MonadSendOSC m where send :: OSC -> m () +withConnection :: MonadIO m => (Connection -> IO a) -> ServerT m a+withConnection f = ServerT $ R.asks _connection >>= \c -> liftIO (f c)+ instance MonadIO m => MonadSendOSC (ServerT m) where- send osc = liftConn $ \c -> C.send c osc+ send osc = withConnection $ \c -> C.send c osc class Monad m => MonadRecvOSC m where -- | Wait for a notification and return the result.@@ -145,17 +220,33 @@ waitForAll_ :: OSC -> [Notification a] -> m () instance MonadIO m => MonadRecvOSC (ServerT m) where- waitFor osc n = liftConn $ \c -> C.waitFor c osc n- waitFor_ osc n = liftConn $ \c -> C.waitFor_ c osc n- waitForAll osc ns = liftConn $ \c -> C.waitForAll c osc ns- waitForAll_ osc ns = liftConn $ \c -> C.waitForAll_ c osc ns+ waitFor osc n = withConnection $ \c -> C.waitFor c osc n+ waitFor_ osc n = withConnection $ \c -> C.waitFor_ c osc n+ waitForAll osc ns = withConnection $ \c -> C.waitForAll c osc ns+ waitForAll_ osc ns = withConnection $ \c -> C.waitForAll_ c osc ns +-- | Append a @\/sync@ message to an OSC packet.+appendSync :: OSC -> SyncId -> OSC+appendSync p i =+ case p of+ m@(Message _ _) -> Bundle immediately [m, s]+ (Bundle t xs) -> Bundle t (xs ++ [s])+ where s = Message "/sync" [Int (fromIntegral i)]++-- | Send an OSC packet and wait for the synchronization barrier. sync :: (MonadIO m) => OSC -> ServerT m ()-sync osc = liftConn $ \c -> C.sync c osc+sync osc = do+ i <- alloc syncIdAllocator+ waitFor_ (osc `appendSync` i) (synced i)+ free syncIdAllocator i +-- NOTE: This is only guaranteed to work with a transport that preserves+-- packet order. NOTE 2: And not even then ;) unsafeSync :: (MonadIO m) => ServerT m ()-unsafeSync = liftConn C.unsafeSync+unsafeSync = sync (Bundle immediately []) + -- | Fork a computation in a new thread and return the thread id.-fork :: (MonadIO m) => ServerT IO () -> ServerT m ThreadId-fork a = liftConn $ \c -> forkIO (runServerT a c)+fork :: (MonadBaseControl IO m) => ServerT m () -> ServerT m ThreadId+fork = CL.fork+
Sound/SC3/Server/Monad/Command.hs view
@@ -51,6 +51,7 @@ , g_dumpTree -- ** Buffers , Buffer+ , bufferId , b_alloc , b_read , HeaderFormat(..)@@ -75,22 +76,21 @@ --import qualified Codec.Digest.SHA as SHA import Control.Arrow (first) import Control.Failure (Failure, failure)-import Control.Monad (liftM)+import Control.Monad (liftM, unless) import Control.Monad.IO.Class (MonadIO)+import Sound.OpenSoundControl (OSC(..)) import Sound.SC3 (Rate(..), UGen) import qualified Sound.SC3.Server.Allocator.Range as Range import Sound.SC3.Server.Monad hiding (sync, unsafeSync) import qualified Sound.SC3.Server.Monad as M-import Sound.SC3.Server.Monad.Send-import qualified Sound.SC3.Server.State as State+import Sound.SC3.Server.Monad.Request import qualified Sound.SC3.Server.Synthdef as Synthdef import Sound.SC3.Server.Allocator (AllocFailure(..)) import Sound.SC3.Server.Command (AddAction(..), PrintLevel(..)) import qualified Sound.SC3.Server.Command as C import qualified Sound.SC3.Server.Command.Completion as C import qualified Sound.SC3.Server.Notification as N-import Sound.SC3.Server.Options (ServerOptions(..))-import Sound.OpenSoundControl (OSC(..))+import Sound.SC3.Server.Process.Options (ServerOptions(..)) -- ==================================================================== -- Utils@@ -103,10 +103,10 @@ -- ==================================================================== -- Master controls -status :: MonadIO m => SendT m (Deferred m N.Status)+status :: MonadIO m => RequestT m (Resource m N.Status) status = send C.status >> after N.status_reply (return ()) -dumpOSC :: MonadIO m => PrintLevel -> SendT m ()+dumpOSC :: MonadIO m => PrintLevel -> RequestT m (Resource m ()) dumpOSC p = do i <- M.alloc M.syncIdAllocator send (C.dumpOSC p)@@ -146,7 +146,7 @@ f osc = (mkC C.d_recv C.d_recv' osc) (Synthdef.synthdef name ugen) -- | Remove definition once all nodes using it have ended.-d_free :: Monad m => SynthDef -> SendT m ()+d_free :: Monad m => SynthDef -> RequestT m () d_free = send . C.d_free . (:[]) . name -- ====================================================================@@ -170,19 +170,19 @@ n_wrap = AbstractNode -- | Place node @a@ after node @b@.-n_after :: (Node a, Node b, Monad m) => a -> b -> SendT m ()+n_after :: (Node a, Node b, Monad m) => a -> b -> RequestT m () n_after a b = send $ C.n_after [(fromIntegral (nodeId a), fromIntegral (nodeId b))] -- | Place node @a@ before node @b@.-n_before :: (Node a, Node b, Monad m) => a -> b -> SendT m ()+n_before :: (Node a, Node b, Monad m) => a -> b -> RequestT m () n_before a b = send $ C.n_after [(fromIntegral (nodeId a), fromIntegral (nodeId b))] -- | Fill ranges of a node's control values.-n_fill :: (Node a, Monad m) => a -> [(String, Int, Double)] -> SendT m ()+n_fill :: (Node a, Monad m) => a -> [(String, Int, Double)] -> RequestT m () n_fill n = send . C.n_fill (fromIntegral (nodeId n)) -- | Delete a node.-n_free :: (Node a, MonadIO m) => a -> SendT m ()+n_free :: (Node a, MonadIO m) => a -> RequestT m () n_free n = do send $ C.n_free [fromIntegral (nodeId n)] finally $ M.free M.nodeIdAllocator (nodeId n)@@ -190,9 +190,9 @@ -- | Mapping node controls to buses. class BusMapping n b where -- | Map a node's controls to read from a control bus.- n_map :: (Node n, Bus b, Monad m) => n -> String -> b -> SendT m ()+ n_map :: (Node n, Bus b, Monad m) => n -> String -> b -> RequestT m () -- | Remove a control's mapping to a control bus.- n_unmap :: (Node n, Bus b, Monad m) => n -> String -> b -> SendT m ()+ n_unmap :: (Node n, Bus b, Monad m) => n -> String -> b -> RequestT m () instance BusMapping n ControlBus where n_map n c b = send msg@@ -225,31 +225,31 @@ else C.n_mapa nid [(c, -1)] -- | Query a node.-n_query_ :: (Node a, Monad m) => a -> SendT m ()+n_query_ :: (Node a, Monad m) => a -> RequestT m () n_query_ n = send $ C.n_query [fromIntegral (nodeId n)] -- | Query a node.-n_query :: (Node a, MonadIO m) => a -> SendT m (Deferred m N.NodeNotification)+n_query :: (Node a, MonadIO m) => a -> RequestT m (Resource m N.NodeNotification) n_query n = n_query_ n >> after (N.n_info (nodeId n)) (return ()) -- | Turn node on or off.-n_run_ :: (Node a, Monad m) => a -> Bool -> SendT m ()+n_run_ :: (Node a, Monad m) => a -> Bool -> RequestT m () n_run_ n b = send $ C.n_run [(fromIntegral (nodeId n), b)] -- | Set a node's control values.-n_set :: (Node a, Monad m) => a -> [(String, Double)] -> SendT m ()+n_set :: (Node a, Monad m) => a -> [(String, Double)] -> RequestT m () n_set n = send . C.n_set (fromIntegral (nodeId n)) -- | Set ranges of a node's control values.-n_setn :: (Node a, Monad m) => a -> [(String, [Double])] -> SendT m ()+n_setn :: (Node a, Monad m) => a -> [(String, [Double])] -> RequestT m () n_setn n = send . C.n_setn (fromIntegral (nodeId n)) -- | Trace a node.-n_trace :: (Node a, Monad m) => a -> SendT m ()+n_trace :: (Node a, Monad m) => a -> RequestT m () n_trace n = send $ C.n_trace [fromIntegral (nodeId n)] -- | Move an ordered sequence of nodes.-n_order :: (Node n, Monad m) => AddAction -> n -> [AbstractNode] -> SendT m ()+n_order :: (Node n, Monad m) => AddAction -> n -> [AbstractNode] -> RequestT m () n_order a n = send . C.n_order a (fromIntegral (nodeId n)) . map (fromIntegral.nodeId) -- ====================================================================@@ -260,16 +260,16 @@ instance Node Synth where nodeId (Synth nid) = nid -s_new :: MonadIO m => SynthDef -> AddAction -> Group -> [(String, Double)] -> SendT m Synth+s_new :: MonadIO m => SynthDef -> AddAction -> Group -> [(String, Double)] -> RequestT m Synth s_new d a g xs = do nid <- M.alloc M.nodeIdAllocator send $ C.s_new (name d) (fromIntegral nid) a (fromIntegral (nodeId g)) xs return $ Synth nid -s_new_ :: MonadIO m => SynthDef -> AddAction -> [(String, Double)] -> SendT m Synth+s_new_ :: MonadIO m => SynthDef -> AddAction -> [(String, Double)] -> RequestT m Synth s_new_ d a xs = rootNode >>= \g -> s_new d a g xs -s_release :: (Node a, MonadIO m) => Double -> a -> SendT m ()+s_release :: (Node a, MonadIO m) => Double -> a -> RequestT m (Resource m ()) s_release r n = do send (C.n_set1 (fromIntegral nid) "gate" r) after_ (N.n_end_ nid) (M.free M.nodeIdAllocator nid)@@ -286,28 +286,28 @@ rootNode :: MonadIdAllocator m => m Group rootNode = liftM Group M.rootNodeId -g_new :: MonadIO m => AddAction -> Group -> SendT m Group+g_new :: MonadIO m => AddAction -> Group -> RequestT m Group g_new a p = do- nid <- M.alloc State.nodeIdAllocator+ nid <- M.alloc M.nodeIdAllocator send $ C.g_new [(fromIntegral nid, a, fromIntegral (nodeId p))] return $ Group nid -g_new_ :: MonadIO m => AddAction -> SendT m Group+g_new_ :: MonadIO m => AddAction -> RequestT m Group g_new_ a = rootNode >>= g_new a -g_deepFree :: Monad m => Group -> SendT m ()+g_deepFree :: Monad m => Group -> RequestT m () g_deepFree g = send $ C.g_deepFree [fromIntegral (nodeId g)] -g_freeAll :: Monad m => Group -> SendT m ()+g_freeAll :: Monad m => Group -> RequestT m () g_freeAll g = send $ C.g_freeAll [fromIntegral (nodeId g)] -g_head :: (Node n, Monad m) => Group -> n -> SendT m ()+g_head :: (Node n, Monad m) => Group -> n -> RequestT m () g_head g n = send $ C.g_head [(fromIntegral (nodeId g), fromIntegral (nodeId n))] -g_tail :: (Node n, Monad m) => Group -> n -> SendT m ()+g_tail :: (Node n, Monad m) => Group -> n -> RequestT m () g_tail g n = send $ C.g_tail [(fromIntegral (nodeId g), fromIntegral (nodeId n))] -g_dumpTree :: Monad m => [(Group, Bool)] -> SendT m ()+g_dumpTree :: Monad m => [(Group, Bool)] -> RequestT m () g_dumpTree = send . C.g_dumpTree . map (first (fromIntegral . nodeId)) -- ====================================================================@@ -317,7 +317,7 @@ b_alloc :: MonadIO m => Int -> Int -> Async m Buffer b_alloc n c = mkAsync $ do- bid <- M.alloc State.bufferIdAllocator+ bid <- M.alloc M.bufferIdAllocator let f osc = (mkC C.b_alloc C.b_alloc' osc) (fromIntegral bid) n c return (Buffer bid, f) @@ -401,7 +401,7 @@ b_free :: MonadIO m => Buffer -> Async m () b_free b = mkAsync $ do let bid = bufferId b- M.free State.bufferIdAllocator bid+ M.free M.bufferIdAllocator bid let f osc = (mkC C.b_free C.b_free' osc) (fromIntegral bid) return ((), f) @@ -410,7 +410,7 @@ where f osc = (mkC C.b_zero C.b_zero' osc) (fromIntegral bid) -b_query :: MonadIO m => Buffer -> SendT m (Deferred m N.BufferInfo)+b_query :: MonadIO m => Buffer -> RequestT m (Resource m N.BufferInfo) b_query (Buffer bid) = do send (C.b_query [fromIntegral bid]) after (N.b_info bid) (return ())@@ -422,7 +422,7 @@ class Bus a where rate :: a -> Rate busIdRange :: a -> Range BusId- freeBus :: MonadIdAllocator m => a -> m ()+ freeBus :: (MonadServer m, MonadIdAllocator m) => a -> m () -- | Bus id. busId :: Bus a => a -> BusId@@ -438,19 +438,28 @@ instance Bus AudioBus where rate _ = AR busIdRange = audioBusId- freeBus = M.freeRange M.audioBusIdAllocator . audioBusId+ freeBus b = do+ hw <- isHardwareBus b+ unless hw $ M.freeRange M.audioBusIdAllocator (audioBusId b) -- | Allocate audio bus with the specified number of channels. newAudioBus :: MonadIdAllocator m => Int -> m AudioBus newAudioBus = liftM AudioBus . M.allocRange M.audioBusIdAllocator +-- | Return 'True' if bus is a hardware output or input bus.+isHardwareBus :: MonadServer m => AudioBus -> m Bool+isHardwareBus b = do+ no <- serverOption numberOfOutputBusChannels+ ni <- serverOption numberOfInputBusChannels+ return $ busId b >= 0 && busId b < fromIntegral (no + ni)+ -- | Get hardware input bus. inputBus :: (MonadServer m, Failure AllocFailure m) => Int -> Int -> m AudioBus inputBus n i = do k <- serverOption numberOfOutputBusChannels m <- serverOption numberOfInputBusChannels let r = Range.sized n (fromIntegral (k+i))- if Range.begin r < fromIntegral k || Range.end r >= fromIntegral (k+m)+ if Range.begin r < fromIntegral k || Range.end r > fromIntegral (k+m) then failure InvalidId else return (AudioBus r) @@ -459,7 +468,7 @@ outputBus n i = do k <- serverOption numberOfOutputBusChannels let r = Range.sized n (fromIntegral i)- if Range.begin r < 0 || Range.end r >= fromIntegral k+ if Range.begin r < 0 || Range.end r > fromIntegral k then failure InvalidId else return (AudioBus r)
+ Sound/SC3/Server/Monad/Process.hs view
@@ -0,0 +1,26 @@+module Sound.SC3.Server.Monad.Process (+ withSynth+ , withDefaultSynth+ -- * Re-exported for convenience+ , module Sound.SC3.Server.Process.Options+ , OutputHandler(..)+ , defaultOutputHandler+) where++import qualified Sound.SC3.Server.Connection as Conn+import Sound.SC3.Server.Monad (Server)+import qualified Sound.SC3.Server.Monad as Server+import Sound.SC3.Server.Process (OutputHandler(..), defaultOutputHandler)+import qualified Sound.SC3.Server.Process as Process+import Sound.SC3.Server.Process.Options++withSynth :: ServerOptions -> RTOptions -> OutputHandler -> Server a -> IO a+withSynth serverOptions rtOptions outputHandler action =+ Process.withSynth+ serverOptions+ rtOptions+ outputHandler+ $ \t -> Conn.open t >>= Server.runServer action serverOptions++withDefaultSynth :: Server a -> IO a+withDefaultSynth = withSynth defaultServerOptions defaultRTOptions defaultOutputHandler
+ Sound/SC3/Server/Monad/Request.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE GeneralizedNewtypeDeriving+ , MultiParamTypeClasses #-}++-- | This module provides abstractions for constructing bundles for server+-- resource allocation in a type safe manner. In particular, the exposed types+-- and functions make sure that asynchronous command results cannot be used+-- before they have been allocated on the server.+--+-- TODO: Real usage example+--+-- > (b0, (g, ig, b)) <- immediately !> do+-- > b0 <- async $ b_alloc 1024 1+-- > x <- b_alloc 1024 1 `whenDone` immediately $ \b -> do+-- > b_free b `whenDone` OSC.UTCr t' $ \() -> do+-- > g <- g_new_ AddToTail+-- > ig <- g_new AddToTail g+-- > return $ pure (g, ig, b)+-- > return $ (,) <$> b0 <*> x+module Sound.SC3.Server.Monad.Request+ ( RequestT+ , AllocT+ -- * Resources+ , Resource+ , resource+ , extract+ , after+ , after_+ , finally+ -- * Asynchronous commands+ , Async+ , mkAsync+ , mkAsync_+ , mkAsyncCM+ , whenDone+ {-, asyncM-}+ , async+ -- * Command execution+ , runRequestT+ , exec+ , exec'+ , (!>)+ {-, execPure-}+ {-, (~>)-}+ ) where++import Control.Applicative+import Control.Arrow (second)+import Control.Monad (liftM, when)+import Control.Monad.IO.Class (MonadIO(..))+import qualified Control.Monad.Trans.Class as Trans+import Control.Monad.Trans.State (StateT(..))+import qualified Control.Monad.Trans.State as State+import Data.IORef+import Sound.SC3.Server.Monad (MonadIdAllocator, MonadSendOSC(..), MonadServer, ServerT)+import qualified Sound.SC3.Server.Monad as M+import qualified Sound.SC3.Server.Command as C+import Sound.SC3.Server.Notification (Notification)+import qualified Sound.SC3.Server.Notification as N+import Sound.OpenSoundControl (OSC(..), Time, immediately)++{-++goals:++* after executing action and synchronizing, all server actions have been executed+* server actions are consistent, i.e. asynchronous resources are not used before they are allocated (Resource)++async sets sync state to "needs sync"+whenDone overrides sync state to "has sync"+whenDone adds a sync barrier to the completion packet when its subaction didn't add one (syncIds empty); the subaction always needs to sync!+exec adds a sync barrier when sync state is "needs sync"+-}++-- | Synchronisation state.+data SyncState =+ NoSync -- ^ No synchronisation barrier needed.+ | NeedsSync -- ^ Need to add a synchronisation barrier to the current context.+ | HasSync -- ^ Synchronisation barrier already present in the current context.+ deriving (Eq, Ord, Show)++-- | Internal state used for constructing bundles from 'RequestT' actions.+data State m = State {+ buildOSC :: [OSC] -- ^ Current list of OSC messages.+ , notifications :: [Notification (ServerT m ())] -- ^ Current list of notifications to synchronise on.+ , cleanup :: ServerT m () -- ^ Cleanup action to deallocate resources.+ , timeTag :: Time -- ^ Time tag.+ , syncState :: SyncState -- ^ Synchronisation barrier state.+ }++-- | Construct a 'RequestT' state with a given synchronisation state.+mkState :: Monad m => Time -> SyncState -> State m+mkState = State [] [] (return ())++-- | Push an OSC packet.+pushOSC :: OSC -> State m -> State m+pushOSC osc s = s { buildOSC = osc : buildOSC s }++-- | Return 'True' if the current context contains OSC messages.+hasOSC :: State m -> Bool+hasOSC = not . null . buildOSC++-- | Get the list of OSC packets.+getOSC :: State m -> [OSC]+getOSC = reverse . buildOSC++-- | Representation of a server-side action (or sequence of actions).+newtype RequestT m a = RequestT (StateT (State m) (ServerT m) a)+ deriving (Applicative, Functor, Monad)++instance Monad m => MonadServer (RequestT m) where+ serverOptions = liftServer M.serverOptions++instance MonadIO m => MonadIdAllocator (RequestT m) where+ rootNodeId = liftServer M.rootNodeId+ alloc = liftServer . M.alloc+ free a = liftServer . M.free a+ allocMany a = liftServer . M.allocMany a+ freeMany a = liftServer . M.freeMany a+ allocRange a = liftServer . M.allocRange a+ freeRange a = liftServer . M.freeRange a++-- | Bundles are flattened into the resulting bundle because @scsynth@ doesn't+-- support nested bundles.+instance Monad m => MonadSendOSC (RequestT m) where+ send osc@(Message _ _) = modify (pushOSC osc)+ send (Bundle _ xs) = mapM_ send xs++-- | Execute a RequestT action, returning the result and the final state.+runRequestT_ :: Monad m => Time -> SyncState -> RequestT m a -> ServerT m (a, State m)+runRequestT_ t s (RequestT m) = State.runStateT m (mkState t s)++-- | Get a value from the state.+gets :: Monad m => (State m -> a) -> RequestT m a+gets = RequestT . State.gets++-- | Modify the state in a RequestT action.+modify :: Monad m => (State m -> State m) -> RequestT m ()+modify = RequestT . State.modify++-- | Lift a ServerT action into RequestT.+--+-- This is potentially unsafe and should only be used for the allocation of+-- server resources. Lifting actions that rely on communication and+-- synchronisation primitives will not work as expected.+liftServer :: Monad m => ServerT m a -> RequestT m a+liftServer = RequestT . Trans.lift++-- | Allocation action newtype wrapper.+newtype AllocT m a = AllocT (ServerT m a)+ deriving (Applicative, Functor, MonadIdAllocator, Monad)++-- | Representation of a deferred server resource.+--+-- Resource resource values can only be observed with 'extract' after the+-- surrounding 'RequestT' action has been executed with 'exec'.+newtype Resource m a = Resource { extract :: ServerT m a -- ^ Extract result from deferred resource.+ }+ deriving (Applicative, Functor, Monad)++-- | Return a pure value as a 'Resource' in the 'RequestT' monad transformer.+resource :: Monad m => a -> RequestT m (Resource m a)+resource = return . return++-- | Register a cleanup action that is executed after the notification has been+-- received and return the deferred notification result.+after :: MonadIO m => Notification a -> AllocT m () -> RequestT m (Resource m a)+after n (AllocT m) = do+ v <- liftServer $ liftIO $ newIORef (error "BUG: after: uninitialized IORef")+ modify $ \s -> s { notifications = fmap (liftIO . writeIORef v) n : notifications s+ , cleanup = cleanup s >> m }+ return $ Resource $ liftIO $ readIORef v++-- | Register a cleanup action, to be executed after a notification has been+-- received and ignore the notification result.+after_ :: Monad m => Notification a -> AllocT m () -> RequestT m (Resource m ())+after_ n (AllocT m) = do+ modify $ \s -> s { notifications = fmap (const (return ())) n : notifications s+ , cleanup = cleanup s >> m }+ return $ Resource $ return ()++-- | Register a cleanup action that is executed after all asynchronous commands+-- and notifications have been performed.+finally :: Monad m => AllocT m () -> RequestT m ()+finally (AllocT m) = modify $ \s -> s { cleanup = cleanup s >> m }++-- | Representation of an asynchronous server command. Asynchronous commands+-- are executed asynchronously with respect to other server commands.+--+-- There are two different ways of synchronising with an asynchronous command:+--+-- * using 'whenDone' for server-side synchronisation, or+--+-- * using 'async' and observing the result of a 'RequestT' action after calling+-- 'exec'.+newtype Async m a = Async (RequestT m (a, (Maybe OSC -> OSC)))++-- | Create an asynchronous command from an allocation action.+--+-- The first return value should be a server resource allocated on the client,+-- the second a function that, given a completion packet, returns an OSC packet+-- that asynchronously allocates the resource on the server.+mkAsync :: Monad m => AllocT m (a, (Maybe OSC -> OSC)) -> Async m a+mkAsync (AllocT m) = Async (liftServer m)++-- | Create an asynchronous command from a side effecting OSC function.+mkAsync_ :: Monad m => (Maybe OSC -> OSC) -> Async m ()+mkAsync_ f = mkAsync $ return ((), f)++-- | Create an asynchronous command.+--+-- The completion message will be appended at the end of the returned message.+mkAsyncCM :: Monad m => AllocT m (a, OSC) -> Async m a+mkAsyncCM = mkAsync . liftM (second f)+ where+ f msg Nothing = msg+ f msg (Just cm) = C.withCM msg cm++-- | Add a synchronisation barrier.+addSync :: MonadIO m => RequestT m a -> RequestT m a+addSync m = do+ a <- m+ b <- gets hasOSC+ when b $ do+ s <- gets syncState+ case s of+ NeedsSync -> do+ sid <- liftServer $ M.alloc M.syncIdAllocator+ send (C.sync (fromIntegral sid))+ after_ (N.synced sid) (M.free M.syncIdAllocator sid)+ return ()+ _ -> return ()+ return a++-- | Execute an server-side action after the asynchronous command has+-- finished.+{-whenDone :: MonadIO m => Async m a -> (a -> RequestT m (Resource m b)) -> Async m b-}+{-whenDone (Async m) f = Async $ do-}+ {-(a, g) <- m-}+ {-b <- f a-}+ {-return (b, g)-}++-- | Execute an asynchronous command asynchronously.+whenDone :: MonadIO m => Async m a -> (a -> RequestT m (Resource m b)) -> RequestT m (Resource m b)+whenDone (Async m) f = do+ t <- gets timeTag+ (a, g) <- m+ (b, s) <- liftServer $ runRequestT_ t NeedsSync $ addSync $ f a+ case getOSC s of+ [] -> do+ send (g Nothing)+ modify $ \s' -> s' {+ syncState = max NeedsSync (syncState s')+ , notifications = notifications s' ++ notifications s+ , cleanup = cleanup s' >> cleanup s }+ osc -> do+ let t' = case syncState s of+ HasSync -> immediately+ _ -> t+ send $ g (Just (Bundle t' osc))+ modify $ \s' -> s' {+ syncState = max HasSync (syncState s')+ , notifications = notifications s' ++ notifications s+ , cleanup = cleanup s' >> cleanup s }+ return b++-- | Execute an asynchronous command asynchronously.+async :: (MonadIO m) => Async m a -> RequestT m (Resource m a)+async = flip whenDone (return . return)++{-+-- | Execute an server-side action after the asynchronous command has+-- finished. The corresponding server commands are scheduled at a time @t@ in+-- the future.+whenDone :: MonadIO m => Async m a -> (a -> RequestT m b) -> RequestT m (Resource b)+whenDone (Async m) f = do+ t <- gets timeTag+ (a, g) <- m+ (b, s) <- liftServer $ runRequestT_ t NeedsSync $ addSync (f a)+ let t' = case syncState s of+ HasSync -> immediately+ _ -> t+ send $ g (Just (Bundle t' (getOSC s)))+ modify $ \s' -> s' {+ notifications = notifications s' ++ notifications s+ , cleanup = cleanup s' >> cleanup s+ , syncState = HasSync }+ return b++-- | Execute an asynchronous command asynchronously.+async :: MonadIO m => Async m a -> RequestT m (Resource a)+async (Async m) = do+ (a, g) <- m+ send (g Nothing)+ modify $ setSyncState NeedsSync+ return $ pure a+-}++runRequestT :: MonadIO m => Time -> RequestT m a -> ServerT m (ServerT m a, Maybe (OSC, [Notification (ServerT m ())]))+runRequestT t m = do+ (a, s) <- runRequestT_ t NoSync $ addSync m+ let result = cleanup s >> return a+ case getOSC s of+ [] -> return (result, Nothing)+ osc -> let t' = case syncState s of+ HasSync -> immediately+ _ -> t+ in return (result, Just (Bundle t' osc, notifications s))++-- | Run the 'RequestT' action and return the result.+--+-- All asynchronous commands and notifications are guaranteed to have finished+-- when this function returns.+exec :: MonadIO m => Time -> RequestT m a -> ServerT m a+exec t m = do+ -- (a, s) <- runRequestT_ t NoSync $ addSync m+ -- case getOSC s of+ -- [] -> return ()+ -- osc -> do+ -- -- liftIO $ print osc+ -- let t' = case syncState s of+ -- HasSync -> immediately+ -- _ -> t+ (result, sync) <- runRequestT t m+ case sync of+ Nothing -> return ()+ Just (osc, ns) -> M.waitForAll osc ns >>= sequence_+ result++exec' :: MonadIO m => Time -> RequestT m (Resource m a) -> ServerT m a+exec' t m = exec t m >>= extract++-- | Infix operator version of 'exec'.+(!>) :: MonadIO m => Time -> RequestT m a -> ServerT m a+(!>) = exec++-- | Run a 'RequestT' action that returns a pure result.+--+-- All asynchronous commands and notifications are guaranteed to have finished+-- when this function returns.+{-execPure :: MonadIO m => Time -> RequestT m a -> ServerT m a-}+{-execPure t m = exec t (m >>= return . return)-}++-- | Infix operator version of 'execPure'.+{-(~>) :: MonadIO m => Time -> RequestT m a -> ServerT m a-}+{-(~>) = execPure-}
− Sound/SC3/Server/Monad/Send.hs
@@ -1,347 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving- , MultiParamTypeClasses #-}---- | This module provides abstractions for constructing bundles for server--- resource allocation in a type safe manner. In particular, the exposed types--- and functions make sure that asynchronous command results cannot be used--- before they have been allocated on the server.------ TODO: Real usage example------ > (b0, (g, ig, b)) <- immediately !> do--- > b0 <- async $ b_alloc 1024 1--- > x <- b_alloc 1024 1 `whenDone` immediately $ \b -> do--- > b_free b `whenDone` OSC.UTCr t' $ \() -> do--- > g <- g_new_ AddToTail--- > ig <- g_new AddToTail g--- > return $ pure (g, ig, b)--- > return $ (,) <$> b0 <*> x-module Sound.SC3.Server.Monad.Send- ( SendT- , AllocT- -- * Deferred values- , Deferred- , after- , after_- , finally- -- * Asynchronous commands- , Async- , mkAsync- , mkAsync_- , mkAsyncCM- , whenDone- , asyncM- , async- -- * Command execution- , run- , exec- , (!>)- , execPure- , (~>)- ) where--import Control.Applicative-import Control.Arrow (second)-import Control.Monad (ap, liftM, when)-import Control.Monad.IO.Class (MonadIO(..))-import qualified Control.Monad.Trans.Class as Trans-import Control.Monad.Trans.State (StateT(..))-import qualified Control.Monad.Trans.State as State-import Data.IORef-import Sound.SC3.Server.Monad (MonadIdAllocator, MonadSendOSC(..), MonadServer, ServerT)-import qualified Sound.SC3.Server.Monad as M-import qualified Sound.SC3.Server.State as State-import qualified Sound.SC3.Server.Command as C-import Sound.SC3.Server.Notification (Notification)-import qualified Sound.SC3.Server.Notification as N-import Sound.OpenSoundControl (OSC(..), Time, immediately)--{---goals:--* after executing action and synchronizing, all server actions have been executed-* server actions are consistent, i.e. asynchronous resources are not used before they are allocated (Deferred)--async sets sync state to "needs sync"-whenDone overrides sync state to "has sync"-whenDone adds a sync barrier to the completion packet when its subaction didn't add one (syncIds empty); the subaction always needs to sync!-exec adds a sync barrier when sync state is "needs sync"--}---- | Synchronisation state.-data SyncState =- NoSync -- ^ No synchronisation barrier needed.- | NeedsSync -- ^ Need to add a synchronisation barrier to the current context.- | HasSync -- ^ Synchronisation barrier already present in the current context.- deriving (Eq, Ord, Show)---- | Internal state used for constructing bundles from 'SendT' actions.-data State m = State {- buildOSC :: [OSC] -- ^ Current list of OSC messages.- , notifications :: [Notification (ServerT m ())] -- ^ Current list of notifications to synchronise on.- , cleanup :: ServerT m () -- ^ Cleanup action to deallocate resources.- , timeTag :: Time -- ^ Time tag.- , syncState :: SyncState -- ^ Synchronisation barrier state.- }---- | Construct a 'SendT' state with a given synchronisation state.-mkState :: Monad m => Time -> SyncState -> State m-mkState = State [] [] (return ())---- | Push an OSC packet.-pushOSC :: OSC -> State m -> State m-pushOSC osc s = s { buildOSC = osc : buildOSC s }---- | Return 'True' if the current context contains OSC messages.-hasOSC :: State m -> Bool-hasOSC = not . null . buildOSC---- | Get the list of OSC packets.-getOSC :: State m -> [OSC]-getOSC = reverse . buildOSC---- | Update the synchronisation state.-setSyncState :: SyncState -> State m -> State m-setSyncState ss s | ss > syncState s = s { syncState = ss }- | otherwise = s---- | Representation of a server-side action (or sequence of actions).-newtype SendT m a = SendT (StateT (State m) (ServerT m) a)- deriving (Applicative, Functor, Monad)--instance MonadIO m => MonadServer (SendT m) where- serverOptions = liftServer M.serverOptions--instance MonadIO m => MonadIdAllocator (SendT m) where- rootNodeId = liftServer M.rootNodeId- alloc = liftServer . M.alloc- free a = liftServer . M.free a- allocMany a = liftServer . M.allocMany a- freeMany a = liftServer . M.freeMany a- allocRange a = liftServer . M.allocRange a- freeRange a = liftServer . M.freeRange a---- | Bundles are flattened into the resulting bundle because @scsynth@ doesn't--- support nested bundles.-instance Monad m => MonadSendOSC (SendT m) where- send osc@(Message _ _) = modify (pushOSC osc)- send (Bundle _ xs) = mapM_ send xs---- | Execute a SendT action, returning the result and the final state.-runSendT :: Monad m => Time -> SyncState -> SendT m a -> ServerT m (a, State m)-runSendT t s (SendT m) = State.runStateT m (mkState t s)---- | Get a value from the state.-gets :: Monad m => (State m -> a) -> SendT m a-gets = SendT . State.gets---- | Modify the state in a SendT action.-modify :: Monad m => (State m -> State m) -> SendT m ()-modify = SendT . State.modify---- | Lift a ServerT action into SendT.------ This is potentially unsafe and should only be used for the allocation of--- server resources. Lifting actions that rely on communication and--- synchronisation primitives will not work as expected.-liftServer :: Monad m => ServerT m a -> SendT m a-liftServer = SendT . Trans.lift---- | Allocation action newtype wrapper.-newtype AllocT m a = AllocT (ServerT m a)- deriving (Applicative, MonadIdAllocator, Functor, Monad)---- | Representation of a deferred server resource.------ Deferred resource values can only be observed a return value of the 'SendT'--- action after 'exec' has been called.------ Deferred has 'Applicative' and 'Functor' instances, so that complex values--- can be built from simple ones.-newtype Deferred m a = Deferred { unDefer :: ServerT m a } deriving (Monad)--instance Monad m => Functor (Deferred m) where- fmap f (Deferred a) = Deferred (liftM f a)--instance Monad m => Applicative (Deferred m) where- pure = Deferred . return- (<*>) (Deferred f) (Deferred a) = Deferred (f `ap` a)---- | Construct a deferred value from an IO action.-deferredIO :: MonadIO m => IO a -> Deferred m a-deferredIO = Deferred . liftIO---- | Register a cleanup action, to be executed after a notification has been--- received and return the deferred notification result.-after :: MonadIO m => Notification a -> AllocT m () -> SendT m (Deferred m a)-after n (AllocT m) = do- v <- liftServer $ liftIO $ newIORef (error "BUG: after: uninitialized IORef")- modify $ \s -> s { notifications = fmap (liftIO . writeIORef v) n : notifications s- , cleanup = cleanup s >> m }- return $ deferredIO (readIORef v)---- | Register a cleanup action, to be executed after a notification has been--- received and ignore the notification result.-after_ :: Monad m => Notification a -> AllocT m () -> SendT m ()-after_ n (AllocT m) = modify $ \s -> s { notifications = fmap (const (return ())) n : notifications s- , cleanup = cleanup s >> m }---- | Register a cleanup action, to be executed after all asynchronous commands--- and notification have finished.-finally :: Monad m => AllocT m () -> SendT m ()-finally (AllocT m) = modify $ \s -> s { cleanup = cleanup s >> m }---- | Representation of an asynchronous server command. Asynchronous commands--- are executed asynchronously with respect to other server commands.------ There are two different ways of synchronising with an asynchronous command:------ * using 'whenDone' for server-side synchronisation, or------ * using 'async' and observing the result of a 'SendT' action after calling--- 'exec'.-newtype Async m a = Async (SendT m (a, (Maybe OSC -> OSC)))---- | Create an asynchronous command from an allocation action.------ The first return value should be a server resource allocated on the client,--- the second a function that, given a completion packet, returns an OSC packet--- that asynchronously allocates the resource on the server.-mkAsync :: Monad m => AllocT m (a, (Maybe OSC -> OSC)) -> Async m a-mkAsync (AllocT m) = Async (liftServer m)---- | Create an asynchronous command from a side effecting OSC function.-mkAsync_ :: Monad m => (Maybe OSC -> OSC) -> Async m ()-mkAsync_ f = mkAsync $ return ((), f)---- | Create an asynchronous command.------ The completion message will be appended at the end of the returned message.-mkAsyncCM :: Monad m => AllocT m (a, OSC) -> Async m a-mkAsyncCM = mkAsync . liftM (second f)- where- f msg Nothing = msg- f msg (Just cm) = C.withCM msg cm---- | Add a synchronisation barrier.-addSync :: MonadIO m => SendT m a -> SendT m a-addSync m = do- a <- m- b <- gets hasOSC- when b $ do- s <- gets syncState- case s of- NeedsSync -> do- sid <- liftServer $ M.alloc State.syncIdAllocator- send (C.sync (fromIntegral sid))- after_ (N.synced sid) (M.free State.syncIdAllocator sid)- _ -> return ()- return a---- | Execute an server-side action after the asynchronous command has--- finished.-whenDone :: MonadIO m => Async m a -> (a -> SendT m b) -> Async m b-whenDone (Async m) f = Async $ do- (a, g) <- m- b <- f a- return (b, g)---- | Execute an asynchronous command asynchronously.-asyncM :: MonadIO m => Async m (Deferred m a) -> SendT m (Deferred m a)-asyncM (Async m) = do- t <- gets timeTag- ((a, g), s) <- liftServer $ runSendT t NeedsSync $ addSync m- case getOSC s of- [] -> do- send (g Nothing)- modify $ \s' -> (setSyncState NeedsSync s') {- notifications = notifications s' ++ notifications s- , cleanup = cleanup s' >> cleanup s }- osc -> do- let t' = case syncState s of- HasSync -> immediately- _ -> t- send $ g (Just (Bundle t' osc))- modify $ \s' -> (setSyncState HasSync s') {- notifications = notifications s' ++ notifications s- , cleanup = cleanup s' >> cleanup s }- return a---- | Execute an asynchronous command asynchronously.-async :: MonadIO m => Async m a -> SendT m (Deferred m a)-async = asyncM . flip whenDone (return . pure)--{---- | Execute an server-side action after the asynchronous command has--- finished. The corresponding server commands are scheduled at a time @t@ in--- the future.-whenDone :: MonadIO m => Async m a -> (a -> SendT m b) -> SendT m (Deferred b)-whenDone (Async m) f = do- t <- gets timeTag- (a, g) <- m- (b, s) <- liftServer $ runSendT t NeedsSync $ addSync (f a)- let t' = case syncState s of- HasSync -> immediately- _ -> t- send $ g (Just (Bundle t' (getOSC s)))- modify $ \s' -> s' {- notifications = notifications s' ++ notifications s- , cleanup = cleanup s' >> cleanup s- , syncState = HasSync }- return b---- | Execute an asynchronous command asynchronously.-async :: MonadIO m => Async m a -> SendT m (Deferred a)-async (Async m) = do- (a, g) <- m- send (g Nothing)- modify $ setSyncState NeedsSync- return $ pure a--}--run :: MonadIO m => Time -> SendT m (Deferred m a) -> ServerT m (ServerT m a, Maybe (OSC, [Notification (ServerT m ())]))-run t m = do- (a, s) <- runSendT t NoSync $ addSync m- let result = cleanup s >> unDefer a- case getOSC s of- [] -> return (result, Nothing)- osc -> let t' = case syncState s of- HasSync -> immediately- _ -> t- in return (result, Just (Bundle t' osc, notifications s))---- | Run the 'SendT' action and return the result.------ All asynchronous commands and notifications are guaranteed to have finished--- when this function returns.-exec :: MonadIO m => Time -> SendT m (Deferred m a) -> ServerT m a-exec t m = do- -- (a, s) <- runSendT t NoSync $ addSync m- -- case getOSC s of- -- [] -> return ()- -- osc -> do- -- -- liftIO $ print osc- -- let t' = case syncState s of- -- HasSync -> immediately- -- _ -> t- (action, sync) <- run t m- case sync of- Nothing -> return ()- Just (osc, ns) -> M.waitForAll osc ns >>= sequence_- action---- | Infix operator version of 'exec'.-(!>) :: MonadIO m => Time -> SendT m (Deferred m a) -> ServerT m a-(!>) = exec---- | Run a 'SendT' action that returns a pure result.------ All asynchronous commands and notifications are guaranteed to have finished--- when this function returns.-execPure :: MonadIO m => Time -> SendT m a -> ServerT m a-execPure t m = exec t (m >>= return . pure)---- | Infix operator version of 'execPure'.-(~>) :: MonadIO m => Time -> SendT m a -> ServerT m a-(~>) = execPure
− Sound/SC3/Server/Process/Monad.hs
@@ -1,41 +0,0 @@-module Sound.SC3.Server.Process.Monad (- withSynth- , withDefaultSynth- , withInternal- , withDefaultInternal- -- * Re-exported for convenience- , module Sound.SC3.Server.Options- , OutputHandler(..)- , defaultOutputHandler-) where--import qualified Sound.SC3.Server.Connection as Conn-import qualified Sound.SC3.Server.Internal as Process-import Sound.SC3.Server.Monad (Server)-import qualified Sound.SC3.Server.Monad as Server-import Sound.SC3.Server.Options-import Sound.SC3.Server.Process ( OutputHandler(..), defaultOutputHandler )-import qualified Sound.SC3.Server.Process as Process-import qualified Sound.SC3.Server.State as State--withSynth :: ServerOptions -> RTOptions -> OutputHandler -> Server a -> IO a-withSynth serverOptions rtOptions outputHandler action =- Process.withSynth- serverOptions- rtOptions- outputHandler- $ \t -> Conn.new (State.new serverOptions) t >>= Server.runServer action--withDefaultSynth :: Server a -> IO a-withDefaultSynth = withSynth defaultServerOptions defaultRTOptions defaultOutputHandler--withInternal :: ServerOptions -> RTOptions -> OutputHandler -> Server a -> IO a-withInternal serverOptions rtOptions outputHandler action =- Process.withInternal- serverOptions- rtOptions- outputHandler- $ \t -> Conn.new (State.new serverOptions) t >>= Server.runServer action--withDefaultInternal :: Server a -> IO a-withDefaultInternal = withInternal defaultServerOptions defaultRTOptions defaultOutputHandler
Sound/SC3/Server/State.hs view
@@ -1,20 +1,14 @@ {-# LANGUAGE- CPP- , ExistentialQuantification+ ExistentialQuantification , GADTs , GeneralizedNewtypeDeriving , TypeFamilies #-} -#include "Accessor.h"- -- | Data type for holding server state. -- -- The server state consists mainly of the allocators needed for different types of resources, such as nodes, buffers and buses. module Sound.SC3.Server.State (- State- , serverOptions- , Allocator- , SyncId+ SyncId , SyncIdAllocator , syncIdAllocator , NodeId@@ -27,12 +21,11 @@ , BusIdAllocator , controlBusIdAllocator , audioBusIdAllocator- , rootNodeId- , new+ , Allocators+ , mkAllocators ) where import Control.DeepSeq (NFData(..))-import Data.Accessor import Data.Int (Int32) import Sound.SC3.Server.Allocator (IdAllocator(..), RangeAllocator(..)) import qualified Sound.SC3.Server.Allocator as Alloc@@ -40,10 +33,7 @@ import qualified Sound.SC3.Server.Allocator.SetAllocator as SetAllocator import qualified Sound.SC3.Server.Allocator.SimpleAllocator as SimpleAllocator import qualified Sound.SC3.Server.Allocator.Wrapped as Wrapped-import Sound.SC3.Server.Options (ServerOptions(..))---- | Allocator accessor.-type Allocator a = Accessor State a+import Sound.SC3.Server.Process.Options (ServerOptions(..)) -- | Synchronisation barrier id. newtype SyncId = SyncId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)@@ -113,52 +103,24 @@ instance NFData BusIdAllocator where rnf (BusIdAllocator a) = rnf a `seq` () --- | Server state.-data State = State {- _serverOptions :: !ServerOptions- , _syncIdAllocator :: !SyncIdAllocator- , _nodeIdAllocator :: !NodeIdAllocator- , _bufferIdAllocator :: !BufferIdAllocator- , _controlBusIdAllocator :: !BusIdAllocator- , _audioBusIdAllocator :: !BusIdAllocator+-- | Server allocators.+data Allocators = Allocators {+ syncIdAllocator :: !SyncIdAllocator+ , nodeIdAllocator :: !NodeIdAllocator+ , bufferIdAllocator :: !BufferIdAllocator+ , controlBusIdAllocator :: !BusIdAllocator+ , audioBusIdAllocator :: !BusIdAllocator } -instance NFData State where- rnf (State x1 x2 x3 x4 x5 x6) =- x1 `seq`- rnf x2 `seq`- rnf x3 `seq`- rnf x4 `seq`- rnf x5 `seq`- rnf x6 `seq` ()---- | Server options used to create this instance.-ACCESSOR(serverOptions, _serverOptions, State, ServerOptions)--- | Synchronisation id allocator.-ACCESSOR(syncIdAllocator, _syncIdAllocator, State, SyncIdAllocator)--- | Node id allocator.-ACCESSOR(nodeIdAllocator, _nodeIdAllocator, State, NodeIdAllocator)--- | Buffer id allocator.-ACCESSOR(bufferIdAllocator, _bufferIdAllocator, State, BufferIdAllocator)--- | Control bus id allocator.-ACCESSOR(controlBusIdAllocator, _controlBusIdAllocator, State, BusIdAllocator)--- | Audio bus id allocator.-ACCESSOR(audioBusIdAllocator, _audioBusIdAllocator, State, BusIdAllocator)---- | Root node id.-rootNodeId :: State -> NodeId-rootNodeId = const (NodeId 0)- -- | Create a new state with default allocators.-new :: ServerOptions -> State-new os =- State {- _serverOptions = os- , _syncIdAllocator = sid- , _nodeIdAllocator = nid- , _bufferIdAllocator = bid- , _controlBusIdAllocator = cid- , _audioBusIdAllocator = aid+mkAllocators :: ServerOptions -> Allocators+mkAllocators os =+ Allocators {+ syncIdAllocator = sid+ , nodeIdAllocator = nid+ , bufferIdAllocator = bid+ , controlBusIdAllocator = cid+ , audioBusIdAllocator = aid } where sid = SyncIdAllocator (SimpleAllocator.cons (Alloc.range 0 (maxBound :: SyncId)))
+ examples/hello.hs view
@@ -0,0 +1,40 @@+import Control.Monad.IO.Class (liftIO)+import Sound.SC3.UGen+import Sound.SC3.Server.Monad+import Sound.SC3.Server.Monad.Command+-- You need the hsc3-server-internal package in order to use the internal server+--import Sound.SC3.Server.Monad.Process.Internal (withDefaultInternal)+import Sound.SC3.Server.Monad.Process (withDefaultSynth)+import Sound.SC3.Server.Monad.Request ((!>), async, extract, resource, whenDone)+import Sound.SC3.Server.Notification+import Sound.OpenSoundControl (immediately)+import qualified Sound.OpenSoundControl as OSC++sine = out 0 $ pan2 x (sinOsc KR 1 0) 1+ where x = sinOsc AR (control KR "freq" 440) 0+ * control KR "amp" 1+ * envGen KR (control KR "gate" 1) 1 0 1 RemoveSynth (envASR 1 1 1 EnvLin)++pauseThread = liftIO . OSC.pauseThread++statusLoop = do+ immediately !> status >>= extract >>= liftIO . print+ pauseThread 1+ statusLoop++-- You need the hsc3-server-internal package in order to use the internal server+--run = withDefaultInternal+run = withDefaultSynth++latency = 0.03+ +main = run $ do+ immediately !> dumpOSC TextPrinter+ r <- rootNode+ synth <- extract =<< immediately !> do+ d_recv "hsc3-server:sine" sine `whenDone`+ \sd -> resource =<< s_new sd AddToTail r [("freq", 440), ("amp", 0.2)]+ fork statusLoop+ pauseThread 10+ immediately !> s_release 0 synth+ pauseThread 2
+ examples/sine-grains.hs view
@@ -0,0 +1,69 @@+import Control.Concurrent.MVar+import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Sound.SC3.UGen+import Sound.SC3.Server.Monad+import Sound.SC3.Server.Monad.Command+-- You need the hsc3-server-internal package in order to use the internal server+--import Sound.SC3.Server.Monad.Process.Internal (withDefaultInternal)+import Sound.SC3.Server.Monad.Process (withDefaultSynth)+import Sound.SC3.Server.Monad.Request+import Sound.SC3.Server.Notification+import Sound.OpenSoundControl (immediately)+import qualified Sound.OpenSoundControl as OSC+import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))+import System.Random++sine = out 0 $ pan2 x (sinOsc KR 1 0 * 0.6) 1+ where x = sinOsc AR (control KR "freq" 440) 0+ * control KR "amp" 1+ * envGen KR (control KR "gate" 1) 1 0 1 RemoveSynth (envASR 0.02 1 0.1 EnvLin)++pauseThread :: MonadIO m => Double -> m ()+pauseThread = liftIO . OSC.pauseThread+pauseThreadUntil = liftIO . OSC.pauseThreadUntil++statusLoop = do+ immediately !> status >>= extract >>= liftIO . print+ pauseThread 1+ statusLoop++keepRunning = liftIO . isEmptyMVar++grainLoop quit synthDef delta sustain t = do+ f <- liftIO $ randomRIO (100,800)+ a <- liftIO $ randomRIO (0.1,0.3)+ r <- rootNode+ synth <- OSC.UTCr (t + latency) !> s_new synthDef AddToTail r [("freq", f), ("amp", a)]+ fork $ do+ let t' = t + sustain+ pauseThreadUntil t'+ OSC.UTCr (t' + latency) !> s_release 0 synth+ return ()+ let t' = t + delta+ pauseThreadUntil t'+ b <- keepRunning quit+ when b $ grainLoop quit synthDef delta sustain t'++-- You need the hsc3-server-internal package in order to use the internal server+--run = withDefaultInternal+run = withDefaultSynth++latency = 0.03+ +newBreakHandler :: IO (MVar ())+newBreakHandler = do+ quit <- newEmptyMVar+ void $ installHandler keyboardSignal+ (Catch $ putStrLn "Quitting..." >> putMVar quit ())+ Nothing+ return quit+ +main :: IO ()+main = do+ quit <- newBreakHandler+ run $ do+ sd <- immediately !> async (d_recv "hsc3-server:sine" sine) >>= extract+ fork statusLoop+ grainLoop quit sd 0.03 0.06 =<< liftIO OSC.utcr+ takeMVar quit
hsc3-server.cabal view
@@ -1,5 +1,5 @@ Name: hsc3-server-Version: 0.3.2+Version: 0.4.0 Synopsis: SuperCollider server resource management and synchronization. Description: This library provides abstractions for managing SuperCollider server@@ -16,12 +16,13 @@ Maintainer: Stefan Kersten Stability: experimental Homepage: http://space.k-hornz.de/software/hsc3-server-Tested-With: GHC == 6.10.1, GHC == 6.12.3, GHC == 7.0.1+Tested-With: GHC == 6.10, GHC == 6.12, GHC == 7.0, GHC == 7.2 Build-Type: Simple Cabal-Version: >= 1.9.2 -Extra-Source-Files:- include/Accessor.h+Flag build-examples+ Description: Build example programs+ Default: False Library Exposed-Modules:@@ -37,26 +38,28 @@ Sound.SC3.Server.Connection.ListenerMap.List Sound.SC3.Server.Monad Sound.SC3.Server.Monad.Command- Sound.SC3.Server.Monad.Send+ Sound.SC3.Server.Monad.Process+ Sound.SC3.Server.Monad.Request Sound.SC3.Server.Notification- Sound.SC3.Server.Process.Monad Sound.SC3.Server.State Other-Modules: Sound.SC3.Server.Allocator.BlockAllocator.FreeList Build-Depends: base >= 3 && < 5- , bitset >= 1.0- , containers- , data-accessor >= 0.2- , deepseq >= 1.1- , failure >= 0.1- , hosc >= 0.8- , hsc3 >= 0.11- , hsc3-process >= 0.6- , strict-concurrency- , transformers- Include-Dirs:- include+ , bitset >= 1.0 && < 1.2+ , containers >= 0.2 && < 0.6+ --, data-accessor >= 0.2+ , deepseq >= 1.1 && < 1.4+ , failure >= 0.2 && < 0.3+ , hosc >= 0.8 && < 0.12+ , hsc3 >= 0.11 && < 0.12+ , hsc3-process >= 0.7 && < 0.8+ , lifted-base >= 0.1 && < 0.2+ , monad-control >= 0.3 && < 0.4+ , resourcet >= 0.3 && < 0.4+ , strict-concurrency >= 0.2 && < 0.3+ , transformers >= 0.2 && < 0.4+ , transformers-base >= 0.4 && < 0.5 Ghc-Options: -W Ghc-Prof-Options:@@ -66,6 +69,56 @@ Type: git Location: git://github.com/kaoskorobase/hsc3-server.git +Executable hsc3-hello+ Main-Is: examples/hello.hs+ if flag(build-examples)+ Buildable: True+ else+ Buildable: False+ Build-Depends:+ base >= 3 && < 5+ , bitset >= 1.0 && < 1.2+ , containers >= 0.2 && < 0.6+ , deepseq >= 1.1 && < 1.4+ , failure >= 0.2 && < 0.3+ , hosc >= 0.8 && < 0.12+ , hsc3 >= 0.11 && < 0.12+ , hsc3-process >= 0.7 && < 0.8+ , lifted-base >= 0.1 && < 0.2+ , monad-control >= 0.3 && < 0.4+ , resourcet >= 0.3 && < 0.4+ , strict-concurrency >= 0.2 && < 0.3+ , transformers >= 0.2 && < 0.4+ , transformers-base >= 0.4 && < 0.5+ Ghc-Options:+ -rtsopts -threaded++Executable hsc3-sine-grains+ Main-Is: examples/sine-grains.hs+ if flag(build-examples)+ Buildable: True+ else+ Buildable: False+ Build-Depends:+ base >= 3 && < 5+ , bitset >= 1.0 && < 1.2+ , containers >= 0.2 && < 0.6+ , deepseq >= 1.1 && < 1.4+ , failure >= 0.2 && < 0.3+ , hosc >= 0.8 && < 0.12+ , hsc3 >= 0.11 && < 0.12+ , hsc3-process >= 0.7 && < 0.8+ , lifted-base >= 0.1 && < 0.2+ , monad-control >= 0.3 && < 0.4+ , random >= 1.0 && < 1.1+ , resourcet >= 0.3 && < 0.4+ , strict-concurrency >= 0.2 && < 0.3+ , transformers >= 0.2 && < 0.4+ , transformers-base >= 0.4 && < 0.5+ , unix >= 2.5 && < 2.6+ Ghc-Options:+ -rtsopts -threaded+ Test-Suite hsc3-server-test Type: exitcode-stdio-1.0 Main-Is: test.hs@@ -73,7 +126,7 @@ Sound.SC3.Server.Allocator.Test Sound.SC3.Server.Allocator.Range.Test Build-Depends:- base+ base >= 3 && < 5 , bitset >= 1.0 , deepseq >= 1.1 , failure >= 0.1
− include/Accessor.h
@@ -1,8 +0,0 @@-#ifndef ACCESSOR_H_INCLUDED-#define ACCESSOR_H_INCLUDED--#define ACCESSOR(N,F,T,V) \-N :: Accessor (T) (V) ; \-N = accessor F (\x a -> a { F = x })--#endif /* ACCESSOR_H_INCLUDED */