chp 2.1.0.1 → 2.2.0

raw patch · 20 files changed

+577/−611 lines, 20 filesdep −loop-whiledep −mtlPVP ok

version bump matches the API change (PVP)

Dependencies removed: loop-while, mtl

API changes (from Hackage documentation)

Files

• Control/Concurrent/CHP/Alt.hs +47/−244
• Control/Concurrent/CHP/Barriers.hs +6/−6
• Control/Concurrent/CHP/Base.hs +278/−85
• Control/Concurrent/CHP/CSP.hs +15/−17
• Control/Concurrent/CHP/Channels/Base.hs +60/−58
• Control/Concurrent/CHP/Channels/BroadcastReduce.hs +15/−16
• Control/Concurrent/CHP/Channels/Communication.hs +5/−6
• Control/Concurrent/CHP/Channels/Creation.hs +7/−56
• Control/Concurrent/CHP/Channels/Ends.hs +2/−4
• Control/Concurrent/CHP/Clocks.hs +13/−13
• Control/Concurrent/CHP/Event.hs +5/−4
• Control/Concurrent/CHP/Guard.hs +1/−2
• Control/Concurrent/CHP/Monad.hs +36/−24
• Control/Concurrent/CHP/Mutex.hs +6/−7
• Control/Concurrent/CHP/Parallel.hs +36/−25
• Control/Concurrent/CHP/Traces/Base.hs +31/−29
• Control/Concurrent/CHP/Traces/CSP.hs +3/−3
• Control/Concurrent/CHP/Traces/Structural.hs +2/−3
• Control/Concurrent/CHP/Traces/VCR.hs +5/−5
• chp.cabal +4/−4

