improve test function write_read (#593)

tests/Tests/Properties/LowLevel.hs

@@ -100,17 +100,14 @@ t_literal_foo = T.pack "foo"
 -- tl_put_get = write_read TL.unlines TL.filter put get
 --   where put h = withRedirect h IO.stdout . TL.putStr
 --         get h = withRedirect h IO.stdin TL.getContents
-t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents
-tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents
+t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents id
+tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents id
 
-t_write_read_line m b t = write_read (T.concat . take 1) T.filter T.hPutStrLn
-                            T.hGetLine m b [t]
-tl_write_read_line m b t = write_read (TL.concat . take 1) TL.filter TL.hPutStrLn
-                             TL.hGetLine m b [t]
+t_write_read_line = write_read (T.concat . take 1) T.filter T.hPutStrLn T.hGetLine (: [])
+tl_write_read_line = write_read (TL.concat . take 1) TL.filter TL.hPutStrLn TL.hGetLine (: [])
 
-utf8_write_read = write_read T.unlines T.filter TU.hPutStr TU.hGetContents
-utf8_write_read_line m b t = write_read (T.concat . take 1) T.filter TU.hPutStrLn
-                            TU.hGetLine m b [t]
+utf8_write_read = write_read T.unlines T.filter TU.hPutStr TU.hGetContents id
+utf8_write_read_line = write_read (T.concat . take 1) T.filter TU.hPutStrLn TU.hGetLine (: [])
 
 testLowLevel :: TestTree
 testLowLevel =
@@ -143,12 +140,12 @@ testLowLevel =
     ],
 
     testGroup "input-output" [
-      testProperty "t_write_read" t_write_read,
-      testProperty "tl_write_read" tl_write_read,
-      testProperty "t_write_read_line" t_write_read_line,
-      testProperty "tl_write_read_line" tl_write_read_line,
-      testProperty "utf8_write_read" utf8_write_read,
-      testProperty "utf8_write_read_line" utf8_write_read_line
+      testGroup "t_write_read" t_write_read,
+      testGroup "tl_write_read" tl_write_read,
+      testGroup "t_write_read_line" t_write_read_line,
+      testGroup "tl_write_read_line" tl_write_read_line,
+      testGroup "utf8_write_read" utf8_write_read,
+      testGroup "utf8_write_read_line" utf8_write_read_line
       -- These tests are subject to I/O race conditions
       -- testProperty "t_put_get" t_put_get,
       -- testProperty "tl_put_get" tl_put_get

tests/Tests/QuickCheckUtils.hs

@@ -5,6 +5,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -31,14 +34,16 @@ module Tests.QuickCheckUtils
     ) where
 
 import Control.Arrow ((***))
-import Control.DeepSeq (NFData (..), deepseq)
-import Control.Exception (bracket)
+import Data.Bool (bool)
 import Data.Char (isSpace)
 import Data.Text.Foreign (I8)
 import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
 import Data.Word (Word8, Word16)
-import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, discard, counterexample, scale, (===), (.&&.), NonEmptyList(..))
+import GHC.IO.Encoding.Types (TextEncoding(TextEncoding,textEncodingName))
+import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, discard, counterexample, scale, (.&&.), NonEmptyList(..), forAll, getPositive)
 import Test.QuickCheck.Gen (Gen, choose, chooseAny, elements, frequency, listOf, oneof, resize, sized)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (testProperty)
 import Tests.Utils
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
@@ -54,6 +59,9 @@ import qualified System.IO as IO
 genWord8 :: Gen Word8
 genWord8 = chooseAny
 
+genWord16 :: Gen Word16
+genWord16 = chooseAny
+
 instance Arbitrary I8 where
     arbitrary     = arbitrarySizedIntegral
     shrink        = shrinkIntegral
