module Control.Concurrent.CHP.Channels.Base where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans
import Data.Unique (Unique)
import Control.Concurrent.CHP.Base
import Control.Concurrent.CHP.Event
import Control.Concurrent.CHP.Poison
newtype Chanin a = Chanin (STMChannel a) deriving Eq
newtype Chanout a = Chanout (STMChannel a) deriving Eq
newtype STMChannel a = STMChan (Event, TVar (WithPoison (Maybe a, Maybe ())))
deriving Eq
data Chan r w a = Chan {
getChannelIdentifier :: Unique,
reader :: r a,
writer :: w a}
class ChaninC c a where
startReadChannelC :: c a -> (Event, STM (WithPoison a))
endReadChannelC :: c a -> STM (WithPoison ())
readChannelC :: c a -> (Event, STM (), STM (WithPoison a))
poisonReadC :: c a -> IO ()
checkPoisonReadC :: c a -> IO (WithPoison ())
class ChanoutC c a where
startWriteChannelC :: c a -> (Event, STM (WithPoison ()))
sendWriteChannelC :: c a -> a -> STM (WithPoison ())
endWriteChannelC :: c a -> STM (WithPoison ())
writeChannelC :: c a -> a -> (Event, STM (), STM (WithPoison ()))
poisonWriteC :: c a -> IO ()
checkPoisonWriteC :: c a -> IO (WithPoison ())
instance Poisonable (Chanin a) where
poison (Chanin c) = liftIO $ poisonReadC c
checkForPoison (Chanin c) = liftCHP $ liftIO (checkPoisonReadC c) >>= checkPoison
instance Poisonable (Chanout a) where
poison (Chanout c) = liftIO $ poisonWriteC c
checkForPoison (Chanout c) = liftCHP $ liftIO (checkPoisonWriteC c) >>= checkPoison
stmChannel :: MonadIO m => (a -> String) -> m (Unique, STMChannel a)
stmChannel sh = liftIO $
do c <- atomically $ newTVar $ NoPoison (Nothing, Nothing)
e <- newEvent (liftM (ChannelComm . maybe "" sh . getVal) $ readTVar c) 2
return (getEventUnique e, STMChan (e,c))
where
getVal PoisonItem = Nothing
getVal (NoPoison (x, _)) = x
consumeData :: TVar (WithPoison (Maybe a, Maybe ())) -> STM (WithPoison a)
consumeData tv = do d <- readTVar tv
case d of
PoisonItem -> return PoisonItem
NoPoison (Nothing, _) -> retry
NoPoison (Just x, a) -> do writeTVar tv $ NoPoison (Nothing, a)
return $ NoPoison x
sendData :: TVar (WithPoison (Maybe a, Maybe ())) -> a -> STM (WithPoison ())
sendData tv x = do y <- readTVar tv
case y of
PoisonItem -> return PoisonItem
NoPoison (Just _, _) -> error "CHP: Found data while sending data"
NoPoison (Nothing, a) -> do writeTVar tv $ NoPoison (Just x, a)
return $ NoPoison ()
consumeAck :: TVar (WithPoison (Maybe a, Maybe ())) -> STM (WithPoison ())
consumeAck tv = do d <- readTVar tv
case d of
PoisonItem -> return PoisonItem
NoPoison (_, Nothing) -> retry
NoPoison (x, Just _) -> do writeTVar tv $ NoPoison (x, Nothing)
return $ NoPoison ()
sendAck :: TVar (WithPoison (Maybe a, Maybe ())) -> STM (WithPoison ())
sendAck tv = do d <- readTVar tv
case d of
PoisonItem -> return PoisonItem
NoPoison (_, Just _) -> error "CHP: Found ack while placing ack!"
NoPoison (x, Nothing) -> do writeTVar tv $ NoPoison (x, Just ())
return $ NoPoison ()
instance ChaninC STMChannel a where
startReadChannelC (STMChan (e,tv)) = (e, consumeData tv)
endReadChannelC (STMChan (_,tv)) = sendAck tv
readChannelC (STMChan (e, tv))
= (e, sendAck tv >> return (), consumeData tv)
poisonReadC (STMChan (e,tv))
= liftSTM $ do poisonEvent e
writeTVar tv PoisonItem
checkPoisonReadC (STMChan (e,_)) = liftSTM $ checkEventForPoison e
instance ChanoutC STMChannel a where
startWriteChannelC (STMChan (e,tv))
= (e, do x <- readTVar tv
case x of
PoisonItem -> return PoisonItem
NoPoison _ -> return $ NoPoison ())
sendWriteChannelC (STMChan (_, tv)) val
= sendData tv val
endWriteChannelC (STMChan (_, tv))
= consumeAck tv
writeChannelC (STMChan (e, tv)) val
= (e, sendData tv val >> return (), consumeAck tv)
poisonWriteC (STMChan (e,tv))
= liftSTM $ do poisonEvent e
writeTVar tv PoisonItem
checkPoisonWriteC (STMChan (e,_)) = liftSTM $ checkEventForPoison e