Full QuickCheck 2.7 compatibility

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

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 ...

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

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"

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

test/hs/Test/Ganeti/HTools/Cluster.hs

@@ -161,9 +161,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
@@ -190,7 +190,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
@@ -256,7 +256,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,
@@ -320,7 +320,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.
@@ -384,9 +384,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

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))
        ]
 

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 &&

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'

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.

test/hs/Test/Ganeti/JQScheduler.hs

@@ -238,11 +238,11 @@ prop_reasonRateLimit =
            "queued jobs cannot be started because of rate limiting"
 
        $ conjoin
-           [ printTestCase "scheduled jobs must be subsequence" $
+           [ counterexample "scheduled jobs must be subsequence" $
                toRun `isSubsequenceOf` enqueued
 
            -- This is the key property:
-           , printTestCase "no job may exceed its bucket limits, except from\
+           , counterexample "no job may exceed its bucket limits, except from\
                             \ jobs that were already running with exceeded\
                             \ limits; those must not increase" $
                conjoin
@@ -558,10 +558,10 @@ prop_jobFiltering =
       -- bugs 25 and 27).
       in (enqueued /= []) ==> actionCovers $ conjoin
 
-           [ printTestCase "scheduled jobs must be subsequence" $
+           [ counterexample "scheduled jobs must be subsequence" $
                toRun `isSubsequenceOf` enqueued
 
-           , printTestCase "a reason for each job (not) being scheduled" .
+           , counterexample "a reason for each job (not) being scheduled" .
 
                -- All enqueued jobs must have a reason why they were (not)
                -- scheduled, determined by the filter that applies.

test/hs/Test/Ganeti/JQueue.hs

@@ -103,15 +103,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)
      ]
 
@@ -171,10 +171,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.
@@ -211,7 +211,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,
@@ -254,15 +254,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)

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
 

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
 

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 extRepr . fromExtRepr = id for all valid extensional
@@ -254,8 +255,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
@@ -269,7 +270,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'
@@ -286,7 +287,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'
@@ -309,7 +310,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
 
@@ -327,15 +329,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)

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)
     ]

test/hs/Test/Ganeti/Objects.hs

@@ -465,11 +465,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)
              ]