module Control.Concurrent.CHP.Event where
import Control.Concurrent.STM
import Control.Monad
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Unique
import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId
data RecordedEventType = ChannelComm | BarrierSync deriving (Eq, Ord, Show)
newtype Event = Event (
Unique,
RecordedEventType,
TVar (WithPoison
(Int,
[OfferSet])
))
instance Eq Event where
(==) = (==) `on` getEventUnique
instance Ord Event where
compare = compare `on` getEventUnique
instance Show Event where
show (Event (u, t, _tv)) = "Event " ++ show (hashUnique u,t)
getEventUnique :: Event -> Unique
getEventUnique (Event (u,_,_)) = u
getEventTVar :: Event -> TVar (WithPoison (Int, [OfferSet]))
getEventTVar (Event (_,_,tv)) = tv
getEventType :: Event -> RecordedEventType
getEventType (Event (_,t,_)) = t
newtype OfferSet = OfferSet (TVar (Maybe [Int])
, ProcessId
, [([Int], Map.Map Event ())])
instance Eq OfferSet where
(==) = (==) `on` (\(OfferSet (tv,_,_)) -> tv)
unionAll :: Ord k => [Map.Map k a] -> Map.Map k a
unionAll = foldl Map.union Map.empty
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, [])
search (offer@(OfferSet (tv, pid, eventSets)) : offers) eventMap
| Map.null mustChooseFromEventSets = tryAll eventSets
| otherwise = tryAll filteredEventSets
where
allEventsInOfferMappedToFalse :: Map.Map Event Bool
allEventsInOfferMappedToFalse = Map.map (const False) (allEventsInOffer offer)
mustChooseFromEventSets :: Map.Map Event Bool
mustChooseFromEventSets
= (Map.filter id eventMap)
`Map.intersection` allEventsInOfferMappedToFalse
filteredEventSets
= [ off
| off@(_,es) <- eventSets,
Map.isSubmapOfBy (\_ _ -> True)
mustChooseFromEventSets
es
]
mapdotall :: Ord k => (a -> Bool) -> Map.Map k a -> Bool
mapdotall f = Map.fold (\x b -> f x && b) True
tryAll :: [([Int],Map.Map Event ())] ->
Maybe (STM (), Map.Map Unique (RecordedEventType, Set.Set ProcessId),
[(TVar (Maybe [Int]), [Event])])
tryAll [] = Nothing
tryAll ((ns, es):next)
| not $ mapdotall id (eventMap `Map.intersection` es)
= 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)
where
eventMap'
= (eventMap `Map.union` (Map.map (const True) es)) `Map.union` allEventsInOfferMappedToFalse
add (tx, pidsx) (_, pidsy) = (tx, pidsx `Set.union` pidsy)
data EventStatus = Fine | NotCompletable deriving (Eq, Show)
resolveOffers :: Maybe (TVar (Maybe [Int])) -> [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
retractOffers $ zip (map fst retract)
(repeat $ unionAll $ map allEventsInOffer allOffers)
return ret
where
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)]
sortOffers :: [OfferSet] -> [OfferSet]
sortOffers xs = sortBy (compare `on` (\(OfferSet (_,_,es)) -> length es)) xs
trim :: ([OfferSet], Set.Set Event) -> ([OfferSet], Set.Set Event)
trim (offers, events) = let ((events', changed), offers') = mapAccumL trimOffer (events,
False) offers
in (if changed then trim else id) (offers', events')
where
trimOffer :: (Set.Set Event, Bool) -> OfferSet -> ((Set.Set Event, Bool), OfferSet)
trimOffer (es, changed) (OfferSet (tv, pid, eventSets))
= let (eventSetsToRemove, eventSetsTrimmed)
= partition (\(_,x) -> not $ (Map.keysSet x) `Set.isSubsetOf` es) eventSets
eventsNotCompletable = Map.keysSet $
(unionAll $ map snd eventSetsToRemove)
`Map.difference` (unionAll $ map snd eventSetsTrimmed)
changed' = changed
|| not (null eventSetsToRemove)
in ((es `Set.difference` eventsNotCompletable, changed'),
OfferSet (tv, pid, eventSetsTrimmed))
discoverRelatedOffers :: [(STM (), Event)] -> STM (WithPoison ([OfferSet], Set.Set Event))
discoverRelatedOffers = discoverRelatedOffersAll $ NoPoison ([], Set.empty)
where
discoverRelatedOffersAll :: WithPoison ([OfferSet], Set.Set Event)
-> [(STM (), Event)]
-> STM (WithPoison ([OfferSet], Set.Set Event))
discoverRelatedOffersAll PoisonItem _ = return PoisonItem
discoverRelatedOffersAll x [] = return x
discoverRelatedOffersAll a@(NoPoison (accum, events)) ((act,e@(Event (_, _, tv))):next)
| e `Set.member` events = discoverRelatedOffersAll a next
| otherwise
= do x <- readTVar tv
case x of
PoisonItem -> act >> return PoisonItem
NoPoison (count, offers) ->
let otherEvents = map allEventsInOffer offers in
if length offers == count
then
discoverRelatedOffersAll
(NoPoison (accum ++ offers, Set.insert e events))
(next ++ zip (repeat $ return ())
(Map.keys $ unionAll otherEvents))
else
discoverRelatedOffersAll a next
discoverAndResolve :: Either OfferSet Event -> STM (WithPoison (Map.Map Unique (RecordedEventType,Set.Set
ProcessId)))
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]
Right e -> [(return (), e)]
case r of
PoisonItem -> return PoisonItem
NoPoison (m, s) -> liftM NoPoison $ resolveOffers tvid (nub m) s
where
tvid = case offOrEvent of
Left (OfferSet (tv, _, _)) -> Just tv
_ -> Nothing
newEvent :: RecordedEventType -> Int -> IO Event
newEvent t n
= do u <- newUnique
atomically $ do tv <- newTVar (NoPoison (n, []))
return $ Event (u, t, tv)
enrollEvent :: Event -> STM (WithPoison ())
enrollEvent e
= do x <- readTVar $ getEventTVar e
case x of
PoisonItem -> return PoisonItem
NoPoison (count, offers) ->
do writeTVar (getEventTVar e) $ NoPoison (count + 1, offers)
return $ NoPoison ()
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)
if (count 1 == length offers)
then liftM (fmap $ \mu -> [((r,u),pids) | (u,(r,pids)) <- Map.toList mu])
$ discoverAndResolve $ Right e
else return $ NoPoison []
retractOffers :: [(TVar (Maybe [Int]), Map.Map Event ())] -> STM ()
retractOffers = mapM_ retractAll
where
retractAll :: (TVar (Maybe [Int]), Map.Map Event ()) -> STM ()
retractAll (tvid, evts) = mapM_ retract (Map.keys evts)
where
retract :: Event -> STM ()
retract e
= do x <- readTVar $ getEventTVar e
case x of
PoisonItem -> return ()
NoPoison (enrolled, offers) ->
let reducedOffers = filter (\(OfferSet (tvx,_,_)) -> tvx /= tvid) offers in
writeTVar (getEventTVar e) $ NoPoison (enrolled, reducedOffers)
makeOffers :: OfferSet -> STM (WithPoison ())
makeOffers offers
= do let allEvents = Map.keys $ allEventsInOffer offers
liftM mergeWithPoison $ mapM makeOffer allEvents
where
makeOffer :: Event -> STM (WithPoison ())
makeOffer e
= do x <- readTVar $ getEventTVar e
case x of
PoisonItem -> return PoisonItem
NoPoison (count, prevOffers) ->
do writeTVar (getEventTVar e) $ NoPoison (count, offers : prevOffers)
return $ NoPoison ()
enableEvents :: TVar (Maybe [Int]) -> ProcessId -> [([Int], STM
(), [Event])] -> Bool -> STM (Maybe ([Int], [((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])
makeOffers offer
pmu <- discoverAndResolve (Left offer)
case (canCommitToWait, pmu) of
(_, PoisonItem) -> do Just chosen <- readTVar tvNotify
return $ Just (chosen, [])
(True, NoPoison mu) | Map.null mu -> return Nothing
(False, NoPoison mu) | Map.null mu ->
do retractOffers [(tvNotify, Map.fromList $ zip es (repeat ())) | (_,_,es) <- events]
return Nothing
(_, NoPoison mu) ->
do
Just chosen <- readTVar tvNotify
return $ Just (chosen, [((r,u),pids) | (u,(r,pids)) <- Map.toList mu])
disableEvents :: TVar (Maybe [Int]) -> [Event] -> STM (Maybe [Int])
disableEvents tv events
= do x <- readTVar tv
when (isNothing x) $
retractOffers [(tv, Map.fromList $ zip events (repeat ()))]
return x
checkEventForPoison :: Event -> STM (WithPoison ())
checkEventForPoison e
= do x <- readTVar $ getEventTVar e
case x of
PoisonItem -> return PoisonItem
_ -> return (NoPoison ())
poisonEvent :: Event -> STM ()
poisonEvent e
= do x <- readTVar $ getEventTVar e
case x of
PoisonItem -> return ()
NoPoison (_, offers) ->
do retractOffers [(tvw, unionAll $ map snd events)
| OfferSet (tvw, _, events) <- offers]
sequence_ [writeTVar tvw (Just $ pickInts events ++ [0])
| OfferSet (tvw, _, events) <- offers]
writeTVar (getEventTVar e) PoisonItem
where
pickInts :: [([Int], Map.Map Event ())] -> [Int]
pickInts es = case filter ((e `Map.member`) . snd) es of
[] -> []
((ns,_):_) -> ns
(**==**) :: Eq a => [a] -> [a] -> Bool
a **==** b = (length a == length b) && (null $ a \\ b)
(**/=**) :: Eq a => [a] -> [a] -> Bool
a **/=** b = not $ a **==** b
testDiscover :: IO ()
testDiscover
= do test "Empty discover" [(NoPoison 1, False)] [] [0]
test "Single full event" [(NoPoison 1, True)] [(True, [[0]])] [0]
test "Two separate events A" [(NoPoison 1, True), (NoPoison 1, False)]
[ (True, [[0]]), (False, [[1]]) ] [0]
test "Two separate events B" [(NoPoison 1, False), (NoPoison 1, True)]
[ (False, [[0]]), (True, [[1]]) ] [1]
test "Three channels, linked by two OR-offerers"
[(NoPoison 2, False), (NoPoison 2, True), (NoPoison
2, False)]
(zip (repeat True) [ [[0],[1]] , [[1],[2]] ]) [1,2]
test "Three channels, linked by two AND-offerers"
[(NoPoison 2, False), (NoPoison 2, True), (NoPoison
2, False)]
(zip (repeat True) [ [[0,1]] , [[1,2]] ]) [0,1]
test "Three barriers, one process offering all pairs"
(replicate 3 (NoPoison 2, False))
[(False,[ [0,1], [0,2], [1,2] ])] [0]
test_Poison "Single poisoned event" [PoisonItem] [ [[0]] ] [0]
test_Poison "Two poisoned events"
[PoisonItem, PoisonItem]
[ [[0,1]] ] [0,1]
test_Poison "One poisoned, one non-poisoned event"
[PoisonItem, NoPoison 1] [ [[0,1]] ] [0,1]
where
test :: String ->
[(WithPoison Int , Bool )] ->
[(Bool, [[Int] ])] -> [Int] -> IO ()
test testName eventCounts offerSets startEvents
= do (events, realOffers) <- makeTestEvents (map fst eventCounts) (map snd offerSets)
let expectedResult
= ([off | (n,off) <- zip [0..] realOffers, fst $ offerSets !! n]
,Set.fromList [events !! n
| (n,(_count, present)) <- zip [0..] eventCounts,
present])
act <- atomically $ discoverRelatedOffers
$ zip (repeat $ return ()) $ map (events!!) startEvents
case act of
PoisonItem -> putStrLn $ testName ++ "Unexpected poison"
NoPoison actualResult -> do
when (fst expectedResult **/=** fst actualResult)
$ putStrLn $ testName ++ " failed offers, exp: "
++ show (length $ fst expectedResult)
++ " got: " ++ show (length $ fst actualResult)
when (snd expectedResult /= snd actualResult)
$ putStrLn $ testName ++ " failed events "
++ "exp: " ++ show (snd expectedResult)
++ "but got: " ++ show (snd actualResult)
test_Poison :: String ->
[WithPoison Int ] ->
[[[Int] ]] -> [Int] -> IO ()
test_Poison testName eventCounts offerSets startEvents
= do (events, _realOffers) <- makeTestEvents eventCounts offerSets
act <- atomically $ discoverRelatedOffers
$ zip (repeat $ return ()) (map (events!!) startEvents)
case act of
PoisonItem -> return ()
NoPoison _ -> putStrLn $ testName ++ " expected poison but none"
testTrim :: IO ()
testTrim
= do test "Empty trim" [(NoPoison 1, False)] [] [0]
test "Trim, Three channels, linked by two OR-offerers"
[(NoPoison 2, False), (NoPoison 2, True), (NoPoison 2, False)]
[ [(False, [0]), (True, [1])] , [(True, [1]), (False, [2])] ] [1]
test "Trim, simplified santa not complete"
(replicate 4 (NoPoison 2, False))
[ zip (repeat False) [[0,1,2],[0,1,3],[0,2,3],[1,2,3]], [(False, [0])],
[(False, [1])]] [0]
test "Trim, simplified santa complete"
(replicate 3 (NoPoison 2, True) ++ [(NoPoison 2, False)])
[ [(True,[0,1,2]),(False,[0,1,3]),(False,[0,2,3]),(False,[1,2,3])], [(True, [0])],
[(True, [1])], [(True, [2])]] [0]
where
test :: String ->
[(WithPoison Int , Bool )] ->
[ [(Bool, [Int]) ]] -> [Int] -> IO ()
test testName eventCounts offerSets startEvents
= do (events, realOffers) <- makeTestEvents (map fst eventCounts) (map (map snd) offerSets)
let expectedResult' = NoPoison $
([OfferSet (tv,pid,[off | (m,off) <- zip [0..] offs, fst $ offerSets !! n !! m])
| (n,OfferSet (tv,pid,offs)) <- zip [0..] realOffers]
,Set.fromList [events !! n
| (n,(_count, present)) <- zip [0..] eventCounts,
present])
actualResult' <- liftM (fmap $ trim . (\(xs,y) -> (nub $ maybe id (:) (listToMaybe realOffers) xs, y)))
$ atomically $ discoverRelatedOffers $ zip (repeat $ return ()) (map (events!!) startEvents)
case (expectedResult', actualResult') of
(PoisonItem, PoisonItem) -> return ()
(PoisonItem, _) -> putStrLn $ testName ++ " expected poison but none found"
(_, PoisonItem) -> putStrLn $ testName ++ " unexpected poison"
(NoPoison expectedResult, NoPoison actualResult)
-> do
when (fst expectedResult **/=** fst actualResult)
$ putStrLn $ testName ++ " failed offers, exp: "
++ show (length $ fst expectedResult)
++ " got: " ++ show (length $ fst actualResult)
when (snd expectedResult /= snd actualResult)
$ putStrLn $ testName ++ " failed events, exp: "
++ show (snd expectedResult)
++ "but got: " ++ show (snd actualResult)
testPoison :: IO ()
testPoison = do
test "Poison empty event" [(NoPoison 2, PoisonItem)] [] 0
test "Poison, single offerer" [(NoPoison 2, PoisonItem)] [[[0]]] 0
test "Poison, offered on two (AND)" [(NoPoison 2, PoisonItem), (NoPoison 2, NoPoison [])] [[[0,1]]] 0
test "Poison, offered on two (OR)" [(NoPoison 2, PoisonItem), (NoPoison 2, NoPoison [])] [[[0],[1]]] 0
where
test :: String ->
[(WithPoison Int , WithPoison [Int] )] ->
[[[Int] ]] -> Int -> IO ()
test testName eventCounts offerSets poisoned = do
(events, realOffers) <- makeTestEvents (map fst eventCounts) offerSets
atomically $ poisonEvent $ events !! poisoned
sequence_ [do x <- atomically $ readTVar $ getEventTVar $ events !! n
case (expect, x) of
(PoisonItem, PoisonItem) -> return ()
(NoPoison _, PoisonItem) -> putStrLn $ testName ++
" expected no poison but found it"
(PoisonItem, NoPoison _) -> putStrLn $ testName ++
" expected poison but found none"
(NoPoison expOff, NoPoison (_, actOff)) ->
when (map (realOffers !!) expOff **/=** actOff) $
putStrLn $ testName ++ " offers did not match"
| (n, (_, expect)) <- zip [0..] eventCounts]
testAll :: IO ()
testAll = testDiscover >> testTrim >> testResolve >> testPoison
makeTestEvents ::
[WithPoison Int ] ->
[[[Int] ]] -> IO ([Event], [OfferSet])
makeTestEvents eventCounts offerSets
= do events <- mapM (\n -> newEvent ChannelComm $ case n of
NoPoison n' -> n'
PoisonItem -> 0) eventCounts
atomically $ sequence_ [writeTVar tv PoisonItem | (n,Event (_,_,tv)) <- zip [0..] events,
eventCounts !! n == PoisonItem]
realOffers <- sequence
[ do tv <- atomically $ newTVar Nothing
let pid = testProcessId processN
offSub = [ ([processN, offerN],
Map.fromList [ (events !! indivEvent, ())
| indivEvent <- singleOffer])
| (offerN, singleOffer) <- zip [0..] processOffers]
off = OfferSet (tv, pid, offSub)
mapM_ (\e -> atomically $ do
x <- readTVar (getEventTVar e)
case x of
NoPoison (count, offs) ->
writeTVar (getEventTVar e) $ NoPoison (count, off : offs)
PoisonItem -> return ()
) (Map.keys $ unionAll $ map snd offSub)
return off
| (processN, processOffers) <- zip [0..] offerSets]
return (events, realOffers)
testResolve :: IO ()
testResolve
= do test "Empty Resolve" [(NoPoison 0, Right [])] [[]]
test "Single offer" [(NoPoison 1, Left [(0,0)])] [[[0]]]
test "Not enough" [(NoPoison 2, Right [0])] [[[0]]]
test "One channel" [(NoPoison 2, Left [(0,0),(1,0)])] [[[0]],[[0]]]
test "Two channels, two single offerers and one double"
[(NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2, Left [(1,0),(2,0)])]
[ [[0]], [[1]], [[0,1]] ]
test "Two channels, two single offerers and one choosing"
[(NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2, Right [1])]
[ [[0]], [[1]], [[0],[1]] ]
test "Three channels, both offering different pair"
[(NoPoison 2, Right []), (NoPoison 2, Left [(0,1),(1,0)]), (NoPoison 2, Right [])]
[ [[0],[1]] , [[1],[2]] ]
test "Two channels, both could complete"
[(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Right [])]
[ [[0],[1]] , [[0],[1]] ]
test "Three channels, any could complete"
[(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Right [2]), (NoPoison 2,
Right [2])]
[ [[0],[1]] , [[0],[2]], [[1],[2]] ]
test "Three channels, one guy offering three pairs, two single offerers"
[(NoPoison 2, Left [(0,1),(1,0)]), (NoPoison 2, Right []), (NoPoison 2,
Left [(0,1),(2,0)])]
[ [[0,1],[0,2],[1,2]], [[0]], [[2]] ]
test "Three channels, one guy offering three pairs, three single offerers"
[(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2,
Right [3])]
[ [[0,1],[0,2],[1,2]], [[0]], [[1]], [[2]] ]
test "Four channels, one guy offering sets of three, three single offerers"
[(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Left [(0,0),(2,0)]),
(NoPoison 2, Left [(0,0),(3,0)]), (NoPoison 2, Right [])]
[ [[0,1,2],[0,1,3],[0,2,3],[1,2,3]], [[0]], [[1]], [[2]] ]
test "Four channels, one guy offering sets of three, two single offerers"
[(NoPoison 2, Right [1,0]), (NoPoison 2, Right [2,0]),
(NoPoison 2, Right [0]), (NoPoison 2, Right [0])]
[ [[0,1,2],[0,1,3],[0,2,3],[1,2,3]], [[0]], [[1]] ]
test' "One event, poisoned"
[(PoisonItem, Left [(0,0)])]
[[[0]]] True
test' "Two events, one poisoned"
[(PoisonItem, Left [(0,0)]), (NoPoison 2, Left [(0,0)])]
[[[0,1]]] True
where
test testName eventCounts offerSets = test' testName eventCounts offerSets False
test' :: String ->
[(WithPoison Int ,
Either [(Int, Int)]
[Int] )] ->
[[[Int] ]] -> Bool -> IO ()
test' testName eventCounts offerSets poisoned = do
(events, realOffers) <- makeTestEvents (map fst eventCounts) offerSets
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))
| (e, Left is) <- zip events (map snd eventCounts)]
when (expectedResult /= actualResult) $
putStrLn $ testName ++ " failed on direct result, expected: "
++ showStuff expectedResult ++ " got: " ++ showStuff actualResult
allFired <- liftM concat $ mapM (flip either (const $ return []) $ mapM $ \(pn, en) ->
let OfferSet (tv,_,_) = realOffers !! pn in
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]
return pn
) $ map snd eventCounts
sequence_ [ let OfferSet (tv,_,_) = realOffers !! n in
do x <- atomically $ readTVar tv
case x of
Nothing -> return ()
Just _ -> putStrLn $ testName ++ " Unexpected win for process: " ++
show n ++ " " ++ show x
| n <- [0 .. length offerSets 1] \\ allFired]
sequence_ [ let e = events !! n
expVal = case st of
Left _ -> []
Right ns -> map (realOffers !!) ns in do
x <- atomically $ readTVar $ getEventTVar e
when (x /= NoPoison (count, expVal)) $
putStrLn $ testName ++ "Event " ++ show n ++
" not as expected after, exp: " ++ show (length expVal)
++ " 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)