Commit 30f1a101 authored by Niklas Hambuechen's avatar Niklas Hambuechen Committed by Petr Pudlak

Full QuickCheck 2.7 compatibility

This renames the deprecated `printTestCase` to its replacement
`counterexample`, add provides a CPP-guarded fallback for QuickCheck < 2.7.
Signed-off-by: default avatarNiklas Hambuechen <niklash@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>

Conflicts:
	test/hs/Test/Ganeti/JQScheduler.hs
          - removed file not present in 2.12
	test/hs/Test/Ganeti/SlotMap.hs
          - removed file not present in 2.12

Cherry-picked-from: 077c415aSigned-off-by: default avatarPetr Pudlak <pudlak@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>
parent 531dccee
......@@ -587,14 +587,14 @@ test on that, by default 500 of those big instances are generated for each
property. In many cases, it would be sufficient to only generate those 500
instances once and test all properties on those. To do this, create a property
that uses ``conjoin`` to combine several properties into one. Use
``printTestCase`` to add expressive error messages. For example::
``counterexample`` to add expressive error messages. For example::
prop_myMegaProp :: myBigType -> Property
prop_myMegaProp b =
conjoin
[ printTestCase
[ counterexample
("Something failed horribly here: " ++ show b) (subProperty1 b)
, printTestCase
, counterexample
("Something else failed horribly here: " ++ show b)
(subProperty2 b)
, -- more properties here ...
......
......@@ -146,9 +146,9 @@ prop_monad_laws :: Int -> Result Int
-> Property
prop_monad_laws a m (Fun _ k) (Fun _ h) =
conjoin
[ printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a)
, printTestCase "m >>= return == m" ((m >>= return) ==? m)
, printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"
[ counterexample "return a >>= k == k a" ((return a >>= k) ==? k a)
, counterexample "m >>= return == m" ((m >>= return) ==? m)
, counterexample "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)"
((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h))
]
......@@ -159,11 +159,11 @@ prop_monad_laws a m (Fun _ k) (Fun _ h) =
-- > v >> mzero = mzero
prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property
prop_monadplus_mzero v (Fun _ f) =
printTestCase "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
counterexample "mzero >>= f = mzero" ((mzero >>= f) ==? mzero) .&&.
-- FIXME: since we have "many" mzeros, we can't test for equality,
-- just that we got back a 'Bad' value; I'm not sure if this means
-- our MonadPlus instance is not sound or not...
printTestCase "v >> mzero = mzero" (isBad (v >> mzero))
counterexample "v >> mzero = mzero" (isBad (v >> mzero))
testSuite "BasicTypes"
[ 'prop_functor_id
......
......@@ -70,10 +70,10 @@ prop_req_sign key (NonNegative timestamp) (Positive bad_delta)
bad_timestamp = timestamp + if pm then bad_delta' else (-bad_delta')
ts_ok = Confd.Utils.parseRequest key signed good_timestamp
ts_bad = Confd.Utils.parseRequest key signed bad_timestamp
in printTestCase "Failed to parse good message"
in counterexample "Failed to parse good message"
(ts_ok ==? BasicTypes.Ok (encoded, crq)) .&&.
printTestCase ("Managed to deserialise message with bad\
\ timestamp, got " ++ show ts_bad)
counterexample ("Managed to deserialise message with bad\
\ timestamp, got " ++ show ts_bad)
(ts_bad ==? BasicTypes.Bad "Too old/too new timestamp or clock skew")
-- | Tests that a ConfdReply can be properly encoded, signed and parsed using
......@@ -105,7 +105,7 @@ prop_bad_key salt crq =
forAll (vector 20 `suchThat` (/= key_sign)) $ \key_verify ->
let signed = Confd.Utils.signMessage key_sign salt (J.encode crq)
encoded = J.encode signed
in printTestCase ("Accepted message signed with different key" ++ encoded) $
in counterexample ("Accepted message signed with different key" ++ encoded) $
(Confd.Utils.parseSignedMessage key_verify encoded
:: BasicTypes.Result (String, String, Confd.ConfdRequest)) ==?
BasicTypes.Bad "HMAC verification failed"
......
......@@ -92,8 +92,8 @@ prop_Load_Instance name mem dsk vcpus status
sbal, pnode, pnode, tags]
in case inst of
Bad msg -> failTest $ "Failed to load instance: " ++ msg
Ok (_, i) -> printTestCase "Mismatch in some field while\
\ loading the instance" $
Ok (_, i) -> counterexample "Mismatch in some field while\
\ loading the instance" $
Instance.name i == name &&
Instance.vcpus i == vcpus &&
Instance.mem i == mem &&
......@@ -110,7 +110,7 @@ prop_Load_InstanceFail ktn fields =
length fields < 10 || length fields > 12 ==>
case Text.loadInst nl fields of
Ok _ -> failTest "Managed to load instance from invalid data"
Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
Bad msg -> counterexample ("Unrecognised error message: " ++ msg) $
"Invalid/incomplete instance data: '" `isPrefixOf` msg
where nl = Map.fromList ktn
......@@ -215,7 +215,7 @@ prop_CreateSerialise =
Cluster.iterateAlloc nl Container.empty (Just maxiter) inst allocn [] []
of
Bad msg -> failTest $ "Failed to allocate: " ++ msg
Ok (_, _, _, [], _) -> printTestCase
Ok (_, _, _, [], _) -> counterexample
"Failed to allocate: no allocations" False
Ok (_, nl', il', _, _) ->
let cdata = Loader.ClusterData defGroupList nl' il' ctags
......
......@@ -157,9 +157,9 @@ prop_Alloc_sane inst =
Just (xnl, xi, _, cv) ->
let il' = Container.add (Instance.idx xi) xi il
tbl = Cluster.Table xnl il' cv []
in printTestCase "Cluster can be balanced after allocation"
in counterexample "Cluster can be balanced after allocation"
(not (canBalance tbl True True False)) .&&.
printTestCase "Solution score differs from actual node list"
counterexample "Solution score differs from actual node list"
(abs (Cluster.compCV xnl - cv) < 1e-12)
-- | Checks that on a 2-5 node cluster, we can allocate a random
......@@ -187,7 +187,7 @@ prop_CanTieredAlloc =
all_nodes fn = sum $ map fn (Container.elems nl)
all_res fn = sum $ map fn [ai_alloc, ai_pool, ai_unav]
in conjoin
[ printTestCase "No instances allocated" $ not (null ixes)
[ counterexample "No instances allocated" $ not (null ixes)
, IntMap.size il' ==? length ixes
, length ixes ==? length cstats
, all_res Types.allocInfoVCpus ==? all_nodes Node.hiCpu
......@@ -253,7 +253,7 @@ check_EvacMode grp inst result =
v -> failmsg ("invalid solution: " ++ show v) False
]
where failmsg :: String -> Bool -> Property
failmsg msg = printTestCase ("Failed to evacuate: " ++ msg)
failmsg msg = counterexample ("Failed to evacuate: " ++ msg)
idx = Instance.idx inst
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
......@@ -316,7 +316,7 @@ prop_AllocBalance =
let ynl = Container.add (Node.idx hnode) hnode xnl
cv = Cluster.compCV ynl
tbl = Cluster.Table ynl il' cv []
in printTestCase "Failed to rebalance" $
in counterexample "Failed to rebalance" $
canBalance tbl True True False
-- | Checks consistency.
......@@ -380,9 +380,9 @@ prop_AllocPolicy =
let rqn = Instance.requiredNodes $ Instance.diskTemplate inst
node' = Node.setPolicy ipol node
nl = makeSmallCluster node' count
in printTestCase "Allocation check:"
in counterexample "Allocation check:"
(isNothing (canAllocOn (makeSmallCluster node count) rqn inst)) .&&.
printTestCase "Policy failure check:" (isJust $ canAllocOn nl rqn inst)
counterexample "Policy failure check:" (isJust $ canAllocOn nl rqn inst)
testSuite "HTools/Cluster"
[ 'prop_Score_Zero
......
......@@ -88,7 +88,7 @@ prop_findByName =
in conjoin
[ Container.findByName nl' (Node.name target) ==? Just target
, Container.findByName nl' (Node.alias target) ==? Just target
, printTestCase "Found non-existing name"
, counterexample "Found non-existing name"
(isNothing (Container.findByName nl' othername))
]
......
......@@ -324,7 +324,7 @@ prop_rMem inst =
in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
(Ok a_ab, Ok a_nb,
Ok d_ab, Ok d_nb) ->
printTestCase "Consistency checks failed" $
counterexample "Consistency checks failed" $
Node.rMem a_ab > orig_rmem &&
Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
Node.rMem a_nb == orig_rmem &&
......
......@@ -164,7 +164,7 @@ prop_IPolicy_serialisation = testSerialisation
prop_opToResult :: Types.OpResult Int -> Property
prop_opToResult op =
case op of
Bad _ -> printTestCase ("expected bad but got " ++ show r) $ isBad r
Bad _ -> counterexample ("expected bad but got " ++ show r) $ isBad r
Ok v -> case r of
Bad msg -> failTest ("expected Ok but got Bad " ++ msg)
Ok v' -> v ==? v'
......
......@@ -139,7 +139,7 @@ isAlmostEqual (LCList c1) (LCList c2) =
(length c1 ==? length c2) .&&.
conjoin (zipWith isAlmostEqual c1 c2)
isAlmostEqual (LCString s1) (LCString s2) = s1 ==? s2
isAlmostEqual (LCDouble d1) (LCDouble d2) = printTestCase msg $ rel <= 1e-12
isAlmostEqual (LCDouble d1) (LCDouble d2) = counterexample msg $ rel <= 1e-12
where rel = relativeError d1 d2
msg = "Relative error " ++ show rel ++ " not smaller than 1e-12\n" ++
"expected: " ++ show d2 ++ "\n but got: " ++ show d1
......@@ -166,7 +166,7 @@ prop_config :: LispConfig -> Property
prop_config conf =
case A.parseOnly lispConfigParser . pack . serializeConf $ conf of
Left msg -> failTest $ "Parsing failed: " ++ msg
Right obtained -> printTestCase "Failing almost equal check" $
Right obtained -> counterexample "Failing almost equal check" $
isAlmostEqual obtained conf
-- | Test whether a randomly generated UptimeInfo text line can be parsed.
......
......@@ -129,15 +129,15 @@ prop_JobStatus =
-- computes status for a job with an added opcode after
st_post_op pop = calcJobStatus (job1 { qjOps = qjOps job1 ++ [pop] })
in conjoin
[ printTestCase "pre-success doesn't change status"
[ counterexample "pre-success doesn't change status"
(st_pre_op op_succ ==? st1)
, printTestCase "post-success doesn't change status"
, counterexample "post-success doesn't change status"
(st_post_op op_succ ==? st1)
, printTestCase "pre-error is error"
, counterexample "pre-error is error"
(st_pre_op op_err ==? JOB_STATUS_ERROR)
, printTestCase "pre-canceling is canceling"
, counterexample "pre-canceling is canceling"
(st_pre_op op_cnl ==? JOB_STATUS_CANCELING)
, printTestCase "pre-canceled is canceled"
, counterexample "pre-canceled is canceled"
(st_pre_op op_cnd ==? JOB_STATUS_CANCELED)
]
......@@ -197,10 +197,10 @@ prop_ListJobIDs = monadicIO $ do
full_dir <- extractJobIDs $ getJobIDs [tempdir]
invalid_dir <- getJobIDs [tempdir </> "no-such-dir"]
return (empty_dir, sortJobIDs full_dir, invalid_dir)
stop $ conjoin [ printTestCase "empty directory" $ e ==? []
, printTestCase "directory with valid names" $
stop $ conjoin [ counterexample "empty directory" $ e ==? []
, counterexample "directory with valid names" $
f ==? sortJobIDs jobs
, printTestCase "invalid directory" $ isBad g
, counterexample "invalid directory" $ isBad g
]
-- | Tests loading jobs from disk.
......@@ -237,7 +237,7 @@ prop_LoadJobs = monadicIO $ do
, current ==? Ganeti.BasicTypes.Ok (job, False)
, archived ==? Ganeti.BasicTypes.Ok (job, True)
, missing_current ==? noSuchJob
, printTestCase "broken job" (isBad broken)
, counterexample "broken job" (isBad broken)
]
-- | Tests computing job directories. Creates random directories,
......@@ -280,15 +280,15 @@ prop_InputOpCode meta i =
-- | Tests 'extractOpSummary'.
prop_extractOpSummary :: MetaOpCode -> Int -> Property
prop_extractOpSummary meta i =
conjoin [ printTestCase "valid opcode" $
conjoin [ counterexample "valid opcode" $
extractOpSummary (ValidOpCode meta) ==? summary
, printTestCase "invalid opcode, correct object" $
, counterexample "invalid opcode, correct object" $
extractOpSummary (InvalidOpCode jsobj) ==? summary
, printTestCase "invalid opcode, empty object" $
, counterexample "invalid opcode, empty object" $
extractOpSummary (InvalidOpCode emptyo) ==? invalid
, printTestCase "invalid opcode, object with invalid OP_ID" $
, counterexample "invalid opcode, object with invalid OP_ID" $
extractOpSummary (InvalidOpCode invobj) ==? invalid
, printTestCase "invalid opcode, not jsobject" $
, counterexample "invalid opcode, not jsobject" $
extractOpSummary (InvalidOpCode jsinval) ==? invalid
]
where summary = opSummary (metaOpCode meta)
......
......@@ -145,7 +145,7 @@ prop_LocksDisjoint =
forAll (arbitrary `suchThat` (/= a)) $ \b ->
let aExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks a state
bAll = M.keysSet $ listLocks b state
in printTestCase
in counterexample
(show a ++ "'s exclusive lock" ++ " is not respected by " ++ show b)
(S.null $ S.intersection aExclusive bAll)
......@@ -156,7 +156,7 @@ prop_LockslistComplete =
forAll (arbitrary :: Gen TestOwner) $ \a ->
forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
`suchThat` (not . M.null . listLocks a)) $ \state ->
printTestCase "All owned locks must be mentioned in the all-locks list" $
counterexample "All owned locks must be mentioned in the all-locks list" $
let allLocks = listAllLocks state in
all (`elem` allLocks) (M.keys $ listLocks a state)
......@@ -165,8 +165,8 @@ prop_LockslistComplete =
prop_LocksAllOwnersSubsetLockslist :: Property
prop_LocksAllOwnersSubsetLockslist =
forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
printTestCase "The list of all active locks must contain all locks mentioned\
\ in the locks state" $
counterexample "The list of all active locks must contain all locks mentioned\
\ in the locks state" $
S.isSubsetOf (S.fromList . map fst $ listAllLocksOwners state)
(S.fromList $ listAllLocks state)
......@@ -177,7 +177,7 @@ prop_LocksAllOwnersComplete =
forAll (arbitrary :: Gen TestOwner) $ \a ->
forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
`suchThat` (not . M.null . listLocks a)) $ \state ->
printTestCase "Owned locks must be mentioned in list of all locks' state" $
counterexample "Owned locks must be mentioned in list of all locks' state" $
let allLocksState = listAllLocksOwners state
in flip all (M.toList $ listLocks a state) $ \(lock, ownership) ->
elem (a, ownership) . fromMaybe [] $ lookup lock allLocksState
......@@ -188,8 +188,8 @@ prop_LocksAllOwnersSound :: Property
prop_LocksAllOwnersSound =
forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
`suchThat` (not . null . listAllLocksOwners)) $ \state ->
printTestCase "All locks mentioned in listAllLocksOwners must be owned by the\
\ mentioned owner" .
counterexample "All locks mentioned in listAllLocksOwners must be owned by\
\ the mentioned owner" .
flip all (listAllLocksOwners state) $ \(lock, owners) ->
flip all owners $ \(owner, ownership) -> holdsLock owner lock ownership state
......@@ -202,7 +202,7 @@ prop_LockImplicationX =
forAll (arbitrary :: Gen TestOwner) $ \a ->
forAll (arbitrary `suchThat` (/= a)) $ \b ->
let bExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks b state
in printTestCase "Others cannot have an exclusive lock on an implied lock" .
in counterexample "Others cannot have an exclusive lock on an implied lock" .
flip all (M.keys $ listLocks a state) $ \lock ->
flip all (lockImplications lock) $ \impliedlock ->
not $ S.member impliedlock bExclusive
......@@ -217,7 +217,7 @@ prop_LockImplicationS =
forAll (arbitrary `suchThat` (/= a)) $ \b ->
let aExclusive = M.keys . M.filter (== OwnExclusive) $ listLocks a state
bAll = M.keysSet $ listLocks b state
in printTestCase "Others cannot hold locks implied by an exclusive lock" .
in counterexample "Others cannot hold locks implied by an exclusive lock" .
flip all aExclusive $ \lock ->
flip all (lockImplications lock) $ \impliedlock ->
not $ S.member impliedlock bAll
......@@ -245,12 +245,12 @@ prop_LockupdateAtomic =
forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
let (state', result) = updateLocks a request state
in if result == Ok S.empty
then printTestCase
then counterexample
("Update succeeded, but in final state " ++ show state'
++ "not all locks are as requested")
$ let owned = listLocks a state'
in all (requestSucceeded owned) request
else printTestCase
else counterexample
("Update failed, but state changed to " ++ show state')
(state == state')
......@@ -261,7 +261,7 @@ prop_LockReleaseSucceeds =
forAll (arbitrary :: Gen TestOwner) $ \a ->
forAll (arbitrary :: Gen TestLock) $ \lock ->
let (_, result) = updateLocks a [requestRelease lock] state
in printTestCase
in counterexample
("Releasing a lock has to suceed uncondiationally, but got "
++ show result)
(isOk result)
......@@ -281,7 +281,7 @@ prop_BlockSufficient =
. snd . updateLocks a request)) $ \state ->
let (_, result) = updateLocks a request state
blockedOn = genericResult (const S.empty) id result
in printTestCase "After all blockers release, a request must succeed"
in counterexample "After all blockers release, a request must succeed"
. isOk . snd . updateLocks a request $ F.foldl freeLocks state blockedOn
-- | Verify the property that every blocking owner is necessary, i.e., even
......@@ -301,7 +301,7 @@ prop_BlockNecessary =
. snd . updateLocks a request)) $ \state ->
let (_, result) = updateLocks a request state
blockers = genericResult (const S.empty) id result
in printTestCase "Each blocker alone must block the request"
in counterexample "Each blocker alone must block the request"
. flip all (S.elems blockers) $ \blocker ->
(==) (Ok $ S.singleton blocker) . snd . updateLocks a request
. F.foldl freeLocks state
......@@ -332,7 +332,7 @@ prop_OwnerSound :: Property
prop_OwnerSound =
forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
`suchThat` (not . null . lockOwners)) $ \state ->
printTestCase "All subjects listed as owners must own at least one lock"
counterexample "All subjects listed as owners must own at least one lock"
. flip all (lockOwners state) $ \owner ->
not . M.null $ listLocks owner state
......
......@@ -78,7 +78,7 @@ prop_ImpliedOrder :: Property
prop_ImpliedOrder =
forAll ((arbitrary :: Gen GanetiLocks)
`suchThat` (not . null . lockImplications)) $ \b ->
printTestCase "Implied locks must be earlier in the lock order"
counterexample "Implied locks must be earlier in the lock order"
. flip all (lockImplications b) $ \a ->
a < b
......@@ -89,7 +89,7 @@ prop_ImpliedIntervall =
`suchThat` (not . null . lockImplications)) $ \b ->
forAll (elements $ lockImplications b) $ \a ->
forAll (arbitrary `suchThat` liftA2 (&&) (a <) (<= b)) $ \x ->
printTestCase ("Locks between a group and a member of the group"
counterexample ("Locks between a group and a member of the group"
++ " must also belong to the group")
$ a `elem` lockImplications x
......
......@@ -125,7 +125,7 @@ prop_NoActionWithPendingRequests =
`suchThat` (S.member a . getPendingOwners)) $ \state ->
forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
forAll arbitrary $ \prio ->
printTestCase "Owners with pending requests may not update locks"
counterexample "Owners with pending requests may not update locks"
. all (isBad . fst . snd)
$ [updateLocks, updateLocksWaiting prio] <*> [a] <*> [req] <*> [state]
......@@ -160,8 +160,8 @@ forAllBlocked predicate =
prop_WaitingRequestsGetPending :: Property
prop_WaitingRequestsGetPending =
forAllBlocked $ \state owner prio req ->
printTestCase "After a not immediately fulfilled waiting request, owner\
\ must have a pending request"
counterexample "After a not immediately fulfilled waiting request, owner\
\ must have a pending request"
. S.member owner . getPendingOwners . fst
$ updateLocksWaiting prio owner req state
......@@ -176,8 +176,9 @@ prop_PendingGetFulfilledEventually =
state'' = S.foldl (\s a -> fst $ releaseResources a s) state'
$ S.union oldpending blockers
finallyOwned = listLocks owner $ getAllocation state''
in printTestCase "After all blockers and old pending owners give up their\
\ resources, a pending request must be granted automatically"
in counterexample "After all blockers and old pending owners give up their\
\ resources, a pending request must be granted\
\ automatically"
$ all (requestSucceeded finallyOwned) req
-- | Verify that the owner of a pending request gets notified once all blockers
......@@ -193,8 +194,8 @@ prop_PendingGetNotifiedEventually =
in (s', newnotify `S.union` tonotify)
(_, notified) = S.foldl releaseOneOwner (state', S.empty)
$ S.union oldpending blockers
in printTestCase "After all blockers and old pending owners give up their\
\ resources, a pending owner must be notified"
in counterexample "After all blockers and old pending owners give up their\
\ resources, a pending owner must be notified"
$ S.member owner notified
-- | Verify that some progress is made after the direct blockers give up their
......@@ -209,8 +210,8 @@ prop_Progress =
let (s', newnotify) = releaseResources o s
in (s', newnotify `S.union` tonotify)
(_, notified) = S.foldl releaseOneOwner (state', S.empty) blockers
in printTestCase "Some progress must be made after all blockers release\
\ their locks"
in counterexample "Some progress must be made after all blockers release\
\ their locks"
. not . S.null $ notified S.\\ blockers
-- | Verify that the notifications send out are sound, i.e., upon notification
......@@ -232,7 +233,7 @@ prop_ProgressSound =
all (requestSucceeded . listLocks o $ getAllocation state'') r)
. S.toList . S.filter (\(_, b, _) -> b == o)
. getPendingRequests $ state'
in printTestCase "If an owner gets notified, his request must be satisfied"
in counterexample "If an owner gets notified, his request must be satisfied"
. all requestFulfilled . S.toList $ notified S.\\ blockers
-- | Verify that all pending requests are valid and cannot be fulfilled in
......@@ -244,7 +245,7 @@ prop_PendingJustified =
let isJustified (_, b, req) =
genericResult (const False) (not . S.null) . snd
. L.updateLocks b req $ getAllocation state
in printTestCase "Pebding requests must be good and not fulfillable"
in counterexample "Pending requests must be good and not fulfillable"
. all isJustified . S.toList $ getPendingRequests state
-- | Verify that `updateLocks` is idempotent, except that in the repetition,
......@@ -272,8 +273,8 @@ prop_extReprPreserved =
forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
let rep = extRepr state
rep' = extRepr $ fromExtRepr rep
in printTestCase "a lock waiting obtained from an extensional representation\
\ must have the same extensional representation"
in counterexample "a lock waiting obtained from an extensional representation\
\ must have the same extensional representation"
$ rep' == rep
-- | Verify that any state is indistinguishable from its canonical version
......@@ -287,7 +288,7 @@ prop_SimulateUpdateLocks =
let state' = fromExtRepr $ extRepr state
(finState, (result, notify)) = updateLocks owner req state
(finState', (result', notify')) = updateLocks owner req state'
in printTestCase "extRepr-equal states must behave equal on updateLocks"
in counterexample "extRepr-equal states must behave equal on updateLocks"
$ and [ result == result'
, notify == notify'
, extRepr finState == extRepr finState'
......@@ -304,7 +305,7 @@ prop_SimulateUpdateLocksWaiting =
let state' = fromExtRepr $ extRepr state
(finState, (result, notify)) = updateLocksWaiting prio owner req state
(finState', (result', notify')) = updateLocksWaiting prio owner req state'
in printTestCase "extRepr-equal states must behave equal on updateLocks"
in counterexample "extRepr-equal states must behave equal on updateLocks"
$ and [ result == result'
, notify == notify'
, extRepr finState == extRepr finState'
......@@ -367,7 +368,8 @@ prop_OpportunisticMonotone =
oldOwned = listLocks a $ getAllocation state
oldLocks = M.keys oldOwned
newOwned = listLocks a $ getAllocation state'
in printTestCase "Opportunistic union may only increase the set of locks held"
in counterexample "Opportunistic union may only increase the set of locks\
\ held"
. flip all oldLocks $ \lock ->
M.lookup lock newOwned >= M.lookup lock oldOwned
......@@ -385,15 +387,15 @@ prop_OpportunisticAnswer =
oldOwned = listLocks a $ getAllocation state
newOwned = listLocks a $ getAllocation state'
involvedLocks = M.keys oldOwned ++ map fst req
in conjoin [ printTestCase ("Locks not in the answer set " ++ show result
++ " may not be changed, but found "
++ show state')
in conjoin [ counterexample ("Locks not in the answer set " ++ show result
++ " may not be changed, but found "
++ show state')
. flip all involvedLocks $ \lock ->
(lock `elem` result)
|| (M.lookup lock oldOwned == M.lookup lock newOwned)
, printTestCase ("Locks not in the answer set " ++ show result
++ " must be as requested, but found "
++ show state')
, counterexample ("Locks not in the answer set " ++ show result
++ " must be as requested, but found "
++ show state')
. flip all involvedLocks $ \lock ->
notElem lock result
|| maybe False (flip elem req . (,) lock)
......
......@@ -24,21 +24,21 @@ import Test.Ganeti.TestHelper
prop_addressPoolProperties :: Network -> Property
prop_addressPoolProperties a =
conjoin
[ printTestCase
[ counterexample
("Not all reservations are included in 'allReservations' of " ++
"address pool:" ++ show a) (allReservationsSubsumesInternal a)
, printTestCase
, counterexample
("Not all external reservations are covered by 'allReservations' " ++
"of address pool: " ++ show a)
(allReservationsSubsumesExternal a)
, printTestCase
, counterexample
("The counts of free and reserved addresses do not add up for " ++
"address pool: " ++ show a)
(checkCounts a)
, printTestCase
, counterexample
("'isFull' wrongly classified the status of the address pool: " ++
show a) (checkIsFull a)
, printTestCase
, counterexample
("Network map is inconsistent with reservations of address pool: " ++
show a) (checkGetMap a)
]
......
......@@ -370,11 +370,11 @@ prop_fillDict defaults custom =
d_keys = map fst defaults
c_map = Map.fromList custom
c_keys = map fst custom
in conjoin [ printTestCase "Empty custom filling"
in conjoin [ counterexample "Empty custom filling"
(fillDict d_map Map.empty [] == d_map)
, printTestCase "Empty defaults filling"
, counterexample "Empty defaults filling"
(fillDict Map.empty c_map [] == c_map)
, printTestCase "Delete all keys"
, counterexample "Delete all keys"
(fillDict d_map c_map (d_keys++c_keys) == Map.empty)
]
......
......@@ -678,7 +678,7 @@ prop_setOpComment op comment =
prop_mkDiskIndex_fail :: QuickCheck.Positive Int -> Property
prop_mkDiskIndex_fail (Positive i) =
case mkDiskIndex (negate i) of
Bad msg -> printTestCase "error message " $
Bad msg -> counterexample "error message " $
"Invalid value" `isPrefixOf` msg
Ok v -> failTest $ "Succeeded to build disk index '" ++ show v ++
"' from negative value " ++ show (negate i)
......
......@@ -63,7 +63,7 @@ checkQueryResults :: ConfigData -> Query -> String
-> [[ResultEntry]] -> Property
checkQueryResults cfg qr descr expected = monadicIO $ do
result <- run (query cfg False qr) >>= resultProp
stop $ printTestCase ("Inconsistent results in " ++ descr)
stop $ counterexample ("Inconsistent results in " ++ descr)
(qresData result ==? expected)
-- | Makes a node name query, given a filter.
......@@ -192,13 +192,13 @@ prop_makeSimpleFilter =
forAll (resize 10 $ listOf1 genName) $ \names ->
forAll (resize 10 $ listOf1 arbitrary) $ \ids ->
forAll genName $ \namefield ->
conjoin [ printTestCase "test expected names" $
conjoin [ counterexample "test expected names" $
makeSimpleFilter namefield (map Left names) ==?
OrFilter (map (EQFilter namefield . QuotedString) names)
, printTestCase "test expected IDs" $
, counterexample "test expected IDs" $
makeSimpleFilter namefield (map Right ids) ==?
OrFilter (map (EQFilter namefield . NumericValue) ids)
, printTestCase "test empty names" $
, counterexample "test empty names" $
makeSimpleFilter namefield [] ==? EmptyFilter
]
......
......@@ -134,7 +134,7 @@ prop_filter_serialisation = forAll genFilter testSerialisation
-- | Tests that filter regexes are serialised correctly.
prop_filterregex_instances :: FilterRegex -> Property
prop_filterregex_instances rex =
printTestCase "failed JSON encoding" (testSerialisation rex)
counterexample "failed JSON encoding" (testSerialisation rex)
-- | Tests 'ResultStatus' serialisation.
prop_resultstatus_serialisation :: ResultStatus -> Property
......
This diff is collapsed.
......@@ -60,7 +60,7 @@ instance Arbitrary Ssconf.SSConf where
prop_filename :: Ssconf.SSKey -> Property
prop_filename key =
printTestCase "Key doesn't start with correct prefix" $
counterexample "Key doesn't start with correct prefix" $