From: Niklas Hambuechen <[email protected]> This renames the deprecated `printTestCase` to its replacement `counterexample`, add provides a CPP-guarded fallback for QuickCheck < 2.7.
Signed-off-by: Niklas Hambuechen <[email protected]> Reviewed-by: Klaus Aehlig <[email protected]> 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 test/hs/Test/Ganeti/TestCommon.hs - added definition for MIN_VERSION_QuickCheck; needs to be removed when merging to 2.14 test/hs/Test/Ganeti/Utils/Statistics.hs - added qualified imports to pull counterexample from TestCommon Signed-off-by: Petr Pudlak <[email protected]> --- Makefile.am | 7 ++ doc/dev-codestyle.rst | 6 +- test/hs/Test/Ganeti/BasicTypes.hs | 10 +-- test/hs/Test/Ganeti/Confd/Utils.hs | 8 +- test/hs/Test/Ganeti/HTools/Backend/Text.hs | 8 +- test/hs/Test/Ganeti/HTools/Cluster.hs | 14 ++-- test/hs/Test/Ganeti/HTools/Container.hs | 2 +- test/hs/Test/Ganeti/HTools/Node.hs | 2 +- test/hs/Test/Ganeti/HTools/Types.hs | 2 +- test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs | 4 +- test/hs/Test/Ganeti/JQueue.hs | 28 +++---- test/hs/Test/Ganeti/Locking/Allocation.hs | 30 +++---- test/hs/Test/Ganeti/Locking/Locks.hs | 4 +- test/hs/Test/Ganeti/Locking/Waiting.hs | 46 +++++------ test/hs/Test/Ganeti/Network.hs | 10 +-- test/hs/Test/Ganeti/Objects.hs | 6 +- test/hs/Test/Ganeti/OpCodes.hs | 2 +- test/hs/Test/Ganeti/Query/Filter.hs | 8 +- test/hs/Test/Ganeti/Query/Language.hs | 2 +- test/hs/Test/Ganeti/Query/Query.hs | 104 ++++++++++++------------- test/hs/Test/Ganeti/Ssconf.hs | 2 +- test/hs/Test/Ganeti/TestCommon.hs | 29 ++++++- test/hs/Test/Ganeti/Utils.hs | 54 ++++++------- test/hs/Test/Ganeti/Utils/MultiMap.hs | 4 +- test/hs/Test/Ganeti/Utils/Statistics.hs | 5 +- 25 files changed, 214 insertions(+), 183 deletions(-) diff --git a/Makefile.am b/Makefile.am index 29c06d8..c9fd066 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1211,6 +1211,13 @@ hs-pkg-versions: -DMONAD_CONTROL_MAJOR=\1 -DMONAD_CONTROL_MINOR=\2 -DMONAD_CONTROL_REV=\3/'\ -e 's/^\s*//' \ >> $@ + ghc-pkg list --simple-output QuickCheck \ + | sed -r -e '$$!d' \ + -e 's/^QuickCheck-([0-9]+(\.[0-9]+)*)/\1 0 0 0/' \ + -e 's/\./ /g' -e 's/([0-9]+) *([0-9]+) *([0-9]+) .*/\ + -DQUICKCHECK_MAJOR=\1 -DQUICKCHECK_MINOR=\2 -DQUICKCHECK_REV=\3/'\ + -e 's/^\s*//' \ + >> $@ HS_MAKEFILE_GHC_SRCS = $(HS_SRC_PROGS:%=%.hs) if WANT_HSTESTS diff --git a/doc/dev-codestyle.rst b/doc/dev-codestyle.rst index b6bbaa5..4055878 100644 --- a/doc/dev-codestyle.rst +++ b/doc/dev-codestyle.rst @@ -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 ... diff --git a/test/hs/Test/Ganeti/BasicTypes.hs b/test/hs/Test/Ganeti/BasicTypes.hs index 60ca398..f29d16f 100644 --- a/test/hs/Test/Ganeti/BasicTypes.hs +++ b/test/hs/Test/Ganeti/BasicTypes.hs @@ -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 diff --git a/test/hs/Test/Ganeti/Confd/Utils.hs b/test/hs/Test/Ganeti/Confd/Utils.hs index df31197..43aae3c 100644 --- a/test/hs/Test/Ganeti/Confd/Utils.hs +++ b/test/hs/Test/Ganeti/Confd/Utils.hs @@ -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" diff --git a/test/hs/Test/Ganeti/HTools/Backend/Text.hs b/test/hs/Test/Ganeti/HTools/Backend/Text.hs index 6eb6f5f..5500ba2 100644 --- a/test/hs/Test/Ganeti/HTools/Backend/Text.hs +++ b/test/hs/Test/Ganeti/HTools/Backend/Text.hs @@ -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 diff --git a/test/hs/Test/Ganeti/HTools/Cluster.hs b/test/hs/Test/Ganeti/HTools/Cluster.hs index d584049..92dc91b 100644 --- a/test/hs/Test/Ganeti/HTools/Cluster.hs +++ b/test/hs/Test/Ganeti/HTools/Cluster.hs @@ -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 diff --git a/test/hs/Test/Ganeti/HTools/Container.hs b/test/hs/Test/Ganeti/HTools/Container.hs index 725580e..069c29c 100644 --- a/test/hs/Test/Ganeti/HTools/Container.hs +++ b/test/hs/Test/Ganeti/HTools/Container.hs @@ -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)) ] diff --git a/test/hs/Test/Ganeti/HTools/Node.hs b/test/hs/Test/Ganeti/HTools/Node.hs index fc63ac5..9177ba7 100644 --- a/test/hs/Test/Ganeti/HTools/Node.hs +++ b/test/hs/Test/Ganeti/HTools/Node.hs @@ -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 && diff --git a/test/hs/Test/Ganeti/HTools/Types.hs b/test/hs/Test/Ganeti/HTools/Types.hs index bf49363..7708b0a 100644 --- a/test/hs/Test/Ganeti/HTools/Types.hs +++ b/test/hs/Test/Ganeti/HTools/Types.hs @@ -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' diff --git a/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs b/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs index 6eb20cc..c56fbbc 100644 --- a/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs +++ b/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs @@ -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. diff --git a/test/hs/Test/Ganeti/JQueue.hs b/test/hs/Test/Ganeti/JQueue.hs index 47c4aaa..c455904 100644 --- a/test/hs/Test/Ganeti/JQueue.hs +++ b/test/hs/Test/Ganeti/JQueue.hs @@ -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) diff --git a/test/hs/Test/Ganeti/Locking/Allocation.hs b/test/hs/Test/Ganeti/Locking/Allocation.hs index a87d232..a4ce21b 100644 --- a/test/hs/Test/Ganeti/Locking/Allocation.hs +++ b/test/hs/Test/Ganeti/Locking/Allocation.hs @@ -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 diff --git a/test/hs/Test/Ganeti/Locking/Locks.hs b/test/hs/Test/Ganeti/Locking/Locks.hs index 91d9dd5..eedaed0 100644 --- a/test/hs/Test/Ganeti/Locking/Locks.hs +++ b/test/hs/Test/Ganeti/Locking/Locks.hs @@ -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 diff --git a/test/hs/Test/Ganeti/Locking/Waiting.hs b/test/hs/Test/Ganeti/Locking/Waiting.hs index 3950663..de863b2 100644 --- a/test/hs/Test/Ganeti/Locking/Waiting.hs +++ b/test/hs/Test/Ganeti/Locking/Waiting.hs @@ -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) diff --git a/test/hs/Test/Ganeti/Network.hs b/test/hs/Test/Ganeti/Network.hs index 58fee6f..affa11e 100644 --- a/test/hs/Test/Ganeti/Network.hs +++ b/test/hs/Test/Ganeti/Network.hs @@ -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) ] diff --git a/test/hs/Test/Ganeti/Objects.hs b/test/hs/Test/Ganeti/Objects.hs index 09e5f00..8de58d2 100644 --- a/test/hs/Test/Ganeti/Objects.hs +++ b/test/hs/Test/Ganeti/Objects.hs @@ -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) ] diff --git a/test/hs/Test/Ganeti/OpCodes.hs b/test/hs/Test/Ganeti/OpCodes.hs index 20517a8..5d84edd 100644 --- a/test/hs/Test/Ganeti/OpCodes.hs +++ b/test/hs/Test/Ganeti/OpCodes.hs @@ -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) diff --git a/test/hs/Test/Ganeti/Query/Filter.hs b/test/hs/Test/Ganeti/Query/Filter.hs index 72adfac..c36294b 100644 --- a/test/hs/Test/Ganeti/Query/Filter.hs +++ b/test/hs/Test/Ganeti/Query/Filter.hs @@ -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 ] diff --git a/test/hs/Test/Ganeti/Query/Language.hs b/test/hs/Test/Ganeti/Query/Language.hs index 98cf5f8..022d95f 100644 --- a/test/hs/Test/Ganeti/Query/Language.hs +++ b/test/hs/Test/Ganeti/Query/Language.hs @@ -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 diff --git a/test/hs/Test/Ganeti/Query/Query.hs b/test/hs/Test/Ganeti/Query/Query.hs index 854326f..6090b38 100644 --- a/test/hs/Test/Ganeti/Query/Query.hs +++ b/test/hs/Test/Ganeti/Query/Query.hs @@ -88,13 +88,13 @@ prop_queryNode_noUnknown = QueryFieldsResult fdefs' <- resultProp $ queryFields (QueryFields (ItemTypeOpCode QRNode) [field]) stop $ conjoin - [ printTestCase ("Got unknown fields via query (" ++ - show fdefs ++ ")") (hasUnknownFields fdefs) - , printTestCase ("Got unknown result status via query (" ++ - show fdata ++ ")") + [ counterexample ("Got unknown fields via query (" ++ + show fdefs ++ ")") (hasUnknownFields fdefs) + , counterexample ("Got unknown result status via query (" ++ + show fdata ++ ")") (all (all ((/= RSUnknown) . rentryStatus)) fdata) - , printTestCase ("Got unknown fields via query fields (" ++ - show fdefs'++ ")") (hasUnknownFields fdefs') + , counterexample ("Got unknown fields via query fields (" ++ + show fdefs'++ ")") (hasUnknownFields fdefs') ] -- | Tests that an unknown field is returned as such. @@ -109,16 +109,16 @@ prop_queryNode_Unknown = QueryFieldsResult fdefs' <- resultProp $ queryFields (QueryFields (ItemTypeOpCode QRNode) [field]) stop $ conjoin - [ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")") + [ counterexample ("Got known fields via query (" ++ show fdefs ++ ")") (not $ hasUnknownFields fdefs) - , printTestCase ("Got /= ResultUnknown result status via query (" ++ - show fdata ++ ")") + , counterexample ("Got /= ResultUnknown result status via query (" ++ + show fdata ++ ")") (all (all ((== RSUnknown) . rentryStatus)) fdata) - , printTestCase ("Got a Just in a result value (" ++ - show fdata ++ ")") + , counterexample ("Got a Just in a result value (" ++ + show fdata ++ ")") (all (all (isNothing . rentryValue)) fdata) - , printTestCase ("Got known fields via query fields (" ++ show fdefs' - ++ ")") (not $ hasUnknownFields fdefs') + , counterexample ("Got known fields via query fields (" ++ show fdefs' + ++ ")") (not $ hasUnknownFields fdefs') ] -- | Checks that a result type is conforming to a field definition. @@ -155,13 +155,13 @@ prop_queryNode_types = run (query cfg False (Query (ItemTypeOpCode QRNode) [field] EmptyFilter)) >>= resultProp stop $ conjoin - [ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")") + [ counterexample ("Inconsistent result entries (" ++ show fdata ++ ")") (conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) - , printTestCase "Wrong field definitions length" + , counterexample "Wrong field definitions length" (length fdefs ==? 1) - , printTestCase "Wrong field result rows length" + , counterexample "Wrong field result rows length" (all ((== 1) . length) fdata) - , printTestCase "Wrong number of result rows" + , counterexample "Wrong number of result rows" (length fdata ==? numnodes) ] @@ -201,7 +201,7 @@ prop_queryNode_filter = run (query cluster False (Query (ItemTypeOpCode QRNode) ["name"] flt)) >>= resultProp stop $ conjoin - [ printTestCase "Invalid node names" $ + [ counterexample "Invalid node names" $ map (map rentryValue) fdata ==? map (\f -> [Just (showJSON f)]) fqdns ] @@ -218,13 +218,13 @@ prop_queryGroup_noUnknown = QueryFieldsResult fdefs' <- resultProp $ queryFields (QueryFields (ItemTypeOpCode QRGroup) [field]) stop $ conjoin - [ printTestCase ("Got unknown fields via query (" ++ show fdefs ++ ")") + [ counterexample ("Got unknown fields via query (" ++ show fdefs ++ ")") (hasUnknownFields fdefs) - , printTestCase ("Got unknown result status via query (" ++ - show fdata ++ ")") + , counterexample ("Got unknown result status via query (" ++ + show fdata ++ ")") (all (all ((/= RSUnknown) . rentryStatus)) fdata) - , printTestCase ("Got unknown fields via query fields (" ++ show fdefs' - ++ ")") (hasUnknownFields fdefs') + , counterexample ("Got unknown fields via query fields (" ++ show fdefs' + ++ ")") (hasUnknownFields fdefs') ] prop_queryGroup_Unknown :: Property @@ -238,16 +238,16 @@ prop_queryGroup_Unknown = QueryFieldsResult fdefs' <- resultProp $ queryFields (QueryFields (ItemTypeOpCode QRGroup) [field]) stop $ conjoin - [ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")") + [ counterexample ("Got known fields via query (" ++ show fdefs ++ ")") (not $ hasUnknownFields fdefs) - , printTestCase ("Got /= ResultUnknown result status via query (" ++ - show fdata ++ ")") + , counterexample ("Got /= ResultUnknown result status via query (" ++ + show fdata ++ ")") (all (all ((== RSUnknown) . rentryStatus)) fdata) - , printTestCase ("Got a Just in a result value (" ++ - show fdata ++ ")") + , counterexample ("Got a Just in a result value (" ++ + show fdata ++ ")") (all (all (isNothing . rentryValue)) fdata) - , printTestCase ("Got known fields via query fields (" ++ show fdefs' - ++ ")") (not $ hasUnknownFields fdefs') + , counterexample ("Got known fields via query fields (" ++ show fdefs' + ++ ")") (not $ hasUnknownFields fdefs') ] prop_queryGroup_types :: Property @@ -259,10 +259,10 @@ prop_queryGroup_types = run (query cfg False (Query (ItemTypeOpCode QRGroup) [field] EmptyFilter)) >>= resultProp stop $ conjoin - [ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")") + [ counterexample ("Inconsistent result entries (" ++ show fdata ++ ")") (conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) - , printTestCase "Wrong field definitions length" (length fdefs ==? 1) - , printTestCase "Wrong field result rows length" + , counterexample "Wrong field definitions length" (length fdefs ==? 1) + , counterexample "Wrong field result rows length" (all ((== 1) . length) fdata) ] @@ -289,7 +289,7 @@ prop_queryGroup_nodeCount = run (query cluster False (Query (ItemTypeOpCode QRGroup) ["node_cnt"] EmptyFilter)) >>= resultProp stop $ conjoin - [ printTestCase "Invalid node count" $ + [ counterexample "Invalid node count" $ map (map rentryValue) fdata ==? [[Just (showJSON nodes)]] ] @@ -312,13 +312,13 @@ prop_queryJob_noUnknown = QueryFieldsResult fdefs' <- resultProp $ queryFields (QueryFields qtype [field]) stop $ conjoin - [ printTestCase ("Got unknown fields via query (" ++ - show fdefs ++ ")") (hasUnknownFields fdefs) - , printTestCase ("Got unknown result status via query (" ++ - show fdata ++ ")") + [ counterexample ("Got unknown fields via query (" ++ + show fdefs ++ ")") (hasUnknownFields fdefs) + , counterexample ("Got unknown result status via query (" ++ + show fdata ++ ")") (all (all ((/= RSUnknown) . rentryStatus)) fdata) - , printTestCase ("Got unknown fields via query fields (" ++ - show fdefs'++ ")") (hasUnknownFields fdefs') + , counterexample ("Got unknown fields via query fields (" ++ + show fdefs'++ ")") (hasUnknownFields fdefs') ] -- | Tests that an unknown field is returned as such. @@ -335,16 +335,16 @@ prop_queryJob_Unknown = QueryFieldsResult fdefs' <- resultProp $ queryFields (QueryFields qtype [field]) stop $ conjoin - [ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")") + [ counterexample ("Got known fields via query (" ++ show fdefs ++ ")") (not $ hasUnknownFields fdefs) - , printTestCase ("Got /= ResultUnknown result status via query (" ++ - show fdata ++ ")") + , counterexample ("Got /= ResultUnknown result status via query (" ++ + show fdata ++ ")") (all (all ((== RSUnknown) . rentryStatus)) fdata) - , printTestCase ("Got a Just in a result value (" ++ - show fdata ++ ")") + , counterexample ("Got a Just in a result value (" ++ + show fdata ++ ")") (all (all (isNothing . rentryValue)) fdata) - , printTestCase ("Got known fields via query fields (" ++ show fdefs' - ++ ")") (not $ hasUnknownFields fdefs') + , counterexample ("Got known fields via query fields (" ++ show fdefs' + ++ ")") (not $ hasUnknownFields fdefs') ] -- ** Misc other tests @@ -357,12 +357,12 @@ prop_getRequestedNames = q_node1 = QuotedString node1 eq_name = EQFilter "name" eq_node1 = eq_name q_node1 - in conjoin [ printTestCase "empty filter" $ chk EmptyFilter ==? [] - , printTestCase "and filter" $ chk (AndFilter [eq_node1]) ==? [] - , printTestCase "simple equality" $ chk eq_node1 ==? [node1] - , printTestCase "non-name field" $ + in conjoin [ counterexample "empty filter" $ chk EmptyFilter ==? [] + , counterexample "and filter" $ chk (AndFilter [eq_node1]) ==? [] + , counterexample "simple equality" $ chk eq_node1 ==? [node1] + , counterexample "non-name field" $ chk (EQFilter "foo" q_node1) ==? [] - , printTestCase "non-simple filter" $ + , counterexample "non-simple filter" $ chk (OrFilter [ eq_node1 , LTFilter "foo" q_node1]) ==? [] ] diff --git a/test/hs/Test/Ganeti/Ssconf.hs b/test/hs/Test/Ganeti/Ssconf.hs index c6eaed1..7a0bbb3 100644 --- a/test/hs/Test/Ganeti/Ssconf.hs +++ b/test/hs/Test/Ganeti/Ssconf.hs @@ -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" $ Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename "" key caseParseNodesVmCapable :: HUnit.Assertion diff --git a/test/hs/Test/Ganeti/TestCommon.hs b/test/hs/Test/Ganeti/TestCommon.hs index 015601f..9ab434b 100644 --- a/test/hs/Test/Ganeti/TestCommon.hs +++ b/test/hs/Test/Ganeti/TestCommon.hs @@ -1,4 +1,7 @@ -{-| Unittest helpers for ganeti-htools. +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| Common helper functions and instances for all Ganeti tests. -} @@ -81,8 +84,17 @@ module Test.Ganeti.TestCommon , genNonNegative , relativeError , getTempFileName + , counterexample ) where +-- The following macro is just a temporary solution for 2.12 and 2.13. +-- Since 2.14 cabal creates proper macros for all dependencies. +#define MIN_VERSION_QuickCheck(maj,min,rev) \ + (((maj)<QUICKCHECK_MAJOR)|| \ + (((maj)==QUICKCHECK_MAJOR)&&((min)<=QUICKCHECK_MINOR))|| \ + (((maj)==QUICKCHECK_MAJOR)&&((min)==QUICKCHECK_MINOR)&& \ + ((rev)<=QUICKCHECK_REV))) + import Control.Applicative import Control.Exception (catchJust) import Control.Monad @@ -100,6 +112,9 @@ import System.IO.Error (isDoesNotExistError) import System.Process (readProcessWithExitCode) import qualified Test.HUnit as HUnit import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,7,0) +import qualified Test.QuickCheck as QC +#endif import Test.QuickCheck.Monadic import qualified Text.JSON as J import Numeric @@ -148,7 +163,7 @@ maxOpCodes = 16 -- | Checks for equality with proper annotation. The first argument is -- the computed value, the second one the expected value. (==?) :: (Show a, Eq a) => a -> a -> Property -(==?) x y = printTestCase +(==?) x y = counterexample ("Expected equality, but got mismatch\nexpected: " ++ show y ++ "\n but got: " ++ show x) (x == y) infix 3 ==? @@ -157,14 +172,14 @@ infix 3 ==? -- is the computed value, the second one the expected (not equal) -- value. (/=?) :: (Show a, Eq a) => a -> a -> Property -(/=?) x y = printTestCase +(/=?) x y = counterexample ("Expected inequality, but got equality: '" ++ show x ++ "'.") (x /= y) infix 3 /=? -- | Show a message and fail the test. failTest :: String -> Property -failTest msg = printTestCase msg False +failTest msg = counterexample msg False -- | A 'True' property. passTest :: Property @@ -500,3 +515,9 @@ getTempFileName filename = do _ <- hClose handle removeFile fpath return fpath + + +#if !MIN_VERSION_QuickCheck(2,7,0) +counterexample :: Testable prop => String -> prop -> Property +counterexample = QC.printTestCase +#endif diff --git a/test/hs/Test/Ganeti/Utils.hs b/test/hs/Test/Ganeti/Utils.hs index 6eea227..63bc26b 100644 --- a/test/hs/Test/Ganeti/Utils.hs +++ b/test/hs/Test/Ganeti/Utils.hs @@ -83,7 +83,7 @@ prop_findFirst :: Property prop_findFirst = forAll (genSublist [0..5 :: Int]) $ \xs -> forAll (choose (-2, 7)) $ \base -> - printTestCase "findFirst utility function" $ + counterexample "findFirst utility function" $ let r = findFirst base (S.fromList xs) (ss, es) = partition (< r) $ dropWhile (< base) xs -- the prefix must be a range of numbers @@ -154,7 +154,7 @@ prop_parseUnit (NonNegative n) = , parseUnit (show n ++ "G") ==? (Ok (truncate n_gb)::Result Int) , parseUnit (show n ++ "t") ==? (Ok (n*1048576)::Result Int) , parseUnit (show n ++ "T") ==? (Ok (truncate n_tb)::Result Int) - , printTestCase "Internal error/overflow?" + , counterexample "Internal error/overflow?" (n_mb >=0 && n_gb >= 0 && n_tb >= 0) , property (isBad (parseUnit (show n ++ "x")::Result Int)) ] @@ -206,8 +206,8 @@ prop_niceSort_single :: Property prop_niceSort_single = forAll genName $ \name -> conjoin - [ printTestCase "single string" $ [name] ==? niceSort [name] - , printTestCase "single plus empty" $ ["", name] ==? niceSort [name, ""] + [ counterexample "single string" $ [name] ==? niceSort [name] + , counterexample "single plus empty" $ ["", name] ==? niceSort [name, ""] ] -- | Tests some generic 'niceSort' properties. Note that the last test @@ -216,10 +216,10 @@ prop_niceSort_generic :: Property prop_niceSort_generic = forAll (resize 20 arbitrary) $ \names -> let n_sorted = niceSort names in - conjoin [ printTestCase "length" $ length names ==? length n_sorted - , printTestCase "same strings" $ sort names ==? sort n_sorted - , printTestCase "idempotence" $ n_sorted ==? niceSort n_sorted - , printTestCase "static prefix" $ n_sorted ==? + conjoin [ counterexample "length" $ length names ==? length n_sorted + , counterexample "same strings" $ sort names ==? sort n_sorted + , counterexample "idempotence" $ n_sorted ==? niceSort n_sorted + , counterexample "static prefix" $ n_sorted ==? map tail (niceSort $ map (" "++) names) ] @@ -237,26 +237,26 @@ prop_niceSortKey_equiv = forAll (vectorOf (length names) (arbitrary::Gen Int)) $ \numbers -> let n_sorted = niceSort names in conjoin - [ printTestCase "key id" $ n_sorted ==? niceSortKey id names - , printTestCase "key rev" $ niceSort (map reverse names) ==? - map reverse (niceSortKey reverse names) - , printTestCase "key snd" $ n_sorted ==? map snd (niceSortKey snd $ - zip numbers names) + [ counterexample "key id" $ n_sorted ==? niceSortKey id names + , counterexample "key rev" $ niceSort (map reverse names) ==? + map reverse (niceSortKey reverse names) + , counterexample "key snd" $ n_sorted ==? map snd (niceSortKey snd $ + zip numbers names) ] -- | Tests 'rStripSpace'. prop_rStripSpace :: NonEmptyList Char -> Property prop_rStripSpace (NonEmpty str) = forAll (resize 50 $ listOf1 (arbitrary `suchThat` isSpace)) $ \whitespace -> - conjoin [ printTestCase "arb. string last char is not space" $ + conjoin [ counterexample "arb. string last char is not space" $ case rStripSpace str of [] -> True xs -> not . isSpace $ last xs - , printTestCase "whitespace suffix is stripped" $ + , counterexample "whitespace suffix is stripped" $ rStripSpace str ==? rStripSpace (str ++ whitespace) - , printTestCase "whitespace reduced to null" $ + , counterexample "whitespace reduced to null" $ rStripSpace whitespace ==? "" - , printTestCase "idempotent on empty strings" $ + , counterexample "idempotent on empty strings" $ rStripSpace "" ==? "" ] @@ -315,15 +315,15 @@ prop_trim (NonEmpty str) = forAll (listOf1 $ elements " \t\n\r\f") $ \whitespace -> forAll (choose (0, length whitespace)) $ \n -> let (preWS, postWS) = splitAt n whitespace in - conjoin [ printTestCase "arb. string first and last char are not space" $ + conjoin [ counterexample "arb. string first and last char are not space" $ case trim str of [] -> True xs -> (not . isSpace . head) xs && (not . isSpace . last) xs - , printTestCase "whitespace is striped" $ + , counterexample "whitespace is striped" $ trim str ==? trim (preWS ++ str ++ postWS) - , printTestCase "whitespace reduced to null" $ + , counterexample "whitespace reduced to null" $ trim whitespace ==? "" - , printTestCase "idempotent on empty strings" $ + , counterexample "idempotent on empty strings" $ trim "" ==? "" ] @@ -331,17 +331,17 @@ prop_trim (NonEmpty str) = prop_splitRecombineEithers :: [Either Int Int] -> Property prop_splitRecombineEithers es = conjoin - [ printTestCase "only lefts are mapped correctly" $ + [ counterexample "only lefts are mapped correctly" $ splitEithers (map Left lefts) ==? (reverse lefts, emptylist, falses) - , printTestCase "only rights are mapped correctly" $ + , counterexample "only rights are mapped correctly" $ splitEithers (map Right rights) ==? (emptylist, reverse rights, trues) - , printTestCase "recombination is no-op" $ + , counterexample "recombination is no-op" $ recombineEithers splitleft splitright trail ==? Ok es - , printTestCase "fail on too long lefts" $ + , counterexample "fail on too long lefts" $ isBad (recombineEithers (0:splitleft) splitright trail) - , printTestCase "fail on too long rights" $ + , counterexample "fail on too long rights" $ isBad (recombineEithers splitleft (0:splitright) trail) - , printTestCase "fail on too long trail" $ + , counterexample "fail on too long trail" $ isBad (recombineEithers splitleft splitright (True:trail)) ] where (lefts, rights) = Either.partitionEithers es diff --git a/test/hs/Test/Ganeti/Utils/MultiMap.hs b/test/hs/Test/Ganeti/Utils/MultiMap.hs index 7fe0553..3656841 100644 --- a/test/hs/Test/Ganeti/Utils/MultiMap.hs +++ b/test/hs/Test/Ganeti/Utils/MultiMap.hs @@ -74,8 +74,8 @@ prop_MultiMap_equality :: MultiMap Three Three -> MultiMap Three Three -> Property prop_MultiMap_equality m1 m2 = let testKey k = MM.lookup k m1 == MM.lookup k m2 - in printTestCase ("Extensional equality of '" ++ show m1 - ++ "' and '" ++ show m2 ++ " doesn't match '=='.") + in counterexample ("Extensional equality of '" ++ show m1 + ++ "' and '" ++ show m2 ++ " doesn't match '=='.") $ all testKey [minBound..maxBound] ==? (m1 == m2) prop_MultiMap_serialisation :: MultiMap Int Int -> Property diff --git a/test/hs/Test/Ganeti/Utils/Statistics.hs b/test/hs/Test/Ganeti/Utils/Statistics.hs index 764ebc8..90fd8bd 100644 --- a/test/hs/Test/Ganeti/Utils/Statistics.hs +++ b/test/hs/Test/Ganeti/Utils/Statistics.hs @@ -36,8 +36,9 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. module Test.Ganeti.Utils.Statistics (testUtils_Statistics) where -import Test.QuickCheck +import Test.QuickCheck (Property, forAll, choose, vectorOf) +import Test.Ganeti.TestCommon import Test.Ganeti.TestHelper import Ganeti.Utils (stdDev) @@ -56,7 +57,7 @@ prop_stddev_update = with_update = getStatisticValue $ updateStatistics (getStdDevStatistics original) (a,b) direct = stdDev modified - in printTestCase ("Value computed by update " ++ show with_update + in counterexample ("Value computed by update " ++ show with_update ++ " differs too much from correct value " ++ show direct) (abs (with_update - direct) < 1e-10) -- 2.4.3.573.g4eafbef
