packages feed

hsc3-server 0.1.0 → 0.3.0

raw patch · 22 files changed

+1884/−351 lines, 22 filesdep +QuickCheckdep +containersdep +randomdep −mtldep ~basedep ~data-accessordep ~deepseq

Dependencies added: QuickCheck, containers, random, test-framework, test-framework-quickcheck2

Dependencies removed: mtl

Dependency ranges changed: base, data-accessor, deepseq, failure, hsc3-process, transformers

Files

Sound/SC3/Server/Allocator.hs view
@@ -4,32 +4,70 @@   , TypeFamilies #-}  module Sound.SC3.Server.Allocator-    ( AllocFailure(..)+    ( -- *Allocation errors+      AllocFailure(..)+      -- * Allocator statistics+    , Statistics(..)+    , percentFree+    , percentUsed+      -- * Allocator classes     , IdAllocator(..)     , RangeAllocator(..)+      -- * Identifier ranges     , module Sound.SC3.Server.Allocator.Range     ) where  import Control.Exception (Exception) import Control.Failure (Failure)-import Control.Monad (replicateM)+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 +-- | Failure type for allocators. data AllocFailure =-    NoFreeIds-  | InvalidId+    NoFreeIds   -- ^ There are no free ids left in the allocator.+  | InvalidId   -- ^ The id being released has not been allocated by this allocator.   deriving (Show, Typeable)  instance Exception AllocFailure +-- | Simple allocator usage statistics.+data Statistics = Statistics {+    numAvailable :: Int     -- ^ Total number of available identifiers+  , numFree :: Int          -- ^ Number of currently available identifiers+  , numUsed :: Int          -- ^ Number of identifiers currently in use+  } deriving (Eq, Show)++-- | Percentage of currently available identifiers.+--+-- > percentFree s = numFree s / numAvailable s+-- > percentFree s + percentUsed s = 1+percentFree :: Statistics -> Double+percentFree s = fromIntegral (numFree s) / fromIntegral (numAvailable s)++-- | Percentage of identifiers currently in use.+--+-- > percentUsed s = numUsed s / numAvailable s+-- > percentUsed s + percentFree s = 1+percentUsed :: Statistics -> Double+percentUsed s = fromIntegral (numUsed s) / fromIntegral (numAvailable s)++-- | IdAllocator provides an interface for allocating and releasing+-- 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)++    -- | 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 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@@ -38,6 +76,17 @@                 State.put $! s'                 return 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++-- | RangeAllocator provides an interface for allocating and releasing ranges+-- 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
+ Sound/SC3/Server/Allocator/BlockAllocator/FirstFit.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts+           , TypeFamilies #-}+module Sound.SC3.Server.Allocator.BlockAllocator.FirstFit+  (+    FirstFitAllocator+  , Sorting(..)+  , Coalescing(..)+  , cons+  , addressFit+  , bestFit+  , worstFit+  ) where++import           Control.Arrow (first)+import           Control.DeepSeq (NFData(..))+import           Control.Failure (Failure, failure)+import           Control.Monad (liftM)+import           Sound.SC3.Server.Allocator+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++data Coalescing = NoCoalescing | LazyCoalescing deriving (Enum, Eq, Show)++data FirstFitAllocator i = FirstFitAllocator {+    coalescing :: Coalescing+  , available :: !Int+  , used :: !Int+  , 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)++addressFit :: Integral i => Coalescing -> Range i -> FirstFitAllocator i+addressFit = cons Address++bestFit :: Integral i => Coalescing -> Range i -> FirstFitAllocator i+bestFit = cons IncreasingSize++worstFit :: Integral i => Coalescing -> Range i -> FirstFitAllocator i+worstFit = cons DecreasingSize++_alloc :: (Integral i, Failure AllocFailure m) => Int -> FirstFitAllocator i -> m (Range i, FirstFitAllocator i)+_alloc n a =+    case FreeList.alloc fits (freeList a) of+        Nothing -> case coalescing a of+                    NoCoalescing ->+                        failure NoFreeIds+                    LazyCoalescing ->+                        case FreeList.alloc fits (FreeList.coalesce (freeList a)) of+                            Nothing -> failure NoFreeIds+                            Just (r, l) -> alloc r l+        Just (r, l) -> alloc r l+    where+        fits r = Range.size r >= n+        alloc r l =+            if Range.size r == n+            then return (r, a { freeList = l+                              , used = used a + n })+            else let (r1, r2) = Range.split n r+                 in return (r1, a { freeList = FreeList.insert r2 l+                                  , used = used a + n })++_free :: (Integral i, Failure AllocFailure m) => Range i -> FirstFitAllocator i -> m (FirstFitAllocator i)+_free r a =+    let u = used a - fromIntegral (Range.size r)+    in if u < 0+       then failure InvalidId+       else return a { freeList = FreeList.insert r (freeList a)+                     , used = u }++_statistics :: (Integral i) => FirstFitAllocator i -> Statistics+_statistics a =+    Statistics {+        numAvailable = available a+      , numFree = available a - used a+      , numUsed = used a }++instance (Integral i) => IdAllocator (FirstFitAllocator i) where+    type Id (FirstFitAllocator i) = i+    alloc = liftM (first Range.begin) . _alloc 1+    free = _free . sized 1+    statistics = _statistics++instance (Integral i) => RangeAllocator (FirstFitAllocator i) where+    allocRange = _alloc+    freeRange = _free
+ Sound/SC3/Server/Allocator/BlockAllocator/FreeList.hs view
@@ -0,0 +1,73 @@+module Sound.SC3.Server.Allocator.BlockAllocator.FreeList+  (+    FreeList+  , Sorting(..)+  , empty+  , singleton+  , fromList+  , insert+  , alloc+  , coalesce+  ) where++import           Control.DeepSeq (NFData(..))+import           Data.Ord (comparing)+import qualified Data.List as List+import           Sound.SC3.Server.Allocator.Range (Range)+import qualified Sound.SC3.Server.Allocator.Range as Range++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++sortFunc :: Integral i => Sorting -> SortFunc i+sortFunc s = f+    where f = case s of+                Address -> comparing Range.begin+                IncreasingSize -> comparing Range.size+                DecreasingSize -> flip (comparing Range.size)++sortBy :: Integral i => Sorting -> [Range i] -> [Range i]+sortBy s = List.sortBy (sortFunc s)++insertBy :: Integral i => Sorting -> Range i -> [Range i] -> [Range i]+insertBy s = List.insertBy (sortFunc s)++empty :: Sorting -> FreeList i+empty s = FreeList s []++singleton :: Sorting -> Range i -> FreeList i+singleton s r = FreeList s [r]++fromList :: Integral i => Sorting -> [Range i] -> FreeList i+fromList s = FreeList s . sortBy s++insert :: Integral i => Range i -> FreeList i -> FreeList i+insert r (FreeList s l) = FreeList s (insertBy s r l)++alloc :: (Range i -> Bool) -> FreeList i -> Maybe (Range i, FreeList i)+alloc p (FreeList s l) =+    case List.break p l of+        (_, []) -> Nothing+        (l1, (r:l2)) -> Just (r, FreeList s (l1 ++ l2))++coalescel :: Ord i => [Range i] -> [Range i]+coalescel [] = []+coalescel l@(_:[]) = l+coalescel (r1:r2:l)+    | Range.adjoins r1 r2 = coalescel (Range.join r1 r2 : l)+    | otherwise           = r1 : coalescel (r2 : l)++sortedByAddress :: Integral i => ([Range i] -> [Range i]) -> FreeList i -> FreeList i+sortedByAddress f (FreeList s l) =+    case s of+        Address -> FreeList s (f l)+        _       -> FreeList s (sortBy s (f (sortBy Address l)))++coalesce :: Integral i => FreeList i -> FreeList i+coalesce = sortedByAddress coalescel
Sound/SC3/Server/Allocator/Range.hs view
@@ -1,9 +1,11 @@ module Sound.SC3.Server.Allocator.Range (     Range   , range+  , sized   , empty-  , lowerBound-  , upperBound+  , begin+  , end+  , last   , size   , null   , toList@@ -12,14 +14,18 @@   , adjoins   , overlaps   , contains+  , split   , join ) where  import Control.DeepSeq (NFData(..))-import Prelude hiding (null)+import Prelude hiding (last, null) --- |Model intervals [a, b[-data Range a = Range !a !a deriving (Eq, Show)+-- | Model intervals [begin, end[+data Range a = Range {+    begin :: !a+  , end :: !a+  } deriving (Eq, Show)  instance NFData a => NFData (Range a) where     rnf (Range x1 x2) = rnf x1 `seq` rnf x2 `seq` ()@@ -31,35 +37,42 @@ range a b | a <= b    = mkRange a b           | otherwise = mkRange b a -empty :: Num a => Range a-empty = mkRange 0 0+sized :: Num a => Int -> a -> Range a+sized n a = mkRange a (a + fromIntegral n) -lowerBound :: Range a -> a-lowerBound (Range a _) = a+empty :: Num a => a -> Range a+empty a = mkRange a a -upperBound :: Range a -> a-upperBound (Range _ a) = a+last :: Enum a => Range a -> a+last = pred . end -size :: Num a => Range a -> a-size a = upperBound a - lowerBound a+size :: Integral a => Range a -> Int+size a = fromIntegral (end a - begin a)  null :: Eq a => Range a -> Bool-null a = lowerBound a == upperBound a+null a = begin a == end a  toList :: Enum a => Range a -> [a]-toList a = [lowerBound a..pred (upperBound a)]+toList a = [begin a..last a]  within :: Ord a => a -> Range a -> Bool-x `within` a = x >= lowerBound a && x < upperBound a+x `within` a = x >= begin a && x < end a  adjoins :: Eq a => Range a -> Range a -> Bool-a `adjoins` b = (upperBound a == lowerBound b) || (upperBound b == lowerBound a)+a `adjoins` b = (end a == begin b) || (end b == begin a)  overlaps :: Ord a => Range a -> Range a -> Bool-a `overlaps` b = (upperBound a > lowerBound b) || (upperBound b > lowerBound a)+a `overlaps` b = (end a > begin b) || (end b > begin a)  contains :: Ord a => Range a -> Range a -> Bool-a `contains` b = lowerBound b >= lowerBound a && upperBound b <= upperBound a+a `contains` b = begin b >= begin a && end b <= end a +split :: Integral a => Int -> Range a -> (Range a, Range a)+split n r@(Range l u)+    | n <= 0 = (empty l, r)+    | n >= size r = (r, empty u)+    | otherwise = (mkRange l (l+k), mkRange (l+k) u)+    where k = fromIntegral n+ join :: Ord a => Range a -> Range a -> Range a-join a b = mkRange (min (lowerBound a) (lowerBound b)) (max (upperBound a) (upperBound b))+join a b = mkRange (min (begin a) (begin b)) (max (end a) (end b))
Sound/SC3/Server/Allocator/SetAllocator.hs view
@@ -8,7 +8,7 @@  import Control.Failure (Failure, failure) import Control.DeepSeq (NFData(..))-import Data.BitSet as Set+import qualified Data.BitSet as Set import Sound.SC3.Server.Allocator  data SetAllocator i =@@ -25,30 +25,51 @@         rnf x3 `seq` ()  cons :: Range i -> SetAllocator i-cons r = SetAllocator r Set.empty (lowerBound r)+cons r = SetAllocator r Set.empty (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+ findNext :: (Integral i) => SetAllocator i -> Maybe i-findNext (SetAllocator r u n) = loop (succ n)+findNext (SetAllocator r u i)+    | fromIntegral (size r) == Set.size u = Nothing+    | otherwise = loop i     where-        loop !i-            | i == n = Nothing-            | i == upperBound r = loop (lowerBound r)-            | Set.member (fromIntegral i) u = loop (succ i)-            | otherwise = Just i+        wrap i = if i >= end r+                    then begin r+                    else i+        loop !i = let i' = wrap (i+1)+                  in if Set.member (toBit r i') u+                     then loop i'+                     else Just i' -sa_alloc :: (Integral i, Failure AllocFailure m) => SetAllocator i -> m (i, SetAllocator i)-sa_alloc s@(SetAllocator r u n)-    | Set.member (fromIntegral n) u = failure NoFreeIds-    | otherwise = case findNext s of-                    Nothing -> failure NoFreeIds-                    Just n' -> return (n, SetAllocator r (Set.insert (fromIntegral n) u) n')+_alloc :: (Integral i, Failure AllocFailure m) => SetAllocator i -> m (i, SetAllocator i)+_alloc a@(SetAllocator r u i) =+    case findNext a of+        Nothing -> failure NoFreeIds+        Just i' -> return (i, SetAllocator r (Set.insert (toBit r i) u) i') -sa_free :: (Integral i, Failure AllocFailure m) => i -> SetAllocator i -> m (SetAllocator i)-sa_free i (SetAllocator r u n) | Set.member (fromIntegral i) u = return (SetAllocator r u' n)-                               | otherwise = failure InvalidId-    where u' = Set.delete (fromIntegral i) u+_free :: (Integral i, Failure AllocFailure m) => i -> SetAllocator i -> m (SetAllocator i)+_free i (SetAllocator r u n) =+    if Set.member (toBit r i) u+    then let u' = Set.delete (toBit r i) u+         in return (SetAllocator r u' n)+    else failure InvalidId +_statistics :: (Integral i) => SetAllocator i -> Statistics+_statistics (SetAllocator r u _) =+    let k = fromIntegral (size r)+        n = Set.size u+    in Statistics {+        numAvailable = k+      , numFree = k - n+      , numUsed = n }+ instance (Integral i) => IdAllocator (SetAllocator i) where     type Id (SetAllocator i) = i-    alloc = sa_alloc-    free  = sa_free+    alloc                    = _alloc+    free                     = _free+    statistics               = _statistics
Sound/SC3/Server/Allocator/SimpleAllocator.hs view
@@ -1,27 +1,49 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts+           , TypeFamilies #-} module Sound.SC3.Server.Allocator.SimpleAllocator (     SimpleAllocator   , cons ) where  import Control.DeepSeq (NFData(..))+import Control.Failure (Failure, failure) import Sound.SC3.Server.Allocator -newtype SimpleAllocator i = SimpleAllocator i deriving (Eq, Show)+data SimpleAllocator i =+    SimpleAllocator+        {-# UNPACK #-}!(Range i)+        {-# UNPACK #-}!Int+                      !i+        deriving (Eq, Show)  instance NFData i => NFData (SimpleAllocator i) where-    rnf (SimpleAllocator x1) = rnf x1 `seq` ()+    rnf (SimpleAllocator x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () -cons :: Num i => SimpleAllocator i-cons = SimpleAllocator 0+cons :: Range i -> SimpleAllocator i+cons r = SimpleAllocator r 0 (begin r) -sa_alloc :: (Num i, Monad m) => SimpleAllocator i -> m (i, SimpleAllocator i)-sa_alloc (SimpleAllocator n) = return (n, SimpleAllocator (n+1))+_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')) -sa_free :: (Monad m) => i -> SimpleAllocator i -> m (SimpleAllocator i)-sa_free _ sa = return sa+_free :: (Failure AllocFailure m) => i -> SimpleAllocator i -> m (SimpleAllocator i)+_free _ (SimpleAllocator r n i) =+    let n' = n-1+    in if n' < 0+       then failure InvalidId+       else return (SimpleAllocator r n' i) +_statistics :: Integral i => SimpleAllocator i -> Statistics+_statistics (SimpleAllocator r n _) =+    let k = fromIntegral (size r)+    in Statistics {+        numAvailable = k+      , numFree = k - n+      , numUsed = n }+ instance (Integral i) => IdAllocator (SimpleAllocator i) where     type Id (SimpleAllocator i) = i-    alloc = sa_alloc-    free  = sa_free+    alloc                       = _alloc+    free                        = _free+    statistics                  = _statistics
+ Sound/SC3/Server/Allocator/Wrapped.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Helper functions for newtype wrappers.+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 qualified Sound.SC3.Server.Allocator as Alloc++alloc :: (Failure AllocFailure m, IdAllocator a) =>+    (a -> a') -> a -> m (Id a, a')+alloc f = liftM (second f) . Alloc.alloc++free :: (Failure AllocFailure m, IdAllocator a) =>+    (a -> a') -> Id a -> a -> m a'+free f i = liftM f . Alloc.free i++statistics :: IdAllocator a => a -> Statistics+statistics = Alloc.statistics++allocRange :: (Failure AllocFailure m, RangeAllocator a) =>+    (a -> a') -> Int -> a -> m (Range (Id a), a')+allocRange f n = liftM (second f) . Alloc.allocRange n++freeRange :: (Failure AllocFailure m, RangeAllocator a) =>+    (a -> a') -> Range (Id a) -> a -> m a'+freeRange f r = liftM f . Alloc.freeRange r
Sound/SC3/Server/Connection.hs view
@@ -1,33 +1,45 @@ {-# LANGUAGE ExistentialQuantification+           , FlexibleContexts            , GeneralizedNewtypeDeriving #-}-module Sound.SC3.Server.Connection (-    Connection+-- | A 'Connection' encapsulates the transport needed for communicating with the synthesis server, the client-side state (e.g. resource id allocators) and various synchronisation primitives.+module Sound.SC3.Server.Connection+  ( Connection   , state   , new   , close-  , fork-  , async-  , syncWith-  , syncAddress+    -- * Allocation+  , alloc+  , free+  , allocMany+  , freeMany+  , allocRange+  , freeRange+    -- * Communication and synchronisation+  , send+  , waitFor+  , waitFor_+  , waitForAll+  , waitForAll_   , sync   , unsafeSync-) where+  ) where -import           Control.Concurrent (ThreadId, forkIO)+import           Control.Concurrent (forkIO) import           Control.Concurrent.MVar-import qualified Data.HashTable as Hash+import           Control.Concurrent.Chan+import           Control.Monad (liftM, replicateM, void)+import           Data.Accessor import           Sound.OpenSoundControl (Datum(..), OSC(..), Transport, immediately) import qualified Sound.OpenSoundControl as OSC- import           Sound.SC3 (notify)-import           Sound.SC3.Server.Notification (done, synced)-import           Sound.SC3.Server.State (State, SyncId)+import           Sound.SC3.Server.Notification (Notification(..), synced)+import           Sound.SC3.Server.Allocator (Id, IdAllocator, Range, RangeAllocator)+import qualified Sound.SC3.Server.Allocator as Alloc+import           Sound.SC3.Server.Connection.ListenerMap (Listener, ListenerId, ListenerMap)+import qualified Sound.SC3.Server.Connection.ListenerMap as ListenerMap+import           Sound.SC3.Server.State (Allocator, State, SyncId) import qualified Sound.SC3.Server.State as State-import qualified Sound.SC3.Server.State.Concurrent as IOState -type ListenerId  = Int-type Listener    = OSC -> IO ()-data ListenerMap = ListenerMap !(Hash.HashTable ListenerId Listener) !ListenerId data Connection  = forall t . Transport t => Connection t (MVar State) (MVar ListenerMap)  state :: Connection -> MVar State@@ -37,68 +49,124 @@ listeners (Connection _ _ l) = l  initServer :: Connection -> IO ()-initServer c = do-    Bundle immediately [notify True] `syncWith` done "notify" $ c-    return ()+initServer c = sync c (Bundle immediately [notify True])  recvLoop :: Connection -> IO () recvLoop c@(Connection t _ _) = do     osc <- OSC.recv t-    withMVar (listeners c) (\(ListenerMap h _) -> mapM_ (\(_, l) -> l osc) =<< Hash.toList h)+    withMVar (listeners c) (ListenerMap.broadcast osc)     recvLoop c +-- | Create a new connection given the initial server state and an OSC transport. new :: Transport t => State -> t -> IO Connection new s t = do-    ios <- IOState.fromState s-    h  <- Hash.new (==) Hash.hashInt-    lm <- newMVar (ListenerMap h 0)+    ios <- newMVar s+    lm <- newMVar =<< ListenerMap.empty     let c = Connection t ios lm     _ <- forkIO $ recvLoop c     initServer c     return c +-- | Close the connection.+--+-- The behavior of sending messages after closing the connection is undefined. close :: Connection -> IO () close (Connection t _ _) = OSC.close t -fork :: Connection -> (Connection -> IO ()) -> IO ThreadId-fork c f = forkIO (f c)+-- ====================================================================+-- Allocation -addListener :: Listener -> Connection -> IO ListenerId-addListener l c = modifyMVar-                    (listeners c) $-                    \(ListenerMap h lid) -> do-                        Hash.insert h lid l-                        -- lc <- Hash.longestChain h-                        -- putStrLn $ "addListener: longestChain=" ++ show (length lc)-                        return (ListenerMap h (lid+1), lid)+withAllocator :: Connection -> Allocator a -> (a -> IO (b, a)) -> IO b+withAllocator c a f = modifyMVar (state c) $ \s -> do+    let x = s ^. a+    (i, x') <- f x+    return $ (a ^= x' $ s, i) -removeListener :: ListenerId -> Connection -> IO ()-removeListener uid c = modifyMVar_ (listeners c) (\lm@(ListenerMap h _) -> Hash.delete h uid >> return lm)+withAllocator_ :: Connection -> Allocator a -> (a -> IO a) -> IO ()+withAllocator_ c a f = withAllocator c a $ liftM ((,)()) . f -async :: OSC -> Connection -> IO ()-async osc (Connection t _ _) = OSC.send t osc+alloc :: IdAllocator a => Connection -> Allocator a -> IO (Id a)+alloc c a = withAllocator c a Alloc.alloc -syncWith :: OSC -> (OSC -> Maybe a) -> Connection -> IO a-syncWith s f c = do+free :: IdAllocator a => Connection -> Allocator a -> Id a -> IO ()+free c a = withAllocator_ c a . Alloc.free++allocMany :: IdAllocator a => Connection -> Allocator a -> Int -> IO [Id a]+allocMany c a = withAllocator c a . Alloc.allocMany++freeMany :: IdAllocator a => Connection -> Allocator a -> [Id a] -> IO ()+freeMany c a = withAllocator_ c a . Alloc.freeMany++allocRange :: RangeAllocator a => Connection -> Allocator a -> Int -> IO (Range (Id a))+allocRange c a = withAllocator c a . Alloc.allocRange++freeRange :: RangeAllocator a => Connection -> Allocator a -> Range (Id a) -> IO ()+freeRange c a = withAllocator_ c a . Alloc.freeRange++-- ====================================================================+-- Communication and synchronization++-- | 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++-- | Add a listener.+--+-- Listeners are entered in a hash table, although the allocation behavior may be more stack-like.+addListener :: Connection -> Listener -> IO ListenerId+addListener c l = modifyMVar (listeners c) $ \lm -> do+    (uid, lm') <- ListenerMap.add l lm+    return (lm', uid)++-- | Remove a listener.+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 (action res) c-    s `async` c+    uid <- addListener c (mkListener (putMVar res) n)+    send c osc     a <- takeMVar res-    removeListener uid c+    removeListener c uid     return a-    where-        action res osc = do-            case f osc of-                Nothing -> return ()-                Just a  -> putMVar res a --- | Wait for an OSC message matching a specific address.-syncAddress :: OSC -> String -> Connection -> IO OSC-syncAddress s a = s `syncWith` hasAddress-    where-        hasAddress m@(Message a' _) = if a == a' then Just m else Nothing-        hasAddress _                = Nothing+-- | 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+ -- | Append a @\/sync@ message to an OSC packet. appendSync :: OSC -> SyncId -> OSC appendSync p i =@@ -107,14 +175,14 @@         (Bundle t xs)   -> Bundle t (xs ++ [s])     where s = Message "/sync" [Int (fromIntegral i)] -sync :: OSC -> Connection -> IO ()-sync osc c = do-    i <- IOState.alloc State.syncId (state c)-    _ <- osc `appendSync` i `syncWith` synced i $ c-    IOState.free State.syncId (state c) i-    return ()+-- | Send an OSC packet and wait for the synchronization barrier.+sync :: Connection -> OSC -> IO ()+sync c osc = do+    i <- alloc c State.syncIdAllocator+    waitFor_ c (osc `appendSync` i) (synced i)+    free c State.syncIdAllocator i  -- NOTE: This is only guaranteed to work with a transport that preserves -- packet order. NOTE 2: And not even then ;) unsafeSync :: Connection -> IO ()-unsafeSync = sync (Bundle immediately [])+unsafeSync c = sync c (Bundle immediately [])
+ Sound/SC3/Server/Connection/ListenerMap.hs view
@@ -0,0 +1,6 @@+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 view
@@ -0,0 +1,34 @@+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 view
@@ -0,0 +1,26 @@+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 view
@@ -1,114 +1,161 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Sound.SC3.Server.Monad (-  -- *Server Monad+{-# LANGUAGE FlexibleContexts+           , GeneralizedNewtypeDeriving+           , MultiParamTypeClasses #-}+module Sound.SC3.Server.Monad+  ( -- * Server Monad     ServerT   , runServerT   , Server   , runServer-  , lift   , liftIO-  , rootNode-  -- *Allocators+  , connection+  -- * Server options+  , MonadServer(..)+  , serverOption+  -- * Allocation+  , Allocator   , BufferId+  , BufferIdAllocator+  , bufferIdAllocator   , BusId+  , BusIdAllocator+  , audioBusIdAllocator+  , controlBusIdAllocator   , NodeId-  , nodeId-  , bufferId-  , busId-  , alloc-  , allocMany-  , free-  , allocRange-  , freeRange-  -- *Synchronization-  , fork-  , async-  , syncWith-  , syncAddress+  , NodeIdAllocator+  , nodeIdAllocator+  , Range+  , MonadIdAllocator(..)+  -- * Communication and synchronization+  , MonadSendOSC(..)+  , MonadRecvOSC(..)+  , SyncId+  , SyncIdAllocator+  , syncIdAllocator   , sync   , unsafeSync-) where+  -- * Concurrency+  , fork+  ) where -import           Control.Concurrent (ThreadId)+import           Control.Applicative+import           Control.Concurrent (ThreadId, forkIO) import           Control.Concurrent.MVar.Strict-import           Control.Monad.Reader (MonadReader, ReaderT(..), ask, asks, lift)-import           Control.Monad.Trans (MonadIO, MonadTrans, liftIO)+import           Control.Monad (MonadPlus, liftM)+import           Control.Monad.Fix (MonadFix)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.Trans.Reader (ReaderT(..), ask, asks)+import           Control.Monad.Trans.Class (MonadTrans) import           Data.Accessor-import           Sound.SC3 (Rate(..))+import           Sound.OpenSoundControl (OSC) import           Sound.SC3.Server.Allocator (Id, IdAllocator, RangeAllocator, Range) import           Sound.SC3.Server.Connection (Connection) import qualified Sound.SC3.Server.Connection as C--- import           Sound.SC3.Server.Process.Options (ServerOptions, numberOfInputBusChannels, numberOfOutputBusChannels)-import           Sound.SC3.Server.State (BufferId, BufferIdAllocator, BusId, BusIdAllocator, NodeId, NodeIdAllocator, State)+import           Sound.SC3.Server.Notification (Notification)+import           Sound.SC3.Server.Options (ServerOptions)+import           Sound.SC3.Server.State ( Allocator+                                        , BufferId, BufferIdAllocator, bufferIdAllocator+                                        , BusId, BusIdAllocator, audioBusIdAllocator, controlBusIdAllocator+                                        , NodeId, NodeIdAllocator, nodeIdAllocator+                                        , SyncId, SyncIdAllocator, syncIdAllocator+                                        , State) import qualified Sound.SC3.Server.State as State-import qualified Sound.SC3.Server.State.Concurrent as IOState -import           Sound.OpenSoundControl (OSC)- newtype ServerT m a = ServerT (ReaderT Connection m a)-    deriving (Functor, Monad, MonadReader Connection, MonadIO, MonadTrans)+    deriving (Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadTrans)  type Server = ServerT IO -type Allocator a = Accessor State a- liftConn :: MonadIO m => (Connection -> IO a) -> ServerT m a-liftConn f = ask >>= \c -> liftIO (f c)+liftConn f = ServerT $ ask >>= \c -> liftIO (f c)  liftState :: MonadIO m => (State -> a) -> ServerT m a-liftState f = asks C.state >>= liftIO . readMVar >>= return . f+liftState f = ServerT $ asks C.state >>= liftIO . readMVar >>= return . f +-- | Run a 'ServerT' computation given a connection and return the result. runServerT :: ServerT m a -> Connection -> m a runServerT (ServerT r) = runReaderT r +-- | Run a 'Server' computation given a connection and return the result in the IO monad. runServer :: Server a -> Connection -> IO a runServer = runServerT -rootNode :: MonadIO m => ServerT m NodeId-rootNode = liftState State.rootNode+-- | Return the connection.+connection :: MonadIO m => ServerT m Connection+connection = liftConn return +class Monad m => MonadServer m where+    -- | Return the server options.+    serverOptions :: m ServerOptions -nodeId :: Allocator NodeIdAllocator-nodeId = State.nodeId+-- | Return a server option.+serverOption :: MonadServer m => (ServerOptions -> a) -> m a+serverOption = flip liftM serverOptions -bufferId :: Allocator BufferIdAllocator-bufferId = State.bufferId+-- serverOptions :: MonadIO m => ServerT m ServerOptions+instance MonadIO m => MonadServer (ServerT m) where+    serverOptions = liftState (getVal State.serverOptions) -busId :: Rate -> Allocator BusIdAllocator-busId AR = State.audioBusId-busId KR = State.controlBusId-busId r  = error ("No bus allocator for rate " ++ show r)+-- | 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) => Allocator a -> m (Id a) -alloc :: (IdAllocator a, MonadIO m) => Allocator a -> ServerT m (Id a)-alloc a = asks C.state >>= liftIO . IOState.alloc a+    -- | Free an id using the given allocator.+    free :: (IdAllocator a) => Allocator a -> Id a -> m () -allocMany :: (IdAllocator a, MonadIO m) => Allocator a -> Int -> ServerT m [Id a]-allocMany a n = asks C.state >>= liftIO . flip (IOState.allocMany a) n+    -- | Allocate a number of ids using the given allocator.+    allocMany :: (IdAllocator a) => Allocator a -> Int -> m [Id a] -free :: (IdAllocator a, MonadIO m) => Allocator a -> Id a -> ServerT m ()-free a i = asks C.state >>= liftIO . flip (IOState.free a) i+    -- | Free a number of ids using the given allocator.+    freeMany :: (IdAllocator a) => Allocator a -> [Id a] -> m () -allocRange :: (RangeAllocator a, MonadIO m) => Allocator a -> Int -> ServerT m (Range (Id a))-allocRange a n = asks C.state >>= liftIO . flip (IOState.allocRange a) n+    -- | Allocate a contiguous range of ids using the given allocator.+    allocRange :: (RangeAllocator a) => Allocator a -> Int -> m (Range (Id a)) -freeRange :: (RangeAllocator a, MonadIO m) => Allocator a -> Range (Id a) -> ServerT m ()-freeRange a r = asks C.state >>= liftIO . flip (IOState.freeRange a) r+    -- | Free a contiguous range of ids using the given allocator.+    freeRange :: (RangeAllocator a) => Allocator a -> Range (Id a) -> m () -fork :: (MonadIO m) => ServerT IO () -> ServerT m ThreadId-fork = liftConn . flip C.fork . runServerT+instance (MonadIO m) => MonadIdAllocator (ServerT m) where+    rootNodeId = liftState State.rootNodeId+    alloc a = liftConn $ \c -> C.alloc c a+    free a i = liftConn $ \c -> C.free c a i+    allocMany a n = liftConn $ \c -> C.allocMany c a n+    freeMany a is = liftConn $ \c -> C.freeMany c a is+    allocRange a n = liftConn $ \c -> C.allocRange c a n+    freeRange a r = liftConn $ \c -> C.freeRange c a r -async :: (MonadIO m) => OSC -> ServerT m ()-async = liftConn . C.async+class Monad m => MonadSendOSC m where+    send :: OSC -> m () -syncWith :: (MonadIO m) => OSC -> (OSC -> Maybe a) -> ServerT m a-syncWith s = liftConn . C.syncWith s+instance MonadIO m => MonadSendOSC (ServerT m) where+    send osc = liftConn $ \c -> C.send c osc -syncAddress :: (MonadIO m) => OSC -> String -> ServerT m OSC-syncAddress s = liftConn . C.syncAddress s+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 = liftConn $ \c -> C.waitFor c osc n+    waitFor_ osc n = liftConn $ \c -> C.waitFor_ c osc n+    waitForAll osc ns = liftConn $ \c -> C.waitForAll c osc ns+    waitForAll_ osc ns = liftConn $ \c -> C.waitForAll_ c osc ns+ sync :: (MonadIO m) => OSC -> ServerT m ()-sync = liftConn . C.sync+sync osc = liftConn $ \c -> C.sync c osc  unsafeSync :: (MonadIO m) => ServerT m () unsafeSync = liftConn C.unsafeSync++-- | Fork a computation in a new thread and return the thread id.+fork :: (MonadIO m) => ServerT IO () -> ServerT m ThreadId+fork a = liftConn $ \c -> forkIO (runServerT a c)
+ Sound/SC3/Server/Monad/Command.hs view
@@ -0,0 +1,476 @@+{-# 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_new+  , 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+  , 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)+import           Control.Monad.IO.Class (MonadIO)+import           Sound.SC3 (Rate(..), UGen)+import qualified Sound.SC3.Server.Allocator.Range as Range+import           Sound.SC3.Server.Monad hiding (sync, unsafeSync)+import qualified Sound.SC3.Server.Monad as M+import           Sound.SC3.Server.Monad.Send+import qualified Sound.SC3.Server.State as State+import qualified Sound.SC3.Server.Synthdef as Synthdef+import           Sound.SC3.Server.Allocator (AllocFailure(..))+import           Sound.SC3.Server.Command (AddAction(..), PrintLevel(..))+import qualified Sound.SC3.Server.Command as C+import qualified Sound.SC3.Server.Command.Completion as C+import qualified Sound.SC3.Server.Notification as N+import           Sound.SC3.Server.Options (ServerOptions(..))+import           Sound.OpenSoundControl (OSC(..))++-- ====================================================================+-- 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 => SendT m (Deferred m N.Status)+status = send C.status >> after N.status_reply (return ())++dumpOSC :: MonadIO m => PrintLevel -> SendT 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_new :: Monad m => String -> UGen -> Async m SynthDef+d_new name ugen+    | length name < 255 = mkAsync $ return (SynthDef name, f)+    | otherwise = error "d_new: 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 -> SendT 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 -> SendT m ()+n_after a b = send $ C.n_after [(fromIntegral (nodeId a), fromIntegral (nodeId b))]++-- | Place node @a@ before node @b@.+n_before :: (Node a, Node b, Monad m) => a -> b -> SendT m ()+n_before a b = send $ C.n_after [(fromIntegral (nodeId a), fromIntegral (nodeId b))]++-- | Fill ranges of a node's control values.+n_fill :: (Node a, Monad m) => a -> [(String, Int, Double)] -> SendT m ()+n_fill n = send . C.n_fill (fromIntegral (nodeId n))++-- | Delete a node.+n_free :: (Node a, MonadIO m) => a -> SendT 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 -> SendT m ()+    -- | Remove a control's mapping to a control bus.+    n_unmap :: (Node n, Bus b, Monad m) => n -> String -> b -> SendT 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 -> SendT m ()+n_query_ n = send $ C.n_query [fromIntegral (nodeId n)]++-- | Query a node.+n_query :: (Node a, MonadIO m) => a -> SendT m (Deferred m N.NodeNotification)+n_query n = n_query_ n >> after (N.n_info (nodeId n)) (return ())++-- | Turn node on or off.+n_run_ :: (Node a, Monad m) => a -> Bool -> SendT m ()+n_run_ n b = send $ C.n_run [(fromIntegral (nodeId n), b)]++-- | Set a node's control values.+n_set :: (Node a, Monad m) => a -> [(String, Double)] -> SendT m ()+n_set n = send . C.n_set (fromIntegral (nodeId n))++-- | Set ranges of a node's control values.+n_setn :: (Node a, Monad m) => a -> [(String, [Double])] -> SendT m ()+n_setn n = send . C.n_setn (fromIntegral (nodeId n))++-- | Trace a node.+n_trace :: (Node a, Monad m) => a -> SendT m ()+n_trace n = send $ C.n_trace [fromIntegral (nodeId n)]++-- | Move an ordered sequence of nodes.+n_order :: (Node n, Monad m) => AddAction -> n -> [AbstractNode] -> SendT m ()+n_order 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)] -> SendT m Synth+s_new d a g xs = do+    nid <- M.alloc M.nodeIdAllocator+    send $ C.s_new (name d) (fromIntegral nid) a (fromIntegral (nodeId g)) xs+    return $ Synth nid++s_new_ :: MonadIO m => SynthDef -> AddAction -> [(String, Double)] -> SendT m Synth+s_new_ d a xs = rootNode >>= \g -> s_new d a g xs++s_release :: (Node a, MonadIO m) => Double -> a -> SendT 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 -> SendT m Group+g_new a p = do+    nid <- M.alloc State.nodeIdAllocator+    send $ C.g_new [(fromIntegral nid, a, fromIntegral (nodeId p))]+    return $ Group nid++g_new_ :: MonadIO m => AddAction -> SendT m Group+g_new_ a = rootNode >>= g_new a++g_deepFree :: Monad m => Group -> SendT m ()+g_deepFree g = send $ C.g_deepFree [fromIntegral (nodeId g)]++g_freeAll :: Monad m => Group -> SendT m ()+g_freeAll g = send $ C.g_freeAll [fromIntegral (nodeId g)]++g_head :: (Node n, Monad m) => Group -> n -> SendT m ()+g_head g n = send $ C.g_head [(fromIntegral (nodeId g), fromIntegral (nodeId n))]++g_tail :: (Node n, Monad m) => Group -> n -> SendT m ()+g_tail g n = send $ C.g_tail [(fromIntegral (nodeId g), fromIntegral (nodeId n))]++g_dumpTree :: Monad m => [(Group, Bool)] -> SendT 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 State.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 State.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 -> SendT m (Deferred 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 :: 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 = M.freeRange M.audioBusIdAllocator . audioBusId++-- | Allocate audio bus with the specified number of channels.+newAudioBus :: MonadIdAllocator m => Int -> m AudioBus+newAudioBus = liftM AudioBus . M.allocRange M.audioBusIdAllocator++-- | 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/Send.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE GeneralizedNewtypeDeriving+           , MultiParamTypeClasses #-}++-- | This module provides abstractions for constructing bundles for server+-- resource allocation in a type safe manner. In particular, the exposed types+-- and functions make sure that asynchronous command results cannot be used+-- before they have been allocated on the server.+--+-- TODO: Real usage example+--+-- > (b0, (g, ig, b)) <- immediately !> do+-- > b0 <- async $ b_alloc 1024 1+-- > x <- b_alloc 1024 1 `whenDone` immediately $ \b -> do+-- >     b_free b `whenDone` OSC.UTCr t' $ \() -> do+-- >         g <- g_new_ AddToTail+-- >         ig <- g_new AddToTail g+-- >         return $ pure (g, ig, b)+-- > return $ (,) <$> b0 <*> x+module Sound.SC3.Server.Monad.Send+  ( SendT+  , AllocT+  -- * Deferred values+  , Deferred+  , after+  , after_+  , finally+  -- * Asynchronous commands+  , Async+  , mkAsync+  , mkAsync_+  , mkAsyncCM+  , whenDone+  , asyncM+  , async+  -- * Command execution+  , run+  , exec+  , (!>)+  , execPure+  , (~>)+  ) where++import           Control.Applicative+import           Control.Arrow (second)+import           Control.Monad (ap, liftM, when)+import           Control.Monad.IO.Class (MonadIO(..))+import qualified Control.Monad.Trans.Class as Trans+import           Control.Monad.Trans.State (StateT(..))+import qualified Control.Monad.Trans.State as State+import           Data.IORef+import           Sound.SC3.Server.Monad (MonadIdAllocator, MonadSendOSC(..), MonadServer, ServerT)+import qualified Sound.SC3.Server.Monad as M+import qualified Sound.SC3.Server.State as State+import qualified Sound.SC3.Server.Command as C+import           Sound.SC3.Server.Notification (Notification)+import qualified Sound.SC3.Server.Notification as N+import           Sound.OpenSoundControl (OSC(..), Time, immediately)++{-++goals:++* after executing action and synchronizing, all server actions have been executed+* server actions are consistent, i.e. asynchronous resources are not used before they are allocated (Deferred)++async sets sync state to "needs sync"+whenDone overrides sync state to "has sync"+whenDone adds a sync barrier to the completion packet when its subaction didn't add one (syncIds empty); the subaction always needs to sync!+exec adds a sync barrier when sync state is "needs sync"+-}++-- | Synchronisation state.+data SyncState =+    NoSync      -- ^ No synchronisation barrier needed.+  | NeedsSync   -- ^ Need to add a synchronisation barrier to the current context.+  | HasSync     -- ^ Synchronisation barrier already present in the current context.+  deriving (Eq, Ord, Show)++-- | Internal state used for constructing bundles from 'SendT' actions.+data State m = State {+    buildOSC      :: [OSC]                         -- ^ Current list of OSC messages.+  , notifications :: [Notification (ServerT m ())] -- ^ Current list of notifications to synchronise on.+  , cleanup       :: ServerT m ()                  -- ^ Cleanup action to deallocate resources.+  , timeTag       :: Time                          -- ^ Time tag.+  , syncState     :: SyncState                     -- ^ Synchronisation barrier state.+  }++-- | Construct a 'SendT' state with a given synchronisation state.+mkState :: Monad m => Time -> SyncState -> State m+mkState = State [] [] (return ())++-- | Push an OSC packet.+pushOSC :: OSC -> State m -> State m+pushOSC osc s = s { buildOSC = osc : buildOSC s }++-- | Return 'True' if the current context contains OSC messages.+hasOSC :: State m -> Bool+hasOSC = not . null . buildOSC++-- | Get the list of OSC packets.+getOSC :: State m -> [OSC]+getOSC = reverse . buildOSC++-- | Update the synchronisation state.+setSyncState :: SyncState -> State m -> State m+setSyncState ss s | ss > syncState s = s { syncState = ss }+                  | otherwise        = s++-- | Representation of a server-side action (or sequence of actions).+newtype SendT m a = SendT (StateT (State m) (ServerT m) a)+                    deriving (Applicative, Functor, Monad)++instance MonadIO m => MonadServer (SendT m) where+    serverOptions = liftServer M.serverOptions++instance MonadIO m => MonadIdAllocator (SendT m) where+    rootNodeId = liftServer M.rootNodeId+    alloc = liftServer . M.alloc+    free a = liftServer . M.free a+    allocMany a = liftServer . M.allocMany a+    freeMany a = liftServer . M.freeMany a+    allocRange a = liftServer . M.allocRange a+    freeRange a = liftServer . M.freeRange a++-- | Bundles are flattened into the resulting bundle because @scsynth@ doesn't+-- support nested bundles.+instance Monad m => MonadSendOSC (SendT m) where+    send osc@(Message _ _) = modify (pushOSC osc)+    send (Bundle _ xs)     = mapM_ send xs++-- | Execute a SendT action, returning the result and the final state.+runSendT :: Monad m => Time -> SyncState -> SendT m a -> ServerT m (a, State m)+runSendT t s (SendT m) = State.runStateT m (mkState t s)++-- | Get a value from the state.+gets :: Monad m => (State m -> a) -> SendT m a+gets = SendT . State.gets++-- | Modify the state in a SendT action.+modify :: Monad m => (State m -> State m) -> SendT m ()+modify = SendT . State.modify++-- | Lift a ServerT action into SendT.+--+-- This is potentially unsafe and should only be used for the allocation of+-- server resources. Lifting actions that rely on communication and+-- synchronisation primitives will not work as expected.+liftServer :: Monad m => ServerT m a -> SendT m a+liftServer = SendT . Trans.lift++-- | Allocation action newtype wrapper.+newtype AllocT m a = AllocT (ServerT m a)+                     deriving (Applicative, MonadIdAllocator, Functor, Monad)++-- | Representation of a deferred server resource.+--+-- Deferred resource values can only be observed a return value of the 'SendT'+-- action after 'exec' has been called.+--+-- Deferred has 'Applicative' and 'Functor' instances, so that complex values+-- can be built from simple ones.+newtype Deferred m a = Deferred { unDefer :: ServerT m a } deriving (Monad)++instance Monad m => Functor (Deferred m) where+    fmap f (Deferred a) = Deferred (liftM f a)++instance Monad m => Applicative (Deferred m) where+    pure = Deferred . return+    (<*>) (Deferred f) (Deferred a) = Deferred (f `ap` a)++-- | Construct a deferred value from an IO action.+deferredIO :: MonadIO m => IO a -> Deferred m a+deferredIO = Deferred . liftIO++-- | Register a cleanup action, to be executed after a notification has been+-- received and return the deferred notification result.+after :: MonadIO m => Notification a -> AllocT m () -> SendT m (Deferred m a)+after n (AllocT m) = do+    v <- liftServer $ liftIO $ newIORef (error "BUG: after: uninitialized IORef")+    modify $ \s -> s { notifications = fmap (liftIO . writeIORef v) n : notifications s+                     , cleanup = cleanup s >> m }+    return $ deferredIO (readIORef v)++-- | Register a cleanup action, to be executed after a notification has been+-- received and ignore the notification result.+after_ :: Monad m => Notification a -> AllocT m () -> SendT m ()+after_ n (AllocT m) = modify $ \s -> s { notifications = fmap (const (return ())) n : notifications s+                                       , cleanup = cleanup s >> m }++-- | Register a cleanup action, to be executed after all asynchronous commands+-- and notification have finished.+finally :: Monad m => AllocT m () -> SendT m ()+finally (AllocT m) = modify $ \s -> s { cleanup = cleanup s >> m }++-- | Representation of an asynchronous server command. Asynchronous commands+-- are executed asynchronously with respect to other server commands.+--+-- There are two different ways of synchronising with an asynchronous command:+--+-- * using 'whenDone' for server-side synchronisation, or+--+-- * using 'async' and observing the result of a 'SendT' action after calling+-- 'exec'.+newtype Async m a = Async (SendT m (a, (Maybe OSC -> OSC)))++-- | Create an asynchronous command from an allocation action.+--+-- The first return value should be a server resource allocated on the client,+-- the second a function that, given a completion packet, returns an OSC packet+-- that asynchronously allocates the resource on the server.+mkAsync :: Monad m => AllocT m (a, (Maybe OSC -> OSC)) -> Async m a+mkAsync (AllocT m) = Async (liftServer m)++-- | Create an asynchronous command from a side effecting OSC function.+mkAsync_ :: Monad m => (Maybe OSC -> OSC) -> Async m ()+mkAsync_ f = mkAsync $ return ((), f)++-- | Create an asynchronous command.+--+-- The completion message will be appended at the end of the returned message.+mkAsyncCM :: Monad m => AllocT m (a, OSC) -> Async m a+mkAsyncCM = mkAsync . liftM (second f)+    where+        f msg Nothing   = msg+        f msg (Just cm) = C.withCM msg cm++-- | Add a synchronisation barrier.+addSync :: MonadIO m => SendT m a -> SendT m a+addSync m = do+    a <- m+    b <- gets hasOSC+    when b $ do+        s <- gets syncState+        case s of+            NeedsSync -> do+                sid <- liftServer $ M.alloc State.syncIdAllocator+                send (C.sync (fromIntegral sid))+                after_ (N.synced sid) (M.free State.syncIdAllocator sid)+            _ -> return ()+    return a++-- | Execute an server-side action after the asynchronous command has+-- finished.+whenDone :: MonadIO m => Async m a -> (a -> SendT m b) -> Async m b+whenDone (Async m) f = Async $ do+    (a, g) <- m+    b <- f a+    return (b, g)++-- | Execute an asynchronous command asynchronously.+asyncM :: MonadIO m => Async m (Deferred m a) -> SendT m (Deferred m a)+asyncM (Async m) = do+    t <- gets timeTag+    ((a, g), s) <- liftServer $ runSendT t NeedsSync $ addSync m+    case getOSC s of+        [] -> do+            send (g Nothing)+            modify $ \s' -> (setSyncState NeedsSync s') {+                notifications = notifications s' ++ notifications s+              , cleanup = cleanup s' >> cleanup s }+        osc -> do+            let t' = case syncState s of+                        HasSync -> immediately+                        _       -> t+            send $ g (Just (Bundle t' osc))+            modify $ \s' -> (setSyncState HasSync s') {+                notifications = notifications s' ++ notifications s+              , cleanup = cleanup s' >> cleanup s }+    return a++-- | Execute an asynchronous command asynchronously.+async :: MonadIO m => Async m a -> SendT m (Deferred m a)+async = asyncM . flip whenDone (return . pure)++{-+-- | Execute an server-side action after the asynchronous command has+-- finished. The corresponding server commands are scheduled at a time @t@ in+-- the future.+whenDone :: MonadIO m => Async m a -> (a -> SendT m b) -> SendT m (Deferred b)+whenDone (Async m) f = do+    t <- gets timeTag+    (a, g) <- m+    (b, s) <- liftServer $ runSendT t NeedsSync $ addSync (f a)+    let t' = case syncState s of+                HasSync -> immediately+                _       -> t+    send $ g (Just (Bundle t' (getOSC s)))+    modify $ \s' -> s' {+        notifications = notifications s' ++ notifications s+      , cleanup = cleanup s' >> cleanup s+      , syncState = HasSync }+    return b++-- | Execute an asynchronous command asynchronously.+async :: MonadIO m => Async m a -> SendT m (Deferred a)+async (Async m) = do+    (a, g) <- m+    send (g Nothing)+    modify $ setSyncState NeedsSync+    return $ pure a+-}++run :: MonadIO m => Time -> SendT m (Deferred m a) -> ServerT m (ServerT m a, Maybe (OSC, [Notification (ServerT m ())]))+run t m = do+    (a, s) <- runSendT t NoSync $ addSync m+    let result = cleanup s >> unDefer a+    case getOSC s of+        [] -> return (result, Nothing)+        osc -> let t' = case syncState s of+                            HasSync -> immediately+                            _ -> t+               in return (result, Just (Bundle t' osc, notifications s))++-- | Run the 'SendT' action and return the result.+--+-- All asynchronous commands and notifications are guaranteed to have finished+-- when this function returns.+exec :: MonadIO m => Time -> SendT m (Deferred m a) -> ServerT m a+exec t m = do+    -- (a, s) <- runSendT t NoSync $ addSync m+    -- case getOSC s of+    --     [] -> return ()+    --     osc -> do+    --         -- liftIO $ print osc+    --         let t' = case syncState s of+    --                     HasSync -> immediately+    --                     _ -> t+    (action, sync) <- run t m+    case sync of+        Nothing -> return ()+        Just (osc, ns) -> M.waitForAll osc ns >>= sequence_+    action++-- | Infix operator version of 'exec'.+(!>) :: MonadIO m => Time -> SendT m (Deferred m a) -> ServerT m a+(!>) = exec++-- | Run a 'SendT' action that returns a pure result.+--+-- All asynchronous commands and notifications are guaranteed to have finished+-- when this function returns.+execPure :: MonadIO m => Time -> SendT m a -> ServerT m a+execPure t m = exec t (m >>= return . pure)++-- | Infix operator version of 'execPure'.+(~>) :: MonadIO m => Time -> SendT m a -> ServerT m a+(~>) = execPure
Sound/SC3/Server/Notification.hs view
@@ -1,17 +1,38 @@ -- | Server notification processors. module Sound.SC3.Server.Notification (-    Status(..)+    Notification(..)+  , hasAddress+  , Status(..)   , status_reply   , tr   , synced   , done-  , NodeNotification(..)+  , NodeNotification(nodeId, parentGroupId, previousNodeId, nextNodeId)+  , headNodeId, tailNodeId   , n_go , n_end , n_off , n_on , n_move , n_info+  , n_go_, n_end_, n_off_, n_on_+  , BufferInfo(..)+  , b_info ) where -import Sound.SC3.Server.State (NodeId, SyncId)+import Sound.SC3.Server.State (BufferId, NodeId, SyncId) import Sound.OpenSoundControl (OSC(..), Datum(..)) +-- | A notification transformer, extracting a value from a matching OSC packet.+newtype Notification a = Notification { match :: OSC -> Maybe a }++instance Functor Notification where+    fmap f = Notification . (.) (fmap f) . match++-- | Wait for an OSC message matching a specific address.+--+-- Returns the matched OSC message.+hasAddress :: String -> Notification OSC+hasAddress a = Notification f+    where+        f m@(Message a' _) = if a == a' then Just m else Nothing+        f _                = Nothing+ data Status = Status {     numUGens          :: Int   , numSynths         :: Int@@ -23,56 +44,136 @@   , actualSampleRate  :: Double } deriving (Eq, Show) -status_reply :: OSC -> Maybe Status-status_reply (Message "/status.reply" [Int _, Int u, Int s, Int g, Int d, Float a, Float p, Double sr, Double sr']) =-    Just $ Status u s g d a p sr sr'-status_reply _ = Nothing+status_reply :: Notification Status+status_reply = Notification f+    where+        f (Message "/status.reply" [Int _, Int u, Int s, Int g, Int d, Float a, Float p, Double sr, Double sr'])+            = Just $ Status u s g d a p sr sr'+        f _ = Nothing -tr :: NodeId -> Maybe Int -> OSC -> Maybe Double-tr n (Just i) (Message "/tr" [Int n', Int i', Float r]) | fromIntegral n == n' && i == i' = Just r-tr n Nothing  (Message "/tr" [Int n', Int _, Float r])  | fromIntegral n == n' = Just r-tr _ _        _                                         = Nothing+tr :: NodeId -> Maybe Int -> Notification Double+tr n = Notification . f+    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])+            | fromIntegral n == n' = Just r+        f _ _ = Nothing -synced :: SyncId -> OSC -> Maybe SyncId-synced i (Message "/synced" [Int j]) | fromIntegral j == i = Just i-synced _ _                                                 = Nothing+synced :: SyncId -> Notification SyncId+synced i = Notification f+    where+        f (Message "/synced" [Int j]) | fromIntegral j == i = Just i+        f _                                                 = Nothing  normalize :: String -> String normalize ('/':s) = s normalize s       = s -done :: String -> OSC -> Maybe [Datum]-done c (Message "/done" (String s:xs)) | normalize c == normalize s = Just xs-done _ _                                                            = Nothing+done :: String -> Notification [Datum]+done c = Notification f+    where+        f (Message "/done" (String s:xs)) | normalize c == normalize s = Just xs+        f _                                                            = Nothing  data NodeNotification =-    SynthNotification NodeId NodeId NodeId NodeId-  | GroupNotification NodeId NodeId NodeId NodeId NodeId NodeId+    SynthNotification {+        nodeId :: NodeId+      , parentGroupId :: NodeId+      , previousNodeId :: Maybe NodeId+      , nextNodeId :: Maybe NodeId+      }+  | GroupNotification {+        nodeId :: NodeId+      , parentGroupId :: NodeId+      , previousNodeId :: Maybe NodeId+      , nextNodeId :: Maybe NodeId+      , _headNodeId :: Maybe NodeId+      , _tailNodeId :: Maybe NodeId+      }+  deriving (Eq, Show) -n_notification :: String -> NodeId -> OSC -> Maybe NodeNotification-n_notification s nid (Message s' (Int nid':Int g:Int p:Int n:Int b:r))-    | s == s' && fromIntegral nid == nid' =-        case b of-            0 -> Just $ SynthNotification nid (fromIntegral g) (fromIntegral p) (fromIntegral n)-            _ -> case r of-                    [Int h, Int t] -> Just $ GroupNotification nid (fromIntegral g) (fromIntegral p) (fromIntegral n) (fromIntegral h) (fromIntegral t)-                    _              -> Just $ GroupNotification nid (fromIntegral g) (fromIntegral p) (fromIntegral n) (fromIntegral (-1 :: Int)) (fromIntegral (-1 :: Int))-n_notification _ _ _ = Nothing+isSynthNotification :: NodeNotification -> Bool+isSynthNotification (SynthNotification _ _ _ _) = True+isSynthNotification _ = False -n_go :: NodeId -> OSC -> Maybe NodeNotification+headNodeId :: NodeNotification -> Maybe NodeId+headNodeId n | isSynthNotification n = Nothing+             | otherwise             = _headNodeId n++tailNodeId :: NodeNotification -> Maybe NodeId+tailNodeId n | isSynthNotification n = Nothing+             | otherwise             = _tailNodeId n++n_notification :: String -> NodeId -> Notification NodeNotification+n_notification s nid = Notification f+    where+        nodeIdToMaybe (-1) = Nothing+        nodeIdToMaybe i    = Just (fromIntegral i)+        f osc =+            case osc of+                (Message s' (Int nid':xs)) ->+                    if s == s' && fromIntegral nid == nid'+                    then case xs of+                            (Int g:Int p:Int n:Int b:rest) ->+                                let group = fromIntegral g+                                    prev = nodeIdToMaybe p+                                    next = nodeIdToMaybe n+                                in case b of+                                    1 -> case rest of+                                        [Int h, Int t] -> Just $ GroupNotification nid group prev next (nodeIdToMaybe h) (nodeIdToMaybe t)+                                        _              -> Nothing+                                    _ -> Just $ SynthNotification nid group prev next+                            _ -> Nothing+                    else Nothing+                _ -> Nothing++n_go :: NodeId -> Notification NodeNotification n_go = n_notification "/n_go" -n_end :: NodeId -> OSC -> Maybe NodeNotification+n_end :: NodeId -> Notification NodeNotification n_end = n_notification "/n_end" -n_off :: NodeId -> OSC -> Maybe NodeNotification+n_off :: NodeId -> Notification NodeNotification n_off = n_notification "/n_off" -n_on :: NodeId -> OSC -> Maybe NodeNotification+n_on :: NodeId -> Notification NodeNotification n_on = n_notification "/n_on" -n_move :: NodeId -> OSC -> Maybe NodeNotification+n_move :: NodeId -> Notification NodeNotification n_move = n_notification "/n_move" -n_info :: NodeId -> OSC -> Maybe NodeNotification+n_info :: NodeId -> Notification NodeNotification n_info = n_notification "/n_info"++n_notification_ :: String -> NodeId -> Notification ()+n_notification_ s nid = Notification f+    where+        f (Message s' (Int nid':_))+            | s == s' && fromIntegral nid == nid' = Just ()+        f _ = Nothing++n_go_ :: NodeId -> Notification ()+n_go_ = n_notification_ "/n_go"++n_end_ :: NodeId -> Notification ()+n_end_ = n_notification_ "/n_end"++n_off_ :: NodeId -> Notification ()+n_off_ = n_notification_ "/n_off"++n_on_ :: NodeId -> Notification ()+n_on_ = n_notification_ "/n_on"++data BufferInfo = BufferInfo {+    numFrames :: Int+  , numChannels :: Int+  , sampleRate :: Double+  } deriving (Eq, Show)++b_info :: BufferId -> Notification BufferInfo+b_info bid = Notification f+    where+        f (Message "/b_info" [Int bid', Int f, Int c, Float r])+            | fromIntegral bid == bid' = Just $ BufferInfo f c r+        f _ = Nothing
Sound/SC3/Server/Process/Monad.hs view
@@ -1,26 +1,34 @@ module Sound.SC3.Server.Process.Monad (     withSynth+  , withDefaultSynth   , withInternal+  , withDefaultInternal+  -- * Re-exported for convenience+  , module Sound.SC3.Server.Options+  , OutputHandler(..)+  , defaultOutputHandler ) where -import           Sound.SC3.Server.Process (ServerOptions, OutputHandler, RTOptions)-import qualified Sound.SC3.Server.Process as Process import qualified Sound.SC3.Server.Connection as Conn-import qualified Sound.SC3.Server.State as State import qualified Sound.SC3.Server.Internal as Process import           Sound.SC3.Server.Monad (Server) import qualified Sound.SC3.Server.Monad as Server-import qualified Sound.OpenSoundControl as OSC+import           Sound.SC3.Server.Options+import           Sound.SC3.Server.Process ( OutputHandler(..), defaultOutputHandler )+import qualified Sound.SC3.Server.Process as Process+import qualified Sound.SC3.Server.State as State -withSynth :: OSC.Transport t => (ServerOptions -> RTOptions -> IO t) -> ServerOptions -> RTOptions -> OutputHandler -> Server a -> IO a-withSynth openTransport serverOptions rtOptions outputHandler action =+withSynth :: ServerOptions -> RTOptions -> OutputHandler -> Server a -> IO a+withSynth serverOptions rtOptions outputHandler action =     Process.withSynth-        openTransport         serverOptions         rtOptions         outputHandler         $ \t -> Conn.new (State.new serverOptions) t >>= Server.runServer action +withDefaultSynth :: Server a -> IO a+withDefaultSynth = withSynth defaultServerOptions defaultRTOptions defaultOutputHandler+ withInternal :: ServerOptions -> RTOptions -> OutputHandler -> Server a -> IO a withInternal serverOptions rtOptions outputHandler action =     Process.withInternal@@ -28,3 +36,6 @@         rtOptions         outputHandler         $ \t -> Conn.new (State.new serverOptions) t >>= Server.runServer action++withDefaultInternal :: Server a -> IO a+withDefaultInternal = withInternal defaultServerOptions defaultRTOptions defaultOutputHandler
Sound/SC3/Server/State.hs view
@@ -7,96 +7,120 @@  #include "Accessor.h" +-- | Data type for holding server state.+--+-- The server state consists mainly of the allocators needed for different types of resources, such as nodes, buffers and buses. module Sound.SC3.Server.State (     State-  , options+  , serverOptions+  , Allocator   , SyncId   , SyncIdAllocator+  , syncIdAllocator   , NodeId   , NodeIdAllocator+  , nodeIdAllocator   , BufferId   , BufferIdAllocator+  , bufferIdAllocator   , BusId   , BusIdAllocator-  , syncId-  , nodeId-  , bufferId-  , controlBusId-  , audioBusId-  , rootNode+  , controlBusIdAllocator+  , audioBusIdAllocator+  , rootNodeId   , new-  , Alloc.alloc-  , Alloc.allocMany-  , Alloc.allocRange-  , Alloc.free ) where -import           Control.Arrow (second) import           Control.DeepSeq (NFData(..))-import           Control.Monad (liftM) import           Data.Accessor-import           Sound.SC3.Server.Allocator (IdAllocator(..))+import           Data.Int (Int32)+import           Sound.SC3.Server.Allocator (IdAllocator(..), RangeAllocator(..)) import qualified Sound.SC3.Server.Allocator as Alloc-import           Sound.SC3.Server.Allocator.SetAllocator (SetAllocator)-import qualified Sound.SC3.Server.Allocator.SetAllocator as SetAlloc-import           Sound.SC3.Server.Allocator.SimpleAllocator (SimpleAllocator)-import qualified Sound.SC3.Server.Allocator.SimpleAllocator as SAlloc+import qualified Sound.SC3.Server.Allocator.BlockAllocator.FirstFit as FirstFitAllocator+import qualified Sound.SC3.Server.Allocator.SetAllocator as SetAllocator+import qualified Sound.SC3.Server.Allocator.SimpleAllocator as SimpleAllocator+import qualified Sound.SC3.Server.Allocator.Wrapped as Wrapped import           Sound.SC3.Server.Options (ServerOptions(..)) -allocM f = liftM (second f) . Alloc.alloc-freeM f i = liftM f . Alloc.free i+-- | Allocator accessor.+type Allocator a = Accessor State a -newtype SyncId = SyncId Int deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)+-- | Synchronisation barrier id.+newtype SyncId = SyncId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)++-- | Synchronisation barrier id allocator. data SyncIdAllocator = forall a . (IdAllocator a, NFData a, Id a ~ SyncId) => SyncIdAllocator !a  instance IdAllocator SyncIdAllocator where     type Id SyncIdAllocator = SyncId-    alloc  (SyncIdAllocator a) = allocM SyncIdAllocator a-    free i (SyncIdAllocator a) = freeM SyncIdAllocator i a+    alloc  (SyncIdAllocator a) = Wrapped.alloc SyncIdAllocator a+    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` () -newtype NodeId = NodeId Int deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)+-- | Node id.+newtype NodeId = NodeId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)++-- | Node id allocator. data NodeIdAllocator = forall a . (IdAllocator a, NFData a, Id a ~ NodeId) => NodeIdAllocator !a  instance IdAllocator NodeIdAllocator where     type Id NodeIdAllocator = NodeId-    alloc  (NodeIdAllocator a) = allocM NodeIdAllocator a-    free i (NodeIdAllocator a) = freeM NodeIdAllocator i a+    alloc  (NodeIdAllocator a) = Wrapped.alloc NodeIdAllocator a+    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` () -newtype BufferId = BufferId Int deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)-data BufferIdAllocator = forall a . (IdAllocator a, NFData a, Id a ~ BufferId) => BufferIdAllocator !a+-- | Buffer id.+newtype BufferId = BufferId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show) +-- | Buffer id allocator.+data BufferIdAllocator = forall a . (RangeAllocator a, NFData a, Id a ~ BufferId) => BufferIdAllocator !a+ instance IdAllocator BufferIdAllocator where     type Id BufferIdAllocator = BufferId-    alloc  (BufferIdAllocator a) = allocM BufferIdAllocator a-    free i (BufferIdAllocator a) = freeM BufferIdAllocator i a+    alloc  (BufferIdAllocator a) = Wrapped.alloc BufferIdAllocator a+    free i (BufferIdAllocator a) = Wrapped.free BufferIdAllocator i a+    statistics (BufferIdAllocator a) = Wrapped.statistics a +instance RangeAllocator BufferIdAllocator where+    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` () -newtype BusId = BusId Int deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show)-data BusIdAllocator = forall a . (IdAllocator a, NFData a, Id a ~ BusId) => BusIdAllocator !a+-- | Bus id.+newtype BusId = BusId Int32 deriving (Bounded, Enum, Eq, Integral, NFData, Num, Ord, Real, Show) +-- | Bus id allocator.+data BusIdAllocator = forall a . (RangeAllocator a, NFData a, Id a ~ BusId) => BusIdAllocator !a+ instance IdAllocator BusIdAllocator where     type Id BusIdAllocator = BusId-    alloc  (BusIdAllocator a) = allocM BusIdAllocator a-    free i (BusIdAllocator a) = freeM BusIdAllocator i a+    alloc  (BusIdAllocator a) = Wrapped.alloc BusIdAllocator a+    free i (BusIdAllocator a) = Wrapped.free BusIdAllocator i a+    statistics (BusIdAllocator a) = Wrapped.statistics a +instance RangeAllocator BusIdAllocator where+    allocRange n (BusIdAllocator a) = Wrapped.allocRange BusIdAllocator n a+    freeRange r (BusIdAllocator a) = Wrapped.freeRange BusIdAllocator r a+ instance NFData BusIdAllocator where     rnf (BusIdAllocator a) = rnf a `seq` () +-- | Server state. data State = State {-    _options      :: !ServerOptions-  , _syncId       :: !SyncIdAllocator-  , _nodeId       :: !NodeIdAllocator-  , _bufferId     :: !BufferIdAllocator-  , _controlBusId :: !BusIdAllocator-  , _audioBusId   :: !BusIdAllocator+    _serverOptions         :: !ServerOptions+  , _syncIdAllocator       :: !SyncIdAllocator+  , _nodeIdAllocator       :: !NodeIdAllocator+  , _bufferIdAllocator     :: !BufferIdAllocator+  , _controlBusIdAllocator :: !BusIdAllocator+  , _audioBusIdAllocator   :: !BusIdAllocator   }  instance NFData State where@@ -108,38 +132,47 @@         rnf x5 `seq`         rnf x6 `seq` () -ACCESSOR(options,      _options,      State, ServerOptions)-ACCESSOR(syncId,       _syncId,       State, SyncIdAllocator)-ACCESSOR(nodeId,       _nodeId,       State, NodeIdAllocator)-ACCESSOR(bufferId,     _bufferId,     State, BufferIdAllocator)-ACCESSOR(controlBusId, _controlBusId, State, BusIdAllocator)-ACCESSOR(audioBusId,   _audioBusId,   State, BusIdAllocator)+-- | Server options used to create this instance.+ACCESSOR(serverOptions,         _serverOptions,         State, ServerOptions)+-- | Synchronisation id allocator.+ACCESSOR(syncIdAllocator,       _syncIdAllocator,       State, SyncIdAllocator)+-- | Node id allocator.+ACCESSOR(nodeIdAllocator,       _nodeIdAllocator,       State, NodeIdAllocator)+-- | Buffer id allocator.+ACCESSOR(bufferIdAllocator,     _bufferIdAllocator,     State, BufferIdAllocator)+-- | Control bus id allocator.+ACCESSOR(controlBusIdAllocator, _controlBusIdAllocator, State, BusIdAllocator)+-- | Audio bus id allocator.+ACCESSOR(audioBusIdAllocator,   _audioBusIdAllocator,   State, BusIdAllocator) -rootNode :: State -> NodeId-rootNode = const (NodeId 0)+-- | Root node id.+rootNodeId :: State -> NodeId+rootNodeId = const (NodeId 0) +-- | Create a new state with default allocators. new :: ServerOptions -> State new os =     State {-        _options      = os-      , _syncId       = sid-      , _nodeId       = nid-      , _bufferId     = bid-      , _controlBusId = cid-      , _audioBusId   = aid+        _serverOptions         = os+      , _syncIdAllocator       = sid+      , _nodeIdAllocator       = nid+      , _bufferIdAllocator     = bid+      , _controlBusIdAllocator = cid+      , _audioBusIdAllocator   = aid     }     where-        sid = SyncIdAllocator-                (SAlloc.cons :: SimpleAllocator SyncId)-        nid = NodeIdAllocator-                (SetAlloc.cons $ Alloc.range 1000 (1000 + fromIntegral (maxNumberOfNodes os)) :: SetAllocator NodeId)-        bid = BufferIdAllocator-                (SetAlloc.cons $ Alloc.range 0 (fromIntegral (numberOfSampleBuffers os - 1)) :: SetAllocator BufferId)-        cid = BusIdAllocator-                (SetAlloc.cons $ Alloc.range 0 (fromIntegral (numberOfControlBusChannels os - 1)) :: SetAllocator BusId)-        aid = BusIdAllocator-                (SetAlloc.cons $ Alloc.range-                    (fromIntegral numHardwareChannels)-                    (fromIntegral (numHardwareChannels + numberOfAudioBusChannels os)) :: SetAllocator BusId)+        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
− Sound/SC3/Server/State/Concurrent.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Sound.SC3.Server.State.Concurrent (-    fromState-  , new-  , alloc-  , allocMany-  , free-  , allocRange-  , freeRange-) where--import           Control.Arrow (second)-import           Control.Failure (Failure)--- import           Control.Concurrent.MVar (MVar, newMVar)-import           Control.Concurrent.MVar.Strict (MVar, modifyMVar, modifyMVar_, newMVar)-import           Data.Accessor-import           Sound.SC3.Server.Allocator (AllocFailure, IdAllocator, Id, RangeAllocator, Range)-import qualified Sound.SC3.Server.Allocator as Alloc-import           Sound.SC3.Server.State (State)-import qualified Sound.SC3.Server.State as State-import           Sound.SC3.Server.Options (ServerOptions)--type IOState = MVar State--fromState :: State -> IO (MVar State)-fromState = newMVar--new :: ServerOptions -> IO (MVar State)-new = fromState . State.new--swap :: (a, b) -> (b, a)-swap (a, b) = (b, a)--alloc :: (IdAllocator a, Failure AllocFailure IO) => (Accessor State a) -> MVar State -> IO (Id a)-alloc f ios = modifyMVar ios (\s -> fmap (swap . second (flip (setVal f) s)) . Alloc.alloc . getVal f $ s)--allocMany :: (IdAllocator a, Failure AllocFailure IO)  => (Accessor State a) -> MVar State -> Int -> IO [Id a]-allocMany f m n = modifyMVar m (\s -> fmap (swap . second (flip (setVal f) s)) . Alloc.allocMany n . getVal f $ s)--free :: IdAllocator a => (Accessor State a) -> IOState -> Id a -> IO ()-free f ios i = modifyMVar_ ios $ \s -> do-    let a  = s ^. f-    a' <- Alloc.free i a-    return $ f ^= a' $ s--allocRange :: (RangeAllocator a, Failure AllocFailure IO) => (Accessor State a) -> MVar State -> Int -> IO (Range (Id a))-allocRange f ios n = modifyMVar ios (\s -> fmap (swap . second (flip (setVal f) s)) . Alloc.allocRange n . getVal f $ s)--freeRange :: (RangeAllocator a, Failure AllocFailure IO) => (Accessor State a) -> MVar State -> Range (Id a) -> IO ()-freeRange f ios r = modifyMVar_ ios $ \s -> do-    let a  = s ^. f-    a' <- Alloc.freeRange r a-    return $ f ^= a' $ s
hsc3-server.cabal view
@@ -1,18 +1,22 @@ Name:               hsc3-server-Version:            0.1.0+Version:            0.3.0 Synopsis:           SuperCollider server resource management and synchronization.-Description:        This library provides abstractions for managing SuperCollider server resources like node, buffer and bus ids and synchronization primitives.+Description:+    This library provides abstractions for managing SuperCollider server+    resources like node, buffer and bus ids and synchronization primitives.+    .+    ChangeLog: <https://github.com/kaoskorobase/hsc3-server/blob/master/ChangeLog.md> License:            GPL License-File:       LICENSE Category:           Sound-Copyright:          Copyright (c) Stefan Kersten 2008-2011+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.1, GHC == 6.12.3, GHC == 7.0.1 Build-Type:         Simple-Cabal-Version:      >= 1.6+Cabal-Version:      >= 1.9.2  Extra-Source-Files:     include/Accessor.h@@ -21,31 +25,59 @@     Exposed-Modules:         Sound.SC3.Server.Allocator         Sound.SC3.Server.Allocator.Range+        Sound.SC3.Server.Allocator.BlockAllocator.FirstFit         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.Send         Sound.SC3.Server.Notification         Sound.SC3.Server.Process.Monad         Sound.SC3.Server.State-        Sound.SC3.Server.State.Concurrent+    Other-Modules:+        Sound.SC3.Server.Allocator.BlockAllocator.FreeList             Build-Depends:         base >= 3 && < 5       , bitset >= 1.0-      , data-accessor-      , deepseq-      , failure+      , containers+      , data-accessor >= 0.2+      , deepseq >= 1.1+      , failure >= 0.1       , hosc >= 0.8       , hsc3 >= 0.7-      , hsc3-process >= 0.5-      , mtl >= 2+      , hsc3-process >= 0.6       , strict-concurrency       , transformers     Include-Dirs:         include     Ghc-Options:         -W+    Ghc-Prof-Options:+        -W -auto-all  Source-Repository head-  Type:             git-  Location:         git://github.com/kaoskorobase/hsc3-server.git+    Type:       git+    Location:   git://github.com/kaoskorobase/hsc3-server.git++Test-Suite hsc3-server-test+    Type: exitcode-stdio-1.0+    Main-Is: test.hs+    Other-Modules:+        Sound.SC3.Server.Allocator.Test+        Sound.SC3.Server.Allocator.Range.Test+    Build-Depends:+        base+      , bitset >= 1.0+      , deepseq >= 1.1+      , failure >= 0.1+      , QuickCheck >= 2.4+      , random >= 1.0+      , test-framework+      , test-framework-quickcheck2+      , transformers >= 0.2+    Hs-Source-Dirs: tests, .
+ tests/Sound/SC3/Server/Allocator/Range/Test.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Sound.SC3.Server.Allocator.Range.Test+    (+        tests+    ) where++import Sound.SC3.Server.Allocator.Range++import Control.Monad (liftM)+import System.Random (Random)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck++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++tests :: [Test]+tests =+    [ testGroup "Sound.SC3.Server.Allocator.Range"+        [ testProperty "bounds" $ \(r :: Range Int) -> begin r <= end r+        , testProperty "split/join" $ \(n :: Int) (r :: Range Int) -> uncurry join (split n r) == r+        ]+    ]
+ tests/Sound/SC3/Server/Allocator/Test.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ExistentialQuantification+           , FlexibleContexts+           , GADTs+           , ScopedTypeVariables+           , 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 qualified Sound.SC3.Server.Allocator.BlockAllocator.FirstFit++import Sound.SC3.Server.Allocator.Range.Test ()++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++instance Show WrappedIdAllocator where+    show (WrappedIdAllocator a) = show 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 Arbitrary Sorting where+    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) ]++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/test.hs view
@@ -0,0 +1,11 @@+import Test.Framework (Test, defaultMain)+import qualified Sound.SC3.Server.Allocator.Range.Test+import qualified Sound.SC3.Server.Allocator.Test++tests :: [Test]+tests =+    Sound.SC3.Server.Allocator.Range.Test.tests+ ++ Sound.SC3.Server.Allocator.Test.tests++main :: IO ()+main = defaultMain tests