chp 1.2.0 → 1.3.0

raw patch · 18 files changed

+547/−393 lines, 18 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/Concurrent/CHP/Alt.hs +86/−127
• Control/Concurrent/CHP/Barriers.hs +2/−2
• Control/Concurrent/CHP/Base.hs +34/−31
• Control/Concurrent/CHP/BroadcastChannels.hs +12/−12
• Control/Concurrent/CHP/CSP.hs +9/−11
• Control/Concurrent/CHP/Channels.hs +4/−4
• Control/Concurrent/CHP/Clocks.hs +24/−21
• Control/Concurrent/CHP/Event.hs +177/−74
• Control/Concurrent/CHP/Guard.hs +16/−9
• Control/Concurrent/CHP/Monad.hs +33/−11
• Control/Concurrent/CHP/Parallel.hs +6/−6
• Control/Concurrent/CHP/Traces.hs +2/−0
• Control/Concurrent/CHP/Traces/Base.hs +86/−53
• Control/Concurrent/CHP/Traces/CSP.hs +9/−11
• Control/Concurrent/CHP/Traces/Structural.hs +26/−8
• Control/Concurrent/CHP/Traces/TraceOff.hs +3/−2
• Control/Concurrent/CHP/Traces/VCR.hs +15/−8
• chp.cabal +3/−3

@@ -107,12 +107,15 @@ import Control.Monad.State import Control.Monad.Trans import Data.List+import qualified Data.Map as Map import Data.Maybe+import Data.Unique import System.IO  import Control.Concurrent.CHP.Base import Control.Concurrent.CHP.Event import Control.Concurrent.CHP.Guard+import Control.Concurrent.CHP.Monad import Control.Concurrent.CHP.Parallel import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.Traces.Base@@ -166,7 +169,7 @@ -- Whichever channel is chosen by both processes will not satisfy the priority -- at one end (if such priority between channels was supported). priAlt :: [CHP a] -> CHP a-priAlt items = (liftPoison $ priAlt' $ map wrapPoison items) >>= checkPoison+priAlt items = unwrapPoison $ priAlt' $ map wrapPoison items  -- | A useful operator to perform an 'alt'.  This operator is associative, -- and has arbitrary priority.  When you have lots of guards, it is probably easier@@ -281,26 +284,37 @@ -- behaviour as x. -- -- Added in version 1.1.0-every :: [CHP a] -> CHP [a]-every [] = liftPoison $ AltableT (SkipGuard [], return []) (return [])-every xs = liftPoison (AltableT (foldl1 merge $ map blankEvent gs, getEventPoison True) (return-  $ NoPoison False)) >>= checkPoison >>= \b -> if b then runParallel (map (unwrapPoison . liftTrace) bodies) else alt [every xs]+every :: forall a. [CHP a] -> CHP [a]+every [] = skip >> return []+every xs = liftPoison (AltableT (liftM ((:[]) . flip (,) (return True)) $ gs >>= foldM1 merge) (return+   False)) >>= \b -> if b then runParallel (map (unwrapPoison . liftTrace) bodies) else alt [every xs]   where-    (gs, bodies) = unzip $ map (pullOutAltable . wrapPoison) xs+    both :: Either String [(Guard, TraceT IO (WithPoison a))]+    both = mapM (checkSingle . pullOutAltable . wrapPoison) xs+    gs :: Either String [Guard]+    gs = liftM (map fst) both+    bodies = map snd $ fromRight both+    fromRight (Right x) = x+    fromRight _ = error "Reached unreachable code in every; bodies executed after bad guard" -    blankEvent :: Guard -> Guard-    blankEvent (EventGuard _ rec act es) = EventGuard [] rec act es-    blankEvent g = g+    checkSingle (Left err) = Left err+    checkSingle (Right []) = Left "Bad guard in every"+    checkSingle (Right [x]) = Right x+    checkSingle (Right _) = Left "Alt inside every" -    merge :: Guard -> Guard -> Guard-    merge (SkipGuard _) g = g-    merge g (SkipGuard _) = g-    merge StopGuard _ = StopGuard-    merge _ StopGuard = StopGuard-    merge (EventGuard _ recx actx esx) (EventGuard _ recy acty esy)-      = EventGuard [] (recx ++ recy) (actx >> acty) (esx ++ esy)-    merge _ _ = BadGuard "merging unsupported guards"+    merge :: Guard -> Guard -> Either String Guard+    merge SkipGuard g = return g+    merge g SkipGuard = return g+    merge StopGuard _ = return StopGuard+    merge _ StopGuard = return StopGuard+    merge (EventGuard recx actx esx) (EventGuard recy acty esy)+      = return $ EventGuard (\n -> recx n ++ recy n) (actx >> acty) (esx ++ esy)+    merge _ _ = badGuard "merging unsupported guards" +    foldM1 :: Monad m => (b -> b -> m b) -> [b] -> m b+    foldM1 f (y:ys) = foldM f y ys+    foldM1 _ _ = error "Reached unreachable code in every; guards empty in non-empty case"+ -- | A useful operator that acts like 'every'.  The operator is associative and -- commutative (see 'every' for notes on idempotence).  When you have lots of things -- to join with this operator, it's probably easier to use the 'every' function.@@ -336,110 +350,52 @@ -- I had some memory efficiency problems so I went with the state-monad-based -- approach instead. -priAlt' :: forall a. [CHP' a] -> CHP' a+priAlt' :: forall a. [CHP' (WithPoison a)] -> CHP' (WithPoison a) priAlt' items   -- Our guard is a nested guard of all our sub-guards.   -- Our action-if-not-guard is to do the selection ourselves.-  -- Our body is to read the numbered list, strip one off and follow the path,-  -- ignoring the action-if-not-guard of the chosen body-  = AltableT (NestedGuards $ wrappedGuards-               ,executeNumberedBody)-             (selectFromGuards >> executeNumberedBody)+  = AltableT flattenedGuards selectFromGuards   where-    wrappedGuards :: [Guard]-    wrappedGuards = map wrap flattenedGuards-      where-        wrap :: (Int, Guard) -> Guard-        wrap (n, SkipGuard ns) = SkipGuard $ n : ns-        wrap (n, EventGuard ns e act ab) = EventGuard (n:ns) e act ab-        wrap (n, TimeoutGuard g) = TimeoutGuard $-          do g' <- g-             return $ do ns <- g'-                         return (n : ns)-        wrap (_, g@(BadGuard _)) = g-        wrap (_, _) = BadGuard "wrapped"--    -- Polls the available guards, but ignores timeout guards and alting barrier-    -- guards-    checkNormalGuards :: STM (Maybe Int)-    checkNormalGuards = foldl1 orElse $-                          (map checkGuard flattenedGuards) ++ [return Nothing]-      where-        checkGuard :: (Int, Guard) -> STM (Maybe Int)-        checkGuard (n, BadGuard _) = return $ Just n-        checkGuard (n, SkipGuard {}) = return $ Just n-        checkGuard (_, _) = retry--    -- Waits for one of the normal (non-alting barrier) guards to be ready,-    -- or the given transaction to complete-    waitNormalGuards :: STM [Int] -> IO (Bool, [Int])-    waitNormalGuards extra-      = do guards <- mapM enable wrappedGuards-           atomically $ foldl1 orElse (wrap True extra : map (wrap False) guards)-      where-        enable :: Guard -> IO (STM [Int])-        enable (BadGuard _) = return $ return []-        enable (SkipGuard ns) = return $ return ns-        enable (TimeoutGuard g) = g-        enable _ = return retry -- This effectively ignores other guards--        wrap :: Bool -> STM [Int] -> STM (Bool, [Int])-        wrap b m = do x <- m-                      return (b, x)--     -- The list of guards without any NestedGuards or StopGuards:-    flattenedGuards :: [(Int, Guard)]-    flattenedGuards = (flatten $ zip [0..] $ map (fst . pullOutAltable) items)+    flattenedGuards :: Either String [(Guard, TraceT IO (WithPoison a))]+    flattenedGuards = liftM (filter (not . isStopGuard . fst)) altStuff       where-        flatten :: [(Int, Guard)] -> [(Int,Guard)]-        flatten [] = []-        flatten ((n,x):xs) = case x of-          NestedGuards gs -> flatten $ zip (repeat n) gs ++ xs-          StopGuard -> flatten xs-          g -> (n, g) : flatten xs+        altStuff :: Either String [(Guard, TraceT IO (WithPoison a))]+        altStuff = liftM concat $ mapM pullOutAltable items      -- The alting barrier guards:-    eventGuards :: [([RecordedIndivEvent], [Int], STM (), [Event])]-    eventGuards = [(rec,ns,act,ab) | EventGuard ns rec act ab <- wrappedGuards]--    -- We must use isPrefixOf, because things are added in the case of poison-    findEventAssoc :: [Int] -> [RecordedIndivEvent]-    findEventAssoc x = case filter (\(_,y,_,_) -> y `isPrefixOf` x) eventGuards of-      [(rec,_,_,_)] -> rec-      _ -> error "Could not find associated event in alt, internal logic error" -                   -        -    --    -- Stores a list of ints in the state-    storeChoice :: [Int] -> TraceT IO ()-    storeChoice ns = modify (\(_, es) -> (ns, es))--    isBadGuard :: Guard -> Bool-    isBadGuard (BadGuard _) = True-    isBadGuard _ = False+    eventGuards :: [Guard] -> [((Unique -> Integer) -> [RecordedIndivEvent Unique], Int, STM (), [Event])]+    eventGuards guards = [(rec,n,act,ab) | (n, EventGuard rec act ab) <- zip [0..] guards] -    -- Performs the select operation on all the guards.  The choice is stored-    -- in the state ready to execute the bodies-    selectFromGuards :: TraceT IO ()-    selectFromGuards-      | null eventGuards-         = do (_,ns) <- liftIO $ waitNormalGuards retry-              storeChoice ns-      | any isBadGuard wrappedGuards-         = let str = head [s | BadGuard s <- wrappedGuards]-               err = "ALTing not supported on given guard: " ++ str+    -- Performs the select operation on all the guards, and then executes the body+    selectFromGuards :: TraceT IO (WithPoison a)+    selectFromGuards = case flattenedGuards of+      Left str ->+           let err = "ALTing not supported on given guard: " ++ str            in liftIO $ do hPutStrLn stderr err                           ioError $ userError err-      | otherwise-         = do earliestReady <- liftIO $ atomically checkNormalGuards++      Right both+        | null (eventGuards $ map fst both) ->+           join $ liftM snd $ liftIO $ waitNormalGuards both retry+        | otherwise ->+           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))               tv <- liftIO . atomically $ newTVar Nothing               pid <- getProcessId-              (_, tr) <- get+              tr <- get               mn <- liftIO . atomically $ do                       ret <- enableEvents tv pid-                        (maybe id take earliestReady [(x,y,z) | (_,x,y,z)<-eventGuards])+                        (maybe id take earliestReady [(Signal $ NoPoison x,y,z) | (_,x,y,z)<-eventGuards guards])                         (isNothing earliestReady)                       maybe (return ()) (\(_,es) -> recordEventLast (nub es) tr) ret                       return ret@@ -447,47 +403,50 @@                 -- An event -- and we were the last person to arrive:                 -- The event must have been higher priority than any other                 -- ready guards-                (Just (ns, _), _) ->-                    do recordEvent $ findEventAssoc ns-                       storeChoice ns+                (Just ((n, m), _), _) -> recordAndRun m n                 -- No events were ready, but there was an available normal                 -- guards.  Re-run the normal guards; at least one will be ready                 (Nothing, Just _) ->-                  do (_, ns) <- liftIO $ waitNormalGuards retry-                     storeChoice ns+                  join $ liftM snd $ liftIO $ waitNormalGuards both retry                 -- No events ready, no other guards ready either                 -- Events will have been enabled; wait for everything:                 (Nothing, Nothing) ->-                    do (wasAltingBarrier, ns) <- liftIO $ waitNormalGuards $ waitAlting tv+                    do (wasAltingBarrier, (n, m)) <- liftIO $ waitNormalGuards+                         guardsAndSignal $ waitAlting tv                        if wasAltingBarrier-                         then recordEvent (findEventAssoc ns) >> storeChoice ns -- It was a barrier, all done+                         then recordAndRun m n -- It was a barrier, all done                          else                             -- Another guard fired, but we must check in case                             -- we have meanwhile been committed to taking an                             -- event:-                            do mn' <- liftIO . atomically $ disableEvents tv (concatMap fourth eventGuards)+                            do mn' <- liftIO . atomically $ disableEvents tv (concatMap fourth+                                 $ eventGuards guards)                                case mn' of                                  -- An event overrides our non-event choice:-                                 Just bns -> recordEvent (findEventAssoc bns) >> storeChoice bns+                                 Just (x, m') -> recordAndRun m' x                                  -- Go with the original option, no events                                  -- became ready:-                                 Nothing -> storeChoice ns+                                 Nothing -> justRun n       where-        waitAlting :: TVar (Maybe [Int]) -> STM [Int]+        waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique Integer)         waitAlting tv = do b <- readTVar tv                            case b of                              Nothing -> retry                              Just ns -> return ns         fourth (_,_,_,c) = c -    executeNumberedBody :: TraceT IO a-    executeNumberedBody-      = do st <- get-           case st of-             ((g:gs), es) ->-               do put (gs, es)-                  snd $ pullOutAltable (items !! g)-             ([], _) -> liftIO $-               do hPutStrLn stderr "ALTing not supported on given guard (no index)"-                  ioError $ userError "ALTing not supported on given guard (no index)"+        makeLookup :: Map.Map Unique Integer -> Unique -> Integer+        makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m ++-- Waits for one of the normal (non-alting barrier) guards to be ready,+-- or the given transaction to complete+waitNormalGuards :: [(Guard, b)] -> STM b -> IO (Bool, b)+waitNormalGuards guards extra+  = do enabled <- mapM enable guards+       atomically $ foldl1 orElse (liftM ((,) True) extra : enabled)+  where+    enable :: (Guard, b) -> IO (STM (Bool, b))+    enable (SkipGuard, x) = return $ return (False, x)+    enable (TimeoutGuard g, x) = liftM (>> return (False, x)) g+    enable _ = return retry -- This effectively ignores other guards

