module Data.Reactor.Reaction (Reaction (..) , step, External, Internal, Recover
, Response (..), prop_data_reactor_reaction)
where
import Data.Typeable (Typeable, cast)
import Control.Monad.State (StateT, runStateT)
import Control.Applicative ((<$>))
import Data.Reactor.Untypeds (Serial , Untyped (Untyped))
import Test.QuickCheck
import Control.Monad.Identity (runIdentity)
import Control.Monad.State (modify, foldM)
type Internal = Untyped
type External = Serial
type Recover = Serial
data Response m = Response {
continue :: Bool ,
newreas :: [Reaction m] ,
newevents :: [Internal]
}
data Reaction m = forall a b . (Typeable a, Show b, Read b, Typeable b) => Reaction {
reaction :: a -> StateT b m (Response m)
, reastate :: b
}
step :: (Monad m, Functor m)
=> Reaction m
-> Internal
-> Maybe (m (
[Reaction m],
[Internal],
Maybe (Reaction m)
)
)
step (Reaction f b) (Untyped x) = k <$> cast x where
k x' = do
(Response t xs ys, b') <- runStateT (f x') b
return (xs,ys, if t then Just $ Reaction f b' else Nothing)
prop_data_reactor_reaction :: Gen Bool
prop_data_reactor_reaction = do
ms <- listOf (elements [1..10::Int])
let r = Reaction (\y -> modify (+ y) >> return (Response True [] [])) (0::Int)
ck Nothing _ = return Nothing
ck (Just r') x = do
let k = step r' x
case k of
Nothing -> return Nothing
Just k' -> do
(_,_,mr) <- k'
return mr
ef = foldM ck (Just r) $ map Untyped ms
q = case runIdentity ef of
Just (Reaction _ z) -> case cast z of
Just z' -> z' == sum ms
Nothing -> False
Nothing -> False
return q