hsc3-server 0.4.0 → 0.5.0
raw patch · 27 files changed
+1863/−1634 lines, 27 filesdep +ListZipperdep +data-defaultdep +hashtablesdep −deepseqdep −strict-concurrencydep ~basedep ~bitsetdep ~containers
Dependencies added: ListZipper, data-default, hashtables, hsc3-server
Dependencies removed: deepseq, strict-concurrency
Dependency ranges changed: base, bitset, containers, failure, hosc, hsc3, hsc3-process, lifted-base, monad-control, random, resourcet, transformers, transformers-base, unix
Files
- Sound/SC3/Server/Allocator.hs +57/−49
- Sound/SC3/Server/Allocator/BlockAllocator/FirstFit.hs +5/−8
- Sound/SC3/Server/Allocator/BlockAllocator/FreeList.hs +0/−4
- Sound/SC3/Server/Allocator/Range.hs +84/−5
- Sound/SC3/Server/Allocator/SetAllocator.hs +13/−18
- Sound/SC3/Server/Allocator/SimpleAllocator.hs +9/−11
- Sound/SC3/Server/Allocator/Wrapped.hs +9/−9
- Sound/SC3/Server/Connection.hs +52/−87
- Sound/SC3/Server/Connection/ListenerMap.hs +0/−6
- Sound/SC3/Server/Connection/ListenerMap/HashTable.hs +0/−34
- Sound/SC3/Server/Connection/ListenerMap/List.hs +0/−26
- Sound/SC3/Server/Monad.hs +0/−252
- Sound/SC3/Server/Monad/Command.hs +0/−485
- Sound/SC3/Server/Monad/Process.hs +0/−26
- Sound/SC3/Server/Monad/Request.hs +0/−345
- Sound/SC3/Server/Notification.hs +78/−11
- Sound/SC3/Server/State.hs +91/−78
- Sound/SC3/Server/State/Monad.hs +198/−0
- Sound/SC3/Server/State/Monad/Class.hs +65/−0
- Sound/SC3/Server/State/Monad/Command.hs +687/−0
- Sound/SC3/Server/State/Monad/Process.hs +47/−0
- Sound/SC3/Server/State/Monad/Request.hs +228/−0
- examples/hello.hs +9/−14
- examples/sine-grains.hs +56/−44
- hsc3-server.cabal +65/−71
- tests/Sound/SC3/Server/Allocator/Range/Test.hs +11/−8
- tests/Sound/SC3/Server/Allocator/Test.hs +99/−43
Sound/SC3/Server/Allocator.hs view
@@ -1,29 +1,26 @@-{-# LANGUAGE- DeriveDataTypeable- , FlexibleContexts- , TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} -module Sound.SC3.Server.Allocator- ( -- *Allocation errors- AllocFailure(..)- -- * Allocator statistics- , Statistics(..)- , percentFree- , percentUsed- -- * Allocator classes- , IdAllocator(..)- , RangeAllocator(..)- -- * Identifier ranges- , module Sound.SC3.Server.Allocator.Range- ) where+module Sound.SC3.Server.Allocator (+ -- *Allocation errors+ AllocFailure(..)+ -- * Allocator statistics+, Statistics(..)+, percentFree+, percentUsed+ -- * Allocator classes+, IdAllocator(..)+, allocMany+, freeMany+, RangeAllocator(..)+) where -import Control.Exception (Exception)-import Control.Failure (Failure)-import Control.Monad (foldM, replicateM)-import qualified Control.Monad.Trans.Class as State-import qualified Control.Monad.Trans.State.Strict as State-import Data.Typeable (Typeable)-import Sound.SC3.Server.Allocator.Range+import Control.Exception (Exception)+import Control.Failure (Failure)+import Data.Typeable (Typeable)+import Sound.SC3.Server.Allocator.Range -- | Failure type for allocators. data AllocFailure =@@ -58,35 +55,46 @@ -- identifiers that correspond to server resources, such as node, buffer and -- bus ids. class IdAllocator a where- type Id a- -- | Allocate a new identifier and return the changed allocator.- alloc :: Failure AllocFailure m => a -> m (Id a, a)+ -- | Id type allocated by this allocator.+ type Id a - -- | Free a previously allocated identifier and return the changed allocator.- --- -- Freeing an identifier that hasn't been allocated with this allocator may trigger a failure.- free :: Failure AllocFailure m => Id a -> a -> m a+ -- | Allocate a new identifier and return the changed allocator.+ alloc :: Failure AllocFailure m => a -> m (Id a, a) - -- | Allocate a number of - not necessarily consecutive - identifiers and return the changed allocator.- allocMany :: Failure AllocFailure m => Int -> a -> m ([Id a], a)- allocMany n = State.runStateT (replicateM n (modifyM alloc))- where- modifyM f = do- (a, s') <- State.get >>= State.lift . f- State.put $! s'- return a+ -- | Free a previously allocated identifier and return the changed allocator.+ --+ -- Freeing an identifier that hasn't been allocated with this allocator may+ -- trigger a failure.+ free :: Failure AllocFailure m => Id a -> a -> m a - -- | Free a list of previously allocated identifiers.- freeMany :: Failure AllocFailure m => [Id a] -> a -> m a- freeMany = flip (foldM (flip free))+ -- | Return usage statistics.+ statistics :: a -> Statistics - -- | Return usage statistics.- statistics :: a -> Statistics+-- | Allocate a number of (not necessarily consecutive) IDs with the given allocator.+--+-- Returns the list of IDs and the modified allocator.+allocMany :: (IdAllocator a, Failure AllocFailure m) => Int -> a -> m ([Id a], a)+allocMany n a = go n a []+ where+ go 0 a is = return (is, a)+ go !n !a is = do+ (i, a') <- alloc a+ go (n-1) a' (i:is) +-- | Free a number of IDs with the given allocator.+--+-- Returns the modified allocator.+freeMany :: (IdAllocator a, Failure AllocFailure m) => [Id a] -> a -> m a+freeMany is a = go is a+ where+ go [] a = return a+ go (i:is) a = free i a >>= go is+ -- | RangeAllocator provides an interface for allocating and releasing ranges--- of consecutive identifiers.+-- of consecutive identifiers. class IdAllocator a => RangeAllocator a where- -- | Allocate n consecutive identifiers and return the changed allocator.- allocRange :: Failure AllocFailure m => Int -> a -> m (Range (Id a), a)- -- | Free a range of previously allocated identifiers and return the changed allocator.- freeRange :: Failure AllocFailure m => Range (Id a) -> a -> m a+ -- | Allocate n consecutive identifiers and return the changed allocator.+ allocRange :: Failure AllocFailure m => Int -> a -> m (Range (Id a), a)+ -- | Free a range of previously allocated identifiers and return the changed+ -- allocator.+ freeRange :: Failure AllocFailure m => Range (Id a) -> a -> m a
Sound/SC3/Server/Allocator/BlockAllocator/FirstFit.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleContexts- , TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Sound.SC3.Server.Allocator.BlockAllocator.FirstFit ( FirstFitAllocator@@ -12,10 +12,10 @@ ) where import Control.Arrow (first)-import Control.DeepSeq (NFData(..)) import Control.Failure (Failure, failure) import Control.Monad (liftM)-import Sound.SC3.Server.Allocator+import Sound.SC3.Server.Allocator (AllocFailure(..), Id, IdAllocator(..), RangeAllocator(..), Statistics(..))+import Sound.SC3.Server.Allocator.Range (Range) import qualified Sound.SC3.Server.Allocator.Range as Range import Sound.SC3.Server.Allocator.BlockAllocator.FreeList (FreeList, Sorting(..)) import qualified Sound.SC3.Server.Allocator.BlockAllocator.FreeList as FreeList@@ -29,9 +29,6 @@ , freeList :: !(FreeList i) } deriving (Eq, Show) -instance NFData i => NFData (FirstFitAllocator i) where- rnf (FirstFitAllocator x1 x2 x3 x4) = x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()- cons :: Integral i => Sorting -> Coalescing -> Range i -> FirstFitAllocator i cons s c r = FirstFitAllocator c (fromIntegral (Range.size r)) 0 (FreeList.singleton s r) @@ -83,7 +80,7 @@ instance (Integral i) => IdAllocator (FirstFitAllocator i) where type Id (FirstFitAllocator i) = i alloc = liftM (first Range.begin) . _alloc 1- free = _free . sized 1+ free = _free . Range.sized 1 statistics = _statistics instance (Integral i) => RangeAllocator (FirstFitAllocator i) where
Sound/SC3/Server/Allocator/BlockAllocator/FreeList.hs view
@@ -10,7 +10,6 @@ , coalesce ) where -import Control.DeepSeq (NFData(..)) import Data.Ord (comparing) import qualified Data.List as List import Sound.SC3.Server.Allocator.Range (Range)@@ -19,9 +18,6 @@ data Sorting = Address | IncreasingSize | DecreasingSize deriving (Enum, Eq, Show) data FreeList i = FreeList Sorting [Range i] deriving (Eq, Show)--instance NFData i => NFData (FreeList i) where- rnf (FreeList x1 x2) = x1 `seq` rnf x2 `seq` () type SortFunc i = Range i -> Range i -> Ordering
Sound/SC3/Server/Allocator/Range.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} module Sound.SC3.Server.Allocator.Range ( Range , range@@ -18,55 +19,133 @@ , join ) where -import Control.DeepSeq (NFData(..)) import Prelude hiding (last, null) --- | Model intervals [begin, end[+-- $setup+-- >>> import Control.Applicative ((<$>), (<*>))+-- >>> import Control.Monad (liftM)+-- >>> import System.Random (Random)+-- >>> import Test.QuickCheck (Arbitrary(..))+-- >>> instance (Arbitrary i, Ord i) => Arbitrary (Range i) where arbitrary = Range <$> arbitrary <*> arbitrary++-- | Open ended interval [begin, end). data Range a = Range { begin :: !a , end :: !a- } deriving (Eq, Show)+ } deriving (Eq) -instance NFData a => NFData (Range a) where- rnf (Range x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+instance Show a => Show (Range a) where+ show r = unwords ["Range", show (begin r), show (end r)] mkRange :: a -> a -> Range a mkRange a b = Range a b +-- | Construct a range from a lower bound (included) and an upper bound (excluded).+--+-- prop> \(r :: Range Int) -> begin r == end r range :: Ord a => a -> a -> Range a range a b | a <= b = mkRange a b | otherwise = mkRange b a +-- | Construct a range from a size and a lower bound.+--+-- >>> sized 20 10+-- Range 10 30 sized :: Num a => Int -> a -> Range a sized n a = mkRange a (a + fromIntegral n) +-- | The empty range starting at some value.+--+-- >>> empty 10+-- Range 10 10+--+-- null (empty 10)+-- True+--+-- size (empty 10)+-- 0 empty :: Num a => a -> Range a empty a = mkRange a a +-- | The last value in the range.+--+-- >>> last (range 10 20)+-- 19 last :: Enum a => Range a -> a last = pred . end +-- | The size of the range.+--+-- >>> size (range 10 20)+-- 10+--+-- >>> size (sized 100 10)+-- 100 size :: Integral a => Range a -> Int size a = fromIntegral (end a - begin a) +-- | True if range is empty.+--+-- >>> null (range 10 10)+-- True+--+-- >>> null (range 10 20)+-- False null :: Eq a => Range a -> Bool null a = begin a == end a +-- | Convert range to a list of its values. toList :: Enum a => Range a -> [a] toList a = [begin a..last a] +-- | Return true if a given value is contained within the range.+--+-- >>> within 12 (sized 3 10)+-- True+--+-- >>> within 20 (range 10 20)+-- False+--+-- >>> within 30 (range 30 30)+-- False within :: Ord a => a -> Range a -> Bool x `within` a = x >= begin a && x < end a +-- | Return true if two ranges adjoin each other.+--+-- >>> range 10 20 `adjoins` range 20 30+-- True+--+-- >>> range 10 20 `adjoins` range 21 30+-- False adjoins :: Eq a => Range a -> Range a -> Bool a `adjoins` b = (end a == begin b) || (end b == begin a) +-- | Return true if two ranges overlap each other. overlaps :: Ord a => Range a -> Range a -> Bool a `overlaps` b = (end a > begin b) || (end b > begin a) +-- | Return true if the second range lies completely within the first range. contains :: Ord a => Range a -> Range a -> Bool a `contains` b = begin b >= begin a && end b <= end a +-- | Split a range at an index.+--+-- >>> let (r1, r2) = split 6 (range 10 20)+-- >>> size r1+-- 6+-- >>> size r2+-- 4+--+-- >>> let (r1, r2) = split 6 (empty 6)+-- >>> null r1 && null r2+-- True+--+-- >>> let (r1, r2) = split 10 (sized 4 10)+-- >>> size r1+-- 4+-- >>> size r2+-- 0 split :: Integral a => Int -> Range a -> (Range a, Range a) split n r@(Range l u) | n <= 0 = (empty l, r)
Sound/SC3/Server/Allocator/SetAllocator.hs view
@@ -1,15 +1,16 @@-{-# LANGUAGE BangPatterns- , FlexibleContexts- , TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Sound.SC3.Server.Allocator.SetAllocator ( SetAllocator , cons ) where -import Control.Failure (Failure, failure)-import Control.DeepSeq (NFData(..))+import Control.Failure (Failure, failure) import qualified Data.BitSet as Set-import Sound.SC3.Server.Allocator+import Sound.SC3.Server.Allocator (AllocFailure(..), IdAllocator(..), Statistics(..))+import Sound.SC3.Server.Allocator.Range (Range)+import qualified Sound.SC3.Server.Allocator.Range as Range data SetAllocator i = SetAllocator@@ -18,28 +19,22 @@ !i deriving (Eq, Show) -instance NFData i => NFData (SetAllocator i) where- rnf (SetAllocator x1 x2 x3) =- rnf x1 `seq`- x2 `seq`- rnf x3 `seq` ()- cons :: Range i -> SetAllocator i-cons r = SetAllocator r Set.empty (begin r)+cons r = SetAllocator r Set.empty (Range.begin r) -- | Convert an id to a bit index. -- -- This is necessary to keep the BitSet size bounded between [0, numIds[. toBit :: Integral i => Range i -> i -> i-toBit r i = i - begin r+toBit r i = i - Range.begin r findNext :: (Integral i) => SetAllocator i -> Maybe i findNext (SetAllocator r u i)- | fromIntegral (size r) == Set.size u = Nothing+ | fromIntegral (Range.size r) == Set.size u = Nothing | otherwise = loop i where- wrap i = if i >= end r- then begin r+ wrap i = if i >= Range.end r+ then Range.begin r else i loop !i = let i' = wrap (i+1) in if Set.member (toBit r i') u@@ -61,7 +56,7 @@ _statistics :: (Integral i) => SetAllocator i -> Statistics _statistics (SetAllocator r u _) =- let k = fromIntegral (size r)+ let k = fromIntegral (Range.size r) n = Set.size u in Statistics { numAvailable = k
Sound/SC3/Server/Allocator/SimpleAllocator.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE FlexibleContexts- , TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Sound.SC3.Server.Allocator.SimpleAllocator ( SimpleAllocator , cons ) where -import Control.DeepSeq (NFData(..))-import Control.Failure (Failure, failure)-import Sound.SC3.Server.Allocator+import Control.Failure (Failure, failure)+import Sound.SC3.Server.Allocator+import Sound.SC3.Server.Allocator.Range (Range)+import qualified Sound.SC3.Server.Allocator.Range as Range data SimpleAllocator i = SimpleAllocator@@ -16,16 +17,13 @@ !i deriving (Eq, Show) -instance NFData i => NFData (SimpleAllocator i) where- rnf (SimpleAllocator x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()- cons :: Range i -> SimpleAllocator i-cons r = SimpleAllocator r 0 (begin r)+cons r = SimpleAllocator r 0 (Range.begin r) _alloc :: (Enum i, Ord i, Monad m) => SimpleAllocator i -> m (i, SimpleAllocator i) _alloc (SimpleAllocator r n i) = let i' = succ i- in return (i, SimpleAllocator r (n+1) (if i' >= end r then begin r else i'))+ in return (i, SimpleAllocator r (n+1) (if i' >= Range.end r then Range.begin r else i')) _free :: (Failure AllocFailure m) => i -> SimpleAllocator i -> m (SimpleAllocator i) _free _ (SimpleAllocator r n i) =@@ -36,7 +34,7 @@ _statistics :: Integral i => SimpleAllocator i -> Statistics _statistics (SimpleAllocator r n _) =- let k = fromIntegral (size r)+ let k = fromIntegral (Range.size r) in Statistics { numAvailable = k , numFree = k - n
Sound/SC3/Server/Allocator/Wrapped.hs view
@@ -1,19 +1,19 @@ {-# LANGUAGE FlexibleContexts #-} -- | Helper functions for newtype wrappers.-module Sound.SC3.Server.Allocator.Wrapped- (- alloc- , free- , statistics- , allocRange- , freeRange- ) where+module Sound.SC3.Server.Allocator.Wrapped (+ alloc+, free+, statistics+, allocRange+, freeRange+) where import Control.Arrow (second) import Control.Failure (Failure) import Control.Monad (liftM)-import Sound.SC3.Server.Allocator (AllocFailure, Id, IdAllocator, Range, RangeAllocator, Statistics)+import Sound.SC3.Server.Allocator (AllocFailure, Id, IdAllocator, RangeAllocator, Statistics) import qualified Sound.SC3.Server.Allocator as Alloc+import Sound.SC3.Server.Allocator.Range (Range) alloc :: (Failure AllocFailure m, IdAllocator a) => (a -> a') -> a -> m (Id a, a')
Sound/SC3/Server/Connection.hs view
@@ -1,50 +1,49 @@-{-# LANGUAGE ExistentialQuantification- , FlexibleContexts- , GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ -- | 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- -- * Creation and termination- , open- , close- -- * Communication and synchronisation- , send- , waitFor- , waitFor_- , waitForAll- , waitForAll_- ) where+module Sound.SC3.Server.Connection (+ Connection+ -- * Creation and termination+, open+, close+ -- * Sending packets+, send+ -- * Receiving packets+, withListener+) where -import Control.Concurrent (forkIO)+import Control.Concurrent (ThreadId, forkIO, myThreadId)+import Control.Monad (forever) import Control.Concurrent.MVar-import Control.Concurrent.Chan-import Control.Monad (replicateM, void)-import Sound.OpenSoundControl (OSC(..), Transport)-import qualified Sound.OpenSoundControl as OSC-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 qualified Control.Exception as E+import Control.Monad (void)+import qualified Data.HashTable.IO as H+import Sound.OSC.FD (OSC(..), Packet, Transport)+import qualified Sound.OSC.FD as OSC +type Listener = Packet -> IO ()+type ListenerMap = H.CuckooHashTable ThreadId Listener+ data Connection = forall t . Transport t => Connection t (MVar ListenerMap) listeners :: Connection -> MVar ListenerMap listeners (Connection _ l) = l recvLoop :: Connection -> IO ()-recvLoop c@(Connection t ls) = do- osc <- OSC.recv t- withMVar ls (ListenerMap.broadcast osc)- recvLoop c+recvLoop (Connection t ls) = forever $+ OSC.recvPacket t >>= \osc -> withMVar ls $ H.mapM_ (\(_, l) -> l osc) -- | 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+ ls <- newMVar =<< H.new+ let c = Connection t ls+ void $ forkIO $ recvLoop c+ return c -- | Close the connection. --@@ -52,65 +51,31 @@ close :: Connection -> IO () close (Connection t _) = OSC.close t --- ====================================================================--- Communication and synchronization+-- | Send an OSC packet asynchronously.+send :: OSC o => Connection -> o -> IO ()+send (Connection t _) = OSC.sendOSC t --- | Create a listener from an IO action and a notification.-mkListener :: (a -> IO ()) -> Notification a -> Listener-mkListener f n osc =- case n `match` osc of- Nothing -> return ()- Just a -> f a+-- ====================================================================+-- Listeners -- | 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)+addListener :: Connection -> Listener -> IO (ThreadId, Maybe Listener)+addListener c l = do+ uid <- myThreadId+ withMVar (listeners c) $ \lm -> do+ l' <- H.lookup lm uid+ H.insert lm uid l+ return (uid, l') -- | 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 an OSC packet and wait for a notification.------ Returns the transformed value.-waitFor :: Connection -> OSC -> Notification a -> IO a-waitFor c osc n = do- res <- newEmptyMVar- uid <- addListener c (mkListener (putMVar res) n)- send c osc- a <- takeMVar res- removeListener c uid- return a---- | Send an OSC packet and wait for a notification.------ Ignores the transformed value.-waitFor_ :: Connection -> OSC -> Notification a -> IO ()-waitFor_ c osc n = void $ waitFor c osc n---- | Send an OSC packet and wait for a list of notifications.------ Returns the transformed values, in unspecified order.-waitForAll :: Connection -> OSC -> [Notification a] -> IO [a]-waitForAll c osc [] =- send c osc >> return []-waitForAll c osc ns = do- res <- newChan- uids <- mapM (addListener c . mkListener (writeChan res)) ns- send c osc- as <- replicateM (length ns) (readChan res)- mapM_ (removeListener c) uids- return as---- | Send an OSC packet and wait for a list of notifications.------ Ignores the transformed values.-waitForAll_ :: Connection -> OSC -> [Notification a] -> IO ()-waitForAll_ c osc ns = void $ waitForAll c osc ns+removeListener :: Connection -> ThreadId -> Maybe Listener -> IO ()+removeListener c uid Nothing = withMVar (listeners c) $ \ls -> H.delete ls uid+removeListener c uid (Just l) = withMVar (listeners c) $ \ls -> H.insert ls uid l +-- | Perform an IO action with a registered listener that is automatically removed.+withListener :: Connection -> (Packet -> IO ()) -> IO a -> IO a+withListener c l = do+ E.bracket+ (addListener c l)+ (uncurry (removeListener c))+ . const
− Sound/SC3/Server/Connection/ListenerMap.hs
@@ -1,6 +0,0 @@-module Sound.SC3.Server.Connection.ListenerMap- ( module Sound.SC3.Server.Connection.ListenerMap.HashTable- ) where--import Sound.SC3.Server.Connection.ListenerMap.HashTable--- import Sound.SC3.Server.Connection.ListenerMap.List
− Sound/SC3/Server/Connection/ListenerMap/HashTable.hs
@@ -1,34 +0,0 @@-module Sound.SC3.Server.Connection.ListenerMap.HashTable where---import qualified Data.HashTable as Hash-import Sound.OpenSoundControl (OSC)--type ListenerId = Int-type Listener = OSC -> IO ()-data ListenerMap = ListenerMap !(Hash.HashTable ListenerId Listener) !ListenerId--broadcast :: OSC -> ListenerMap -> IO ()-broadcast osc (ListenerMap h _) = mapM_ (\(_, l) -> l osc) =<< Hash.toList h--empty :: IO ListenerMap-empty = do- h <- Hash.new (==) Hash.hashInt- return $ ListenerMap h 0---- | Add a listener.------ Listeners are entered in a hash table, although the allocation behavior may be more stack-like.-add :: Listener -> ListenerMap -> IO (ListenerId, ListenerMap)-add l (ListenerMap h lid) = do- Hash.insert h lid l- -- xs <- Hash.toList h- -- lc <- Hash.longestChain h- -- putStrLn $ "addListener: n=" ++ show (length xs) ++ " lc=" ++ show (length lc)- return (lid, ListenerMap h (lid+1))---- | Remove a listener.-delete :: ListenerId -> ListenerMap -> IO ListenerMap-delete uid lm@(ListenerMap h _) = do- Hash.delete h uid- return lm
− Sound/SC3/Server/Connection/ListenerMap/List.hs
@@ -1,26 +0,0 @@-module Sound.SC3.Server.Connection.ListenerMap.List where--import Sound.OpenSoundControl (OSC)--type ListenerId = Int-type Listener = OSC -> IO ()-data ListenerMap = ListenerMap [(ListenerId, Listener)] !ListenerId--broadcast :: OSC -> ListenerMap -> IO ()-broadcast osc (ListenerMap m _) = mapM_ (\(_, l) -> l osc) m--empty :: IO ListenerMap-empty = return $ ListenerMap [] 0--add :: Listener -> ListenerMap -> IO (ListenerId, ListenerMap)-add l (ListenerMap m i) = return (i, ListenerMap ((i,l):m) (i+1))--deletePred :: (a -> Bool) -> [a] -> [a]-deletePred _ [] = []-deletePred f (x:xs) =- if f x- then xs- else x : deletePred f xs--delete :: ListenerId -> ListenerMap -> IO ListenerMap-delete uid (ListenerMap m i) = return (ListenerMap (deletePred (\(uid', _) -> uid' == uid) m) i)
− Sound/SC3/Server/Monad.hs
@@ -1,252 +0,0 @@-{-# LANGUAGE FlexibleContexts- , FlexibleInstances- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses- , TypeFamilies- , UndecidableInstances #-}-module Sound.SC3.Server.Monad- ( -- * Server Monad- ServerT- , runServerT- , capture- , Server- , runServer- -- * Server options- , MonadServer(..)- , serverOption- -- * Allocation- , Allocator- , BufferId- , BufferIdAllocator- , bufferIdAllocator- , BusId- , BusIdAllocator- , audioBusIdAllocator- , controlBusIdAllocator- , NodeId- , NodeIdAllocator- , nodeIdAllocator- , Range- , MonadIdAllocator(..)- -- * Communication and synchronization- , MonadSendOSC(..)- , MonadRecvOSC(..)- , SyncId- , SyncIdAllocator- , syncIdAllocator- , sync- , unsafeSync- -- * Concurrency- , fork- ) where--import Control.Applicative-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(..))-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, 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--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--instance MonadBase b m => MonadBase b (ServerT m) where- {-# INLINE liftBase #-}- liftBase = liftBaseDefault--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 :: 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 -> ServerOptions -> Connection -> IO a-runServer = runServerT---- | 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.- serverOptions :: m ServerOptions---- | Return a server option.-serverOption :: MonadServer m => (ServerOptions -> a) -> m a-serverOption = flip liftM serverOptions---- serverOptions :: MonadIO m => ServerT m ServerOptions-instance Monad m => MonadServer (ServerT m) where- serverOptions = ServerT $ R.asks _serverOptions---- | Monadic resource id management interface.-class Monad m => MonadIdAllocator m where- -- | Return the root node id.- rootNodeId :: m NodeId-- -- | Allocate an id using the given allocator.- alloc :: (IdAllocator a, NFData a) => Allocator a -> m (Id a)-- -- | Free an id using the given allocator.- free :: (IdAllocator a, NFData a) => Allocator a -> Id a -> m ()-- -- | Allocate a number of ids using the given allocator.- allocMany :: (IdAllocator a, NFData a) => Allocator a -> Int -> m [Id a]-- -- | Free a number of ids using the given allocator.- freeMany :: (IdAllocator a, NFData a) => Allocator a -> [Id a] -> m ()-- -- | Allocate a contiguous range of ids using the given allocator.- 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, 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 = 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 = withConnection $ \c -> C.send c osc--class Monad m => MonadRecvOSC m where- -- | Wait for a notification and return the result.- waitFor :: OSC -> Notification a -> m a- -- | Wait for a notification and ignore the result.- waitFor_ :: OSC -> Notification a -> m ()- -- | Wait for a set of notifications and return their results in unspecified order.- waitForAll :: OSC -> [Notification a] -> m [a]- -- | Wait for a set of notifications and ignore their results.- waitForAll_ :: OSC -> [Notification a] -> m ()--instance MonadIO m => MonadRecvOSC (ServerT m) where- 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 = 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 = sync (Bundle immediately [])----- | Fork a computation in a new thread and return the thread id.-fork :: (MonadBaseControl IO m) => ServerT m () -> ServerT m ThreadId-fork = CL.fork-
− Sound/SC3/Server/Monad/Command.hs
@@ -1,485 +0,0 @@-{-# LANGUAGE ExistentialQuantification- , FlexibleContexts- , FlexibleInstances- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses #-}-module Sound.SC3.Server.Monad.Command- (- -- * Master controls- status- , PrintLevel(..)- , dumpOSC- -- * Synth definitions- , SynthDef(name)- -- , d_recv- -- , d_load- -- , d_loadDir- , d_named- , d_default- , d_recv- , d_free- -- * Resources- -- ** Nodes- , Node(..)- , AddAction(..)- , n_after- , n_before- , n_fill- , n_free- , BusMapping(..)- , n_query_- , n_query- , n_run_- , n_set- , n_setn- , n_trace- , n_order- -- *** Synths- , Synth(..)- , s_new- , s_new_- , s_release- -- *** Groups- , Group(..)- , rootNode- , g_new- , g_new_- , g_deepFree- , g_freeAll- , g_head- , g_tail- , g_dumpTree- -- ** Buffers- , Buffer- , bufferId- , b_alloc- , b_read- , HeaderFormat(..)- , SampleFormat(..)- , b_write- , b_free- , b_zero- , b_query- -- ** Buses- , Bus(..)- , busId- , numChannels- , AudioBus(..)- , inputBus- , outputBus- , newAudioBus- , ControlBus(..)- , newControlBus- ) where----import qualified Codec.Compression.BZip as BZip---import qualified Codec.Digest.SHA as SHA-import Control.Arrow (first)-import Control.Failure (Failure, failure)-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.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.Process.Options (ServerOptions(..))---- ====================================================================--- Utils---- | Construct a function suitable for 'mkAsync'.-mkC :: a -> (OSC -> a) -> (Maybe OSC -> a)-mkC f _ Nothing = f-mkC _ f (Just osc) = f osc---- ====================================================================--- Master controls--status :: MonadIO m => RequestT m (Resource m N.Status)-status = send C.status >> after N.status_reply (return ())--dumpOSC :: MonadIO m => PrintLevel -> RequestT m (Resource m ())-dumpOSC p = do- i <- M.alloc M.syncIdAllocator- send (C.dumpOSC p)- send (C.sync (fromIntegral i))- after_ (N.synced i) (return ())---- ====================================================================--- Synth definitions--newtype SynthDef = SynthDef {- name :: String- } deriving (Eq, Show)--d_named :: String -> SynthDef-d_named = SynthDef--d_default :: SynthDef-d_default = d_named "default"---- | Compute a unique name for a UGen graph.--- graphName :: UGen -> String--- graphName = SHA.showBSasHex . SHA.hash SHA.SHA256 . BZip.compress . Synthdef.graphdef . Synthdef.synth---- | Create a new synth definition.--- d_new :: Monad m => String -> UGen -> Async m SynthDef--- d_new prefix ugen--- | length prefix < 127 = mkAsync $ return (sd, f)--- | otherwise = error "d_new: name prefix too long, resulting string exceeds 255 characters"--- where--- sd = SynthDef (prefix ++ "-" ++ graphName ugen)--- f osc = (mkC C.d_recv C.d_recv' osc) (Synthdef.synthdef (name sd) ugen)-d_recv :: Monad m => String -> UGen -> Async m SynthDef-d_recv name ugen- | length name < 255 = mkAsync $ return (SynthDef name, f)- | otherwise = error "d_recv: name too long, resulting string exceeds 255 characters"- where- 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 -> RequestT m ()-d_free = send . C.d_free . (:[]) . name---- ====================================================================--- Node--class Node a where- nodeId :: a -> NodeId--data AbstractNode = forall n . (Eq n, Node n, Show n) => AbstractNode n--instance Eq AbstractNode where- (AbstractNode a) == (AbstractNode b) = nodeId a == nodeId b--instance Node AbstractNode where- nodeId (AbstractNode n) = nodeId n--instance Show AbstractNode where- show (AbstractNode n) = show n--n_wrap :: (Eq n, Node n, Show n) => n -> AbstractNode-n_wrap = AbstractNode---- | Place node @a@ after node @b@.-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 -> 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)] -> RequestT m ()-n_fill n = send . C.n_fill (fromIntegral (nodeId n))---- | Delete a node.-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)---- | 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 -> RequestT m ()- -- | Remove a control's mapping to a control bus.- 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- where- nid = fromIntegral (nodeId n)- bid = fromIntegral (busId b)- msg = if numChannels b > 1- then C.n_mapn nid [(c, bid, numChannels b)]- else C.n_map nid [(c, bid)]- n_unmap n c b = send msg- where- nid = fromIntegral (nodeId n)- msg = if numChannels b > 1- then C.n_mapn nid [(c, -1, numChannels b)]- else C.n_map nid [(c, -1)]--instance BusMapping n AudioBus where- n_map n c b = send msg- where- nid = fromIntegral (nodeId n)- bid = fromIntegral (busId b)- msg = if numChannels b > 1- then C.n_mapan nid [(c, bid, numChannels b)]- else C.n_mapa nid [(c, bid)]- n_unmap n c b = send msg- where- nid = fromIntegral (nodeId n)- msg = if numChannels b > 1- then C.n_mapan nid [(c, -1, numChannels b)]- else C.n_mapa nid [(c, -1)]---- | Query a node.-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 -> 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 -> 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)] -> 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])] -> RequestT m ()-n_setn n = send . C.n_setn (fromIntegral (nodeId n))---- | Trace a node.-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] -> RequestT m ()-n_order a n = send . C.n_order a (fromIntegral (nodeId n)) . map (fromIntegral.nodeId)---- ====================================================================--- Synth--newtype Synth = Synth NodeId deriving (Eq, Ord, Show)--instance Node Synth where- nodeId (Synth nid) = nid--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)] -> RequestT m Synth-s_new_ d a xs = rootNode >>= \g -> s_new d a g xs--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)- where nid = nodeId n---- ====================================================================--- Group--newtype Group = Group NodeId deriving (Eq, Ord, Show)--instance Node Group where- nodeId (Group nid) = nid--rootNode :: MonadIdAllocator m => m Group-rootNode = liftM Group M.rootNodeId--g_new :: MonadIO m => AddAction -> Group -> RequestT m Group-g_new a p = do- nid <- M.alloc M.nodeIdAllocator- send $ C.g_new [(fromIntegral nid, a, fromIntegral (nodeId p))]- return $ Group nid--g_new_ :: MonadIO m => AddAction -> RequestT m Group-g_new_ a = rootNode >>= g_new a--g_deepFree :: Monad m => Group -> RequestT m ()-g_deepFree g = send $ C.g_deepFree [fromIntegral (nodeId g)]--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 -> RequestT m ()-g_head g n = send $ C.g_head [(fromIntegral (nodeId g), fromIntegral (nodeId n))]--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)] -> RequestT m ()-g_dumpTree = send . C.g_dumpTree . map (first (fromIntegral . nodeId))---- ====================================================================--- Buffer--newtype Buffer = Buffer { bufferId :: BufferId } deriving (Eq, Ord, Show)--b_alloc :: MonadIO m => Int -> Int -> Async m Buffer-b_alloc n c = mkAsync $ do- bid <- M.alloc M.bufferIdAllocator- let f osc = (mkC C.b_alloc C.b_alloc' osc) (fromIntegral bid) n c- return (Buffer bid, f)--b_read :: MonadIO m =>- Buffer- -> FilePath- -> Maybe Int- -> Maybe Int- -> Maybe Int- -> Bool- -> Async m ()-b_read (Buffer bid) path- fileOffset numFrames bufferOffset- leaveOpen = mkAsync_ f- where- f osc = (mkC C.b_read C.b_read' osc)- (fromIntegral bid) path- (maybe 0 id fileOffset)- (maybe (-1) id numFrames)- (maybe 0 id bufferOffset)- leaveOpen--data HeaderFormat =- Aiff- | Next- | Wav- | Ircam- | Raw- deriving (Enum, Eq, Read, Show)--data SampleFormat =- PcmInt8- | PcmInt16- | PcmInt24- | PcmInt32- | PcmFloat- | PcmDouble- | PcmMulaw- | PcmAlaw- deriving (Enum, Eq, Read, Show)--headerFormatString :: HeaderFormat -> String-headerFormatString Aiff = "aiff"-headerFormatString Next = "next"-headerFormatString Wav = "wav"-headerFormatString Ircam = "ircam"-headerFormatString Raw = "raw"--sampleFormatString :: SampleFormat -> String-sampleFormatString PcmInt8 = "int8"-sampleFormatString PcmInt16 = "int16"-sampleFormatString PcmInt24 = "int24"-sampleFormatString PcmInt32 = "int32"-sampleFormatString PcmFloat = "float"-sampleFormatString PcmDouble = "double"-sampleFormatString PcmMulaw = "mulaw"-sampleFormatString PcmAlaw = "alaw"--b_write :: MonadIO m =>- Buffer- -> FilePath- -> HeaderFormat- -> SampleFormat- -> Maybe Int- -> Maybe Int- -> Bool- -> Async m ()-b_write (Buffer bid) path- headerFormat sampleFormat- fileOffset numFrames- leaveOpen = mkAsync_ f- where- f osc = (mkC C.b_write C.b_write' osc)- (fromIntegral bid) path- (headerFormatString headerFormat)- (sampleFormatString sampleFormat)- (maybe 0 id fileOffset)- (maybe (-1) id numFrames)- leaveOpen--b_free :: MonadIO m => Buffer -> Async m ()-b_free b = mkAsync $ do- let bid = bufferId b- M.free M.bufferIdAllocator bid- let f osc = (mkC C.b_free C.b_free' osc) (fromIntegral bid)- return ((), f)--b_zero :: MonadIO m => Buffer -> Async m ()-b_zero (Buffer bid) = mkAsync_ f- where- f osc = (mkC C.b_zero C.b_zero' osc) (fromIntegral bid)--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 ())---- ====================================================================--- Bus---- | Abstract interface for control and audio rate buses.-class Bus a where- rate :: a -> Rate- busIdRange :: a -> Range BusId- freeBus :: (MonadServer m, MonadIdAllocator m) => a -> m ()---- | Bus id.-busId :: Bus a => a -> BusId-busId = Range.begin . busIdRange---- | Number of channels of the bus.-numChannels :: Bus a => a -> Int-numChannels = Range.size . busIdRange---- | Audio bus.-newtype AudioBus = AudioBus { audioBusId :: Range BusId } deriving (Eq, Show)--instance Bus AudioBus where- rate _ = AR- busIdRange = 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)- then failure InvalidId- else return (AudioBus r)---- | Get hardware output bus.-outputBus :: (MonadServer m, Failure AllocFailure m) => Int -> Int -> m AudioBus-outputBus n i = do- k <- serverOption numberOfOutputBusChannels- let r = Range.sized n (fromIntegral i)- if Range.begin r < 0 || Range.end r > fromIntegral k- then failure InvalidId- else return (AudioBus r)---- | Control bus.-newtype ControlBus = ControlBus { controlBusId :: Range BusId } deriving (Eq, Show)--instance Bus ControlBus where- rate _ = KR- busIdRange = controlBusId- freeBus = M.freeRange M.controlBusIdAllocator . controlBusId---- | Allocate control bus with the specified number of channels.-newControlBus :: MonadIdAllocator m => Int -> m ControlBus-newControlBus = liftM ControlBus . M.allocRange M.controlBusIdAllocator
− Sound/SC3/Server/Monad/Process.hs
@@ -1,26 +0,0 @@-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
@@ -1,345 +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.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/Notification.hs view
@@ -2,6 +2,8 @@ module Sound.SC3.Server.Notification ( Notification(..) , hasAddress+ , waitFor+ , waitForAll , Status(..) , status_reply , tr@@ -11,15 +13,19 @@ , headNodeId, tailNodeId , n_go , n_end , n_off , n_on , n_move , n_info , n_go_, n_end_, n_off_, n_on_+ , n_set, n_setn , BufferInfo(..) , b_info ) where -import Sound.SC3.Server.State (BufferId, NodeId, SyncId)-import Sound.OpenSoundControl (OSC(..), Datum(..))+import Control.Applicative (pure, (<*>))+import qualified Data.List.Zipper as Zipper+import Sound.SC3.Server.State (BufferId, NodeId, SyncId)+import Sound.OpenSoundControl (Datum(..), Message(..))+import Sound.OSC.Transport.Monad (RecvOSC(..), SendOSC(..), recvMessage) --- | A notification transformer, extracting a value from a matching OSC packet.-newtype Notification a = Notification { match :: OSC -> Maybe a }+-- | A notification transformer, extracting a value from a matching OSC message.+newtype Notification a = Notification { match :: Message -> Maybe a } instance Functor Notification where fmap f = Notification . (.) (fmap f) . match@@ -27,12 +33,49 @@ -- | Wait for an OSC message matching a specific address. -- -- Returns the matched OSC message.-hasAddress :: String -> Notification OSC+hasAddress :: String -> Notification Message hasAddress a = Notification f where- f m@(Message a' _) = if a == a' then Just m else Nothing- f _ = Nothing+ f p@(Message a' _) | a == a' = Just p+ f _ = Nothing +-- | Send an OSC packet and wait for a notification.+--+-- Returns the transformed value.+waitFor :: (RecvOSC m, SendOSC m) => Notification a -> m a+waitFor n = go+ where+ go = do+ msg <- recvMessage+ case match n =<< msg of+ Nothing -> go+ Just a -> return a++-- | Send an OSC packet and wait for a list of notifications.+--+-- Returns the transformed values, in unspecified order.+waitForAll :: (RecvOSC m, SendOSC m) => [Notification a] -> m [a]+waitForAll = go []+ where+ go as [] = return as+ go as ns = do+ msg <- recvMessage+ case msg of+ Nothing -> go as ns+ Just msg ->+ case findMatch msg ns of+ Nothing -> go as ns+ Just (a, ns') -> go (a:as) ns'+ findMatch msg = go . Zipper.fromList+ where+ go z+ | Zipper.endp z = Nothing+ | otherwise =+ let n = Zipper.cursor z+ in case match n msg of+ Nothing -> go (Zipper.right z)+ Just a -> Just (a, Zipper.toList (Zipper.delete z))+ data Status = Status { numUGens :: Int , numSynths :: Int@@ -56,7 +99,7 @@ where f (Just i) (Message "/tr" [Int n', Int i', Float r]) | fromIntegral n == n' && i == i' = Just r- f Nothing (Message "/tr" [Int n', Int _, Float r])+ f Nothing (Message "/tr" [Int n', Int _, Float r]) | fromIntegral n == n' = Just r f _ _ = Nothing @@ -64,7 +107,7 @@ synced i = Notification f where f (Message "/synced" [Int j]) | fromIntegral j == i = Just i- f _ = Nothing+ f _ = Nothing normalize :: String -> String normalize ('/':s) = s@@ -74,7 +117,7 @@ done c = Notification f where f (Message "/done" (String s:xs)) | normalize c == normalize s = Just xs- f _ = Nothing+ f _ = Nothing data NodeNotification = SynthNotification {@@ -112,7 +155,7 @@ nodeIdToMaybe i = Just (fromIntegral i) f osc = case osc of- (Message s' (Int nid':xs)) ->+ Message s' (Int nid':xs) -> if s == s' && fromIntegral nid == nid' then case xs of (Int g:Int p:Int n:Int b:rest) ->@@ -164,6 +207,30 @@ n_on_ :: NodeId -> Notification () n_on_ = n_notification_ "/n_on"++n_set :: NodeId -> Notification [(Either Int String, Double)]+n_set nid = Notification f+ where+ f (Message "/n_set" (Int nid':cs))+ | nid == fromIntegral nid' = mapM ctrl (pairs cs)+ f _ = Nothing+ pairs (a:a':as) = (a, a') : pairs as+ pairs _ = []+ ctrl (Int k, Float v) = Just (Left k, v)+ ctrl (String k, Float v) = Just (Right k, v)+ ctrl _ = Nothing++n_setn :: NodeId -> Notification [(Either Int String, [Double])]+n_setn nid = Notification f+ where+ f (Message "/n_setn" (Int nid':cs))+ | nid == fromIntegral nid' = sequence (conv cs)+ f _ = Nothing+ value (Float v) = Just v+ value _ = Nothing+ conv (Int k:Int n:xs) = (pure (,) <*> pure (Left k) <*> mapM value (take n xs)) : conv (drop n xs)+ conv (String k:Int n:xs) = (pure (,) <*> pure (Right k) <*> mapM value (take n xs)) : conv (drop n xs)+ conv _ = [] data BufferInfo = BufferInfo { numFrames :: Int
Sound/SC3/Server/State.hs view
@@ -1,45 +1,45 @@-{-# LANGUAGE- ExistentialQuantification- , GADTs- , GeneralizedNewtypeDeriving- , TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} -- | 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 (- SyncId- , SyncIdAllocator- , syncIdAllocator- , NodeId- , NodeIdAllocator- , nodeIdAllocator- , BufferId- , BufferIdAllocator- , bufferIdAllocator- , BusId- , BusIdAllocator- , controlBusIdAllocator- , audioBusIdAllocator- , Allocators- , mkAllocators+ SyncId+, SyncIdAllocator+, syncIdAllocator+, NodeId+, NodeIdAllocator+, nodeIdAllocator+, BufferId+, BufferIdAllocator+, bufferIdAllocator+, ControlBusId+, ControlBusIdAllocator+, controlBusIdAllocator+, AudioBusId+, AudioBusIdAllocator+, audioBusIdAllocator+, Allocators+, mkAllocators ) where -import Control.DeepSeq (NFData(..)) import Data.Int (Int32) import Sound.SC3.Server.Allocator (IdAllocator(..), RangeAllocator(..))-import qualified Sound.SC3.Server.Allocator as Alloc import qualified Sound.SC3.Server.Allocator.BlockAllocator.FirstFit as FirstFitAllocator+import qualified Sound.SC3.Server.Allocator.Range as Range 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.Process.Options (ServerOptions(..)) -- | Synchronisation barrier id.-newtype SyncId = SyncId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)+newtype SyncId = SyncId Int32 deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) -- | Synchronisation barrier id allocator.-data SyncIdAllocator = forall a . (IdAllocator a, NFData a, Id a ~ SyncId) => SyncIdAllocator !a+data SyncIdAllocator = forall a . (IdAllocator a, Id a ~ SyncId) => SyncIdAllocator !a instance IdAllocator SyncIdAllocator where type Id SyncIdAllocator = SyncId@@ -47,14 +47,11 @@ free i (SyncIdAllocator a) = Wrapped.free SyncIdAllocator i a statistics (SyncIdAllocator a) = Wrapped.statistics a -instance NFData SyncIdAllocator where- rnf (SyncIdAllocator a) = rnf a `seq` ()- -- | Node id.-newtype NodeId = NodeId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)+newtype NodeId = NodeId Int32 deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) -- | Node id allocator.-data NodeIdAllocator = forall a . (IdAllocator a, NFData a, Id a ~ NodeId) => NodeIdAllocator !a+data NodeIdAllocator = forall a . (IdAllocator a, Id a ~ NodeId) => NodeIdAllocator !a instance IdAllocator NodeIdAllocator where type Id NodeIdAllocator = NodeId@@ -62,14 +59,11 @@ free i (NodeIdAllocator a) = Wrapped.free NodeIdAllocator i a statistics (NodeIdAllocator a) = Wrapped.statistics a -instance NFData NodeIdAllocator where- rnf (NodeIdAllocator a) = rnf a `seq` ()- -- | Buffer id.-newtype BufferId = BufferId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)+newtype BufferId = BufferId Int32 deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) -- | Buffer id allocator.-data BufferIdAllocator = forall a . (RangeAllocator a, NFData a, Id a ~ BufferId) => BufferIdAllocator !a+data BufferIdAllocator = forall a . (RangeAllocator a, Id a ~ BufferId) => BufferIdAllocator !a instance IdAllocator BufferIdAllocator where type Id BufferIdAllocator = BufferId@@ -81,60 +75,79 @@ allocRange n (BufferIdAllocator a) = Wrapped.allocRange BufferIdAllocator n a freeRange r (BufferIdAllocator a) = Wrapped.freeRange BufferIdAllocator r a -instance NFData BufferIdAllocator where- rnf (BufferIdAllocator a) = rnf a `seq` ()+-- | Control bus id.+newtype ControlBusId = ControlBusId Int32+ deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) --- | Bus id.-newtype BusId = BusId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)+-- | Control bus id allocator.+data ControlBusIdAllocator = forall a . (RangeAllocator a, Id a ~ ControlBusId) => ControlBusIdAllocator !a --- | Bus id allocator.-data BusIdAllocator = forall a . (RangeAllocator a, NFData a, Id a ~ BusId) => BusIdAllocator !a+instance IdAllocator ControlBusIdAllocator where+ type Id ControlBusIdAllocator = ControlBusId+ alloc (ControlBusIdAllocator a) = Wrapped.alloc ControlBusIdAllocator a+ free i (ControlBusIdAllocator a) = Wrapped.free ControlBusIdAllocator i a+ statistics (ControlBusIdAllocator a) = Wrapped.statistics a -instance IdAllocator BusIdAllocator where- type Id BusIdAllocator = BusId- alloc (BusIdAllocator a) = Wrapped.alloc BusIdAllocator a- free i (BusIdAllocator a) = Wrapped.free BusIdAllocator i a- statistics (BusIdAllocator a) = Wrapped.statistics a+instance RangeAllocator ControlBusIdAllocator where+ allocRange n (ControlBusIdAllocator a) = Wrapped.allocRange ControlBusIdAllocator n a+ freeRange r (ControlBusIdAllocator a) = Wrapped.freeRange ControlBusIdAllocator r a -instance RangeAllocator BusIdAllocator where- allocRange n (BusIdAllocator a) = Wrapped.allocRange BusIdAllocator n a- freeRange r (BusIdAllocator a) = Wrapped.freeRange BusIdAllocator r a+-- | Audio bus id.+newtype AudioBusId = AudioBusId Int32+ deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) -instance NFData BusIdAllocator where- rnf (BusIdAllocator a) = rnf a `seq` ()+-- | Audio bus id allocator.+data AudioBusIdAllocator = forall a . (RangeAllocator a, Id a ~ AudioBusId) => AudioBusIdAllocator !a +instance IdAllocator AudioBusIdAllocator where+ type Id AudioBusIdAllocator = AudioBusId+ alloc (AudioBusIdAllocator a) = Wrapped.alloc AudioBusIdAllocator a+ free i (AudioBusIdAllocator a) = Wrapped.free AudioBusIdAllocator i a+ statistics (AudioBusIdAllocator a) = Wrapped.statistics a++instance RangeAllocator AudioBusIdAllocator where+ allocRange n (AudioBusIdAllocator a) = Wrapped.allocRange AudioBusIdAllocator n a+ freeRange r (AudioBusIdAllocator a) = Wrapped.freeRange AudioBusIdAllocator r a+ -- | Server allocators. data Allocators = Allocators {- syncIdAllocator :: !SyncIdAllocator- , nodeIdAllocator :: !NodeIdAllocator- , bufferIdAllocator :: !BufferIdAllocator- , controlBusIdAllocator :: !BusIdAllocator- , audioBusIdAllocator :: !BusIdAllocator+ syncIdAllocator :: SyncIdAllocator+ , nodeIdAllocator :: NodeIdAllocator+ , bufferIdAllocator :: BufferIdAllocator+ , audioBusIdAllocator :: AudioBusIdAllocator+ , controlBusIdAllocator :: ControlBusIdAllocator } -- | Create a new state with default allocators. 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)))- nid = NodeIdAllocator (SetAllocator.cons (Alloc.range 1000 (1000 + fromIntegral (maxNumberOfNodes os))))- bid = BufferIdAllocator (FirstFitAllocator.bestFit- FirstFitAllocator.LazyCoalescing- (Alloc.range 0 (fromIntegral (numberOfSampleBuffers os))))- cid = BusIdAllocator (FirstFitAllocator.bestFit- FirstFitAllocator.LazyCoalescing- (Alloc.range 0 (fromIntegral (numberOfControlBusChannels os))))- aid = BusIdAllocator (FirstFitAllocator.bestFit- FirstFitAllocator.LazyCoalescing- (Alloc.range- (fromIntegral numHardwareChannels)- (fromIntegral (numHardwareChannels + numberOfAudioBusChannels os))))- numHardwareChannels = numberOfInputBusChannels os- + numberOfOutputBusChannels os+ Allocators {+ syncIdAllocator =+ SyncIdAllocator $+ SimpleAllocator.cons+ (Range.range 0 (maxBound :: SyncId))+ , nodeIdAllocator =+ NodeIdAllocator $+ SetAllocator.cons+ (Range.range 1000 (1000 + fromIntegral (maxNumberOfNodes os)))+ , bufferIdAllocator =+ BufferIdAllocator $+ FirstFitAllocator.bestFit+ FirstFitAllocator.LazyCoalescing+ (Range.range 0 (fromIntegral (numberOfSampleBuffers os)))+ , audioBusIdAllocator =+ AudioBusIdAllocator $+ FirstFitAllocator.bestFit+ FirstFitAllocator.LazyCoalescing+ (Range.range+ (fromIntegral numHardwareChannels)+ (fromIntegral (numHardwareChannels + numberOfAudioBusChannels os)))+ , controlBusIdAllocator =+ ControlBusIdAllocator $+ FirstFitAllocator.bestFit+ FirstFitAllocator.LazyCoalescing+ (Range.range 0 (fromIntegral (numberOfControlBusChannels os)))+ }+ where+ numHardwareChannels = numberOfInputBusChannels os+ + numberOfOutputBusChannels os
+ Sound/SC3/Server/State/Monad.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Sound.SC3.Server.State.Monad (+-- * Server Monad+ Server+, runServer+-- * Server options+, MonadServer(..)+, serverOption+-- * Allocation+, BufferId+, BufferIdAllocator+, ControlBusId+, ControlBusIdAllocator+, AudioBusId+, AudioBusIdAllocator+, NodeId+, NodeIdAllocator+, MonadIdAllocator(..)+-- * Communication and synchronization+, SendOSC(..)+, RequestOSC(..)+, SyncId+, SyncIdAllocator+, sync+, unsafeSync+-- * Concurrency+, fork+) where++import Control.Applicative (Applicative)+import Control.Concurrent (ThreadId)+import Control.Concurrent.Lifted (MVar)+import qualified Control.Concurrent.Lifted as Conc+import Control.Monad (ap, liftM, void)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import qualified Control.Monad.Trans.Reader as R+import Sound.OpenSoundControl (Bundle(..), Datum(Int), Message(..), Packet(..), immediately)+import Sound.OSC.Transport.Monad (DuplexOSC, RecvOSC(..), SendOSC(..), Transport)+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 qualified Sound.SC3.Server.Notification as N+import Sound.SC3.Server.Process.Options (ServerOptions)+import Sound.SC3.Server.State ( AudioBusId, AudioBusIdAllocator+ , BufferId, BufferIdAllocator+ , ControlBusId, ControlBusIdAllocator+ , NodeId, NodeIdAllocator+ , SyncId, SyncIdAllocator+ )+import qualified Sound.SC3.Server.State as State+import Sound.SC3.Server.State.Monad.Class++data State = State {+ _serverOptions :: ServerOptions+ , _connection :: Connection+ , _syncIdAllocator :: MVar SyncIdAllocator+ , _nodeIdAllocator :: MVar NodeIdAllocator+ , _bufferIdAllocator :: MVar BufferIdAllocator+ , _audioBusIdAllocator :: MVar AudioBusIdAllocator+ , _controlBusIdAllocator :: MVar ControlBusIdAllocator+ }++newtype Server a = Server { unServer :: ReaderT State IO a }+ deriving (Applicative, Functor, Monad, MonadFix, MonadIO)++instance MonadBase IO Server where+ {-# INLINE liftBase #-}+ liftBase = liftIO++instance MonadBaseControl IO Server where+ newtype StM Server a = StM_Server a+ {-# INLINE liftBaseWith #-}+ liftBaseWith f = do+ s <- Server R.ask+ liftIO $ f $ flip runReaderT s . unServer . fmap StM_Server+ {-# INLINE restoreM #-}+ restoreM (StM_Server a) = return a++-- | Run a 'Server' computation given a connection and return the result.+runServer :: Server a -> ServerOptions -> Connection -> IO a+runServer (Server r) so c =+ return (State so c)+ `ap` new State.syncIdAllocator+ `ap` new State.nodeIdAllocator+ `ap` new State.bufferIdAllocator+ `ap` new State.audioBusIdAllocator+ `ap` new State.controlBusIdAllocator+ >>= runReaderT (init >> r)+ where+ as = State.mkAllocators so+ new :: MonadIO m => (State.Allocators -> a) -> m (MVar a)+ new f = liftIO $ Conc.newMVar (f as)+ -- Register with server to receive notifications.+ (Server init) = sync (Packet_Bundle (Bundle immediately [notify True]))++instance MonadServer Server where+ serverOptions = Server $ R.asks _serverOptions+ rootNodeId = return (fromIntegral 0)++withAllocator :: (State -> MVar a) -> (a -> IO (b, a)) -> Server b+withAllocator a f = Server $ do+ mv <- R.asks a+ liftIO $ Conc.modifyMVar mv $ \s -> do+ (i, s') <- f s+ -- Evaluate allocator before putting it back into MVar.+ return $! s' `seq` (s', i)++withAllocator_ :: (State -> MVar a) -> (a -> IO a) -> Server ()+withAllocator_ a f = Server $ do+ mv <- R.asks a+ liftIO $ Conc.modifyMVar_ mv $ \s -> do+ s' <- f s+ -- Evaluate allocator before putting it back into MVar.+ return $! s'++instance MonadIdAllocator Server where+ newtype Allocator Server a = Allocator (State -> MVar a)++ syncIdAllocator = Allocator _syncIdAllocator+ nodeIdAllocator = Allocator _nodeIdAllocator+ bufferIdAllocator = Allocator _bufferIdAllocator+ audioBusIdAllocator = Allocator _audioBusIdAllocator+ controlBusIdAllocator = Allocator _controlBusIdAllocator++ alloc (Allocator a) = withAllocator a A.alloc+ free (Allocator a) = withAllocator_ a . A.free+ statistics (Allocator a) = liftM A.statistics $ Server (R.asks a >>= liftIO . Conc.readMVar)++ allocRange (Allocator a) = withAllocator a . A.allocRange+ freeRange (Allocator a) = withAllocator_ a . A.freeRange++withConnection :: (Connection -> IO a) -> Server a+withConnection f = Server $ R.asks _connection >>= \c -> liftIO (f c)++instance SendOSC Server where+ sendOSC osc = withConnection (flip C.send osc)++newtype AsTransport a = AsTransport (ReaderT (Connection, Conc.Chan Packet) IO a)+ deriving (Functor, Monad, MonadIO)++instance SendOSC AsTransport where+ sendOSC osc = AsTransport $ R.asks fst >>= liftIO . flip C.send osc++instance RecvOSC AsTransport where+ recvPacket = AsTransport $ R.asks snd >>= liftIO . Conc.readChan++instance DuplexOSC AsTransport+instance Transport AsTransport++asTransport :: AsTransport a -> Server a+asTransport (AsTransport a) =+ withConnection $ \conn -> do+ recvVar <- Conc.newChan+ C.withListener conn (liftIO . Conc.writeChan recvVar) $+ R.runReaderT a (conn, recvVar)++instance RequestOSC Server where+ request osc n = asTransport (sendOSC osc >> N.waitFor n)+ requestAll osc ns = asTransport (sendOSC osc >> N.waitForAll ns)++-- | Append a @\/sync@ message to an OSC packet.+appendSync :: Packet -> SyncId -> Packet+appendSync p i =+ case p of+ Packet_Message m -> Packet_Bundle (Bundle immediately [m, s])+ Packet_Bundle (Bundle t xs) -> Packet_Bundle (Bundle t (xs ++ [s]))+ where s = Message "/sync" [Int (fromIntegral i)]++-- | Send an OSC packet and wait for the synchronization barrier.+sync :: Packet -> Server ()+sync osc = do+ i <- alloc syncIdAllocator+ void $ request (osc `appendSync` i) (N.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 :: Server ()+unsafeSync = sync (Packet_Bundle (Bundle immediately []))++-- | Fork a computation in a new thread and return the thread id.+--+-- This is an alias for 'Control.Concurrent.Lifted.fork'.+fork :: Server () -> Server ThreadId+{-# INLINE fork #-}+--fork (Server a) = Server R.ask >>= liftIO . Conc.forkIO . R.runReaderT a+fork = Conc.fork
+ Sound/SC3/Server/State/Monad/Class.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Sound.SC3.Server.State.Monad.Class (+ MonadServer(..)+, serverOption+, MonadIdAllocator(..)+, RequestOSC(..)+) where++import Control.Monad (liftM)+import Sound.OpenSoundControl (OSC)+import Sound.OSC.Transport.Monad (SendOSC)+import Sound.SC3.Server.Allocator (Id, IdAllocator, RangeAllocator, Statistics)+import Sound.SC3.Server.Allocator.Range (Range)+import Sound.SC3.Server.Notification (Notification)+import Sound.SC3.Server.State ( AudioBusIdAllocator+ , ControlBusIdAllocator+ , BufferIdAllocator+ , NodeId+ , NodeIdAllocator+ , SyncIdAllocator )+import Sound.SC3.Server.Process (ServerOptions)++class Monad m => MonadServer m where+ -- | Return the server options.+ serverOptions :: m ServerOptions+ -- | Return the root node id.+ rootNodeId :: m NodeId++-- | Return a server option.+serverOption :: MonadServer m => (ServerOptions -> a) -> m a+serverOption = flip liftM serverOptions++-- | Monadic resource id management interface.+class Monad m => MonadIdAllocator m where+ data Allocator m a++ -- | 'NodeId' allocator.+ nodeIdAllocator :: Allocator m NodeIdAllocator+ -- | 'SyncId' allocator.+ syncIdAllocator :: Allocator m SyncIdAllocator+ -- | 'BufferId' allocator.+ bufferIdAllocator :: Allocator m BufferIdAllocator+ -- | 'AudioBusId' allocator.+ audioBusIdAllocator :: Allocator m AudioBusIdAllocator+ -- | 'ControlBusId' allocator.+ controlBusIdAllocator :: Allocator m ControlBusIdAllocator++ -- | Allocate an id using the given allocator.+ alloc :: IdAllocator a => Allocator m a -> m (Id a)+ -- | Free an id using the given allocator.+ free :: IdAllocator a => Allocator m a -> Id a -> m ()+ -- | Return allocator statistics+ statistics :: IdAllocator a => Allocator m a -> m Statistics++ -- | Allocate a contiguous range of ids using the given allocator.+ allocRange :: RangeAllocator a => Allocator m a -> Int -> m (Range (Id a))+ -- | Free a contiguous range of ids using the given allocator.+ freeRange :: RangeAllocator a => Allocator m a -> Range (Id a) -> m ()++class SendOSC m => RequestOSC m where+ -- | Wait for a notification and return the result.+ request :: OSC o => o -> Notification a -> m a+ -- | Wait for a set of notifications and return their results in unspecified order.+ requestAll :: OSC o => o -> [Notification a] -> m [a]
+ Sound/SC3/Server/State/Monad/Command.hs view
@@ -0,0 +1,687 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Sound.SC3.Server.State.Monad.Command (+-- * Requests+ Request+, R.exec+, R.exec_+, Result+, R.extract+-- * Master controls+, status+, statusM+, PrintLevel(..)+, dumpOSC+, clearSched+, ErrorScope(..)+, ErrorMode(..)+, errorMode+-- * Synth definitions+, SynthDef(name)+-- , d_recv+, d_named+, d_default+, d_recv+, d_load+, d_loadDir+, d_free+-- * Resources+-- ** Nodes+, Node(..)+, AddAction(..)+, AbstractNode+, node+, n_after+, n_before+, n_fill+, n_free+, BusMapping(..)+, n_query_+, n_query+, n_queryM+, n_run_+, n_set+, n_setn+, n_trace+, n_order+-- *** Synths+, Synth(..)+, s_new+, s_new_+, s_release+, s_get+, s_getn+, s_noid+-- *** Groups+, Group(..)+, rootNode+, g_new+, g_new_+, g_deepFree+, g_freeAll+, g_head+, g_tail+, g_dumpTree+--, g_queryTree+-- ** Plugin Commands+, cmd+-- ** Unit Generator Commands+, u_cmd+-- ** Buffers+, Buffer+, bufferId+, b_alloc+, b_allocRead+, b_allocReadChannel+, b_read+, b_readChannel+, SoundFileFormat(..)+, SampleFormat(..)+, b_write+, b_free+, b_zero+, b_set+, b_setn+, b_fill+, b_gen+, b_gen_sine1+, b_gen_sine2+, b_gen_sine3+, b_gen_cheby+, b_gen_copy+, b_close+, b_query+, b_queryM+--, b_get+--, b_getn+-- ** Buses+, Bus(..)+, AudioBus(audioBusIdRange)+, audioBusId+, inputBus+, outputBus+, newAudioBus+, ControlBus(controlBusIdRange)+, controlBusId+, newControlBus+-- *** Control Bus Commands+--, c_set+--, c_setn+--, c_fill+--, c_get+--, c_getn+) where++--import qualified Codec.Compression.BZip as BZip+--import qualified Codec.Digest.SHA as SHA+import Control.Arrow (first)+import Control.Failure (Failure, failure)+import Control.Monad (liftM, unless)+import Control.Monad.IO.Class (MonadIO)+import Sound.OpenSoundControl (Datum(..), OSC(..))+import Sound.SC3 (Rate(..), UGen)+import Sound.SC3.Server.Allocator.Range (Range)+import qualified Sound.SC3.Server.Allocator.Range as Range+import qualified Sound.SC3.Server.Command.Completion as C+import qualified Sound.SC3.Server.Synthdef as Synthdef+import Sound.SC3.Server.Allocator (AllocFailure(..))+import Sound.SC3.Server.Command (AddAction(..), ErrorScope(..), ErrorMode(..), PrintLevel(..))+import qualified Sound.SC3.Server.Command as C+import Sound.SC3.Server.Enum (SoundFileFormat(..), SampleFormat(..))+import qualified Sound.SC3.Server.Notification as N+import Sound.SC3.Server.Process.Options (ServerOptions(..))+import Sound.SC3.Server.State (AudioBusId, BufferId, ControlBusId, NodeId)+import Sound.SC3.Server.State.Monad (sendOSC)+import qualified Sound.SC3.Server.State.Monad as M+import Sound.SC3.Server.State.Monad.Class (MonadIdAllocator, MonadServer, RequestOSC, serverOption)+import Sound.SC3.Server.State.Monad.Request (Request, Result, after_, finally, mkAsync, mkAsync_, mkSync, waitFor)+import qualified Sound.SC3.Server.State.Monad.Request as R+import Sound.SC3.UGen.Enum (B_Gen)++-- ====================================================================+-- Utils++-- | Construct a function suitable for 'mkAsync'.+mkC :: OSC o => a -> (o -> a) -> (Maybe o -> a)+mkC f _ Nothing = f+mkC _ f (Just osc) = f osc++get :: (MonadIdAllocator m, RequestOSC m, MonadIO m) => Request m (Result a) -> m a+get m = R.exec_ m >>= R.extract++withSync :: MonadIdAllocator m => OSC o => o -> Request m ()+withSync c = do+ sendOSC c+ sendOSC =<< mkSync++-- ====================================================================+-- Master controls++-- | Request server status.+status :: MonadIO m => Request m (Result N.Status)+status = do+ sendOSC C.status+ waitFor N.status_reply++-- | Request server status.+statusM :: (MonadIdAllocator m, RequestOSC m, MonadIO m) => m N.Status+statusM = get status++-- | Select printing of incoming Open Sound Control messages.+dumpOSC :: MonadIdAllocator m => PrintLevel -> Request m ()+dumpOSC p = withSync (C.dumpOSC p)++-- | Remove all bundles from the scheduling queue.+clearSched :: Monad m => Request m ()+clearSched = sendOSC C.clearSched++-- | Set error posting scope and mode.+errorMode :: Monad m => ErrorScope -> ErrorMode -> Request m ()+errorMode scope = sendOSC . C.errorMode scope++-- ====================================================================+-- Synth definitions++newtype SynthDef = SynthDef {+ name :: String+ } deriving (Eq, Show)++-- | Construct a synth definition from a name.+d_named :: String -> SynthDef+d_named = SynthDef++-- | The default synth definition.+d_default :: SynthDef+d_default = d_named "default"++-- | Compute a unique name for a UGen graph.+-- graphName :: UGen -> String+-- graphName = SHA.showBSasHex . SHA.hash SHA.SHA256 . BZip.compress . Synthdef.graphdef . Synthdef.synth++-- | Create a new synth definition.+-- d_new :: Monad m => String -> UGen -> Async m SynthDef+-- d_new prefix ugen+-- | length prefix < 127 = mkAsync $ return (sd, f)+-- | otherwise = error "d_new: name prefix too long, resulting string exceeds 255 characters"+-- where+-- sd = SynthDef (prefix ++ "-" ++ graphName ugen)+-- f osc = (mkC C.d_recv C.d_recv' osc) (Synthdef.synthdef (name sd) ugen)++-- | Create a synth definition from a name and a UGen graph.+d_recv :: Monad m => String -> UGen -> Request m SynthDef+d_recv name ugen+ | length name < 255 = mkAsync $ return (SynthDef name, f)+ | otherwise = error "d_recv: name too long, resulting string exceeds 255 characters"+ where+ f osc = (mkC C.d_recv C.d_recv' osc) (Synthdef.synthdef name ugen)++-- | Load a synth definition from a named file. (Asynchronous)+d_load :: Monad m => FilePath -> Request m ()+d_load fp = mkAsync_ $ \osc -> mkC C.d_load C.d_load' osc $ fp++-- | Load a directory of synth definition files. (Asynchronous)+d_loadDir :: Monad m => FilePath -> Request m ()+d_loadDir fp = mkAsync_ $ \osc -> mkC C.d_loadDir C.d_loadDir' osc $ fp++-- | Remove definition once all nodes using it have ended.+d_free :: Monad m => SynthDef -> Request m ()+d_free = sendOSC . C.d_free . (:[]) . name++-- ====================================================================+-- Node++class Node a where+ nodeId :: a -> NodeId++data AbstractNode = forall n . (Eq n, Node n, Show n) => AbstractNode n++instance Eq AbstractNode where+ (AbstractNode a) == (AbstractNode b) = nodeId a == nodeId b++instance Node AbstractNode where+ nodeId (AbstractNode n) = nodeId n++instance Show AbstractNode where+ show (AbstractNode n) = show n++-- | Construct an abstract node wrapper.+node :: (Eq n, Node n, Show n) => n -> AbstractNode+node = AbstractNode++-- | Place node @a@ after node @b@.+n_after :: (Node a, Node b, Monad m) => a -> b -> Request m ()+n_after a b = sendOSC $ 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 -> Request m ()+n_before a b = sendOSC $ 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)] -> Request m ()+n_fill n = sendOSC . C.n_fill (fromIntegral (nodeId n))++-- | Delete a node.+n_free :: (Node a, MonadIdAllocator m) => a -> Request m ()+n_free n = do+ sendOSC $ C.n_free [fromIntegral (nodeId n)]+ finally $ M.free M.nodeIdAllocator (nodeId n)++-- | 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 -> Request m ()+ -- | Remove a control's mapping to a control bus.+ n_unmap :: (Node n, Bus b, Monad m) => n -> String -> b -> Request m ()++instance BusMapping n ControlBus where+ n_map n c b = sendOSC msg+ where+ nid = fromIntegral (nodeId n)+ bid = fromIntegral (controlBusId b)+ msg = if numChannels b > 1+ then C.n_mapn nid [(c, bid, numChannels b)]+ else C.n_map nid [(c, bid)]+ n_unmap n c b = sendOSC msg+ where+ nid = fromIntegral (nodeId n)+ msg = if numChannels b > 1+ then C.n_mapn nid [(c, -1, numChannels b)]+ else C.n_map nid [(c, -1)]++instance BusMapping n AudioBus where+ n_map n c b = sendOSC msg+ where+ nid = fromIntegral (nodeId n)+ bid = fromIntegral (audioBusId b)+ msg = if numChannels b > 1+ then C.n_mapan nid [(c, bid, numChannels b)]+ else C.n_mapa nid [(c, bid)]+ n_unmap n c b = sendOSC msg+ where+ nid = fromIntegral (nodeId n)+ msg = if numChannels b > 1+ then C.n_mapan nid [(c, -1, numChannels b)]+ else C.n_mapa nid [(c, -1)]++-- | Query a node.+n_query_ :: (Node a, Monad m) => a -> Request m ()+n_query_ n = sendOSC (C.n_query [fromIntegral (nodeId n)])++-- | Query a node.+n_query :: (Node a, MonadIO m) => a -> Request m (Result N.NodeNotification)+n_query n = do+ n_query_ n+ waitFor (N.n_info (nodeId n))++-- | Query a node.+n_queryM :: (Node a, MonadIdAllocator m, RequestOSC m, MonadIO m) => a -> m N.NodeNotification+n_queryM = get . n_query++-- | Turn node on or off.+n_run_ :: (Node a, Monad m) => a -> Bool -> Request m ()+n_run_ n b = sendOSC $ C.n_run [(fromIntegral (nodeId n), b)]++-- | Set a node's control values.+n_set :: (Node a, Monad m) => a -> [(String, Double)] -> Request m ()+n_set n = sendOSC . C.n_set (fromIntegral (nodeId n))++-- | Set ranges of a node's control values.+n_setn :: (Node a, Monad m) => a -> [(String, [Double])] -> Request m ()+n_setn n = sendOSC . C.n_setn (fromIntegral (nodeId n))++-- | Trace a node.+n_trace :: (Node a, Monad m) => a -> Request m ()+n_trace n = sendOSC $ C.n_trace [fromIntegral (nodeId n)]++-- | Move an ordered sequence of nodes.+n_order :: (Node n, Monad m) => AddAction -> n -> [AbstractNode] -> Request m ()+n_order a n = sendOSC . C.n_order a (fromIntegral (nodeId n)) . map (fromIntegral.nodeId)++-- ====================================================================+-- Synth++newtype Synth = Synth NodeId deriving (Eq, Ord, Show)++instance Node Synth where+ nodeId (Synth nid) = nid++-- | Create a new synth.+s_new :: MonadIdAllocator m => SynthDef -> AddAction -> Group -> [(String, Double)] -> Request m Synth+s_new d a g xs = do+ nid <- M.alloc M.nodeIdAllocator+ sendOSC $ C.s_new (name d) (fromIntegral nid) a (fromIntegral (nodeId g)) xs+ return $ Synth nid++-- | Create a new synth in the root group.+s_new_ :: (MonadServer m, MonadIdAllocator m) => SynthDef -> AddAction -> [(String, Double)] -> Request m Synth+s_new_ d a xs = rootNode >>= \g -> s_new d a g xs++-- | Release a synth with a "gate" envelope control.+s_release :: MonadIdAllocator m => Double -> Synth -> Request m ()+s_release r s = do+ sendOSC (C.n_set1 (fromIntegral nid) "gate" r)+ after_ (N.n_end_ nid) (M.free M.nodeIdAllocator nid)+ where nid = nodeId s++-- | Get control values.+s_get :: MonadIO m => Synth -> [String] -> Request m (Result [(Either Int String, Double)])+s_get s cs = do+ sendOSC (C.s_get (fromIntegral nid) cs)+ waitFor (N.n_set nid)+ where nid = nodeId s++-- | Get ranges of control values.+s_getn :: MonadIO m => Synth -> [(String, Int)] -> Request m (Result [(Either Int String, [Double])])+s_getn s cs = do+ sendOSC (C.s_getn (fromIntegral nid) cs)+ waitFor (N.n_setn nid)+ where nid = nodeId s++-- | Free a synth's ID and auto-reassign it to a reserved value (the node is not freed!).+s_noid :: MonadIdAllocator m => Synth -> Request m ()+s_noid s = do+ sendOSC (C.s_noid [fromIntegral nid])+ M.free M.nodeIdAllocator nid+ where nid = nodeId s++-- ====================================================================+-- Group++newtype Group = Group NodeId deriving (Eq, Ord, Show)++instance Node Group where+ nodeId (Group nid) = nid++-- | Return the server's root group.+rootNode :: MonadServer m => m Group+rootNode = liftM Group M.rootNodeId++-- | Create a new group.+g_new :: MonadIdAllocator m => AddAction -> Group -> Request m Group+g_new a p = do+ nid <- M.alloc M.nodeIdAllocator+ sendOSC $ C.g_new [(fromIntegral nid, a, fromIntegral (nodeId p))]+ return $ Group nid++-- | Create a new group in the top level group.+g_new_ :: (MonadServer m, MonadIdAllocator m) => AddAction -> Request m Group+g_new_ a = rootNode >>= g_new a++-- | Free all synths in this group and all its sub-groups.+g_deepFree :: Monad m => Group -> Request m ()+g_deepFree g = sendOSC $ C.g_deepFree [fromIntegral (nodeId g)]++-- | Delete all nodes in a group.+g_freeAll :: Monad m => Group -> Request m ()+g_freeAll g = sendOSC $ C.g_freeAll [fromIntegral (nodeId g)]++-- | Add node to head of group.+g_head :: (Node n, Monad m) => Group -> n -> Request m ()+g_head g n = sendOSC $ C.g_head [(fromIntegral (nodeId g), fromIntegral (nodeId n))]++-- | Add node to tail of group.+g_tail :: (Node n, Monad m) => Group -> n -> Request m ()+g_tail g n = sendOSC $ C.g_tail [(fromIntegral (nodeId g), fromIntegral (nodeId n))]++-- | Post a representation of a group's node subtree, optionally including the current control values for synths.+g_dumpTree :: Monad m => [(Group, Bool)] -> Request m ()+g_dumpTree = sendOSC . C.g_dumpTree . map (first (fromIntegral . nodeId))++-- ====================================================================+-- Plugin Commands++-- | Send a plugin command.+cmd :: Monad m => String -> [Datum] -> Request m ()+cmd s = sendOSC . C.cmd s++-- ====================================================================+-- Unit Generator Commands++-- | Send a command to a unit generator.+u_cmd :: Monad m => AbstractNode -> Int -> String -> [Datum] -> Request m ()+u_cmd n i s = sendOSC . C.u_cmd (fromIntegral (nodeId n)) i s++-- ====================================================================+-- Buffer Commands++newtype Buffer = Buffer { bufferId :: BufferId } deriving (Eq, Ord, Show)++-- | Allocates zero filled buffer to number of channels and samples. (Asynchronous)+b_alloc :: MonadIdAllocator m => Int -> Int -> Request m Buffer+b_alloc n c = mkAsync $ do+ bid <- M.alloc M.bufferIdAllocator+ let f osc = (mkC C.b_alloc C.b_alloc' osc) (fromIntegral bid) n c+ return (Buffer bid, f)++-- | Allocate buffer space and read a sound file. (Asynchronous)+b_allocRead :: MonadIdAllocator m => FilePath -> Maybe Int -> Maybe Int -> Request m Buffer+b_allocRead path fileOffset numFrames = mkAsync $ do+ bid <- M.alloc M.bufferIdAllocator+ let f osc = (mkC C.b_allocRead C.b_allocRead' osc)+ (fromIntegral bid) path+ (maybe 0 id fileOffset)+ (maybe (-1) id numFrames)+ return (Buffer bid, f)++-- | Allocate buffer space and read a sound file, picking specific channels. (Asynchronous)+b_allocReadChannel :: MonadIdAllocator m => FilePath -> Maybe Int -> Maybe Int -> [Int] -> Request m Buffer+b_allocReadChannel path fileOffset numFrames channels = mkAsync $ do+ bid <- M.alloc M.bufferIdAllocator+ let f osc = (mkC C.b_allocReadChannel C.b_allocReadChannel' osc)+ (fromIntegral bid) path+ (maybe 0 id fileOffset)+ (maybe (-1) id numFrames)+ channels+ return (Buffer bid, f)++-- | Read sound file data into an existing buffer. (Asynchronous)+b_read :: Monad m =>+ Buffer+ -> FilePath+ -> Maybe Int+ -> Maybe Int+ -> Maybe Int+ -> Bool+ -> Request m ()+b_read (Buffer bid) path fileOffset numFrames bufferOffset leaveOpen =+ mkAsync_ $ \osc -> (mkC C.b_read C.b_read' osc)+ (fromIntegral bid) path+ (maybe 0 id fileOffset)+ (maybe (-1) id numFrames)+ (maybe 0 id bufferOffset)+ leaveOpen++-- | Read sound file data into an existing buffer, picking specific channels. (Asynchronous)+b_readChannel :: MonadIO m =>+ Buffer+ -> FilePath+ -> Maybe Int+ -> Maybe Int+ -> Maybe Int+ -> Bool+ -> [Int]+ -> Request m ()+b_readChannel (Buffer bid) path fileOffset numFrames bufferOffset leaveOpen channels =+ mkAsync_ $ \osc -> (mkC C.b_readChannel C.b_readChannel' osc)+ (fromIntegral bid) path+ (maybe 0 id fileOffset)+ (maybe (-1) id numFrames)+ (maybe 0 id bufferOffset)+ leaveOpen+ channels++-- | Write sound file data. (Asynchronous)+b_write :: MonadIO m =>+ Buffer+ -> FilePath+ -> SoundFileFormat+ -> SampleFormat+ -> Maybe Int+ -> Maybe Int+ -> Bool+ -> Request m ()+b_write (Buffer bid) path+ soundFileFormat sampleFormat+ fileOffset numFrames+ leaveOpen = mkAsync_ f+ where+ f osc = (mkC C.b_write C.b_write' osc)+ (fromIntegral bid) path+ soundFileFormat+ sampleFormat+ (maybe 0 id fileOffset)+ (maybe (-1) id numFrames)+ leaveOpen++-- | Free buffer. (Asynchronous)+b_free :: MonadIdAllocator m => Buffer -> Request m ()+b_free b = mkAsync $ do+ let bid = bufferId b+ M.free M.bufferIdAllocator bid+ let f osc = (mkC C.b_free C.b_free' osc) (fromIntegral bid)+ return ((), f)++-- | Zero sample data. (Asynchronous)+b_zero :: MonadIO m => Buffer -> Request m ()+b_zero buffer = mkAsync_ $ \osc ->+ (mkC C.b_zero C.b_zero' osc)+ (fromIntegral (bufferId buffer))++-- | Set sample values.+b_set :: Monad m => Buffer -> [(Int, Double)] -> Request m ()+b_set buffer = sendOSC . C.b_set (fromIntegral (bufferId buffer))++-- | Set ranges of sample values.+b_setn :: Monad m => Buffer -> [(Int, [Double])] -> Request m ()+b_setn buffer = sendOSC . C.b_setn (fromIntegral (bufferId buffer))++-- | Fill ranges of sample values.+b_fill :: Monad m => Buffer -> [(Int, Int, Double)] -> Request m ()+b_fill buffer = sendOSC . C.b_fill (fromIntegral (bufferId buffer))++-- | Call a command to fill a buffer. (Asynchronous)+b_gen :: MonadIdAllocator m => Buffer -> String -> [Datum] -> Request m ()+b_gen buffer cmd = withSync . C.b_gen (fromIntegral (bufferId buffer)) cmd++-- | Fill a buffer with partials, specifying amplitudes.+b_gen_sine1 :: MonadIdAllocator m => Buffer -> [B_Gen] -> [Double] -> Request m ()+b_gen_sine1 buffer flags = withSync . C.b_gen_sine1 (fromIntegral (bufferId buffer)) flags++-- | Fill a buffer with partials, specifying frequencies (in cycles per buffer) and amplitudes.+b_gen_sine2 :: MonadIdAllocator m => Buffer -> [B_Gen] -> [(Double, Double)] -> Request m ()+b_gen_sine2 buffer flags = withSync . C.b_gen_sine2 (fromIntegral (bufferId buffer)) flags++-- | Fill a buffer with partials, specifying frequencies (in cycles per buffer), amplitudes and phases.+b_gen_sine3 :: MonadIdAllocator m => Buffer -> [B_Gen] -> [(Double, Double, Double)] -> Request m ()+b_gen_sine3 buffer flags = withSync . C.b_gen_sine3 (fromIntegral (bufferId buffer)) flags++-- | Fills a buffer with a series of chebyshev polynomials.++-- Chebychev polynomials can be defined as:+--+-- cheby(n) = amplitude * cos(n * acos(x))+--+-- The first float value specifies the amplitude for n = 1, the second float+-- value specifies the amplitude for n = 2, and so on. To eliminate a DC offset+-- when used as a waveshaper, the wavetable is offset so that the center value+-- is zero.+b_gen_cheby :: MonadIdAllocator m => Buffer -> [B_Gen] -> [Double] -> Request m ()+b_gen_cheby buffer flags = withSync . C.b_gen_cheby (fromIntegral (bufferId buffer)) flags++-- | Copy samples from the source buffer to the destination buffer.+b_gen_copy :: MonadIdAllocator m => Buffer -> Int -> Buffer -> Int -> Maybe Int -> Request m ()+b_gen_copy buffer sampleOffset srcBuffer srcSampleOffset numSamples =+ withSync $ C.b_gen_copy (fromIntegral (bufferId buffer))+ sampleOffset+ (fromIntegral (bufferId srcBuffer))+ srcSampleOffset+ numSamples++-- | Close attached soundfile and write header information. (Asynchronous)+b_close :: Monad m => Buffer -> Request m ()+b_close buffer = mkAsync_ $ \osc -> mkC C.b_close C.b_close' osc $ fromIntegral (bufferId buffer)++-- | Request 'BufferInfo'.+b_query :: MonadIO m => Buffer -> Request m (Result N.BufferInfo)+b_query (Buffer bid) = do+ sendOSC (C.b_query [fromIntegral bid])+ waitFor (N.b_info bid)++-- | Request 'BufferInfo'.+b_queryM :: (MonadIdAllocator m, RequestOSC m, MonadIO m) => Buffer -> m N.BufferInfo+b_queryM = get . b_query++-- ====================================================================+-- Bus++-- | Abstract interface for control and audio rate buses.+class Bus a where+ -- | Rate of computation.+ rate :: a -> Rate+ -- | Number of channels.+ numChannels :: a -> Int+ -- | Free bus.+ freeBus :: (MonadServer m, MonadIdAllocator m) => a -> m ()++-- | Audio bus.+newtype AudioBus = AudioBus { audioBusIdRange :: Range AudioBusId } deriving (Eq, Show)++-- | Get audio bus id.+audioBusId :: AudioBus -> AudioBusId+audioBusId = Range.begin . audioBusIdRange++instance Bus AudioBus where+ rate _ = AR+ numChannels = Range.size . audioBusIdRange+ freeBus b = do+ hw <- isHardwareBus b+ unless hw $ M.freeRange M.audioBusIdAllocator (audioBusIdRange 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 $ audioBusId b >= 0 && audioBusId 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)+ then failure InvalidId+ else return (AudioBus r)++-- | Get hardware output bus.+outputBus :: (MonadServer m, Failure AllocFailure m) => Int -> Int -> m AudioBus+outputBus n i = do+ k <- serverOption numberOfOutputBusChannels+ let r = Range.sized n (fromIntegral i)+ if Range.begin r < 0 || Range.end r > fromIntegral k+ then failure InvalidId+ else return (AudioBus r)++-- | Control bus.+newtype ControlBus = ControlBus { controlBusIdRange :: Range ControlBusId } deriving (Eq, Show)++-- | Get control bus ID.+controlBusId :: ControlBus -> ControlBusId+controlBusId = Range.begin . controlBusIdRange++instance Bus ControlBus where+ rate _ = KR+ numChannels = Range.size . controlBusIdRange+ freeBus = M.freeRange M.controlBusIdAllocator . controlBusIdRange++-- | Allocate control bus with the specified number of channels.+newControlBus :: MonadIdAllocator m => Int -> m ControlBus+newControlBus = liftM ControlBus . M.allocRange M.controlBusIdAllocator
+ Sound/SC3/Server/State/Monad/Process.hs view
@@ -0,0 +1,47 @@+module Sound.SC3.Server.State.Monad.Process (+ withTransport+, withSynth+, withDefaultSynth+-- * Re-exported for convenience+, module Sound.SC3.Server.Process+) where++import Data.Default (def)+import qualified Sound.SC3.Server.Connection as Conn+import Sound.SC3.Server.Process hiding (withSynth, withTransport)+import qualified Sound.SC3.Server.Process as Process+import Sound.SC3.Server.State.Monad (Server)+import qualified Sound.SC3.Server.State.Monad as Server++-- | Open a transport to an existing @scsynth@ process determined by+-- 'networkPort' and run the supplied 'Server' action.+withTransport ::+ ServerOptions -- ^ General server options+ -> RTOptions -- ^ Realtime server options+ -> Server a -- ^ Action to execute+ -> IO a -- ^ Action result+withTransport serverOptions rtOptions action =+ Process.withTransport+ serverOptions+ rtOptions+ $ \t -> Conn.open t >>= Server.runServer action serverOptions++-- | Start an @scsynth@ instance and run the supplied 'Server' action.+--+-- When the action returns, @scsynth@ will quit.+withSynth ::+ ServerOptions -- ^ General server options+ -> RTOptions -- ^ Realtime server options+ -> OutputHandler -- ^ Output handler+ -> Server a -- ^ Action to execute+ -> IO a -- ^ Action result+withSynth serverOptions rtOptions outputHandler action =+ Process.withSynth+ serverOptions+ rtOptions+ outputHandler+ $ \t -> Conn.open t >>= Server.runServer action serverOptions++-- | Start an @scsynth@ instance with default options and run the supplied 'Server' action.+withDefaultSynth :: Server a -> IO a+withDefaultSynth = withSynth def def def
+ Sound/SC3/Server/State/Monad/Request.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+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 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.OpenSoundControl (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'++-- | Internal state used for constructing bundles from 'Request' actions.+data State m = State {+ requests :: Builder -- ^ Current list of OSC messages.+ , notifications :: [Notification (m ())] -- ^ Current list of notifications to synchronise on.+ , cleanup :: m () -- ^ Cleanup action to deallocate resources.+ , needsSync :: Bool -- ^ Whether last bundle needs a synchronisation barrier.+ }++-- | The empty state.+emptyState :: Monad m => State m+emptyState = State BuildDone [] (return ()) False++-- | Server-side action (or sequence of actions).+newtype Request m a = Request (State.StateT (State m) m a)+ deriving (Applicative, Functor, Monad)++-- | Lift a ServerT action into Request.+--+-- 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.+lift :: Monad m => m a -> Request m a+lift = Request . Trans.lift++-- | Get a value from the state.+gets :: Monad m => (State m -> a) -> Request m a+gets = Request . State.gets++-- | Modify the state in a Request action.+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++-- | Bundles are flattened into the resulting bundle because @scsynth@ doesn't+-- support nested bundles.+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++-- | Allocation action newtype wrapper.+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++-- | Representation of a deferred server resource.+--+-- Resource resource values can only be observed with 'extract' after the+-- surrounding 'Request' action has been executed with 'exec'.+newtype Result a = Result (IO a)+ deriving (Applicative, Functor, Monad)++-- | Extract a 'Result'\'s value.+extract :: MonadIO m => Result a -> m a+extract (Result a) = liftIO a++-- | Register a cleanup action that is executed after the notification has been+-- received and return the notification result.+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)++-- | 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 () -> Request m ()+after_ n (AllocT m) =+ modify $ \s -> s { notifications = fmap (const (return ())) n : notifications s+ , cleanup = cleanup s >> m }++-- | Wait for a notification and return the result.+waitFor :: MonadIO m => Notification a -> Request m (Result a)+waitFor n = after n (return ())++-- | Register a cleanup action that is executed after all asynchronous commands+-- and notifications have been performed.+finally :: Monad m => AllocT m () -> Request m ()+finally (AllocT m) = modify $ \s -> s { cleanup = cleanup s >> m }++-- | 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 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++-- | Create an asynchronous command from an OSC function that has side effects+-- only on the server.+mkAsync_ :: Monad m => (Maybe Bundle -> Message) -> Request m ()+mkAsync_ f = mkAsync $ return ((), f)++-- | Create a synchronisation barrier message.+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)++-- | Add a synchronisation barrier to a request if needed.+finish :: MonadIdAllocator m => Request m a -> Request m a+finish m = do+ a <- m+ b <- gets needsSync+ when b $ mkSync >>= sendOSC+ return a++-- | Run a request, returning the action's result, an OSC packet,+-- a list of notifications to synchronise on and a cleanup action.+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)++-- | Execute a request.+--+-- The commands after the last asynchronous command will be scheduled at the given time.+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++-- | Execute a request immediately.+exec_ :: (MonadIdAllocator m, RequestOSC m) => Request m a -> m a+exec_ = exec immediately
examples/hello.hs view
@@ -1,13 +1,10 @@ import Control.Monad.IO.Class (liftIO) import Sound.SC3.UGen-import Sound.SC3.Server.Monad-import Sound.SC3.Server.Monad.Command+import Sound.SC3.Server.State.Monad+import Sound.SC3.Server.State.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 Sound.SC3.Server.State.Monad.Process (withDefaultSynth) import qualified Sound.OpenSoundControl as OSC sine = out 0 $ pan2 x (sinOsc KR 1 0) 1@@ -18,23 +15,21 @@ pauseThread = liftIO . OSC.pauseThread statusLoop = do- immediately !> status >>= extract >>= liftIO . print+ statusM >>= 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+ --exec_ $ 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)]+ synth <- exec_ $ do+ sd <- d_recv "hsc3-server:sine" sine+ s_new sd AddToTail r [("freq", 440), ("amp", 0.2)] fork statusLoop pauseThread 10- immediately !> s_release 0 synth+ exec_ $ s_release 0 synth pauseThread 2
examples/sine-grains.hs view
@@ -2,68 +2,80 @@ 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+import Sound.SC3.Server.State.Monad+import Sound.SC3.Server.State.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 Sound.SC3.Server.State.Monad.Process (withDefaultSynth)+import Sound.OpenSoundControl (pauseThread, pauseThreadUntil) import qualified Sound.OpenSoundControl as OSC import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch)) import System.Random +-- Simple sine grain synthdef with frequency and amplitude controls and an ASR envelope.+sine :: UGen 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-+-- | Once a second ask for the server status and print it.+statusLoop :: Server () statusLoop = do- immediately !> status >>= extract >>= liftIO . print- pauseThread 1- statusLoop+ statusM >>= liftIO . print+ pauseThread 1+ statusLoop -keepRunning = liftIO . isEmptyMVar+-- | Latency imposed on packets sent to the server.+latency :: Double+latency = 0.03 +-- | Random sine grain generator loop.+grainLoop :: MVar a -> SynthDef -> Double -> Double -> Double -> Server () 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+ -- Get a random frequency between 100 and 800 Hz+ f <- liftIO $ randomRIO (100,800)+ -- Get a random amplitude between 0.1 and 0.3+ a <- liftIO $ randomRIO (0.1,0.3)+ -- Get the root node+ r <- rootNode+ -- Create a synth of the sine grain SynthDef with the random freqyency and amplitude from above+ -- Schedule the synth for execution in 'latency' seconds in order to avoid jitter+ synth <- (t + latency) `exec` s_new synthDef AddToTail r [("freq", f), ("amp", a)]+ -- Fork a thread for releasing the synth after 'sustain' seconds+ fork $ do+ -- Calculate the time at which to release the synth and pause+ let t' = t + sustain 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+ -- Release the synth, taking latency into account+ (t' + latency) `exec` s_release 0 synth+ -- Calculate the time for the next iteration and pause+ let t' = t + delta+ pauseThreadUntil t'+ -- Check whether to exit the loop and recurse+ b <- liftIO $ isEmptyMVar quit+ when b $ grainLoop quit synthDef delta sustain t' -latency = 0.03- newBreakHandler :: IO (MVar ()) newBreakHandler = do- quit <- newEmptyMVar- void $ installHandler keyboardSignal- (Catch $ putStrLn "Quitting..." >> putMVar quit ())- Nothing- return quit- + 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+ -- Install keyboard break handler+ quit <- newBreakHandler+ -- Run an scsynth process+ -- You need the hsc3-server-internal package in order to use the internal server+ -- withDefaultInternal $ do+ withDefaultSynth $ do+ -- Create a new SynthDef+ sd <- exec_ $ d_recv "hsc3-server:sine" sine+ -- Fork the status display loop+ fork statusLoop+ -- Enter the grain loop+ grainLoop quit sd 0.03 0.06 =<< liftIO OSC.time+ takeMVar quit
hsc3-server.cabal view
@@ -1,5 +1,5 @@ Name: hsc3-server-Version: 0.4.0+Version: 0.5.0 Synopsis: SuperCollider server resource management and synchronization. Description: This library provides abstractions for managing SuperCollider server@@ -13,10 +13,9 @@ Category: Sound Copyright: Copyright (c) Stefan Kersten 2008-2012 Author: Stefan Kersten-Maintainer: Stefan Kersten-Stability: experimental-Homepage: http://space.k-hornz.de/software/hsc3-server-Tested-With: GHC == 6.10, GHC == 6.12, GHC == 7.0, GHC == 7.2+Maintainer: kaoskorobase@gmail.com+Homepage: https://github.com/kaoskorobase/hsc3-server+Tested-With: GHC == 7.4 Build-Type: Simple Cabal-Version: >= 1.9.2 @@ -27,39 +26,37 @@ Library Exposed-Modules: Sound.SC3.Server.Allocator- Sound.SC3.Server.Allocator.Range Sound.SC3.Server.Allocator.BlockAllocator.FirstFit+ Sound.SC3.Server.Allocator.Range Sound.SC3.Server.Allocator.SetAllocator Sound.SC3.Server.Allocator.SimpleAllocator Sound.SC3.Server.Allocator.Wrapped- Sound.SC3.Server.Connection- Sound.SC3.Server.Connection.ListenerMap- Sound.SC3.Server.Connection.ListenerMap.HashTable- Sound.SC3.Server.Connection.ListenerMap.List- Sound.SC3.Server.Monad- Sound.SC3.Server.Monad.Command- Sound.SC3.Server.Monad.Process- Sound.SC3.Server.Monad.Request+ Sound.SC3.Server.State.Monad+ Sound.SC3.Server.State.Monad.Class+ Sound.SC3.Server.State.Monad.Command+ Sound.SC3.Server.State.Monad.Process Sound.SC3.Server.Notification- Sound.SC3.Server.State Other-Modules:- Sound.SC3.Server.Allocator.BlockAllocator.FreeList + Sound.SC3.Server.Allocator.BlockAllocator.FreeList+ Sound.SC3.Server.Connection+ Sound.SC3.Server.State.Monad.Request+ Sound.SC3.Server.State Build-Depends:- base >= 3 && < 5- , 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+ base >= 4.3 && < 5+ , bitset >= 1.0+ , containers >= 0.2+ , data-default >= 0.5+ , failure >= 0.2+ , hashtables >= 1.0+ , hosc >= 0.13+ , hsc3 >= 0.13+ , hsc3-process == 0.8.*+ , lifted-base >= 0.1+ , ListZipper+ , monad-control >= 0.3+ , resourcet >= 0.3+ , transformers >= 0.2+ , transformers-base >= 0.4 Ghc-Options: -W Ghc-Prof-Options:@@ -70,69 +67,66 @@ Location: git://github.com/kaoskorobase/hsc3-server.git Executable hsc3-hello- Main-Is: examples/hello.hs+ Main-Is: hello.hs+ Hs-Source-Dirs: examples 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+ base >= 4.3 && < 5+ , hosc >= 0.13+ , hsc3 >= 0.13+ , hsc3-server >= 0.5+ , transformers >= 0.2 Ghc-Options:- -rtsopts -threaded+ -W -rtsopts -threaded+ Ghc-Prof-Options:+ -W -rtsopts -threaded -auto-all Executable hsc3-sine-grains- Main-Is: examples/sine-grains.hs+ Main-Is: sine-grains.hs+ Hs-Source-Dirs: examples 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+ base >= 4.3 && < 5+ , hosc >= 0.13+ , hsc3 >= 0.13+ , hsc3-server >= 0.5+ , random >= 1.0+ , transformers >= 0.2+ , unix >= 2.5 Ghc-Options:- -rtsopts -threaded+ -W -rtsopts -threaded+ Ghc-Prof-Options:+ -W -rtsopts -threaded -auto-all Test-Suite hsc3-server-test Type: exitcode-stdio-1.0 Main-Is: test.hs+ Hs-Source-Dirs: tests Other-Modules: Sound.SC3.Server.Allocator.Test Sound.SC3.Server.Allocator.Range.Test Build-Depends:- base >= 3 && < 5- , bitset >= 1.0- , deepseq >= 1.1- , failure >= 0.1+ base >= 4.3 && < 5+ , failure >= 0.2+ , hsc3-server >= 0.5 , QuickCheck >= 2.4- , random >= 1.0+ , random , test-framework , test-framework-quickcheck2 , transformers >= 0.2- Hs-Source-Dirs: tests, .+ Ghc-Options:+ -W -rtsopts -threaded+ Ghc-Prof-Options:+ -W -rtsopts -threaded -auto-all++-- Test-Suite hsc3-server-doctests+-- Type: exitcode-stdio-1.0+-- Ghc-Options: -threaded+-- Main-Is: tests/doctests.hs+-- Build-Depends: base, doctest >= 0.8
tests/Sound/SC3/Server/Allocator/Range/Test.hs view
@@ -5,23 +5,26 @@ ) where import Sound.SC3.Server.Allocator.Range+import Prelude hiding (null) -import Control.Monad (liftM)-import System.Random (Random)+import Control.Applicative ((<$>), (<*>)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck+import Test.QuickCheck (Arbitrary(..), NonNegative) -instance (Integral i, Arbitrary i, Random i) => Arbitrary (Range i) where- arbitrary = do- l <- liftM fromIntegral (arbitrary :: Gen (NonNegative i))- h <- choose (l, l + 2048)- return $ range l h+instance (Integral i, Arbitrary i) => Arbitrary (Range i) where+ arbitrary = sized <$> ((`mod`10000) <$> arbitrary) <*> arbitrary tests :: [Test] tests = [ testGroup "Sound.SC3.Server.Allocator.Range" [ testProperty "bounds" $ \(r :: Range Int) -> begin r <= end r+ , testProperty "split" $ \(n :: NonNegative Int) (r :: Range Int) ->+ let n' = fromIntegral n+ (r1, r2) = split n' r in+ if n' > size r+ then r1 == r && null r2+ else size r1 == n' && size r2 == (size r - n') , testProperty "split/join" $ \(n :: Int) (r :: Range Int) -> uncurry join (split n r) == r ] ]
tests/Sound/SC3/Server/Allocator/Test.hs view
@@ -1,63 +1,119 @@-{-# LANGUAGE ExistentialQuantification- , FlexibleContexts- , GADTs- , ScopedTypeVariables- , TypeFamilies #-}-module Sound.SC3.Server.Allocator.Test- (- tests- ) where+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Sound.SC3.Server.Allocator.Test (+ tests+) where import Sound.SC3.Server.Allocator import qualified Sound.SC3.Server.Allocator.Wrapped as Wrapped import qualified Sound.SC3.Server.Allocator.SimpleAllocator import qualified Sound.SC3.Server.Allocator.SetAllocator-import Sound.SC3.Server.Allocator.BlockAllocator.FirstFit (Coalescing(LazyCoalescing), Sorting(..))+import Sound.SC3.Server.Allocator.BlockAllocator.FirstFit (Coalescing(..), Sorting(..)) import qualified Sound.SC3.Server.Allocator.BlockAllocator.FirstFit import Sound.SC3.Server.Allocator.Range.Test () +import Control.Applicative import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck -data WrappedIdAllocator = forall a . (IdAllocator a, Id a ~ Id WrappedIdAllocator, Show a) => WrappedIdAllocator a+import Debug.Trace -instance Show WrappedIdAllocator where- show (WrappedIdAllocator a) = show a+data AnyIdAllocator = forall a . (IdAllocator a, Id a ~ Id AnyIdAllocator, Show a) => AnyIdAllocator a -instance IdAllocator WrappedIdAllocator where- type Id WrappedIdAllocator = Int- alloc (WrappedIdAllocator a) = Wrapped.alloc WrappedIdAllocator a- free i (WrappedIdAllocator a) = Wrapped.free WrappedIdAllocator i a- statistics (WrappedIdAllocator a) = Wrapped.statistics a+instance Show AnyIdAllocator where+ show (AnyIdAllocator a) = show a +instance IdAllocator AnyIdAllocator where+ type Id AnyIdAllocator = Int+ alloc (AnyIdAllocator a) = Wrapped.alloc AnyIdAllocator a+ free i (AnyIdAllocator a) = Wrapped.free AnyIdAllocator i a+ statistics (AnyIdAllocator a) = Wrapped.statistics a+ instance Arbitrary Sorting where- arbitrary = elements (enumFromTo Address DecreasingSize)+ arbitrary = elements (enumFromTo Address DecreasingSize) -instance Arbitrary WrappedIdAllocator where- arbitrary = do- r <- arbitrary- s <- arbitrary- elements [ WrappedIdAllocator (Sound.SC3.Server.Allocator.SimpleAllocator.cons r)- , WrappedIdAllocator (Sound.SC3.Server.Allocator.SetAllocator.cons r)- , WrappedIdAllocator (Sound.SC3.Server.Allocator.BlockAllocator.FirstFit.cons s LazyCoalescing r) ]+instance Arbitrary Coalescing where+ --arbitrary = elements (enumFromTo NoCoalescing LazyCoalescing)+ arbitrary = return LazyCoalescing +instance Arbitrary AnyIdAllocator where+ arbitrary = oneof [+ AnyIdAllocator . Sound.SC3.Server.Allocator.SimpleAllocator.cons+ <$> arbitrary+ , AnyIdAllocator . Sound.SC3.Server.Allocator.SetAllocator.cons+ <$> arbitrary+ , AnyIdAllocator <$>+ (Sound.SC3.Server.Allocator.BlockAllocator.FirstFit.cons+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary) ]++data AnyRangeAllocator =+ forall a . (RangeAllocator a, Id a ~ Id AnyRangeAllocator, Show a) =>+ AnyRangeAllocator a++instance Show AnyRangeAllocator where+ show (AnyRangeAllocator a) = show a++instance IdAllocator AnyRangeAllocator where+ type Id AnyRangeAllocator = Int+ alloc (AnyRangeAllocator a) = Wrapped.alloc AnyRangeAllocator a+ free i (AnyRangeAllocator a) = Wrapped.free AnyRangeAllocator i a+ statistics (AnyRangeAllocator a) = Wrapped.statistics a++instance RangeAllocator AnyRangeAllocator where+ allocRange i (AnyRangeAllocator a) = Wrapped.allocRange AnyRangeAllocator i a+ freeRange r (AnyRangeAllocator a) = Wrapped.freeRange AnyRangeAllocator r a++instance Arbitrary AnyRangeAllocator where+ arbitrary = AnyRangeAllocator+ <$> (Sound.SC3.Server.Allocator.BlockAllocator.FirstFit.cons+ <$> arbitrary+ <*> pure LazyCoalescing+ <*> arbitrary)++allocAll !a rs =+ if numFree (statistics a) == 0+ then return (a, rs)+ else do+ n <- choose (1, min 4 (numFree (statistics a)))+ let Just (r, a') = allocRange n a+ allocAll a' (r:rs)++freeAll !a rs = do+ case rs of+ [] -> return a+ (r:rs) -> do+ let Just a' = freeRange r a+ freeAll a' (reverse rs)+ tests :: [Test]-tests = [ testGroup "Sound.SC3.Server.Allocator"- [ testGroup "IdAllocator"- [ testProperty "initial statistics" $ \(a :: WrappedIdAllocator) ->- let s = statistics a- in numFree s == numAvailable s && numUsed s == 0- , testProperty "statistics after allocating something" $ \(a :: WrappedIdAllocator) (n :: Int) ->- let n' = max 0 (min n (numAvailable (statistics a)))- Just (_, a') = allocMany n' a- s = statistics a'- in numFree s == (numAvailable s - n') && numUsed s == n'- , testProperty "statistics after allocating everything" $ \(a :: WrappedIdAllocator) ->- let Just (_, a') = allocMany (numAvailable (statistics a)) a- s = statistics a'- in numFree s == 0 && numUsed s == numAvailable s- ]- ]- ]+tests =+ [ testGroup "Sound.SC3.Server.Allocator"+ [ testGroup "IdAllocator"+ [ testProperty "initial statistics" $ \(a :: AnyIdAllocator) ->+ let s = statistics a+ in numFree s == numAvailable s && numUsed s == 0+ , testProperty "statistics after allocating something" $ \(a :: AnyIdAllocator) (n :: Int) ->+ let n' = max 0 (min n (numAvailable (statistics a)))+ Just (_, a') = allocMany n' a+ s = statistics a'+ in numFree s == (numAvailable s - n') && numUsed s == n'+ , testProperty "statistics after allocating everything" $ \(a :: AnyIdAllocator) ->+ let Just (_, a') = allocMany (numAvailable (statistics a)) a+ s = statistics a'+ in numFree s == 0 && numUsed s == numAvailable s+ , testProperty "statistics stay the same after allocating and freeing everything (RangeAllocator)" $ \(a :: AnyRangeAllocator) -> do+ let s = statistics a+ (a, rs) <- allocAll a []+ a <- freeAll a rs+ return $ statistics a == s+ ]+ ]+ ]