module Control.Concurrent.CHP.Event (RecordedEventType(..), Event, getEventUnique,
SignalVar, SignalValue(..), enableEvents, disableEvents,
newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison,
testAll, getEventTypeVal) where
import Control.Arrow
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 qualified Data.Traversable as T
import Data.Unique
import Prelude hiding (seq)
import Test.HUnit hiding (test)
import Control.Concurrent.CHP.Poison
import Control.Concurrent.CHP.ProcessId
data RecordedEventType
= ChannelComm String
| BarrierSync String
| ClockSync String deriving (Eq, Ord, Show)
getEventTypeVal :: RecordedEventType -> String
getEventTypeVal (ChannelComm s) = s
getEventTypeVal (BarrierSync s) = s
getEventTypeVal (ClockSync s) = s
newtype Event = Event (
Unique,
STM RecordedEventType,
TVar (WithPoison
(Int,
Integer,
[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)
getEventUnique :: Event -> Unique
getEventUnique (Event (u,_,_)) = u
getEventTVar :: Event -> TVar (WithPoison (Int, Integer, [OfferSet]))
getEventTVar (Event (_,_,tv)) = tv
getEventType :: Event -> STM RecordedEventType
getEventType (Event (_,t,_)) = t
newtype SignalValue = Signal (WithPoison Int)
deriving (Eq, Show)
type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique (Integer, RecordedEventType)))
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
, ProcessId
, [((SignalValue, STM ()), Map.Map Event ())])
instance Eq OfferSet where
(==) = (==) `on` (\(OfferSet (tv,_,_)) -> tv)
instance Show OfferSet where
show (OfferSet (_, pid, vs)) = "OfferSet " ++ show (pid, map (first fst) vs)
unionAll :: Ord k => [Map.Map k a] -> Map.Map k a
unionAll [] = Map.empty
unionAll ms = foldl1 Map.union ms
allEventsInOffer :: OfferSet -> Map.Map Event ()
allEventsInOffer (OfferSet (_, _, [(_,es)])) = es
allEventsInOffer (OfferSet (_, _, eventSets)) = unionAll (map snd eventSets)
getAndIncCounter :: Event -> (a, b) -> STM (WithPoison (Integer, a))
getAndIncCounter e (r, _)
= do x <- readTVar (getEventTVar e)
case x of
PoisonItem -> return PoisonItem
NoPoison (a, !n, c) -> do writeTVar (getEventTVar e) $
NoPoison (a, succ n, c)
return $ NoPoison (n, r)
search :: [OfferSet]
-> Map.Map Event Bool
-> Maybe ( [(SignalVar, SignalValue, STM ())]
, Map.Map Event (STM RecordedEventType, Set.Set ProcessId)
)
search [] _ = Just ([], 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
and' :: Ord k => Map.Map k Bool -> Bool
and' = mapdotall id
tryAll :: [((SignalValue, STM ()), Map.Map Event ())]
-> Maybe ( [(SignalVar, SignalValue, STM ())]
, Map.Map Event (STM RecordedEventType, Set.Set ProcessId)
)
tryAll [] = Nothing
tryAll ((ns, es):next)
| not $ and' (eventMap `Map.intersection` es)
= tryAll next
| otherwise = case search offers eventMap' of
Nothing -> tryAll next
Just (act, resolved) -> Just
(if isNullSignal (fst ns) then act else (tv, fst ns, snd ns) : act
, foldl (\m e -> Map.insertWith add e
(getEventType e, Set.singleton pid) m)
resolved (Map.keys es)
)
where
eventMap'
= (eventMap `Map.union` (Map.map (const True) es)) `Map.union` allEventsInOfferMappedToFalse
add (tx, pidsx) (_, pidsy) = (tx, pidsx `Set.union` pidsy)
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) = fromMaybe ([], Map.empty) $
search (map addNullOffer $ sortOffers offers') Map.empty
mapM_ (\(_, _, m) -> m) act
ret' <- T.mapM (\(m,y) -> do x <- m
return (x, y)) ret
eventCounts <- T.sequence $ Map.mapWithKey getAndIncCounter ret'
let NoPoison uniqCounts = T.sequence $ Map.mapKeysMonotonic getEventUnique eventCounts
mapM_ (\(tv, x, _) -> writeTVar tv (Just (x, uniqCounts))) act
retractOffers $ zip (map fst3 act)
(repeat $ unionAll $ map allEventsInOffer allOffers)
return (Map.mapKeysMonotonic getEventUnique ret')
where
fst3 (x, _, _) = x
addNullOffer :: OfferSet -> OfferSet
addNullOffer (OfferSet (tv,y,zs)) = OfferSet (tv,y,if Just tv == newTvid then zs else zs++nullOffer)
nullOffer :: [((SignalValue, STM ()), Map.Map Event ())]
nullOffer = [((nullSignalValue, return ()) ,Map.empty)]
sortOffers :: [OfferSet] -> [OfferSet]
sortOffers xs
| length xs > 2 = sortBy (compare `on` (\(OfferSet (_,_,es)) -> length es)) xs
| otherwise = xs
trim :: ([OfferSet], Set.Set Event) -> ([OfferSet], Set.Set Event)
trim (offers, events) = let ((events', changed), offers') = mapAccumL trimOffer (events,
False) offers
oe = (offers', events')
in if changed then trim oe else oe
where
trimOffer :: (Set.Set Event, Bool) -> OfferSet -> ((Set.Set Event, Bool), OfferSet)
trimOffer (es, changed) o@(OfferSet (tv, pid, eventSets))
= let (eventSetsToRemove, eventSetsTrimmed)
| Set.size es == 1 = partition (\(_,x) -> Map.size x /= 1 || fst (Map.findMin x) /= Set.findMin es) eventSets
| otherwise = 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 if null eventSetsToRemove then ((es, changed), o)
else
((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))
(if Map.size (unionAll otherEvents) == 1
then next
else (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 (addPoison ns, Map.empty)))
(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 :: STM RecordedEventType -> Int -> IO Event
newEvent t n
= do u <- newUnique
atomically $ do tv <- newTVar (NoPoison (n, 0, []))
return $ Event (u, t, tv)
newEventUnique :: IO Unique
newEventUnique = newUnique
enrollEvent :: Event -> STM (WithPoison ())
enrollEvent e
= do x <- readTVar $ getEventTVar e
case x of
PoisonItem -> return PoisonItem
NoPoison (count, seq, offers) ->
do writeTVar (getEventTVar e) $ NoPoison (count + 1, seq, 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, 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 []
retractOffers :: [(SignalVar, Map.Map Event ())] -> STM ()
retractOffers = mapM_ retractAll
where
retractAll :: (SignalVar, 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, seq, offers) ->
let reducedOffers = filter (\(OfferSet (tvx,_,_)) -> tvx /= tvid) offers in
writeTVar (getEventTVar e) $ NoPoison (enrolled, seq, 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, seq, prevOffers) ->
do writeTVar (getEventTVar e) $ NoPoison (count, seq, offers : prevOffers)
return $ NoPoison ()
enableEvents :: SignalVar
-> ProcessId
-> [((SignalValue, STM ()), [Event])]
-> Bool
-> STM (Maybe ((SignalValue, Map.Map Unique (Integer, RecordedEventType)), [((RecordedEventType, Unique), Set.Set ProcessId)]))
enableEvents tvNotify pid events canCommitToWait
= do let offer = OfferSet (tvNotify, pid, [(nid, Map.fromList (zip es (repeat ()))) | (nid, es) <- events])
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 :: SignalVar -> [Event] -> STM (Maybe (SignalValue, Map.Map Unique (Integer,
RecordedEventType)))
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 (addPoison $ pickInts events, Map.empty))
| OfferSet (tvw, _, events) <- offers]
writeTVar (getEventTVar e) PoisonItem
where
pickInts :: [((SignalValue, STM ()), Map.Map Event ())] -> SignalValue
pickInts es = case filter ((e `Map.member`) . snd) es of
[] -> nullSignalValue
(((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 :: Test
testDiscover = TestCase $
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 "Two separate events A, non-completable" [(NoPoison 2, False), (NoPoison 1, False)]
[ (False, [[0]]), (False, [[1]]) ] [0]
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 | ((yes, _),off) <- zip offerSets realOffers, yes]
,Set.fromList [e
| (e,(_count, present)) <- zip events eventCounts,
present])
act <- atomically $ discoverRelatedOffers
$ zip (repeat $ return ()) $ map (events!!) startEvents
case act of
PoisonItem -> assertFailure $ testName ++ "Unexpected poison"
NoPoison actualResult -> do
when (fst expectedResult **/=** fst actualResult)
$ assertFailure $ testName ++ " failed offers, exp: "
++ show (length $ fst expectedResult)
++ " got: " ++ show (length $ fst actualResult)
when (snd expectedResult /= snd actualResult)
$ assertFailure $ 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 _ -> assertFailure $ testName ++ " expected poison but none"
testTrim :: Test
testTrim = TestCase $
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, _) -> assertFailure $ testName ++ " expected poison but none found"
(_, PoisonItem) -> assertFailure $ testName ++ " unexpected poison"
(NoPoison expectedResult, NoPoison actualResult)
-> do
when (fst expectedResult **/=** fst actualResult)
$ assertFailure $ testName ++ " failed offers, exp: "
++ show (length $ fst expectedResult)
++ " got: " ++ show (length $ fst actualResult)
when (snd expectedResult /= snd actualResult)
$ assertFailure $ testName ++ " failed events, exp: "
++ show (snd expectedResult)
++ "but got: " ++ show (snd actualResult)
testPoison :: Test
testPoison = TestCase $ 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) -> assertFailure $ testName ++
" expected no poison but found it"
(PoisonItem, NoPoison _) -> assertFailure $ testName ++
" expected poison but found none"
(NoPoison expOff, NoPoison (_, _, actOff)) ->
when (map (realOffers !!) expOff **/=** actOff) $
assertFailure $ testName ++ " offers did not match"
| (n, (_, expect)) <- zip [0..] eventCounts]
testAll :: Test
testAll = TestList [testDiscover, testTrim, testResolve, testPoison]
makeTestEvents ::
[WithPoison Int ] ->
[[[Int] ]] -> IO ([Event], [OfferSet])
makeTestEvents eventCounts offerSets
= do events <- mapM (\n -> newEvent (return $ 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 = [ ((Signal $ NoPoison (processN + offerN), return ()),
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, s, offs) ->
writeTVar (getEventTVar e) $ NoPoison (count, s, off : offs)
PoisonItem -> return ()
) (Map.keys $ unionAll $ map snd offSub)
return off
| (processN, processOffers) <- zip (map (*1000) [0..]) offerSets]
return (events, realOffers)
testResolve :: Test
testResolve = TestCase $
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 <- liftM (liftM (fmap snd)) $ atomically $ discoverAndResolve $ Left $ head realOffers
let expectedResult = if poisoned then PoisonItem else NoPoison $
Map.fromList [ (getEventUnique e,
Set.fromList $ map (testProcessId . (*1000) . fst) is)
| (e, Left is) <- zip events (map snd eventCounts)]
when (expectedResult /= actualResult) $
assertFailure $ testName ++ " failed on direct result, expected: "
++ 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 -> assertFailure $ "Unexpected no-win for " ++ show (pn,en)
Just v -> when (fst v /= (if poisoned then addPoison else id)
(Signal $ NoPoison ((pn*1000)+en))) $
assertFailure $ testName ++ " wrong choice: " ++ " 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 _ -> assertFailure $ testName ++ " Unexpected win for process: " ++
show n
| n <- [0 .. length offerSets 1] \\ allFired]
c <- sequence
[ let e = events !! n
expVal = case st of
Left _ -> []
Right ns -> map (realOffers !!) ns in do
x <- atomically $ readTVar $ getEventTVar e
case x of
NoPoison (c, _, e') -> return $ Just ((count, expVal), (c, e'))
_ -> do assertFailure $ testName ++ " unexpected poison"
return Nothing
| (n,(NoPoison count, st)) <- zip [0..] eventCounts]
uncurry (assertEqual testName) (unzip $ catMaybes c)
showStuff = show . fmap (map (\(u,x) -> (hashUnique u, x)) . Map.toList)