@@ -28,9 +28,8 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  --- | A module containing the ALT constructs.  An ALT (a term inherited from--- occam) is a choice between several alternate events.  In CHP, we say that an event--- must support alting to be a valid choice.  Events that /do/ support alting are:+-- | A module containing constructs for choice, or alting.  An ALT (a term inherited from+-- occam) is a choice between several alternate events.  Events that inherently support choice are: -- -- * 'Control.Concurrent.CHP.Monad.skip' --@@ -38,11 +37,11 @@ --  -- * 'Control.Concurrent.CHP.Monad.waitFor' -- --- * Reading from a channel (including extended reads): that is, calls to 'Control.Concurrent.CHP.Channels.readChannel'--- and 'Control.Concurrent.CHP.Channels.extReadChannel'+-- * Reading from a channel (including extended reads): that is, calls to 'Control.Concurrent.CHP.Channels.Communication.readChannel'+-- and 'Control.Concurrent.CHP.Channels.Communication.extReadChannel' -- --- * Writing to a channel (including extended writes): that is, calls to 'Control.Concurrent.CHP.Channels.writeChannel'--- and 'Control.Concurrent.CHP.Channels.extWriteChannel'+-- * Writing to a channel (including extended writes): that is, calls to 'Control.Concurrent.CHP.Channels.Communication.writeChannel'+-- and 'Control.Concurrent.CHP.Channels.Communication.extWriteChannel' --  -- * Synchronising on a barrier (using 'Control.Concurrent.CHP.Barriers.syncBarrier') -- @@ -55,7 +54,8 @@ -- * A call to 'every', which joins together several items (see the documentation -- on 'every'). ----- Examples of events that do /NOT/ support alting are:+-- There are several other events that can occur in CHP; these are assumed to be+-- always-ready when they are included in a choice.  Examples include: -- -- * Enrolling and resigning with a barrier -- @@ -69,60 +69,44 @@ -- -- * Claiming a shared channel (yet...) ----- It is not easily possible to represent this at the type level (while still--- making CHP easy to use).  Therefore it is left to you to not try to alt--- over something that does not support it.  Given how much of the library--- does support alting, that should hopefully be straightforward.+-- * A return statement by itself -- -- Here are some examples of using alting: -- -- * Wait for an integer channel, or 1 second to elapse: ----- > liftM Just (readChannel c) <-> (waitFor 1000000 >> return Nothing)+-- > liftM Just (readChannel c) <|> (waitFor 1000000 >> return Nothing) ----- * Check if a channel is ready, otherwise return immediately.  Note that you must use the--- alt operator with priority here, otherwise your skip guard might be chosen,--- even when the channel is ready.+-- * Check if a channel is ready, otherwise return immediately; this can be done+-- using the 'optional' function from "Control.Applicative": -- --- > liftM Just (readChannel c) </> (skip >> return Nothing)+-- > optional (readChannel c) -- -- * Wait for input from one of two (identically typed) channels -- --- > readChannel c0 <-> readChannel c1+-- > readChannel c0 <|> readChannel c1 -- -- * Check if a channel is ready; if so send, it on, otherwise return immediately: -- --- > (readChannel c >>= writeChannel d) </> skip+-- > (readChannel c >>= writeChannel d) <|> skip -- -- Note that if you wait for a sequential composition: ----- > (readChannel c >>= writeChannel d) <-> (writeChannel e 6 >> readChannel f)+-- > (readChannel c >>= writeChannel d) <|> (writeChannel e 6 >> readChannel f) -- -- This only waits for the first action in both (reading from channel c, or writing -- to channel e), not for all of the actions (as, for example, an STM transaction -- would). module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>), every, every_, (<&>)) where -import Control.Applicative-import Control.Arrow-import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad.Reader-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import qualified Data.Set as Set-import Data.Unique-import System.IO+import Control.Applicative ((<$>), (<|>))+import Data.Monoid (mappend) -import Control.Concurrent.CHP.Base-import Control.Concurrent.CHP.Event-import Control.Concurrent.CHP.Guard-import Control.Concurrent.CHP.Monad-import Control.Concurrent.CHP.Parallel-import Control.Concurrent.CHP.Poison-import Control.Concurrent.CHP.Traces.Base+import Control.Concurrent.CHP.Base (CHP(..), CHP'(..), liftIO_CHP, makeAltable', priAlt, throwPoison, wrapPoison)+import Control.Concurrent.CHP.Guard (Guard(..))+import Control.Concurrent.CHP.Monad (skip)+import Control.Concurrent.CHP.Parallel (runParallel)+import Control.Concurrent.CHP.Poison (WithPoison(..))  -- | An alt between several actions, with arbitrary priority.  The first -- available action is chosen (with an arbitrary choice if many actions are@@ -130,51 +114,6 @@ alt :: [CHP a] -> CHP a alt = priAlt --- | An alt between several actions, with descending priority.  The first--- available action is chosen (biased towards actions nearest the beginning--- of the list), its body run, and its value returned.------ What priority means here is a difficult thing, and in some ways a historical--- artifact.  We can group the guards into three categories:------ 1. synchronisation guards (reading from and writing to channels, and synchronising--- on barriers)------ 2. time-out guards (such as 'Control.Concurrent.CHP.Monad.waitFor')------ 3. dummy guards ('Control.Concurrent.CHP.Monad.skip' and 'Control.Concurrent.CHP.Monad.stop')------ There exists priority when comparing dummy guards to anything else.  So for--- example,------ > priAlt [ skip, x ]------ Will always select the first guard, whereas:------ > priAlt [ x , skip ]------ Is an effective way to poll and see if x is ready, otherwise the 'Control.Concurrent.CHP.Monad.skip' will--- be chosen.  However, there is no priority between synchronisation guards and--- time-out guards.  So the two lines:------ > priAlt [ x, y ]--- > priAlt [ y, x ]------ May have the same or different behaviour (when x and y are not dummy guards),--- there is no guarantee either way.  The reason behind this is that if you ask--- for:------ > priAlt [ readChannel c, writeChannel d 6 ]------ And the process at the other end is asking for:------ > priAlt [ readChannel d, writeChannel c 8 ]------ Whichever channel is chosen by both processes will not satisfy the priority--- at one end (if such priority between channels was supported).-priAlt :: [CHP a] -> CHP a-priAlt = unwrapPoison . priAlt' . map wrapPoison- -- | A useful operator to perform an 'alt'.  This operator is associative, -- and has arbitrary priority.  When you have lots of guards, it is probably easier -- to use the 'alt' function.  'alt' /may/ be more efficent than@@ -187,8 +126,11 @@ -- left-biased).  When you have lots of actions, it is probably easier -- to use the 'priAlt' function.  'priAlt' /may/ be more efficent than -- foldl1 (\<\/\>)+--+-- Since version 2.2.0, this operator is deprecated in favour of the (<|>) operator+-- from the Alternative type-class. (</>) :: CHP a -> CHP a -> CHP a-(</>) a b = priAlt [a,b]+(</>) = (<|>)  infixl </> infixl <->@@ -288,36 +230,31 @@ -- behaviour as x. -- -- Added in version 1.1.0-every :: forall a. [CHP a] -> CHP [a]+every :: [CHP a] -> CHP [a] every [] = skip >> return []-every xs = liftPoison (AltableT (liftM ((:[]) . flip (,) (return True)) $ gs >>= foldM1 merge) (return-   False)) >>= \b -> if b then runParallel (map (unwrapPoison . liftTrace) bodies) else alt [every xs]+every xs = makeAltable' (\tr -> let gs = map fst $ getAltable tr+  in [(foldl1 merge gs, return $ NoPoison ())]) >> wrapped   where-    both :: Either String [(Guard, TraceT IO (WithPoison a))]-    both = mapM (checkSingle . pullOutAltable . wrapPoison) xs-    gs :: Either String [Guard]-    gs = liftM (map fst) both-    bodies = map snd $ fromRight both-    fromRight (Right x) = x-    fromRight _ = error "Reached unreachable code in every; bodies executed after bad guard"+    wrapped = PoisonT $ \t f -> let bodies = map snd $ getAltable t+      in wrapPoison t (runParallel (map wrap bodies)) >>= f -    checkSingle (Left err) = Left err-    checkSingle (Right []) = Left "Bad guard in every"-    checkSingle (Right [x]) = Right x-    checkSingle (Right _) = Left "Alt inside every"+    wrap m = liftIO_CHP m >>= \v -> case v of+      PoisonItem -> throwPoison+      NoPoison x -> return x -    merge :: Guard -> Guard -> Either String Guard-    merge SkipGuard g = return g-    merge g SkipGuard = return g-    merge StopGuard _ = return StopGuard-    merge _ StopGuard = return StopGuard+    getAltable tr = flip map xs $ \x -> case runPoisonT x tr return of+      Altable _ [ga] -> ga+      _ -> error "Bad item in every"++    merge :: Guard -> Guard -> Guard+    merge SkipGuard g = g+    merge g SkipGuard = g+    merge StopGuard _ = StopGuard+    merge _ StopGuard = StopGuard     merge (EventGuard recx actx esx) (EventGuard recy acty esy)-      = return $ EventGuard (\n -> recx n ++ recy n) (actx `mappend` acty) (esx ++ esy)-    merge _ _ = badGuard "merging unsupported guards"+      = EventGuard (\n -> recx n ++ recy n) (actx `mappend` acty) (esx ++ esy)+    merge _ _ = error "every: merging unsupported guards" -    foldM1 :: Monad m => (b -> b -> m b) -> [b] -> m b-    foldM1 f (y:ys) = foldM f y ys-    foldM1 _ _ = error "Reached unreachable code in every; guards empty in non-empty case"  -- | Like 'every' but discards the results. --@@ -330,7 +267,7 @@ -- to join with this operator, it's probably easier to use the 'every' function. -- -- Added in version 1.1.0-(<&>) :: forall a b. CHP a -> CHP b -> CHP (a, b)+(<&>) :: CHP a -> CHP b -> CHP (a, b) (<&>) a b = merge <$> every [Left <$> a, Right <$> b]   where     merge :: [Either a b] -> (a, b)@@ -338,138 +275,4 @@     merge [Right y, Left x] = (x, y)     merge _ = error "Invalid merge possibility in <&>" --- ALTing is implemented as follows in CHP.  The CHP monad has [Int] in its--- state.  When you choose between N events, you form one body, that pulls--- the next number from the head of the state and executes the body for the--- event corresponding to that index.  Nested ALTs prepend to the list.--- So for example, if you choose between:------ > (a <-> b) <-> c------ The overall number corresponding to a is [0,0], b is [0,1], c is [1].  The--- outer choice peels off the head of the list.  On 1 it executes c; on 0 it--- descends to the nested choice, which takes the next number in the list and--- executes a or b given 0 or 1 respectively.------ If an event is poisoned, an integer (of arbitrary value) is /appended/ to--- the list.  Thus when an event-based guard is executed, if the list in the--- state is non-empty, it knows it has been poisoned.------ I did try implementing this in a more functional manner, making each event--- in the monad take [Int] and return the body, rather than using state.  However,--- I had some memory efficiency problems so I went with the state-monad-based--- approach instead. -priAlt' :: forall a. [CHP' (WithPoison a)] -> CHP' (WithPoison a)-priAlt' items-  -- Our guard is a nested guard of all our sub-guards.-  -- Our action-if-not-guard is to do the selection ourselves.-  = AltableT flattenedGuards (selectFromGuards flattenedGuards)-  where-    -- The list of guards without any NestedGuards or StopGuards:-    flattenedGuards :: Either String [(Guard, TraceT IO (WithPoison a))]-    flattenedGuards = liftM (filter (not . isStopGuard . fst)) altStuff-      where-        altStuff :: Either String [(Guard, TraceT IO (WithPoison a))]-        altStuff = liftM concat $ mapM pullOutAltable items---- Performs the select operation on all the guards, and then executes the body-selectFromGuards :: forall a. (Either String [(Guard, TraceT IO (WithPoison a))]) -> TraceT IO (WithPoison a)-selectFromGuards (Left str) =-           let err = "ALTing not supported on given guard: " ++ str-           in liftIO $ do hPutStrLn stderr err-                          ioError $ userError err-selectFromGuards (Right both)-        | null (eventGuards $ map fst both) =-           join $ liftM snd $ liftIO $ waitNormalGuards both Nothing-        | otherwise =-           do let (guards, _bodies) = unzip both-                  earliestReady = findIndex isSkipGuard guards-                  recordAndRun :: WithPoison ([RecordedIndivEvent Unique], TraceT-                    IO (WithPoison a)) -> TraceT IO (WithPoison a)-                  recordAndRun PoisonItem = return PoisonItem-                  recordAndRun (NoPoison (r, m)) = recordEvent r >> m-                  guardsAndRec :: [(Guard, WithPoison ([RecordedIndivEvent Unique], TraceT IO (WithPoison a)))]-                  guardsAndRec = map (second (NoPoison . (,) [])) both-                  getRec :: (SignalValue, Map.Map Unique (Integer, RecordedEventType))-                         -> WithPoison ([RecordedIndivEvent Unique], TraceT IO (WithPoison a))-                  getRec (Signal PoisonItem, _) = PoisonItem-                  getRec (Signal (NoPoison n), m)-                    = case both !! n of-                        (EventGuard recF _ _, body) ->-                          NoPoison (recF (makeLookup m), body)-                        (_, body) -> NoPoison ([], body)-              tv <- liftIO $ newTVarIO Nothing-              pid <- getProcessId-              tr <- ask-              tid <- liftIO myThreadId-              mn <- liftIO . atomically $ do-                      ret <- enableEvents tv (tid, pid)-                        (maybe id take earliestReady $ eventGuards guards)-                        (isNothing earliestReady)-                      either (const $ return ())-                            (\((sigVal,_),es) -> do-                               recordEventLast (nub es) tr-                               case sigVal of-                                 Signal PoisonItem -> return ()-                                 Signal (NoPoison n) ->-                                   let EventGuard _ act _ = guards !! n-                                   in actWhenLast act (Map.fromList $ map (snd *** Set.size) es)-                            )-                            ret-                      return $ either Left (Right . getRec . fst) ret-              case (mn, earliestReady) of-                -- An event -- and we were the last person to arrive:-                -- The event must have been higher priority than any other-                -- ready guards-                (Right r, _) -> recordAndRun r-                -- No events were ready, but there was an available normal-                -- guards.  Re-run the normal guards; at least one will be ready-                (Left _, Just _) ->-                  join $ liftM snd $ liftIO $ waitNormalGuards both Nothing-                -- No events ready, no other guards ready either-                -- Events will have been enabled; wait for everything:-                (Left disable, Nothing) ->-                    do (wasAltingBarrier, pr) <- liftIO $ waitNormalGuards-                         guardsAndRec $ Just $ liftM getRec $ waitAlting tv-                       if wasAltingBarrier-                         then recordAndRun pr -- It was a barrier, all done-                         else-                            -- Another guard fired, but we must check in case-                            -- we have meanwhile been committed to taking an-                            -- event:-                            do mn' <- liftIO . atomically $ disable-                               case mn' of-                                 -- An event overrides our non-event choice:-                                 Just pr' -> recordAndRun $ getRec pr'-                                 -- Go with the original option, no events-                                 -- became ready:-                                 Nothing -> recordAndRun pr--waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique (Integer, RecordedEventType))-waitAlting tv = do b <- readTVar tv-                   case b of-                     Nothing -> retry-                     Just ns -> return ns--makeLookup :: Map.Map Unique (Integer, RecordedEventType) -> Unique -> (Integer,-  RecordedEventType)-makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m---- The alting barrier guards:-eventGuards :: [Guard] -> [((SignalValue, STM ()), [Event])]-eventGuards guards = [((Signal $ NoPoison n, actAlways acts), ab)-                     | (n, EventGuard _ acts ab) <- zip [0..] guards]----- Waits for one of the normal (non-alting barrier) guards to be ready,--- or the given transaction to complete-waitNormalGuards :: [(Guard, b)] -> Maybe (STM b) -> IO (Bool, b)-waitNormalGuards guards extra-  = do enabled <- sequence $ mapMaybe enable guards-       atomically $ foldr orElse retry $ maybe id ((:) . liftM ((,) True)) extra $ enabled-  where-    enable :: (Guard, b) -> Maybe (IO (STM (Bool, b)))-    enable (SkipGuard, x) = Just $ return $ return (False, x)-    enable (TimeoutGuard g, x) = Just $ liftM (>> return (False, x)) g-    enable _ = Nothing -- This effectively ignores other guards

@@ -69,7 +69,7 @@     syncBarrier, getBarrierIdentifier) where  import Control.Concurrent.STM-import Control.Monad.State+import Control.Monad (liftM, unless, when) import Data.Unique  import Control.Concurrent.CHP.Base@@ -93,7 +93,7 @@      -- | Finds out the current phase a barrier is on. currentPhase :: Enrolled PhasedBarrier phase -> CHP phase-currentPhase (Enrolled (Barrier (_, tv, _))) = liftIO $ atomically $ readTVar tv+currentPhase (Enrolled (Barrier (_, tv, _))) = liftSTM $ readTVar tv  repeatUntil :: (Monad m) => (a -> Bool) -> m a -> m () repeatUntil target comp = do x <- comp@@ -172,10 +172,10 @@  -- | Like 'newPhasedBarrier' but allows you to customise the options. newPhasedBarrier' :: phase -> BarOpts phase -> CHP (PhasedBarrier phase)-newPhasedBarrier' ph (BarOpts incPh pri showPh label) = liftPoison $ liftTrace $ do-  tv <- liftIO $ atomically $ newTVar ph-  e <- liftIO $ newBarrierEvent showPh pri tv-  maybe (return ()) (labelEvent e) label+newPhasedBarrier' ph (BarOpts incPh pri showPh label) = getTrace >>= \tr -> liftIO_CHP $ do+  tv <- atomically $ newTVar ph+  e <- newBarrierEvent showPh pri tv+  maybe (return ()) (labelEvent tr e) label   return $ Barrier (e, tv, incPh)  -- | Creates a new barrier with no processes enrolled and labels it in traces

@@ -35,19 +35,20 @@  import Control.Applicative import Control.Arrow+import Control.Concurrent (myThreadId, threadDelay) 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 import Data.Function (on)+import Data.List (findIndex, nub) import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isNothing, mapMaybe)+import qualified Data.Set as Set import Data.Unique import System.IO import qualified Text.PrettyPrint.HughesPJ +import Control.Concurrent.CHP.Event import Control.Concurrent.CHP.Guard import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.ProcessId@@ -57,9 +58,6 @@ -- Types: -- ====== --- | An internal dummy type for poison errors-newtype PoisonError = PoisonError ()- -- | An enrolled wrapper for barriers that shows at the type-level whether -- you are enrolled on a barrier.  Enrolled Barriers should never be passed -- to two (or more) processes running in parallel; if two processes synchronise@@ -70,18 +68,43 @@ -- 'Control.Concurrent.CHP.Monad.runCHP' and -- 'Control.Concurrent.CHP.Monad.runCHP_' to execute programs in this -- monad.-newtype CHP a = PoisonT (ErrorT PoisonError CHP' a)-  deriving (Functor, Monad, MonadIO)+--+-- The Alternative instance was added in version 2.2.0.+newtype CHP a = PoisonT {runPoisonT :: forall b. TraceStore -> (a -> CHP' b) -> CHP' b}+--  deriving (Functor, Monad, MonadIO) +instance Functor CHP where+  fmap f m = PoisonT $ \t c -> runPoisonT m t (c . f)++instance Monad CHP where+  return a = PoisonT $ const ($ a)+  m >>= k  = PoisonT $ \t c -> runPoisonT m t (\a -> runPoisonT (k a) t c)+             instance Applicative CHP where   pure = return   (<*>) = ap -data CHP' a = AltableTRet a | AltableT {+instance Alternative CHP where+  empty = stop+  a <|> b = priAlt [a, b]+  -- Like the default definition but makes clear+  -- which the leading action is:+--  some p = do x <- p+--              xs <- many p+--              return (x : xs)++-- | An implementation of liftIO for the CHP monad; this function lifts IO actions+-- into the CHP monad.+--+-- Added in version 2.2.0.+liftIO_CHP :: IO a -> CHP a+liftIO_CHP m = PoisonT $ const $ \f -> (Standard (liftM NoPoison m) >>= f)++data CHP' a = Return a    -- The guard, and body to execute after the guard-  getAltable :: Either String [(Guard, TraceT IO a)],+  | Altable TraceStore [(Guard, IO (WithPoison a))]   -- The body to execute without a guard-  getStandard :: TraceT IO a }+  | Standard (IO (WithPoison a))  -- ======== -- Classes:@@ -90,7 +113,7 @@ -- | A monad transformer class that is very similar to 'MonadIO'.  This can be -- useful if you want to add monad transformers (such as 'StateT', 'ReaderT') on -- top of the 'CHP' monad.-class MonadIO m => MonadCHP m where+class Monad m => MonadCHP m where   liftCHP :: CHP a -> m a  -- | A class representing a type of trace.  The main useful function is 'runCHPAndTrace',@@ -127,32 +150,31 @@ -- Functions:  -- ========== -pullOutStandard :: CHP' a -> TraceT IO a-pullOutStandard m = case m of-  AltableTRet x -> return x-  AltableT _ st -> st+makeAltable :: [(Guard, IO (WithPoison a))] -> CHP a+makeAltable gas = PoisonT $ \t f -> Altable t (map (second (&>>= pullOutStandard . f)) gas) -pullOutAltable :: CHP' a -> Either String [(Guard, TraceT IO a)]-pullOutAltable m = case m of-  AltableTRet _ -> badGuard "return"-  AltableT alt _ -> alt+makeAltable' :: (TraceStore -> [(Guard, IO (WithPoison a))]) -> CHP a+makeAltable' gas = PoisonT $ \t f -> Altable t (map (second (&>>= pullOutStandard . f)) (gas t)) -liftTrace :: TraceT IO a -> CHP' a-liftTrace = AltableT (badGuard "lifted action")+pullOutStandard :: CHP' a -> IO (WithPoison a)+pullOutStandard (Return x) = return (NoPoison x)+pullOutStandard (Altable tr gas) = selectFromGuards tr gas+pullOutStandard (Standard m) = m -wrapPoison :: CHP a -> CHP' (WithPoison a)-wrapPoison (PoisonT m) = either (const PoisonItem) NoPoison <$> runErrorT m+wrapPoison :: TraceStore -> CHP a -> CHP' a+wrapPoison t (PoisonT m) = m t return -unwrapPoison :: CHP' (WithPoison a) -> CHP a-unwrapPoison m = PoisonT (lift m) >>= checkPoison+--unwrapPoison :: (TraceStore -> CHP' a) -> CHP a+--unwrapPoison m = PoisonT $ \t f -> m t >>= f +   -- | Checks for poison, and either returns the value, or throws a poison exception checkPoison :: WithPoison a -> CHP a checkPoison (NoPoison x) = return x-checkPoison PoisonItem = PoisonT $ throwError $ PoisonError ()+checkPoison PoisonItem = PoisonT $ \_ _ -> Standard $ return PoisonItem -liftPoison :: CHP' a -> CHP a-liftPoison = PoisonT . lift+liftPoison :: (TraceStore -> CHP' a) -> CHP a+liftPoison m = PoisonT ((>>=) . m)  -- | Throws a poison exception. throwPoison :: CHP a@@ -167,8 +189,16 @@ -- does so).  If you want to rethrow (and actually, you'll find you usually -- do), use 'onPoisonRethrow' onPoisonTrap :: CHP a -> CHP a -> CHP a-onPoisonTrap (PoisonT body) (PoisonT handler) = PoisonT $ body `catchError` (const handler)+onPoisonTrap (PoisonT body) (PoisonT handler)+  = PoisonT $ \t f ->+     let trap PoisonItem = pullOutStandard $ handler t f+         trap (NoPoison x) = pullOutStandard $ f x in+    case body t return of+      Return x -> f x+      Altable tr gas -> Altable tr (map (second (>>= trap)) gas)+      Standard m -> Standard $ m >>= trap + -- | Like 'onPoisonTrap', this function allows you to provide a handler --  for poison.  The difference with this function is that even if the --  poison handler does not throw, the poison exception will always be@@ -179,35 +209,36 @@ -- > foo `onPoisonRethrow` throwPoison -- > foo `onPoisonRethrow` return () onPoisonRethrow :: CHP a -> CHP () -> CHP a-onPoisonRethrow (PoisonT body) (PoisonT handler) = PoisonT $-  body `catchError` (\err -> handler >> throwError err)+onPoisonRethrow (PoisonT body) (PoisonT handler)+  = PoisonT $ \t f ->+     let handle PoisonItem = PoisonItem <$ (pullOutStandard $ handler t return)+         handle (NoPoison x) = pullOutStandard $ f x in+    case body t return of+      Return x -> f x+      Altable tr gas -> Altable tr (map (second (>>= handle)) gas)+      Standard m -> Standard $ m >>= handle  -- | Poisons all the given items.  A handy shortcut for @mapM_ poison@. poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m () poisonAll = mapM_ poison +getTrace :: CHP TraceStore+getTrace = PoisonT (flip ($)) -liftSTM :: MonadIO m => STM a -> m a-liftSTM = liftIO . atomically+liftSTM :: STM a -> CHP a+liftSTM = liftIO_CHP . atomically -getProcessId :: TraceT IO ProcessId-getProcessId = do x <- ask-                  case x of-                    Trace (pid,_,_) -> return pid-                    NoTrace pid -> return pid+getProcessId :: TraceStore -> ProcessId+getProcessId (Trace (pid,_,_)) = pid+getProcessId (NoTrace pid) = 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+wrapProcess :: CHP a -> TraceStore -> (CHP' a -> IO (WithPoison a)) -> IO (Maybe (WithPoison a))+wrapProcess (PoisonT proc) t unwrapInner+  = (Just <$> unwrapInner (proc t return)) `C.catches` allHandlers   where     response :: C.Exception e => e -> IO (Maybe a)-    response x = liftIO (hPutStrLn stderr $ "(CHP) Thread terminated with: " ++ show x)-                   >> return Nothing+    response x = do 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))@@ -222,15 +253,11 @@  runCHPProgramWith :: TraceStore -> CHP a -> IO (Maybe a) runCHPProgramWith start p-  = do r <- wrapProcess p run+  = do r <- wrapProcess p start pullOutStandard        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-    --run m = runStateT ({-liftM (either (const Nothing) Just) $ -} pullOutStandard m) start+         Nothing -> putStrLn "Deadlock" >> return Nothing+         Just PoisonItem -> putStrLn "Uncaught Poison" >> return Nothing+         Just (NoPoison x) -> return (Just x)  runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> IO t) -> CHP a -> IO (Maybe a, t) runCHPProgramWith' subStart f p@@ -283,41 +310,207 @@ -- Instances:  -- ========== -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- -- The monad is lazy, and very similar to the writer monad instance Monad CHP' where   -- m :: AltableT g m a   -- f :: a -> AltableT g m b   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+             Return x -> f x+             Altable tr altBody -> Altable tr $ map (second (&>>= pullOutStandard . f)) altBody+             Standard s -> Standard $ s &>>= pullOutStandard . f+  return = Return  instance Functor CHP' where   fmap = liftM -instance MonadIO CHP' where-  liftIO = liftTrace . liftIO+infixr 8 &>>=+(&>>=) :: IO (WithPoison a) -> (a -> IO (WithPoison b)) -> IO (WithPoison b)+(&>>=) m f = do v <- m+                case v of+                  PoisonItem -> return PoisonItem+                  NoPoison x -> f x+++-- ====+-- Alt:+-- ====++-- Performs the select operation on all the guards, and then executes the body+selectFromGuards :: forall a. TraceStore -> [(Guard, IO (WithPoison a))] -> IO (WithPoison a)+selectFromGuards tr items+  | null (eventGuards guards)+     = join $ liftM snd $ waitNormalGuards items Nothing+  | otherwise = do+      tv <- newTVarIO Nothing+      tid <- myThreadId+      mn <- atomically $ do+              ret <- enableEvents tv (tid, pid)+                (maybe id take earliestReady $ eventGuards guards)+                (isNothing earliestReady)+              either (const $ return ()) whenLast ret+              return $ either Left (Right . getRec . fst) ret+      case (mn, earliestReady) of+        -- An event -- and we were the last person to arrive:+        -- The event must have been higher priority than any other+        -- ready guards+        (Right r, _) -> recordAndRun r+        -- No events were ready, but there was an available normal+        -- guards.  Re-run the normal guards; at least one will be ready+        (Left _, Just _) ->+          join $ liftM snd $ waitNormalGuards items Nothing+        -- No events ready, no other guards ready either+        -- Events will have been enabled; wait for everything:+        (Left disable, Nothing) ->+            do (wasAltingBarrier, pr) <- waitNormalGuards+                 guardsAndRec $ Just $ liftM getRec $ waitAlting tv+               if wasAltingBarrier+                 then recordAndRun pr -- It was a barrier, all done+                 else+                    -- Another guard fired, but we must check in case+                    -- we have meanwhile been committed to taking an+                    -- event:+                    do mn' <- atomically $ disable+                       case mn' of+                         -- An event overrides our non-event choice:+                         Just pr' -> recordAndRun $ getRec pr'+                         -- Go with the original option, no events+                         -- became ready:+                         Nothing -> recordAndRun pr+  where+    guards = map fst items+    earliestReady = findIndex isSkipGuard guards++    recordAndRun :: WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a)) -> IO (WithPoison a)+    recordAndRun PoisonItem = return PoisonItem+    recordAndRun (NoPoison (r, m)) = recordEvent r tr >> m++    guardsAndRec :: [(Guard, WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a)))]+    guardsAndRec = map (second (NoPoison . (,) [])) items++    getRec :: (SignalValue, Map.Map Unique (Integer, RecordedEventType))+           -> WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a))+    getRec (Signal PoisonItem, _) = PoisonItem+    getRec (Signal (NoPoison n), m)+      = case items !! n of+          (EventGuard recF _ _, body) ->+            NoPoison (recF (makeLookup m), body)+          (_, body) -> NoPoison ([], body)++    whenLast ((sigVal,_),es)+      = do recordEventLast (nub es) tr+           case sigVal of+             Signal PoisonItem -> return ()+             Signal (NoPoison n) ->+               let EventGuard _ act _ = guards !! n+               in actWhenLast act (Map.fromList $ map (snd *** Set.size) es)++    pid = getProcessId tr++waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique (Integer, RecordedEventType))+waitAlting tv = do b <- readTVar tv+                   case b of+                     Nothing -> retry+                     Just ns -> return ns++makeLookup :: Map.Map Unique (Integer, RecordedEventType) -> Unique -> (Integer,+  RecordedEventType)+makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m++-- The alting barrier guards:+eventGuards :: [Guard] -> [((SignalValue, STM ()), [Event])]+eventGuards guards = [((Signal $ NoPoison n, actAlways acts), ab)+                     | (n, EventGuard _ acts ab) <- zip [0..] guards]+++-- Waits for one of the normal (non-alting barrier) guards to be ready,+-- or the given transaction to complete+waitNormalGuards :: [(Guard, b)] -> Maybe (STM b) -> IO (Bool, b)+waitNormalGuards guards extra+  = do enabled <- sequence $ mapMaybe enable guards+       atomically $ foldr orElse retry $ maybe id ((:) . liftM ((,) True)) extra $ enabled+  where+    enable :: (Guard, b) -> Maybe (IO (STM (Bool, b)))+    enable (SkipGuard, x) = Just $ return $ return (False, x)+    enable (TimeoutGuard g, x) = Just $ liftM (>> return (False, x)) g+    enable _ = Nothing -- This effectively ignores other guards+++++-- | An alt between several actions, with descending priority.  The first+-- available action is chosen (biased towards actions nearest the beginning+-- of the list), its body run, and its value returned.+--+-- What priority means here is a difficult thing, and in some ways a historical+-- artifact.  We can group the guards into three categories:+--+-- 1. synchronisation guards (reading from and writing to channels, and synchronising+-- on barriers)+--+-- 2. time-out guards (such as 'Control.Concurrent.CHP.Monad.waitFor')+--+-- 3. dummy guards ('Control.Concurrent.CHP.Monad.skip', 'Control.Concurrent.CHP.Monad.stop'+-- and things like IO actions)+--+-- There exists priority when comparing dummy guards to anything else.  So for+-- example,+--+-- > priAlt [ skip, x ]+--+-- Will always select the first guard (the skip guard), whereas:+--+-- > priAlt [ x , skip ]+--+-- Is an effective way to poll and see if x is ready, otherwise the 'Control.Concurrent.CHP.Monad.skip' will+-- be chosen.  However, there is no priority between synchronisation guards and+-- time-out guards.  So the two lines:+--+-- > priAlt [ x, y ]+-- > priAlt [ y, x ]+--+-- May have the same or different behaviour (when x and y are not dummy guards),+-- there is no guarantee either way.  The reason behind this is that if you ask+-- for:+--+-- > priAlt [ readChannel c, writeChannel d 6 ]+--+-- And the process at the other end is asking for:+--+-- > priAlt [ readChannel d, writeChannel c 8 ]+--+-- Whichever channel is chosen by both processes will not satisfy the priority+-- at one end (if such priority between channels was supported).  If you do want+-- priority that is globally consistent, look at the channel and barrier creation+-- methods for ways to set priority on events.+priAlt :: [CHP a] -> CHP a+priAlt xs = PoisonT $ \t f -> priAlt' t (map (wrapPoison t) xs) >>= f++priAlt' :: TraceStore -> [CHP' a] -> CHP' a+priAlt' tr = Altable tr . filter (not . isStopGuard . fst) . concatMap getAltable+  where+    getAltable :: CHP' a -> [(Guard, IO (WithPoison a))]+    getAltable (Return x) = [(SkipGuard, return $ NoPoison x)]+    getAltable (Altable _ gs) = gs+    getAltable (Standard m) = [(SkipGuard, m)]+++-- | The stop guard.  Its main use is that it is never ready in a choice, so+-- can be used to mask out guards.  If you actually execute 'stop', that process+-- will do nothing more.  Any parent process waiting for it to complete will+-- wait forever.+--+-- The type of this function was generalised in CHP 1.6.0.+stop :: CHP a+stop = makeAltable [(stopGuard, hang)]+  where+    -- Strangely, I can't work out a good way to actually implement stop.+    -- If you wait on a variable that will never be ready, GHC will wake+    -- you up with an exception.  If you loop doing that, you'll burn the+    -- CPU.  Throwing an exception would be caught and terminate the+    -- process, which is not the desired behaviour.  The only thing I can think+    -- to do is to repeatedly wait for a very long time.+    hang :: IO a+    hang = forever $ threadDelay maxBound

@@ -32,38 +32,36 @@ -- TODO rename this module. module Control.Concurrent.CHP.CSP where +import Control.Applicative import Control.Concurrent.STM import Control.Exception-import Control.Monad.Reader+import Control.Monad (when) import Data.List import qualified Data.Map as Map import Data.Unique -import Control.Concurrent.CHP.Alt import Control.Concurrent.CHP.Base import qualified Control.Concurrent.CHP.Event as Event import Control.Concurrent.CHP.Enroll import Control.Concurrent.CHP.Guard+import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.Traces.Base  -- First engages in event, then executes the body.  The returned value is suitable -- for use in an alt-buildOnEventPoison :: (Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique]) -> Event.Event -> EventActions -> CHP a -> CHP a+buildOnEventPoison :: (Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique]) -> Event.Event -> EventActions -> IO (WithPoison a) -> CHP a buildOnEventPoison recE e act body-  = liftPoison (AltableT (Right [(theGuard, return True)])-                   (return False))-    >>= \b -> if b then body else-      alt [liftPoison $ AltableT (Right [(theGuard, return ())]) (return ())] >> body-    where-      theGuard = EventGuard (recE (Event.getEventUnique e)) act [e]+  = makeAltable [(theGuard, body)]+  where+    theGuard = EventGuard (recE (Event.getEventUnique e)) act [e]  scopeBlock :: CHP a -> (a -> CHP b) -> IO () -> CHP b scopeBlock start body errorEnd     = do x <- start-         tr <- liftPoison $ liftTrace ask-         y <- liftIO $ bracketOnError (return ()) (const errorEnd) $ const-           $ runReaderT (pullOutStandard (wrapPoison $ body x)) tr-         checkPoison y `onPoisonRethrow` (liftIO errorEnd)+         tr <- getTrace+         y <- liftIO_CHP $ bracketOnError (return ()) (const errorEnd) $ const+           $ pullOutStandard (wrapPoison tr $ body x)+         checkPoison y `onPoisonRethrow` (liftIO_CHP errorEnd)  wrapIndiv :: (Unique -> (Unique -> Integer) -> String -> [RecordedIndivEvent Unique])           -> Unique -> (Unique -> (Integer, Event.RecordedEventType))@@ -76,7 +74,7 @@   -> (Int -> STM ()) -> Enrolled PhasedBarrier phase -> CHP phase syncBarrierWith recE storeN (Enrolled (Barrier (e,tv, fph)))     = buildOnEventPoison (wrapIndiv recE) e (EventActions incPhase (return ()))-        (liftIO $ atomically $ readTVar tv)+        (NoPoison <$> (atomically $ readTVar tv))     where       incPhase :: Map.Map Unique Int -> STM ()       incPhase m = do readTVar tv >>= writeTVar tv . fph@@ -112,13 +110,13 @@     = do liftSTM (Event.enrollEvent e) >>= checkPoison          x <- f $ Enrolled b          liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->-           do tr <- liftPoison $ liftTrace ask+           do tr <- getTrace               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)          return x    resign (Enrolled (Barrier (e, _, _))) m     = do liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->-           do tr <- liftPoison $ liftTrace ask+           do tr <- getTrace               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)          x <- m          liftSTM (Event.enrollEvent e) >>= checkPoison@@ -126,7 +124,7 @@  instance Poisonable (Enrolled PhasedBarrier phase) where   poison (Enrolled (Barrier (e, _, _)))-    = liftSTM $ Event.poisonEvent e+    = liftCHP . liftSTM $ Event.poisonEvent e   checkForPoison (Enrolled (Barrier (e, _, _)))     = liftCHP $ liftSTM (Event.checkEventForPoison e) >>= checkPoison 

