{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Data.GenValidity.Utils
  ( -- ** Helper functions for implementing generators
    upTo,
    genSplit,
    genSplit3,
    genSplit4,
    genSplit5,
    genSplit6,
    genSplit7,
    genSplit8,
    arbPartition,
    shuffle,
    genListLength,
    genListOf,
    genNonEmptyOf,

    -- ** Helper functions for implementing shrinking functions
    shrinkTuple,
    shrinkT2,
    shrinkT3,
    shrinkT4,
    genIntX,
    genWordX,
    genFloat,
    genDouble,
    genFloatX,
    genInteger,
  )
where

import Control.Monad (forM, replicateM)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Ratio
import GHC.Float (castWord32ToFloat, castWord64ToDouble)
import System.Random
import Test.QuickCheck hiding (Fixed)

-- | 'upTo' generates an integer between 0 (inclusive) and 'n'.
upTo :: Int -> Gen Int
upTo :: Int -> Gen Int
upTo Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> Gen Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
  | Bool
otherwise = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)

-- | 'genSplit a' generates a tuple '(b, c)' such that 'b + c' equals 'a'.
genSplit :: Int -> Gen (Int, Int)
genSplit :: Int -> Gen (Int, Int)
genSplit Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int) -> Gen (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0)
  | Bool
otherwise = do
    Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
    let j :: Int
j = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
    (Int, Int) -> Gen (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, Int
j)

-- | 'genSplit3 a' generates a triple '(b, c, d)' such that 'b + c + d' equals 'a'.
genSplit3 :: Int -> Gen (Int, Int, Int)
genSplit3 :: Int -> Gen (Int, Int, Int)
genSplit3 Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int, Int) -> Gen (Int, Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0, Int
0)
  | Bool
otherwise = do
    (Int
a, Int
z) <- Int -> Gen (Int, Int)
genSplit Int
n
    (Int
b, Int
c) <- Int -> Gen (Int, Int)
genSplit Int
z
    (Int, Int, Int) -> Gen (Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a, Int
b, Int
c)

-- | 'genSplit4 a' generates a quadruple '(b, c, d, e)' such that 'b + c + d + e' equals 'a'.
genSplit4 :: Int -> Gen (Int, Int, Int, Int)
genSplit4 :: Int -> Gen (Int, Int, Int, Int)
genSplit4 Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int, Int, Int) -> Gen (Int, Int, Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0, Int
0, Int
0)
  | Bool
otherwise = do
    (Int
y, Int
z) <- Int -> Gen (Int, Int)
genSplit Int
n
    (Int
a, Int
b) <- Int -> Gen (Int, Int)
genSplit Int
y
    (Int
c, Int
d) <- Int -> Gen (Int, Int)
genSplit Int
z
    (Int, Int, Int, Int) -> Gen (Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a, Int
b, Int
c, Int
d)

-- | 'genSplit5 a' generates a quintuple '(b, c, d, e, f)' such that 'b + c + d + e + f' equals 'a'.
genSplit5 :: Int -> Gen (Int, Int, Int, Int, Int)
genSplit5 :: Int -> Gen (Int, Int, Int, Int, Int)
genSplit5 Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int, Int, Int, Int) -> Gen (Int, Int, Int, Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0, Int
0, Int
0, Int
0)
  | Bool
otherwise = do
    (Int
y, Int
z) <- Int -> Gen (Int, Int)
genSplit Int
n
    (Int
a, Int
b, Int
c) <- Int -> Gen (Int, Int, Int)
genSplit3 Int
y
    (Int
d, Int
e) <- Int -> Gen (Int, Int)
genSplit Int
z
    (Int, Int, Int, Int, Int) -> Gen (Int, Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a, Int
b, Int
c, Int
d, Int
e)

-- | 'genSplit6 a' generates a sextuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'.
genSplit6 :: Int -> Gen (Int, Int, Int, Int, Int, Int)
genSplit6 :: Int -> Gen (Int, Int, Int, Int, Int, Int)
genSplit6 Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int, Int, Int, Int, Int)
-> Gen (Int, Int, Int, Int, Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0, Int
0, Int
0, Int
0, Int
0)
  | Bool
otherwise = do
    (Int
y, Int
z) <- Int -> Gen (Int, Int)
genSplit Int
n
    (Int
a, Int
b, Int
c) <- Int -> Gen (Int, Int, Int)
genSplit3 Int
y
    (Int
d, Int
e, Int
f) <- Int -> Gen (Int, Int, Int)
genSplit3 Int
z
    (Int, Int, Int, Int, Int, Int)
