module Control.Concurrent.CHP.Event (RecordedEventType(..), Event, getEventUnique,
SignalVar, SignalValue(..), enableEvents, disableEvents,
newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison,
getEventTypeVal
#ifdef CHP_TEST
, testAll
#endif
) 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)
#ifdef CHP_TEST
import Test.HUnit hiding (test)
#endif
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
#ifdef CHP_TEST
(**==**) :: 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 (first hashUnique) . Map.toList)
#endif