WIP

Author: Anton-Latukha

tests/Tests/Properties/Builder.hs

@@ -90,7 +90,7 @@ tb_formatRealFloat :: (RealFloat a, Show a) =>
 tb_formatRealFloat a fmt prec = cond ==>
     TB.formatRealFloat fmt p a ===
     TB.fromString (showFloat fmt p a "")
-  where p = precision a prec
+  where p = unPrecision prec
         cond = case (p,fmt) of
 #if MIN_VERSION_base(4,12,0)
                   (Just 0, TB.Generic) -> False -- skipping due to gh-231

tests/Tests/QuickCheckUtils.hs

@@ -4,6 +4,8 @@
 --
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -29,13 +31,14 @@ module Tests.QuickCheckUtils
     ) where
 
 import Control.Arrow ((***))
-import Control.DeepSeq (NFData (..), deepseq)
-import Control.Exception (bracket)
+import Control.DeepSeq (NFData(..), deepseq)
 import Data.Char (isSpace)
+import Data.Coerce (coerce)
 import Data.Text.Foreign (I8)
 import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
 import Data.Word (Word8, Word16)
-import Test.QuickCheck hiding (Fixed(..), Small (..), (.&.))
+import GHC.Num (integerLog2)
+import Test.QuickCheck hiding (Fixed(..), Small(..), (.&.))
 import Tests.Utils
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
@@ -47,6 +50,7 @@ import qualified Data.Text.Internal.Lazy as TL
 import qualified Data.Text.Internal.Lazy.Fusion as TLF
 import qualified Data.Text.Lazy as TL
 import qualified System.IO as IO
+import Control.Applicative (liftA2, liftA3)
 
 genWord8 :: Gen Word8
 genWord8 = chooseAny
@@ -56,7 +60,7 @@ instance Arbitrary I8 where
     shrink        = shrinkIntegral
 
 instance Arbitrary B.ByteString where
-    arbitrary     = B.pack `fmap` listOf genWord8
+    arbitrary     = B.pack <$> listOf genWord8
     shrink        = map B.pack . shrink . B.unpack
 
 instance Arbitrary BL.ByteString where
@@ -66,64 +70,84 @@ instance Arbitrary BL.ByteString where
       , BL.fromChunks . map B.singleton <$> listOf genWord8
       -- so that a code point with 4 byte long utf8 representation
       -- could appear split over 3 non-singleton chunks
-      , (\a b c -> BL.fromChunks [a, b, c])
-        <$> arbitrary
-        <*> ((\a b -> B.pack [a, b]) <$> genWord8 <*> genWord8)
-        <*> arbitrary
+      , liftA3 (\a b c -> BL.fromChunks [a, b, c])
+          arbitrary
+          (liftA2 (\a b -> B.pack [a, b])
+            genWord8
+            genWord8
+          )
+          arbitrary
       ]
     shrink xs = BL.fromChunks <$> shrink (BL.toChunks xs)
 
 -- | For tests that have O(n^2) running times or input sizes, resize
 -- their inputs to the square root of the originals.
 newtype Sqrt a = Sqrt { unSqrt :: a }
-    deriving (Eq, Show)
+ deriving (Eq, Show)
 
 instance Arbitrary a => Arbitrary (Sqrt a) where
-    arbitrary = fmap Sqrt $ sized $ \n -> resize (smallish n) arbitrary
-        where
-            smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
-    shrink = map Sqrt . shrink . unSqrt
+    arbitrary = coerce $ sized $ \n -> resize (smallish n) $ arbitrary @a
+     where
+      smallish = round . sqrt @Double . fromIntegral . abs
+    shrink = coerce (shrink @a)
 
 instance Arbitrary T.Text where
-    arbitrary = (T.pack . getUnicodeString) `fmap` arbitrary
+    arbitrary = T.pack <$> listOf arbitraryUnicodeChar -- without surrogates
     shrink = map T.pack . shrink . T.unpack
 
 instance Arbitrary TL.Text where
-    arbitrary = (TL.fromChunks . map notEmpty . unSqrt) `fmap` arbitrary
+    arbitrary = TL.fromChunks <$> coerce (arbitrary @(Sqrt [NotEmpty T.Text]))
     shrink = map TL.pack . shrink . TL.unpack
 
 newtype BigInt = Big Integer
-               deriving (Eq, Show)
+ deriving (Eq, Show)
 
 instance Arbitrary BigInt where