-> Gen (Int, Int, Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a, Int
b, Int
c, Int
d, Int
e, Int
f)

-- | 'genSplit7 a' generates a septtuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'.
genSplit7 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int)
genSplit7 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int)
genSplit7 Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int, Int, Int, Int, Int, Int)
-> Gen (Int, Int, Int, Int, Int, Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0)
  | Bool
otherwise = do
    (Int
y, Int
z) <- Int -> Gen (Int, Int)
genSplit Int
n
    (Int
a, Int
b, Int
c) <- Int -> Gen (Int, Int, Int)
genSplit3 Int
y
    (Int
d, Int
e, Int
f, Int
g) <- Int -> Gen (Int, Int, Int, Int)
genSplit4 Int
z
    (Int, Int, Int, Int, Int, Int, Int)
-> Gen (Int, Int, Int, Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a, Int
b, Int
c, Int
d, Int
e, Int
f, Int
g)

-- | 'genSplit8 a' generates a octtuple '(b, c, d, e, f, g, h)' such that 'b + c + d + e + f + g + h' equals 'a'.
genSplit8 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int, Int)
genSplit8 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int, Int)
genSplit8 Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (Int, Int, Int, Int, Int, Int, Int, Int)
-> Gen (Int, Int, Int, Int, Int, Int, Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0)
  | Bool
otherwise = do
    (Int
y, Int
z) <- Int -> Gen (Int, Int)
genSplit Int
n
    (Int
a, Int
b, Int
c, Int
d) <- Int -> Gen (Int, Int, Int, Int)
genSplit4 Int
y
    (Int
e, Int
f, Int
g, Int
h) <- Int -> Gen (Int, Int, Int, Int)
genSplit4 Int
z
    (Int, Int, Int, Int, Int, Int, Int, Int)
-> Gen (Int, Int, Int, Int, Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
a, Int
b, Int
c, Int
d, Int
e, Int
f, Int
g, Int
h)

-- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n', approximately.
arbPartition :: Int -> Gen [Int]
arbPartition :: Int -> Gen [Int]
arbPartition Int
0 = [Int] -> Gen [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
arbPartition Int
i = Int -> Gen Int
genListLengthWithSize Int
i Gen Int -> (Int -> Gen [Int]) -> Gen [Int]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> Gen [Int]
go Int
i
  where
    go :: Int -> Int -> Gen [Int]
    go :: Int -> Int -> Gen [Int]
go Int
size Int
len = do
      [Double]
us <- Int -> Gen Double -> Gen [Double]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len (Gen Double -> Gen [Double]) -> Gen Double -> Gen [Double]
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
1)
      let invs :: [Double]
invs = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double
invE Double
0.25) [Double]
us
      -- Rescale the sizes to (approximately) sum to the given size.
      [Int] -> Gen [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> Gen [Int]) -> [Int] -> Gen [Int]
forall a b. (a -> b) -> a -> b
$ (Double -> Int) -> [Double] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> (Double -> Double) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
invs))) [Double]
invs

    -- Use an exponential distribution for generating the
    -- sizes in the partition.
    invE :: Double -> Double -> Double
    invE :: Double -> Double -> Double
invE Double
lambda Double
u = (- Double -> Double
forall a. Floating a => a -> a
log (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
u)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lambda

genNonEmptyOf :: Gen a -> Gen (NonEmpty a)
genNonEmptyOf :: Gen a -> Gen (NonEmpty a)
genNonEmptyOf Gen a
gen = do
  [a]
l <- Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
genListOf Gen a
gen
  case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
l of
    Maybe (NonEmpty a)
Nothing -> (Int -> Int) -> Gen (NonEmpty a) -> Gen (NonEmpty a)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Gen (NonEmpty a) -> Gen (NonEmpty a))
-> Gen (NonEmpty a) -> Gen (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ Gen a -> Gen (NonEmpty a)
forall a. Gen a -> Gen (NonEmpty a)
genNonEmptyOf Gen a
gen
    Just NonEmpty a
ne -> NonEmpty a -> Gen (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty a
ne

-- Uses 'genListLengthWithSize' with the size parameter
genListLength :: Gen Int
genListLength :: Gen Int
genListLength = (Int -> Gen Int) -> Gen Int
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen Int
genListLengthWithSize

-- Generate a list length with the given size
genListLengthWithSize :: Int -> Gen Int
genListLengthWithSize :: Int -> Gen Int
genListLengthWithSize Int
maxLen = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> (Double -> Double) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
invT (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxLen) (Double -> Int) -> Gen Double -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
1)
  where
    -- Use a triangle distribution for generating the
    -- length of the list
    -- with minimum length '0', mode length '2'
    -- and given max length.
    invT :: Double -> Double -> Double
    invT :: Double -> Double -> Double
invT Double
m Double
u =
      let a :: Double
a = Double
0
          b :: Double
b = Double
m
          c :: Double
c = Double
2
          fc :: Double
fc = (Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a)
       in if Double
u Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
fc
            then Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Floating a => a -> a
sqrt (Double
u Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a))
            else Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
