Porting to GHC 7.0. Added incubator.

Etage.cabal

@@ -23,19 +23,23 @@ Maintainer:          mitar.haskell@tnode.com
 Copyright:           (c) 2010 Mitar Milutinovic
 Category:            Control
 Build-type:          Simple
-Cabal-version:       >= 1.2
+Cabal-version:       >= 1.8
 Stability:           experimental
 Homepage:            http://mitar.tnode.com
 
 Library
   Exposed-modules:     Control.Etage,
                        Control.Etage.Dump,
-                       Control.Etage.Random
-  Build-depends:       base >= 4 && < 5,
+                       Control.Etage.Sequence
+  Build-depends:       base >= 4.3 && < 5,
+                       mtl >= 1.1 && < 3,
                        random > 1.0 && < 2,
                        unix >= 2.4 && < 3,
-                       time >= 1.1 && < 2
+                       time >= 1.1 && < 2,
+                       operational >= 0.2 && < 1
   Other-modules:       Control.Etage.Types,
-                       Control.Etage.Propagate
+                       Control.Etage.Propagate,
+                       Control.Etage.Incubator,
+                       Control.Etage.Chan
   HS-source-dirs:      lib
   GHC-options:         -Wall

lib/Control/Etage.hs

@@ -1,7 +1,7 @@
 module Control.Etage (
   module Control.Etage.Types,
-  module Control.Etage.Propagate
+  module Control.Etage.Incubator
 ) where
 
 import Control.Etage.Types
-import Control.Etage.Propagate
+import Control.Etage.Incubator

