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 #-}
 
@@ -30,8 +32,8 @@ module Tests.QuickCheckUtils
 
 import Control.Arrow ((***))
 import Control.DeepSeq (NFData (..), deepseq)
-import Control.Exception (bracket)
 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)
@@ -47,6 +49,8 @@ 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)
+import Data.Bits (shiftR, shiftL, countLeadingZeros, finiteBitSize)
 
 genWord8 :: Gen Word8
 genWord8 = chooseAny
@@ -79,39 +83,63 @@ newtype Sqrt a = Sqrt { unSqrt :: a }
     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 = intSqrt . abs
+      -- | Simple implementation of square root for integers.
+      intSqrt :: Int -> Int
+      intSqrt n =
+        if n < 2
+          then n
+          else
+            let b2 = shiftR (finiteBitSize n - countLeadingZeros n) 1 in
+            shiftR (shiftL 1 b2 + shiftR n b2) 1
+    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)
 
 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)
 
+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)
@@ -167,71 +195,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 =
+  testCounterExamples
+    [ ("orig", s , t   )
+    , ("mini", s , mini)
+    , ("head", sa, ta  )
+    , ("tail", sb, tb  )
+    ]
+ where
+  testCounterExamples        :: Property
+  testCounterExamples        = foldr (.&&.) mempty $ fmap $ uncurry3 testCounterExample
+  uncurry3 fun (a, b, c)     = fun a b c
+  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 null s then id else (`mod` length s)) $ 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@ or @unPrecision@ 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 +286,24 @@ 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
+
+      roundTrip path h = do
+        IO.hSetNewlineMode h nl
+        IO.hSetBuffering h buf
+        () <- writer h t
+        IO.hClose h
+        let
+          readBack h' = do
+            IO.hSetNewlineMode h' nl
+            IO.hSetBuffering h' buf
+            r <- reader h'
+            r `deepseq` pure r
+        IO.withFile path IO.ReadMode readBack
 
 -- Generate various Unicode space characters with high probability
 arbitrarySpacyChar :: Gen Char
@@ -269,5 +316,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])