@@ -227,7 +235,7 @@ instance Arbitrary IO.BufferMode where
                         return IO.LineBuffering,
                         return (IO.BlockBuffering Nothing),
                         (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`
-                        (arbitrary :: Gen Word16) ]
+                        genWord16 ]
 
 -- This test harness is complex!  What property are we checking?
 --
@@ -240,33 +248,39 @@ instance Arbitrary IO.BufferMode where
 --   sometimes contain line endings.)
 -- * Newline translation mode.
 -- * Buffering.
-write_read :: (NFData a, Eq a, Show a)
-           => ([b] -> a)
-           -> ((Char -> Bool) -> a -> b)
-           -> (IO.Handle -> a -> IO ())
-           -> (IO.Handle -> IO a)
-           -> IO.NewlineMode
-           -> IO.BufferMode
-           -> [a]
-           -> Property
-write_read _ _ _ _ (IO.NewlineMode IO.LF IO.CRLF) _ _ = discard
-write_read unline filt writer reader nl buf ts = ioProperty $
-    (===t) <$> act
+write_read :: forall a b c.
+  (Eq a, Show a, Show c, Arbitrary c)
+  => ([b] -> a)
+  -> ((Char -> Bool) -> b -> b)
+  -> (IO.Handle -> a -> IO ())
+  -> (IO.Handle -> IO a)
+  -> (c -> [b])
+  -> [TestTree]
+write_read unline filt writer reader modData
+  = encodings <&> \enc@TextEncoding {textEncodingName} -> testGroup textEncodingName
+    [ testProperty "NoBuffering" $ propTest enc (pure IO.NoBuffering)
+    , testProperty "LineBuffering" $ propTest enc (pure IO.LineBuffering)
+    , testProperty "BlockBuffering" $ propTest enc blockBuffering
+    ]
   where
-    t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
-
-    act = withTempFile $ \path h -> do
-            IO.hSetEncoding h IO.utf8
-            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.hSetEncoding h' IO.utf8
-              IO.hSetNewlineMode h' nl
-              IO.hSetBuffering h' buf
-              r <- reader h'
-              r `deepseq` return r
+  propTest :: TextEncoding -> Gen IO.BufferMode -> IO.NewlineMode -> c -> Property
+  propTest _   _ (IO.NewlineMode IO.LF IO.CRLF) _ = discard
+  propTest enc genBufferMode nl d = forAll genBufferMode $ \mode -> ioProperty $ withTempFile $ \_ h -> do
+    let ts = modData d
+        t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
+    IO.hSetEncoding h enc
+    IO.hSetNewlineMode h nl
+    IO.hSetBuffering h mode
+    () <- writer h t
+    IO.hSeek h IO.AbsoluteSeek 0
+    r <- reader h
+    let isEq = r == t
+    seq isEq $ pure $ counterexample (show r ++ bool " /= " " == " isEq ++ show t) isEq
+
+  encodings = [IO.utf8, IO.utf8_bom, IO.utf16, IO.utf16le, IO.utf16be, IO.utf32, IO.utf32le, IO.utf32be]
+
+  blockBuffering :: Gen IO.BufferMode
+  blockBuffering = IO.BlockBuffering <$> fmap (fmap $ min 4 . getPositive) arbitrary
 
 -- Generate various Unicode space characters with high probability
 arbitrarySpacyChar :: Gen Char
@@ -287,3 +301,7 @@ newtype SkewedBool = Skewed { getSkewed :: Bool }
 
 instance Arbitrary SkewedBool where
   arbitrary = Skewed <$> frequency [(1, pure False), (5, pure True)]
+
+(<&>) :: [a] -> (a -> b) -> [b]
+(<&>) = flip fmap
+

tests/Tests/Utils.hs

@@ -9,10 +9,10 @@ module Tests.Utils
     ) where
 
 import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
-import Control.Monad (when)
+import Control.Monad (when, unless)
 import GHC.IO.Handle.Internals (withHandle)
 import System.Directory (removeFile)
-import System.IO (Handle, hClose, hFlush, hIsOpen, hIsWritable, openTempFile)
+import System.IO (Handle, hClose, hFlush, hIsOpen, hIsClosed, hIsWritable, openTempFile)
 import Test.QuickCheck (Property, ioProperty, property, (===), counterexample)
 
 -- Ensure that two potentially bottom values (in the sense of crashing
@@ -34,8 +34,8 @@ withTempFile :: (FilePath -> Handle -> IO a) -> IO a
 withTempFile = bracket (openTempFile "." "crashy.txt") cleanupTemp . uncurry
   where
     cleanupTemp (path,h) = do
-      open <- hIsOpen h
-      when open (hClose h)
+      closed <- hIsClosed h
+      unless closed $ hClose h
       removeFile path
 
 withRedirect :: Handle -> Handle -> IO a -> IO a