@@ -91,13 +91,13 @@ -- | 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 (Just . BarrierSyncIndiv)+syncBarrier = syncBarrierWith (indivRecJust BarrierSyncIndiv)      -- | Finds out the current phase a barrier is on. currentPhase :: Enrolled PhasedBarrier phase -> CHP phase currentPhase (Enrolled (Barrier (_, tv, _))) = liftIO $ atomically $ readTVar tv -repeatUntil :: (Monad m, Eq a) => (a -> Bool) -> m a -> m ()+repeatUntil :: (Monad m) => (a -> Bool) -> m a -> m () repeatUntil target comp = do x <- comp                              unless (target x) $ repeatUntil target comp 

@@ -33,20 +33,23 @@ -- monads, and poison.  Not publicly visible. module Control.Concurrent.CHP.Base where +import Control.Applicative+import Control.Arrow import Control.Concurrent.STM-#if __GLASGOW_HASKELL__ >= 609+-- #if __GLASGOW_HASKELL__ >= 609 -- I can't figure out the new Exception system in GHC 6.10 and how I catch all -- exceptions (see GHC bug #2655), so I'm just going to use the old system:-import qualified Control.OldException as C-#else-import qualified Control.Exception as C-#endif+--import qualified Control.OldException as C+-- #else+--import qualified Control.Exception as C+-- #endif import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Monad.Trans import qualified Data.Map as Map+import Data.Unique import qualified Text.PrettyPrint.HughesPJ  import Control.Concurrent.CHP.Guard@@ -72,11 +75,15 @@ -- 'Control.Concurrent.CHP.Monad.runCHP_' to execute programs in this -- monad. newtype CHP a = PoisonT (ErrorT PoisonError CHP' a)-  deriving (Monad, MonadIO)+  deriving (Functor, Monad, MonadIO) +instance Applicative CHP where+  pure = return+  (<*>) = ap+ data CHP' a = AltableTRet a | AltableT {   -- The guard, and body to execute after the guard-  getAltable :: (Guard, TraceT IO a),+  getAltable :: Either String [(Guard, TraceT IO a)],   -- The body to execute without a guard   getStandard :: TraceT IO a } @@ -94,17 +101,22 @@ -- but because its type is only determined by its return type, you may wish -- to use the already-typed functions offered in each trace module -- see the -- modules in "Control.Concurrent.CHP.Traces".-class Show t => Trace t where+--+-- The trace type involved became parameterised in version 1.3.0.+class Trace t where   -- | Runs the given CHP program, and returns its return value and the trace.   --  The return value is a Maybe type because the process may have exited   -- due to uncaught poison.  In that case Nothing is return as the result.-  runCHPAndTrace :: CHP a -> IO (Maybe a, t)+  runCHPAndTrace :: CHP a -> IO (Maybe a, t Unique)   -- | The empty trace.-  emptyTrace :: t+  emptyTrace :: t u   -- | Pretty-prints the given trace using the "Text.PrettyPrint.HughesPJ"   -- module.-  prettyPrint :: t -> Text.PrettyPrint.HughesPJ.Doc+  prettyPrint :: Ord u => t u -> Text.PrettyPrint.HughesPJ.Doc +  -- | Added in version 1.3.0.+  labelAll :: Ord u => t u -> t String+ -- | A class indicating that something is poisonable. class Poisonable c where   -- | Poisons the given item.@@ -124,13 +136,13 @@   AltableTRet x -> return x   AltableT _ st -> st -pullOutAltable :: CHP' a -> (Guard, TraceT IO a)+pullOutAltable :: CHP' a -> Either String [(Guard, TraceT IO a)] pullOutAltable m = case m of-  AltableTRet x -> (badGuard "return", return x)+  AltableTRet _ -> badGuard "return"   AltableT alt _ -> alt  liftTrace :: TraceT IO a -> CHP' a-liftTrace m = AltableT (badGuard "lifted action", m) m+liftTrace m = AltableT (badGuard "lifted action") m  wrapPoison :: CHP a -> CHP' (WithPoison a) wrapPoison (PoisonT m) = (liftM $ either (const PoisonItem) NoPoison) $@@ -184,37 +196,28 @@ liftSTM = liftIO . atomically  getProcessId :: TraceT IO ProcessId-getProcessId = do (_, x) <- get+getProcessId = do x <- get                   case x of                     Trace (pid,_,_) -> return pid                     NoTrace -> return emptyProcessId  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)+  = do (x, t) <- runStateT (liftM (either (const Nothing) Just) $ pullOutStandard $ runErrorT p) start        return (x, f t) -runCHPProgramWith' :: SubTraceStore -> (ChannelLabels -> SubTraceStore -> IO t) -> CHP a -> IO (Maybe a, t)+runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> SubTraceStore -> 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-                             `C.catch` const (return (Nothing,-                               Trace (undefined, undefined, subStart)))+--                             `C.catch` const (return (Nothing,+--                               Trace (undefined, undefined, subStart)))        l <- atomically $ readTVar tv        t' <- f l t        return (x, t') -getEventPoison :: a -> TraceT IO (WithPoison a)-getEventPoison x-        = do (ns,y) <- get-             case ns of-               [] -> return $ NoPoison x-               _ -> do put ([],y)-                       return PoisonItem-- -- ========== -- Instances:  -- ==========@@ -243,10 +246,10 @@   -- f :: a -> AltableT g m b   m >>= f = case m of              AltableTRet x -> f x-             AltableT (grd, altBody) nonAlt ->-              let altBody' = altBody >>= pullOutStandard . f+             AltableT altBody nonAlt ->+              let altBody' = liftM (map $ second (>>= pullOutStandard . f)) altBody                   nonAlt' = nonAlt >>= pullOutStandard . f-              in AltableT (grd, altBody') nonAlt'+              in AltableT altBody' nonAlt'   return x = AltableTRet x  instance MonadIO CHP' where

