test/Utils.hs

   1 {-#LANGUAGE ScopedTypeVariables#-}
   2 module Utils where
   3 import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
   4 import System.IO.Unsafe (unsafePerformIO)
   5 import Debug.Trace (trace)
   6 import Data.Bits ((.&.))
   7 import Data.Char (chr)
   8 import Data.String (IsString, fromString)
   9 import System.Random (Random (..), RandomGen)
  10 import Test.QuickCheck hiding ((.&.))
  11 import Test.QuickCheck.Monadic (assert, monadicIO, run)
  12 import qualified Data.ByteString as B
  13 import 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
  23 i =^= 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
  31 infix 4 =^=
  32 {-# NOINLINE (=^=) #-}
  33
  34 -- Do two functions give the same answer?
  35 eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
  36 eq 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
  58 instance Arbitrary B.ByteString where
  59     arbitrary     = B.pack `fmap` arbitrary
  60
  61 genUnicode :: IsString a => Gen a
  62 genUnicode = 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)