-    arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)
-    shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l]
-      where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer
+    arbitrary = do
+      e <- choose @Int (1,200)
+      coerce $ choose @Integer (10^(e-1),10^e)
+
+    shrink ba = [coerce (a `div` 2^(l-e)) | e <- shrink l]
+     where
+      a :: Integer
+      a = coerce ba
+      l :: Word
+      l = integerLog2 a
 
 newtype NotEmpty a = NotEmpty { notEmpty :: a }
-    deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show)
+
+toNotEmptyBy :: Functor m => ([Char] -> a) -> m (NonEmptyList Char) -> m (NotEmpty a)
+toNotEmptyBy f = fmap (coerce f)
+
+arbitraryNotEmptyBy :: ([Char] -> a) -> Gen (NotEmpty a)
+arbitraryNotEmptyBy f = toNotEmptyBy f arbitrary
+
+shrinkNotEmptyBy :: ([Char] -> a) -> (a -> [Char]) -> NotEmpty a -> [NotEmpty a]
+shrinkNotEmptyBy g f =
+  toNotEmptyBy g . shrink . coerce f
 
 instance Arbitrary (NotEmpty T.Text) where
-    arbitrary   = fmap (NotEmpty . T.pack . getNonEmpty) arbitrary
-    shrink      = fmap (NotEmpty . T.pack . getNonEmpty)
-                . shrink . NonEmpty . T.unpack . notEmpty
+    arbitrary   = arbitraryNotEmptyBy T.pack
+    shrink      = shrinkNotEmptyBy T.pack T.unpack
 
 instance Arbitrary (NotEmpty TL.Text) where
-    arbitrary   = fmap (NotEmpty . TL.pack . getNonEmpty) arbitrary
-    shrink      = fmap (NotEmpty . TL.pack . getNonEmpty)
-                . shrink . NonEmpty . TL.unpack . notEmpty
+    arbitrary   = arbitraryNotEmptyBy TL.pack
+    shrink      = shrinkNotEmptyBy TL.pack TL.unpack
+
 
 data DecodeErr = Lenient | Ignore | Strict | Replace
-               deriving (Show, Eq, Bounded, Enum)
+ deriving (Show, Eq, Bounded, Enum)
 
 genDecodeErr :: DecodeErr -> Gen T.OnDecodeError
-genDecodeErr Lenient = return T.lenientDecode
-genDecodeErr Ignore  = return T.ignore
-genDecodeErr Strict  = return T.strictDecode
-genDecodeErr Replace = (\c _ _ -> c) <$> frequency
-  [ (1, return Nothing)
-  , (50, Just <$> arbitraryUnicodeChar)
-  ]
+genDecodeErr Lenient = pure T.lenientDecode
+genDecodeErr Ignore  = pure T.ignore
+genDecodeErr Strict  = pure T.strictDecode
+genDecodeErr Replace = (\c _ _ -> c) <$>
+  frequency
+    [ (1, pure Nothing)
+    , (50, pure <$> arbitraryUnicodeChar)
+    ]
 
 instance Arbitrary DecodeErr where
     arbitrary = arbitraryBoundedEnum
@@ -167,71 +191,84 @@ 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 -> 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
-          (ta,tb)       = splitAtS m t
-          l             = length s
-          m | l == 0    = n
-            | otherwise = n `mod` l
-          n             = fromIntegral w
+eqP f g s w  =
+  testCounterExample "orig" s t .&&.
+  testCounterExample "mini" s mini .&&.
+  testCounterExample "head" sa ta .&&.
+  testCounterExample "tail" sb tb
+ where
+  testCounterExample txt a b = counterexample txt $ f a =^= g b
+
+  t       = packS s
+  mini    = packSChunkSize 10 s
+  (sa,sb) = splitAt m s
+  (ta,tb) = splitAtS m t
+
+  m       = if l == 0 then n else n `mod` l
+   where
+    l       = length s
+    n       = fromIntegral w
 
 eqPSqrt :: (Eq a, Show a, Stringy s) =>
        (String -> a) -> (s -> a) -> Sqrt String -> Word8 -> Property
-eqPSqrt f g s = eqP f g (unSqrt s)
+eqPSqrt f g s = eqP f g $ coerce s
 
 instance Arbitrary FPFormat where
     arbitrary = arbitraryBoundedEnum
 
-newtype Precision a = Precision (Maybe Int)
-                    deriving (Eq, Show)
+newtype Precision a = Precision { unPrecision :: Maybe Int}
+ deriving (Eq, Show)
 
+--  Deprecated on 2021-10-05
 precision :: a -> Precision a -> Maybe Int