@@ -119,24 +119,24 @@  instance WriteableChannel BroadcastChanout where   extWriteChannel (BO (BC (b, tv))) m-    = do syncBarrierWith (Just . ChannelWrite)+    = do syncBarrierWith (indivRecJust ChannelWrite)            $ Enrolled b          m >>= liftIO . atomically . writeTVar tv-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b          return ()  instance ReadableChannel (Enrolled BroadcastChanin) where   extReadChannel (Enrolled (BI (BC (b, tv)))) f-    = do syncBarrierWith (Just . ChannelRead)+    = do syncBarrierWith (indivRecJust ChannelRead)            $ Enrolled b-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b          x <- liftIO (atomically $ readTVar tv)          y <- f x-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b          return y @@ -204,25 +204,25 @@  instance WriteableChannel (Enrolled ReduceChanout) where   extWriteChannel (Enrolled (GO (GC (b, tv, (f,_))))) m-    = do syncBarrierWith (Just . ChannelWrite)+    = do syncBarrierWith (indivRecJust ChannelWrite)            $ Enrolled b          m >>= liftIO . atomically . \x -> readTVar tv >>= writeTVar tv . f x-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b          return ()  instance ReadableChannel ReduceChanin where   extReadChannel (GI (GC (b, tv, (_, empty)))) f-    = do syncBarrierWith (Just . ChannelRead)+    = do syncBarrierWith (indivRecJust ChannelRead)            $ Enrolled b-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b          x <- liftIO (atomically $ readTVar tv)          y <- f x          liftIO (atomically $ writeTVar tv empty)-         syncBarrierWith (const Nothing)+         syncBarrierWith (const $ const Nothing)            $ Enrolled b          return y 

@@ -48,20 +48,18 @@ import Control.Concurrent.CHP.Enroll import Control.Concurrent.CHP.Guard import Control.Concurrent.CHP.Mutex-import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.Traces.Base  -- First engages in event, then executes the body.  The returned value is suitable -- for use in an alt-buildOnEventPoison :: (Unique -> Maybe RecordedIndivEvent) -> Event.Event -> STM () -> CHP a -> CHP a+buildOnEventPoison :: (Unique -> (Unique -> Integer) -> Maybe (RecordedIndivEvent Unique)) -> Event.Event -> STM () -> CHP a -> CHP a buildOnEventPoison rec e act body-  = liftPoison (AltableT (theGuard, getEventPoison True)-                   (return $ NoPoison False))-    >>= checkPoison >>= \b -> if b then body else-      alt [liftPoison $ AltableT (theGuard, getEventPoison ()) (return $ NoPoison())] >>=-        checkPoison >> 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 (maybeToList . rec (Event.getEventUnique e)) act [e]  scopeBlock :: CHP a -> (a -> CHP b) -> IO () -> CHP b scopeBlock start body errorEnd@@ -75,7 +73,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.-syncBarrierWith :: (Unique -> Maybe RecordedIndivEvent)+syncBarrierWith :: (Unique -> (Unique -> Integer) -> Maybe (RecordedIndivEvent Unique))   -> Enrolled PhasedBarrier phase -> CHP phase syncBarrierWith rec (Enrolled (Barrier (e,tv, fph)))     = buildOnEventPoison rec e incPhase@@ -115,13 +113,13 @@     = 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 get               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 get               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)          x <- m          liftSTM (Event.enrollEvent e) >>= checkPoison

