Commit af3ef85f authored by Bodigrim's avatar Bodigrim Committed by Xia Li-yao
Browse files

Use QuickCheck in more idiomatic and ergonomic way, printing counterexamples

parent 9ee8208d
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 [
......
......@@ -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
......@@ -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 (=^=) #-}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment