module Control.Concurrent.CHPSpec.Base where
import Control.Arrow
import Control.Monad (liftM)
import Control.Monad.State (StateT)
import Control.Monad.Trans (MonadTrans(..))
import Data.Dynamic
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Concurrent.CHPSpec.Spec
newtype CHPSpecT m a = CHPSpecT {runSpecT :: forall b. (a -> m (b, SpecMod)) -> m (b, SpecMod) }
instance MonadTrans CHPSpecT where
lift m = CHPSpecT (m >>=)
addSpecT1 :: forall m a. Monad m => m (a, SpecItem) -> CHPSpecT m a
addSpecT1 m = CHPSpecT $ \k -> m >>= apply k
where
apply :: (a -> m (b, SpecMod)) -> (a, SpecItem) -> m (b, SpecMod)
apply k (x, s) = liftM (second ((s :) .)) $ k x
finSpecT :: Monad m => CHPSpecT m a -> m (a, Spec)
finSpecT = liftM (second finalise) . flip runSpecT (\x -> return (x, id))
stopSpecT :: Monad m => m SpecItem -> CHPSpecT m a
stopSpecT m = CHPSpecT $ const $ liftM (\sp -> (error "stopSpecT", (sp :))) m
instance Monad m => Monad (CHPSpecT m) where
return x = CHPSpecT ($ x)
m >>= k = CHPSpecT $ \c -> runSpecT m $ \a -> runSpecT (k a) c
newtype Enrolled b a = Enrolled (b a) deriving (Eq)
instance Typeable (b a) => Typeable (Enrolled b a) where
typeOf x = let Enrolled b = Enrolled undefined `asTypeOf` x in mkTyConApp (mkTyCon "Enrolled") [typeOf b]
type CheckArg = Dynamic -> Bool
data CHPState = CHPState
{ chpEventMap :: Map.Map Integer String
, chpIOEvents :: Set.Set Integer
, chpProcessMap :: Map.Map String (Map.Map Integer ([CheckArg], (Spec, Dynamic)))
, chpFreeNames :: [(Dynamic, CheckArg)]
, chpNextBottom :: !Integer
, chpNextProcess :: !Integer
}
type CHP = CHPSpecT (StateT CHPState IO)
class Monad m => MonadCHP m where
liftCHP :: CHP a -> m a
class Poisonable c where
poison :: MonadCHP m => c -> m ()
checkForPoison :: MonadCHP m => c -> m ()
throwPoison :: CHP a
throwPoison = return $ error "throwPoison"
onPoisonTrap :: forall a. CHP a -> CHP a -> CHP a
onPoisonTrap x _ = x
onPoisonRethrow :: CHP a -> CHP () -> CHP a
onPoisonRethrow x _ = x
poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m ()
poisonAll = mapM_ poison
instance MonadCHP CHP where
liftCHP = id
altSpecT :: Monad m => [CHPSpecT m a] -> CHPSpecT m a
altSpecT ms = CHPSpecT $
\k -> do xfs <- mapM (flip runSpecT k) ms
return (error "alt return", \s -> [Alt $ map (($ s) . snd) xfs])
insertMapMap :: (Ord k, Ord k') => k -> k' -> v -> Map.Map k (Map.Map k' v) -> Map.Map k (Map.Map k' v)
insertMapMap k k' v = Map.insertWith Map.union k (Map.singleton k' v)
collapseMapMap :: Ord kk => (k -> k' -> kk) -> Map.Map k (Map.Map k' v) -> Map.Map kk v
collapseMapMap f = Map.fromList . concatMap (\(k, kvs) -> map (first $ f k) kvs) . Map.toList . Map.map Map.toList