@@ -322,7 +322,7 @@ instance ReadableChannel Chanin where   readChannel (Chanin c)     = let (e, m) = startReadChannelC c in-      buildOnEventPoison (Just . ChannelRead) e (return ()) (liftSTM $+      buildOnEventPoison (indivRecJust ChannelRead) e (return ()) (liftSTM $         do x <- m            endReadChannelC c            return x) >>= checkPoison@@ -330,7 +330,7 @@   extReadChannel (Chanin c) body     = let (e, m) = startReadChannelC c in       scopeBlock-        (buildOnEventPoison (Just . ChannelRead) e (return ()) (liftSTM m) >>= checkPoison)+        (buildOnEventPoison (indivRecJust ChannelRead) e (return ()) (liftSTM m) >>= checkPoison)         (\val -> do x <- body val                     liftSTM $ endReadChannelC c                     return x)@@ -339,7 +339,7 @@ instance WriteableChannel Chanout where   writeChannel (Chanout c) x     = let (e, m) = startWriteChannelC c in-        buildOnEventPoison (Just . ChannelWrite) e (return ())+        buildOnEventPoison (indivRecJust ChannelWrite) e (return ())           (liftM2 (++)             (liftSTM $ sequence [m, sendWriteChannelC c x])             (liftSTM $ sequence [endWriteChannelC c]))@@ -347,7 +347,7 @@   extWriteChannel (Chanout c) body     = let (e, m) = startWriteChannelC c in       scopeBlock-        (buildOnEventPoison (Just . ChannelWrite)+        (buildOnEventPoison (indivRecJust ChannelWrite)           e (return ()) (liftSTM m) >>= checkPoison)         (const $ sequence [body >>= liftSTM . sendWriteChannelC c                           ,liftSTM (endWriteChannelC c)]

@@ -105,8 +105,10 @@ -- This is also true if not every process enrolled on a barrier wants to take action -- every phase -- a clock allows those processes to remain sleeping, rather than -- wake up only to sleep again,+--  -- * Barriers support choice, but clocks do not.  This means clocks are both -- less powerful, but also faster than barriers.+--  -- * Barriers choose their next phase using their incrementing function.  Clocks -- are more flexible, in that their next phase is chosen solely by looking at the -- requests from the various processes.  Hence why Double is a suitable type for@@ -120,11 +122,11 @@ import Control.Monad hiding (mapM, mapM_) import Control.Monad.State (get) import Control.Monad.Trans+import Data.Foldable (mapM_) -- Needed for testing: --import Data.Maybe import qualified Data.Sequence as Seq import qualified Data.Set as Set-import Data.Traversable import Data.Unique import Prelude hiding (mapM, mapM_) @@ -218,31 +220,30 @@ poisonTVar :: TVar (WithPoison a) -> STM () poisonTVar = flip writeTVar PoisonItem --- Provides mapM_ for Traversable:-mapM_ :: (Traversable t, Monad m) => (a -> m b) -> t a -> m ()-mapM_ f x = mapM f x >> return ()+type TimeVar time = TVar (WithPoison (Maybe (time, Integer)))  data TimerData time   = TimerData {       curTime :: time+     ,seqTime :: Integer      ,enrolledOnTimer :: Int      -- A slightly more efficient way of knowing current offers:      ,offeredOnTimer :: Int       -- Offers are held, sorted by time.  We rely on the fact that for all x,       -- Nothing < Just x-     ,timerOffersNext :: Maybe ([ProcessId], TVar (WithPoison (Maybe time)))-     ,timerOffersBefore :: [([ProcessId], (time, TVar (WithPoison (Maybe time))))]-     ,timerOffersAfter :: [([ProcessId], (time, TVar (WithPoison (Maybe time))))]-     ,timerEventPool :: Seq.Seq (TVar (WithPoison (Maybe time)))+     ,timerOffersNext :: Maybe ([ProcessId], TimeVar time)+     ,timerOffersBefore :: [([ProcessId], (time, TimeVar time))]+     ,timerOffersAfter :: [([ProcessId], (time, TimeVar time))]+     ,timerEventPool :: Seq.Seq (TimeVar time)      } -- Uncomment these lines while testing: --  deriving (Eq, Show) --instance Show (TVar (WithPoison (Maybe a))) where show = const "<tv>"  emptyTimerData :: time -> TimerData time-emptyTimerData t = TimerData t 0 0 Nothing [] [] Seq.empty+emptyTimerData t = TimerData t 0 0 0 Nothing [] [] Seq.empty -enrollTimerData :: Maybe (TVar (WithPoison (Maybe time))) -> TimerData time -> TimerData time+enrollTimerData :: Maybe (TimeVar time) -> TimerData time -> TimerData time enrollTimerData me td   = td {enrolledOnTimer = enrolledOnTimer td + 1        -- It's important that the event goes on the front, so that we don't re-use@@ -273,7 +274,7 @@   offerTimerData :: forall time. Ord time => ProcessId -> Maybe time -> TimerData time-  -> STM (TimerData time, TVar (WithPoison (Maybe time)))+  -> STM (TimerData time, TimeVar time) offerTimerData pid Nothing td = case timerOffersNext td of   Nothing -> do     (e, pool) <- spareEvent $ timerEventPool td@@ -326,14 +327,14 @@          liftSTM (modifyTVar tv $ enrollTimerData $ Just ev)            >>= checkPoison          x <- f $ Enrolled tim-         ts <- liftPoison $ liftTrace $ liftM snd get+         ts <- liftPoison $ liftTrace $ get          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 $ liftM snd get+    = do ts <- liftPoison $ liftTrace $ get          liftSTM (modifyTVar' tv (checkCompletion u sh ts . resignTimerData False))            >>= checkPoison          x <- m@@ -346,12 +347,13 @@   | offeredOnTimer td == enrolledOnTimer td =       case timerOffersAfter td of         ((pids, (newT, ev)):rest) -> do-          writeTVar ev $ NoPoison $ Just newT-          maybe (return ()) (flip writeTVar (NoPoison $ Just newT) . snd) (timerOffersNext td)+          writeTVar ev $ NoPoison $ Just (newT, seqTime td)+          maybe (return ()) (flip writeTVar (NoPoison $ Just (newT, seqTime td)) . snd) (timerOffersNext td)           recordEventLast [((Event.ClockSync $ sh newT,u)             , Set.fromList $ pids ++ maybe [] fst (timerOffersNext td))]             ts           return $ td { timerOffersAfter = rest+                      , seqTime = succ $ seqTime td                       , offeredOnTimer =                           offeredOnTimer td                             - (length pids + maybe 0 (length . fst) (timerOffersNext td))@@ -367,8 +369,8 @@                       }         [] -> case timerOffersBefore td of                 ((pids, (newT, ev)):rest) -> do-                  writeTVar ev $ NoPoison $ Just newT-                  maybe (return ()) (flip writeTVar (NoPoison $ Just newT) . snd) (timerOffersNext td)+                  writeTVar ev $ NoPoison $ Just (newT, seqTime td)+                  maybe (return ()) (flip writeTVar (NoPoison $ Just (newT, seqTime td)) . snd) (timerOffersNext td)                   return $                     td { timerOffersAfter = rest                        , timerOffersBefore = []@@ -376,6 +378,7 @@                            offeredOnTimer td                              - (length pids + maybe 0 (length . fst) (timerOffersNext td))                        , curTime = newT+                       , seqTime = succ $ seqTime td                        , timerOffersNext = Nothing                        -- The event will only be re-used once we get to the                        -- end of the list, and thus all the people are ready@@ -389,7 +392,7 @@   | otherwise = return td  waitClock :: Ord time =>-  ProcessId -> TraceStore -> Enrolled Clock time -> Maybe time -> STM (STM (WithPoison time))+  ProcessId -> TraceStore -> Enrolled Clock time -> Maybe time -> STM (STM (WithPoison (time, Integer))) waitClock pid ts (Enrolled (Clock (tv, u, sh))) ph   = do x <- readTVar tv        case x of@@ -419,11 +422,11 @@   getCurrentTime (Enrolled (Clock (tv, _, _)))     = liftSTM (liftM (fmap curTime) $ readTVar tv) >>= checkPoison   wait c@(Enrolled (Clock (_, u, sh))) mt-    = do ts <- liftPoison $ liftTrace $ liftM snd get+    = do ts <- liftPoison $ liftTrace $ get          pid <- liftPoison $ liftTrace $ getProcessId          waitAct <- liftSTM $ waitClock pid ts c mt-         t <- liftSTM waitAct >>= checkPoison-         liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u $ sh t]+         (t, s) <- liftSTM waitAct >>= checkPoison+         liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u s $ sh t]          return t  instance Ord time => Poisonable (Enrolled Clock time) where

@@ -28,7 +28,10 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  --TODO document this (for internal purposes)-module Control.Concurrent.CHP.Event where+module Control.Concurrent.CHP.Event (RecordedEventType(..), Event, getEventUnique,+  SignalVar, SignalValue(..), enableEvents, disableEvents,+  newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison,+  testAll) where  import Control.Concurrent.STM import Control.Monad@@ -37,7 +40,9 @@ import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set+import qualified Data.Traversable as T import Data.Unique+import Prelude hiding (seq)   import Control.Concurrent.CHP.Poison@@ -55,6 +60,7 @@   RecordedEventType, -- Event type for trace recording   TVar (WithPoison     (Int, -- Enrolled count+     Integer, -- Event sequence count     [OfferSet]) -- A list of offer sets  )) @@ -71,15 +77,32 @@ getEventUnique :: Event -> Unique getEventUnique (Event (u,_,_)) = u -getEventTVar :: Event -> TVar (WithPoison (Int, [OfferSet]))+getEventTVar :: Event -> TVar (WithPoison (Int, Integer, [OfferSet])) getEventTVar (Event (_,_,tv)) = tv  getEventType :: Event -> RecordedEventType getEventType (Event (_,t,_)) = t -newtype OfferSet = OfferSet (TVar (Maybe [Int]) -- Variable to use to signal when committed+-- The value used to pass information to a waiting process once one of their events+-- has fired (and they have been committed to it).  The Int is an index into their+-- list of guards+newtype SignalValue = Signal (WithPoison Int)+  deriving (Eq, Show)++type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique Integer))++addPoison :: SignalValue -> SignalValue+addPoison = const $ Signal PoisonItem++nullSignalValue :: SignalValue+nullSignalValue = Signal $ NoPoison (-1)++isNullSignal :: SignalValue -> Bool+isNullSignal (Signal n) = n == NoPoison (-1)++newtype OfferSet = OfferSet (SignalVar -- Variable to use to signal when committed                 , ProcessId -- Id of the process making the offer-                , [([Int], Map.Map Event ())]) -- Value to send when committed+                , [(SignalValue, Map.Map Event ())]) -- Value to send when committed                                     -- A list of all sets of events currently offered  instance Eq OfferSet where@@ -98,9 +121,42 @@ allEventsInOffer :: OfferSet -> Map.Map Event () allEventsInOffer (OfferSet (_, _, eventSets)) = unionAll (map snd eventSets) -search :: [OfferSet] -> Map.Map Event Bool -> Maybe (STM (), Map.Map Unique (RecordedEventType,-  Set.Set ProcessId), [(TVar (Maybe [Int]), [Event])])-search [] _ = Just (return (), Map.empty, [])+getAndIncCounter :: Event -> a -> STM (WithPoison Integer)+getAndIncCounter e _+  = 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++-- | 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,+-- it just searches the offer-sets (which will have been discovered through STM)+-- for completions.+--+-- search performs a 2-dimensional traversal of the offers.  The search function+-- is called with a list of offer-sets.  For the offer-set at the head, it calls+-- tryAll.  tryAll searches through each offer in the offer-set, seeing if it can+-- be completed.  If it can, it calls search on the remaining offer-sets.  If this+-- fails, it reverts to trying the other offers in the list. The map of events passed through+-- relates to the previous things found in the search.+search :: [OfferSet]+          -- ^ The collection of all the related offer-sets+          -> Map.Map Event Bool+          -- ^ This contains the events already decided upon in the search.  If+          -- an event maps to True, it means it was chosen by an earlier part of+          -- the search, and thus future parts of the search /must/ have this event+          -- in the chosen offer (if the process offers it at all -- if it doesn't,+          -- it can be ignored).  If an event maps to False, it was already ruled+          -- 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)]+                   , Map.Map Event (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.+search [] _ = Just ([], Map.empty) search (offer@(OfferSet (tv, pid, eventSets)) : offers) eventMap       | Map.null mustChooseFromEventSets = tryAll eventSets       | otherwise = tryAll filteredEventSets@@ -122,16 +178,21 @@                 es             ] +        -- Folds across a map, seeing if the given predicate holds for all values+        -- in the map.         mapdotall :: Ord k => (a -> Bool) -> Map.Map k a -> Bool         mapdotall f = Map.fold (\x b -> f x && b) True -        -- All events in the maps in the first parameter will be mapped to True-        tryAll :: [([Int],Map.Map Event ())] ->-          Maybe (STM (), Map.Map Unique (RecordedEventType, Set.Set ProcessId),-            [(TVar (Maybe [Int]), [Event])])+        and' :: Ord k => Map.Map k Bool -> Bool+        and' = mapdotall id++        tryAll :: [(SignalValue, Map.Map Event ())]+          -> Maybe ( [(SignalVar, SignalValue)]+                   , Map.Map Event (RecordedEventType, Set.Set ProcessId)+                   )         tryAll [] = Nothing         tryAll ((ns, es):next)-          | not $ mapdotall id (eventMap `Map.intersection` es)+          | not $ and' (eventMap `Map.intersection` es)               -- Contains an already-rejected event (one that mapped to False), skip:               -- Need to reject the other events too though -- well, at least put               -- them in the appropriate map and pass them through.  They will@@ -140,10 +201,12 @@               = tryAll next           | otherwise = case search offers eventMap' of             Nothing -> tryAll next-            Just (act, resolved, retract) -> Just (if null ns then act else writeTVar tv (Just ns) >> act, foldl-              (\m e -> Map.insertWith add (getEventUnique e) (getEventType-                e, Set.singleton pid) m) resolved (Map.keys es), if null ns then retract else-                  (tv, Map.keys allEventsInOfferMappedToFalse) : retract)+            Just (act, resolved) -> Just+              (if isNullSignal ns then act else (tv, ns) : act+              , foldl (\m e -> Map.insertWith add e+                                 (getEventType e, Set.singleton pid) m)+                  resolved (Map.keys es)+              )                          where             -- All events that features in other offers by this process, but not@@ -157,8 +220,6 @@              add (tx, pidsx) (_, pidsy) = (tx, pidsx `Set.union` pidsy)             -data EventStatus = Fine | NotCompletable deriving (Eq, Show)- -- Given a list of offers that could possibly complete, check if any set -- of offers can.  If so, complete it (including all retractions and -- notifications for each process), otherwise leave things untouched.@@ -167,26 +228,28 @@ -- list of all offer-sets that need to be considered (they will have come from -- all events in a connected sub-graph), the map of relevant events to their status, -- and returns the map of event-identifiers that did complete.-resolveOffers :: Maybe (TVar (Maybe [Int])) -> [OfferSet] -> Set.Set Event -> STM (Map.Map Unique (RecordedEventType,-  Set.Set ProcessId))+resolveOffers :: Maybe SignalVar -> [OfferSet] -> Set.Set Event+  -> STM (Map.Map Unique (RecordedEventType, Set.Set ProcessId)) resolveOffers newTvid allOffers events   = do let (offers', _) = trim (allOffers, events)-           (act, ret, retract) = fromMaybe (return (), Map.empty, []) $ search (map addNullOffer-             $ sortOffers offers') Map.empty-       act+           (act, ret) = fromMaybe ([], Map.empty) $+             search (map addNullOffer $ sortOffers offers') Map.empty+       eventCounts <- T.sequence $ Map.mapWithKey getAndIncCounter ret+       let NoPoison uniqCounts = T.sequence $ Map.mapKeysMonotonic getEventUnique eventCounts+       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 fst retract)+       retractOffers $ zip (map fst act)                            (repeat $ unionAll $ map allEventsInOffer allOffers)-       return ret+       return (Map.mapKeysMonotonic getEventUnique ret)   where     -- Don't add the null offer for the newest process, and null offer should be     -- added to the end:     addNullOffer :: OfferSet -> OfferSet     addNullOffer (OfferSet (tv,y,zs)) = OfferSet (tv,y,if Just tv == newTvid then zs else zs++nullOffer) -    nullOffer :: [([Int], Map.Map Event ())]-    nullOffer = [([],Map.empty)]+    nullOffer :: [(SignalValue, Map.Map Event ())]+    nullOffer = [(nullSignalValue,Map.empty)]      -- SMallest offers first to minimise backtracking:     sortOffers :: [OfferSet] -> [OfferSet]@@ -262,7 +325,7 @@           = do x <- readTVar tv                case x of                  PoisonItem -> act >> return PoisonItem-                 NoPoison (count, offers) ->+                 NoPoison (count, _, offers) ->                    let otherEvents = map allEventsInOffer offers in                    if length offers == count                      then -- It could be ready@@ -273,19 +336,29 @@                      else -- No way it could be ready, so ignore it:                        discoverRelatedOffersAll a next --- Given an optional waiting-tvar from the newest process to offer (if any), and--- an event, spiders out, discovers all the offers, then resolves them and returns--- a map containing all the completed events, mapping the identifier to the event--- type and the set of process identifiers that participated in the succesfully--- completed events.  The map will be empty if and only if no events were completed.-discoverAndResolve :: Either OfferSet Event -> STM (WithPoison (Map.Map Unique (RecordedEventType,Set.Set-  ProcessId)))+-- Given an event, spiders out, discovers all the offers, then resolves them+-- and returns a map containing all the completed events, mapping the+-- identifier to the event type and the set of process identifiers that+-- participated in the succesfully completed events.  The map will be empty if+-- and only if no events were completed.+discoverAndResolve :: Either OfferSet Event+                        -- ^ Either an OfferSet to spider out from, or a single+                        -- event.  The latter case is for when we are resigning+                        -- from an event and need to check if that completes anything.+                      -> STM (WithPoison (Map.Map Unique (RecordedEventType, Set.Set ProcessId)))+                        -- ^ Gives back either poison, or a map from event identifiers+                        -- to information about the completed event.  The map is+                        -- empty if no events were completed. discoverAndResolve offOrEvent   = do r <- discoverRelatedOffers $ case offOrEvent of               Left off@(OfferSet (tv, _, nes)) ->                 let retract = retractOffers [(tv, allEventsInOffer off)] in-                      concat [zip (repeat $ retract >> writeTVar tv (Just $ ns-                         ++ [0])) (Map.keys es) | (ns, es) <- nes]+                      concat [zip+                        -- This is the action to execute if an event is found to+                        -- be poisoned:+                        (repeat $ retract >> writeTVar tv (Just (addPoison ns, Map.empty)))+                        (Map.keys es)+                        | (ns, es) <- nes]               Right e -> [(return (), e)]        case r of          PoisonItem -> return PoisonItem@@ -298,7 +371,7 @@ newEvent :: RecordedEventType -> Int -> IO Event newEvent t n   = do u <- newUnique-       atomically $ do tv <- newTVar (NoPoison (n, []))+       atomically $ do tv <- newTVar (NoPoison (n, 0, []))                        return $ Event (u, t, tv)  newEventUnique :: IO Unique@@ -309,30 +382,30 @@   = do x <- readTVar $ getEventTVar e        case x of          PoisonItem -> return PoisonItem-         NoPoison (count, offers) ->-           do writeTVar (getEventTVar e) $ NoPoison (count + 1, offers)+         NoPoison (count, seq, offers) ->+           do writeTVar (getEventTVar e) $ NoPoison (count + 1, seq, offers)               return $ NoPoison ()  -- If the event completes, we return details related to it:-resignEvent :: Event -> STM (WithPoison [((RecordedEventType, Unique), Set.Set-    ProcessId)])+resignEvent :: Event -> STM (WithPoison [((RecordedEventType, Unique), Set.Set ProcessId)]) resignEvent e   = do x <- readTVar $ getEventTVar e        case x of          PoisonItem -> return PoisonItem-         NoPoison (count, offers) ->-           do writeTVar (getEventTVar e) $ NoPoison (count - 1, offers)+         NoPoison (count, seq, offers) ->+           do writeTVar (getEventTVar e) $ NoPoison (count - 1, seq, offers)               if (count - 1 == length offers)                 then liftM (fmap $ \mu -> [((r,u),pids) | (u,(r,pids)) <- Map.toList mu])                        $ discoverAndResolve $ Right e                 else return $ NoPoison []  -- Given the list of identifiers paired with all the events that that process might--- be engaged in, retracts all the offers during a transaction.-retractOffers :: [(TVar (Maybe [Int]), Map.Map Event ())] -> STM ()+-- be engaged in, retracts all the offers that are associated with the given TVar;+-- i.e. the TVar is used as an identifier for the process+retractOffers :: [(SignalVar, Map.Map Event ())] -> STM () retractOffers = mapM_ retractAll   where-    retractAll :: (TVar (Maybe [Int]), Map.Map Event ()) -> STM ()+    retractAll :: (SignalVar, Map.Map Event ()) -> STM ()     retractAll (tvid, evts) = mapM_ retract (Map.keys evts)       where         retract :: Event -> STM ()@@ -340,15 +413,17 @@           = do x <- readTVar $ getEventTVar e                case x of                  PoisonItem -> return ()-                 NoPoison (enrolled, offers) ->+                 NoPoison (enrolled, seq, offers) ->                    let reducedOffers = filter (\(OfferSet (tvx,_,_)) -> tvx /= tvid) offers in-                   writeTVar (getEventTVar e) $ NoPoison (enrolled, reducedOffers)+                   writeTVar (getEventTVar e) $ NoPoison (enrolled, seq, reducedOffers)  -- Simply adds the offers but doesn't check if that will complete an event: -- Returns PoisonItem if any of the events were poisoned makeOffers :: OfferSet -> STM (WithPoison ()) makeOffers offers   = do let allEvents = Map.keys $ allEventsInOffer offers+       -- No need for nub, as having it come from a map guarantees there are no+       -- duplicates in the list of events        liftM mergeWithPoison $ mapM makeOffer allEvents   where     makeOffer :: Event -> STM (WithPoison ())@@ -356,18 +431,38 @@       = do x <- readTVar $ getEventTVar e            case x of              PoisonItem -> return PoisonItem-             NoPoison (count, prevOffers) ->-               do writeTVar (getEventTVar e) $ NoPoison (count, offers : prevOffers)+             NoPoison (count, seq, prevOffers) ->+               do writeTVar (getEventTVar e) $ NoPoison (count, seq, offers : prevOffers)                   return $ NoPoison () --- Passed: True if allowed to commit to waiting--- Returns: True if committed, False otherwise-enableEvents :: TVar (Maybe [Int]) -> ProcessId -> [([Int], STM-  (), [Event])] -> Bool -> STM (Maybe ([Int], [((RecordedEventType, Unique), Set.Set-    ProcessId)]))+-- Returns Nothing if no events were ready.  Returns Just with the signal value+-- if an event was immediately available, followed by the information for each+-- event involved in the synchronisation.  If poison was encounted, this list will+-- be empty.+enableEvents :: SignalVar+                  -- ^ Variable used to signal the process once a choice is made+                -> ProcessId+                  -- ^ The id of the process making the choice+                -> [(SignalValue, STM (), [Event])]+                  -- ^ The list of options.  Each option has a signalvalue to return+                  -- if chosen, an STM action to execute at the same time as the+                  -- synchronisation, and a list of events (conjoined together).+                  --  So this list is the disjunction of conjunctions, with a little+                  -- more information.+                -> Bool+                  -- ^ True if it can commit to waiting.  If there is an event+                  -- combination ready during the transaction, it will chosen regardless+                  -- 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)])) 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:+       -- We don't check the result for poison, as discoverAndResolve will find+       -- it anyway        makeOffers offer+       -- Then spider out and see if anything can be resolved:        pmu <- discoverAndResolve (Left offer)        case (canCommitToWait, pmu) of          (_, PoisonItem) -> do Just chosen <- readTVar tvNotify@@ -385,7 +480,12 @@                    Just chosen <- readTVar tvNotify                    return $ Just (chosen, [((r,u),pids) | (u,(r,pids)) <- Map.toList mu]) -disableEvents :: TVar (Maybe [Int]) -> [Event] -> STM (Maybe [Int])+-- | Given the variable used to signal the process, and the list of events that+-- were involved in its offers, attempts to disable the events.  If the variable+-- 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 tv events   = do x <- readTVar tv        -- Since the transaction will be atomic, we know@@ -406,16 +506,16 @@   = do x <- readTVar $ getEventTVar e        case x of          PoisonItem -> return ()-         NoPoison (_, offers) ->+         NoPoison (_, _, offers) ->            do retractOffers [(tvw, unionAll $ map snd events)                             | OfferSet (tvw, _, events) <- offers]-              sequence_ [writeTVar tvw (Just $ pickInts events ++ [0])+              sequence_ [writeTVar tvw (Just (addPoison $ pickInts events, Map.empty))                         | OfferSet (tvw, _, events) <- offers]               writeTVar (getEventTVar e) PoisonItem   where-    pickInts :: [([Int], Map.Map Event ())] -> [Int]+    pickInts :: [(SignalValue, Map.Map Event ())] -> SignalValue     pickInts es = case filter ((e `Map.member`) . snd) es of-      [] -> [] -- Should never happen+      [] -> nullSignalValue -- Should never happen       ((ns,_):_) -> ns  --TODO document how if it's poisoned, 0 will be appended to the list@@ -568,7 +668,7 @@                         " expected no poison but found it"                       (PoisonItem, NoPoison _) -> putStrLn $ testName ++                         " expected poison but found none"-                      (NoPoison expOff, NoPoison (_, actOff)) ->+                      (NoPoison expOff, NoPoison (_, _, actOff)) ->                         when (map (realOffers !!) expOff **/=** actOff) $                           putStrLn $ testName ++ " offers did not match"                 | (n, (_, expect)) <- zip [0..] eventCounts]@@ -595,7 +695,7 @@            realOffers <- sequence              [ do tv <- atomically $ newTVar Nothing                   let pid = testProcessId processN-                      offSub = [ ([processN, offerN],+                      offSub = [ (Signal $ NoPoison (processN + offerN),                                   Map.fromList [ (events !! indivEvent, ())                                   | indivEvent <- singleOffer])                                | (offerN, singleOffer) <- zip [0..] processOffers]@@ -603,12 +703,12 @@                   mapM_ (\e -> atomically $ do                     x <- readTVar (getEventTVar e)                     case x of-                      NoPoison (count, offs) ->-                        writeTVar (getEventTVar e) $ NoPoison (count, off : offs)+                      NoPoison (count, s, offs) ->+                        writeTVar (getEventTVar e) $ NoPoison (count, s, off : offs)                       PoisonItem -> return ()                     ) (Map.keys $ unionAll $ map snd offSub)                   return off-             | (processN, processOffers) <- zip [0..] offerSets]+             | (processN, processOffers) <- zip (map (*1000) [0..]) offerSets]            return (events, realOffers)  testResolve :: IO ()@@ -673,7 +773,7 @@            actualResult <- atomically $ discoverAndResolve $ Left $ head realOffers            let expectedResult = if poisoned then PoisonItem else NoPoison $                                 Map.fromList [ (getEventUnique e, (ChannelComm,-                                               Set.fromList $ map (testProcessId . fst) is))+                                               Set.fromList $ map (testProcessId . (*1000) . fst) is))                                              | (e, Left is) <- zip events (map snd eventCounts)]            when (expectedResult /= actualResult) $              putStrLn $ testName ++ " failed on direct result, expected: "@@ -684,9 +784,10 @@                do x <- atomically $ readTVar tv                   case x of                     Nothing -> putStrLn $ "Unexpected no-win for " ++ show (pn,en)-                    Just v -> when (v /= (if poisoned then (++[0]) else id) [pn, en]) $-                      putStrLn $ testName ++ " wrong choice: " ++ show v ++ " exp: " ++ show-                        [pn, en]+                    Just v -> when (fst v /= (if poisoned then addPoison else id)+                                             (Signal $ NoPoison ((pn*1000)+en))) $+                      putStrLn $ testName ++ " wrong choice: " ++ " exp: " ++ show+                        (pn+en)                   return pn              ) $ map snd eventCounts            -- test the others are unchanged@@ -695,7 +796,7 @@                             case x of                               Nothing -> return ()                               Just _ -> putStrLn $ testName ++ " Unexpected win for process: " ++-                                show n ++ " " ++ show x+                                show n                      | n <- [0 .. length offerSets - 1] \\ allFired]            -- check events are blanked afterwards:            sequence_ [ let e = events !! n@@ -703,10 +804,12 @@                              Left _ -> []                              Right ns -> map (realOffers !!) ns in do                          x <- atomically $ readTVar $ getEventTVar e-                         when (x /= NoPoison (count, expVal)) $-                           putStrLn $ testName ++ "Event " ++ show n +++                         case x of+                           NoPoison (c, _, e') | c == count && e' == expVal -> return ()+                           _ ->+                             putStrLn $ testName ++ "Event " ++ show n ++                              " not as expected after, exp: " ++ show (length expVal)-                             ++ " act: " ++ (let NoPoison (_,act) = x in show (length act))+                             ++ " act: " ++ (let NoPoison (_,_,act) = x in show (length act))                      | (n,(NoPoison count, st)) <- zip [0..] eventCounts]      showStuff = show . fmap (map (\(u,x) -> (hashUnique u, x)) . Map.toList)

@@ -31,30 +31,37 @@  import Control.Concurrent.STM import Control.Monad.Trans+import Data.Unique import System.IO  import Control.Concurrent.CHP.Event import Control.Concurrent.CHP.Traces.Base  -- Setup (giving transaction)-data Guard = TimeoutGuard (IO (STM [Int]))-             | SkipGuard [Int]+data Guard = TimeoutGuard (IO (STM ()))+             | SkipGuard              | StopGuard-             | BadGuard String              -- The STM item is an action to take in the same transaction as              -- completing the event (before it is completed).-             | EventGuard [Int] [RecordedIndivEvent] (STM ()) [Event]-             | NestedGuards [Guard]+             | EventGuard ((Unique -> Integer) -> [RecordedIndivEvent Unique]) (STM ()) [Event]  skipGuard :: Guard-skipGuard = SkipGuard []+skipGuard = SkipGuard -badGuard :: String -> Guard-badGuard = BadGuard+isSkipGuard :: Guard -> Bool+isSkipGuard SkipGuard = True+isSkipGuard _ = False +badGuard :: String -> Either String a+badGuard = Left+ stopGuard :: Guard stopGuard = StopGuard +isStopGuard :: Guard -> Bool+isStopGuard StopGuard = True+isStopGuard _ = False+ -- Microseconds guardWaitFor :: Int -> Guard guardWaitFor n@@ -63,6 +70,6 @@         return $ do b <- readTVar signalDone                     if b == False                       then retry-                      else return []+                      else return ()  

@@ -32,6 +32,7 @@   (    -- * CHP Monad   CHP, MonadCHP(..), runCHP, runCHP_,+  embedCHP, embedCHP_, embedCHP1, embedCHP1_,    onPoisonTrap, onPoisonRethrow, throwPoison, Poisonable(..), poisonAll, @@ -43,9 +44,9 @@    ) where  import Control.Concurrent-import Control.Monad.Error import Control.Monad.State import Control.Monad.Trans+import Data.Unique  -- This module primarily re-exports the public definitions from -- Control.Concurrent.CHP.{Base,CSP,Poison}:@@ -59,12 +60,39 @@ -- communicate between those processes using channels.  Instead, run this function -- once and use it to spawn off the parallel processes that you need. runCHP :: CHP a -> IO (Maybe a)-runCHP = liftM fst . (runCHPAndTrace :: CHP a -> IO (Maybe a, TraceOff))+runCHP = liftM fst . (runCHPAndTrace :: CHP a -> IO (Maybe a, TraceOff Unique))  -- | Runs a CHP program.  Like 'runCHP' but discards the output. runCHP_ :: CHP a -> IO () runCHP_ p = runCHP p >> return () +-- | Allows embedding of the CHP monad back into the IO monad.  The argument+-- that this function takes is a CHP action (with arbitrary behaviour).  The+-- function is monadic, and returns something of type: IO a.  This+-- is an IO action that you can now use in the IO monad wherever you like.+-- What it returns is the result of your original action.+--+-- This function is intended for use wherever you need to supply an IO callback+-- (for example with the OpenGL libraries) that needs to perform CHP communications.+--  It is the safe way to do things, rather than using runCHP twice (and also works+-- with CSP and VCR traces -- but not structural traces!).+embedCHP :: CHP a -> CHP (IO (Maybe a))+embedCHP m = liftM ($ ()) $ embedCHP1 (\() -> m)++-- | A convenient version of embedCHP that ignores the result+embedCHP_ :: CHP a -> CHP (IO ())+embedCHP_ = liftM (>> return ()) . embedCHP++-- | 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++-- | A convenient version of embedCHP1 that ignores the result+embedCHP1_ :: (a -> CHP b) -> CHP (a -> IO ())+embedCHP1_ = liftM (\m x -> m x >> return ()) . embedCHP1++ -- | A monad transformer for easier looping.  This is independent of the -- CHP aspects, but has all the right type-classes defined for it to make -- it easy to use with the CHP library.@@ -88,12 +116,6 @@ instance MonadCHP m => MonadCHP (LoopWhileT m) where   liftCHP = lift . liftCHP -instance MonadError e m => MonadError e (LoopWhileT m) where-  throwError e = lift $ throwError e-  catchError m h = LWT $ catchError (getLoop m) (getLoop . h)----TODO instances for all the other monad transformers- -- | Runs the given action in a loop, executing it repeatedly until a 'while' -- statement inside it has a False condition.  If you use 'loop' without 'while', -- the effect is the same as 'forever'.@@ -126,7 +148,7 @@ -- /NOTE:/ If you wish to use this as part of a choice, you must use @-threaded@ -- as a GHC compilation option (at least under 6.8.2). waitFor :: Int -> CHP ()-waitFor n = liftPoison $ AltableT (guardWaitFor n, return ()) (liftIO $ threadDelay n)+waitFor n = liftPoison $ AltableT (Right [(guardWaitFor n, return ())]) (liftIO $ threadDelay n) -- TODO maybe fix the above lack of guarantees by keeping timeout guards explicit.  -- TODO add waitUntil@@ -135,14 +157,14 @@ -- -- Suitable for use in an 'Control.Concurrent.CHP.Alt.alt'. skip :: CHP ()-skip = liftPoison $ AltableT (skipGuard, return ()) (return ())+skip = liftPoison $ AltableT (Right [(skipGuard, return ())]) (return ())  -- | The stop guard.  Its main use is that it is never ready in a choice, so -- can be used to mask out guards.  If you actually execute 'stop', that process -- will do nothing more.  Any parent process waiting for it to complete will -- wait forever. stop :: CHP ()-stop = liftPoison $ AltableT (stopGuard, liftIO hang) (liftIO hang)+stop = liftPoison $ AltableT (Right [(stopGuard, liftIO hang)]) (liftIO hang)   where     -- Strangely, I can't work out a good way to actually implement stop.     -- If you wait on a variable that will never be ready, GHC will wake

@@ -117,16 +117,16 @@ runParallelPoison :: forall a. [CHP a] -> CHP [a] runParallelPoison processes   = do c <- liftIO $ atomically $ newResultsVar-       (_, trace) <- PoisonT $ lift $ liftTrace get+       trace <- PoisonT $ lift $ liftTrace get        blanks <- liftIO $ blankTraces trace (length processes)        liftIO $ -         mapM_ forkIO [do y <- wrapProcess p $ flip runStateT ([], btr) . pullOutStandard+         mapM_ forkIO [do y <- wrapProcess p $ flip runStateT btr . pullOutStandard                           C.block $ atomically $                             do ys <- readTVar c                                writeTVar c $ (case y of                                  Nothing -> (n, (Nothing, Nothing))-                                 Just (Right (x,(_,t))) -> (n, (Just x, Just t))-                                 Just (Left (_,t)) -> (n, (Nothing, Just t))+                                 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 c@@ -178,10 +178,10 @@               liftIO $ atomically $ do                 (pa, n) <- readTVar b                 writeTVar b (pa, n + 1)-              (_, trace) <- liftCHP $ PoisonT $ lift $ liftTrace get+              trace <- liftCHP $ PoisonT $ lift $ liftTrace get               [blank] <- liftIO $ blankTraces trace 1               liftIO $ forkIO $ do-                r <- wrapProcess p $ flip runStateT ([], blank) . pullOutStandard+                r <- wrapProcess p $ flip runStateT blank . pullOutStandard                 C.block $ atomically $ do                   (poisonedAlready, n) <- readTVar b                   writeTVar b $ (poisonedAlready || isNothing r, n - 1)

@@ -66,6 +66,8 @@   ,ChannelLabels   ,RecordedEventType(..)   ,RecordedIndivEvent(..)+  ,recordedIndivEventLabel+  ,recordedIndivEventSeq   ,Trace(..)   ) where 

@@ -45,7 +45,9 @@ -- identifiers are per channel\/barrier, not per event.  Currently, -- channels and barriers can never have the same Unique as each other, but -- do not rely on this behaviour.-type RecordedEvent = (RecordedEventType, Unique)+--+-- The type became parameterised in version 1.3.0.+type RecordedEvent u = (RecordedEventType, u)  -- | An individual record of an event, found in nested traces.  Either a -- channel write or read, or a barrier synchronisation, each with a unique@@ -56,17 +58,41 @@ -- never have the same Unique as each other, but do not rely on this -- behaviour. ----- TimerSyncIndiv was added in version 1.2.0.-data RecordedIndivEvent = -  ChannelWrite Unique-  | ChannelRead Unique-  | BarrierSyncIndiv Unique-  | ClockSyncIndiv Unique String-  deriving (Eq, Ord)+-- 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.+data RecordedIndivEvent u = +  ChannelWrite u Integer+  | ChannelRead u Integer+  | BarrierSyncIndiv u Integer+  | ClockSyncIndiv u Integer String+  deriving (Eq, Ord, Read, Show) -type RecEvents = ([RecordedEvent], [RecordedIndivEvent])+-- | Added in version 1.3.0.+recordedIndivEventLabel :: RecordedIndivEvent u -> u+recordedIndivEventLabel (ChannelWrite x _) = x+recordedIndivEventLabel (ChannelRead x _) = x+recordedIndivEventLabel (BarrierSyncIndiv x _) = x+recordedIndivEventLabel (ClockSyncIndiv x _ _) = x -getName :: String -> Unique -> State (Map.Map Unique String) String+-- | Added in version 1.3.0.+recordedIndivEventSeq :: RecordedIndivEvent u -> Integer+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 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++type RecEvents = ([RecordedEvent Unique], [RecordedIndivEvent Unique])++getName :: Ord u => String -> u -> State (Map.Map u String) String getName prefix u           = do m <- get                case Map.lookup u m of@@ -75,7 +101,7 @@                             do put $ Map.insert u x m                                return x -nameEvent :: RecordedEvent -> State (Map.Map Unique String) String+nameEvent :: Ord u => RecordedEvent u -> State (Map.Map u String) String nameEvent (t, c) = liftM (++ suffix) $ getName prefix c   where     (prefix, suffix) = case t of@@ -83,39 +109,54 @@       BarrierSync -> ("_b","")       ClockSync st -> ("_t", ':' : st) -nameIndivEvent :: RecordedIndivEvent -> State (Map.Map Unique String) String-nameIndivEvent (ChannelWrite c) = do c' <- getName "_c" c-                                     return $ c' ++ "!"-nameIndivEvent (ChannelRead c) = do c' <- getName "_c" c-                                    return $ c' ++ "?"-nameIndivEvent (BarrierSyncIndiv c) = do c' <- getName "_b" c-                                         return $ c' ++ "*"-nameIndivEvent (ClockSyncIndiv c t) = do c' <- getName "_t" c-                                         return $ c' ++ ":" ++ t+nameEvent' :: Ord u => RecordedEvent u -> State (Map.Map u String) (RecordedEvent String)+nameEvent' (t, c) = do c' <- getName prefix c+                       return (t, c' ++ suffix)+  where+    (prefix, suffix) = case t of+      ChannelComm -> ("_c","")+      BarrierSync -> ("_b","")+      ClockSync st -> ("_t", ':' : st)  -ensureAllNamed :: Map.Map Unique String -> [RecordedEvent] -> Map.Map Unique String--- Quite hacky:-ensureAllNamed m es = execState (mapM_ nameEvent es) m+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 (ClockSyncIndiv c n t) = do c' <- getName "_t" c+                                           return $ c' ++ ":" ++ t+                                             ++ "[" ++ show n ++ "]" -ensureAllNamedIndiv :: Map.Map Unique String -> [RecordedIndivEvent] -> Map.Map Unique String--- Quite hacky:-ensureAllNamedIndiv m es = execState (mapM_ nameIndivEvent es) m+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' (ClockSyncIndiv c n t) = do c' <- getName "_t" c+                                            return $ ClockSyncIndiv c' n t  --- The list of integers is for alting-type TraceT = StateT ([Int], TraceStore)+type TraceT = StateT TraceStore  data TraceStore =   NoTrace-  | Trace (ProcessId, TVar ChannelLabels, SubTraceStore)+  | Trace (ProcessId, TVar (ChannelLabels Unique), SubTraceStore) -type ChannelLabels = Map.Map Unique String+mapSubTrace :: (SubTraceStore -> SubTraceStore) -> TraceStore -> TraceStore+mapSubTrace _ NoTrace = NoTrace+mapSubTrace f (Trace (pid, tv, s)) = Trace (pid, tv, f s) +type ChannelLabels u = Map.Map u String+ data SubTraceStore =-  Hierarchy (Structured RecordedIndivEvent)-  | CSPTraceRev (TVar [(Int, [RecordedEvent])])-  | VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent)])+  Hierarchy (Structured (RecordedIndivEvent Unique))+  | CSPTraceRev (TVar [(Int, [RecordedEvent Unique])])+  | VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent Unique)])  data Ord a => Structured a =   StrEvent a@@ -124,7 +165,7 @@   deriving (Eq, Ord)  -- | Records an event where you were the last person to engage in the event-recordEventLast :: [(RecordedEvent, Set.Set ProcessId)] -> TraceStore -> STM ()+recordEventLast :: [(RecordedEvent Unique, Set.Set ProcessId)] -> TraceStore -> STM () recordEventLast news y            =    case y of                   Trace (_,_,CSPTraceRev tv) ->@@ -145,25 +186,17 @@                   _ -> return ()  -- | Records an event where you were one of the people involved-recordEvent :: [RecordedIndivEvent] -> TraceT IO ()-recordEvent e-           = do (x,y) <- get-                case (x, y) of-                  (as, Trace (pid,tvls,Hierarchy es)) ->-                       put (as, Trace (pid, tvls, Hierarchy (foldl (flip addSeqEventH) es e)))-                  _ -> return ()+recordEvent :: [RecordedIndivEvent Unique] -> TraceT IO ()+recordEvent e = modify $ mapSubTrace $ \(Hierarchy es) ->+                  Hierarchy (addParEventsH (map StrEvent e) es)  mergeSubProcessTraces :: [TraceStore] -> TraceT IO () mergeSubProcessTraces ts-  = do s <- get-       case s of-         (as, Trace (pid, tvls, Hierarchy es)) ->-           put (as, Trace (pid, tvls, Hierarchy $ addParEventsH ts' es))-           where ts' = [t | Trace (_,_,Hierarchy t) <- ts]-         _ -> return ()-+  = modify $ mapSubTrace $ \(Hierarchy es) -> Hierarchy (addParEventsH ts' es)+  where+    ts' = [t | Trace (_,_,Hierarchy t) <- ts] -shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent)+shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent Unique)   -> Bool shouldMakeNewSetVCR newIds existingSet   = exists existingSet $ \(bigP,_) -> exists bigP $ \p -> exists newIds $ \q ->@@ -222,18 +255,18 @@ addRLE x nes = (1,[x]):nes  -labelEvent :: Event -> String -> StateT (a, TraceStore) IO ()+labelEvent :: Event -> String -> StateT TraceStore IO () labelEvent e l   = labelUnique (getEventUnique e) l -labelUnique :: Unique -> String -> StateT (a, TraceStore) IO ()+labelUnique :: Unique -> String -> StateT TraceStore IO () labelUnique u l-  = do (_,t) <- get+  = do t <- get        case t of          NoTrace -> return ()          Trace (_,tvls,_) -> add tvls   where-    add :: TVar (Map.Map Unique String) -> StateT (a, TraceStore) IO ()+    add :: TVar (Map.Map Unique String) -> StateT TraceStore IO ()     add tv = liftIO $ atomically $ do       m <- readTVar tv       writeTVar tv $ Map.insert u l m

