Commits

Jasper Van der Jeugt committed 3638263

Move more utility functions away from Properties

  • Participants
  • Parent commits 74228a6

Comments (0)

Files changed (3)

File tests/tests/src/Data/Text/Tests/Properties.hs

 {-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings,
              ScopedTypeVariables, TypeSynonymInstances, CPP #-}
 {-# OPTIONS_GHC -fno-enable-rewrite-rules #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 module Data.Text.Tests.Properties
     (
       tests
 import Test.QuickCheck.Monadic
 import Text.Show.Functions ()
 
-import qualified Data.Bits as Bits (shiftL, shiftR)
-import Numeric (showHex)
+import Control.Arrow ((***), second)
+import Control.Exception (catch)
 import Data.Char (chr, isDigit, isHexDigit, isLower, isSpace, isUpper, ord)
 import Data.Monoid (Monoid(..))
 import Data.String (fromString)
-import Debug.Trace (trace)
-import Control.Arrow ((***), second)
-import Control.DeepSeq
+import Data.Text.Encoding.Error
+import Data.Text.Foreign
+import Data.Text.Fusion.Size
+import Data.Text.Lazy.Read as TL
+import Data.Text.Read as T
+import Data.Text.Search (indices)
 import Data.Word (Word8, Word16, Word32)
+import Numeric (showHex)
+import Prelude hiding (catch, replicate)
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import qualified Data.Bits as Bits (shiftL, shiftR)
+import qualified Data.ByteString as B
+import qualified Data.List as L
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+import qualified Data.Text.Fusion as S
+import qualified Data.Text.Fusion.Common as S
 import qualified Data.Text.IO as T
 import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.IO as TL
-import qualified Data.Text.Lazy.Internal as TL
 import qualified Data.Text.Lazy.Builder as TB
-import qualified Data.Text.Encoding as E
-import Data.Text.Read as T
-import Data.Text.Lazy.Read as TL
-import Data.Text.Encoding.Error
-import Control.Exception (SomeException, bracket, catch, evaluate, try)
-import Data.Text.Foreign
-import qualified Data.Text.Fusion as S
-import qualified Data.Text.Fusion.Common as S
-import Data.Text.Fusion.Size
 import qualified Data.Text.Lazy.Encoding as EL
 import qualified Data.Text.Lazy.Fusion as SL
+import qualified Data.Text.Lazy.IO as TL
+import qualified Data.Text.Lazy.Search as S (indices)
 import qualified Data.Text.UnsafeShift as U
-import qualified Data.List as L
-import Prelude hiding (catch, replicate)
-import System.IO
-import System.IO.Unsafe (unsafePerformIO)
-import Test.Framework (Test, defaultMain, testGroup)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Data.Text.Search (indices)
-import qualified Data.Text.Lazy.Search as S (indices)
+import qualified System.IO as IO
 
 import Data.Text.Tests.QuickCheckUtils
 import Data.Text.Tests.TestUtils
 t_utf32BE    = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id
 tl_utf32BE   = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id
 
-data DecodeErr = DE String OnDecodeError
-
-instance Show DecodeErr where
-    show (DE d _) = "DE " ++ d
-
-instance Arbitrary DecodeErr where
-    arbitrary = oneof [ return $ DE "lenient" lenientDecode
-                      , return $ DE "ignore" ignore
-                      , return $ DE "strict" strictDecode
-                      , DE "replace" `fmap` arbitrary ]
-
 -- This is a poor attempt to ensure that the error handling paths on
 -- decode are exercised in some way.  Proper testing would be rather
 -- more involved.
+t_utf8_err :: DecodeErr -> B.ByteString -> Property
 t_utf8_err (DE _ de) bs = monadicIO $ do
   l <- run $ let len = T.length (E.decodeUtf8With de bs)
              in (len `seq` return (Right len)) `catch`
     Left err -> assert $ length (show err) >= 0
     Right n  -> assert $ n >= 0
 
+t_utf8_err' :: B.ByteString -> Property
 t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of
                                         Left err -> length (show err) >= 0
                                         Right t  -> T.length t >= 0
 
-class Stringy s where
-    packS    :: String -> s
-    unpackS  :: s -> String
-    splitAtS :: Int -> s -> (s,s)
-    packSChunkSize :: Int -> String -> s
-    packSChunkSize _ = packS
-
-instance Stringy String where
-    packS    = id
-    unpackS  = id
-    splitAtS = splitAt
-
-instance Stringy (S.Stream Char) where
-    packS        = S.streamList
-    unpackS      = S.unstreamList
-    splitAtS n s = (S.take n s, S.drop n s)
-
-instance Stringy T.Text where
-    packS    = T.pack
-    unpackS  = T.unpack
-    splitAtS = T.splitAt
-
-instance Stringy TL.Text where
-    packSChunkSize k = SL.unstreamChunks k . S.streamList
-    packS    = TL.pack
-    unpackS  = TL.unpack
-    splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .
-               TL.splitAt . fromIntegral
-
--- Do two functions give the same answer?
-eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
-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 -> Bool
-eqP f g s w  = eql "orig" (f s) (g t) &&
-               eql "mini" (f s) (g mini) &&
-               eql "head" (f sa) (g ta) &&
-               eql "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
-          eql d a b
-            | a =^= b   = True
-            | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
-
 s_Eq s            = (s==)    `eq` ((S.streamList s==) . S.streamList)
     where _types = s :: String
 sf_Eq p s =
 
 -- Input and output.
 
--- Work around lack of Show instance for TextEncoding.
-data Encoding = E String TextEncoding
-
-instance Show Encoding where show (E n _) = "utf" ++ n
-
-instance Arbitrary Encoding where
-    arbitrary = oneof . map return $
-      [ E "8" utf8, E "8_bom" utf8_bom, E "16" utf16, E "16le" utf16le,
-        E "16be" utf16be, E "32" utf32, E "32le" utf32le, E "32be" utf32be ]
-
-windowsNewlineMode  = NewlineMode { inputNL = CRLF, outputNL = CRLF }
-
--- Newline and NewlineMode have standard Show instance from GHC 7 onwards
-#if __GLASGOW_HASKELL__ < 700
-instance Show Newline where
-    show CRLF = "CRLF"
-    show LF   = "LF"
-
-instance Show NewlineMode where
-    show (NewlineMode i o) = "NewlineMode { inputNL = " ++ show i ++
-                             ", outputNL = " ++ show o ++ " }"
-# endif
-
-instance Arbitrary NewlineMode where
-    arbitrary = oneof . map return $
-      [ noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
-        windowsNewlineMode ]
-
-instance Arbitrary BufferMode where
-    arbitrary = oneof [ return NoBuffering,
-                        return LineBuffering,
-                        return (BlockBuffering Nothing),
-                        (BlockBuffering . Just . (+1) . fromIntegral) `fmap`
-                        (arbitrary :: Gen 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.)
--- * Encoding.
--- * Newline translation mode.
--- * Buffering.
-write_read unline filt writer reader (E _ enc) nl buf ts =
-    monadicIO $ assert . (==t) =<< run act
-  where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
-        act = withTempFile $ \path h -> do
-                -- hSetEncoding h enc
-                hSetNewlineMode h nl
-                hSetBuffering h buf
-                () <- writer h t
-                hClose h
-                bracket (openFile path ReadMode) hClose $ \h' -> do
-                  -- hSetEncoding h' enc
-                  hSetNewlineMode h' nl
-                  hSetBuffering h' buf
-                  r <- reader h'
-                  r `deepseq` return r
-
 t_put_get = write_read T.unlines T.filter put get
-  where put h = withRedirect h stdout . T.putStr
-        get h = withRedirect h stdin T.getContents
+  where put h = withRedirect h IO.stdout . T.putStr
+        get h = withRedirect h IO.stdin T.getContents
 tl_put_get = write_read TL.unlines TL.filter put get
-  where put h = withRedirect h stdout . TL.putStr
-        get h = withRedirect h stdin TL.getContents
+  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
 

File tests/tests/src/Data/Text/Tests/QuickCheckUtils.hs

-{-# LANGUAGE FlexibleInstances #-}
+-- | This module provides quickcheck utilities, e.g. arbitrary and show
+-- instances, and comparison functions, so we can focus on the actual properties
+-- in the 'Data.Text.Tests.Properties' module.
+--
+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Data.Text.Tests.QuickCheckUtils
     (
       genUnicode
     , small
 
     , integralRandomR
+
+    , DecodeErr (..)
+
+    , Stringy (..)
+    , eq
+    , eqP
+
+    , Encoding (..)
+    
+    , write_read
     ) where
 
-import Control.Arrow (first)
+import Control.Arrow (first, (***))
+import Control.DeepSeq (NFData (..), deepseq)
+import Control.Exception (bracket)
 import Data.Bits ((.&.))
 import Data.Char (chr)
+import Data.Word (Word8, Word16)
 import Data.String (IsString, fromString)
 import Data.Text.Foreign (I16)
+import Debug.Trace (trace)
+import System.Random (Random (..), RandomGen)
+import Test.QuickCheck hiding ((.&.))
+import Test.QuickCheck.Monadic (assert, monadicIO, run)
 import qualified Data.ByteString as B
 import qualified Data.Text as T
+import qualified Data.Text.Encoding.Error as T
+import qualified Data.Text.Fusion as TF
+import qualified Data.Text.Fusion.Common as TF
 import qualified Data.Text.Lazy as TL
-import System.Random (Random (..), RandomGen)
-import Test.QuickCheck hiding ((.&.))
+import qualified Data.Text.Lazy.Fusion as TLF
+import qualified Data.Text.Lazy.Internal as TL
+import qualified System.IO as IO
+
+import Data.Text.Tests.TestUtils
 
 instance Random I16 where
     randomR = integralRandomR
 integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,
                                          fromIntegral b :: Integer) g of
                             (x,h) -> (fromIntegral x, h)
+
+data DecodeErr = DE String T.OnDecodeError
+
+instance Show DecodeErr where
+    show (DE d _) = "DE " ++ d
+
+instance Arbitrary DecodeErr where
+    arbitrary = oneof [ return $ DE "lenient" T.lenientDecode
+                      , return $ DE "ignore" T.ignore
+                      , return $ DE "strict" T.strictDecode
+                      , DE "replace" `fmap` arbitrary ]
+
+class Stringy s where
+    packS    :: String -> s
+    unpackS  :: s -> String
+    splitAtS :: Int -> s -> (s,s)
+    packSChunkSize :: Int -> String -> s
+    packSChunkSize _ = packS
+
+instance Stringy String where
+    packS    = id
+    unpackS  = id
+    splitAtS = splitAt
+
+instance Stringy (TF.Stream Char) where
+    packS        = TF.streamList
+    unpackS      = TF.unstreamList
+    splitAtS n s = (TF.take n s, TF.drop n s)
+
+instance Stringy T.Text where
+    packS    = T.pack
+    unpackS  = T.unpack
+    splitAtS = T.splitAt
+
+instance Stringy TL.Text where
+    packSChunkSize k = TLF.unstreamChunks k . TF.streamList
+    packS    = TL.pack
+    unpackS  = TL.unpack
+    splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .
+               TL.splitAt . fromIntegral
+
+-- Do two functions give the same answer?
+eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
+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 -> Bool
+eqP f g s w  = eql "orig" (f s) (g t) &&
+               eql "mini" (f s) (g mini) &&
+               eql "head" (f sa) (g ta) &&
+               eql "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
+          eql d a b
+            | a =^= b   = True
+            | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
+
+-- Work around lack of Show instance for TextEncoding.
+data Encoding = E String IO.TextEncoding
+
+instance Show Encoding where show (E n _) = "utf" ++ n
+
+instance Arbitrary Encoding where
+    arbitrary = oneof . map return $
+      [ E "8" IO.utf8, E "8_bom" IO.utf8_bom, E "16" IO.utf16
+      , E "16le" IO.utf16le, E "16be" IO.utf16be, E "32" IO.utf32
+      , E "32le" IO.utf32le, E "32be" IO.utf32be
+      ]
+
+windowsNewlineMode :: IO.NewlineMode
+windowsNewlineMode = IO.NewlineMode
+    { IO.inputNL = IO.CRLF, IO.outputNL = IO.CRLF
+    }
+
+-- Newline and NewlineMode have standard Show instance from GHC 7 onwards
+#if __GLASGOW_HASKELL__ < 700
+instance Show Newline where
+    show CRLF = "CRLF"
+    show LF   = "LF"
+
+instance Show NewlineMode where
+    show (NewlineMode i o) = "NewlineMode { inputNL = " ++ show i ++
+                             ", outputNL = " ++ show o ++ " }"
+# endif
+
+instance Arbitrary IO.NewlineMode where
+    arbitrary = oneof . map return $
+      [ IO.noNewlineTranslation, IO.universalNewlineMode, IO.nativeNewlineMode
+      , windowsNewlineMode
+      ]
+
+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) ]
+
+-- 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.)
+-- * Encoding.
+-- * Newline translation mode.
+-- * Buffering.
+write_read :: (NFData a, Eq a)
+           => ([b] -> a)
+           -> ((Char -> Bool) -> a -> b)
+           -> (IO.Handle -> a -> IO ())
+           -> (IO.Handle -> IO a)
+           -> Encoding
+           -> IO.NewlineMode
+           -> IO.BufferMode
+           -> [a]
+           -> Property
+write_read unline filt writer reader (E _ enc) nl buf ts =
+    monadicIO $ assert . (==t) =<< run act
+  where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
+        act = withTempFile $ \path h -> do
+                -- hSetEncoding h enc
+                IO.hSetNewlineMode h nl
+                IO.hSetBuffering h buf
+                () <- writer h t
+                IO.hClose h
+                bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
+                  -- hSetEncoding h' enc
+                  IO.hSetNewlineMode h' nl
+                  IO.hSetBuffering h' buf
+                  r <- reader h'
+                  r `deepseq` return r

File tests/tests/text-tests.cabal

     -Wall
     -threaded
     -O0
-    -fno-warn-orphans
-    -fno-warn-missing-signatures 
 
   -- Optional HPC support
   if flag(hpc)