packages feed

Etage 0.1.7 → 0.1.8

raw patch · 5 files changed

+60/−31 lines, 5 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

Etage.cabal view
@@ -1,5 +1,5 @@ Name:                Etage-Version:             0.1.7+Version:             0.1.8 Synopsis:            A general data-flow framework Description:         A general data-flow framework featuring nondeterminism, laziness and neurological pseudo-terminology. It can be                      used for example for data-flow computations or event propagation networks. It tries hard to aide type checking and to@@ -42,6 +42,7 @@                        unix >= 2.4 && < 3,                        time >= 1.1 && < 2,                        operational >= 0.2 && < 1,+                       containers >= 0.4 && < 1,                        ghc >= 7   Other-modules:       Control.Etage.Internals,                        Control.Etage.Externals,
lib/Control/Etage/Chan.hs view
@@ -37,8 +37,9 @@  import Prelude -import System.IO.Unsafe         ( unsafeInterleaveIO )+import System.IO.Unsafe import Control.Concurrent.MVar+import Data.IORef import Data.Typeable  import Control.Exception.Base@@ -51,8 +52,19 @@ data Chan a  = Chan (MVar (Stream a))         (MVar (Stream a))- deriving (Eq, Typeable)+        Int+ deriving (Typeable) +instance Eq (Chan a) where+  (Chan _ _ i') == (Chan _ _ i'') = i' == i''++instance Ord (Chan a) where+  (Chan _ _ i') `compare` (Chan _ _ i'') = i' `compare` i''++globalChanIndex :: IORef Int+{-# NOINLINE globalChanIndex #-}+globalChanIndex = unsafePerformIO (newIORef 0)+ type Stream a = MVar (ChItem a)  data ChItem a = ChItem a (Stream a)@@ -69,7 +81,8 @@    hole  <- newEmptyMVar    readVar  <- newMVar hole    writeVar <- newMVar hole-   return (Chan readVar writeVar)+   index <- atomicModifyIORef globalChanIndex (\i -> (i + 1, i))+   return (Chan readVar writeVar index)  -- To put an element on a channel, a new hole at the write end is created. -- What was previously the empty @MVar@ at the back of the channel is then@@ -78,7 +91,7 @@  -- |Write a value to a 'Chan'. writeChan :: Chan a -> a -> IO ()-writeChan (Chan _ writeVar) val = do+writeChan (Chan _ writeVar _) val = do   new_hole <- newEmptyMVar   modifyMVar_ writeVar $ \old_hole -> do     putMVar old_hole (ChItem val new_hole)@@ -86,7 +99,7 @@  -- |Read the next value from the 'Chan'. readChan :: Chan a -> IO a-readChan (Chan readVar _) = do+readChan (Chan readVar _ _) = do   modifyMVar readVar $ \read_end -> do     (ChItem val new_read_end) <- readMVar read_end         -- Use readMVar here, not takeMVar,@@ -126,7 +139,7 @@ -- |A non-blocking version of 'readChan'. The 'tryReadChan' function returns immediately, with 'Nothing' if the 'Chan' was empty or would -- block, or @'Just' a@ with the next value from the 'Chan', otherwise. tryReadChan :: Chan a -> IO (Maybe a)-tryReadChan (Chan readVar _) = do+tryReadChan (Chan readVar _ _) = do   tryModifyMVar readVar $ \read_end -> do     item <- tryReadMVar read_end         -- Use tryReadMVar here, not tryTakeMVar,@@ -140,14 +153,14 @@ -- a kind of broadcast channel, where data written by anyone is seen by -- everyone else. dupChan :: Chan a -> IO (Chan a)-dupChan (Chan _ writeVar) = do+dupChan (Chan _ writeVar index) = do    hole       <- readMVar writeVar    newReadVar <- newMVar hole-   return (Chan newReadVar writeVar)+   return (Chan newReadVar writeVar index)  -- |Put a data item back onto a channel, where it will be the next item read. unGetChan :: Chan a -> a -> IO ()-unGetChan (Chan readVar _) val = do+unGetChan (Chan readVar _ _) val = do    new_read_end <- newEmptyMVar    modifyMVar_ readVar $ \read_end -> do      putMVar new_read_end (ChItem val read_end)@@ -156,7 +169,7 @@  -- |Returns 'True' if the supplied 'Chan' is empty. isEmptyChan :: Chan a -> IO Bool-isEmptyChan (Chan readVar writeVar) = do+isEmptyChan (Chan readVar writeVar _) = do    withMVar readVar $ \r -> do      w <- readMVar writeVar      let eq = r == w
lib/Control/Etage/Externals.hs view
@@ -91,6 +91,8 @@ import Control.Etage.Chan import Control.Etage.Internals +-- TODO: Implement some way to dump network structure into Graphviz format for visualization+ {-| Sends an 'Impulse' from a 'Neuron'. 'Nerve' does not need to be conductive, 'Impulse' will be silently dropped in this case. -}@@ -402,6 +404,7 @@            -- TODO: Remove unsafeUnmask in favor of forkIOWithUnmask when it will be available            bracket (grow options) dissolve (unsafeUnmask . live nerve) `catches` [                Handler (\(_ :: DissolveException) -> return ()), -- we ignore DissolveException+               Handler (\(e :: BlockedIndefinitelyOnMVar) -> hPutStrLn stderr $ "Warning: " ++ show e ++ ". Have you forgot to initialize with prepareEnvironment?"), -- we ignore BlockedIndefinitelyOnMVar                Handler (\(e :: SomeException) -> uninterruptible $ throwTo currentThread e)              ] `finally` uninterruptible (writeSampleVar dissolved ())   return $ LiveNeuron dissolved nid@@ -506,6 +509,8 @@ Helper function which does some common initialization. Currently it sets 'stderr' buffering to 'LineBuffering' so that when multiple 'Neuron's print to 'stderr' output is not mixed. It also installs handlers for 'keyboardSignal' and 'softwareTermination' signals so that cleanup in 'Incubation' works as expected.++Using it has also an useful side-effect of Haskell not throwing `BlockedIndefinitelyOnMVar` exceptions when the network runs out. -} prepareEnvironment :: IO () prepareEnvironment = do
lib/Control/Etage/Fuse.hs view
@@ -37,6 +37,7 @@      grow options = return $ FuseNeuron options   +  -- TODO: Optionally always read only the latest Impulse from each Nerve?   live nerve (FuseNeuron FuseOptions { fuser, nerves }) = forever $ do     is <- concat <$> mapM (\(TranslatableFrom n) -> translate <$> getFromNeuron n) nerves     time <- getCurrentImpulseTime
lib/Control/Etage/Incubator.hs view
@@ -79,12 +79,15 @@   cross ) where -import Control.Applicative+import Prelude hiding (null)++import Control.Applicative hiding (empty) import Control.Exception import Control.Monad import Control.Monad.Operational import Control.Monad.Trans-import Data.List+import Data.Maybe+import Data.Set hiding (singleton) import Data.Typeable import System.IO @@ -112,21 +115,24 @@ -} incubate :: Incubation () -> IO () incubate (Incubation program) = mask $ \restore -> do-  (neurons, chans, attached) <- restore $ interpret [] [] [] program+  (neurons, chans, attached) <- restore $ interpret [] empty empty program   flip finally (detachManyAndWait neurons) $ do-    let na = nub chans \\ nub attached-        typ = unlines . map (\(ChanBox c) -> ' ' : show (impulseTypeOf c)) $ na+    let na = chans \\ attached+        typ = unlines . map' (\(ChanBox c) -> ' ' : show (impulseTypeOf c)) $ na     unless (null na) $ hPutStrLn stderr $ "Warning: It seems not all created (conductive) nerves were attached. This causes a memory leak as send impulses are not received. You should probably just define those nerves as NerveOnlyFor or NerveNone. Dangling nerves have following impulse types in direction from a neuron:\n" ++ typ     restore waitForException -interpret :: [LiveNeuron] -> [ChanBox] -> [ChanBox] -> Incubation' () -> IO ([LiveNeuron], [ChanBox], [ChanBox])+map' :: (a -> b) -> Set a -> [b]+map' f = fold ((:) . f) []++interpret :: [LiveNeuron] -> Set ChanBox -> Set ChanBox -> Incubation' () -> IO ([LiveNeuron], Set ChanBox, Set ChanBox) interpret neurons chans attached = viewT >=> eval neurons chans attached-    where eval :: [LiveNeuron] -> [ChanBox] -> [ChanBox] -> ProgramViewT IncubationOperation IO () -> IO ([LiveNeuron], [ChanBox], [ChanBox])+    where eval :: [LiveNeuron] -> Set ChanBox -> Set ChanBox -> ProgramViewT IncubationOperation IO () -> IO ([LiveNeuron], Set ChanBox, Set ChanBox)           eval ns cs ats (Return ()) = return (ns, cs, ats)           eval ns cs ats (NeuronOperation optionsSetter :>>= is) = do             nerve <- liftIO growNerve             let c = getFromChan nerve-            bracketOnError (attach optionsSetter nerve) detachAndWait $ \n -> interpret (n:ns) (c ++ cs) ats . is $ nerve+            bracketOnError (attach optionsSetter nerve) detachAndWait $ \n -> interpret (n:ns) (maybe cs (`insert` cs) c) ats . is $ nerve           eval ns cs ats (AttachOperation from for :>>= is) = do             (from', ats') <- maybeBranch from ats             propagate from' for@@ -135,18 +141,18 @@             (nerves', ats') <- maybeBranchMany nerves ats             n <- fuse nerves' fuser             let c = getFromChan n-            interpret ns (c ++ cs) ats' . is $ n+            interpret ns (maybe cs (`insert` cs) c) ats' . is $ n -maybeBranch :: forall from for forConductivity. (Impulse from, Impulse for) => Nerve from AxonConductive for forConductivity -> [ChanBox] -> IO (Nerve from AxonConductive for forConductivity, [ChanBox])+maybeBranch :: forall from for forConductivity. (Impulse from, Impulse for) => Nerve from AxonConductive for forConductivity -> Set ChanBox -> IO (Nerve from AxonConductive for forConductivity, Set ChanBox) maybeBranch from ats = do-  let c = head . getFromChan $ from -- we know there exists from chan as type checking assures that (from is conductive)-  if c `notElem` ats-    then return (from, c:ats)+  let c = fromJust . getFromChan $ from -- we know there exists from chan as type checking assures that (from is conductive)+  if c `notMember` ats+    then return (from, insert c ats)     else do       branchFrom <- branchNerveFrom from -- we have to branch from chan as it is attached multiple times-      return (branchFrom, ats) -- we store only original nerves in attached list+      return (branchFrom, ats) -maybeBranchMany :: forall i. (Impulse i) => [TranslatableFrom i] -> [ChanBox] -> IO ([TranslatableFrom i], [ChanBox])+maybeBranchMany :: forall i. (Impulse i) => [TranslatableFrom i] -> Set ChanBox -> IO ([TranslatableFrom i], Set ChanBox) maybeBranchMany [] ats = return ([], ats) maybeBranchMany (TranslatableFrom n:ns) ats = do   (n', ats') <- maybeBranch n ats@@ -223,7 +229,7 @@ -} type NerveOnlyFor n = (NeuronOptions n -> NeuronOptions n) -> Incubation (Nerve (NeuronFromImpulse n) AxonNonConductive (NeuronForImpulse n) AxonConductive) -class (Typeable a, Eq a) => ChanClass a where+class (Typeable a, Eq a, Ord a) => ChanClass a where   impulseTypeOf :: a -> TypeRep  instance Impulse i => ChanClass (Chan i) where@@ -233,11 +239,14 @@   ChanBox :: ChanClass a => a -> ChanBox  instance Eq ChanBox where-  ChanBox a == ChanBox b = typeOf a == typeOf b && cast a == Just b -- tests both typeOf and cast to be sure (cast could be defined to succeed for different types?)+  ChanBox a == ChanBox b = typeOf a == typeOf b && cast a == Just b -- tests both typeOf and cast to be sure (eq could be defined to succeed for different types?) -getFromChan :: Nerve from fromConductivity for forConductivity -> [ChanBox]-getFromChan (Nerve (Axon c) _) = [ChanBox c]-getFromChan (Nerve NoAxon _) = []+instance Ord ChanBox where+  ChanBox a `compare` ChanBox b = cast a `compare` Just b++getFromChan :: Nerve from fromConductivity for forConductivity -> Maybe ChanBox+getFromChan (Nerve (Axon c) _) = Just (ChanBox c)+getFromChan (Nerve NoAxon _) = Nothing  {-| Branches 'Nerve' on the 'Neuron' side. This allows multiple 'Neuron's to be attached to it and still receive all 'Impulse's