@@ -31,7 +31,6 @@  import Control.Concurrent.STM import Control.Monad-import Control.Monad.Trans import Data.Unique (Unique)  import Control.Concurrent.CHP.Base@@ -68,48 +67,17 @@   writer :: w a}  -class ChaninC c a where-  -- Start gets the event and the transaction that will wait for data.  You-  -- sync on the event (possible extended write occurs) then wait for data-  startReadChannelC :: c a -> (Event, STM (WithPoison a))-  -- (extended read action goes here)-  -- Read releases the writer-  endReadChannelC :: c a -> STM (WithPoison ())--  -- First action is to be done as part of the completion:-  readChannelC :: c a -> (Event, STM (), STM (WithPoison a))--  poisonReadC :: c a -> IO ()-  checkPoisonReadC :: c a -> IO (WithPoison ())--class ChanoutC c a where-  -- Start checks for poison and gets the event:-  startWriteChannelC :: c a -> (Event, STM (WithPoison ()))-  -- (extended write action goes here)-  -- Send actually transmits the value:-  sendWriteChannelC :: c a -> a -> STM (WithPoison ())-  -- (extended read action goes here)-  -- End waits for the reader to tell us we're done, must be done in a different-  -- transaction to the send-  endWriteChannelC :: c a -> STM (WithPoison ())--  -- First action is to be done as part of the completion:-  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+  poison (Chanin c) = liftCHP . liftIO_CHP $ poisonReadC c+  checkForPoison (Chanin c) = liftCHP $ liftIO_CHP (checkPoisonReadC c) >>= checkPoison  instance Poisonable (Chanout a) where-  poison (Chanout c) = liftIO $ poisonWriteC c-  checkForPoison (Chanout c) = liftCHP $ liftIO (checkPoisonWriteC c) >>= checkPoison+  poison (Chanout c) = liftCHP . liftIO_CHP $ poisonWriteC c+  checkForPoison (Chanout c) = liftCHP $ liftIO_CHP (checkPoisonWriteC c) >>= checkPoison  -stmChannel :: MonadIO m => Int -> (a -> String) -> m (Unique, STMChannel a)-stmChannel pri sh = liftIO $+stmChannel :: Int -> (a -> String) -> IO (Unique, STMChannel a)+stmChannel pri sh =   do c <- atomically $ newTVar $ NoPoison (Nothing, Nothing)      e <- newEventPri (liftM (ChannelComm . maybe "" sh . getVal) $ readTVar c) 2 pri      return (getEventUnique e, STMChan (e,c))@@ -128,11 +96,18 @@                       NoPoison (Just x, a) -> do writeTVar tv $ NoPoison (Nothing, a)                                                  return $ NoPoison x +sharedError :: String -> String+sharedError s+  = unlines ["CHP: Assumption violated; found " ++ s ++ " when placing " ++ s ++ "."+            ,"This is typically because you have multiple writers or multiple readers accessing a unshared (one-to-one) channel."+            ,"If you want to have many writers or many readers, use an appropriate (any-to-one, one-to-any or any-to-any) shared channel, using the claim function."+            ]+ 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 (Just _, _) -> error $ sharedError "data"                       NoPoison (Nothing, a) -> do writeTVar tv $ NoPoison (Just x, a)                                                   return $ NoPoison () @@ -148,35 +123,62 @@ sendAck tv =    do d <- readTVar tv                    case d of                       PoisonItem -> return PoisonItem-                      NoPoison (_, Just _) -> error "CHP: Found ack while placing ack!"+                      NoPoison (_, Just _) -> error $ sharedError "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)+-- Start gets the event and the transaction that will wait for data.  You+-- sync on the event (possible extended write occurs) then wait for data+startReadChannelC :: STMChannel a -> (Event, STM (WithPoison a))+startReadChannelC (STMChan (e,tv)) = (e, consumeData tv) -  poisonReadC (STMChan (e,tv))-    = liftSTM $ do poisonEvent e-                   writeTVar tv PoisonItem-  checkPoisonReadC (STMChan (e,_)) = liftSTM $ checkEventForPoison e+-- (extended read action goes here)+-- Read releases the writer+endReadChannelC :: STMChannel a -> STM (WithPoison ())+endReadChannelC (STMChan (_,tv)) = sendAck tv -instance ChanoutC STMChannel a where-  startWriteChannelC (STMChan (e,tv))+-- First action is to be done as part of the completion:+readChannelC :: STMChannel a -> (Event, STM (), STM (WithPoison a))+readChannelC (STMChan (e, tv))+  = (e, sendAck tv >> return (), consumeData tv)++poisonReadC :: STMChannel a -> IO ()+poisonReadC (STMChan (e,tv))+    = atomically $ do poisonEvent e+                      writeTVar tv PoisonItem++checkPoisonReadC :: STMChannel a -> IO (WithPoison ())+checkPoisonReadC (STMChan (e,_)) = atomically $ checkEventForPoison e++-- Start checks for poison and gets the event:+startWriteChannelC :: STMChannel a -> (Event, STM (WithPoison ()))+startWriteChannelC (STMChan (e,tv))     = (e, do x <- readTVar tv              case x of                PoisonItem -> return PoisonItem                NoPoison _ -> return $ NoPoison ())-  sendWriteChannelC (STMChan (_, tv)) = sendData tv-  endWriteChannelC (STMChan (_, tv))++-- (extended write action goes here)+-- Send actually transmits the value:+sendWriteChannelC :: STMChannel a -> a -> STM (WithPoison ())+sendWriteChannelC (STMChan (_, tv)) = sendData tv++-- (extended read action goes here)+-- End waits for the reader to tell us we're done, must be done in a different+-- transaction to the send+endWriteChannelC :: STMChannel a -> STM (WithPoison ())+endWriteChannelC (STMChan (_, tv))     = consumeAck tv -  writeChannelC (STMChan (e, tv)) val+-- First action is to be done as part of the completion:+writeChannelC :: STMChannel a -> a -> (Event, STM (), STM (WithPoison ()))+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+poisonWriteC :: STMChannel a -> IO ()+poisonWriteC (STMChan (e,tv))+  = atomically $ do poisonEvent e+                    writeTVar tv PoisonItem++checkPoisonWriteC :: STMChannel a -> IO (WithPoison ())+checkPoisonWriteC (STMChan (e,_)) = atomically $ checkEventForPoison e

