chp 1.4.0 → 1.5.0

raw patch · 31 files changed

+2045/−991 lines, 31 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Concurrent/CHP.hs +3/−1
• Control/Concurrent/CHP/Alt.hs +31/−22
• Control/Concurrent/CHP/Arrow.hs +88/−2
• Control/Concurrent/CHP/Barriers.hs +50/−9
• Control/Concurrent/CHP/Base.hs +70/−11
• Control/Concurrent/CHP/BroadcastChannels.hs +6/−266
• Control/Concurrent/CHP/CSP.hs +21/−33
• Control/Concurrent/CHP/Channels.hs +48/−466
• Control/Concurrent/CHP/Channels/Base.hs +183/−0
• Control/Concurrent/CHP/Channels/BroadcastReduce.hs +280/−0
• Control/Concurrent/CHP/Channels/Communication.hs +161/−0
• Control/Concurrent/CHP/Channels/Creation.hs +248/−0
• Control/Concurrent/CHP/Channels/Ends.hs +69/−0
• Control/Concurrent/CHP/Channels/Synonyms.hs +97/−0
• Control/Concurrent/CHP/Clocks.hs +4/−4
• Control/Concurrent/CHP/Common.hs +10/−2
• Control/Concurrent/CHP/Console.hs +5/−1
• Control/Concurrent/CHP/Event.hs +39/−24
• Control/Concurrent/CHP/Guard.hs +6/−4
• Control/Concurrent/CHP/Monad.hs +3/−2
• Control/Concurrent/CHP/Mutex.hs +4/−0
• Control/Concurrent/CHP/Parallel.hs +16/−50
• Control/Concurrent/CHP/Test.hs +207/−13
• Control/Concurrent/CHP/Traces.hs +169/−0
• Control/Concurrent/CHP/Traces/Base.hs +100/−67
• Control/Concurrent/CHP/Traces/CSP.hs +12/−2
• Control/Concurrent/CHP/Traces/Structural.hs +32/−4
• Control/Concurrent/CHP/Traces/TraceOff.hs +13/−3
• Control/Concurrent/CHP/Traces/VCR.hs +11/−2
• Control/Concurrent/CHP/Utils.hs +51/−1
• chp.cabal +8/−2

@@ -30,7 +30,7 @@ -- | This module re-exports the core functionality of the CHP library.  Other -- modules that you also may wish to import are: ----- * "Control.Concurrent.CHP.Action"+-- * "Control.Concurrent.CHP.Actions" --  -- * "Control.Concurrent.CHP.Arrow" --@@ -39,6 +39,8 @@ -- * "Control.Concurrent.CHP.Common" -- -- * "Control.Concurrent.CHP.Console"+--+-- * "Control.Concurrent.CHP.Test" -- -- * "Control.Concurrent.CHP.Traces" --

@@ -103,13 +103,16 @@ -- would). module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>), every, (<&>)) where +import Control.Arrow import Control.Concurrent.STM+import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans 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 @@ -365,7 +368,7 @@         altStuff = liftM concat $ mapM pullOutAltable items  -- Performs the select operation on all the guards, and then executes the body-selectFromGuards :: (Either String [(Guard, TraceT IO (WithPoison a))]) -> TraceT IO (WithPoison a)+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@@ -374,20 +377,25 @@         | null (eventGuards $ map fst both) =            join $ liftM snd $ liftIO $ waitNormalGuards both Nothing         | otherwise =-           do let (guards, bodies) = unzip both+           do let (guards, _bodies) = unzip both                   earliestReady = findIndex isSkipGuard guards-                  recordAndRun _ (Signal PoisonItem)-                    = return PoisonItem-                  recordAndRun m (Signal (NoPoison n))-                    = let (EventGuard rec _ _, body) = both !! n-                      in recordEvent (rec $ makeLookup m) >> body-                  justRun (Signal PoisonItem) = return PoisonItem-                  justRun (Signal (NoPoison n)) = bodies !! n-                  guardsAndSignal :: [(Guard, (SignalValue, Map.Map Unique Integer))]-                  guardsAndSignal = zip guards (zip (map (Signal . NoPoison) [0..]) (repeat Map.empty))+                  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 rec _ _, body) ->+                          NoPoison (rec (makeLookup m), body)+                        (_, body) -> NoPoison ([], body)               tv <- liftIO $ newTVarIO Nothing               pid <- getProcessId-              tr <- get+              tr <- ask               mn <- liftIO . atomically $ do                       ret <- enableEvents tv pid                         (maybe id take earliestReady $ eventGuards guards)@@ -399,15 +407,15 @@                                  Signal PoisonItem -> return ()                                  Signal (NoPoison n) ->                                    let EventGuard _ act _ = guards !! n-                                   in actWhenLast act+                                   in actWhenLast act (Map.fromList $ map (snd *** Set.size) es)                             )                             ret-                      return ret+                      return $ fmap (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-                (Just ((n, m), _), _) -> recordAndRun m n+                (Just 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                 (Nothing, Just _) ->@@ -415,10 +423,10 @@                 -- No events ready, no other guards ready either                 -- Events will have been enabled; wait for everything:                 (Nothing, Nothing) ->-                    do (wasAltingBarrier, (n, m)) <- liftIO $ waitNormalGuards-                         guardsAndSignal $ Just $ waitAlting tv+                    do (wasAltingBarrier, pr) <- liftIO $ waitNormalGuards+                         guardsAndRec $ Just $ liftM getRec $ waitAlting tv                        if wasAltingBarrier-                         then recordAndRun m n -- It was a barrier, all done+                         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@@ -427,18 +435,19 @@                                  $ eventGuards guards)                                case mn' of                                  -- An event overrides our non-event choice:-                                 Just (x, m') -> recordAndRun m' x+                                 Just pr' -> recordAndRun $ getRec pr'                                  -- Go with the original option, no events                                  -- became ready:-                                 Nothing -> justRun n+                                 Nothing -> recordAndRun pr -waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique Integer)+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 -> Unique -> Integer+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:

@@ -60,7 +60,9 @@ -- together a certain class of process network, you should do fine. -- -- Added in version 1.0.2.-module Control.Concurrent.CHP.Arrow (ProcessPipeline, runPipeline, arrowProcess, arrStrict) where+module Control.Concurrent.CHP.Arrow (ProcessPipeline, runPipeline, arrowProcess, arrStrict,+  ProcessPipelineLabel, runPipelineLabel, arrowProcessLabel, arrLabel, arrStrictLabel,+  (*>>>*), (*<<<*), (*&&&*), (*****)) where  -- I have got this module to work on GHC 6.8 and 6.10 by following the CPP-variant -- instructions on this page: http://haskell.org/haskellwiki/Upgrading_packages@@ -81,6 +83,89 @@ import qualified Control.Concurrent.CHP.Common as CHP import Control.Concurrent.CHP.Utils +-- | ProcessPipelineLabel is a version of 'ProcessPipeline' that allows the processes+-- to be labelled, and thus in turn for the channels connecting the processes to+-- be automatically labelled.  ProcessPipelineLabel is not an instance of Arrow,+-- but it does have a lot of similarly named functions for working with it.  This+-- awkwardness is due to the extra Show constraints on the connectors that allow+-- the arrow's contents to appear in traces.+--+-- If you don't use traces, use 'ProcessPipeline'.  If you do use traces, and want+-- to have better labels on the process and values used in your arrows, consider+-- switching to ProcessPipelineLabel.+--+-- ProcessPipelineLabel and all the functions that use it, were added in version+-- 1.5.0.+data ProcessPipelineLabel a b = ProcessPipelineLabel+  { runPipelineLabel :: Chanin a -> Chanout b -> CHP ()+    -- ^ Like 'runPipeline' but for 'ProcessPipelineLabel'+  , _pipelineLabels :: (String, String)+  }++-- | Like 'arrowProcess', but allows the process to be labelled.  The same+-- warnings as 'arrowProcess' apply.+arrowProcessLabel :: String -> (Chanin a -> Chanout b -> CHP ()) -> ProcessPipelineLabel a b+arrowProcessLabel l p = ProcessPipelineLabel p (l, l)++-- | Like 'arr' for 'ProcessPipeline', but allows the process to be labelled.+arrLabel :: String -> (a -> b) -> ProcessPipelineLabel a b+arrLabel l = arrowProcessLabel l . CHP.map++-- | Like 'arrStrict', but allows the process to be labelled.+arrStrictLabel :: NFData b => String -> (a -> b) -> ProcessPipelineLabel a b+arrStrictLabel l = arrowProcessLabel l . CHP.map'++-- | The '(>>>)' arrow combinator, for 'ProcessPipelineLabel'.+(*>>>*) :: Show b => ProcessPipelineLabel a b -> ProcessPipelineLabel b c+  -> ProcessPipelineLabel a c+(*>>>*) (ProcessPipelineLabel p (pl, pr)) (ProcessPipelineLabel q (ql, qr))+  = ProcessPipelineLabel (p |->|^ (pr ++ "->" ++ ql, q)) (pl, qr)++-- | The '(<<<)' arrow combinator, for 'ProcessPipelineLabel'.+(*<<<*) :: Show b => ProcessPipelineLabel b c -> ProcessPipelineLabel a b+  -> ProcessPipelineLabel a c+(*<<<*) = flip (*>>>*)++-- | The '(&&&)' arrow combinator, for 'ProcessPipelineLabel'.+(*&&&*) :: (Show b, Show c, Show c') => ProcessPipelineLabel b c -> ProcessPipelineLabel b c' -> ProcessPipelineLabel b (c, c')+(*&&&*) (ProcessPipelineLabel p (pl, pr))+        (ProcessPipelineLabel q (ql, qr))+  = ProcessPipelineLabel proc (mix pl ql, mix pr qr)+  where+    mix a b = "(" ++ a ++ "*&&&*" ++ b ++ ")"+    proc input output+       = do deltaP <- oneToOneChannel' $ chanLabel $ pl ++ ".in"+            deltaQ <- oneToOneChannel' $ chanLabel $ ql ++ ".in"+            joinP <- oneToOneChannel' $ chanLabel $ pr ++ ".out"+            joinQ <- oneToOneChannel' $ chanLabel $ qr ++ ".out"+            runParallel_+              [CHP.parDelta input (writers [deltaP, deltaQ])+              ,p (reader deltaP) (writer joinP)+              ,q (reader deltaQ) (writer joinQ)+              ,CHP.join (,) (reader joinP) (reader joinQ) output+              ]++-- | The '(***)' arrow combinator, for 'ProcessPipelineLabel'.+(*****) :: (Show b, Show b', Show c, Show c') => ProcessPipelineLabel b c -> ProcessPipelineLabel b' c'+  -> ProcessPipelineLabel (b, b') (c, c')+(*****) (ProcessPipelineLabel p (pl, pr))+        (ProcessPipelineLabel q (ql, qr))+  = ProcessPipelineLabel proc (mix pl ql, mix pr qr)+  where+    mix a b = "(" ++ a ++ "*****" ++ b ++ ")"+    proc input output+       = do deltaP <- oneToOneChannel' $ chanLabel $ mix pl ql ++ "->" ++ pl+            deltaQ <- oneToOneChannel' $ chanLabel $ mix pl ql ++ "->" ++ ql+            joinP <- oneToOneChannel' $ chanLabel $ pr ++ "->" ++ mix pr qr+            joinQ <- oneToOneChannel' $ chanLabel $ qr ++ "->" ++ mix pr qr+            runParallel_+              [CHP.split input (writer deltaP) (writer deltaQ)+              ,p (reader deltaP) (writer joinP)+              ,q (reader deltaQ) (writer joinQ)+              ,CHP.join (,) (reader joinP) (reader joinQ) output+              ]++ -- | The type that is an instance of 'Arrow' for process pipelines.  See 'runPipeline'. data ProcessPipeline a b = ProcessPipeline   { runPipeline :: Chanin a -> Chanout b -> CHP ()@@ -108,7 +193,8 @@ -- Any process you apply this to should produce exactly one output per -- input, or else you will find odd behaviour resulting (including deadlock). --  So for example, /don't/ use @arrowProcess ('Control.Concurrent.CHP.Common.filter'--- ...)@ or @arrowProcess 'Control.Concurrent.CHP.Common.stream'@+-- ...)@ or @arrowProcess 'Control.Concurrent.CHP.Common.stream'@ inside any arrow combinators+-- other than >>> and <<<. -- -- Added in version 1.1.0 arrowProcess :: (Chanin a -> Chanout b -> CHP ()) -> ProcessPipeline a b

@@ -65,7 +65,8 @@ -- on. module Control.Concurrent.CHP.Barriers (Barrier, EnrolledBarrier, newBarrier, newBarrierWithLabel,   PhasedBarrier, newPhasedBarrier, newPhasedBarrierWithLabel, newPhasedBarrierCustomInc,-    newPhasedBarrierWithLabelCustomInc, currentPhase, waitForPhase,+    newPhasedBarrierCustomShowInc, newPhasedBarrierWithLabelCustomInc,+    newPhasedBarrierWithLabelCustomShowInc, currentPhase, waitForPhase,     syncBarrier, getBarrierIdentifier) where  import Control.Concurrent.STM@@ -91,7 +92,7 @@ -- | Synchronises on the given barrier.  You must be enrolled on a barrier in order -- to synchronise on it.  Returns the new phase, following the synchronisation. syncBarrier :: Enrolled PhasedBarrier phase -> CHP phase-syncBarrier = syncBarrierWith (indivRecJust BarrierSyncIndiv)+syncBarrier = syncBarrierWith (indivRecJust BarrierSyncIndiv) (const $ return ())      -- | Finds out the current phase a barrier is on. currentPhase :: Enrolled PhasedBarrier phase -> CHP phase@@ -112,13 +113,18 @@ newBarrier :: CHP Barrier newBarrier = newPhasedBarrier () +newBarrierEvent :: (phase -> String) -> TVar phase -> IO Event+newBarrierEvent sh tv = newEvent (liftM (BarrierSync . sh) $ readTVar tv) 0+ -- | Creates a new barrier with no processes enrolled, that will be on the -- given phase.  You will often want to pass in the last value in your phase -- cycle, so that the first synchronisation moves it on to the first-newPhasedBarrier :: (Enum phase, Bounded phase, Eq phase) => phase -> CHP (PhasedBarrier phase)+--+-- The Show constraint was added in version 1.5.0+newPhasedBarrier :: (Enum phase, Bounded phase, Eq phase, Show phase) => phase -> CHP (PhasedBarrier phase) newPhasedBarrier ph = liftPoison $ liftTrace $ do-  e <- liftIO $ newEvent BarrierSync 0   tv <- liftIO $ atomically $ newTVar ph+  e <- liftIO $ newBarrierEvent show tv    return $ Barrier (e, tv, \p -> if p == maxBound then minBound else succ p)  -- | Creates a new barrier with no processes enrolled, that will be on the@@ -127,13 +133,32 @@ -- function) to get a barrier that never cycles.  You can also do things like supplying -- (+2) as the incrementing function, or even using lists as the phase type to -- do crazy things.+--+-- Note that the phase will not show up in the traces -- see+-- 'newPhasedBarrierCustomShowInc' for that. newPhasedBarrierCustomInc :: (phase -> phase) -> phase -> CHP (PhasedBarrier phase) newPhasedBarrierCustomInc f ph = liftPoison $ liftTrace $ do-  e <- liftIO $ newEvent BarrierSync 0   tv <- liftIO $ atomically $ newTVar ph+  e <- liftIO $ newBarrierEvent (const "") tv   return $ Barrier (e, tv, f) +-- | Creates a new barrier with no processes enrolled, that will be on the+-- given phase, along with a custom function to show the phase in traces and to+-- increment the phase.  You can therefore+-- use this function with Integer as the inner type (and succ or (+1) as the incrementing+-- function, and show as the showing function) to get a barrier that never cycles.  You can also do things like supplying+-- (+2) as the incrementing function, or even using lists as the phase type to+-- do crazy things.+--+-- This function was added in version 1.5.0.+newPhasedBarrierCustomShowInc :: (phase -> String) -> (phase -> phase) -> phase -> CHP (PhasedBarrier phase)+newPhasedBarrierCustomShowInc sh f ph = liftPoison $ liftTrace $ do+  tv <- liftIO $ atomically $ newTVar ph+  e <- liftIO $ newBarrierEvent sh tv+  return $ Barrier (e, tv, f) ++ -- | Creates a new barrier with no processes enrolled and labels it in traces -- using the given label.  See 'newBarrier'. newBarrierWithLabel :: String -> CHP Barrier@@ -141,20 +166,36 @@  -- | Creates a new barrier with no processes enrolled and labels it in traces -- using the given label.  See 'newPhasedBarrier'.-newPhasedBarrierWithLabel :: (Enum phase, Bounded phase, Eq phase) => String -> phase -> CHP (PhasedBarrier phase)+--+-- The Show constraint was added in version 1.5.0.+newPhasedBarrierWithLabel :: (Enum phase, Bounded phase, Eq phase, Show phase) => String -> phase -> CHP (PhasedBarrier phase) newPhasedBarrierWithLabel l ph = liftPoison $ liftTrace $ do-  e <- liftIO $ newEvent BarrierSync 0-  labelEvent e l   tv <- liftIO $ atomically $ newTVar ph+  e <- liftIO $ newBarrierEvent show tv+  labelEvent e l   return $ Barrier (e, tv, \p -> if p == maxBound then minBound else succ p)  -- | Creates a new barrier with no processes enrolled and labels it in traces -- using the given label.  See 'newPhasedBarrierCustomInc'.+--+-- Note that the barrier will not record the phase in the traces -- see+-- 'newPhasedBarrierWithLabelCustomShowInc' for that. newPhasedBarrierWithLabelCustomInc :: String -> (phase -> phase) -> phase -> CHP (PhasedBarrier phase) newPhasedBarrierWithLabelCustomInc l f ph = liftPoison $ liftTrace $ do-  e <- liftIO $ newEvent BarrierSync 0+  tv <- liftIO $ atomically $ newTVar ph+  e <- liftIO $ newBarrierEvent (const "") tv   labelEvent e l+  return $ Barrier (e, tv, f)++-- | Creates a new barrier with no processes enrolled and labels it in traces+-- using the given label and given show function for the phase.  See 'newPhasedBarrierWithLabelCustomInc'.+--+-- This function was added in version 1.5.0.+newPhasedBarrierWithLabelCustomShowInc :: String -> (phase -> String) -> (phase -> phase) -> phase -> CHP (PhasedBarrier phase)+newPhasedBarrierWithLabelCustomShowInc l sh f ph = liftPoison $ liftTrace $ do   tv <- liftIO $ atomically $ newTVar ph+  e <- liftIO $ newBarrierEvent sh tv+  labelEvent e l   return $ Barrier (e, tv, f)  

@@ -36,6 +36,7 @@ import Control.Applicative import Control.Arrow import Control.Concurrent.STM+import qualified Control.Exception.Extensible as C import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State@@ -43,6 +44,7 @@ import Control.Monad.Trans import qualified Data.Map as Map import Data.Unique+import System.IO import qualified Text.PrettyPrint.HughesPJ  import Control.Concurrent.CHP.Guard@@ -189,27 +191,84 @@ liftSTM = liftIO . atomically  getProcessId :: TraceT IO ProcessId-getProcessId = do x <- get+getProcessId = do x <- ask                   case x of                     Trace (pid,_,_) -> return pid-                    NoTrace -> return emptyProcessId+                    NoTrace pid -> return pid -runCHPProgramWith :: TraceStore -> (TraceStore -> t) -> CHP a -> IO (Maybe a, t)-runCHPProgramWith start f (PoisonT p)-  = do (x, t) <- runStateT (liftM (either (const Nothing) Just) $ pullOutStandard $ runErrorT p) start-       return (x, f t)+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 -runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> SubTraceStore -> IO t) -> CHP a -> IO (Maybe a, t)+    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+    --run m = runStateT ({-liftM (either (const Nothing) Just) $ -} pullOutStandard m) start++runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> IO t) -> CHP a -> IO (Maybe a, t) runCHPProgramWith' subStart f p   = do tv <- atomically $ newTVar Map.empty-       (x, Trace (_,_,t)) <- runCHPProgramWith-                                (Trace (rootProcessId, tv, subStart))-                                id p+       x <- runCHPProgramWith (Trace (rootProcessId, tv, subStart)) p --                             `C.catch` const (return (Nothing, --                               Trace (undefined, undefined, subStart)))        l <- atomically $ readTVar tv-       t' <- f l t+       t' <- f l        return (x, t')++newtype ManyToOneTVar a = ManyToOneTVar (TVar a, TVar (Maybe a))+  deriving Eq++newManyToOneTVar :: a -> STM (ManyToOneTVar a)+newManyToOneTVar x+  = do tvInter <- newTVar x+       tvFinal <- newTVar Nothing+       return $ ManyToOneTVar (tvInter, tvFinal)++writeManyToOneTVar :: (a -> Bool, STM a) -> (a -> a) -> ManyToOneTVar a -> STM a+writeManyToOneTVar (done, reset) f (ManyToOneTVar (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 (_tvInter, tvFinal))+  = do x <- readTVar tvFinal >>= maybe retry return+       writeTVar tvFinal Nothing+       return x++resetManyToOneTVar :: ManyToOneTVar a -> a -> STM ()+resetManyToOneTVar (ManyToOneTVar (tvInter, tvFinal)) x+  = writeTVar tvInter x >> writeTVar tvFinal Nothing  -- ========== -- Instances: 

@@ -1,5 +1,5 @@ -- Communicating Haskell Processes.--- Copyright (c) 2008, University of Kent.+-- Copyright (c) 2008--2009, University of Kent. -- All rights reserved. --  -- Redistribution and use in source and binary forms, with or without@@ -27,269 +27,9 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- | A module containing broadcast channels (one-to-many).  Whereas a one-to-any--- channel features one writer sending a /single/ value to /one/ (of many) readers, a--- one-to-many channel features one writer sending the /same/ value to /many/--- readers.  So a one-to-any channel involves claiming the channel-end to ensure--- exclusivity, but a one-to-many channel involves enrolling on the channel-end--- (subscribing) before it can engage in communication.------ A communication on a one-to-many channel only takes place when the writer--- and all readers currently enrolled agree to communicate.  What happens when--- the writer wants to communicate and no readers are enrolled is undefined--- (the writer may block, or may communicate happily to no-one).------ This module also contains reduce channels (added in version 1.1.1).  Because--- in CHP channels must have the same type at both ends, we use the Monoid--- type-class.  It is important to be aware that the order of mappends will be--- non-deterministic, and thus you should either use an mappend that is commutative--- or code around this restruction.------ For example, a common thing to do would be to use lists as the type for--- reduce channels, make each writer write a single item list (but more is--- possible), then use the list afterwards, but be aware that it is unordered.---  If it is important to have an ordered list, make each writer write a pair--- containing a (unique) index value and the real data, then sort by the index--- value and discard it.------ Since reduce channels were added after the initial library design, there--- is a slight complication: it is not possible to use newChannel (and all--- similar functions) with reduce channels because it is impossible to express--- the Monoid constraint for the Channel instance.  Instead, you must use manyToOneChannel--- and manyToAnyChannel.-module Control.Concurrent.CHP.BroadcastChannels (BroadcastChanin, BroadcastChanout,-  OneToManyChannel, AnyToManyChannel, oneToManyChannel, anyToManyChannel,-    oneToManyChannelWithLabel, anyToManyChannelWithLabel, ReduceChanin,-    ReduceChanout, sameReduceChannel, ManyToOneChannel, ManyToAnyChannel, manyToOneChannel,-    manyToAnyChannel, manyToOneChannelWithLabel, manyToAnyChannelWithLabel)-      where--import Control.Concurrent.STM-import Control.Monad.Trans-import Data.Monoid--import Control.Concurrent.CHP.Barriers-import Control.Concurrent.CHP.Base-import Control.Concurrent.CHP.Channels-import Control.Concurrent.CHP.CSP-import Control.Concurrent.CHP.Enroll-import Control.Concurrent.CHP.Event-import Control.Concurrent.CHP.Mutex-import Control.Concurrent.CHP.Traces.Base----- The general pattern of a broadcast channel is as follows:--- SYNC -> Agreement; the readers indicate they are all willing to read, and the--- writer indicates it is ready to write.  Either side may ALT.------ After this synchronisation, the writer can write his data to the TVar, possibly--- following an extended action--- --- SYNC -> Reading; everyone syncs (no-one ALTs) to move to the reading phase------ After this synchronisation, the readers can all read the data from the TVar,--- and possibly complete an extended action------ SYNC -> Neutral; everyone syncs (no-one ALTs) to indicate one communication--- cycle has finished.  After this the writer may proceed on their way (the--- main reason for needing a third sync).---- There used to be a warning that the first two constructors are never used, but they--- do need to be there for the Enum and Bounded instances...-data Phase = Agreement | Reading | Neutral deriving (Enum, Bounded, Eq)--- So I constructed this horrendous hack to suppress the warning:-dontWarnMe :: a -> a-dontWarnMe = flip const [Agreement, Reading, Neutral]---- | The Eq instance was added in version 1.4.0.-newtype BroadcastChannel a = BC (PhasedBarrier Phase, TVar a)--instance Eq (BroadcastChannel a) where-  (BC (_, tvX)) == (BC (_, tvY)) = tvX == tvY---- | The reading end of a broadcast channel.  You must enroll on it before--- you can read from it or poison it.--- --- The Eq instance was added in version 1.4.0.-newtype BroadcastChanin a = BI (BroadcastChannel a) deriving (Eq)---- | The writing end of a broadcast channel.--- --- The Eq instance was added in version 1.4.0.-newtype BroadcastChanout a = BO (BroadcastChannel a) deriving (Eq)--instance Enrollable BroadcastChanin a where-  enroll c@(BI (BC (b,_))) f = enroll b (\eb -> waitForPhase Neutral eb >> f (Enrolled c))-  resign (Enrolled (BI (BC (b,_)))) m-    = do x <- resign (Enrolled b) m-         waitForPhase Neutral (Enrolled b)-         return x--instance WriteableChannel BroadcastChanout where-  extWriteChannel' (BO (BC (b, tv))) m-    = do syncBarrierWith (indivRecJust ChannelWrite)-           $ Enrolled b-         (x, r) <- m-         liftIO . atomically $ writeTVar tv x-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         return r--instance ReadableChannel (Enrolled BroadcastChanin) where-  extReadChannel (Enrolled (BI (BC (b, tv)))) f-    = do syncBarrierWith (indivRecJust ChannelRead)-           $ Enrolled b-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         x <- liftIO (atomically $ readTVar tv)-         y <- f x-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         return y--instance Poisonable (BroadcastChanout a) where-  poison (BO (BC (b,_))) = poison $ Enrolled b-  checkForPoison (BO (BC (b,_))) = checkForPoison $ Enrolled b--instance Poisonable (Enrolled BroadcastChanin a) where-  poison (Enrolled (BI (BC (b,_)))) = poison $ Enrolled b-  checkForPoison (Enrolled (BI (BC (b,_)))) = checkForPoison $ Enrolled b--newBroadcastChannel :: CHP (BroadcastChannel a)-newBroadcastChannel = dontWarnMe {- see above -} $ do-    do b@(Barrier (e, _, _)) <- newPhasedBarrier Neutral-       -- Writer is always enrolled:-       liftIO $ atomically $ enrollEvent e-       tv <- liftIO $ atomically $ newTVar undefined-       return $ BC (b, tv)--instance Channel BroadcastChanin BroadcastChanout where-  newChannel = liftCHP $ do-    c@(BC (b,_)) <- newBroadcastChannel-    return $ Chan (getBarrierIdentifier b) (BI c) (BO c)-  sameChannel (BI x) (BO y) = x == y--instance Channel BroadcastChanin (Shared BroadcastChanout) where-  newChannel = liftCHP $ do-    m <- newMutex-    c <- newChannel-    return $ Chan (getChannelIdentifier c) (reader c) (Shared (m, writer c))-  sameChannel (BI x) (Shared (_, BO y)) = x == y--type OneToManyChannel = Chan BroadcastChanin BroadcastChanout-type AnyToManyChannel = Chan BroadcastChanin (Shared BroadcastChanout)--oneToManyChannel :: MonadCHP m => m (OneToManyChannel a)-oneToManyChannel = newChannel--anyToManyChannel :: MonadCHP m => m (AnyToManyChannel a)-anyToManyChannel = newChannel---- | Added in version 1.2.0.-oneToManyChannelWithLabel :: MonadCHP m => String -> m (OneToManyChannel a)-oneToManyChannelWithLabel = newChannelWithLabel---- | Added in version 1.2.0.-anyToManyChannelWithLabel :: MonadCHP m => String -> m (AnyToManyChannel a)-anyToManyChannelWithLabel = newChannelWithLabel----- | The Eq instance was added in version 1.4.0.-newtype ReduceChannel a = GC (PhasedBarrier Phase, TVar a, (a -> a -> a, a))--instance Eq (ReduceChannel a) where-  (GC (_, tvX, _)) == (GC (_, tvY, _)) = tvX == tvY---- | The reading end of a reduce channel.------ The Eq instance was added in version 1.4.0.-newtype ReduceChanin a = GI (ReduceChannel a) deriving (Eq)---- | The writing end of a reduce channel.  You must enroll on it before--- you can read from it or poison it.------ The Eq instance was added in version 1.4.0.-newtype ReduceChanout a = GO (ReduceChannel a) deriving (Eq)--instance Enrollable ReduceChanout a where-  enroll c@(GO (GC (b,_,_))) f = enroll b (\eb -> waitForPhase Neutral eb >> f (Enrolled c))-  resign (Enrolled (GO (GC (b,_,_)))) m-    = do x <- resign (Enrolled b) m-         waitForPhase Neutral (Enrolled b)-         return x--instance WriteableChannel (Enrolled ReduceChanout) where-  extWriteChannel' (Enrolled (GO (GC (b, tv, (f,_))))) m-    = do syncBarrierWith (indivRecJust ChannelWrite)-           $ Enrolled b-         (x, r) <- m-         liftIO . atomically $ readTVar tv >>= writeTVar tv . f x-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         return r--instance ReadableChannel ReduceChanin where-  extReadChannel (GI (GC (b, tv, (_, empty)))) f-    = do syncBarrierWith (indivRecJust ChannelRead)-           $ Enrolled b-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         x <- liftIO (atomically $ readTVar tv)-         y <- f x-         liftIO (atomically $ writeTVar tv empty)-         syncBarrierWith (const $ const Nothing)-           $ Enrolled b-         return y--instance Poisonable (Enrolled ReduceChanout a) where-  poison (Enrolled (GO (GC (b,_,_)))) = poison $ Enrolled b-  checkForPoison (Enrolled (GO (GC (b,_,_)))) = checkForPoison $ Enrolled b--instance Poisonable (ReduceChanin a) where-  poison (GI (GC (b,_,_))) = poison $ Enrolled b-  checkForPoison (GI (GC (b,_,_))) = checkForPoison $ Enrolled b--newReduceChannel :: Monoid a => CHP (ReduceChannel a)-newReduceChannel = dontWarnMe {- see above -} $ do-    do b@(Barrier (e, _, _)) <- newPhasedBarrier Neutral-       -- Writer is always enrolled:-       liftIO $ atomically $ enrollEvent e-       tv <- liftIO $ atomically $ newTVar mempty-       return $ GC (b, tv, (mappend, mempty))---- | The reduce channel version of sameChannel.--- --- This function was added in version 1.4.0.-sameReduceChannel :: ReduceChanin a -> ReduceChanout a -> Bool-sameReduceChannel (GI x) (GO y) = x == y--type ManyToOneChannel = Chan ReduceChanin ReduceChanout-type ManyToAnyChannel = Chan (Shared ReduceChanin) ReduceChanout--manyToOneChannel :: (Monoid a, MonadCHP m) => m (ManyToOneChannel a)-manyToOneChannel = do-    c@(GC (b,_,_)) <- liftCHP newReduceChannel-    return $ Chan (getBarrierIdentifier b) (GI c) (GO c)---manyToAnyChannel :: (Monoid a, MonadCHP m) => m (ManyToAnyChannel a)-manyToAnyChannel = do-    m <- newMutex-    c <- manyToOneChannel-    return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (writer c)--manyToOneChannelWithLabel :: (Monoid a, MonadCHP m) => String -> m (ManyToOneChannel a)-manyToOneChannelWithLabel l-  = do c <- manyToOneChannel-       liftCHP . liftPoison . liftTrace $ labelUnique (getChannelIdentifier c) l-       return c+-- | Since version 1.5.0, this module is a synonym for the "Control.Concurrent.CHP.Channels.BroadcastReduce"+-- module, and is liable to be removed in a future version.+module Control.Concurrent.CHP.BroadcastChannels+  (module Control.Concurrent.CHP.Channels.BroadcastReduce) where -manyToAnyChannelWithLabel :: (Monoid a, MonadCHP m) => String -> m (ManyToAnyChannel a)-manyToAnyChannelWithLabel l-  = do c <- manyToAnyChannel-       liftCHP . liftPoison . liftTrace $ labelUnique (getChannelIdentifier c) l-       return c+import Control.Concurrent.CHP.Channels.BroadcastReduce

@@ -34,11 +34,11 @@  import Control.Concurrent.STM import Control.Exception-import Control.Monad.State+import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Trans import Data.List-import Data.Maybe+import qualified Data.Map as Map import Data.Unique import System.IO @@ -47,41 +47,43 @@ import qualified Control.Concurrent.CHP.Event as Event import Control.Concurrent.CHP.Enroll import Control.Concurrent.CHP.Guard-import Control.Concurrent.CHP.Mutex 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) -> Maybe (RecordedIndivEvent Unique)) -> Event.Event -> EventActions -> CHP a -> CHP a+buildOnEventPoison :: (Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique]) -> Event.Event -> EventActions -> CHP a -> CHP a buildOnEventPoison rec 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 (maybeToList . rec (Event.getEventUnique e)) act [e]+      theGuard = EventGuard (rec (Event.getEventUnique e)) act [e]  scopeBlock :: CHP a -> (a -> CHP b) -> IO () -> CHP b scopeBlock start body errorEnd     = do x <- start-         tr <- liftPoison $ liftTrace get-         (y, tr') <- liftIO $ bracketOnError (return ()) (const errorEnd) $ const-           $ runStateT (pullOutStandard (wrapPoison $ body x)) tr-         liftPoison $ liftTrace $ put tr'+         tr <- liftPoison $ liftTrace ask+         y <- liftIO $ bracketOnError (return ()) (const errorEnd) $ const+           $ runReaderT (pullOutStandard (wrapPoison $ body x)) tr          checkPoison y +wrapIndiv :: (Unique -> (Unique -> Integer) -> String -> [RecordedIndivEvent Unique])+          -> Unique -> (Unique -> (Integer, Event.RecordedEventType))+          -> [RecordedIndivEvent Unique]+wrapIndiv rec u lu = rec u (fst . lu) (Event.getEventTypeVal $ snd $ lu u)  -- | Synchronises on the given barrier.  You must be enrolled on a barrier in order -- to synchronise on it.  Returns the new phase, following the synchronisation.-syncBarrierWith :: (Unique -> (Unique -> Integer) -> Maybe (RecordedIndivEvent Unique))-  -> Enrolled PhasedBarrier phase -> CHP phase-syncBarrierWith rec (Enrolled (Barrier (e,tv, fph)))-    = buildOnEventPoison rec e (EventActions incPhase (return ()))+syncBarrierWith :: (Unique -> (Unique -> Integer) -> String -> [RecordedIndivEvent Unique])+  -> (Int -> STM ()) -> Enrolled PhasedBarrier phase -> CHP phase+syncBarrierWith rec storeN (Enrolled (Barrier (e,tv, fph)))+    = buildOnEventPoison (wrapIndiv rec) e (EventActions incPhase (return ()))         (liftIO $ atomically $ readTVar tv)     where-      incPhase :: STM ()-      incPhase = do p <- readTVar tv-                    writeTVar tv $ fph p+      incPhase :: Map.Map Unique Int -> STM ()+      incPhase m = do readTVar tv >>= writeTVar tv . fph+                      maybe (return ()) storeN $ Map.lookup (Event.getEventUnique e) m  -- | A phased barrier that is capable of being poisoned and throwing poison. --  You will need to enroll on it to do anything useful with it.@@ -113,37 +115,23 @@     = do liftSTM (Event.enrollEvent e) >>= checkPoison          x <- f $ Enrolled b          liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->-           do tr <- liftPoison $ liftTrace get+           do tr <- liftPoison $ liftTrace ask               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 get+           do tr <- liftPoison $ liftTrace ask               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)          x <- m          liftSTM (Event.enrollEvent e) >>= checkPoison          return x ---- | A channel type, that can be used to get the ends of the channel via 'reader'--- and 'writer'-data Chan r w a = Chan {-  -- | Gets the channel's identifier.  Useful if you need to be able to identify-  -- a channel in the trace later on.-  getChannelIdentifier :: Unique,-  -- | Gets the reading end of a channel from its 'Chan' type.-  reader :: r a,-  -- | Gets the writing end of a channel from its 'Chan' type.-  writer :: w a}- instance Poisonable (Enrolled PhasedBarrier phase) where   poison (Enrolled (Barrier (e, _, _)))     = liftSTM $ Event.poisonEvent e   checkForPoison (Enrolled (Barrier (e, _, _)))     = liftCHP $ liftSTM (Event.checkEventForPoison e) >>= checkPoison --- | A wrapper (usually around a channel-end) indicating that the inner item--- is shared.  Use the 'claim' function to use this type.-data Shared c a = Shared (Mutex, c a)+ 

@@ -1,5 +1,5 @@ -- Communicating Haskell Processes.--- Copyright (c) 2008, University of Kent.+-- Copyright (c) 2008--2009, University of Kent. -- All rights reserved. --  -- Redistribution and use in source and binary forms, with or without@@ -28,483 +28,65 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  --- | The module containing all the different types of channels in CHP.  Unlike--- JCSP and C++CSP2, CHP does not offer buffered channels directly (see the--- "Control.Concurrent.CHP.Buffers" module).  There are four different channel types, effectively--- all possible combinations of:+-- | The module containing all the different types of channels in CHP.+-- +-- A communication in CHP is always synchronised: the writer must wait until the+-- reader arrives to take the data.  There is thus no automatic or underlying buffering+-- of data.  (If you want to use buffers, see the "Control.Concurrent.CHP.Buffers"+-- module). ----- * Shared reader vs non-shared reader+-- If it helps, a channel communication can be thought of as a distributed binding.+--  Imagine you have a process that creates a channel and then becomes the parallel+-- composition of two sub-processes that at some point communicate on that channel+-- (formatted here as two columns for illustration): ----- * Shared writer vs non-shared writer+-- > do                      c <- oneToOneChannel+-- >                                    (<||>)+-- >    do p                                   do p'+-- >       q                                      y <- q'+-- >       x <- readChannel (reader c)            writeChannel (writer c) y+-- >       r                                      r'+-- >       s x                                    s' ----- For most applications you probably want just 'OneToOneChannel'.+-- It is as if, at the point where the two processes want to communicate, they come+-- together and directly bind the value from one process in the other:+-- +-- > do                      c <- oneToOneChannel+-- >                                    (<||>)+-- >    do p                                   do p'+-- >       q                                      y <- q'+-- >       x                            <-        return y+-- >       r                                      r'+-- >       s x                                    s' ----- It is possible for the type system to infer which channel you want when--- you use 'newChannel'.  If the types of the ends are known by the type system,--- the channel-type can be inferred.  So you can usually just write 'newChannel',--- and depending on how you use the channel, the type system will figure out--- which one you needed.+-- The "Control.Concurrent.CHP.Channels.Creation" contains functions relating to+-- the creation of channels.  Channels are used via their ends -- see the "Control.Concurrent.CHP.Channels.Ends"+-- module, and the "Control.Concurrent.CHP.Channels.Communication" module.+--+-- Broadcast and reduce channels are available in the "Control.Concurrent.CHP.Channels.BroadcastReduce"+-- module, which is not automatically re-exported here.+-- +-- This module was split into several smaller modules in version 1.5.0.  Since+-- it re-exports all the new modules, your code should not be affected at all. module Control.Concurrent.CHP.Channels (-  -- * Channel Creation-  Chan, Channel(..), writeChannelStrict, newChannelWithLabel, newChannelWR, newChannelRW, ChannelTuple(..),-  newChannelList, newChannelListWithLabels, newChannelListWithStem,+  -- * Channel Creation and Types+  module Control.Concurrent.CHP.Channels.Creation,   getChannelIdentifier,   -- * Channel-Ends-  Chanin, Chanout,-  reader, writer, readers, writers,+  module Control.Concurrent.CHP.Channels.Ends,    -- * Reading and Writing with Channels-  ReadableChannel(..), WriteableChannel(..), +  module Control.Concurrent.CHP.Channels.Communication, -  -- * Shared Channels-  claim, Shared,+  -- * Useful Type and Function Synonyms+  module Control.Concurrent.CHP.Channels.Synonyms -  -- * Specific Channel Types-  -- | All the functions here are equivalent to newChannel (or newChannelWithLabel), but typed.  So for-  -- example, @oneToOneChannel = newChannel :: MonadCHP m => m OneToOneChannel@.-  OneToOneChannel, oneToOneChannel, oneToOneChannelWithLabel,-  OneToAnyChannel, oneToAnyChannel, oneToAnyChannelWithLabel,-  AnyToOneChannel, anyToOneChannel, anyToOneChannelWithLabel,-  AnyToAnyChannel, anyToAnyChannel, anyToAnyChannelWithLabel   )   where  -import Control.Concurrent.STM.TVar-import Control.Monad-import Control.Monad.STM-import Control.Monad.Trans-import Control.Parallel.Strategies-import Data.Maybe-import Data.Monoid-import Data.Unique--import Control.Concurrent.CHP.Base-import Control.Concurrent.CHP.CSP-import Control.Concurrent.CHP.Event-import Control.Concurrent.CHP.Guard-import Control.Concurrent.CHP.Monad-import Control.Concurrent.CHP.Mutex-import Control.Concurrent.CHP.Poison-import Control.Concurrent.CHP.Traces.Base---- ======--- Types:--- ======---- | A reading channel-end type that allows poison to be thrown------ Eq instance added in version 1.1.1-newtype Chanin a = Chanin (STMChannel a) deriving Eq---- | A writing channel-end type that allows poison to be thrown------ Eq instance added in version 1.1.1-newtype Chanout a = Chanout (STMChannel a) deriving Eq--newtype STMChannel a = STMChan (Event, TVar (WithPoison (Maybe a, Maybe ()))) deriving-  Eq--type OneToOneChannel = Chan Chanin Chanout-type AnyToOneChannel = Chan (Chanin) (Shared Chanout)-type OneToAnyChannel = Chan (Shared Chanin) (Chanout)-type AnyToAnyChannel = Chan (Shared Chanin) (Shared Chanout)---- ========--- Classes:--- ========--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 ())---- | A class used for allocating new channels, and getting the reading and--- writing ends.  There is a bijective assocation between the channel, and--- its pair of end types.  You can see the types in the list of instances below.--- Thus, 'newChannel' may be used, and the compiler will infer which type of--- channel is required based on what end-types you get from 'reader' and 'writer'.--- Alternatively, if you explicitly type the return of 'newChannel', it will--- be definite which ends you will use.  If you do want to fix the type of--- the channel you are using when you allocate it, consider using one of the--- many 'oneToOneChannel'-like shorthand functions that fix the type.-class Channel r w where-  -- | Allocates a new channel.  Nothing need be done to-  -- destroy\/de-allocate the channel when it is no longer in use.-  newChannel :: MonadCHP m => m (Chan r w a)--  -- | Determines if two channel-ends refer to the same channel.-  ---  -- This function was added in version 1.4.0.-  sameChannel :: r a -> w a -> Bool---- | A class indicating that a channel can be read from.-class ReadableChannel chanEnd where -- minimal implementation: extReadChannel-  -- | Reads from the given reading channel-end-  readChannel :: chanEnd a -> CHP a-  readChannel c = extReadChannel c return-  -- | Performs an extended read from the channel, performing the given action-  -- before freeing the writer-  extReadChannel :: chanEnd a -> (a -> CHP b) -> CHP b---- | A class indicating that a channel can be written to.-class WriteableChannel chanEnd where -- minimal implementation: extWriteChannel-  -- | Writes from the given writing channel-end-  writeChannel :: chanEnd a -> a -> CHP ()-  writeChannel c x = extWriteChannel c (return x) >> return ()--  -- | Starts the communication, then performs the given extended action, then-  -- sends the result of that down the channel.-  extWriteChannel :: chanEnd a -> CHP a -> CHP ()-  extWriteChannel c m = extWriteChannel' c (liftM (flip (,) ()) m)--  -- | Like extWriteChannel, but allows a value to be returned from the inner action.-  ---  -- This function was added in version 1.4.0.-  extWriteChannel' :: chanEnd a -> CHP (a, b) -> CHP b-  ---- | 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---- ==========--- Functions: --- ==========---- | A helper function that uses the parallel strategies library (see the--- paper: \"Algorithm + Strategy = Parallelism\", P.W. Trinder et al, JFP--- 8(1) 1998,--- <http://www.macs.hw.ac.uk/~dsg/gph/papers/html/Strategies/strategies.html>)--- to make sure that the value sent down a channel is strictly evaluated--- by the sender before transmission.------ This is useful when you want to write worker processes that evaluate data---  and send it back to some \"harvester\" process.  By default the values sent--- back may be unevaluated, and thus the harvester might end up doing the evaluation.---  If you use this function, the value is guaranteed to be completely evaluated--- before sending.------ Added in version 1.0.2.-writeChannelStrict :: (NFData a, WriteableChannel chanEnd) => chanEnd a -> a -> CHP ()-writeChannelStrict c x = (writeChannel c $| rnf) x--chan :: Monad m => m (Unique, c a) -> (c a -> r a) -> (c a -> w a) -> m (Chan r w a)-chan m r w = do (u, x) <- m-                return $ Chan u (r x) (w x)---- | Like 'newChannel' but also associates a label with that channel in a--- trace.  You can use this function whether tracing is turned on or not,--- so if you ever use tracing, you should use this rather than 'newChannel'.-newChannelWithLabel :: (Channel r w, MonadCHP m) => String -> m (Chan r w a)-newChannelWithLabel l-  = do c <- newChannel-       liftCHP . liftPoison . liftTrace $ labelUnique (getChannelIdentifier c) l-       return c----- | 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)-newChannelRW = do c <- newChannel-                  return (reader c, writer c)---- | A helper that is like 'newChannel' but returns the writing and reading--- end of the channels directly.-newChannelWR :: (Channel r w, MonadCHP m) => m (w a, r a)-newChannelWR = do c <- newChannel-                  return (writer c, reader c)---- | Creates a list of channels of the same type with the given length.  If--- you need to access some channels by index, use this function.  Otherwise--- you may find using 'newChannels' to be easier.-newChannelList :: (Channel r w, MonadCHP m) => Int -> m [Chan r w a]-newChannelList n = replicateM n newChannel---- | A helper that is like 'newChannelList', but labels the channels according--- to a pattern.  Given a stem such as foo, it names the channels in the list--- foo0, foo1, foo2, etc.-newChannelListWithStem :: (Channel r w, MonadCHP m) => Int -> String -> m [Chan r w a]-newChannelListWithStem n s = sequence [newChannelWithLabel (s ++ show i) | i <- [0 .. (n - 1)]]---- | A helper that is like 'newChannelList', but labels the channels with the--- given list.  The number of channels returned is the same as the length of--- the list of labels-newChannelListWithLabels :: (Channel r w, MonadCHP m) => [String] -> m [Chan r w a]-newChannelListWithLabels = mapM newChannelWithLabel---- | Gets all the reading ends of a list of channels.  A shorthand for @map--- reader@.-readers :: [Chan r w a] -> [r a]-readers = map reader---- | Gets all the writing ends of a list of channels.  A shorthand for @map--- writer@.-writers :: [Chan r w a] -> [w a]-writers = map writer--stmChannel :: MonadIO m => m (Unique, STMChannel a)-stmChannel = liftIO $-  do e <- newEvent ChannelComm 2-     c <- atomically $ newTVar $ NoPoison (Nothing, Nothing)-     return (getEventUnique e, STMChan (e,c))---- | A type-constrained version of newChannel.-oneToOneChannel :: MonadCHP m => m (OneToOneChannel a)-oneToOneChannel = newChannel---- | A type-constrained version of newChannelWithLabel.------ Added in version 1.2.0.-oneToOneChannelWithLabel :: MonadCHP m => String -> m (OneToOneChannel a)-oneToOneChannelWithLabel = newChannelWithLabel----- | Claims the given channel-end, executes the given block, then releases--- the channel-end and returns the output value.  If poison or an IO--- exception is thrown inside the block, the channel is released and the--- poison\/exception re-thrown.-claim :: Shared c a -> (c a -> CHP b) -> CHP b-claim (Shared (lock, c)) body-  = scopeBlock-       (claimMutex lock >> return c)-       (\y -> do x <- body y-                 liftIO $ releaseMutex lock-                 return x)-       (releaseMutex lock)---- | A type-constrained version of newChannel.-anyToOneChannel :: MonadCHP m => m (AnyToOneChannel a)-anyToOneChannel = newChannel---- | A type-constrained version of newChannel.-oneToAnyChannel :: MonadCHP m => m (OneToAnyChannel a)-oneToAnyChannel = newChannel---- | A type-constrained version of newChannel.-anyToAnyChannel :: MonadCHP m => m (AnyToAnyChannel a)-anyToAnyChannel = newChannel---- | A type-constrained version of newChannelWithLabel.------ Added in version 1.2.0.-anyToOneChannelWithLabel :: MonadCHP m => String -> m (AnyToOneChannel a)-anyToOneChannelWithLabel = newChannelWithLabel---- | A type-constrained version of newChannelWithLabel.------ Added in version 1.2.0.-oneToAnyChannelWithLabel :: MonadCHP m => String -> m (OneToAnyChannel a)-oneToAnyChannelWithLabel = newChannelWithLabel---- | A type-constrained version of newChannelWithLabel.------ Added in version 1.2.0.-anyToAnyChannelWithLabel :: MonadCHP m => String -> m (AnyToAnyChannel a)-anyToAnyChannelWithLabel = newChannelWithLabel---- ==========--- Instances: --- ==========--instance ReadableChannel Chanin where-  readChannel (Chanin c)-    = let (e, mdur, mafter) = readChannelC c in-      buildOnEventPoison (indivRecJust ChannelRead) e-        (EventActions (return ()) mdur)-        (liftSTM mafter) >>= checkPoison--  extReadChannel (Chanin c) body-    = let (e, m) = startReadChannelC c in-      scopeBlock-        (buildOnEventPoison (indivRecJust ChannelRead) e mempty (liftSTM m) >>= checkPoison)-        (\val -> do x <- body val-                    liftSTM $ endReadChannelC c-                    return x)-        (poisonReadC c)--instance WriteableChannel Chanout where-  writeChannel (Chanout c) x-    = let (e, mdur, mafter) = writeChannelC c x in-        buildOnEventPoison (indivRecJust ChannelWrite) e-          (EventActions (return ()) mdur) (liftSTM mafter)-        >>= checkPoison-  extWriteChannel' (Chanout c) body-    = let (e, m) = startWriteChannelC c in-      scopeBlock-        (buildOnEventPoison (indivRecJust ChannelWrite)-          e mempty (liftSTM m) >>= checkPoison)-        (const $ do (x, r) <- body-                    sequence [liftSTM $ sendWriteChannelC c x-                             ,liftSTM (endWriteChannelC c)]-                      >>= checkPoison . mergeWithPoison-                    return r)-        (poisonWriteC c)-        --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--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)---- Some of this is defensive programming -- the writer should never be able--- to discover poison in the channel variable, for example--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--instance Channel Chanin Chanout where-  newChannel = chan stmChannel Chanin Chanout-  sameChannel (Chanin x) (Chanout y) = x == y--instance Channel (Shared Chanin) Chanout where-  newChannel = do m <- newMutex-                  c <- newChannel-                  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 = do m <- newMutex-                  c <- newChannel-                  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 = do m <- newMutex-                  m' <- newMutex-                  c <- newChannel-                  return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (Shared (m', writer c))-  sameChannel (Shared (_, Chanin x)) (Shared (_, Chanout y)) = x == y+import Control.Concurrent.CHP.Channels.Base+import Control.Concurrent.CHP.Channels.Communication+import Control.Concurrent.CHP.Channels.Creation+import Control.Concurrent.CHP.Channels.Ends+import Control.Concurrent.CHP.Channels.Synonyms

@@ -0,0 +1,183 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++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+++-- | A reading channel-end type.+--+-- See 'reader' to obtain one, and 'ReadableChannel' for how to use one.+--+-- Eq instance added in version 1.1.1+newtype Chanin a = Chanin (STMChannel a) deriving Eq++-- | A writing channel-end type.+--+-- See 'writer' to obtain one, and 'WritableChannel' for how to use one.+-- +-- Eq instance added in version 1.1.1+newtype Chanout a = Chanout (STMChannel a) deriving Eq++newtype STMChannel a = STMChan (Event, TVar (WithPoison (Maybe a, Maybe ())))+  deriving Eq++-- | A channel type, that can be used to get the ends of the channel via 'reader'+-- and 'writer'+data Chan r w a = Chan {+  -- | Gets the channel's identifier.  Useful if you need to be able to identify+  -- a channel in the trace later on.+  getChannelIdentifier :: Unique,+  -- | Gets the reading end of a channel from its 'Chan' type.+  reader :: r a,+  -- | Gets the writing end of a channel from its 'Chan' type.+  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++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++-- Some of this is defensive programming -- the writer should never be able+-- to discover poison in the channel variable, for example++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

@@ -0,0 +1,280 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | A module containing broadcast channels (one-to-many).  Whereas a one-to-any+-- channel features one writer sending a /single/ value to /one/ (of many) readers, a+-- one-to-many channel features one writer sending the /same/ value to /many/+-- readers.  So a one-to-any channel involves claiming the channel-end to ensure+-- exclusivity, but a one-to-many channel involves enrolling on the channel-end+-- (subscribing) before it can engage in communication.+--+-- A communication on a one-to-many channel only takes place when the writer+-- and all readers currently enrolled agree to communicate.  What happens when+-- the writer wants to communicate and no readers are enrolled is undefined+-- (the writer may block, or may communicate happily to no-one).+--+-- This module also contains reduce channels (added in version 1.1.1).  Because+-- in CHP channels must have the same type at both ends, we use the Monoid+-- type-class.  It is important to be aware that the order of mappends will be+-- non-deterministic, and thus you should either use an mappend that is commutative+-- or code around this restruction.+--+-- For example, a common thing to do would be to use lists as the type for+-- reduce channels, make each writer write a single item list (but more is+-- possible), then use the list afterwards, but be aware that it is unordered.+--  If it is important to have an ordered list, make each writer write a pair+-- containing a (unique) index value and the real data, then sort by the index+-- value and discard it.+--+-- Since reduce channels were added after the initial library design, there+-- is a slight complication: it is not possible to use newChannel (and all+-- similar functions) with reduce channels because it is impossible to express+-- the Monoid constraint for the Channel instance.  Instead, you must use manyToOneChannel+-- and manyToAnyChannel.+module Control.Concurrent.CHP.Channels.BroadcastReduce (BroadcastChanin, BroadcastChanout,+  OneToManyChannel, AnyToManyChannel, oneToManyChannel, anyToManyChannel,+    oneToManyChannel', anyToManyChannel', ReduceChanin,+    ReduceChanout, sameReduceChannel, ManyToOneChannel, ManyToAnyChannel, manyToOneChannel,+    manyToAnyChannel, manyToOneChannel', manyToAnyChannel')+      where++import Control.Arrow+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans+import Data.Monoid++import Control.Concurrent.CHP.Barriers+import Control.Concurrent.CHP.Base+import Control.Concurrent.CHP.Channels+import Control.Concurrent.CHP.Channels.Base+import Control.Concurrent.CHP.CSP+import Control.Concurrent.CHP.Enroll+import Control.Concurrent.CHP.Event+import Control.Concurrent.CHP.Mutex+import Control.Concurrent.CHP.Traces.Base++-- | The Eq instance was added in version 1.4.0.+--+-- In version 1.5.0, the broadcast and reduce channels do not appear correctly+-- in the traces.+newtype BroadcastChannel a = BC (Barrier, TVar (Maybe a), ManyToOneTVar Int)++instance Eq (BroadcastChannel a) where+  (BC (_, tvX, _)) == (BC (_, tvY, _)) = tvX == tvY++-- | The reading end of a broadcast channel.  You must enroll on it before+-- you can read from it or poison it.+-- +-- The Eq instance was added in version 1.4.0.+newtype BroadcastChanin a = BI (BroadcastChannel a) deriving (Eq)++-- | The writing end of a broadcast channel.+-- +-- The Eq instance was added in version 1.4.0.+newtype BroadcastChanout a = BO (BroadcastChannel a) deriving (Eq)++instance Enrollable BroadcastChanin a where+  enroll c@(BI (BC (b,_,_))) f = enroll b (const $ f (Enrolled c))+  resign (Enrolled (BI (BC (b,_,_)))) m+    = resign (Enrolled b) m++instance WriteableChannel BroadcastChanout where+  extWriteChannel' (BO (BC (b, tvSend, tvAck))) m+    = do syncBarrierWith (indivRecJust ChannelWrite)+           (resetManyToOneTVar tvAck . pred) $ Enrolled b+           -- subtract one for writer+         (x, r) <- m+         liftIO . atomically $ writeTVar tvSend $ Just x+         -- Must be two separate transactions:+         liftIO . atomically $ 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+         y <- f x+         liftIO $ atomically $ writeManyToOneTVar ((== 0), return 0) pred tvAck+         return y++instance Poisonable (BroadcastChanout a) where+  poison (BO (BC (b,_,_))) = poison $ Enrolled b+  checkForPoison (BO (BC (b,_,_))) = checkForPoison $ Enrolled b++instance Poisonable (Enrolled BroadcastChanin a) where+  poison (Enrolled (BI (BC (b,_,_)))) = poison $ Enrolled b+  checkForPoison (Enrolled (BI (BC (b,_,_)))) = checkForPoison $ Enrolled b++newBroadcastChannel :: CHP (BroadcastChannel a)+newBroadcastChannel = do+    do b@(Barrier (e, _, _)) <- newBarrier+       -- Writer is always enrolled:+       liftIO $ atomically $ enrollEvent e+       tvSend <- liftIO $ atomically $ newTVar Nothing+       tvAck <- liftIO $ atomically $ newManyToOneTVar 0+       return $ BC (b, tvSend, tvAck)++instance Channel BroadcastChanin BroadcastChanout where+  newChannel' _sh = liftCHP $ do+    c@(BC (b, _, _)) <- newBroadcastChannel+    return $ Chan (getBarrierIdentifier b) (BI c) (BO c)+  sameChannel (BI x) (BO y) = x == y++instance Channel BroadcastChanin (Shared BroadcastChanout) where+  newChannel' _sh = liftCHP $ do+    m <- newMutex+    c <- newChannel+    return $ Chan (getChannelIdentifier c) (reader c) (Shared (m, writer c))+  sameChannel (BI x) (Shared (_, BO y)) = x == y++type OneToManyChannel = Chan BroadcastChanin BroadcastChanout+type AnyToManyChannel = Chan BroadcastChanin (Shared BroadcastChanout)++oneToManyChannel :: MonadCHP m => m (OneToManyChannel a)+oneToManyChannel = newChannel++anyToManyChannel :: MonadCHP m => m (AnyToManyChannel a)+anyToManyChannel = newChannel++-- | Added in version 1.5.0.+--+-- In version 1.5.0, the broadcast and reduce channels do not appear correctly+-- in the traces.+oneToManyChannel' :: MonadCHP m => ChanOpts a -> m (OneToManyChannel a)+oneToManyChannel' = newChannel'++-- | Added in version 1.5.0.+--+-- In version 1.5.0, the broadcast and reduce channels do not appear correctly+-- in the traces.+anyToManyChannel' :: MonadCHP m => ChanOpts a -> m (AnyToManyChannel a)+anyToManyChannel' = newChannel'+++-- | The Eq instance was added in version 1.4.0.+-- +-- In version 1.5.0, the broadcast and reduce channels do not appear correctly+-- in the traces.+newtype ReduceChannel a = GC (Barrier, ManyToOneTVar (Int, Maybe (a, TVar Bool)), (a -> a -> a, a))++instance Eq (ReduceChannel a) where+  (GC (_, tvX, _)) == (GC (_, tvY, _)) = tvX == tvY++-- | The reading end of a reduce channel.+--+-- The Eq instance was added in version 1.4.0.+newtype ReduceChanin a = GI (ReduceChannel a) deriving (Eq)++-- | The writing end of a reduce channel.  You must enroll on it before+-- you can read from it or poison it.+--+-- The Eq instance was added in version 1.4.0.+newtype ReduceChanout a = GO (ReduceChannel a) deriving (Eq)++instance Enrollable ReduceChanout a where+  enroll c@(GO (GC (b,_,_))) f = enroll b (const $ f (Enrolled c))+  resign (Enrolled (GO (GC (b,_,_)))) m+    = resign (Enrolled b) m+      +instance WriteableChannel (Enrolled ReduceChanout) where+  extWriteChannel' (Enrolled (GO (GC (b, tv, (f,_))))) m+    = do syncBarrierWith (indivRecJust ChannelWrite)+           (\n -> resetManyToOneTVar tv (pred n, Nothing)) $ Enrolled b+           -- Subtract one for reader+         (x, r) <- m+         (_, Just (_, rtvb)) <- liftIO . atomically $ do+           tvb <- newTVar False+           let upd (n, mx) = (pred n, Just $ maybe (x, tvb) (first $ f x) mx)+           writeManyToOneTVar ((== 0) . fst, return (0, Nothing)) upd tv+         -- Has to be two separate transactions+         liftIO $ atomically $ readTVar rtvb >>= flip unless retry+         return r++instance ReadableChannel ReduceChanin where+  extReadChannel (GI (GC (b, tv, (_, _empty)))) f+    = do syncBarrierWith (indivRecJust ChannelRead)+           (\n -> resetManyToOneTVar tv (pred n, Nothing)) $ Enrolled b+           -- Subtract one for reader+         (_, Just (x, tvb)) <- liftIO $ atomically $ readManyToOneTVar tv+         y <- f x+         liftIO $ atomically $ writeTVar tvb True+         return y++instance Poisonable (Enrolled ReduceChanout a) where+  poison (Enrolled (GO (GC (b,_,_)))) = poison $ Enrolled b+  checkForPoison (Enrolled (GO (GC (b,_,_)))) = checkForPoison $ Enrolled b++instance Poisonable (ReduceChanin a) where+  poison (GI (GC (b,_,_))) = poison $ Enrolled b+  checkForPoison (GI (GC (b,_,_))) = checkForPoison $ Enrolled b++newReduceChannel :: Monoid a => CHP (ReduceChannel a)+newReduceChannel = do+    do b@(Barrier (e, _, _)) <- newBarrier+       -- Writer is always enrolled:+       liftIO $ atomically $ enrollEvent e+       mtv <- liftIO $ atomically $ newManyToOneTVar (0, Nothing)+       return $ GC (b, mtv, (mappend, mempty))++-- | The reduce channel version of sameChannel.+-- +-- This function was added in version 1.4.0.+sameReduceChannel :: ReduceChanin a -> ReduceChanout a -> Bool+sameReduceChannel (GI x) (GO y) = x == y++type ManyToOneChannel = Chan ReduceChanin ReduceChanout+type ManyToAnyChannel = Chan (Shared ReduceChanin) ReduceChanout++manyToOneChannel :: (Monoid a, MonadCHP m) => m (ManyToOneChannel a)+manyToOneChannel = do+    c@(GC (b,_,_)) <- liftCHP newReduceChannel+    return $ Chan (getBarrierIdentifier b) (GI c) (GO c)+++manyToAnyChannel :: (Monoid a, MonadCHP m) => m (ManyToAnyChannel a)+manyToAnyChannel = do+    m <- newMutex+    c <- manyToOneChannel+    return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (writer c)++-- | Added in version 1.5.0.+-- +-- In version 1.5.0, the broadcast and reduce channels do not appear correctly+-- in the traces.+manyToOneChannel' :: (Monoid a, MonadCHP m) => ChanOpts a -> m (ManyToOneChannel a)+manyToOneChannel' = const manyToOneChannel --TODO++-- | Added in version 1.5.0.+-- +-- In version 1.5.0, the broadcast and reduce channels do not appear correctly+-- in the traces.+manyToAnyChannel' :: (Monoid a, MonadCHP m) => ChanOpts a -> m (ManyToAnyChannel a)+manyToAnyChannel' = const manyToAnyChannel --TODO

@@ -0,0 +1,161 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | All the channel-ends in CHP are instances of 'ReadableChannel' (for ends that+-- you can read from) or 'WriteableChannel' (for ends that you can write to).+--+-- The 'readChannel' and 'writeChannel' functions are the standard way to communicate+-- on a channel.  These functions wait for the other party in the communication+-- to arrive, then exchange the data, then complete.  In pseudo-code, the semantics+-- are like this when two parties (shown here as two columns) communicate:+--+-- > do sync                          sync+-- >    x                        <-   return y+-- >    done                          done+--+-- Further options are offered by the 'extReadChannel' and 'extWriteChannel' channels,+-- which allow either side to perform additional (so-called extended) actions during the communication.+--  The semantics when both sides are performing extended actions are:+--+-- > do sync                          sync+-- >                                  y <- extWriteAction+-- >    x                        <-   return y+-- >    x' <- extReadAction x         done+-- >    done                          done+-- >    return x'+--+-- Neither end need know that the other is performing an extended action, and any+-- combination is possible (e.g. a normal 'writeChannel' with an 'extReadChannel').+module Control.Concurrent.CHP.Channels.Communication (+  ReadableChannel(..), WriteableChannel(..), writeValue, writeChannelStrict+  ) where++import Control.Monad+import Control.Parallel.Strategies+import Data.Monoid++import Control.Concurrent.CHP.Base+import Control.Concurrent.CHP.CSP+import Control.Concurrent.CHP.Channels.Base+import Control.Concurrent.CHP.Guard+import Control.Concurrent.CHP.Poison+import Control.Concurrent.CHP.Traces.Base++-- | A class indicating that a channel can be read from.+class ReadableChannel chanEnd where -- minimal implementation: extReadChannel+  -- | Reads from the given reading channel-end+  readChannel :: chanEnd a -> CHP a+  readChannel c = extReadChannel c return+  -- | Performs an extended read from the channel, performing the given action+  -- before freeing the writer+  extReadChannel :: chanEnd a -> (a -> CHP b) -> CHP b++-- | A class indicating that a channel can be written to.+class WriteableChannel chanEnd where -- minimal implementation: extWriteChannel+  -- | Writes from the given writing channel-end+  writeChannel :: chanEnd a -> a -> CHP ()+  writeChannel c x = extWriteChannel c (return x) >> return ()++  -- | Starts the communication, then performs the given extended action, then+  -- sends the result of that down the channel.+  extWriteChannel :: chanEnd a -> CHP a -> CHP ()+  extWriteChannel c m = extWriteChannel' c (liftM (flip (,) ()) m)++  -- | Like extWriteChannel, but allows a value to be returned from the inner action.+  --+  -- This function was added in version 1.4.0.+  extWriteChannel' :: chanEnd a -> CHP (a, b) -> CHP b+  ++-- ==========+-- Functions: +-- ==========++-- | A useful synonym for @flip writeChannel@.  Especially useful with 'claim'+-- so that instead of writing @claim output (flip writeChannel 6)@ you can write+-- @claim output (writeValue 6)@.+--+-- Added in version 1.5.0.+writeValue :: WriteableChannel chanEnd => a -> chanEnd a -> CHP ()+writeValue = flip writeChannel++-- | A helper function that uses the parallel strategies library (see the+-- paper: \"Algorithm + Strategy = Parallelism\", P.W. Trinder et al, JFP+-- 8(1) 1998,+-- <http://www.macs.hw.ac.uk/~dsg/gph/papers/html/Strategies/strategies.html>)+-- to make sure that the value sent down a channel is strictly evaluated+-- by the sender before transmission.+--+-- This is useful when you want to write worker processes that evaluate data+--  and send it back to some \"harvester\" process.  By default the values sent+-- back may be unevaluated, and thus the harvester might end up doing the evaluation.+--  If you use this function, the value is guaranteed to be completely evaluated+-- before sending.+--+-- Added in version 1.0.2.+writeChannelStrict :: (NFData a, WriteableChannel chanEnd) => chanEnd a -> a -> CHP ()+writeChannelStrict c x = (writeChannel c $| rnf) x++-- ==========+-- Instances: +-- ==========++instance ReadableChannel Chanin where+  readChannel (Chanin c)+    = let (e, mdur, mafter) = readChannelC c in+      buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e+        (EventActions (const $ return ()) mdur)+        (liftSTM mafter) >>= checkPoison++  extReadChannel (Chanin c) body+    = let (e, m) = startReadChannelC c in+      scopeBlock+        (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e mempty (liftSTM m) >>= checkPoison)+        (\val -> do x <- body val+                    liftSTM $ endReadChannelC c+                    return x)+        (poisonReadC c)++instance WriteableChannel Chanout where+  writeChannel (Chanout c) x+    = let (e, mdur, mafter) = writeChannelC c x in+        buildOnEventPoison (wrapIndiv $ indivRecJust ChannelWrite) e+          (EventActions (const $ return ()) mdur) (liftSTM mafter)+        >>= checkPoison+  extWriteChannel' (Chanout c) body+    = let (e, m) = startWriteChannelC c in+      scopeBlock+        (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelWrite)+          e mempty (liftSTM m) >>= checkPoison)+        (const $ do (x, r) <- body+                    sequence [liftSTM $ sendWriteChannelC c x+                             ,liftSTM (endWriteChannelC c)]+                      >>= checkPoison . mergeWithPoison+                    return r)+        (poisonWriteC c)

@@ -0,0 +1,248 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | This module contains a proliferation of channel creation methods.+--+-- For most uses, 'newChannel' is the only method needed from this module.  This+-- creates a channel for you to use.  The channel will be automatically destroyed+-- during garbage collection when it falls out of use, so there is no need to do+-- anything to destroy it.+--+-- It is often possible for the type system to infer which channel you want when+-- you use 'newChannel'.  If the types of the ends are known by the type system,+-- the channel-type can be inferred.  So you can usually just write 'newChannel',+-- and depending on how you use the channel, the type system will figure out+-- which one you needed.+--+-- If this gives a type error along the lines of:+-- +-- >    Ambiguous type variables `r', `w' in the constraint:+-- >      `Channel r w' arising from a use of `newChannel' at tmp.hs:3:24-33+-- >    Probable fix: add a type signature that fixes these type variable(s)+--+-- Then you must either explicitly type the channel ends you are using, or more+-- simply, use one of the synonyms in "Control.Concurrent.CHP.Channels.Synonyms"+-- to indicate which kind of channel you are allocating.+--+-- Several other functions in this module, such as 'newChannelWR', 'newChannels'+-- and 'newChannelList' are helpers built with newChannel to ease dealing with+-- channel creation.+--+-- The remainder of the functions in this module are related to traces (see "Control.Concurrent.CHP.Traces"),+-- and allowing the channels to show up usefully in traces: see 'newChannel'' and+-- 'ChanOpts'.+--+-- The channel creation methods were refactored in version 1.5.0.  Your code will+-- only be affected if you were using the trace-related methods (for labelling+-- 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(..),+  newChannelList, newChannelListWithLabels, newChannelListWithStem,+  labelChannel+  ) where++import Control.Monad+import Data.Unique++import Control.Concurrent.CHP.Base+import Control.Concurrent.CHP.Channels.Base+import Control.Concurrent.CHP.Mutex+import Control.Concurrent.CHP.Traces.Base++-- | A class used for allocating new channels, and getting the reading and+-- writing ends.  There is a bijective assocation between the channel, and+-- its pair of end types.  You can see the types in the list of instances below.+-- Thus, 'newChannel' may be used, and the compiler will infer which type of+-- channel is required based on what end-types you get from 'reader' and 'writer'.+-- Alternatively, if you explicitly type the return of 'newChannel', it will+-- be definite which ends you will use.  If you do want to fix the type of+-- the channel you are using when you allocate it, consider using one of the+-- many 'oneToOneChannel'-like shorthand functions that fix the type.+class Channel r w where+  -- | Like 'newChannel' but allows you to specify a way to convert the values+  -- into Strings in order to display them in the traces, and a label for the traces.  If+  -- you don't use traces, you can use 'newChannel'.+  --+  -- Added in version 1.5.0.+  newChannel' :: MonadCHP m => ChanOpts a -> m (Chan r w a)++  -- | Determines if two channel-ends refer to the same channel.+  --+  -- This function was added in version 1.4.0.+  sameChannel :: r a -> w a -> Bool++-- | Options for channel creation; a function to show the inner data, and an optional+-- label (both only affect tracing).  These options can be passed to newChannel'.+--+-- Added in version 1.5.0.+data ChanOpts a = ChanOpts { chanOptsShow :: a -> String, chanOptsLabel :: Maybe String }++-- | The default: don't show anything, don't label anything+-- +-- Added in version 1.5.0.+defaultChanOpts :: ChanOpts a+defaultChanOpts = ChanOpts (const "") Nothing++-- | Uses the Show instance for showing the data in traces, and the given label.+--+-- Added in version 1.5.0.+chanLabel :: Show a => String -> ChanOpts a+chanLabel = ChanOpts show . Just++-- | Allocates a new channel.  Nothing need be done to+-- destroy\/de-allocate the channel when it is no longer in use.+--+-- This function does not add any information to the traces: see newChannel' for+-- that purpose.+--+-- In version 1.5.0, this function was moved out of the 'Channel' class, but that+-- should only matter if you were declaring your own instances of that class (very+-- unlikely).+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)+newChannelRW = do c <- newChannel+                  return (reader c, writer c)++-- | A helper that is like 'newChannel' but returns the writing and reading+-- end of the channels directly.+newChannelWR :: (Channel r w, MonadCHP m) => m (w a, r a)+newChannelWR = do c <- newChannel+                  return (writer c, reader c)++-- | Creates a list of channels of the same type with the given length.  If+-- you need to access some channels by index, use this function.  Otherwise+-- you may find using 'newChannels' to be easier.+newChannelList :: (Channel r w, MonadCHP m) => Int -> m [Chan r w a]+newChannelList n = replicateM n newChannel++-- | A helper that is like 'newChannelList', but labels the channels according+-- to a pattern.  Given a stem such as foo, it names the channels in the list+-- foo0, foo1, foo2, etc.+newChannelListWithStem :: (Channel r w, MonadCHP m) => Int -> String -> m [Chan r w a]+newChannelListWithStem n s = sequence [newChannel' $ ChanOpts (const "") (Just $ s ++ show i) | i <- [0 .. (n - 1)]]++-- | A helper that is like 'newChannelList', but labels the channels with the+-- given list.  The number of channels returned is the same as the length of+-- the list of labels+newChannelListWithLabels :: (Channel r w, MonadCHP m) => [String] -> m [Chan r w a]+newChannelListWithLabels = mapM (newChannel' . ChanOpts (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)+++instance Channel Chanin Chanout where+  newChannel' o = do c <- chan (stmChannel $ 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+                  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+                  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+                  c <- newChannel' o+                  return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (Shared (m', writer c))+  sameChannel (Shared (_, Chanin x)) (Shared (_, Chanout y)) = x == y++chan :: Monad m => m (Unique, c a) -> (c a -> r a) -> (c a -> w a) -> m (Chan r w a)+chan m r w = do (u, x) <- m+                return $ Chan u (r x) (w x)

@@ -0,0 +1,69 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | Channels in CHP must be used via their ends.  It is generally these ends that+-- you pass around to processes that want to communicate on the channel -- thus+-- it is possible to see from the type ('Chanin'\/'Chanout') whether the process+-- will use it for reading or writing.  The channel-ends are named from the perspective+-- of processes: a Chanin is a channel-end that a process may input values from,+-- whereas a Chanout is a channel-end that a process may output values to.+module Control.Concurrent.CHP.Channels.Ends (+  Chanin, Chanout, Shared,+  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+import Control.Concurrent.CHP.Mutex++-- | Gets all the reading ends of a list of channels.  A shorthand for @map+-- reader@.+readers :: [Chan r w a] -> [r a]+readers = map reader++-- | Gets all the writing ends of a list of channels.  A shorthand for @map+-- writer@.+writers :: [Chan r w a] -> [w a]+writers = map writer++-- | Claims the given channel-end, executes the given block, then releases+-- the channel-end and returns the output value.  If poison or an IO+-- exception is thrown inside the block, the channel is released and the+-- poison\/exception re-thrown.+claim :: Shared c a -> (c a -> CHP b) -> CHP b+claim (Shared (lock, c)) body+  = scopeBlock+       (claimMutex lock >> return c)+       (\y -> do x <- body y+                 liftIO $ releaseMutex lock+                 return x)+       (releaseMutex lock)

@@ -0,0 +1,97 @@+-- Communicating Haskell Processes.+-- Copyright (c) 2008--2009, University of Kent.+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+--  * Redistributions of source code must retain the above copyright+--    notice, this list of conditions and the following disclaimer.+--  * Redistributions in binary form must reproduce the above copyright+--    notice, this list of conditions and the following disclaimer in the+--    documentation and/or other materials provided with the distribution.+--  * Neither the name of the University of Kent nor the names of its+--    contributors may be used to endorse or promote products derived from+--    this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | A module containing some useful type synonyms for dealing with channels.+--+-- If you get a type error such as:+--+-- >    Ambiguous type variables `r', `w' in the constraint:+-- >      `Channel r w' arising from a use of `newChannel' at tmp.hs:3:24-33+-- >    Probable fix: add a type signature that fixes these type variable(s)+--+-- Then you may want to substitute your use of 'newChannel' for 'oneToOneChannel'+-- (if you are not using channel sharing).+module Control.Concurrent.CHP.Channels.Synonyms (+  -- * Specific Channel Types+  -- | All the functions here are equivalent to newChannel (or newChannelWithLabel), but typed.  So for+  -- example, @oneToOneChannel = newChannel :: MonadCHP m => m OneToOneChannel@.+  OneToOneChannel, oneToOneChannel, oneToOneChannel',+  OneToAnyChannel, oneToAnyChannel, oneToAnyChannel',+  AnyToOneChannel, anyToOneChannel, anyToOneChannel',+  AnyToAnyChannel, anyToAnyChannel, anyToAnyChannel'+  ) where++import Control.Concurrent.CHP.Base+import Control.Concurrent.CHP.Channels.Creation+import Control.Concurrent.CHP.Channels.Ends++type OneToOneChannel = Chan Chanin Chanout+type AnyToOneChannel = Chan (Chanin) (Shared Chanout)+type OneToAnyChannel = Chan (Shared Chanin) (Chanout)+type AnyToAnyChannel = Chan (Shared Chanin) (Shared Chanout)++-- | A type-constrained version of newChannel.+oneToOneChannel :: MonadCHP m => m (OneToOneChannel a)+oneToOneChannel = newChannel++-- | A type-constrained version of newChannel'.+--+-- Added in version 1.5.0.+oneToOneChannel' :: MonadCHP m => ChanOpts a -> m (OneToOneChannel a)+oneToOneChannel' = newChannel'++-- | A type-constrained version of newChannel.+anyToOneChannel :: MonadCHP m => m (AnyToOneChannel a)+anyToOneChannel = newChannel++-- | A type-constrained version of newChannel.+oneToAnyChannel :: MonadCHP m => m (OneToAnyChannel a)+oneToAnyChannel = newChannel++-- | A type-constrained version of newChannel.+anyToAnyChannel :: MonadCHP m => m (AnyToAnyChannel a)+anyToAnyChannel = newChannel++-- | A type-constrained version of newChannel'.+--+-- Added in version 1.5.0.+anyToOneChannel' :: MonadCHP m => ChanOpts a -> m (AnyToOneChannel a)+anyToOneChannel' = newChannel'++-- | A type-constrained version of newChannel'.+--+-- Added in version 1.5.0.+oneToAnyChannel' :: MonadCHP m => ChanOpts a -> m (OneToAnyChannel a)+oneToAnyChannel' = newChannel'++-- | A type-constrained version of newChannel'.+--+-- Added in version 1.5.0.+anyToAnyChannel' :: MonadCHP m => ChanOpts a -> m (AnyToAnyChannel a)+anyToAnyChannel' = newChannel'

@@ -120,7 +120,7 @@  import Control.Concurrent.STM import Control.Monad hiding (mapM, mapM_)-import Control.Monad.State (get)+import Control.Monad.Reader (ask) import Control.Monad.Trans import Data.Foldable (mapM_) -- Needed for testing:@@ -327,14 +327,14 @@          liftSTM (modifyTVar tv $ enrollTimerData $ Just ev)            >>= checkPoison          x <- f $ Enrolled tim-         ts <- liftPoison $ liftTrace $ get+         ts <- liftPoison $ liftTrace $ ask          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 $ get+    = do ts <- liftPoison $ liftTrace $ ask          liftSTM (modifyTVar' tv (checkCompletion u sh ts . resignTimerData False))            >>= checkPoison          x <- m@@ -422,7 +422,7 @@   getCurrentTime (Enrolled (Clock (tv, _, _)))     = liftSTM (liftM (fmap curTime) $ readTVar tv) >>= checkPoison   wait c@(Enrolled (Clock (_, u, sh))) mt-    = do ts <- liftPoison $ liftTrace $ get+    = do ts <- liftPoison $ liftTrace $ ask          pid <- liftPoison $ liftTrace $ getProcessId          waitAct <- liftSTM $ waitClock pid ts c mt          (t, s) <- liftSTM waitAct >>= checkPoison

@@ -99,6 +99,13 @@ prefix x in_ out = (writeChannel out x >> id in_ out)   `onPoisonRethrow` (poison in_ >> poison out) +-- | Discards the first value it receives then act likes id.+--+-- Added in version 1.5.0.+tail :: Chanin a -> Chanout a -> CHP ()+tail input output = do readChannel input `onPoisonRethrow` (poison input >> poison output)+                       id input output+ -- | Forever reads in a value, and then sends out its successor (using 'Prelude.succ'). succ :: Enum a => Chanin a -> Chanout a -> CHP () succ = map Prelude.succ@@ -178,7 +185,7 @@ -- Added in version 1.2.0. consumeAlongside :: Chanin a -> CHP b -> CHP b consumeAlongside in_ proc-  = do c <- oneToOneChannelWithLabel "consumeAlongside-Internal"+  = do c <- oneToOneChannel' $ chanLabel "consumeAlongside-Internal"        (x,_) <-           ((do x <- proc               writeChannel (writer c) ()@@ -204,7 +211,8 @@ -- they are equal or not, etc. join :: (a -> b -> c) -> Chanin a -> Chanin b -> Chanout c -> CHP () join f in0 in1 out = (forever $ do-  (x,y) <- readChannel in0 <||> readChannel in1+  [Prelude.Left x, Prelude.Right y] <- runParallel+    [liftM Prelude.Left $ readChannel in0, liftM Prelude.Right $ readChannel in1]   writeChannel out $ f x y   ) `onPoisonRethrow` (poison in0 >> poison in1 >> poison out) 

@@ -35,7 +35,7 @@ import qualified Control.Exception.Extensible as C import Control.Monad import Control.Monad.Trans-import Data.Maybe+--import Data.Maybe import System.IO  import Control.Concurrent.CHP@@ -87,7 +87,11 @@          handlers = [C.Handler (response :: C.IOException -> IO (Maybe a))                    ,C.Handler (response :: C.AsyncException -> 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))                    ]     

@@ -31,7 +31,7 @@ module Control.Concurrent.CHP.Event (RecordedEventType(..), Event, getEventUnique,   SignalVar, SignalValue(..), enableEvents, disableEvents,   newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison,-  testAll) where+  testAll, getEventTypeVal) where  import Control.Arrow import Control.Concurrent.STM@@ -50,16 +50,26 @@ import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.ProcessId --- | ClockSync was added in version 1.2.0.+-- | The type of an event in the CSP and VCR traces.+--+-- ClockSync was added in version 1.2.0.+--+-- The extra parameter on ChannelComm and BarrierSync (which are the result of+-- showing the value sent and phase ended respectively) was added in version 1.5.0. data RecordedEventType-  = ChannelComm-  | BarrierSync+  = ChannelComm String+  | BarrierSync String   | ClockSync String deriving (Eq, Ord, Show) +getEventTypeVal :: RecordedEventType -> String+getEventTypeVal (ChannelComm s) = s+getEventTypeVal (BarrierSync s) = s+getEventTypeVal (ClockSync s) = s+ -- Not really a CSP event, more like an enrollable poisonable alting barrier! newtype Event = Event (   Unique, -- Event identifier-  RecordedEventType, -- Event type for trace recording+  STM RecordedEventType, -- Event type for trace recording   TVar (WithPoison     (Int, -- Enrolled count      Integer, -- Event sequence count@@ -74,7 +84,7 @@  -- For testing: instance Show Event where-  show (Event (u, t, _tv)) = "Event " ++ show (hashUnique u,t)+  show (Event (u, _t, _tv)) = "Event " ++ show (hashUnique u)  getEventUnique :: Event -> Unique getEventUnique (Event (u,_,_)) = u@@ -82,7 +92,7 @@ getEventTVar :: Event -> TVar (WithPoison (Int, Integer, [OfferSet])) getEventTVar (Event (_,_,tv)) = tv -getEventType :: Event -> RecordedEventType+getEventType :: Event -> STM RecordedEventType getEventType (Event (_,t,_)) = t  -- The value used to pass information to a waiting process once one of their events@@ -91,7 +101,7 @@ newtype SignalValue = Signal (WithPoison Int)   deriving (Eq, Show) -type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique Integer))+type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique (Integer, RecordedEventType)))  addPoison :: SignalValue -> SignalValue addPoison = const $ Signal PoisonItem@@ -128,14 +138,14 @@ allEventsInOffer (OfferSet (_, _, [(_,es)])) = es allEventsInOffer (OfferSet (_, _, eventSets)) = unionAll (map snd eventSets) -getAndIncCounter :: Event -> a -> STM (WithPoison Integer)-getAndIncCounter e _+getAndIncCounter :: Event -> (a, b) -> STM (WithPoison (Integer, a))+getAndIncCounter e (r, _)   = do x <- readTVar (getEventTVar e)        case x of          PoisonItem -> return PoisonItem          NoPoison (a, !n, c) -> do writeTVar (getEventTVar e) $                                      NoPoison (a, succ n, c)-                                   return $ NoPoison n+                                   return $ NoPoison (n, r)  -- | search is /not/ used for discovering offers.  It is used for looking for possible -- resolutions to a collection of offer sets.  It is pure; it performs no STM actions,@@ -159,7 +169,7 @@           -- out by not being chosen in another part of the search, and it cannot           -- be chosen by any future parts of the search.  Should be empty when first called from the outside.           -> Maybe ( [(SignalVar, SignalValue, STM ())]-                   , Map.Map Event (RecordedEventType, Set.Set ProcessId)+                   , Map.Map Event (STM RecordedEventType, Set.Set ProcessId)                    )              -- ^ The list of tvars involved with the completion and the signal              -- value for them, and the map with information about the completed events.@@ -195,7 +205,7 @@          tryAll :: [((SignalValue, STM ()), Map.Map Event ())]           -> Maybe ( [(SignalVar, SignalValue, STM ())]-                   , Map.Map Event (RecordedEventType, Set.Set ProcessId)+                   , Map.Map Event (STM RecordedEventType, Set.Set ProcessId)                    )         tryAll [] = Nothing         tryAll ((ns, es):next)@@ -241,15 +251,19 @@   = do let (offers', _) = trim (allOffers, events)            (act, ret) = fromMaybe ([], Map.empty) $              search (map addNullOffer $ sortOffers offers') Map.empty-       eventCounts <- T.sequence $ Map.mapWithKey getAndIncCounter ret+       -- The associated event-action must come first as that puts the values in the channels:+       mapM_ (\(_, _, m) -> m) act+       -- These values are then read by these on-completion bits:+       ret' <- T.mapM (\(m,y) -> do x <- m+                                    return (x, y)) ret+       eventCounts <- T.sequence $ Map.mapWithKey getAndIncCounter ret'        let NoPoison uniqCounts = T.sequence $ Map.mapKeysMonotonic getEventUnique eventCounts-       mapM_ (\(tv, x, m) -> writeTVar tv (Just (x, uniqCounts)) >> m-             ) act+       mapM_ (\(tv, x, _) -> writeTVar tv (Just (x, uniqCounts))) act        -- do the retractions for all involved processes once the choice is made:        -- TODO optimise:        retractOffers $ zip (map fst3 act)                            (repeat $ unionAll $ map allEventsInOffer allOffers)-       return (Map.mapKeysMonotonic getEventUnique ret)+       return (Map.mapKeysMonotonic getEventUnique ret')   where     fst3 (x, _, _) = x     -- Don't add the null offer for the newest process, and null offer should be@@ -387,7 +401,7 @@              Left (OfferSet (tv, _, _)) -> Just tv              _ -> Nothing -newEvent :: RecordedEventType -> Int -> IO Event+newEvent :: STM RecordedEventType -> Int -> IO Event newEvent t n   = do u <- newUnique        atomically $ do tv <- newTVar (NoPoison (n, 0, []))@@ -473,7 +487,7 @@                   -- of the value of this flag.  However, if there no events ready,                   -- passing True will leave the offers there, but False will retract                   -- the offers.-                -> STM (Maybe ((SignalValue, Map.Map Unique Integer), [((RecordedEventType, Unique), Set.Set ProcessId)]))+                -> STM (Maybe ((SignalValue, Map.Map Unique (Integer, RecordedEventType)), [((RecordedEventType, Unique), Set.Set ProcessId)])) enableEvents tvNotify pid events canCommitToWait   = do let offer = OfferSet (tvNotify, pid, [(nid, Map.fromList (zip es (repeat ()))) | (nid, es) <- events])        -- First add our offer to all the events:@@ -503,7 +517,8 @@ -- has been signalled (i.e. has a Just value), that is returned and nothing is done, if the variable -- has not been signalled (i.e. is Nothing), the events are disabled and Nothing -- is returned.-disableEvents :: SignalVar -> [Event] -> STM (Maybe (SignalValue, Map.Map Unique Integer))+disableEvents :: SignalVar -> [Event] -> STM (Maybe (SignalValue, Map.Map Unique (Integer,+  RecordedEventType))) disableEvents tv events   = do x <- readTVar tv        -- Since the transaction will be atomic, we know@@ -706,7 +721,7 @@             -- Middle list is one-per-offer             -- Inner list is a conjunction of events makeTestEvents eventCounts offerSets-      = do events <- mapM (\n -> newEvent ChannelComm $ case n of+      = do events <- mapM (\n -> newEvent (return $ ChannelComm "") $ case n of              NoPoison n' -> n'              PoisonItem -> 0) eventCounts            -- Poison all the events marked as poisoned:@@ -792,10 +807,10 @@     test' testName eventCounts offerSets poisoned = do            (events, realOffers) <- makeTestEvents (map fst eventCounts) offerSets -           actualResult <- atomically $ discoverAndResolve $ Left $ head realOffers+           actualResult <- liftM (liftM (fmap snd)) $ atomically $ discoverAndResolve $ Left $ head realOffers            let expectedResult = if poisoned then PoisonItem else NoPoison $-                                Map.fromList [ (getEventUnique e, (ChannelComm,-                                               Set.fromList $ map (testProcessId . (*1000) . fst) is))+                                Map.fromList [ (getEventUnique e,+                                               Set.fromList $ map (testProcessId . (*1000) . fst) is)                                              | (e, Left is) <- zip events (map snd eventCounts)]            when (expectedResult /= actualResult) $              assertFailure $ testName ++ " failed on direct result, expected: "

@@ -31,6 +31,7 @@  import Control.Concurrent.STM import Control.Monad.Trans+import qualified Data.Map as Map import Data.Monoid import Data.Unique import System.IO@@ -44,14 +45,15 @@              | StopGuard              -- The STM item is an action to take in the same transaction as              -- completing the event (before it is completed).-             | EventGuard ((Unique -> Integer) -> [RecordedIndivEvent Unique]) EventActions [Event]+             | EventGuard ((Unique -> (Integer, RecordedEventType)) -> [RecordedIndivEvent Unique]) EventActions [Event] -data EventActions = EventActions { actWhenLast :: STM ()+data EventActions = EventActions { actWhenLast :: Map.Map Unique Int -> STM ()                                  , actAlways :: STM () }  instance Monoid EventActions where-  mempty = EventActions (return ()) (return ())-  mappend (EventActions a a') (EventActions b b') = EventActions (a>>b) (a'>>b')+  mempty = EventActions (const $ return ()) (return ())+  mappend (EventActions a a') (EventActions b b')+    = EventActions (\n -> a n >> b n) (a' >> b')  skipGuard :: Guard skipGuard = SkipGuard

@@ -44,6 +44,7 @@    ) where  import Control.Concurrent+import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans import Data.Unique@@ -85,8 +86,8 @@  -- | 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 get-                 return $ liftM fst . runCHPProgramWith t (const ()) . f+embedCHP1 f = do t <- liftPoison $ liftTrace ask+                 return $ runCHPProgramWith t . f  -- | A convenient version of embedCHP1 that ignores the result embedCHP1_ :: (a -> CHP b) -> CHP (a -> IO ())

@@ -42,3 +42,7 @@  releaseMutex :: MonadIO m => Mutex -> m () releaseMutex m = liftIO $ putMVar m ()++-- | A wrapper (usually around a channel-end) indicating that the inner item+-- is shared.  Use the 'claim' function to use this type.+data Shared c a = Shared (Mutex, c a)

@@ -33,13 +33,11 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Extensible as C-import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State import Data.List import Data.Maybe import Data.Ord-import System.IO  import Control.Concurrent.CHP.Base import Control.Concurrent.CHP.Traces.Base@@ -93,61 +91,29 @@ -- Doesn't really matter for this operator: infixr <|*|> --wrapProcess :: CHP a -> (CHP' (Either PoisonError a) -> IO (Either PoisonError-  a, st)) -> IO (Maybe (Either st (a, st)))-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 _, st) -> return $ Just $ Left st-         Just (Right y, st) -> return $ Just $ Right (y, st)-  where-    response :: C.Exception e => e -> IO (Maybe a)-    response x = liftIO (hPutStrLn stderr $ "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))-                  ,C.Handler (response :: C.BlockedIndefinitely -> IO (Maybe a))-                  ,C.Handler (response :: C.Deadlock -> IO (Maybe a))-                  ]- -- | 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 processes-  = do (final, intermed) <- liftIO $ atomically $ do-         a <- newResultsVar-         b <- newResultsVar-         return (a, b)-       trace <- PoisonT $ lift $ liftTrace get+  = do resultVar <- liftIO $ atomically $ newManyToOneTVar []+       trace <- PoisonT $ lift $ liftTrace ask        blanks <- liftIO $ blankTraces trace (length processes)        liftIO $ -         mapM_ forkIO [do y <- wrapProcess p $ flip runStateT btr . pullOutStandard+         mapM_ forkIO [do y <- wrapProcess p $ flip runReaderT btr . pullOutStandard                           C.block $ atomically $-                            do ys <- readTVar intermed-                               writeTVar-                                 (if length ys == length processes - 1 then final else intermed)-                                 $ (case y of-                                 Nothing -> (n, (Nothing, Nothing))-                                 Just (Right (x,t)) -> (n, (Just x, Just t))-                                 Just (Left t) -> (n, (Nothing, Just t))-                                 ) : ys-                      | (p, btr, n) <- zip3 processes blanks [0..]]-       results <- liftIO $ atomically $ do xs <- readTVar final-                                           if length xs == length processes-                                             then return xs-                                             else retry+                            writeManyToOneTVar ((== length processes) . length, return []) +                             ((:) (case y of+                                 Nothing -> (n, Nothing)+                                 Just (Right x) -> (n, Just x)+                                 Just (Left _) -> (n, Nothing)+                                 )) resultVar+                             >> return ()+                      | (p, btr, n) <- zip3 processes blanks [(0::Int)..]]+       results <- liftIO $ atomically $ readManyToOneTVar resultVar        let sortedResults = map snd $ sortBy (comparing fst) results-       PoisonT $ lift $ liftTrace $ mergeSubProcessTraces (mapMaybe snd sortedResults)-       mapM (maybe throwPoison return . fst) sortedResults-  where-    newResultsVar :: STM (TVar [(Integer, (Maybe a, Maybe TraceStore))])-    newResultsVar = newTVar []+       PoisonT $ lift $ liftTrace $ mergeSubProcessTraces blanks+       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,@@ -185,10 +151,10 @@               liftIO $ atomically $ do                 (pa, n) <- readTVar b                 writeTVar b (pa, n + 1)-              trace <- liftCHP $ PoisonT $ lift $ liftTrace get+              trace <- liftCHP $ PoisonT $ lift $ liftTrace ask               [blank] <- liftIO $ blankTraces trace 1               liftIO $ forkIO $ do-                r <- wrapProcess p $ flip runStateT blank . pullOutStandard+                r <- wrapProcess p $ flip runReaderT blank . pullOutStandard                 C.block $ atomically $ do                   (poisonedAlready, n) <- readTVar b                   writeTVar b $ (poisonedAlready || isNothing r, n - 1)

@@ -31,23 +31,80 @@ -- the QuickCheck 2 framework and using HUnit. -- -- This whole module was added in version 1.4.0.-module Control.Concurrent.CHP.Test where+module Control.Concurrent.CHP.Test (QuickCheckCHP, qcCHP, qcCHP', propCHPInOut, testCHP, testCHPInOut,+  testCHP', CHPTestResult(..), (=*=), CHPTest, withCheck, assertCHP, assertCHP',+    assertCHPEqual, assertCHPEqual') where +import Control.Arrow import Control.Monad+import Control.Monad.Error (ErrorT, runErrorT, throwError)+import Control.Monad.Trans (MonadIO) import Data.Maybe-import Test.HUnit (assertBool, Test(..))-import Test.QuickCheck (Gen, Property)-import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)+import Data.Monoid+import Data.Unique+import Test.HUnit (assertFailure, Test(..))+import Test.QuickCheck (Gen, forAll)+import Test.QuickCheck.Property (Property, Result(..), Testable(..), failed, succeeded, liftIOResult)+import Text.PrettyPrint.HughesPJ  import Control.Concurrent.CHP+import Control.Concurrent.CHP.Traces --- | Takes a CHP program that returns a Bool (True = test passed, False = test--- failed) and forms it into a Property that QuickCheck can test.+-- | A wrapper around the CHP type that supports some QuickCheck 'Testable' instances.+--  See 'qcCHP' and 'qcCHP''. ----- Note that if the program exits with poison, this is counted as a test failure.-propCHP :: CHP Bool -> Property-propCHP = monadicIO . (>>= assert . fromMaybe False) . run . runCHP+-- Added in version 1.5.0.+newtype QuickCheckCHP a = QCCHP (IO (Maybe a, Doc)) +-- | Turns a CHP program into a 'QuickCheckCHP' for use with 'Testable' instances.+--+-- Equivalent to @qcCHP' . runCHP_CSPTrace@.+--+-- Added in version 1.5.0.+qcCHP :: CHP a -> QuickCheckCHP a+qcCHP = qcCHP' . runCHP_CSPTrace++-- | Takes the command that runs a CHP program and gives back a 'QuickCheckCHP'+-- item for use with 'Testable' instances.+--+-- You use this function like:+--+-- > qcCHP' (runCHP_CSPTrace p)+--+-- To test process @p@ with a CSP trace if it fails.  To turn off the display of+-- tracing when a test fails, use:+--+-- > qcCHP' (runCHP_TraceOff p)+--+-- Added in version 1.5.0.+qcCHP' :: Trace t => IO (Maybe a, t Unique) -> QuickCheckCHP a+qcCHP' = QCCHP . liftM (second prettyPrint)++qcResult :: IO (Maybe Result, Doc) -> Property+qcResult m = liftIOResult $+             do (mr, t) <- m+                case mr of+                  Just r -> return $ r { reason = reason r ++ "; trace: " ++ show t }+                  Nothing -> return $ failed { reason = "QuickCheckCHP Failure (deadlock/uncaught poison); trace: " ++ show t }++chpToQC :: CHPTestResult -> Result+chpToQC (CHPTestPass) = succeeded+chpToQC (CHPTestFail msg) = failed { reason = msg }++boolToResult :: Bool -> Result+boolToResult b = if b then succeeded else failed++instance Testable (QuickCheckCHP Bool) where+  property (QCCHP x) = qcResult $ liftM (first $ fmap boolToResult) x++instance Testable (QuickCheckCHP Result) where+  property (QCCHP x) = qcResult x++instance Testable (QuickCheckCHP CHPTestResult) where+  property (QCCHP x) = qcResult $ liftM (first $ fmap chpToQC) x+++ -- | Tests a process that takes a single input and produces a single output, using -- QuickCheck. --@@ -71,7 +128,7 @@ -- something like the Common.filter process), the test will deadlock. propCHPInOut :: Show a => (a -> b -> Bool) -> (Chanin a -> Chanout b -> CHP ()) -> Gen a -> Property propCHPInOut f p gen-  = monadicIO $ forAllM gen $ \x -> run (runCHP $+  = forAll gen $ \x -> qcCHP $               do c <- oneToOneChannel                  d <- oneToOneChannel                  (_,r) <- (p (reader c) (writer d)@@ -81,15 +138,152 @@                              poison (writer c) >> poison (reader d)                              return $ f x y                          ) `onPoisonTrap` return False)-                 return r) >>= assert . fromMaybe False+                 return r  -- | Takes a CHP program that returns a Bool (True = test passed, False = test -- failed) and forms it into an HUnit test. -- -- Note that if the program exits with poison, this is counted as a test failure. testCHP :: CHP Bool -> Test-testCHP = TestCase . (>>= assertBool "testCHP failure" . fromMaybe False) . runCHP+testCHP = TestCase . (>>= assertWithTrace) . runCHPAndTrace+  where+    assertWithTrace :: (Maybe Bool, CSPTrace Unique) -> IO ()+    assertWithTrace (Just True, _) = return ()+    assertWithTrace (Just False, t) = assertFailure $ "testCHP Failure; trace: " ++ show (prettyPrint t)+    assertWithTrace (Nothing, t) = assertFailure $ "testCHP Failure (deadlock/uncaught poison); trace: " ++ show (prettyPrint t) +-- | A helper type for describing a more detailed result of a CHP test.  You can+-- construct these values manually, or using the '(=*=)' operator.+--+-- Added in version 1.5.0.+data CHPTestResult = CHPTestPass | CHPTestFail String++instance Monoid CHPTestResult where+  mempty = CHPTestPass+  mappend CHPTestPass y = y+  mappend x _ = x++-- | Checks if two things are equal; passes the test if they are, otherwise fails+-- and gives an error that shows the two things in question.+--+-- Added in version 1.5.0.+(=*=) :: (Eq a, Show a) => a -> a -> CHPTestResult+(=*=) expected act+  | expected == act = CHPTestPass+  | otherwise = CHPTestFail $ "Expected: " ++ show expected ++ "; Actual: " ++ show act++-- | Like 'testCHP' but allows you to return the more descriptive 'CHPTestResult'+-- type, rather than a plain Bool.+--+-- Added in version 1.5.0.+testCHP' :: CHP CHPTestResult -> Test+testCHP' p = TestCase $ do (r, t) <- runCHP_CSPTrace p+                           case r of+                             Just CHPTestPass -> return ()+                             Just (CHPTestFail s) -> assertFailure $+                               s ++ "; trace: " ++ show t+                             Nothing -> assertFailure $ "testCHP' Failure (deadlock/uncaught poison); trace: "+                               ++ show t++-- | See withCheck.  Added in version 1.5.0.+newtype CHPTest a = CHPTest (ErrorT String CHP a)+  deriving (Monad, MonadIO, MonadCHP)++-- | A helper function that allows you to create CHP tests in an assertion style, either+-- for use with HUnit or QuickCheck 2.+--+-- Any poison thrown by the first argument (the left-hand side when this function+-- is used infix) is trapped and ignored.  Poison thrown by the second argument+-- (the right-hand side when used infix) is counted as a test failure.+--+-- As an example, imagine that you have a process that should repeatedly+-- output the same value (42), called @myProc@.  There are several ways to test+-- this, but for the purposes of illustration we will start by testing the+-- first two values:+--+-- > myTest :: Test+-- > myTest = testCHP' $ do+-- >   c <- oneToOneChannel+-- >   myProc (writer c)+-- >     `withCheck` do x0 <- liftCHP $ readChannel (reader c)+-- >                    assertCHPEqual (poison (reader c)) "First value" 42 x0+-- >                    x1 <- liftCHP $ readChannel (reader c)+-- >                    poison (reader c) -- Shutdown myProc+-- >                    assertCHPEqual' "Second value" 42 x1+--+-- This demonstrates the typical pattern: a do block with some initialisation to+-- begin with (creating channels, enrolling on barriers), then a withCheck call+-- with the thing you want to test on the left-hand side, and the part doing the+-- testing with the asserts on the right-hand side.  Most CHP actions must be surrounded+-- by 'liftCHP', and assertions can then be made about the values.+--+-- Poison is used twice in our example.  The assertCHPEqual function takes as a+-- first argument the command to execute if the assertion fails.  The problem+-- is that if the assertion fails, the right-hand side will finish.  But it is+-- composed in parallel with the left-hand side, which does not know to finish+-- (deadlock!).  Thus we must pass a command to execute if the assertion fails+-- that will shutdown the right-hand side.  The second assertion doesn't need+-- this, because by the time we make the assertion, we have already inserted+-- the poison.  Don't forget that you must poison to shut down the left-hand+-- side if your test is successful or else you will again get deadlock.+--+-- A better way to test this process is of course to read in a much larger number+-- of samples and check they are all the same, for example:+--+-- > myTest :: Test+-- > myTest = testCHP' $ do+-- >   c <- oneToOneChannel+-- >   myProc (writer c)+-- >     `withCheck` do xs <- liftCHP $ replicateM 1000 $ readChannel (reader c)+-- >                    poison (reader c) -- Shutdown myProc+-- >                    assertCHPEqual' "1000 values" xs (replicate 1000 42)+--+-- Added in version 1.5.0.+withCheck :: CHP a -> CHPTest () -> CHP CHPTestResult+withCheck p (CHPTest t) = liftM snd $ (p `onPoisonTrap` return undefined) <||> do+  er <- runErrorT t+  case er of+    Left msg -> return $ CHPTestFail msg+    Right _ -> return CHPTestPass++-- | Checks that the given Bool is True.  If it is, the assertion passes and the+-- test continues.  If it is False, the given command is run (which should shut+-- down the left-hand side of withCheck) and the test finishes, failing with the+-- given String.+--+-- Added in version 1.5.0.+assertCHP :: CHP () -> String -> Bool -> CHPTest ()+assertCHP comp msg passed+  | passed = return ()+  | otherwise = liftCHP comp >> CHPTest (throwError msg)++-- | Checks that the given values are equal (first is the expected value of the+-- test, second is the actual value).  If they are equal, the assertion passes and the+-- test continues.  If they are not equal, the given command is run (which should shut+-- down the left-hand side of withCheck) and the test finishes, failing with the+-- a message formed of the given String, and describing the two values.+--+-- Added in version 1.5.0.+assertCHPEqual :: (Eq a, Show a) => CHP () -> String -> a -> a -> CHPTest ()+assertCHPEqual comp msg expected act+  = assertCHP comp+              (msg ++ "; expected: " ++ show expected ++ "; actual: " ++ show act)+              (expected == act)++-- | Like 'assertCHP' but issues no shutdown command.  You should only use this+-- function if you are sure that the left-hand side of withCheck has already completed.+--+-- Added in version 1.5.0.+assertCHP' :: String -> Bool -> CHPTest ()+assertCHP' = assertCHP (return ())++-- | Like 'assertCHPEqual' but issues no shutdown command.  You should only use this+-- function if you are sure that the left-hand side of withCheck has already completed.+--+-- Added in version 1.5.0.+assertCHPEqual' :: (Eq a, Show a) => String -> a -> a -> CHPTest ()+assertCHPEqual' = assertCHPEqual (return ())+ -- | Tests a process that takes a single input and produces a single output, using -- HUnit. --@@ -128,4 +322,4 @@                              return $ f x y                          ) `onPoisonTrap` return False) --- TODO add some better HUnit facilities+

@@ -69,12 +69,181 @@   ,recordedIndivEventLabel   ,recordedIndivEventSeq   ,Trace(..)+  ,vcrToCSP+  ,structuralToCSP+  ,structuralToVCR   ) where +import Control.Arrow+--import Control.Monad.Cont+--import Control.Monad.State+import qualified Data.Foldable as F+import Data.List+import qualified Data.Map as Map+import Data.Monoid+import qualified Data.Set as Set+ import Control.Concurrent.CHP.Base import Control.Concurrent.CHP.Event+import Control.Concurrent.CHP.ProcessId import Control.Concurrent.CHP.Traces.Base import Control.Concurrent.CHP.Traces.CSP import Control.Concurrent.CHP.Traces.Structural import Control.Concurrent.CHP.Traces.TraceOff import Control.Concurrent.CHP.Traces.VCR++-- | Takes a VCR trace and forms all the possible CSP traces (without+-- duplicates) that could have arisen from the same execution.+--+-- This is done by taking all permutations of each set in the VCR trace (which+-- is a list of sets) and concatenating them with the results of the same process+-- on the rest of the trace.  Thus the maximum size of the returned set of CSP traces+-- is the product of the sizes of all the non-empty sets in the VCR trace.+--+-- This function was added in version 1.5.0.+vcrToCSP :: Eq u => VCRTrace u -> [CSPTrace u]+vcrToCSP (VCRTrace (ls, sets)) = [CSPTrace (ls, es) | es <- nub $ process sets]+  where+    process :: [Set.Set a] -> [[a]]+    process [] = [[]]+    process (s:ss)+      | Set.null s = process ss+      | otherwise = [a ++ b | a <- chp_permutations (Set.toList s), b <- process ss]++--type SeqId = Integer+--type CM eventId = ContT (EventMap eventId) (State (Seq.Seq (Set.Set (RecordedEvent eventId))))++type EventMap eventId = Map.Map (RecordedIndivEvent eventId) (Set.Set ProcessId)++combine :: Ord u => [EventMap u] -> EventMap u+combine = foldl (Map.unionWith Set.union) Map.empty++participants :: Ord u => EventHierarchy (RecordedIndivEvent u)+             -> Map.Map (RecordedIndivEvent u) Int+{-participants (SingleEvent e)+  = Map.singleton (recordedIndivEventLabel e, recordedIndivEventSeq e) 1+participants (StructuralSequence _ ss)+  = combine $ map participants ss+participants (StructuralParallel ps)+  = combine $ map participants ps+-}+participants = F.foldr+ (\e -> Map.insertWith (+) e 1)+ Map.empty++single :: RecordedIndivEvent u -> ProcessId -> EventMap u+single k v = Map.singleton k (Set.singleton v)++data Cont u = Cont (EventMap u) ([RecordedIndivEvent u] -> Cont u)+            | ContDone++instance Monoid (Cont u) where+  mempty = ContDone+  mappend ContDone r = r+  mappend (Cont m f) r = Cont m (\e -> f e `mappend` r)++makeCont :: Ord u => EventHierarchy (RecordedIndivEvent u) -> ProcessId -> Cont u+makeCont (SingleEvent e) pid = c+  where+    c = Cont (single e pid) wait+    wait e'+      | e `elem` e' = ContDone+      | otherwise = c+makeCont (StructuralSequence 0 _) _ = ContDone+makeCont (StructuralSequence n es) pid+  = mconcat (map (uncurry makeCont) $ zip es pidsPlusOne)+      `mappend` makeCont (StructuralSequence (n-1) es) (last pidsPlusOne)+  where+    pidsPlusOne = take (1 + length es) $ iterate incPid pid++    incPid (ProcessId ps) = ProcessId $ init ps ++ [ParSeq p (succ s)]+      where+        ParSeq p s = last ps+makeCont (StructuralParallel es) pid+  = mergePar (map (uncurry makeCont) $ zip es (parPids pid))+  where+    parPids (ProcessId ps) = [ProcessId $ ps ++ [ParSeq i 0] | i <- [0..]]++mergePar :: Ord u => [Cont u] -> Cont u+mergePar cs = case [ m | Cont m _f <- cs] of+                [] -> ContDone+                ms -> Cont (combine ms) (\e -> mergePar [f e | Cont _m f <- cs])++-- | Takes a structural trace and forms all the possible VCR traces (without+-- duplicates) that could have arisen from the same execution.+--+-- This is done -- roughly speaking -- by replaying the structural trace in all+-- possible execution orderings and pulling out the VCR trace for each ordering.+--+-- This function was added in version 1.5.0.+structuralToVCR :: Ord u => StructuralTrace u -> [VCRTrace u]+structuralToVCR (StructuralTrace (ls, Nothing)) = [VCRTrace (ls, [])]+structuralToVCR (StructuralTrace (ls, Just str))+  = nubBy eq [VCRTrace (ls, map (Set.map snd) $ reverse $ toVCR $ reverse tr) | tr <- flattenStructural str]+  where+    eq (VCRTrace (_, a)) (VCRTrace (_, b)) = a == b++toVCR :: Ord u => [(RecordedEvent u, Set.Set ProcessId)]+      -> [(Set.Set (Set.Set ProcessId, RecordedEvent u))]+toVCR [] = []+toVCR ((e, pids) : rest)+  = prependVCR (toVCR rest) pids [(pids, e)]++-- | Takes a structural trace and forms all the possible CSP traces (without+-- duplicates) that could have arisen from the same execution.+--+-- This is done -- roughly speaking -- by replaying the structural trace in all+-- possible execution orderings and pulling out the CSP trace for each ordering.+--+-- It should be the case for all structural traces @t@ that do not use conjunction ('every' and+-- '(\<&\>)'):+-- +-- > structuralToCSP t =~= (concatMap vcrToCSP . structuralToVCR) t+-- >   where a =~= b = or [a' == b' | a' <- permutations a, b' <- permutations  b]+--+-- This function was added in version 1.5.0.+structuralToCSP :: Ord u => StructuralTrace u -> [CSPTrace u]+structuralToCSP (StructuralTrace (ls, Nothing)) = [CSPTrace (ls, [])]+structuralToCSP (StructuralTrace (ls, Just str))+  = [CSPTrace (ls, map fst tr) | tr <- flattenStructural str]++flattenStructural :: forall u. Ord u => EventHierarchy (RecordedIndivEvent u) -> [[(RecordedEvent u, Set.Set ProcessId)]]+flattenStructural tr+  = process $ makeCont tr rootProcessId+  where+    ps = participants tr++    process :: Cont u -> [[(RecordedEvent u, Set.Set ProcessId)]]+    process ContDone = [[]]+    process (Cont m f)+      = concat [map ((e, pids) :) $ process (f ie)+               | (e,(ie,pids)) <- Map.toAscList eventsWithAllParticipants]+      where+        indivEventsWithAllParticipants :: Map.Map (RecordedIndivEvent u) (Set.Set ProcessId)+        indivEventsWithAllParticipants = Map.map fst $ Map.filter (\(s, n) -> Set.size s == n) (Map.intersectionWith (,) m ps)++        eventsWithAllParticipants :: Map.Map (RecordedEvent u) ([RecordedIndivEvent u], Set.Set ProcessId)+        eventsWithAllParticipants+          = Map.map snd $+              Map.filterWithKey fixEvents $+              Map.mapKeysWith mergeVals toWhole $+              Map.map ((,) False . first (:[])) $+              Map.mapWithKey (,) $+              indivEventsWithAllParticipants+          where+            mergeVals :: (Bool, ([RecordedIndivEvent u], Set.Set ProcessId))+                      -> (Bool, ([RecordedIndivEvent u], Set.Set ProcessId))+                      -> (Bool, ([RecordedIndivEvent u], Set.Set ProcessId))+            mergeVals (_, (es, pids)) (_, (es', pids'))+              = (True, (es ++ es', Set.union pids pids'))++    fixEvents :: RecordedEvent a -> (Bool, b) -> Bool+    fixEvents (ChannelComm _, _) (b, _) = b -- Channel comms need to have both sides+    fixEvents _ _ = True++    toWhole :: RecordedIndivEvent a -> RecordedEvent a+    toWhole (ChannelWrite x _ s) = (ChannelComm s, x)+    toWhole (ChannelRead x _ s) = (ChannelComm s, x)+    toWhole (BarrierSyncIndiv x _ s) = (BarrierSync s, x)+    toWhole (ClockSyncIndiv x _ t) = (ClockSync t, x)+    

