Use QuickCheck in more idiomatic and ergonomic way, printing counterexamples

tests/Tests/Properties/Builder.hs

@@ -29,7 +29,7 @@ tb_fromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .
                                    map (TB.fromText . packS))
 
 tb_associative s1 s2 s3 =
-    TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==
+    TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ===
     TB.toLazyText ((b1 `mappend` b2) `mappend` b3)
   where b1 = TB.fromText (packS s1)
         b2 = TB.fromText (packS s2)
@@ -37,7 +37,7 @@ tb_associative s1 s2 s3 =
 
 -- Numeric builder stuff.
 
-tb_decimal :: (Integral a, Show a) => a -> Bool
+tb_decimal :: (Integral a, Show a) => a -> Property
 tb_decimal = (TB.toLazyText . TB.decimal) `eq` (TL.pack . show)
 
 tb_decimal_integer (a::Integer) = tb_decimal a
@@ -58,7 +58,7 @@ tb_decimal_big_int64 (BigBounded (a::Int64)) = tb_decimal a
 tb_decimal_big_word (BigBounded (a::Word)) = tb_decimal a
 tb_decimal_big_word64 (BigBounded (a::Word64)) = tb_decimal a
 
-tb_hex :: (Integral a, Show a) => a -> Bool
+tb_hex :: (Integral a, Show a) => a -> Property
 tb_hex = (TB.toLazyText . TB.hexadecimal) `eq` (TL.pack . flip showHex "")
 
 tb_hexadecimal_integer (a::Integer) = tb_hex a
@@ -73,7 +73,7 @@ tb_hexadecimal_word16 (a::Word16) = tb_hex a
 tb_hexadecimal_word32 (a::Word32) = tb_hex a
 tb_hexadecimal_word64 (a::Word64) = tb_hex a
 
-tb_realfloat :: (RealFloat a, Show a) => a -> Bool
+tb_realfloat :: (RealFloat a, Show a) => a -> Property
 tb_realfloat = (TB.toLazyText . TB.realFloat) `eq` (TL.pack . show)
 
 tb_realfloat_float (a::Float) = tb_realfloat a

tests/Tests/Properties/LowLevel.hs

@@ -12,7 +12,6 @@ import Data.Text.Foreign
 import Data.Text.Internal (mul, mul32, mul64)
 import Data.Word (Word16, Word32)
 import System.IO.Unsafe (unsafePerformIO)
-import Test.QuickCheck.Monadic
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
 import Test.QuickCheck hiding ((.&.))
@@ -51,7 +50,7 @@ t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t
 t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t
 t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) === t
   where n = small m
-t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)
+t_use_from t = ioProperty $ (==t) <$> useAsPtr t fromPtr
 
 t_copy t = T.copy t === t
 

tests/Tests/Properties/Read.hs

@@ -41,14 +41,14 @@ isFloaty c = c `elem` ("+-.0123456789eE" :: String)
 
 t_read_rational p tol (n::Double) s =
     case p (T.pack (show n) `T.append` t) of
-      Left _err     -> False
-      Right (n',t') -> t == t' && abs (n-n') <= tol
+      Left err      -> counterexample err $ property False
+      Right (n',t') -> t === t' .&&. property (abs (n-n') <= tol)
     where t = T.dropWhile isFloaty s
 
 tl_read_rational p tol (n::Double) s =
     case p (TL.pack (show n) `TL.append` t) of
-      Left _err     -> False
-      Right (n',t') -> t == t' && abs (n-n') <= tol
+      Left err      -> counterexample err $ property False
+      Right (n',t') -> t === t' .&&. property (abs (n-n') <= tol)
     where t = TL.dropWhile isFloaty s
 
 t_double = t_read_rational T.double 1e-13

tests/Tests/Properties/Substrings.hs

@@ -127,10 +127,10 @@ t_tails           = L.tails       `eqP` (map unpackS . T.tails)
 tl_tails          = L.tails       `eqPSqrt` (map unpackS . TL.tails)
 t_findAppendId = \(Sqrt (NotEmpty s)) ts ->
     let t = T.intercalate s ts
-    in all (==t) $ map (uncurry T.append) (T.breakOnAll s t)
+    in conjoin $ map (=== t) $ map (uncurry T.append) (T.breakOnAll s t)
 tl_findAppendId = \(Sqrt (NotEmpty s)) ts ->
     let t = TL.intercalate s ts