@@ -74,7 +74,6 @@ import Control.Arrow import Control.Concurrent.STM import Control.Monad-import Control.Monad.Trans import Data.Monoid  import Control.Concurrent.CHP.Barriers@@ -117,18 +116,18 @@            (resetManyToOneTVar tvAck . pred) $ Enrolled b            -- subtract one for writer          (x, r) <- m-         liftIO . atomically $ writeTVar tvSend $ Just x+         liftSTM $ writeTVar tvSend $ Just x          -- Must be two separate transactions:-         _ <- liftIO . atomically $ readManyToOneTVar tvAck+         _ <- liftSTM $ readManyToOneTVar tvAck          return r  instance ReadableChannel (Enrolled BroadcastChanin) where   extReadChannel (Enrolled (BI (BC (b, tvSend, tvAck)))) f     = do syncBarrierWith (indivRecJust ChannelRead)            (resetManyToOneTVar tvAck . pred) $ Enrolled b-         x <- liftIO $ atomically $ readTVar tvSend >>= maybe retry return+         x <- liftSTM $ readTVar tvSend >>= maybe retry return          y <- f x-         _ <- liftIO $ atomically $ writeManyToOneTVar pred tvAck+         _ <- liftSTM $ writeManyToOneTVar pred tvAck          return y  instance Poisonable (BroadcastChanout a) where@@ -143,9 +142,9 @@ newBroadcastChannel   = do b@(Barrier (e, _, _)) <- newBarrier        -- Writer is always enrolled:-       _ <- liftIO $ atomically $ enrollEvent e-       tvSend <- liftIO $ atomically $ newTVar Nothing-       tvAck <- liftIO $ atomically $ newManyToOneTVar (== 0) (return 0) 0+       _ <- liftSTM $ enrollEvent e+       tvSend <- liftSTM $ newTVar Nothing+       tvAck <- liftSTM $ newManyToOneTVar (== 0) (return 0) 0        return $ BC (b, tvSend, tvAck)  instance Channel BroadcastChanin BroadcastChanout where@@ -156,7 +155,7 @@  instance Channel BroadcastChanin (Shared BroadcastChanout) where   newChannel' _sh = liftCHP $ do-    m <- newMutex+    m <- liftIO_CHP newMutex     c <- newChannel     return $ Chan (getChannelIdentifier c) (reader c) (Shared (m, writer c))   sameChannel (BI x) (Shared (_, BO y)) = x == y@@ -215,12 +214,12 @@            (\n -> resetManyToOneTVar tv (pred n, Nothing)) $ Enrolled b            -- Subtract one for reader          (x, r) <- m-         (_, Just (_, rtvb)) <- liftIO . atomically $ do+         (_, Just (_, rtvb)) <- liftSTM $ do            tvb <- newTVar False            let upd (n, mx) = (pred n, Just $ maybe (x, tvb) (first $ f x) mx)            writeManyToOneTVar upd tv          -- Has to be two separate transactions-         liftIO $ atomically $ readTVar rtvb >>= flip unless retry+         liftSTM $ readTVar rtvb >>= flip unless retry          return r  instance ReadableChannel ReduceChanin where@@ -228,10 +227,10 @@     = do syncBarrierWith (indivRecJust ChannelRead)            (\n -> resetManyToOneTVar tv (pred n, Nothing)) $ Enrolled b            -- Subtract one for reader-         (_, val) <- liftIO $ atomically $ readManyToOneTVar tv+         (_, val) <- liftSTM $ readManyToOneTVar tv          case val of            Just (x, tvb) -> do y <- f x-                               liftIO $ atomically $ writeTVar tvb True+                               liftSTM $ writeTVar tvb True                                return y            Nothing -> f empty @@ -247,8 +246,8 @@ newReduceChannel   = do b@(Barrier (e, _, _)) <- newBarrier        -- Writer is always enrolled:-       _ <- liftIO $ atomically $ enrollEvent e-       mtv <- liftIO $ atomically $ newManyToOneTVar ((== 0) . fst) (return (0, Nothing)) (0, Nothing)+       _ <- liftSTM $ enrollEvent e+       mtv <- liftSTM $ newManyToOneTVar ((== 0) . fst) (return (0, Nothing)) (0, Nothing)        return $ GC (b, mtv, (mappend, mempty))  -- | The reduce channel version of sameChannel.@@ -268,7 +267,7 @@  manyToAnyChannel :: (Monoid a, MonadCHP m) => m (ManyToAnyChannel a) manyToAnyChannel = do-    m <- newMutex+    m <- liftCHP $ liftIO_CHP newMutex     c <- manyToOneChannel     return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (writer c) 

