diff --git a/tests/Tests/Properties/LowLevel.hs b/tests/Tests/Properties/LowLevel.hs index 5a7c7ceb..0fac6970 100644 --- a/tests/Tests/Properties/LowLevel.hs +++ b/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 diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs index 098d09d6..d38eddee 100644 --- a/tests/Tests/QuickCheckUtils.hs +++ b/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 + diff --git a/tests/Tests/Utils.hs b/tests/Tests/Utils.hs index 4d41a530..58ca7f6b 100644 --- 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) +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