]> git.immae.eu Git - github/fretlink/text-pipes.git/blame - test/Utils.hs
more travis
[github/fretlink/text-pipes.git] / test / Utils.hs
CommitLineData
8c482809 1{-#LANGUAGE ScopedTypeVariables#-}
2module Utils where
3import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
4import System.IO.Unsafe (unsafePerformIO)
5import Debug.Trace (trace)
6import Data.Bits ((.&.))
7import Data.Char (chr)
8import Data.String (IsString, fromString)
9import System.Random (Random (..), RandomGen)
10import Test.QuickCheck hiding ((.&.))
11import Test.QuickCheck.Monadic (assert, monadicIO, run)
12import qualified Data.ByteString as B
13import Pipes.Text.Internal
14
15
16
17
18
19-- Ensure that two potentially bottom values (in the sense of crashing
20-- for some inputs, not looping infinitely) either both crash, or both
21-- give comparable results for some input.
22(=^=) :: (Eq a, Show a) => a -> a -> Bool
23i =^= j = unsafePerformIO $ do
24 x <- try (evaluate i)
25 y <- try (evaluate j)
26 case (x,y) of
27 (Left (_ :: SomeException), Left (_ :: SomeException))
28 -> return True
29 (Right a, Right b) -> return (a == b)
30 e -> trace ("*** Divergence: " ++ show e) return False
31infix 4 =^=
32{-# NOINLINE (=^=) #-}
33
34-- Do two functions give the same answer?
35eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
36eq a b s = a s =^= b s
37
38-- What about with the RHS packed?
39-- eqP :: (Eq a, Show a, Stringy s) =>
40-- (String -> a) -> (s -> a) -> String -> Word8 -> Bool
41-- eqP f g s w = eql "orig" (f s) (g t) &&
42-- eql "mini" (f s) (g mini) &&
43-- eql "head" (f sa) (g ta) &&
44-- eql "tail" (f sb) (g tb)
45-- where t = packS s
46-- mini = packSChunkSize 10 s
47-- (sa,sb) = splitAt m s
48-- (ta,tb) = splitAtS m t
49-- l = length s
50-- m | l == 0 = n
51-- | otherwise = n `mod` l
52-- n = fromIntegral w
53-- eql d a b
54-- | a =^= b = True
55-- | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
56
57
58instance Arbitrary B.ByteString where
59 arbitrary = B.pack `fmap` arbitrary
60
61genUnicode :: IsString a => Gen a
62genUnicode = fmap fromString string where
63 string = sized $ \n ->
64 do k <- choose (0,n)
65 sequence [ char | _ <- [1..k] ]
66
67 excluding :: [a -> Bool] -> Gen a -> Gen a
68 excluding bad gen = loop
69 where
70 loop = do
71 x <- gen
72 if or (map ($ x) bad)
73 then loop
74 else return x
75
76 reserved = [lowSurrogate, highSurrogate, noncharacter]
77 lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF
78 highSurrogate c = c >= 0xD800 && c <= 0xDBFF
79 noncharacter c = masked == 0xFFFE || masked == 0xFFFF
80 where
81 masked = c .&. 0xFFFF
82
83 ascii = choose (0,0x7F)
84 plane0 = choose (0xF0, 0xFFFF)
85 plane1 = oneof [ choose (0x10000, 0x10FFF)
86 , choose (0x11000, 0x11FFF)
87 , choose (0x12000, 0x12FFF)
88 , choose (0x13000, 0x13FFF)
89 , choose (0x1D000, 0x1DFFF)
90 , choose (0x1F000, 0x1FFFF)
91 ]
92 plane2 = oneof [ choose (0x20000, 0x20FFF)
93 , choose (0x21000, 0x21FFF)
94 , choose (0x22000, 0x22FFF)
95 , choose (0x23000, 0x23FFF)
96 , choose (0x24000, 0x24FFF)
97 , choose (0x25000, 0x25FFF)
98 , choose (0x26000, 0x26FFF)
99 , choose (0x27000, 0x27FFF)
100 , choose (0x28000, 0x28FFF)
101 , choose (0x29000, 0x29FFF)
102 , choose (0x2A000, 0x2AFFF)
103 , choose (0x2B000, 0x2BFFF)
104 , choose (0x2F000, 0x2FFFF)
105 ]
106 plane14 = choose (0xE0000, 0xE0FFF)
107 planes = [ascii, plane0, plane1, plane2, plane14]
108
109 char = chr `fmap` excluding reserved (oneof planes)