@@ -56,7 +56,7 @@   ReadableChannel(..), WriteableChannel(..), writeValue, writeChannelStrict   ) where -+import Control.Concurrent.STM (atomically) import Control.DeepSeq import Control.Monad import Data.Monoid@@ -132,12 +132,12 @@     = let (e, mdur, mafter) = readChannelC c in       buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e         (EventActions (const $ return ()) mdur)-        (liftSTM mafter) >>= checkPoison+        (atomically mafter)    extReadChannel (Chanin c) body     = let (e, m) = startReadChannelC c in       scopeBlock-        (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e mempty (liftSTM m) >>= checkPoison)+        (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e mempty (atomically m))         (\val -> do x <- body val                     _ <- liftSTM $ endReadChannelC c                     return x)@@ -147,13 +147,12 @@   writeChannel (Chanout c) x     = let (e, mdur, mafter) = writeChannelC c x in         buildOnEventPoison (wrapIndiv $ indivRecJust ChannelWrite) e-          (EventActions (const $ return ()) mdur) (liftSTM mafter)-        >>= checkPoison+          (EventActions (const $ return ()) mdur) (atomically mafter)   extWriteChannel' (Chanout c) body     = let (e, m) = startWriteChannelC c in       scopeBlock         (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelWrite)-          e mempty (liftSTM m) >>= checkPoison)+          e mempty (atomically m))         (const $ do (x, r) <- body                     sequence [liftSTM $ sendWriteChannelC c x                              ,liftSTM (endWriteChannelC c)]