@@ -30,7 +30,9 @@ module Control.Concurrent.CHP.Traces.Base where  import Control.Concurrent.STM+import Control.Monad.Reader import Control.Monad.State+import Data.IORef import Data.List import qualified Data.Map as Map import qualified Data.Set as Set@@ -58,37 +60,45 @@ -- never have the same Unique as each other, but do not rely on this -- behaviour. --+-- The type u item is the unique identifier of the channel/barrier/clock, and the+-- Integer is a sequence identifier for that channel/barrier/clock (first sync+-- is 0, second sync is 1, etc), and finally the String shows the value-sent/phase-ended/time+-- involved.+-- -- ClockSyncIndiv was added in version 1.2.0. -- -- The type became parameterised, and the Show and Read instances were added in version 1.3.0.+--+-- The String parameters on ChannelWrite, ChannelRead and BarrierSyncIndiv were+-- added in version 1.5.0. data RecordedIndivEvent u = -  ChannelWrite u Integer-  | ChannelRead u Integer-  | BarrierSyncIndiv u Integer+  ChannelWrite u Integer String+  | ChannelRead u Integer String+  | BarrierSyncIndiv u Integer String   | ClockSyncIndiv u Integer String   deriving (Eq, Ord, Read, Show)  -- | Added in version 1.3.0. recordedIndivEventLabel :: RecordedIndivEvent u -> u-recordedIndivEventLabel (ChannelWrite x _) = x-recordedIndivEventLabel (ChannelRead x _) = x-recordedIndivEventLabel (BarrierSyncIndiv x _) = x+recordedIndivEventLabel (ChannelWrite x _ _) = x+recordedIndivEventLabel (ChannelRead x _ _) = x+recordedIndivEventLabel (BarrierSyncIndiv x _ _) = x recordedIndivEventLabel (ClockSyncIndiv x _ _) = x  -- | Added in version 1.3.0. recordedIndivEventSeq :: RecordedIndivEvent u -> Integer-recordedIndivEventSeq (ChannelWrite _ n) = n-recordedIndivEventSeq (ChannelRead _ n) = n-recordedIndivEventSeq (BarrierSyncIndiv _ n) = n+recordedIndivEventSeq (ChannelWrite _ n _) = n+recordedIndivEventSeq (ChannelRead _ n _) = n+recordedIndivEventSeq (BarrierSyncIndiv _ n _) = n recordedIndivEventSeq (ClockSyncIndiv _ n _) = n -indivRec :: (u -> Integer -> RecordedIndivEvent u)-            -> u -> (u -> Integer) -> (RecordedIndivEvent u)+indivRec :: (u -> Integer -> String -> RecordedIndivEvent u)+            -> u -> (u -> Integer) -> String -> (RecordedIndivEvent u) indivRec r u f = r u (f u) -indivRecJust :: (u -> Integer -> RecordedIndivEvent u)-                -> u -> (u -> Integer) -> Maybe (RecordedIndivEvent u)-indivRecJust r u f = Just $ indivRec r u f+indivRecJust :: (u -> Integer -> String -> RecordedIndivEvent u)+                -> u -> (u -> Integer) -> String -> [RecordedIndivEvent u]+indivRecJust r u f x = [indivRec r u f x]  type RecEvents = ([RecordedEvent Unique], [RecordedIndivEvent Unique]) @@ -105,8 +115,8 @@ nameEvent (t, c) = liftM (++ suffix) $ getName prefix c   where     (prefix, suffix) = case t of-      ChannelComm -> ("_c","")-      BarrierSync -> ("_b","")+      ChannelComm x -> ("_c", if null x then "" else "[" ++ x ++ "]")+      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)@@ -114,47 +124,47 @@                        return (t, c' ++ suffix)   where     (prefix, suffix) = case t of-      ChannelComm -> ("_c","")-      BarrierSync -> ("_b","")+      ChannelComm _ -> ("_c", "")+      BarrierSync _ -> ("_b", "")       ClockSync st -> ("_t", ':' : st)   nameIndivEvent :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) String-nameIndivEvent (ChannelWrite c n) = do c' <- getName "_c" c-                                       return $ c' ++ "![" ++ show n ++ "]"-nameIndivEvent (ChannelRead c n) = do c' <- getName "_c" c-                                      return $ c' ++ "?[" ++ show n ++ "]"-nameIndivEvent (BarrierSyncIndiv c n) = do c' <- getName "_b" c-                                           return $ c' ++ "[" ++ show n ++ "]"+nameIndivEvent (ChannelWrite c n _) = do c' <- getName "_c" c+                                         return $ c' ++ "![" ++ show n ++ "]"+nameIndivEvent (ChannelRead c n _) = do c' <- getName "_c" c+                                        return $ c' ++ "?[" ++ show n ++ "]"+nameIndivEvent (BarrierSyncIndiv c n _) = do c' <- getName "_b" c+                                             return $ c' ++ "[" ++ show n ++ "]" nameIndivEvent (ClockSyncIndiv c n t) = do c' <- getName "_t" c                                            return $ c' ++ ":" ++ t                                              ++ "[" ++ show n ++ "]"  nameIndivEvent' :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) (RecordedIndivEvent String)-nameIndivEvent' (ChannelWrite c n) = do c' <- getName "_c" c-                                        return $ ChannelWrite c' n-nameIndivEvent' (ChannelRead c n) = do c' <- getName "_c" c-                                       return $ ChannelRead c' n-nameIndivEvent' (BarrierSyncIndiv c n) = do c' <- getName "_b" c-                                            return $ BarrierSyncIndiv c' n+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+                                         return $ ChannelRead c' n x+nameIndivEvent' (BarrierSyncIndiv c n x) = do c' <- getName "_b" c+                                              return $ BarrierSyncIndiv c' n x nameIndivEvent' (ClockSyncIndiv c n t) = do c' <- getName "_t" c                                             return $ ClockSyncIndiv c' n t  -type TraceT = StateT TraceStore+type TraceT = ReaderT TraceStore  data TraceStore =-  NoTrace+  NoTrace ProcessId   | Trace (ProcessId, TVar (ChannelLabels Unique), SubTraceStore) -mapSubTrace :: (SubTraceStore -> SubTraceStore) -> TraceStore -> TraceStore-mapSubTrace _ NoTrace = NoTrace-mapSubTrace f (Trace (pid, tv, s)) = Trace (pid, tv, f s)+mapSubTrace :: Monad m => (SubTraceStore -> m ()) -> TraceStore -> m ()+mapSubTrace _ (NoTrace {}) = return ()+mapSubTrace f (Trace (_pid, _tv, s)) = f s  type ChannelLabels u = Map.Map u String  data SubTraceStore =-  Hierarchy (Structured (RecordedIndivEvent Unique))+  Hierarchy (IORef (Structured (RecordedIndivEvent Unique)))   | CSPTraceRev (TVar [(Int, [RecordedEvent Unique])])   | VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent Unique)]) @@ -173,33 +183,45 @@                        writeTVar tv $! foldl (flip addRLE) t (map fst news)                   Trace (pid, _, VCRTraceRev tv) -> do                     t <- readTVar tv-                    let pidSet = (foldl Set.union (Set.singleton pid) $ map snd news)-                        news' = map (\(a,b) -> (b,a)) news-                        t' = case t of-                                -- Trace previously empty:-                               [] -> [Set.fromList news']-                               (z:zs) | shouldMakeNewSetVCR pidSet z-                                         -> Set.fromList news' : t-                                      | otherwise-                                          -> foldl (flip Set.insert) z news' : zs+                    let news' = map (\(a,b) -> (b,a)) news+                        pidSet = (foldl Set.union (Set.singleton pid) $ map fst news')+                        t' = prependVCR t pidSet news'                     writeTVar tv $! t'                   _ -> return () +prependVCR :: Ord u =>+             [Set.Set (Set.Set ProcessId, RecordedEvent u)]+          -> Set.Set ProcessId+          -> [(Set.Set ProcessId, RecordedEvent u)]+          -> [Set.Set (Set.Set ProcessId, RecordedEvent u)]+prependVCR t pidSet news'+  = case t of+      -- Trace previously empty:+      [] -> [Set.fromList news']+      (z:zs) | shouldMakeNewSetVCR pidSet z+                 -> Set.fromList news' : t+             | otherwise+                 -> 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 = modify $ mapSubTrace $ \(Hierarchy es) ->-                  Hierarchy (addParEventsH (map StrEvent e) es)+recordEvent e = ask >>= lift . mapSubTrace rec+  where+    rec (Hierarchy es) = modifyIORef es (addParEventsH (map StrEvent e))+    rec _ = return ()  mergeSubProcessTraces :: [TraceStore] -> TraceT IO () mergeSubProcessTraces ts-  = modify $ mapSubTrace $ \(Hierarchy es) -> Hierarchy (addParEventsH ts' es)+  = ask >>= lift . mapSubTrace merge   where-    ts' = [t | Trace (_,_,Hierarchy t) <- ts]+    ts' = mapM readIORef [t | Trace (_,_,Hierarchy t) <- ts]+    merge (Hierarchy es) = ts' >>= modifyIORef es . addParEventsH+    merge _ = return () -shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent Unique)+shouldMakeNewSetVCR :: Ord u => Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent u)   -> Bool-shouldMakeNewSetVCR newIds existingSet-  = exists existingSet $ \(bigP,_) -> exists bigP $ \p -> exists newIds $ \q ->+shouldMakeNewSetVCR newpids existingSet+  = exists existingSet $ \(bigP,_) -> exists bigP $ \p -> exists newpids $ \q ->       p `pidLessThanOrEqual` q   where     -- Like the any function (flipped), but for sets:@@ -255,38 +277,49 @@ addRLE x nes = (1,[x]):nes  -labelEvent :: Event -> String -> StateT TraceStore IO ()+labelEvent :: Event -> String -> TraceT IO () labelEvent e l   = labelUnique (getEventUnique e) l -labelUnique :: Unique -> String -> StateT TraceStore IO ()+labelUnique :: Unique -> String -> TraceT IO () labelUnique u l-  = do t <- get+  = do t <- ask        case t of-         NoTrace -> return ()+         NoTrace {} -> return ()          Trace (_,tvls,_) -> add tvls   where-    add :: TVar (Map.Map Unique String) -> StateT TraceStore IO ()+    add :: TVar (Map.Map Unique String) -> TraceT IO ()     add tv = liftIO $ atomically $ do       m <- readTVar tv       writeTVar tv $ Map.insert u l m +newIds :: Int -> ProcessId -> [ProcessId]+newIds n pid = let ProcessId parts = pid in+  [ProcessId $ parts ++ [ParSeq i 0] | i <- [0 .. (n - 1)]]  blankTraces :: TraceStore -> Int -> IO [TraceStore]-blankTraces NoTrace n = return $ replicate n NoTrace+blankTraces (NoTrace pid) n = return $ map NoTrace $ newIds n pid blankTraces (Trace (pid, tvls, subT)) n =-  return [Trace (newId, tvls, newSubT) | newId <- newIds]+  sequence [liftM (\s -> Trace (newId, tvls, s)) newSubT | newId <- newIds n pid]   where-    newIds :: [ProcessId]-    newIds = let ProcessId parts = pid in-      [ProcessId $ parts ++ [ParSeq i 0] | i <- [0 .. (n - 1)]]--    newSubT :: SubTraceStore+    newSubT :: IO SubTraceStore     newSubT = case subT of-      Hierarchy {} -> Hierarchy $ RevSeq []-      _ -> subT-+      Hierarchy {} -> liftM Hierarchy $ newIORef $ RevSeq []+      _ -> return subT +-- Taken from base-4, as we only require base-3:+chp_permutations            :: [b] -> [[b]]+chp_permutations xs0        =  xs0 : perms xs0 []+        where+          perms []     _  = []+          perms (t:ts) is = foldr interleave (perms ts (t:is)) (chp_permutations is)+            where+                interleave    xs     r = let (_,zs) = interleave' id xs r in zs+                interleave' _ []     r = (ts, r)+                interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r+                                         in (y:us, f (t:y:us) : zs) +bagsEq :: Eq a => [a] -> [a] -> Bool+bagsEq a b = or [a' == b' | a' <- chp_permutations a, b' <- chp_permutations b]          

