module Data.Reactor (Reactor (..), mkReactor) where
import Data.List (nub)
import Data.Maybe (fromMaybe, catMaybes)
import Control.Applicative ((<$>))
import Control.Monad (foldM, ap)
import Control.Monad.State (MonadState, get, put)
import Control.Monad.Writer (runWriterT, listen)
import Control.Monad.Reader (local, runReaderT)
import Control.Arrow (second)
import Data.Reactor.Untypeds (toUntyped)
import Data.Reactor.Reaction (External, Recover, Reaction)
import Data.Reactor.MinimalGraph (Index, MinimalGraph(..), mkMinimalGraph)
import Data.Reactor.Pruned (Pruned (..), expand, serialize, restore)
import Data.Reactor.Operational (OperationalLayer, Operational (..), mkOperationalPruned)
import Data.Reactor.Serialization (Serialization, SerialReactor)
type ReaTree m = Pruned (OperationalLayer m) (Maybe Recover,[Index])
data Reactor m c = Reactor {
insertExternals :: [External] -> m (Maybe (Reactor m c)),
restoreReactor :: SerialReactor c -> m (Maybe (Reactor m c)),
serializeReactor :: SerialReactor c
}
serialize' :: ReaTree m -> ([Maybe Recover], [Index])
serialize' = second (concat) . unzip . serialize
insertSerialization :: c
-> External
-> [ReaTree m]
-> Serialization c
-> (Index,Serialization c)
insertSerialization c e xs (MinimalGraph add' _ _) = let (mrs,iss) = unzip $ map serialize' xs in
add' ((c,e,mrs),nub . concat $ iss)
purgeSerialization :: [ReaTree m] -> Serialization c -> Maybe (Serialization c)
purgeSerialization ns (MinimalGraph _ resize' _) = resize' (nub . concat . map (snd . serialize') $ ns)
mkReaTree ::(Monad m, Functor m) => Reaction m -> ReaTree m
mkReaTree r = mkOperationalPruned $ Operational Nothing (Right r)
zero :: (Monad m, Functor m) => [Reaction m] -> (Serialization c,[ReaTree m])
zero rs = (mkMinimalGraph, map mkReaTree rs)
new :: (Functor m, MonadState c m) => [Reaction m] -> (Serialization c,[ReaTree m]) -> Maybe (Reactor m c)
new rs (dg,ns) = case ns of
[] -> Nothing
_ -> Just $ Reactor (insert rs (dg',ns)) (restore' rs) (map (fst . serialize') ns, values dg')
where dg' = fromMaybe
(error "Restore graph reduction failed")
$ purgeSerialization ns dg
restore' :: forall m c . (Functor m, MonadState c m) => [Reaction m] -> SerialReactor c -> m (Maybe (Reactor m c))
restore' rs (actual,ecs) = new rs <$> second (ctxz actual) <$> foldM k (zero rs) ecs where
ctxz :: [[Maybe Recover]] -> [ReaTree m] -> [ReaTree m]
ctxz mrs ns = map (\(mr,n) -> restore n $ zip mr $ error "restoring dependencies") $ zip mrs ns
k (dg,ns) (c,e,mrs) = if length mrs /= length ns
then error "Restore failed in the numbers of base reactions"
else do put c
insert' (dg,ctxz mrs ns) e
insert :: (Functor m, MonadState c m) => [Reaction m] -> (Serialization c,[ReaTree m]) -> [External] -> m (Maybe (Reactor m c))
insert rs (dg,ns) es = new rs <$> foldM insert' (dg,ns) es
insert' :: (Functor m, MonadState c m) => (Serialization c,[ReaTree m]) -> External -> m (Serialization c,[ReaTree m])
insert' (dg,ns) e = do
c <- get
let (i,dg') = insertSerialization c e ns dg
ns' <- catMaybes <$> mapM (react (i,e)) ns
return (dg' ,ns')
react :: (Monad m, Functor m) => (Index,External) -> ReaTree m -> m (Maybe (ReaTree m))
react (i,e) p = fmap fst . runWriterT . flip runReaderT (i,toUntyped e) $ z (Just p) where
z Nothing = return Nothing
z (Just p') = do
(p'',es) <- listen $ expand p'
if null es then return p'' else case p'' of
Nothing -> return Nothing
p''' -> let k mp e' = local (\(i',_) -> (i',e')) $ z mp
in foldM k p''' es
mkReactor :: (Functor m, MonadState c m)
=> [Reaction m]
-> Reactor m c
mkReactor = fromMaybe (error "cannot make a reactor with no base reactions") . (new `ap` zero)