BufferMode rejection logic moved to a generator

haskell · May 14, 2024 · 6e0f58e · 6e0f58e
1 parent 96e77d8
commit 6e0f58e
Show file tree

Hide file tree

Showing 2 changed files with 20 additions and 14 deletions.
diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs
@@ -41,7 +41,7 @@ import Data.Text.Foreign (I8)
 import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
 import Data.Word (Word8, Word16)
 import GHC.IO.Encoding.Types (TextEncoding(TextEncoding,textEncodingName))
-import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, discard, counterexample, scale, (.&&.), NonEmptyList(..))
+import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, discard, counterexample, scale, (.&&.), NonEmptyList(..), suchThat, 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)
@@ -60,6 +60,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
@@ -233,7 +236,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?
 --
@@ -256,27 +259,30 @@ write_read :: forall a b c.
   -> [TestTree]
 write_read unline filt writer reader modData
   = encodings <&> \enc@TextEncoding {textEncodingName} -> testGroup textEncodingName
-    [ testProperty "NoBuffering" $ propTest enc (\() -> IO.NoBuffering) (const False)
-    , testProperty "LineBuffering" $ propTest enc (\() -> IO.LineBuffering) (const False)
-    , testProperty "BlockBuffering" $ propTest enc IO.BlockBuffering (maybe False (< 4))
+    [ testProperty "NoBuffering" $ propTest enc (pure IO.NoBuffering)
+    , testProperty "LineBuffering" $ propTest enc (pure IO.LineBuffering)
+    , testProperty "BlockBuffering" $ propTest enc blockBuffering
     ]
   where
-  propTest :: TextEncoding -> (modeArg -> IO.BufferMode) -> (modeArg -> Bool) -> modeArg -> IO.NewlineMode -> c -> Property
-  propTest _   _               _           _      (IO.NewlineMode IO.LF IO.CRLF) _ = discard
-  propTest _   _               modeArgPred bufArg _                              _ | modeArgPred bufArg = discard
-  propTest enc mkBufferingMode _           bufArg nl                             d = ioProperty $ withTempFile $ \_ h -> do
+  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 $ mkBufferingMode bufArg
+    IO.hSetBuffering h mode
     () <- writer h t
     IO.hSeek h IO.AbsoluteSeek 0
     r <- reader h
     let isEq = r == t
     deepseq 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 getPositive) arbitrary) `suchThat` maybe True (> 4)
+
+
 -- Generate various Unicode space characters with high probability
 arbitrarySpacyChar :: Gen Char
 arbitrarySpacyChar = oneof

diff --git a/tests/Tests/Utils.hs b/tests/Tests/Utils.hs
@@ -9,10 +9,10 @@ module Tests.Utils
     ) where
 
 import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
-import Control.Monad (when, unless)
+import Control.Monad (when)
 import GHC.IO.Handle.Internals (withHandle)
 import System.Directory (removeFile)
-import System.IO (Handle, hClose, hFlush, hIsOpen, hIsClosed, hIsWritable, openTempFile)
+import System.IO (Handle, hClose, hFlush, hIsOpen, 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
-      closed <- hIsClosed h
-      unless closed $ hClose h
+      open <- hIsOpen h
+      when open (hClose h)
       removeFile path
 
 withRedirect :: Handle -> Handle -> IO a -> IO a