@@ -34,6 +34,7 @@ import Control.Concurrent.STM import Control.Monad.State import qualified Data.Map as Map+import Data.Unique import Text.PrettyPrint.HughesPJ  import Control.Concurrent.CHP.Base@@ -41,9 +42,9 @@  -- | A classic CSP trace.  It is simply the channel labels, and a list of recorded -- events in sequence -- the head of the list is the first (oldest) event.-newtype CSPTrace = CSPTrace (ChannelLabels, [RecordedEvent])+newtype CSPTrace u = CSPTrace (ChannelLabels u, [RecordedEvent u]) -instance Show CSPTrace where+instance Ord u => Show (CSPTrace u) where   show = renderStyle (Style OneLineMode 1 1) . prettyPrint  instance Trace CSPTrace where@@ -52,21 +53,18 @@                         runCHPProgramWith' (CSPTraceRev tv) toPublic p    prettyPrint (CSPTrace (labels, events))-    = char '<' <+> (sep $ punctuate (char ',') $ map (text . nameCSP labels') events) <+> char '>'-    where-      labels' = ensureAllNamed labels events      +    = char '<' <+> (sep $ punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>' -toPublic :: ChannelLabels -> SubTraceStore -> IO CSPTrace+  labelAll (CSPTrace (labels, events))+    = CSPTrace (Map.empty, evalState (mapM nameEvent' events) labels)++toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (CSPTrace Unique) toPublic l (CSPTraceRev tv)   = 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" -nameCSP :: ChannelLabels -> RecordedEvent -> String-nameCSP m = flip evalState m . nameEvent---runCHP_CSPTrace :: CHP a -> IO (Maybe a, CSPTrace)+runCHP_CSPTrace :: CHP a -> IO (Maybe a, CSPTrace Unique) runCHP_CSPTrace = runCHPAndTrace  runCHP_CSPTraceAndPrint :: CHP a -> IO ()

@@ -37,10 +37,14 @@ module Control.Concurrent.CHP.Traces.Structural (StructuralTrace(..), EventHierarchy(..), runCHP_StructuralTrace, runCHP_StructuralTraceAndPrint,   getAllEventsInHierarchy) where +import Control.Applicative hiding (empty) import Control.Monad.State+import qualified Data.Foldable as F import Data.List import qualified Data.Map as Map import Data.Maybe+import qualified Data.Traversable as T+import Data.Unique import Text.PrettyPrint.HughesPJ  import Control.Concurrent.CHP.Base@@ -48,16 +52,29 @@  -- | A data type representing a hierarchy of events.  The count on the StructuralSequence -- 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. data EventHierarchy a =   SingleEvent a   | StructuralSequence Int [EventHierarchy a]   | StructuralParallel [EventHierarchy a]+  deriving (Show, Read)  instance Functor EventHierarchy where   fmap f (SingleEvent x) = SingleEvent $ f x   fmap f (StructuralSequence n es) = StructuralSequence n $ map (fmap f) es   fmap f (StructuralParallel es) = StructuralParallel $ map (fmap f) es +instance F.Foldable EventHierarchy where+  foldr f y (SingleEvent x) = f x y+  foldr f y (StructuralSequence _ es) = F.foldr (flip $ F.foldr f) y es+  foldr f y (StructuralParallel es) = F.foldr (flip $ F.foldr f) y es++instance T.Traversable EventHierarchy where+  traverse f (SingleEvent x) = SingleEvent <$> f x+  traverse f (StructuralSequence n es) = StructuralSequence n <$> T.traverse (T.traverse f) es+  traverse f (StructuralParallel es) = StructuralParallel <$> T.traverse (T.traverse f) es+ -- | Flattens the events into a list.  The resulting list may contain duplicates, and it -- should not be assumed that the order relates in any way to the original -- hierarchy.@@ -69,9 +86,9 @@  -- | A nested (or hierarchical) trace.  The trace is an event hierarchy, wrapped -- in a Maybe type to allow for representation of the empty trace (Nothing).-newtype StructuralTrace = StructuralTrace (ChannelLabels, Maybe (EventHierarchy RecordedIndivEvent))+newtype StructuralTrace u = StructuralTrace (ChannelLabels u, Maybe (EventHierarchy (RecordedIndivEvent u))) -instance Show StructuralTrace where+instance Ord u => Show (StructuralTrace u) where   show = renderStyle (Style OneLineMode 1 1) . prettyPrint  instance Trace StructuralTrace where@@ -80,11 +97,8 @@    prettyPrint (StructuralTrace (_,Nothing)) = empty   prettyPrint (StructuralTrace (labels, Just h))-    = pp $ fmap (flip evalState labels' . nameIndivEvent) h+    = pp $ evalState (T.mapM nameIndivEvent h) labels     where-      labels' = ensureAllNamedIndiv labels $-        getAllEventsInHierarchy h-        pp :: EventHierarchy String -> Doc       pp (SingleEvent x) = text x       pp (StructuralSequence 1 es)@@ -95,7 +109,11 @@       pp (StructuralParallel es)         = parens $ sep $ intersperse (text "||") $ map pp es -toPublic :: ChannelLabels -> SubTraceStore -> IO StructuralTrace+  labelAll (StructuralTrace (_, Nothing)) = StructuralTrace (Map.empty, Nothing)+  labelAll (StructuralTrace (labels, Just h))+    = 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)   where@@ -119,7 +137,7 @@           reverse s) rev toPublic _ _ = error "Error in Structural trace -- tracing type got switched" -runCHP_StructuralTrace :: CHP a -> IO (Maybe a, StructuralTrace)+runCHP_StructuralTrace :: CHP a -> IO (Maybe a, StructuralTrace Unique) runCHP_StructuralTrace = runCHPAndTrace  runCHP_StructuralTraceAndPrint :: CHP a -> IO ()

@@ -38,14 +38,15 @@ import Text.PrettyPrint.HughesPJ  -- | A trace type that does not record anything.-newtype TraceOff = TraceOff ()+newtype TraceOff a = TraceOff () -instance Show TraceOff where+instance Show (TraceOff a) where   show = const ""  instance Trace TraceOff where   runCHPAndTrace = runCHPProgramWith NoTrace (const $ TraceOff ())   emptyTrace = TraceOff ()   prettyPrint = const empty+  labelAll = const emptyTrace  

@@ -37,6 +37,7 @@ import Control.Monad.State import qualified Data.Map as Map import qualified Data.Set as Set+import Data.Unique import Text.PrettyPrint.HughesPJ  import Control.Concurrent.CHP.Base@@ -46,9 +47,11 @@ -- accompanied by a sequential list of sets of recorded events.  Each of -- the sets is a set of independent events.  The set at the head of the -- list is the first-recorded (oldest).-newtype VCRTrace = VCRTrace (ChannelLabels, [Set.Set RecordedEvent])+--+-- The type became parameterised in version 1.3.0+newtype VCRTrace u = VCRTrace (ChannelLabels u, [Set.Set (RecordedEvent u)]) -instance Show VCRTrace where+instance Ord u => Show (VCRTrace u) where   show = renderStyle (Style OneLineMode 1 1) . prettyPrint  instance Trace VCRTrace where@@ -59,24 +62,28 @@   prettyPrint (VCRTrace (labels, eventSets))     = char '<' <+> (sep $ punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>'     where-      labels' = ensureAllNamed labels (concatMap Set.toList eventSets)-      es = map (nameVCR labels') eventSets+      es = evalState (mapM nameVCR eventSets) labels        ropes :: [[Doc]]       ropes = map (map text . Set.toList) es +  labelAll (VCRTrace (labels, eventSets))+    = VCRTrace (Map.empty, evalState (mapM nameVCR' eventSets) labels) -toPublic :: ChannelLabels -> SubTraceStore -> IO VCRTrace+toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (VCRTrace Unique) toPublic l (VCRTraceRev tv)   = do setList <- atomically $ readTVar tv        return $ VCRTrace (l, map (Set.map snd) $ reverse setList) toPublic _ _ = error "Error in VCR trace -- tracing type got switched" -nameVCR :: ChannelLabels -> Set.Set RecordedEvent -> Set.Set String-nameVCR m x = Set.fromList $ evalState (mapM nameEvent $ Set.toList x) m+nameVCR :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set String)+nameVCR = liftM Set.fromList . mapM nameEvent . Set.toList +nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set (RecordedEvent String))+nameVCR' = liftM Set.fromList . mapM nameEvent' . Set.toList -runCHP_VCRTrace :: CHP a -> IO (Maybe a, VCRTrace)++runCHP_VCRTrace :: CHP a -> IO (Maybe a, VCRTrace Unique) runCHP_VCRTrace = runCHPAndTrace  runCHP_VCRTraceAndPrint :: CHP a -> IO ()

@@ -1,5 +1,5 @@ Name:            chp-Version:         1.2.0+Version:         1.3.0 Synopsis:        An implementation of concurrency ideas from Communicating Sequential Processes License:         BSD3 License-file:    LICENSE@@ -18,7 +18,7 @@ Category:        Concurrency  Build-Type:      Simple-Build-Depends:   base, containers, mtl, parallel, pretty, stm+Build-Depends:   base >= 3 && < 5, containers, mtl, parallel, pretty, stm  Exposed-modules: Control.Concurrent.CHP                  Control.Concurrent.CHP.Actions@@ -51,7 +51,7 @@                  Control.Concurrent.CHP.Traces.Base  Extensions:      ScopedTypeVariables MultiParamTypeClasses-                 FlexibleInstances UndecidableInstances+                 FlexibleInstances                  GeneralizedNewtypeDeriving CPP  GHC-Options:     -Wall -threaded