@@ -29,7 +29,7 @@  -- | This module contains support for CSP-style tracing.  A CSP trace is simply -- a flat list of events in the order in which they occurred.-module Control.Concurrent.CHP.Traces.CSP (CSPTrace(..), runCHP_CSPTrace, runCHP_CSPTraceAndPrint) where+module Control.Concurrent.CHP.Traces.CSP (CSPTrace(..), getCSPPlain, runCHP_CSPTrace, runCHP_CSPTraceAndPrint) where  import Control.Concurrent.STM import Control.Monad.State@@ -50,7 +50,8 @@ instance Trace CSPTrace where   emptyTrace = CSPTrace (Map.empty, [])   runCHPAndTrace p = do tv <- atomically $ newTVar []-                        runCHPProgramWith' (CSPTraceRev tv) toPublic p+                        let st = CSPTraceRev tv+                        runCHPProgramWith' st (flip toPublic st) p    prettyPrint (CSPTrace (labels, events))     = char '<' <+> (sep $ punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>'@@ -63,6 +64,15 @@   = do list <- atomically $ readTVar tv        return $ CSPTrace (l, concatMap (\(n,es) -> concat $ replicate n $ reverse es) $ reverse list) toPublic _ _ = error "Error in CSP trace -- tracing type got switched"++-- | A helper function for pulling out the interesting bit from a CSP trace processed+-- by labelAll.+--+-- Added in version 1.5.0.+getCSPPlain :: CSPTrace String -> [RecordedEvent String]+getCSPPlain (CSPTrace (ls, t))+  | Map.null ls = t+  | otherwise = error "getCSPPlain: remaining unused labels"  runCHP_CSPTrace :: CHP a -> IO (Maybe a, CSPTrace Unique) runCHP_CSPTrace = runCHPAndTrace

@@ -34,12 +34,13 @@ -- sequentially and parallel-composed traces.  Note that in this tracing -- style, unlike CSP and VCR, events are recorded by /every/ process -- involved in them, not just once per occurrence.-module Control.Concurrent.CHP.Traces.Structural (StructuralTrace(..), EventHierarchy(..), runCHP_StructuralTrace, runCHP_StructuralTraceAndPrint,+module Control.Concurrent.CHP.Traces.Structural (StructuralTrace(..), EventHierarchy(..), getStructuralPlain, runCHP_StructuralTrace, runCHP_StructuralTraceAndPrint,   getAllEventsInHierarchy) where  import Control.Applicative hiding (empty) import Control.Monad.State import qualified Data.Foldable as F+import Data.IORef import Data.List import qualified Data.Map as Map import Data.Maybe@@ -54,12 +55,27 @@ -- count is a replicator count for that list of sequential items. -- -- The Show, Read, Foldable and Traversable instances were added in version 1.3.0.+--+-- The Eq instance was added in version 1.5.0. data EventHierarchy a =   SingleEvent a   | StructuralSequence Int [EventHierarchy a]   | StructuralParallel [EventHierarchy a]   deriving (Show, Read) +instance Eq a => Eq (EventHierarchy a) where+  (SingleEvent x) == (SingleEvent y) = x == y+  (StructuralSequence m es) == (StructuralSequence m' es')+    = concat (replicate m es) == concat (replicate m' es')+  (StructuralParallel es) == (StructuralParallel es')+    = es `bagsEq` es'++  (StructuralSequence 1 [x]) == y = x == y+  x == (StructuralSequence 1 [y]) = x == y+  (StructuralParallel [x]) == y = x == y+  x == (StructuralParallel [y]) = x == y+  _ == _ = False+ instance Functor EventHierarchy where   fmap f (SingleEvent x) = SingleEvent $ f x   fmap f (StructuralSequence n es) = StructuralSequence n $ map (fmap f) es@@ -93,7 +109,9 @@  instance Trace StructuralTrace where   emptyTrace = StructuralTrace (Map.empty, Nothing)-  runCHPAndTrace p = runCHPProgramWith' (Hierarchy $ RevSeq []) toPublic p+  runCHPAndTrace p = do trV <- newIORef $ RevSeq []+                        let st = (Hierarchy trV)+                        runCHPProgramWith' st (flip toPublic st) p    prettyPrint (StructuralTrace (_,Nothing)) = empty   prettyPrint (StructuralTrace (labels, Just h))@@ -114,8 +132,9 @@     = StructuralTrace (Map.empty, Just $ evalState (T.mapM nameIndivEvent' h) labels)  toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (StructuralTrace Unique)-toPublic l (Hierarchy h)-  = return $ StructuralTrace (l, conv h)+toPublic l (Hierarchy hv)+  = do h <- readIORef hv+       return $ StructuralTrace (l, conv h)   where     nonEmptyListToMaybe :: ([a] -> b) -> [a] -> Maybe b     nonEmptyListToMaybe _ [] = Nothing@@ -136,6 +155,15 @@         trans = mapToMaybe (StructuralSequence 1) (\(n,s) -> mapToMaybe (StructuralSequence n) conv $           reverse s) rev toPublic _ _ = error "Error in Structural trace -- tracing type got switched"++-- | A helper function for pulling out the interesting bit from a Structural trace processed+-- by labelAll.+--+-- Added in version 1.5.0.+getStructuralPlain :: StructuralTrace String -> Maybe (EventHierarchy (RecordedIndivEvent String))+getStructuralPlain (StructuralTrace (ls, t))+  | Map.null ls = t+  | otherwise = error "getStructuralPlain: remaining unused labels"  runCHP_StructuralTrace :: CHP a -> IO (Maybe a, StructuralTrace Unique) runCHP_StructuralTrace = runCHPAndTrace

@@ -30,13 +30,18 @@ -- This module contains a trace-type that does not record anything.  This is -- generally not needed (just use runCSP without tracing) but is included in -- the library for completeness.-module Control.Concurrent.CHP.Traces.TraceOff (TraceOff) where+module Control.Concurrent.CHP.Traces.TraceOff (TraceOff, runCHP_TraceOff) where +import Control.Monad+import Data.Unique+import Text.PrettyPrint.HughesPJ+ import Control.Concurrent.CHP.Base+import Control.Concurrent.CHP.ProcessId import Control.Concurrent.CHP.Traces.Base -import Text.PrettyPrint.HughesPJ + -- | A trace type that does not record anything. newtype TraceOff a = TraceOff () @@ -44,9 +49,14 @@   show = const ""  instance Trace TraceOff where-  runCHPAndTrace = runCHPProgramWith NoTrace (const $ TraceOff ())+  runCHPAndTrace = liftM (flip (,) (TraceOff ())) . runCHPProgramWith (NoTrace rootProcessId)   emptyTrace = TraceOff ()   prettyPrint = const empty   labelAll = const emptyTrace  +-- | A type-constrained version of 'runCHPAndTrace'.  This is semantically identical+-- to 'runCHP', but this function is useful with the 'qcCHP'' function in the testing+-- module.+runCHP_TraceOff :: CHP a -> IO (Maybe a, TraceOff Unique)+runCHP_TraceOff = runCHPAndTrace

@@ -31,7 +31,7 @@ -- reasnoning trace is a list of sets of events.  Each set contains independent -- events that have no causal relationship between them.  Hopefully we will -- publish a paper explaining all this in detail soon.-module Control.Concurrent.CHP.Traces.VCR (VCRTrace(..), runCHP_VCRTrace, runCHP_VCRTraceAndPrint) where+module Control.Concurrent.CHP.Traces.VCR (VCRTrace(..), getVCRPlain, runCHP_VCRTrace, runCHP_VCRTraceAndPrint) where  import Control.Concurrent.STM import Control.Monad.State@@ -57,7 +57,8 @@ instance Trace VCRTrace where   emptyTrace = VCRTrace (Map.empty, [])   runCHPAndTrace p = do tv <- atomically $ newTVar []-                        runCHPProgramWith' (VCRTraceRev tv) toPublic p+                        let st = VCRTraceRev tv+                        runCHPProgramWith' st (flip toPublic st) p    prettyPrint (VCRTrace (labels, eventSets))     = char '<' <+> (sep $ punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>'@@ -82,6 +83,14 @@ nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels 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+-- by labelAll.+--+-- Added in version 1.5.0.+getVCRPlain :: VCRTrace String -> [Set.Set (RecordedEvent String)]+getVCRPlain (VCRTrace (ls, t))+  | Map.null ls = t+  | otherwise = error "getVCRPlain: remaining unused labels"  runCHP_VCRTrace :: CHP a -> IO (Maybe a, VCRTrace Unique) runCHP_VCRTrace = runCHPAndTrace

@@ -156,6 +156,15 @@ (|->|) p q x y = do c <- oneToOneChannel                     runParallel_ [p x (writer c), q (reader c) y] +-- | Like (|->|), but labels the channel and uses show for the traces.+--+-- Added in version 1.5.0.+(|->|^) :: Show b => (a -> Chanout b ->  CHP ()) -> (String, Chanin b -> c -> CHP ()) ->+  (a -> c -> CHP ())+(|->|^) p (l, q) x y+  = do c <- oneToOneChannel' $ chanLabel l+       runParallel_ [p x (writer c), q (reader c) y]+ -- | Process composition that works with processes that connect with a channel in both -- directions.  Like (|->|), but connects a channel in each direction. --@@ -208,4 +217,45 @@ (<->|) p q x = do c <- oneToOneChannel                   d <- oneToOneChannel                   runParallel_ [p (reader d, writer c), q (reader c, writer d) x]-                   ++{-+-- Like runParallel, but offers a choice between the leading event of each+-- parallel branch such that if any leading event of a parallel branch is+-- poisoned, any siblings still waiting for their leading event will also be+-- poisoned.  Note however that any handlers in the sibling branches will not+-- execute, as technically they did not encounter poison.+--+-- If all the branches have just one event (e.g. a readChannel), this ensures that+-- the parallel composition will not deadlock in the presence of poison.+--+-- Added in version 1.5.0.+runParallelPoison :: [CHP a] -> CHP [a]+runParallelPoison ps+  = do b <- newBarrierWithLabel "runParallelPoison"+       -- The barrier can never sync properly, but it can be poisoned:+       enroll b $ const $ enrollList (replicate (length ps) b) $+         \ebs -> runParallel $ zipWith useBar ebs ps+  where+    useBar :: EnrolledBarrier -> CHP a -> CHP a+    useBar b p = (p <-> (syncBarrier b >> throwPoison)) `onPoisonRethrow` (poison b)++-- Like runParallel_, but offers a choice between the leading event of each+-- parallel branch such that if any leading event of a parallel branch is+-- poisoned, any siblings still waiting for their leading event will also be+-- poisoned.  Note however that any handlers in the sibling branches will not+-- execute, as technically they did not encounter poison.+--+-- If all the branches have just one event (e.g. a readChannel), this ensures that+-- the parallel composition will not deadlock in the presence of poison.+--+-- Added in version 1.5.0.+runParallelPoison_ :: [CHP a] -> CHP ()+runParallelPoison_ ps+  = do b <- newBarrierWithLabel "runParallelPoison"+       -- The barrier can never sync properly, but it can be poisoned:+       enroll b $ const $ enrollList (replicate (length ps) b) $+         \ebs -> runParallel_ $ zipWith useBar ebs ps+  where+    useBar :: EnrolledBarrier -> CHP a -> CHP a+    useBar b p = (p <-> (syncBarrier b >> throwPoison)) `onPoisonRethrow` (poison b)+-}

@@ -1,5 +1,5 @@ Name:            chp-Version:         1.4.0+Version:         1.5.0 Synopsis:        An implementation of concurrency ideas from Communicating Sequential Processes License:         BSD3 License-file:    LICENSE@@ -30,6 +30,11 @@                  Control.Concurrent.CHP.BroadcastChannels                  Control.Concurrent.CHP.Buffers                  Control.Concurrent.CHP.Channels+                 Control.Concurrent.CHP.Channels.BroadcastReduce+                 Control.Concurrent.CHP.Channels.Communication+                 Control.Concurrent.CHP.Channels.Creation+                 Control.Concurrent.CHP.Channels.Ends+                 Control.Concurrent.CHP.Channels.Synonyms                  Control.Concurrent.CHP.Clocks                  Control.Concurrent.CHP.Common                  Control.Concurrent.CHP.Console@@ -45,7 +50,8 @@                  Control.Concurrent.CHP.Utils  Other-modules:   Control.Concurrent.CHP.Base-                 Control.Concurrent.CHP.CSP+                 Control.Concurrent.CHP.Channels.Base+                 Control.Concurrent.CHP.CSP                                   Control.Concurrent.CHP.Event                  Control.Concurrent.CHP.Guard                  Control.Concurrent.CHP.Mutex