module Control.Concurrent.CHP.Base where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM
import qualified Control.Exception.Extensible as C
import Control.Monad.Error
import Control.Monad.LoopWhile
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Trans
import Data.Function (on)
import qualified Data.Map as Map
import Data.Unique
import System.IO
import qualified Text.PrettyPrint.HughesPJ
import Control.Concurrent.CHP.Guard
import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId
import Control.Concurrent.CHP.Traces.Base
newtype PoisonError = PoisonError ()
newtype Enrolled b a = Enrolled (b a) deriving (Eq)
newtype CHP a = PoisonT (ErrorT PoisonError CHP' a)
deriving (Functor, Monad, MonadIO)
instance Applicative CHP where
pure = return
(<*>) = ap
data CHP' a = AltableTRet a | AltableT {
getAltable :: Either String [(Guard, TraceT IO a)],
getStandard :: TraceT IO a }
class MonadIO m => MonadCHP m where
liftCHP :: CHP a -> m a
class Trace t where
runCHPAndTrace :: CHP a -> IO (Maybe a, t Unique)
emptyTrace :: t u
prettyPrint :: Ord u => t u -> Text.PrettyPrint.HughesPJ.Doc
labelAll :: Ord u => t u -> t String
class Poisonable c where
poison :: MonadCHP m => c -> m ()
checkForPoison :: MonadCHP m => c -> m ()
pullOutStandard :: CHP' a -> TraceT IO a
pullOutStandard m = case m of
AltableTRet x -> return x
AltableT _ st -> st
pullOutAltable :: CHP' a -> Either String [(Guard, TraceT IO a)]
pullOutAltable m = case m of
AltableTRet _ -> badGuard "return"
AltableT alt _ -> alt
liftTrace :: TraceT IO a -> CHP' a
liftTrace = AltableT (badGuard "lifted action")
wrapPoison :: CHP a -> CHP' (WithPoison a)
wrapPoison (PoisonT m) = either (const PoisonItem) NoPoison <$> runErrorT m
unwrapPoison :: CHP' (WithPoison a) -> CHP a
unwrapPoison m = PoisonT (lift m) >>= checkPoison
checkPoison :: WithPoison a -> CHP a
checkPoison (NoPoison x) = return x
checkPoison PoisonItem = PoisonT $ throwError $ PoisonError ()
liftPoison :: CHP' a -> CHP a
liftPoison = PoisonT . lift
throwPoison :: CHP a
throwPoison = checkPoison PoisonItem
onPoisonTrap :: CHP a -> CHP a -> CHP a
onPoisonTrap (PoisonT body) (PoisonT handler) = PoisonT $ body `catchError` (const handler)
onPoisonRethrow :: CHP a -> CHP () -> CHP a
onPoisonRethrow (PoisonT body) (PoisonT handler) = PoisonT $
body `catchError` (\err -> handler >> throwError err)
poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m ()
poisonAll = mapM_ poison
liftSTM :: MonadIO m => STM a -> m a
liftSTM = liftIO . atomically
getProcessId :: TraceT IO ProcessId
getProcessId = do x <- ask
case x of
Trace (pid,_,_) -> return pid
NoTrace pid -> return pid
wrapProcess :: CHP a -> (CHP' (Either PoisonError a) -> IO (Either PoisonError a)) -> IO (Maybe (Either () a))
wrapProcess (PoisonT proc) unwrapInner
= do let inner = runErrorT proc
x <- liftM Just (unwrapInner inner) `C.catches` allHandlers
case x of
Nothing -> return Nothing
Just (Left _) -> return $ Just $ Left ()
Just (Right y) -> return $ Just $ Right y
where
response :: C.Exception e => e -> IO (Maybe a)
response x = liftIO (hPutStrLn stderr $ "(CHP) Thread terminated with: " ++ show x)
>> return Nothing
allHandlers = [C.Handler (response :: C.IOException -> IO (Maybe a))
,C.Handler (response :: C.AsyncException -> IO (Maybe a))
,C.Handler (response :: C.NonTermination -> IO (Maybe a))
#if __GLASGOW_HASKELL__ >= 611
,C.Handler (response :: C.BlockedIndefinitelyOnSTM -> IO (Maybe a))
#else
,C.Handler (response :: C.BlockedIndefinitely -> IO (Maybe a))
#endif
,C.Handler (response :: C.Deadlock -> IO (Maybe a))
]
runCHPProgramWith :: TraceStore -> CHP a -> IO (Maybe a)
runCHPProgramWith start p
= do r <- wrapProcess p run
case r of
Nothing -> return Nothing
Just (Left _) -> return Nothing
Just (Right x) -> return (Just x)
where
run :: CHP' (Either PoisonError a) -> IO (Either PoisonError a)
run = flip runReaderT start . pullOutStandard
runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> IO t) -> CHP a -> IO (Maybe a, t)
runCHPProgramWith' subStart f p
= do tv <- atomically $ newTVar Map.empty
x <- runCHPProgramWith (Trace (rootProcessId, tv, subStart)) p
l <- atomically $ readTVar tv
t' <- f l
return (x, t')
data ManyToOneTVar a = ManyToOneTVar
{ mtoIsFinalValue :: a -> Bool
, mtoReset :: STM a
, mtoInter :: TVar a
, mtoFinal :: TVar (Maybe a)
}
instance Eq (ManyToOneTVar a) where
(==) = (==) `on` mtoFinal
newManyToOneTVar :: (a -> Bool) -> STM a -> a -> STM (ManyToOneTVar a)
newManyToOneTVar f r x
= do tvInter <- newTVar x
tvFinal <- newTVar $ if f x then Just x else Nothing
return $ ManyToOneTVar f r tvInter tvFinal
writeManyToOneTVar :: (a -> a) -> ManyToOneTVar a -> STM a
writeManyToOneTVar f (ManyToOneTVar done reset tvInter tvFinal)
= do x <- readTVar tvInter
if done (f x)
then do writeTVar tvFinal $ Just $ f x
reset >>= writeTVar tvInter
else writeTVar tvInter $ f x
return $ f x
readManyToOneTVar :: ManyToOneTVar a -> STM a
readManyToOneTVar (ManyToOneTVar _done _reset _tvInter tvFinal)
= do x <- readTVar tvFinal >>= maybe retry return
writeTVar tvFinal Nothing
return x
resetManyToOneTVar :: ManyToOneTVar a -> a -> STM ()
resetManyToOneTVar (ManyToOneTVar done reset tvInter tvFinal) x
| done x = (reset >>= writeTVar tvInter) >> writeTVar tvFinal (Just x)
| otherwise = writeTVar tvInter x >> writeTVar tvFinal Nothing
instance Error PoisonError where
noMsg = PoisonError ()
instance (Error e, MonadCHP m) => MonadCHP (ErrorT e m) where
liftCHP = lift . liftCHP
instance MonadCHP m => MonadCHP (ReaderT r m) where
liftCHP = lift . liftCHP
instance MonadCHP m => MonadCHP (StateT s m) where
liftCHP = lift . liftCHP
instance (Monoid w, MonadCHP m) => MonadCHP (WriterT w m) where
liftCHP = lift . liftCHP
instance MonadCHP CHP where
liftCHP = id
instance MonadCHP m => MonadCHP (LoopWhileT m) where
liftCHP = lift . liftCHP
instance Monad CHP' where
m >>= f = case m of
AltableTRet x -> f x
AltableT altBody nonAlt ->
let altBody' = liftM (map $ second (>>= pullOutStandard . f)) altBody
nonAlt' = nonAlt >>= pullOutStandard . f
in AltableT altBody' nonAlt'
return = AltableTRet
instance Functor CHP' where
fmap = liftM
instance MonadIO CHP' where
liftIO = liftTrace . liftIO