lib/Control/Etage/Chan.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Concurrent.Chan
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (concurrency)
+--
+-- Unbounded channels.
+--
+-----------------------------------------------------------------------------
+
+-- Changes: Eq derived on Chan.
+
+module Control.Etage.Chan
+  ( 
+          -- * The 'Chan' type
+        Chan,                   -- abstract
+
+          -- * Operations
+        newChan,                -- :: IO (Chan a)
+        writeChan,              -- :: Chan a -> a -> IO ()
+        readChan,               -- :: Chan a -> IO a
+        dupChan,                -- :: Chan a -> IO (Chan a)
+        unGetChan,              -- :: Chan a -> a -> IO ()
+        isEmptyChan,            -- :: Chan a -> IO Bool
+
+          -- * Stream interface
+        getChanContents,        -- :: Chan a -> IO [a]
+        writeList2Chan,         -- :: Chan a -> [a] -> IO ()
+   ) where
+
+import Prelude
+
+import System.IO.Unsafe         ( unsafeInterleaveIO )
+import Control.Concurrent.MVar
+import Data.Typeable
+
+-- A channel is represented by two @MVar@s keeping track of the two ends
+-- of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
+-- are used to handle consumers trying to read from an empty channel.
+
+-- |'Chan' is an abstract type representing an unbounded FIFO channel.
+data Chan a
+ = Chan (MVar (Stream a))
+        (MVar (Stream a))
+ deriving (Eq, Typeable)
+
+type Stream a = MVar (ChItem a)
+
+data ChItem a = ChItem a (Stream a)
+
+-- See the Concurrent Haskell paper for a diagram explaining the
+-- how the different channel operations proceed.
+
+-- @newChan@ sets up the read and write end of a channel by initialising
+-- these two @MVar@s with an empty @MVar@.
+
+-- |Build and returns a new instance of 'Chan'.
+newChan :: IO (Chan a)
+newChan = do
+   hole  <- newEmptyMVar
+   readVar  <- newMVar hole
+   writeVar <- newMVar hole
+   return (Chan readVar writeVar)
+
+-- 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
+-- filled in with a new stream element holding the entered value and the
+-- new hole.
+
+-- |Write a value to a 'Chan'.
+writeChan :: Chan a -> a -> IO ()
+writeChan (Chan _ writeVar) val = do
+  new_hole <- newEmptyMVar
+  modifyMVar_ writeVar $ \old_hole -> do
+    putMVar old_hole (ChItem val new_hole)
+    return new_hole
+
+-- |Read the next value from the 'Chan'.
+readChan :: Chan a -> IO a
+readChan (Chan readVar _) = do
+  modifyMVar readVar $ \read_end -> do
+    (ChItem val new_read_end) <- readMVar read_end
+        -- Use readMVar here, not takeMVar,
+        -- else dupChan doesn't work
+    return (new_read_end, val)
+
+-- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to
+-- either channel from then on will be available from both.  Hence this creates
+-- 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
+   hole       <- readMVar writeVar
+   newReadVar <- newMVar hole
+   return (Chan newReadVar writeVar)
+
+-- |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
+   new_read_end <- newEmptyMVar
+   modifyMVar_ readVar $ \read_end -> do
+     putMVar new_read_end (ChItem val read_end)
+     return new_read_end
+{-# DEPRECATED unGetChan "if you need this operation, use Control.Concurrent.STM.TChan instead.  See http://hackage.haskell.org/trac/ghc/ticket/4154 for details" #-}
+
+-- |Returns 'True' if the supplied 'Chan' is empty.
+isEmptyChan :: Chan a -> IO Bool
+isEmptyChan (Chan readVar writeVar) = do
+   withMVar readVar $ \r -> do
+     w <- readMVar writeVar
+     let eq = r == w
+     eq `seq` return eq
+{-# DEPRECATED isEmptyChan "if you need this operation, use Control.Concurrent.STM.TChan instead.  See http://hackage.haskell.org/trac/ghc/ticket/4154 for details" #-}
+
+-- Operators for interfacing with functional streams.
+
+-- |Return a lazy list representing the contents of the supplied
+-- 'Chan', much like 'System.IO.hGetContents'.
+getChanContents :: Chan a -> IO [a]
+getChanContents ch
+  = unsafeInterleaveIO (do
+        x  <- readChan ch
+        xs <- getChanContents ch
+        return (x:xs)
+    )
+
+-- |Write an entire list of items to a 'Chan'.
+writeList2Chan :: Chan a -> [a] -> IO ()
+writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)

lib/Control/Etage/Dump.hs

@@ -1,27 +1,29 @@
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, GADTs, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances, EmptyDataDecls, RecordWildCards, NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, GADTs, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable, EmptyDataDecls, RecordWildCards, NamedFieldPuns #-}
 
 module Control.Etage.Dump where
 
 import Control.Monad
+import Data.Typeable
 import System.IO
 
-import Control.Etage.Types
+import Control.Etage
 
-data DumpNeuron = DumpNeuron DumpOptions
+data DumpNeuron = DumpNeuron DumpOptions deriving (Typeable)
 
-instance Impulse DumpForImpulse where
-  impulseTime (DumpForImpulse i) = impulseTime i
-  impulseValue (DumpForImpulse i) = impulseValue i
+type LiveDumpNeuron = LiveNeuron DumpNeuron
+type DumpFromImpulse = NeuronFromImpulse DumpNeuron
+type DumpForImpulse = NeuronForImpulse DumpNeuron
+type DumpOptions = NeuronOptions DumpNeuron
 
--- TODO: Remove in favor of automatic deriving in GHC 7.0?
 instance Impulse DumpFromImpulse where
   impulseTime _ = undefined
   impulseValue _ = undefined
 
-type LiveDumpNeuron = LiveNeuron DumpNeuron
-type DumpForImpulse = NeuronForImpulse DumpNeuron
-type DumpFromImpulse = NeuronFromImpulse DumpNeuron
-type DumpOptions = NeuronOptions DumpNeuron
+instance Impulse DumpForImpulse where
+  impulseTime (DumpForImpulse i) = impulseTime i
+  impulseValue (DumpForImpulse i) = impulseValue i
+
+deriving instance Show DumpFromImpulse
 
 instance Show DumpForImpulse where
   show (DumpForImpulse i) = show i
@@ -32,15 +34,11 @@ instance Eq DumpForImpulse where
 instance Ord DumpForImpulse where
   compare = impulseCompare
 
--- TODO: Remove in favor of automatic deriving in GHC 7.0?
-instance Show DumpFromImpulse where
-  show _ = undefined
-
 instance Neuron DumpNeuron where
   data LiveNeuron DumpNeuron = LiveDumpNeuron NeuronDissolved NeuronId
+  data NeuronFromImpulse DumpNeuron
   data NeuronForImpulse DumpNeuron where
     DumpForImpulse :: Impulse i => i -> DumpForImpulse
-  data NeuronFromImpulse DumpNeuron
   data NeuronOptions DumpNeuron = DumpOptions {
       handle :: Handle,
       showInsteadOfDump :: Bool

lib/Control/Etage/Incubator.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE GADTs, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}
+
+module Control.Etage.Incubator (
+  incubate,
+  growNeuron,
+  attachTo,
+  NerveBoth,
+  NerveNone,
+  NerveOnlyFrom,
+  NerveOnlyFor
+) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Control.Monad.Operational
+import Control.Monad.Trans
+import Data.List
+import Data.Typeable
+import System.IO
+
+import Control.Etage.Chan
+import Control.Etage.Propagate
+import Control.Etage.Types
+
+data IncubationOperation a where
+  NeuronOperation :: (Neuron n, GrowAxon (Axon (NeuronFromImpulse n) fromConductivity), GrowAxon (Axon (NeuronForImpulse n) forConductivity)) => (NeuronOptions n -> NeuronOptions n) -> IncubationOperation (Nerve (NeuronFromImpulse n) fromConductivity (NeuronForImpulse n) forConductivity)
+  AttachOperation :: forall from for forConductivity. (Typeable from, Typeable for, Typeable forConductivity) => Nerve from AxonConductive for forConductivity -> [Translatable from] -> IncubationOperation ()
+
+type Incubation a = ProgramT IncubationOperation IO a
+
+-- TODO: Check if all chans have been attached with type checking? (If this checking even shows as useful. And correct.)
+incubate :: Incubation () -> IO ()
+incubate program = mask $ \restore -> do
+  (neurons, chans, attached) <- restore $ interpret [] [] [] program
+  let na  = nub chans \\ nub attached
+      typ = unlines . map (\(ChanBox c) -> show $ neuronTypeOf c) $ na
+  unless (null na) $ hPutStrLn stderr $ "Warning: It seems not all created nerves were attached. This causes a memory leak as produced data is not consumed. You should probably just define those nerves as NerveOnlyFor or NerveNone. Dangling nerves for neurons:\n" ++ typ
+  waitForDissolve neurons
+
+interpret :: [Living] -> [ChanBox] -> [ChanBox] -> Incubation () -> IO ([Living], [ChanBox], [ChanBox])
+interpret neurons chans attached = viewT >=> (eval neurons chans attached)
+    where eval :: [Living] -> [ChanBox] -> [ChanBox] -> ProgramViewT IncubationOperation IO () -> IO ([Living], [ChanBox], [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) detach $ \n -> (interpret ((Living n):ns) (c ++ cs) ats) . is $ nerve
+          eval ns cs ats (AttachOperation from for :>>= is) = do
+            let c = head . getFromChan $ from -- we know there exists from chan as type checking assures that (from is conductive)
+            (from', ats') <- if c `notElem` ats
+                               then return (from, c:ats)
+                               else do
+                                 dupFrom <- dupNerve from -- we have to duplicate from chan as it is attached multiple times
+                                 return (dupFrom, ats) -- we store only original nerves in attached list
+            propagate from' for
+            (interpret ns cs ats') . is $ ()
+
+growNeuron :: (Neuron n, GrowAxon (Axon (NeuronFromImpulse n) fromConductivity), GrowAxon (Axon (NeuronForImpulse n) forConductivity)) => (NeuronOptions n -> NeuronOptions n) -> Incubation (Nerve (NeuronFromImpulse n) fromConductivity (NeuronForImpulse n) forConductivity)
+growNeuron os = singleton (NeuronOperation os)
+
+attachTo :: forall from for forConductivity. (Typeable from, Typeable for, Typeable forConductivity) => Nerve from AxonConductive for forConductivity -> [Translatable from] -> Incubation ()
+attachTo n ts = singleton (AttachOperation n ts)
+
+class GrowAxon a where
+  growAxon :: IO a
+
+instance Impulse i => GrowAxon (Axon i AxonConductive) where
+  growAxon = Axon <$> newChan
+
+instance GrowAxon (Axon i AxonNonConductive) where
+  growAxon = return NoAxon
+
+growNerve :: (Impulse from, Impulse for, GrowAxon (Axon from fromConductivity), GrowAxon (Axon for forConductivity)) => IO (Nerve from fromConductivity for forConductivity)
+growNerve = do
+  from <- growAxon
+  for <- growAxon
+  return $ Nerve from for
+
+type NerveBoth n = Incubation (Nerve (NeuronFromImpulse n) AxonConductive (NeuronForImpulse n) AxonConductive)
+type NerveNone n = Incubation (Nerve (NeuronFromImpulse n) AxonNonConductive (NeuronForImpulse n) AxonNonConductive)
+type NerveOnlyFrom n = Incubation (Nerve (NeuronFromImpulse n) AxonConductive (NeuronForImpulse n) AxonNonConductive)
+type NerveOnlyFor n = Incubation (Nerve (NeuronFromImpulse n) AxonNonConductive (NeuronForImpulse n) AxonConductive)
+
+class (Typeable a, Eq a) => ChanClass a where
+  neuronTypeOf :: a -> TypeRep
+
+instance Impulse i => ChanClass (Chan i) where
+  neuronTypeOf = head . typeRepArgs . head . typeRepArgs . typeOf -- we assume here that impulses are just NeuronFromImpulse or NeuronForImpulse
+
+data ChanBox where
+  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?)
+
+getFromChan :: Nerve from fromConductivity for forConductivity -> [ChanBox]
+getFromChan (Nerve (Axon c) _) = [ChanBox c]
+getFromChan (Nerve NoAxon _) = []
+
+dupNerve :: Nerve from AxonConductive for forConductivity -> IO (Nerve from AxonConductive for forConductivity)
+dupNerve (Nerve (Axon c) for) = do
+  c' <- dupChan c
+  return $ Nerve (Axon c') for