-    in all (==t) $ map (uncurry TL.append) (TL.breakOnAll s t)
+    in conjoin $ map (=== t) $ map (uncurry TL.append) (TL.breakOnAll s t)
 t_findContains = \(Sqrt (NotEmpty s)) ->
     all (T.isPrefixOf s . snd) . T.breakOnAll s . T.intercalate s
 tl_findContains = \(Sqrt (NotEmpty s)) -> all (TL.isPrefixOf s . snd) .
@@ -158,11 +158,11 @@ split p xs = loop xs
                  | otherwise = l : loop (tail s')
               where (l, s') = break p s
 
-t_chunksOf_same_lengths k = all ((==k) . T.length) . ini . T.chunksOf k
+t_chunksOf_same_lengths k = conjoin . map ((===k) . T.length) . ini . T.chunksOf k
   where ini [] = []
         ini xs = init xs
 
-t_chunksOf_length k t = len == T.length t || (k <= 0 && len == 0)
+t_chunksOf_length k t = len === T.length t .||. property (k <= 0 && len == 0)
   where len = L.sum . L.map T.length $ T.chunksOf k t
 
 tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) .
@@ -214,14 +214,14 @@ commonPrefixes a0@(_:_) b0@(_:_) = Just (go a0 b0 [])
 commonPrefixes _ _ = Nothing
 
 t_commonPrefixes a b (NonEmpty p)
-    = commonPrefixes pa pb ==
+    = commonPrefixes pa pb ===
       repack `fmap` T.commonPrefixes (packS pa) (packS pb)
   where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)
         pa = p ++ a
         pb = p ++ b
 
 tl_commonPrefixes a b (NonEmpty p)
-    = commonPrefixes pa pb ==
+    = commonPrefixes pa pb ===
       repack `fmap` TL.commonPrefixes (packS pa) (packS pb)
   where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)
         pa = p ++ a

tests/Tests/Properties/Transcoding.hs

@@ -13,7 +13,6 @@ import Data.Text.Encoding.Error (UnicodeException)
 import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4)
 import Test.QuickCheck hiding ((.&.))
 import Test.QuickCheck.Property (Property(..))
-import Test.QuickCheck.Monadic
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
 import Tests.QuickCheckUtils
@@ -122,10 +121,10 @@ t_utf8_err bad (Just de) = forAll (genDecodeErr de) $ \onErr -> ioProperty $ do
       length (show err) >= 0
     Right _  -> counterexample (show (decoded, l)) $ de /= Strict
 