@@ -63,7 +63,7 @@ -- the channels in traces).  Instead of using @oneToOneChannelWithLabel "foo"@, -- you should use @oneToOneChannel' $ chanLabel "foo"@. module Control.Concurrent.CHP.Channels.Creation (-  Chan, Channel(..), newChannel, ChanOpts(..), defaultChanOpts, chanLabel, newChannelWR, newChannelRW, ChannelTuple(..),+  Chan, Channel(..), newChannel, ChanOpts(..), defaultChanOpts, chanLabel, newChannelWR, newChannelRW,   newChannelList, newChannelListWithLabels, newChannelListWithStem,   labelChannel   ) where@@ -137,17 +137,6 @@ newChannel :: (MonadCHP m, Channel r w) => m (Chan r w a) newChannel = newChannel' defaultChanOpts --- | A helper class for easily creating several channels of the same type.---  The same type refers not only to what type the channel carries, but---  also to the type of channel (one-to-one no poison, one-to-any with---  poison, etc).  You can write code like this:------ > (a, b, c, d, e) <- newChannels------ To create five channels of the same type.-class ChannelTuple t where-  newChannels :: MonadCHP m => m t- -- | A helper that is like 'newChannel' but returns the reading and writing -- end of the channels directly. newChannelRW :: (Channel r w, MonadCHP m) => m (r a, w a)@@ -178,76 +167,38 @@ newChannelListWithLabels :: (Channel r w, MonadCHP m) => [String] -> m [Chan r w a] newChannelListWithLabels = mapM (newChannel' . ChanOpts 0 (const "") . Just) -instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a) where-  newChannels = do c0 <- newChannel-                   c1 <- newChannel-                   return (c0, c1)--instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a) where-  newChannels = do c0 <- newChannel-                   c1 <- newChannel-                   c2 <- newChannel-                   return (c0, c1, c2)--instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a,-  Chan r w a) where-  newChannels = do c0 <- newChannel-                   c1 <- newChannel-                   c2 <- newChannel-                   c3 <- newChannel-                   return (c0, c1, c2, c3)--instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a,-  Chan r w a, Chan r w a) where-  newChannels = do c0 <- newChannel-                   c1 <- newChannel-                   c2 <- newChannel-                   c3 <- newChannel-                   c4 <- newChannel-                   return (c0, c1, c2, c3, c4)--instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a,-  Chan r w a, Chan r w a, Chan r w a) where-  newChannels = do c0 <- newChannel-                   c1 <- newChannel-                   c2 <- newChannel-                   c3 <- newChannel-                   c4 <- newChannel-                   c5 <- newChannel-                   return (c0, c1, c2, c3, c4, c5)- -- | Labels a channel in the traces.  It is easiest to do this at creation. -- The effect of re-labelling channels after their first use is undefined. -- -- Added in version 1.5.0. labelChannel :: MonadCHP m => Chan r w a -> String -> m ()-labelChannel c = liftCHP . liftPoison . liftTrace . labelUnique (getChannelIdentifier c)+labelChannel c s = liftCHP $ getTrace >>= \t -> liftIO_CHP $ labelUnique t (getChannelIdentifier c) s   instance Channel Chanin Chanout where-  newChannel' o = do c <- chan (stmChannel (chanOptsPriority o) (chanOptsShow o)) Chanin Chanout+  newChannel' o = do c <- chan (liftCHP . liftIO_CHP $ stmChannel (chanOptsPriority o) (chanOptsShow o)) Chanin Chanout                      maybe (return ()) (labelChannel c) (chanOptsLabel o)                      return c   sameChannel (Chanin x) (Chanout y) = x == y  instance Channel (Shared Chanin) Chanout where   newChannel' o = do-                  m <- newMutex+                  m <- liftCHP . liftIO_CHP $ newMutex                   c <- newChannel' o                   return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (writer c)   sameChannel (Shared (_, Chanin x)) (Chanout y) = x == y  instance Channel Chanin (Shared Chanout) where   newChannel' o = do-                  m <- newMutex+                  m <- liftCHP . liftIO_CHP $ newMutex                   c <- newChannel' o                   return $ Chan (getChannelIdentifier c) (reader c) (Shared (m, writer c))   sameChannel (Chanin x) (Shared (_, Chanout y)) = x == y  instance Channel (Shared Chanin) (Shared Chanout) where   newChannel' o = do-                  m <- newMutex-                  m' <- newMutex+                  m <- liftCHP . liftIO_CHP $ newMutex+                  m' <- liftCHP . liftIO_CHP $ newMutex                   c <- newChannel' o                   return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (Shared (m', writer c))   sameChannel (Shared (_, Chanin x)) (Shared (_, Chanout y)) = x == y

@@ -38,8 +38,6 @@   reader, writer, readers, writers,   claim) where -import Control.Monad.Trans (liftIO)- import Control.Concurrent.CHP.Base import Control.Concurrent.CHP.CSP import Control.Concurrent.CHP.Channels.Base@@ -62,8 +60,8 @@ claim :: Shared c a -> (c a -> CHP b) -> CHP b claim (Shared (lock, c)) body   = scopeBlock-       (claimMutex lock >> return c)+       (liftIO_CHP (claimMutex lock) >> return c)        (\y -> do x <- body y-                 liftIO $ releaseMutex lock+                 liftIO_CHP $ releaseMutex lock                  return x)        (releaseMutex lock)

