git.iko.soy/text
on 3dfd6d2 help sign in
text/tests/Tests/QuickCheckUtils.hs
360 lines 11 kB history raw
1-- | This module provides quickcheck utilities, e.g. arbitrary and show
2-- instances, and comparison functions, so we can focus on the actual properties
3-- in the 'Tests.Properties' module.
4--
5{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
7module Tests.QuickCheckUtils
8 (
9 genUnicode
10 , unsquare
11 , smallArbitrary
13 , BigBounded(..)
14 , BigInt(..)
15 , NotEmpty(..)
17 , Small(..)
18 , small
20 , Precision(..)
21 , precision
23 , integralRandomR
25 , DecodeErr(..)
26 , genDecodeErr
28 , Stringy(..)
29 , eq
30 , eqP
32 , Encoding(..)
34 , write_read
35 ) where
37import Control.Applicative ((<$>))
38import Control.Arrow (first, (***))
39import Control.DeepSeq (NFData (..), deepseq)
40import Control.Exception (bracket)
41import Data.String (IsString, fromString)
42import Data.Text.Foreign (I16)
43import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
44import Data.Word (Word8, Word16)
45import Debug.Trace (trace)
46import System.Random (Random(..), RandomGen)
47import Test.QuickCheck hiding (Fixed(..), Small (..), (.&.))
48import Test.QuickCheck.Monadic (assert, monadicIO, run)
49import Test.QuickCheck.Unicode (string)
50import Tests.Utils
51import qualified Data.ByteString as B
52import qualified Data.Text as T
53import qualified Data.Text.Encoding.Error as T
54import qualified Data.Text.Internal.Fusion as TF
55import qualified Data.Text.Internal.Fusion.Common as TF
56import qualified Data.Text.Internal.Lazy as TL
57import qualified Data.Text.Internal.Lazy.Fusion as TLF
58import qualified Data.Text.Lazy as TL
59import qualified System.IO as IO
61#if !MIN_VERSION_base(4,4,0)
62import Data.Int (Int64)
63import Data.Word (Word, Word64)
64#endif
66genUnicode :: IsString a => Gen a
67genUnicode = fromString <$> string
69instance Random I16 where
70 randomR = integralRandomR
71 random = randomR (minBound,maxBound)
73instance Arbitrary I16 where
74 arbitrary = arbitrarySizedIntegral
75 shrink = shrinkIntegral
77instance Arbitrary B.ByteString where
78 arbitrary = B.pack `fmap` arbitrary
79 shrink = map B.pack . shrink . B.unpack
81#if !MIN_VERSION_base(4,4,0)
82instance Random Int64 where
83 randomR = integralRandomR
84 random = randomR (minBound,maxBound)
86instance Random Word where
87 randomR = integralRandomR
88 random = randomR (minBound,maxBound)
90instance Random Word8 where
91 randomR = integralRandomR
92 random = randomR (minBound,maxBound)
94instance Random Word64 where
95 randomR = integralRandomR
96 random = randomR (minBound,maxBound)
97#endif
99-- For tests that have O(n^2) running times or input sizes, resize
100-- their inputs to the square root of the originals.
101unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property
102unsquare = forAll smallArbitrary
104smallArbitrary :: (Arbitrary a, Show a) => Gen a
105smallArbitrary = sized $ \n -> resize (smallish n) arbitrary
106 where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
108instance Arbitrary T.Text where
109 arbitrary = T.pack `fmap` arbitrary
110 shrink = map T.pack . shrink . T.unpack
112instance Arbitrary TL.Text where
113 arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary
114 shrink = map TL.pack . shrink . TL.unpack
116newtype BigInt = Big Integer
117 deriving (Eq, Show)
119instance Arbitrary BigInt where
120 arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)
121 shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l]
122 where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer
124newtype BigBounded a = BigBounded a
125 deriving (Eq, Show)
127instance (Bounded a, Random a, Arbitrary a) => Arbitrary (BigBounded a) where
128 arbitrary = BigBounded <$> choose (minBound, maxBound)
130newtype NotEmpty a = NotEmpty { notEmpty :: a }
131 deriving (Eq, Ord)
133instance Show a => Show (NotEmpty a) where
134 show (NotEmpty a) = show a
136instance Functor NotEmpty where
137 fmap f (NotEmpty a) = NotEmpty (f a)
139instance Arbitrary a => Arbitrary (NotEmpty [a]) where
140 arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
141 shrink = shrinkNotEmpty null
143instance Arbitrary (NotEmpty T.Text) where
144 arbitrary = (fmap T.pack) `fmap` arbitrary
145 shrink = shrinkNotEmpty T.null
147instance Arbitrary (NotEmpty TL.Text) where
148 arbitrary = (fmap TL.pack) `fmap` arbitrary
149 shrink = shrinkNotEmpty TL.null
151instance Arbitrary (NotEmpty B.ByteString) where
152 arbitrary = (fmap B.pack) `fmap` arbitrary
153 shrink = shrinkNotEmpty B.null
155shrinkNotEmpty :: Arbitrary a => (a -> Bool) -> NotEmpty a -> [NotEmpty a]
156shrinkNotEmpty isNull (NotEmpty xs) =
157 [ NotEmpty xs' | xs' <- shrink xs, not (isNull xs') ]
159data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7
160 | S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15
161 | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23
162 | S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31
163 deriving (Eq, Ord, Enum, Bounded)
165small :: Integral a => Small -> a
166small = fromIntegral . fromEnum
168intf :: (Int -> Int -> Int) -> Small -> Small -> Small
169intf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)
171instance Show Small where
172 show = show . fromEnum
174instance Read Small where
175 readsPrec n = map (first toEnum) . readsPrec n
177instance Num Small where
178 fromInteger = toEnum . fromIntegral
179 signum _ = 1
180 abs = id
181 (+) = intf (+)
182 (-) = intf (-)
183 (*) = intf (*)
185instance Real Small where
186 toRational = toRational . fromEnum
188instance Integral Small where
189 toInteger = toInteger . fromEnum
190 quotRem a b = (toEnum x, toEnum y)
191 where (x, y) = fromEnum a `quotRem` fromEnum b
193instance Random Small where
194 randomR = integralRandomR
195 random = randomR (minBound,maxBound)
197instance Arbitrary Small where
198 arbitrary = choose (minBound, maxBound)
199 shrink = shrinkIntegral
201integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
202integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
203 fromIntegral b :: Integer) g of
204 (x,h) -> (fromIntegral x, h)
206data DecodeErr = Lenient | Ignore | Strict | Replace
207 deriving (Show, Eq)
209genDecodeErr :: DecodeErr -> Gen T.OnDecodeError
210genDecodeErr Lenient = return T.lenientDecode
211genDecodeErr Ignore = return T.ignore
212genDecodeErr Strict = return T.strictDecode
213genDecodeErr Replace = arbitrary
215instance Arbitrary DecodeErr where
216 arbitrary = elements [Lenient, Ignore, Strict, Replace]
218class Stringy s where
219 packS :: String -> s
220 unpackS :: s -> String
221 splitAtS :: Int -> s -> (s,s)
222 packSChunkSize :: Int -> String -> s
223 packSChunkSize _ = packS
225instance Stringy String where
226 packS = id
227 unpackS = id
228 splitAtS = splitAt
230instance Stringy (TF.Stream Char) where
231 packS = TF.streamList
232 unpackS = TF.unstreamList
233 splitAtS n s = (TF.take n s, TF.drop n s)
235instance Stringy T.Text where
236 packS = T.pack
237 unpackS = T.unpack
238 splitAtS = T.splitAt
240instance Stringy TL.Text where
241 packSChunkSize k = TLF.unstreamChunks k . TF.streamList
242 packS = TL.pack
243 unpackS = TL.unpack
244 splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .
245 TL.splitAt . fromIntegral
247-- Do two functions give the same answer?
248eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
249eq a b s = a s =^= b s
251-- What about with the RHS packed?
252eqP :: (Eq a, Show a, Stringy s) =>
253 (String -> a) -> (s -> a) -> String -> Word8 -> Bool
254eqP f g s w = eql "orig" (f s) (g t) &&
255 eql "mini" (f s) (g mini) &&
256 eql "head" (f sa) (g ta) &&
257 eql "tail" (f sb) (g tb)
258 where t = packS s
259 mini = packSChunkSize 10 s
260 (sa,sb) = splitAt m s
261 (ta,tb) = splitAtS m t
262 l = length s
263 m | l == 0 = n
264 | otherwise = n `mod` l
265 n = fromIntegral w
266 eql d a b
267 | a =^= b = True
268 | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
270instance Arbitrary FPFormat where
271 arbitrary = elements [Exponent, Fixed, Generic]
273newtype Precision a = Precision (Maybe Int)
274 deriving (Eq, Show)
276precision :: a -> Precision a -> Maybe Int
277precision _ (Precision prec) = prec
279arbitraryPrecision :: Int -> Gen (Precision a)
280arbitraryPrecision maxDigits = Precision <$> do
281 n <- choose (-1,maxDigits)
282 return $ if n == -1
283 then Nothing
284 else Just n
286instance Arbitrary (Precision Float) where
287 arbitrary = arbitraryPrecision 11
288 shrink = map Precision . shrink . precision undefined
290instance Arbitrary (Precision Double) where
291 arbitrary = arbitraryPrecision 22
292 shrink = map Precision . shrink . precision undefined
294-- Work around lack of Show instance for TextEncoding.
295data Encoding = E String IO.TextEncoding
297instance Show Encoding where show (E n _) = "utf" ++ n
299instance Arbitrary Encoding where
300 arbitrary = oneof . map return $
301 [ E "8" IO.utf8, E "8_bom" IO.utf8_bom, E "16" IO.utf16
302 , E "16le" IO.utf16le, E "16be" IO.utf16be, E "32" IO.utf32
303 , E "32le" IO.utf32le, E "32be" IO.utf32be
304 ]
306windowsNewlineMode :: IO.NewlineMode
307windowsNewlineMode = IO.NewlineMode
308 { IO.inputNL = IO.CRLF, IO.outputNL = IO.CRLF
309 }
311instance Arbitrary IO.NewlineMode where
312 arbitrary = oneof . map return $
313 [ IO.noNewlineTranslation, IO.universalNewlineMode, IO.nativeNewlineMode
314 , windowsNewlineMode
315 ]
317instance Arbitrary IO.BufferMode where
318 arbitrary = oneof [ return IO.NoBuffering,
319 return IO.LineBuffering,
320 return (IO.BlockBuffering Nothing),
321 (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`
322 (arbitrary :: Gen Word16) ]
324-- This test harness is complex! What property are we checking?
325--
326-- Reading after writing a multi-line file should give the same
327-- results as were written.
328--
329-- What do we vary while checking this property?
330-- * The lines themselves, scrubbed to contain neither CR nor LF. (By
331-- working with a list of lines, we ensure that the data will
332-- sometimes contain line endings.)
333-- * Encoding.
334-- * Newline translation mode.
335-- * Buffering.
336write_read :: (NFData a, Eq a)
337 => ([b] -> a)
338 -> ((Char -> Bool) -> a -> b)
339 -> (IO.Handle -> a -> IO ())
340 -> (IO.Handle -> IO a)
341 -> Encoding
342 -> IO.NewlineMode
343 -> IO.BufferMode
344 -> [a]
345 -> Property
346write_read unline filt writer reader (E _ _) nl buf ts =
347 monadicIO $ assert . (==t) =<< run act
348 where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
349 act = withTempFile $ \path h -> do
350 -- hSetEncoding h enc
351 IO.hSetNewlineMode h nl
352 IO.hSetBuffering h buf
353 () <- writer h t
354 IO.hClose h
355 bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
356 -- hSetEncoding h' enc
357 IO.hSetNewlineMode h' nl
358 IO.hSetBuffering h' buf
359 r <- reader h'
360 r `deepseq` return r