-t_utf8_err' :: B.ByteString -> Property
-t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of
-                                        Left err -> length (show err) >= 0
-                                        Right t  -> T.length t >= 0
+t_utf8_err' :: B.ByteString -> Bool
+t_utf8_err' bs = case E.decodeUtf8' bs of
+  Left err -> length (show err) >= 0
+  Right t  -> T.length t >= 0
 
 genInvalidUTF8 :: Gen B.ByteString
 genInvalidUTF8 = B.pack <$> oneof [

tests/Tests/QuickCheckUtils.hs

@@ -38,10 +38,8 @@ import Control.Exception (bracket)
 import Data.Text.Foreign (I16)
 import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
 import Data.Word (Word8, Word16)
-import Debug.Trace (trace)
 import System.Random (Random(..), RandomGen)
 import Test.QuickCheck hiding (Fixed(..), Small (..), (.&.))
-import Test.QuickCheck.Monadic (assert, monadicIO, run)
 import Tests.Utils
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
@@ -240,16 +238,16 @@ unpack2 :: (Stringy s) => (s,s) -> (String,String)
 unpack2 = unpackS *** unpackS
 
 -- Do two functions give the same answer?
-eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
+eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Property
 eq a b s  = a s =^= b s
 
 -- What about with the RHS packed?
 eqP :: (Eq a, Show a, Stringy s) =>
-       (String -> a) -> (s -> a) -> String -> Word8 -> Bool
-eqP f g s w  = eql "orig" (f s) (g t) &&
-               eql "mini" (f s) (g mini) &&
-               eql "head" (f sa) (g ta) &&
-               eql "tail" (f sb) (g tb)
+       (String -> a) -> (s -> a) -> String -> Word8 -> Property
+eqP f g s w  = counterexample "orig" (f s =^= g t) .&&.
+               counterexample "mini" (f s =^= g mini) .&&.
+               counterexample "head" (f sa =^= g ta) .&&.
+               counterexample "tail" (f sb =^= g tb)
     where t             = packS s
           mini          = packSChunkSize 10 s
           (sa,sb)       = splitAt m s
@@ -258,12 +256,9 @@ eqP f g s w  = eql "orig" (f s) (g t) &&
           m | l == 0    = n
             | otherwise = n `mod` l
           n             = fromIntegral w
-          eql d a b
-            | a =^= b   = True
-            | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
 
 eqPSqrt :: (Eq a, Show a, Stringy s) =>
-       (String -> a) -> (s -> a) -> Sqrt String -> Word8 -> Bool
+       (String -> a) -> (s -> a) -> Sqrt String -> Word8 -> Property
 eqPSqrt f g s = eqP f g (unSqrt s)
 
 instance Arbitrary FPFormat where
@@ -332,7 +327,7 @@ instance Arbitrary IO.BufferMode where
 -- * Encoding.
 -- * Newline translation mode.
 -- * Buffering.
-write_read :: (NFData a, Eq a)
+write_read :: (NFData a, Eq a, Show a)
            => ([b] -> a)
            -> ((Char -> Bool) -> a -> b)
            -> (IO.Handle -> a -> IO ())
@@ -342,18 +337,20 @@ write_read :: (NFData a, Eq a)
            -> IO.BufferMode
            -> [a]
            -> Property
-write_read unline filt writer reader (E _ _) nl buf ts =
-    monadicIO $ assert . (==t) =<< run act
-  where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
-        act = withTempFile $ \path h -> do
-                -- hSetEncoding h enc
-                IO.hSetNewlineMode h nl
-                IO.hSetBuffering h buf
-                () <- writer h t
-                IO.hClose h
-                bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
-                  -- hSetEncoding h' enc
-                  IO.hSetNewlineMode h' nl
-                  IO.hSetBuffering h' buf
-                  r <- reader h'
-                  r `deepseq` return r
+write_read unline filt writer reader (E _ _) nl buf ts = ioProperty $
+    (===t) <$> act
+  where
+    t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
+
+    act = withTempFile $ \path h -> do
+            -- hSetEncoding h enc
+            IO.hSetNewlineMode h nl
+            IO.hSetBuffering h buf
+            () <- writer h t
+            IO.hClose h
+            bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
+              -- hSetEncoding h' enc
+              IO.hSetNewlineMode h' nl
+              IO.hSetBuffering h' buf
+              r <- reader h'
+              r `deepseq` return r

tests/Tests/Utils.hs

@@ -10,24 +10,23 @@ module Tests.Utils
 
 import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
 import Control.Monad (when)
-import Debug.Trace (trace)
 import GHC.IO.Handle.Internals (withHandle)
 import System.Directory (removeFile)
 import System.IO (Handle, hClose, hFlush, hIsOpen, hIsWritable, openTempFile)
-import System.IO.Unsafe (unsafePerformIO)
+import Test.QuickCheck (Property, ioProperty, property, (===), counterexample)
 
 -- Ensure that two potentially bottom values (in the sense of crashing
 -- for some inputs, not looping infinitely) either both crash, or both
 -- give comparable results for some input.
-(=^=) :: (Eq a, Show a) => a -> a -> Bool
-i =^= j = unsafePerformIO $ do
+(=^=) :: (Eq a, Show a) => a -> a -> Property
+i =^= j = ioProperty $ do
   x <- try (evaluate i)
   y <- try (evaluate j)
-  case (x,y) of
+  return $ case (x, y) of
     (Left (_ :: SomeException), Left (_ :: SomeException))
-                       -> return True
-    (Right a, Right b) -> return (a == b)
-    e                  -> trace ("*** Divergence: " ++ show e) return False
+                       -> property True
+    (Right a, Right b) -> a === b
+    e                  -> counterexample ("Divergence: " ++ show e) $ property False
 infix 4 =^=
 {-# NOINLINE (=^=) #-}