Full QuickCheck 2.7 compatibility
authorNiklas Hambuechen <niklash@google.com>
Fri, 7 Nov 2014 23:51:34 +0000 (00:51 +0100)
committerPetr Pudlak <pudlak@google.com>
Mon, 22 Jun 2015 16:14:32 +0000 (18:14 +0200)
This renames the deprecated `printTestCase` to its replacement
`counterexample`, add provides a CPP-guarded fallback for QuickCheck < 2.7.

Signed-off-by: Niklas Hambuechen <niklash@google.com>
Reviewed-by: Klaus 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: 077c415a09f8c381ce788ebe6c065d8ccab60564
Signed-off-by: Petr Pudlak <pudlak@google.com>
Reviewed-by: Klaus Aehlig <aehlig@google.com>

24 files changed:
doc/dev-codestyle.rst
test/hs/Test/Ganeti/BasicTypes.hs
test/hs/Test/Ganeti/Confd/Utils.hs
test/hs/Test/Ganeti/HTools/Backend/Text.hs
test/hs/Test/Ganeti/HTools/Cluster.hs
test/hs/Test/Ganeti/HTools/Container.hs
test/hs/Test/Ganeti/HTools/Node.hs
test/hs/Test/Ganeti/HTools/Types.hs
test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs
test/hs/Test/Ganeti/JQueue.hs
test/hs/Test/Ganeti/Locking/Allocation.hs
test/hs/Test/Ganeti/Locking/Locks.hs
test/hs/Test/Ganeti/Locking/Waiting.hs
test/hs/Test/Ganeti/Network.hs
test/hs/Test/Ganeti/Objects.hs
test/hs/Test/Ganeti/OpCodes.hs
test/hs/Test/Ganeti/Query/Filter.hs
test/hs/Test/Ganeti/Query/Language.hs
test/hs/Test/Ganeti/Query/Query.hs
test/hs/Test/Ganeti/Ssconf.hs
test/hs/Test/Ganeti/TestCommon.hs
test/hs/Test/Ganeti/Utils.hs
test/hs/Test/Ganeti/Utils/MultiMap.hs
test/hs/Test/Ganeti/Utils/Statistics.hs

index b6bbaa5..4055878 100644 (file)
@@ -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 ...
index 60ca398..f29d16f 100644 (file)
@@ -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
index df31197..43aae3c 100644 (file)
@@ -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"
index 6eb6f5f..5500ba2 100644 (file)
@@ -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
index d584049..92dc91b 100644 (file)
@@ -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
index 725580e..069c29c 100644 (file)
@@ -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))
        ]
 
index fc63ac5..9177ba7 100644 (file)
@@ -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 &&
index bf49363..7708b0a 100644 (file)
@@ -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'
index 6eb20cc..c56fbbc 100644 (file)
@@ -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.
index 47c4aaa..c455904 100644 (file)
@@ -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)
index a87d232..a4ce21b 100644 (file)
@@ -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
 
index 91d9dd5..eedaed0 100644 (file)
@@ -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
 
index 3950663..de863b2 100644 (file)
@@ -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)
index 58fee6f..affa11e 100644 (file)
@@ -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)
     ]
index 09e5f00..8de58d2 100644 (file)
@@ -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)
              ]
 
index 20517a8..5d84edd 100644 (file)
@@ -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)
index 72adfac..c36294b 100644 (file)
@@ -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
           ]
 
index 98cf5f8..022d95f 100644 (file)
@@ -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
index 854326f..6090b38 100644 (file)
@@ -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]) ==? []
              ]
 
index c6eaed1..7a0bbb3 100644 (file)
@@ -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
index 0b8e83e..a2ebccb 100644 (file)
@@ -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,6 +84,7 @@ module Test.Ganeti.TestCommon
   , genNonNegative
   , relativeError
   , getTempFileName
+  , counterexample
   ) where
 
 -- The following macro is just a temporary solution for 2.12 and 2.13.
@@ -108,6 +112,7 @@ import System.IO.Error (isDoesNotExistError)
 import System.Process (readProcessWithExitCode)
 import qualified Test.HUnit as HUnit
 import Test.QuickCheck
+import qualified Test.QuickCheck as QC
 import Test.QuickCheck.Monadic
 import qualified Text.JSON as J
 import Numeric
@@ -156,7 +161,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 ==?
@@ -165,14 +170,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
@@ -508,3 +513,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
index 6eea227..63bc26b 100644 (file)
@@ -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
index 7fe0553..3656841 100644 (file)
@@ -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
index 764ebc8..5c34a21 100644 (file)
@@ -38,6 +38,7 @@ module Test.Ganeti.Utils.Statistics (testUtils_Statistics) where
 
 import Test.QuickCheck
 
+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)