forall a. Floating a => a -> a
sqrt ((Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
u) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
c))

-- | A version of @listOf@ that takes size into account more accurately.
--
-- This generator distributes the size that is is given among the values
-- in the list that it generates.
genListOf :: Gen a -> Gen [a]
genListOf :: Gen a -> Gen [a]
genListOf Gen a
func =
  (Int -> Gen [a]) -> Gen [a]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [a]) -> Gen [a]) -> (Int -> Gen [a]) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
    [Int]
pars <- Int -> Gen [Int]
arbPartition Int
n
    [Int] -> (Int -> Gen a) -> Gen [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
pars ((Int -> Gen a) -> Gen [a]) -> (Int -> Gen a) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \Int
i -> Int -> Gen a -> Gen a
forall a. Int -> Gen a -> Gen a
resize Int
i Gen a
func

shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
shrinkTuple a -> [a]
sa b -> [b]
sb (a
a, b
b) =
  ((,) (a -> b -> (a, b)) -> [a] -> [b -> (a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
sa a
a [b -> (a, b)] -> [b] -> [(a, b)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> [b]
sb b
b)
    [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++ [(a
a', b
b) | a
a' <- a -> [a]
sa a
a]
    [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++ [(a
a, b
b') | b
b' <- b -> [b]
sb b
b]

-- | Turn a shrinking function into a function that shrinks tuples.
shrinkT2 :: (a -> [a]) -> (a, a) -> [(a, a)]
shrinkT2 :: (a -> [a]) -> (a, a) -> [(a, a)]
shrinkT2 a -> [a]
s (a
a, a
b) = (,) (a -> a -> (a, a)) -> [a] -> [a -> (a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
s a
a [a -> (a, a)] -> [a] -> [(a, a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> [a]
s a
b

-- | Turn a shrinking function into a function that shrinks triples.
shrinkT3 :: (a -> [a]) -> (a, a, a) -> [(a, a, a)]
shrinkT3 :: (a -> [a]) -> (a, a, a) -> [(a, a, a)]
shrinkT3 a -> [a]
s (a
a, a
b, a
c) = (,,) (a -> a -> a -> (a, a, a)) -> [a] -> [a -> a -> (a, a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
s a
a [a -> a -> (a, a, a)] -> [a] -> [a -> (a, a, a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> [a]
s a
b [a -> (a, a, a)] -> [a] -> [(a, a, a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> [a]
s a
c

-- | Turn a shrinking function into a function that shrinks quadruples.
shrinkT4 :: (a -> [a]) -> (a, a, a, a) -> [(a, a, a, a)]
shrinkT4 :: (a -> [a]) -> (a, a, a, a) -> [(a, a, a, a)]
shrinkT4 a -> [a]
s (a
a, a
b, a
c, a
d) = (,,,) (a -> a -> a -> a -> (a, a, a, a))
-> [a] -> [a -> a -> a -> (a, a, a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
s a
a [a -> a -> a -> (a, a, a, a)] -> [a] -> [a -> a -> (a, a, a, a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> [a]
s a
b [a -> a -> (a, a, a, a)] -> [a] -> [a -> (a, a, a, a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> [a]
s a
c [a -> (a, a, a, a)] -> [a] -> [(a, a, a, a)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> [a]
s a
d

-- | Generate Int, Int8, Int16, Int32 and Int64 values smartly.
--
-- * Some at the border
-- * Some around zero
-- * Mostly uniformly
genIntX :: forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX :: Gen a
genIntX =
  [(Int, Gen a)] -> Gen a
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Gen a
extreme),
      (Int
1, Gen a
small),
      (Int
8, Gen a
uniformInt)
    ]
  where
    extreme :: Gen a
    extreme :: Gen a
extreme = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen a) -> Gen a) -> (Int -> Gen a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \Int
s ->
      [Gen a] -> Gen a
forall a. [Gen a] -> Gen a
oneof
        [ (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
forall a. Bounded a => a
maxBound a -> a -> a
forall a. Num a => a -> a -> a
- Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s, a
forall a. Bounded a => a
maxBound),
          (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
forall a. Bounded a => a
minBound, a
forall a. Bounded a => a
minBound a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s)
        ]
    small :: Gen a
    small :: Gen a
small = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen a) -> Gen a) -> (Int -> Gen a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \Int
s -> (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (- Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s, Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s)
    uniformInt :: Gen a
    uniformInt :: Gen a
uniformInt = (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
forall a. Bounded a => a
minBound, a
forall a. Bounded a => a
maxBound)

-- | Generate Word, Word8, Word16, Word32 and Word64 values smartly.
--
-- * Some at the border
-- * Some around zero
-- * Mostly uniformly
genWordX :: forall a. (Integral a, Bounded a, Random a) => Gen a
genWordX :: Gen a
genWordX =
  [(Int, Gen a)] -> Gen a
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Gen a
extreme),
      (Int
1, Gen a
small),
      (Int
8, Gen a
uniformWord)
    ]
  where
    extreme :: Gen a
    extreme :: Gen a
extreme = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen a) -> Gen a) -> (Int -> Gen a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \Int
s ->
      (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
forall a. Bounded a => a
maxBound a -> a -> a
forall a. Num a => a -> a -> a
- Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s, a
forall a. Bounded a => a
maxBound)
    small :: Gen a
    small :: Gen a
small = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen a) -> Gen a) -> (Int -> Gen a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \Int
s -> (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
0, Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s)
    uniformWord :: Gen a
    uniformWord :: Gen a
uniformWord = (a, a) -> Gen a
forall a. Random a => (a, a) -> Gen a
choose (a
forall a. Bounded a => a
minBound, a
forall a. Bounded a => a
maxBound)

-- | See 'genFloatX'
genFloat :: Gen Float
genFloat :: Gen Float
genFloat = (Word32 -> Float) -> Gen Float
forall a w.
(Read a, RealFloat a, Bounded w, Random w) =>
(w -> a) -> Gen a
genFloatX Word32 -> Float
castWord32ToFloat

-- | See 'genFloatX'
genDouble :: Gen Double
genDouble :: Gen Double
genDouble = (Word64 -> Double) -> Gen Double
forall a w.
(Read a, RealFloat a, Bounded w, Random w) =>
(w -> a) -> Gen a
genFloatX Word64 -> Double
castWord64ToDouble

-- | Generate floating point numbers smartly:
--
-- * Some denormalised
-- * Some around zero
-- * Some around the bounds
-- * Some by encoding an Integer and an Int to a floating point number.
-- * Some accross the entire range
-- * Mostly uniformly via the bitrepresentation
--
-- The function parameter is to go from the bitrepresentation to the floating point value.
genFloatX ::
  forall a w.
  (Read a, RealFloat a, Bounded w, Random w) =>
  (w -> a) ->
  Gen a
genFloatX :: (w -> a) -> Gen a
genFloatX w -> a
func =
  [(Int, Gen a)] -> Gen a
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Gen a
denormalised),
      (Int
1, Gen a
small),
      (Int
1, Gen a
aroundBounds),
      (Int
1, Gen a
uniformViaEncoding),
      (Int
6, Gen a
reallyUniform)
    ]
  where
    denormalised :: Gen a
    denormalised :: Gen a
denormalised =
      [a] -> Gen a
forall a. [a] -> Gen a
elements
        [ String -> a
forall a. Read a => String -> a
read String
"NaN",
          String -> a
forall a. Read a => String -> a
read String
"Infinity",
          String -> a
forall a. Read a => String -> a
read String
"-Infinity",
          String -> a
forall a. Read a => String -> a
read String
"-0"
        ]
    -- This is what Quickcheck does,
    -- but inlined so QuickCheck cannot change
    -- it behind the scenes in the future.
    small :: Gen a
    small :: Gen a
small = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen a) -> Gen a) -> (Int -> Gen a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
      let n' :: Integer
n' = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n
      let precision :: Integer
precision = Integer
9999999999999 :: Integer
      Integer
b <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
precision)
      Integer
a <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose ((- Integer
n') Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b, Integer
n' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b)
      a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rational -> a
forall a. Fractional a => Rational -> a
fromRational (Integer
a Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
b))
    upperSignificand :: Integer
    upperSignificand :: Integer
upperSignificand = a -> Integer
forall a. RealFloat a => a -> Integer
floatRadix (a
0.0 :: a) Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ a -> Int
forall a. RealFloat a => a -> Int
floatDigits (a
0.0 :: a)
    lowerSignificand :: Integer
    lowerSignificand :: Integer
lowerSignificand = (- Integer
upperSignificand)
    (Int
lowerExponent, Int
upperExponent) = a -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange (a
0.0 :: a)
    aroundBounds :: Gen a
    aroundBounds :: Gen a
aroundBounds = do
      Integer
s <- (Int -> Gen Integer) -> Gen Integer
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Integer) -> Gen Integer)
-> (Int -> Gen Integer) -> Gen Integer
forall a b. (a -> b) -> a -> b
$ \Int
n ->
        [Gen Integer] -> Gen Integer
forall a. [Gen a] -> Gen a
oneof
          [ (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
lowerSignificand, Integer
lowerSignificand Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n),
            (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
upperSignificand Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, Integer
upperSignificand)
          ]
      Int
e <- (Int -> Gen Int) -> Gen Int
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Int) -> Gen Int) -> (Int -> Gen Int) -> Gen Int
forall a b. (a -> b) -> a -> b
$ \Int
n ->
        [Gen Int] -> Gen Int
forall a. [Gen a] -> Gen a
oneof
          [ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
lowerExponent, Int
lowerExponent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n),
            (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
upperExponent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n, Int
upperExponent)
          ]
      a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Gen a) -> a -> Gen a
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
s Int
e
    uniformViaEncoding :: Gen a
    uniformViaEncoding :: Gen a
uniformViaEncoding = do
      Integer
s <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
lowerSignificand, Integer
upperSignificand)
      Int
e <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose ((Int, Int) -> Gen Int) -> (Int, Int) -> Gen Int
forall a b. (a -> b) -> a -> b
$ a -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange (a
0.0 :: a)
      a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Gen a) -> a -> Gen a
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
s Int
e
    -- Not really uniform, but good enough
    reallyUniform :: Gen a
    reallyUniform :: Gen a
reallyUniform = w -> a
func (w -> a) -> Gen w -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (w, w) -> Gen w
forall a. Random a => (a, a) -> Gen a
choose (w
forall a. Bounded a => a
minBound, w
forall a. Bounded a => a
maxBound)

genInteger :: Gen Integer
genInteger :: Gen Integer
genInteger = (Int -> Gen Integer) -> Gen Integer
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Integer) -> Gen Integer)
-> (Int -> Gen Integer) -> Gen Integer
forall a b. (a -> b) -> a -> b
$ \Int
s ->
  [Gen Integer] -> Gen Integer
forall a. [Gen a] -> Gen a
oneof ([Gen Integer] -> Gen Integer) -> [Gen Integer] -> Gen Integer
forall a b. (a -> b) -> a -> b
$
    (if Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 then (Gen Integer
genBiggerInteger Gen Integer -> [Gen Integer] -> [Gen Integer]
forall a. a -> [a] -> [a]
:) else [Gen Integer] -> [Gen Integer]
forall a. a -> a
id)
      [ Gen Integer
genIntSizedInteger,
        Gen Integer
small
      ]
  where
    small :: Gen Integer
small = (Int -> Gen Integer) -> Gen Integer
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Integer) -> Gen Integer)
-> (Int -> Gen Integer) -> Gen Integer
forall a b. (a -> b) -> a -> b
$ \Int
s -> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (- Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
s, Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
s)
    genIntSizedInteger :: Gen Integer
genIntSizedInteger = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Gen Int -> Gen Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Int
forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX :: Gen Int)
    genBiggerInteger :: Gen Integer
genBiggerInteger = (Int -> Gen Integer) -> Gen Integer
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen Integer) -> Gen Integer)
-> (Int -> Gen Integer) -> Gen Integer
forall a b. (a -> b) -> a -> b
$ \Int
s -> do
      (Int
a, Int
b, Int
c) <- Int -> Gen (Int, Int, Int)
genSplit3 Int
s
      Integer
ai <- Int -> Gen Integer -> Gen Integer
forall a. Int -> Gen a -> Gen a
resize Int
a Gen Integer
genIntSizedInteger
      Integer
bi <- Int -> Gen Integer -> Gen Integer
forall a. Int -> Gen a -> Gen a
resize Int
b Gen Integer
genInteger
      Integer
ci <- Int -> Gen Integer -> Gen Integer
forall a. Int -> Gen a -> Gen a
resize Int
c Gen Integer
genIntSizedInteger
      Integer -> Gen Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Gen Integer) -> Integer -> Gen Integer
forall a b. (a -> b) -> a -> b
$ Integer
ai Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
bi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
ci