@@ -120,8 +120,6 @@  import Control.Concurrent.STM import Control.Monad hiding (mapM, mapM_)-import Control.Monad.Reader (ask)-import Control.Monad.Trans import Data.Foldable (mapM_) -- Needed for testing: --import Data.Maybe@@ -327,14 +325,14 @@          liftSTM (modifyTVar tv $ enrollTimerData $ Just ev)            >>= checkPoison          x <- f $ Enrolled tim-         ts <- liftPoison . liftTrace $ ask+         ts <- getTrace          liftSTM (modifyTVar' tv $ checkCompletion u sh ts . resignTimerData True)            >>= checkPoison          return x    -- For temporary resignations, we don't touch the event pool   resign (Enrolled (Clock (tv, u, sh))) m-    = do ts <- liftPoison . liftTrace $ ask+    = do ts <- getTrace          liftSTM (modifyTVar' tv (checkCompletion u sh ts . resignTimerData False))            >>= checkPoison          x <- m@@ -406,32 +404,34 @@ -- to display times in traces. newClock :: (Ord time, Show time) => time -> CHP (Clock time) newClock t = do tv <- liftSTM $ newTVar $ NoPoison $ emptyTimerData t-                u <- liftIO Event.newEventUnique+                u <- liftIO_CHP Event.newEventUnique                 return $ Clock (tv, u, show)  -- | Creates a clock that starts at the given time, and gives it the given -- label in traces.  The Show instance is needed to display times in traces. newClockWithLabel :: (Ord time, Show time) =>   time -> String -> CHP (Clock time)-newClockWithLabel t l = do tv <- liftSTM $ newTVar $ NoPoison $ emptyTimerData t-                           u <- liftIO Event.newEventUnique-                           liftPoison $ liftTrace $ labelUnique u l+newClockWithLabel t l = getTrace >>= \tr -> liftIO_CHP $+                        do tv <- atomically $ newTVar $ NoPoison $ emptyTimerData t+                           u <- Event.newEventUnique+                           labelUnique tr u l                            return $ Clock (tv, u, show)  instance Waitable Clock where   getCurrentTime (Enrolled (Clock (tv, _, _)))     = liftSTM (liftM (fmap curTime) $ readTVar tv) >>= checkPoison   wait c@(Enrolled (Clock (_, u, sh))) mt-    = do ts <- liftPoison . liftTrace $ ask-         pid <- liftPoison . liftTrace $ getProcessId-         waitAct <- liftSTM $ waitClock pid ts c mt+    = do tr <- getTrace+         let pid = getProcessId tr+         waitAct <- liftSTM $ waitClock pid tr c mt          (t, s) <- liftSTM waitAct >>= checkPoison-         liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u s $ sh t]+         liftIO_CHP $ recordEvent [ClockSyncIndiv u s $ sh t] tr          return t  instance Ord time => Poisonable (Enrolled Clock time) where   poison (Enrolled (Clock (tv,_,_)))-    = liftSTM $ do x <- readTVar tv+    = liftCHP . liftSTM $ do+                   x <- readTVar tv                    case x of                      PoisonItem -> return ()                      NoPoison td -> do poisonTimerData td

@@ -44,7 +44,6 @@ import Control.Concurrent.STM hiding (always) import Control.Concurrent.CHP.EventType import Control.Monad-import Control.Monad.Reader #ifdef CHP_TEST import Control.Monad.State #endif@@ -92,7 +91,7 @@ -- Nothing if resigning checkEvent :: CurOfferSet -> SearchState -> Event -> DiscoverM SearchState checkEvent cos ss e = do-  s <- lift $ readTVar $ getEventTVar e+  s <- liftWPMT $ readTVar $ getEventTVar e   case s of     PoisonItem -> WPMT $ return PoisonItem     NoPoison (enrollCount, _, offers) ->@@ -218,8 +217,10 @@ instance Monad m => Functor (WithPoisonMaybeT m) where   fmap f = WPMT . liftM (fmap (fmap f)) . runWPMT -instance MonadTrans WithPoisonMaybeT where-  lift = WPMT . liftM (NoPoison . Just)+liftWPMT :: Monad m => m a -> WithPoisonMaybeT m a+liftWPMT = WPMT . liftM (NoPoison . Just)++  instance (Monad m) => Applicative (WithPoisonMaybeT m) where   pure = return

@@ -31,7 +31,6 @@  import Control.Concurrent.STM import Control.Monad-import Control.Monad.Trans import qualified Data.Map as Map import Data.Monoid import Data.Unique@@ -76,7 +75,7 @@ guardWaitFor :: Int -> Guard guardWaitFor n   = TimeoutGuard $ -     do signalDone <- liftIO $ registerDelay n+     do signalDone <- registerDelay n         return $ do b <- readTVar signalDone                     when (not b) retry 

@@ -31,17 +31,19 @@ module Control.Concurrent.CHP.Monad   (    -- * CHP Monad-  CHP, MonadCHP(..), runCHP, runCHP_,+  CHP, MonadCHP(..), liftIO_CHP, runCHP, runCHP_,   embedCHP, embedCHP_, embedCHP1, embedCHP1_,    onPoisonTrap, onPoisonRethrow, throwPoison, Poisonable(..), poisonAll,    -- * Primitive actions-  skip, stop, waitFor+  skip, stop, waitFor,++  -- * chp-spec items+  foreverP, liftIO_CHP', process, subProcess    ) where -import Control.Concurrent-import Control.Monad.Reader+import Control.Monad (liftM, forever) import Data.Unique  -- This module primarily re-exports the public definitions from@@ -49,6 +51,7 @@  import Control.Concurrent.CHP.Base import Control.Concurrent.CHP.Guard+import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.Traces.TraceOff  -- | Runs a CHP program.  You should use this once, at the top-level of your@@ -62,6 +65,27 @@ runCHP_ :: CHP a -> IO () runCHP_ p = runCHP p >> return () +-- | Exactly the same as 'forever'.  Useful only because it mirrors a different definition+-- from the chp-spec library.+--+-- Added in version 2.2.0.+foreverP :: CHP a -> CHP b+foreverP = forever++-- | Acts as @const id@.  Useful only because it mirrors a different definition in the+-- chp-spec library.+--+-- Added in version 2.2.0.+process :: String -> a -> a+process = const id++-- | Acts as @const id@.  Useful only because it mirrors a different definition in the+-- chp-spec library.+--+-- Added in version 2.2.0.+subProcess :: String -> a -> a+subProcess = const id+ -- | Allows embedding of the CHP monad back into the IO monad.  The argument -- that this function takes is a CHP action (with arbitrary behaviour).  The -- function is monadic, and returns something of type: IO a.  This@@ -81,7 +105,7 @@  -- | A helper like embedCHP for callbacks that take an argument embedCHP1 :: (a -> CHP b) -> CHP (a -> IO (Maybe b))-embedCHP1 f = do t <- liftPoison $ liftTrace ask+embedCHP1 f = do t <- getTrace                  return $ runCHPProgramWith t . f  -- | A convenient version of embedCHP1 that ignores the result@@ -102,7 +126,7 @@ -- /NOTE:/ If you wish to use this as part of a choice, you must use @-threaded@ -- as a GHC compilation option (at least under 6.8.2). waitFor :: Int -> CHP ()-waitFor n = liftPoison $ AltableT (Right [(guardWaitFor n, return ())]) (liftIO $ threadDelay n)+waitFor n = makeAltable [(guardWaitFor n, return $ NoPoison ())] -- TODO maybe fix the above lack of guarantees by keeping timeout guards explicit.  -- TODO add waitUntil@@ -111,23 +135,11 @@ -- -- Suitable for use in an 'Control.Concurrent.CHP.Alt.alt'. skip :: CHP ()-skip = liftPoison $ AltableT (Right [(skipGuard, return ())]) (return ())+skip = makeAltable [(skipGuard, return $ NoPoison ())] --- | The stop guard.  Its main use is that it is never ready in a choice, so--- can be used to mask out guards.  If you actually execute 'stop', that process--- will do nothing more.  Any parent process waiting for it to complete will--- wait forever.+-- | Acts as @const liftIO_CHP@.  Useful only because it mirrors a different definition in the+-- chp-spec library. ----- The type of this function was generalised in CHP 1.6.0.-stop :: CHP a-stop = liftPoison $ AltableT (Right [(stopGuard, liftIO hang)]) (liftIO hang)-  where-    -- Strangely, I can't work out a good way to actually implement stop.-    -- If you wait on a variable that will never be ready, GHC will wake-    -- you up with an exception.  If you loop doing that, you'll burn the-    -- CPU.  Throwing an exception would be caught and terminate the-    -- process, which is not the desired behaviour.  The only thing I can think-    -- to do is to repeatedly wait for a very long time.-    hang :: IO a-    hang = forever $ threadDelay maxBound-+-- Added in version 2.2.0.+liftIO_CHP' :: String -> IO a -> CHP a+liftIO_CHP' = const liftIO_CHP

@@ -30,18 +30,17 @@ module Control.Concurrent.CHP.Mutex where  import Control.Concurrent-import Control.Monad.Trans  type Mutex = MVar () -claimMutex :: MonadIO m => Mutex -> m ()-claimMutex = liftIO . takeMVar+claimMutex :: Mutex -> IO ()+claimMutex = takeMVar -newMutex :: MonadIO m => m Mutex-newMutex = liftIO $ newMVar ()+newMutex :: IO Mutex+newMutex = newMVar () -releaseMutex :: MonadIO m => Mutex -> m ()-releaseMutex m = liftIO $ putMVar m ()+releaseMutex :: Mutex -> IO ()+releaseMutex m = putMVar m ()  -- | A wrapper (usually around a channel-end) indicating that the inner item -- is shared.  Use the 'claim' function to use this type.

@@ -28,17 +28,18 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  module Control.Concurrent.CHP.Parallel (runParallel, runParallel_, (<||>), (<|*|>),-  runParMapM, runParMapM_, ForkingT, forking, fork) where+  runParMapM, runParMapM_ , ForkingT, liftForking, forking, fork) where  import Control.Concurrent import Control.Concurrent.STM+import Control.Monad (liftM) import qualified Control.Exception.Extensible as C-import Control.Monad.Reader import Data.List import Data.Maybe import Data.Ord  import Control.Concurrent.CHP.Base+import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.Traces.Base  -- | This type-class supports parallel composition of processes.  You may use@@ -114,35 +115,46 @@ -- | Runs all the processes in parallel and returns their results once they -- have all finished.  The length and ordering of the results reflects the -- length and ordering of the input-runParallelPoison :: forall a. [CHP a] -> CHP [a]+runParallelPoison :: [CHP a] -> CHP [a] runParallelPoison processes-  = do resultVar <- liftIO $ atomically $ newManyToOneTVar+  = do resultVar <- liftIO_CHP $ atomically $ newManyToOneTVar          ((== length processes) . length) (return []) []-       trace <- PoisonT $ lift $ liftTrace ask-       blanks <- liftIO $ blankTraces trace (length processes)-       liftIO $ -         mapM_ forkIO [do y <- wrapProcess p $ flip runReaderT btr . pullOutStandard+       trace <- getTrace+       blanks <- liftIO_CHP $ blankTraces trace (length processes)+       liftIO_CHP $ +         mapM_ forkIO [do y <- wrapProcess p btr pullOutStandard                           C.block $ atomically $                             writeManyToOneTVar                              ((:) (case y of                                  Nothing -> (n, Nothing)-                                 Just (Right x) -> (n, Just x)-                                 Just (Left _) -> (n, Nothing)+                                 Just (NoPoison x) -> (n, Just x)+                                 Just PoisonItem -> (n, Nothing)                                  )) resultVar                              >> return ()                       | (p, btr, n) <- zip3 processes blanks [(0::Int)..]]-       results <- liftIO $ atomically $ readManyToOneTVar resultVar+       results <- liftIO_CHP $ atomically $ readManyToOneTVar resultVar        let sortedResults = map snd $ sortBy (comparing fst) results-       PoisonT $ lift $ liftTrace $ mergeSubProcessTraces blanks+       liftIO_CHP $ mergeSubProcessTraces blanks trace        mapM (maybe throwPoison return) sortedResults  -- | A monad transformer used for introducing forking blocks.-newtype (Monad m, MonadCHP m) => ForkingT m a = Forking (ReaderT (TVar (Bool,-  Int)) m a)-  deriving (Monad, MonadIO, MonadTrans, MonadCHP)+newtype ForkingT m a = Forking {runForkingT :: TVar (Bool, Int) -> m a } +instance Monad m => Monad (ForkingT m) where+  return = liftForking . return+  m >>= k = Forking $ \tv -> runForkingT m tv >>= (flip runForkingT tv . k)++instance MonadCHP m => MonadCHP (ForkingT m) where+  liftCHP = liftForking . liftCHP+ -- TODO in future, get forking working with structural traces +-- | An implementation of lift for the ForkingT monad transformer.+--+-- Added in version 2.2.0.+liftForking :: Monad m => m a -> ForkingT m a+liftForking = Forking . const+ -- | Executes a forking block.  Processes may be forked off inside (using the -- 'fork' function).  When the block completes, it waits for all the forked -- off processes to complete before returning the output, as long as none of@@ -150,9 +162,9 @@ -- is propagated (rethrown). forking :: MonadCHP m => ForkingT m a -> m a -- Like with parallel, this could probably be made a little more efficient-forking (Forking m) = do b <- liftIO $ atomically $ newTVar (False, 0)-                         output <- runReaderT m b-                         p <- liftIO $ atomically $ do+forking (Forking m) = do b <- liftCHP . liftSTM $ newTVar (False, 0)+                         output <- m b+                         p <- liftCHP . liftSTM $ do                            (p,n) <- readTVar b                            if n == 0                              then return p@@ -167,15 +179,14 @@ -- are waited for.  At that point, once all of the processes have finished, -- if any of them threw poison it is propagated. fork :: MonadCHP m => CHP () -> ForkingT m ()-fork p = Forking $-           do b <- ask-              liftIO $ atomically $ do+fork p = Forking $ \b ->+           do liftCHP . liftSTM $ do                 (pa, n) <- readTVar b                 writeTVar b (pa, n + 1)-              trace <- liftCHP $ PoisonT $ lift $ liftTrace ask-              [blank] <- liftIO $ blankTraces trace 1-              _ <- liftIO $ forkIO $ do-                r <- wrapProcess p $ flip runReaderT blank . pullOutStandard+              trace <- liftCHP getTrace+              [blank] <- liftCHP . liftIO_CHP $ blankTraces trace 1+              _ <- liftCHP . liftIO_CHP $ forkIO $ do+                r <- wrapProcess p blank pullOutStandard                 C.block $ atomically $ do                   (poisonedAlready, n) <- readTVar b                   writeTVar b (poisonedAlready || isNothing r, n - 1)

@@ -30,8 +30,7 @@ module Control.Concurrent.CHP.Traces.Base where  import Control.Concurrent.STM-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad (liftM) import Data.IORef import Data.List import qualified Data.Map as Map@@ -102,16 +101,22 @@  type RecEvents = ([RecordedEvent Unique], [RecordedIndivEvent Unique]) -getName :: Ord u => String -> u -> State (Map.Map u String) String-getName prefix u-          = do m <- get+data LabelM u a = LabelM { runLabelM :: ChannelLabels u -> (a, ChannelLabels u) }++labelWith :: LabelM u a -> ChannelLabels u -> a+labelWith = (fst .) . runLabelM++instance Monad (LabelM u) where+  return = LabelM . (,)+  m >>= k = LabelM $ \s -> let (a, s') = runLabelM m s in runLabelM (k a) s'++getName :: Ord u => String -> u -> LabelM u String+getName prefix u = LabelM $ \m ->                case Map.lookup u m of-                 Just x -> return x-                 Nothing -> let x = prefix ++ show (Map.size m) in-                            do put $ Map.insert u x m-                               return x+                 Just x -> (x, m)+                 Nothing -> let x = prefix ++ show (Map.size m) in (x, Map.insert u x m) -nameEvent :: Ord u => RecordedEvent u -> State (Map.Map u String) String+nameEvent :: Ord u => RecordedEvent u -> LabelM u String nameEvent (t, c) = liftM (++ suffix) $ getName prefix c   where     (prefix, suffix) = case t of@@ -119,7 +124,7 @@       BarrierSync x -> ("_b", if null x then "" else '.' : x)       ClockSync st -> ("_t", ':' : st) -nameEvent' :: Ord u => RecordedEvent u -> State (Map.Map u String) (RecordedEvent String)+nameEvent' :: Ord u => RecordedEvent u -> LabelM u (RecordedEvent String) nameEvent' (t, c) = do c' <- getName prefix c                        return (t, c' ++ suffix)   where@@ -129,7 +134,7 @@       ClockSync st -> ("_t", ':' : st)  -nameIndivEvent :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) String+nameIndivEvent :: Ord u => RecordedIndivEvent u -> LabelM u String nameIndivEvent (ChannelWrite c n _) = do c' <- getName "_c" c                                          return $ c' ++ "![" ++ show n ++ "]" nameIndivEvent (ChannelRead c n _) = do c' <- getName "_c" c@@ -140,7 +145,7 @@                                            return $ c' ++ ":" ++ t                                              ++ "[" ++ show n ++ "]" -nameIndivEvent' :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) (RecordedIndivEvent String)+nameIndivEvent' :: Ord u => RecordedIndivEvent u -> LabelM u (RecordedIndivEvent String) nameIndivEvent' (ChannelWrite c n x) = do c' <- getName "_c" c                                           return $ ChannelWrite c' n x nameIndivEvent' (ChannelRead c n x) = do c' <- getName "_c" c@@ -151,8 +156,6 @@                                             return $ ClockSyncIndiv c' n t  -type TraceT = ReaderT TraceStore- data TraceStore =   NoTrace ProcessId   | Trace (ProcessId, TVar (ChannelLabels Unique), SubTraceStore)@@ -204,15 +207,15 @@                  -> foldl (flip Set.insert) z news' : zs  -- | Records an event where you were one of the people involved-recordEvent :: [RecordedIndivEvent Unique] -> TraceT IO ()-recordEvent e = ask >>= lift . mapSubTrace recH+recordEvent :: [RecordedIndivEvent Unique] -> TraceStore -> IO ()+recordEvent e = mapSubTrace recH   where     recH (Hierarchy es) = modifyIORef es (addParEventsH (map StrEvent e))     recH _ = return () -mergeSubProcessTraces :: [TraceStore] -> TraceT IO ()+mergeSubProcessTraces :: [TraceStore] -> TraceStore -> IO () mergeSubProcessTraces ts-  = ask >>= lift . mapSubTrace merge+  = mapSubTrace merge   where     ts' = mapM readIORef [t | Trace (_,_,Hierarchy t) <- ts]     merge (Hierarchy es) = ts' >>= modifyIORef es . addParEventsH@@ -277,18 +280,17 @@ addRLE x nes = (1,[x]):nes  -labelEvent :: Event -> String -> TraceT IO ()-labelEvent e = labelUnique (getEventUnique e)+labelEvent :: TraceStore -> Event -> String -> IO ()+labelEvent t e = labelUnique t (getEventUnique e) -labelUnique :: Unique -> String -> TraceT IO ()-labelUnique u l-  = do t <- ask-       case t of-         NoTrace {} -> return ()-         Trace (_,tvls,_) -> add tvls+labelUnique :: TraceStore -> Unique -> String -> IO ()+labelUnique t u l+  = case t of+       NoTrace {} -> return ()+       Trace (_,tvls,_) -> add tvls   where-    add :: TVar (Map.Map Unique String) -> TraceT IO ()-    add tv = liftIO $ atomically $ do+    add :: TVar (Map.Map Unique String) -> IO ()+    add tv = atomically $ do       m <- readTVar tv       writeTVar tv $ Map.insert u l m 

@@ -32,7 +32,7 @@ module Control.Concurrent.CHP.Traces.CSP (CSPTrace(..), getCSPPlain, runCHP_CSPTrace, runCHP_CSPTraceAndPrint) where  import Control.Concurrent.STM-import Control.Monad.State+import Control.Monad (liftM) import qualified Data.Map as Map import Data.Unique import Text.PrettyPrint.HughesPJ@@ -54,10 +54,10 @@                         runCHPProgramWith' st (flip toPublic st) p    prettyPrint (CSPTrace (labels, events))-    = char '<' <+> sep (punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>'+    = char '<' <+> sep (punctuate (char ',') $ mapM (liftM text . nameEvent) events `labelWith` labels) <+> char '>'    labelAll (CSPTrace (labels, events))-    = CSPTrace (Map.empty, evalState (mapM nameEvent' events) labels)+    = CSPTrace (Map.empty, mapM nameEvent' events `labelWith` labels)  toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (CSPTrace Unique) toPublic l (CSPTraceRev tv)

@@ -38,7 +38,6 @@   getAllEventsInHierarchy) where  import Control.Applicative hiding (empty)-import Control.Monad.State import qualified Data.Foldable as F import Data.IORef import Data.List@@ -115,7 +114,7 @@    prettyPrint (StructuralTrace (_,Nothing)) = empty   prettyPrint (StructuralTrace (labels, Just h))-    = pp $ evalState (T.mapM nameIndivEvent h) labels+    = pp $ T.mapM nameIndivEvent h `labelWith` labels     where       pp :: EventHierarchy String -> Doc       pp (SingleEvent x) = text x@@ -129,7 +128,7 @@    labelAll (StructuralTrace (_, Nothing)) = StructuralTrace (Map.empty, Nothing)   labelAll (StructuralTrace (labels, Just h))-    = StructuralTrace (Map.empty, Just $ evalState (T.mapM nameIndivEvent' h) labels)+    = StructuralTrace (Map.empty, Just $ T.mapM nameIndivEvent' h `labelWith` labels)  toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (StructuralTrace Unique) toPublic l (Hierarchy hv)

@@ -34,7 +34,7 @@ module Control.Concurrent.CHP.Traces.VCR (VCRTrace(..), getVCRPlain, runCHP_VCRTrace, runCHP_VCRTraceAndPrint) where  import Control.Concurrent.STM-import Control.Monad.State+import Control.Monad (liftM) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Unique@@ -63,13 +63,13 @@   prettyPrint (VCRTrace (labels, eventSets))     = char '<' <+> sep (punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>'     where-      es = evalState (mapM nameVCR eventSets) labels+      es = mapM nameVCR eventSets `labelWith` labels        ropes :: [[Doc]]       ropes = map (map text . Set.toList) es    labelAll (VCRTrace (labels, eventSets))-    = VCRTrace (Map.empty, evalState (mapM nameVCR' eventSets) labels)+    = VCRTrace (Map.empty, mapM nameVCR' eventSets `labelWith` labels)  toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (VCRTrace Unique) toPublic l (VCRTraceRev tv)@@ -77,10 +77,10 @@        return $ VCRTrace (l, map (Set.map snd) $ reverse setList) toPublic _ _ = error "Error in VCR trace -- tracing type got switched" -nameVCR :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set String)+nameVCR :: Ord u => Set.Set (RecordedEvent u) -> LabelM u (Set.Set String) nameVCR = liftM Set.fromList . mapM nameEvent . Set.toList -nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set (RecordedEvent String))+nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> LabelM u (Set.Set (RecordedEvent String)) nameVCR' = liftM Set.fromList . mapM nameEvent' . Set.toList  -- | A helper function for pulling out the interesting bit from a VCR trace processed

@@ -1,5 +1,5 @@ Name:            chp-Version:         2.1.0.1+Version:         2.2.0 Synopsis:        An implementation of concurrency ideas from Communicating Sequential Processes License:         BSD3 License-file:    LICENSE@@ -23,7 +23,7 @@  Cabal-Version:   >= 1.2.3 Build-Type:      Simple-Build-Depends:   base >= 3 && < 5, containers, deepseq >= 1.1 && < 1.2, extensible-exceptions >= 0.1.1.0, loop-while, mtl, pretty, stm+Build-Depends:   base >= 3 && < 5, containers, deepseq >= 1.1 && < 1.2, extensible-exceptions >= 0.1.1.0, pretty, stm  Exposed-modules: Control.Concurrent.CHP                  Control.Concurrent.CHP.Alt@@ -57,7 +57,7 @@                  Control.Concurrent.CHP.ProcessId                  Control.Concurrent.CHP.Traces.Base -Extensions:      BangPatterns CPP FlexibleInstances GeneralizedNewtypeDeriving-                 MultiParamTypeClasses ScopedTypeVariables +Extensions:      BangPatterns CPP FlexibleInstances+                 MultiParamTypeClasses Rank2Types ScopedTypeVariables  GHC-Options:     -Wall -auto-all