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