1 {-# LANGUAGE FlexibleInstances #-}
    2 
    3 module QuickCheckUtils where
    4 
    5 import Control.Arrow (first)
    6 import Data.Char (chr)
    7 import Data.Bits ((.&.))
    8 import Data.Int (Int64)
    9 import Data.Word (Word8, Word16, Word32)
   10 import Data.String (IsString, fromString)
   11 import qualified Data.Text as T
   12 import qualified Data.Text.Lazy as TL
   13 import System.Random (Random(..), RandomGen)
   14 import Test.QuickCheck hiding ((.&.))
   15 import qualified Data.ByteString as B
   16 
   17 instance Random Int64 where
   18     -- entered 100 timesrandomR = integralRandomR
   19     -- never enteredrandom  = randomR (minBound,maxBound)
   20 
   21 instance Arbitrary Int64 where
   22     -- entered oncearbitrary     = choose (minBound,maxBound)
   23 
   24 instance Random Word8 where
   25     -- entered 22,592 timesrandomR = integralRandomR
   26     -- never enteredrandom  = randomR (minBound,maxBound)
   27 
   28 instance Arbitrary Word8 where
   29     -- entered oncearbitrary     = choose (minBound,maxBound)
   30 
   31 instance Arbitrary B.ByteString where
   32     -- entered oncearbitrary     = B.pack `fmap` arbitrary
   33 
   34 instance Random Word16 where
   35     -- entered 895 timesrandomR = integralRandomR
   36     -- never enteredrandom  = randomR (minBound,maxBound)
   37 
   38 instance Arbitrary Word16 where
   39     -- entered oncearbitrary     = choose (minBound,maxBound)
   40 
   41 instance Random Word32 where
   42     -- entered 200 timesrandomR = integralRandomR
   43     -- never enteredrandom  = randomR (minBound,maxBound)
   44 
   45 instance Arbitrary Word32 where
   46     -- entered oncearbitrary     = choose (minBound,maxBound)
   47 
   48 genUnicode :: IsString a => Gen a
   49 -- entered 1000 timesgenUnicode = fmap fromString string where
   50     string = sized $ \n ->
   51         do k <- choose (0,n)
   52            sequence [ char | _ <- [1..k] ]
   53     
   54     excluding :: [a -> Bool] -> Gen a -> Gen a
   55     excluding bad gen = loop
   56       where
   57         loop = do
   58           x <- gen
   59           if or (map ($ x) bad)
   60             then loop
   61             else return x
   62     
   63     reserved = [lowSurrogate, highSurrogate, noncharacter]
   64     lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF
   65     highSurrogate c = c >= 0xD800 && c <= 0xDBFF
   66     noncharacter c = masked == 0xFFFE || masked == 0xFFFF
   67       where
   68         masked = c .&. 0xFFFF 
   69     
   70     ascii = choose (0,0x7F)
   71     plane0 = choose (0xF0, 0xFFFF)
   72     plane1 = oneof [ choose (0x10000, 0x10FFF)
   73                    , choose (0x11000, 0x11FFF)
   74                    , choose (0x12000, 0x12FFF)
   75                    , choose (0x13000, 0x13FFF)
   76                    , choose (0x1D000, 0x1DFFF)
   77                    , choose (0x1F000, 0x1FFFF)
   78                    ]
   79     plane2 = oneof [ choose (0x20000, 0x20FFF)
   80                    , choose (0x21000, 0x21FFF)
   81                    , choose (0x22000, 0x22FFF)
   82                    , choose (0x23000, 0x23FFF)
   83                    , choose (0x24000, 0x24FFF)
   84                    , choose (0x25000, 0x25FFF)
   85                    , choose (0x26000, 0x26FFF)
   86                    , choose (0x27000, 0x27FFF)
   87                    , choose (0x28000, 0x28FFF)
   88                    , choose (0x29000, 0x29FFF)
   89                    , choose (0x2A000, 0x2AFFF)
   90                    , choose (0x2B000, 0x2BFFF)
   91                    , choose (0x2F000, 0x2FFFF)
   92                    ]
   93     plane14 = choose (0xE0000, 0xE0FFF)
   94     planes = [ascii, plane0, plane1, plane2, plane14]
   95     
   96     char = chr `fmap` excluding reserved (oneof planes)
   97 
   98 -- For tests that have O(n^2) running times or input sizes, resize
   99 -- their inputs to the square root of the originals.
  100 unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property
  101 -- entered 500 timesunsquare = forAll smallArbitrary
  102 
  103 smallArbitrary :: (Arbitrary a, Show a) => Gen a
  104 -- entered 501 timessmallArbitrary = sized $ \n -> resize (smallish n) arbitrary
  105   where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
  106 
  107 instance Arbitrary T.Text where
  108     -- entered oncearbitrary = T.pack `fmap` arbitrary
  109 
  110 instance Arbitrary TL.Text where
  111     -- entered oncearbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary
  112 
  113 newtype NotEmpty a = NotEmpty { notEmpty :: a }
  114     deriving (Eq, Ord)
  115 
  116 instance Show a => Show (NotEmpty a) where
  117     -- never enteredshow (NotEmpty a) = show a
  118 
  119 instance Functor NotEmpty where
  120     -- entered 26,453 timesfmap f (NotEmpty a) = NotEmpty (f a)
  121 
  122 instance Arbitrary a => Arbitrary (NotEmpty [a]) where
  123     -- entered 26,453 timesarbitrary   = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
  124 
  125 instance Arbitrary (NotEmpty T.Text) where
  126     -- entered oncearbitrary   = (fmap T.pack) `fmap` arbitrary
  127 
  128 instance Arbitrary (NotEmpty TL.Text) where
  129     -- entered oncearbitrary   = (fmap TL.pack) `fmap` arbitrary
  130 
  131 instance Arbitrary (NotEmpty B.ByteString) where
  132     -- never enteredarbitrary   = (fmap B.pack) `fmap` arbitrary
  133 
  134 data Small = S0  | S1  | S2  | S3  | S4  | S5  | S6  | S7
  135            | S8  | S9  | S10 | S11 | S12 | S13 | S14 | S15
  136            | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23
  137            | S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31
  138     deriving (-- never entered-- never enteredEq, -- never enteredOrd, -- never entered-- never entered-- entered 500 times-- entered 5072 times-- never entered-- never enteredEnum, -- entered once-- entered onceBounded)
  139 
  140 small :: Small -> Int
  141 -- entered 4072 timessmall = fromEnum
  142 
  143 -- never enteredintf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)
  144 
  145 instance Show Small where
  146     -- never enteredshow = show . fromEnum
  147 
  148 instance Read Small where
  149     -- never enteredreadsPrec n = map (first toEnum) . readsPrec n
  150 
  151 instance Num Small where
  152     -- entered oncefromInteger = toEnum . fromIntegral
  153     -- never enteredsignum _ = 1
  154     -- never enteredabs = id
  155     -- never entered(+) = intf (+)
  156     -- never entered(-) = intf (-)
  157     -- never entered(*) = intf (*)
  158 
  159 instance Real Small where
  160     -- never enteredtoRational = toRational . fromEnum
  161 
  162 instance Integral Small where
  163     -- entered oncetoInteger = toInteger . fromEnum
  164     -- never enteredquotRem a b = (toEnum x, toEnum y)
  165         where (x, y) = fromEnum a `quotRem` fromEnum b
  166 
  167 instance Random Small where
  168     -- entered 500 timesrandomR = integralRandomR
  169     -- never enteredrandom  = randomR (minBound,maxBound)
  170 
  171 instance Arbitrary Small where
  172     -- entered oncearbitrary     = choose (minBound,maxBound)
  173 
  174 integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
  175 -- entered 24,287 timesintegralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,
  176                                          fromIntegral b :: Integer) g of
  177                             (x,h) -> (fromIntegral x, h)