git.iko.soy/text
on 09cd408 help sign in
text/tests/Tests/QuickCheckUtils.hs
369 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 , genUnicodeWith
11 , ascii
12 , plane0
13 , plane1
14 , plane2
15 , plane14
16 , planes
18 , unsquare
19 , smallArbitrary
21 , NotEmpty (..)
23 , Small (..)
24 , small
26 , integralRandomR
28 , DecodeErr (..)
29 , genDecodeErr
31 , Stringy (..)
32 , eq
33 , eqP
35 , Encoding (..)
37 , write_read
38 ) where
40import Control.Arrow (first, (***))
41import Control.DeepSeq (NFData (..), deepseq)
42import Control.Exception (bracket)
43import Data.Bits ((.&.))
44import Data.Char (chr)
45import Data.String (IsString, fromString)
46import Data.Text.Foreign (I16)
47import Data.Word (Word8, Word16)
48import Debug.Trace (trace)
49import System.Random (Random (..), RandomGen)
50import Test.QuickCheck hiding ((.&.))
51import Test.QuickCheck.Monadic (assert, monadicIO, run)
52import Tests.Utils
53import qualified Data.ByteString as B
54import qualified Data.Text as T
55import qualified Data.Text.Encoding.Error as T
56import qualified Data.Text.Internal.Fusion as TF
57import qualified Data.Text.Internal.Fusion.Common as TF
58import qualified Data.Text.Internal.Lazy as TL
59import qualified Data.Text.Internal.Lazy.Fusion as TLF
60import qualified Data.Text.Lazy as TL
61import qualified System.IO as IO
63instance Random I16 where
64 randomR = integralRandomR
65 random = randomR (minBound,maxBound)
67instance Arbitrary I16 where
68 arbitrary = arbitrarySizedIntegral
69 shrink = shrinkIntegral
71instance Arbitrary B.ByteString where
72 arbitrary = B.pack `fmap` arbitrary
73 shrink = map B.pack . shrink . B.unpack
75#if !MIN_VERSION_base(4,4,0)
76instance Random Word8 where
77 randomR = integralRandomR
78 random = randomR (minBound,maxBound)
79#endif
81genUnicode :: IsString a => Gen a
82genUnicode = genUnicodeWith planes
84genUnicodeWith :: IsString a => [Gen Int] -> Gen a
85genUnicodeWith gens = fmap fromString string
86 where
87 string = sized $ \n ->
88 do k <- choose (0,n)
89 sequence [ char | _ <- [1..k] ]
91 excluding :: [a -> Bool] -> Gen a -> Gen a
92 excluding bad gen = loop
93 where
94 loop = do
95 x <- gen
96 if or (map ($ x) bad)
97 then loop
98 else return x
100 reserved = [lowSurrogate, highSurrogate, noncharacter]
101 lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF
102 highSurrogate c = c >= 0xD800 && c <= 0xDBFF
103 noncharacter c = masked == 0xFFFE || masked == 0xFFFF
104 where
105 masked = c .&. 0xFFFF
107 char = chr `fmap` excluding reserved (oneof gens)
109ascii :: Gen Int
110ascii = choose (0,0x7F)
112plane0 :: Gen Int
113plane0 = choose (0xF0, 0xFFFF)
115plane1 :: Gen Int
116plane1 = oneof [ choose (0x10000, 0x10FFF)
117 , choose (0x11000, 0x11FFF)
118 , choose (0x12000, 0x12FFF)
119 , choose (0x13000, 0x13FFF)
120 , choose (0x1D000, 0x1DFFF)
121 , choose (0x1F000, 0x1FFFF)
122 ]
124plane2 :: Gen Int
125plane2 = oneof [ choose (0x20000, 0x20FFF)
126 , choose (0x21000, 0x21FFF)
127 , choose (0x22000, 0x22FFF)
128 , choose (0x23000, 0x23FFF)
129 , choose (0x24000, 0x24FFF)
130 , choose (0x25000, 0x25FFF)
131 , choose (0x26000, 0x26FFF)
132 , choose (0x27000, 0x27FFF)
133 , choose (0x28000, 0x28FFF)
134 , choose (0x29000, 0x29FFF)
135 , choose (0x2A000, 0x2AFFF)
136 , choose (0x2B000, 0x2BFFF)
137 , choose (0x2F000, 0x2FFFF)
138 ]
140plane14 :: Gen Int
141plane14 = choose (0xE0000, 0xE0FFF)
143planes :: [Gen Int]
144planes = [ascii, plane0, plane1, plane2, plane14]
146-- For tests that have O(n^2) running times or input sizes, resize
147-- their inputs to the square root of the originals.
148unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property
149unsquare = forAll smallArbitrary
151smallArbitrary :: (Arbitrary a, Show a) => Gen a
152smallArbitrary = sized $ \n -> resize (smallish n) arbitrary
153 where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
155instance Arbitrary T.Text where
156 arbitrary = T.pack `fmap` arbitrary
157 shrink = map T.pack . shrink . T.unpack
159instance Arbitrary TL.Text where
160 arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary
161 shrink = map TL.pack . shrink . TL.unpack
163newtype NotEmpty a = NotEmpty { notEmpty :: a }
164 deriving (Eq, Ord)
166instance Show a => Show (NotEmpty a) where
167 show (NotEmpty a) = show a
169instance Functor NotEmpty where
170 fmap f (NotEmpty a) = NotEmpty (f a)
172instance Arbitrary a => Arbitrary (NotEmpty [a]) where
173 arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
174 shrink = shrinkNotEmpty null
176instance Arbitrary (NotEmpty T.Text) where
177 arbitrary = (fmap T.pack) `fmap` arbitrary
178 shrink = shrinkNotEmpty T.null
180instance Arbitrary (NotEmpty TL.Text) where
181 arbitrary = (fmap TL.pack) `fmap` arbitrary
182 shrink = shrinkNotEmpty TL.null
184instance Arbitrary (NotEmpty B.ByteString) where
185 arbitrary = (fmap B.pack) `fmap` arbitrary
186 shrink = shrinkNotEmpty B.null
188shrinkNotEmpty :: Arbitrary a => (a -> Bool) -> NotEmpty a -> [NotEmpty a]
189shrinkNotEmpty isNull (NotEmpty xs) =
190 [ NotEmpty xs' | xs' <- shrink xs, not (isNull xs') ]
192data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7
193 | S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15
194 | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23
195 | S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31
196 deriving (Eq, Ord, Enum, Bounded)
198small :: Integral a => Small -> a
199small = fromIntegral . fromEnum
201intf :: (Int -> Int -> Int) -> Small -> Small -> Small
202intf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)
204instance Show Small where
205 show = show . fromEnum
207instance Read Small where
208 readsPrec n = map (first toEnum) . readsPrec n
210instance Num Small where
211 fromInteger = toEnum . fromIntegral
212 signum _ = 1
213 abs = id
214 (+) = intf (+)
215 (-) = intf (-)
216 (*) = intf (*)
218instance Real Small where
219 toRational = toRational . fromEnum
221instance Integral Small where
222 toInteger = toInteger . fromEnum
223 quotRem a b = (toEnum x, toEnum y)
224 where (x, y) = fromEnum a `quotRem` fromEnum b
226instance Random Small where
227 randomR = integralRandomR
228 random = randomR (minBound,maxBound)
230instance Arbitrary Small where
231 arbitrary = choose (minBound, maxBound)
232 shrink = shrinkIntegral
234integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
235integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
236 fromIntegral b :: Integer) g of
237 (x,h) -> (fromIntegral x, h)
239data DecodeErr = Lenient | Ignore | Strict | Replace
240 deriving (Show, Eq)
242genDecodeErr :: DecodeErr -> Gen T.OnDecodeError
243genDecodeErr Lenient = return T.lenientDecode
244genDecodeErr Ignore = return T.ignore
245genDecodeErr Strict = return T.strictDecode
246genDecodeErr Replace = arbitrary
248instance Arbitrary DecodeErr where
249 arbitrary = elements [Lenient, Ignore, Strict, Replace]
251class Stringy s where
252 packS :: String -> s
253 unpackS :: s -> String
254 splitAtS :: Int -> s -> (s,s)
255 packSChunkSize :: Int -> String -> s
256 packSChunkSize _ = packS
258instance Stringy String where
259 packS = id
260 unpackS = id
261 splitAtS = splitAt
263instance Stringy (TF.Stream Char) where
264 packS = TF.streamList
265 unpackS = TF.unstreamList
266 splitAtS n s = (TF.take n s, TF.drop n s)
268instance Stringy T.Text where
269 packS = T.pack
270 unpackS = T.unpack
271 splitAtS = T.splitAt
273instance Stringy TL.Text where
274 packSChunkSize k = TLF.unstreamChunks k . TF.streamList
275 packS = TL.pack
276 unpackS = TL.unpack
277 splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .
278 TL.splitAt . fromIntegral
280-- Do two functions give the same answer?
281eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
282eq a b s = a s =^= b s
284-- What about with the RHS packed?
285eqP :: (Eq a, Show a, Stringy s) =>
286 (String -> a) -> (s -> a) -> String -> Word8 -> Bool
287eqP f g s w = eql "orig" (f s) (g t) &&
288 eql "mini" (f s) (g mini) &&
289 eql "head" (f sa) (g ta) &&
290 eql "tail" (f sb) (g tb)
291 where t = packS s
292 mini = packSChunkSize 10 s
293 (sa,sb) = splitAt m s
294 (ta,tb) = splitAtS m t
295 l = length s
296 m | l == 0 = n
297 | otherwise = n `mod` l
298 n = fromIntegral w
299 eql d a b
300 | a =^= b = True
301 | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
303-- Work around lack of Show instance for TextEncoding.
304data Encoding = E String IO.TextEncoding
306instance Show Encoding where show (E n _) = "utf" ++ n
308instance Arbitrary Encoding where
309 arbitrary = oneof . map return $
310 [ E "8" IO.utf8, E "8_bom" IO.utf8_bom, E "16" IO.utf16
311 , E "16le" IO.utf16le, E "16be" IO.utf16be, E "32" IO.utf32
312 , E "32le" IO.utf32le, E "32be" IO.utf32be
313 ]
315windowsNewlineMode :: IO.NewlineMode
316windowsNewlineMode = IO.NewlineMode
317 { IO.inputNL = IO.CRLF, IO.outputNL = IO.CRLF
318 }
320instance Arbitrary IO.NewlineMode where
321 arbitrary = oneof . map return $
322 [ IO.noNewlineTranslation, IO.universalNewlineMode, IO.nativeNewlineMode
323 , windowsNewlineMode
324 ]
326instance Arbitrary IO.BufferMode where
327 arbitrary = oneof [ return IO.NoBuffering,
328 return IO.LineBuffering,
329 return (IO.BlockBuffering Nothing),
330 (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`
331 (arbitrary :: Gen Word16) ]
333-- This test harness is complex! What property are we checking?
334--
335-- Reading after writing a multi-line file should give the same
336-- results as were written.
337--
338-- What do we vary while checking this property?
339-- * The lines themselves, scrubbed to contain neither CR nor LF. (By
340-- working with a list of lines, we ensure that the data will
341-- sometimes contain line endings.)
342-- * Encoding.
343-- * Newline translation mode.
344-- * Buffering.
345write_read :: (NFData a, Eq a)
346 => ([b] -> a)
347 -> ((Char -> Bool) -> a -> b)
348 -> (IO.Handle -> a -> IO ())
349 -> (IO.Handle -> IO a)
350 -> Encoding
351 -> IO.NewlineMode
352 -> IO.BufferMode
353 -> [a]
354 -> Property
355write_read unline filt writer reader (E _ _) nl buf ts =
356 monadicIO $ assert . (==t) =<< run act
357 where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
358 act = withTempFile $ \path h -> do
359 -- hSetEncoding h enc
360 IO.hSetNewlineMode h nl
361 IO.hSetBuffering h buf
362 () <- writer h t
363 IO.hClose h
364 bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
365 -- hSetEncoding h' enc
366 IO.hSetNewlineMode h' nl
367 IO.hSetBuffering h' buf
368 r <- reader h'
369 r `deepseq` return r