-precision _ (Precision prec) = prec
+precision _ = coerce
+{-# DEPRECATED precision "Use @coerce@ with types instead." #-}
 
 arbitraryPrecision :: Int -> Gen (Precision a)
-arbitraryPrecision maxDigits = Precision <$> do
-  n <- choose (-1,maxDigits)
-  return $ if n == -1
-           then Nothing
-           else Just n
+arbitraryPrecision maxDigits = do
+  n <- choose (0,maxDigits)
+  frequency
+    [ (1, pure $ coerce $ Nothing @Int)
+    , (n, pure $ coerce $ Just n)
+    ]
 
 instance Arbitrary (Precision Float) where
     arbitrary = arbitraryPrecision 11
-    shrink    = map Precision . shrink . precision undefined
+    shrink    = coerce (shrink @(Maybe Int))
 
 instance Arbitrary (Precision Double) where
     arbitrary = arbitraryPrecision 22
-    shrink    = map Precision . shrink . precision undefined
+    shrink    = coerce (shrink @(Maybe Int))
 
 instance Arbitrary IO.Newline where
-    arbitrary = oneof [return IO.LF, return IO.CRLF]
+    arbitrary = oneof [pure IO.LF, pure IO.CRLF]
 
 instance Arbitrary IO.NewlineMode where
-    arbitrary = IO.NewlineMode <$> arbitrary <*> arbitrary
+    arbitrary =
+      liftA2 IO.NewlineMode
+        arbitrary
+        arbitrary
 
 instance Arbitrary IO.BufferMode where
-    arbitrary = oneof [ return IO.NoBuffering,
-                        return IO.LineBuffering,
-                        return (IO.BlockBuffering Nothing),
-                        (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`
-                        (arbitrary :: Gen Word16) ]
+    arbitrary =
+      oneof
+        [ pure IO.NoBuffering
+        , pure IO.LineBuffering
+        , pure (IO.BlockBuffering Nothing)
+        , IO.BlockBuffering . pure . succ . fromIntegral <$> arbitrary @Word16
+        ]
 
 -- This test harness is complex!  What property are we checking?
 --
 -- Reading after writing a multi-line file should give the same
 -- results as were written.
 --
 -- What do we vary while checking this property?
--- * The lines themselves, scrubbed to contain neither CR nor LF.  (By
---   working with a list of lines, we ensure that the data will
---   sometimes contain line endings.)
--- * Newline translation mode.
--- * Buffering.
+--  * The lines themselves, scrubbed to contain neither CR nor LF.  (By
+--    working with a list of lines, we ensure that the data will
+--    sometimes contain line endings.)
+--  * Newline translation mode.
+--  * Buffering.
 write_read :: (NFData a, Eq a, Show a)
            => ([b] -> a)
            -> ((Char -> Bool) -> a -> b)
@@ -245,18 +282,26 @@ write_read _ _ _ _ (IO.NewlineMode IO.LF IO.CRLF) _ _ = discard
 write_read unline filt writer reader nl buf ts = ioProperty $
     (===t) <$> act
   where
-    t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
-
-    act = withTempFile $ \path h -> do
-            IO.hSetNewlineMode h nl
-            IO.hSetBuffering h buf
-            () <- writer h t
-            IO.hClose h
-            bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
-              IO.hSetNewlineMode h' nl
-              IO.hSetBuffering h' buf
-              r <- reader h'
-              r `deepseq` return r
+
+    t = unline . map (filt (`notElem` "\r\n")) $ ts
+
+    act =
+      withTempFile roundTrip
+     where
+
+      readBack h' = do
+        IO.hSetNewlineMode h' nl
+        IO.hSetBuffering h' buf
+        r <- reader h'
+        r `deepseq` pure r
+
+      roundTrip path h = do
+        IO.hSetNewlineMode h nl
+        IO.hSetBuffering h buf
+        () <- writer h t
+        IO.hClose h
+
+        IO.withFile path IO.ReadMode readBack
 
 -- Generate various Unicode space characters with high probability
 arbitrarySpacyChar :: Gen Char
@@ -269,5 +314,5 @@ newtype SpacyString = SpacyString { getSpacyString :: String }
   deriving (Eq, Ord, Show, Read)
 
 instance Arbitrary SpacyString where
-  arbitrary = SpacyString `fmap` listOf arbitrarySpacyChar
-  shrink (SpacyString xs) = SpacyString `fmap` shrink xs
+  arbitrary = coerce $ listOf arbitrarySpacyChar
+  shrink = coerce (shrink @[Char])