-- editorconfig-checker-disable
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE TypeApplications  #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module PlutusCore.Generators.QuickCheck.Builtin where

import PlutusPrelude

import PlutusCore hiding (Constr)
import PlutusCore.Builtin
import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1
import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2
import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing
import PlutusCore.Data
import PlutusCore.Generators.QuickCheck.GenerateKinds ()
import PlutusCore.Generators.QuickCheck.Split (multiSplit0, multiSplit1, multiSplit1In)

import Data.ByteString (ByteString, empty)
import Data.Int
import Data.Kind qualified as GHC
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Test.QuickCheck
import Test.QuickCheck.Instances.ByteString ()
import Universe

-- | Same as 'Arbitrary' but specifically for Plutus built-in types, so that we are not tied to
-- the default implementation of the methods for a built-in type.
class ArbitraryBuiltin a where
    arbitraryBuiltin :: Gen a
    default arbitraryBuiltin :: Arbitrary a => Gen a
    arbitraryBuiltin = Gen a
forall a. Arbitrary a => Gen a
arbitrary

    shrinkBuiltin :: a -> [a]
    default shrinkBuiltin :: Arbitrary a => a -> [a]
    shrinkBuiltin = a -> [a]
forall a. Arbitrary a => a -> [a]
shrink

instance ArbitraryBuiltin ()
instance ArbitraryBuiltin Bool

{- Note [QuickCheck and integral types]
The 'Arbitrary' instances for 'Integer' and 'Int' only generate small integers:

    >>> :set -XTypeApplications
    >>> fmap (any ((> 30) . abs) . concat . concat . concat) . sample' $ arbitrary @[[[Integer]]]
    False
    >>> fmap (any ((> 30) . abs) . concat . concat . concat) . sample' $ arbitrary @[[[Int]]]
    False

We want to generate larger ones, including converted-to-Integer 'minBound' and 'maxBound' of various
integral types. Hence we declare 'nextInterestingBound' and 'highInterestingBound' to specify the
"interesting" ranges to generate positive integers within. We also make it likely to hit either end
of each of those ranges.
-}

-- See Note [QuickCheck and integral types].
nextInterestingBound :: Integer -> Integer
nextInterestingBound :: Integer -> Integer
nextInterestingBound Integer
1 = Integer
127
nextInterestingBound Integer
x = (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
2 :: Int) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

-- See Note [QuickCheck and integral types].
highInterestingBound :: Integer
highInterestingBound :: Integer
highInterestingBound = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
16

-- | A list of ranges.
--
-- >>> import Data.Int
-- >>> magnitudesPositive (* 10) (toInteger (maxBound :: Int16))
-- [(1,10),(11,100),(101,1000),(1001,10000),(10001,32767)]
-- >>> magnitudesPositive nextInterestingBound (toInteger (maxBound :: Int64))
-- [(1,127),(128,32767),(32768,2147483647),(2147483648,9223372036854775807)]
magnitudesPositive :: (Integer -> Integer) -> Integer -> [(Integer, Integer)]
magnitudesPositive :: (Integer -> Integer) -> Integer -> [(Integer, Integer)]
magnitudesPositive Integer -> Integer
next Integer
high =
    (Integer -> Integer -> (Integer, Integer))
-> [Integer] -> [Integer] -> [(Integer, Integer)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Integer
lo Integer
hi -> (Integer
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, Integer
hi)) [Integer]
borders ([Integer] -> [Integer]
forall a. HasCallStack => [a] -> [a]
tail [Integer]
borders)
  where
    preborders :: [Integer]
preborders = [Integer] -> [Integer]
forall a. HasCallStack => [a] -> [a]
tail ([Integer] -> [Integer])
-> ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Integer
x -> Integer -> Integer
next Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
high) ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer) -> Integer -> [Integer]
forall a. (a -> a) -> a -> [a]
iterate Integer -> Integer
next Integer
1
    borders :: [Integer]
borders = Integer
0 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
preborders [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ [Integer -> Integer
next (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall a. HasCallStack => [a] -> a
last [Integer]
preborders, Integer
high]

chooseIntegerPreferEnds :: (Integer, Integer) -> Gen Integer
chooseIntegerPreferEnds :: (Integer, Integer) -> Gen Integer
chooseIntegerPreferEnds (Integer
lo, Integer
hi)
    | Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
lo Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
20 = (Integer, Integer) -> Gen Integer
chooseInteger (Integer
lo, Integer
hi)
    | Bool
otherwise    = [(Int, Gen Integer)] -> Gen Integer
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen Integer)] -> Gen Integer)
-> [(Int, Gen Integer)] -> Gen Integer
forall a b. (a -> b) -> a -> b
$ [[(Int, Gen Integer)]] -> [(Int, Gen Integer)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Int] -> [Gen Integer] -> [(Int, Gen Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int
50 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
9, Int
8.. Int
1]) ([Gen Integer] -> [(Int, Gen Integer)])
-> [Gen Integer] -> [(Int, Gen Integer)]
forall a b. (a -> b) -> a -> b
$ (Integer -> Gen Integer) -> [Integer] -> [Gen Integer]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Integer
lo..]
        , [Int] -> [Gen Integer] -> [(Int, Gen Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int
50 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
9, Int
8.. Int
1]) ([Gen Integer] -> [(Int, Gen Integer)])
-> [Gen Integer] -> [(Int, Gen Integer)]
forall a b. (a -> b) -> a -> b
$ (Integer -> Gen Integer) -> [Integer] -> [Gen Integer]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Integer
hi, Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]
        , [(Int
200, (Integer, Integer) -> Gen Integer
chooseInteger (Integer
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
10, Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
10))]
        ]

-- | Generate asymptotically larger positive negative numbers (sans zero) with exponentially lower
-- chance, stop at the geometric mean of the range and start increasing the probability of
-- generating larger numbers, so that we generate we're most likely to generate numbers that are
-- either fairly small or really big. Numbers at the beginning of the range are more likely to get
-- generated than at the very end, but only by a fairly small factor. The size parameter is ignored,
-- which is perhaps wrong and should be fixed.
arbitraryPositive :: (Integer -> Integer) -> Integer -> Gen Integer
arbitraryPositive :: (Integer -> Integer) -> Integer -> Gen Integer
arbitraryPositive Integer -> Integer
next Integer
high = [(Int, Gen Integer)] -> Gen Integer
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen Integer)] -> Gen Integer)
-> ([Gen Integer] -> [(Int, Gen Integer)])
-> [Gen Integer]
-> Gen Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Gen Integer] -> [(Int, Gen Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
freqs ([Gen Integer] -> Gen Integer) -> [Gen Integer] -> Gen Integer
forall a b. (a -> b) -> a -> b
$ ((Integer, Integer) -> Gen Integer)
-> [(Integer, Integer)] -> [Gen Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Integer) -> Gen Integer
chooseIntegerPreferEnds [(Integer, Integer)]
magnitudes where
    magnitudes :: [(Integer, Integer)]
magnitudes = (Integer -> Integer) -> Integer -> [(Integer, Integer)]
magnitudesPositive Integer -> Integer
next Integer
high
    prefreqs :: [Int]
prefreqs = (Double -> Int) -> [Double] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ([Double] -> [Int]) -> [Double] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Double -> Double) -> Double -> [Double]
forall a. (a -> a) -> a -> [a]
iterate (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1.1) (Double
100 :: Double)
    freqs :: [Int]
freqs = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Int] -> [Int]
forall a. [a] -> [a]
reverse (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take ([(Integer, Integer)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Integer, Integer)]
magnitudes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Int]
prefreqs)
        , (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1.5 :: Double)) (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Int]
prefreqs
        ]

-- | Same as 'arbitraryPositive' except produces negative integers.
arbitraryNegative :: (Integer -> Integer) -> Integer -> Gen Integer
arbitraryNegative :: (Integer -> Integer) -> Integer -> Gen Integer
arbitraryNegative Integer -> Integer
next Integer
high = Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Gen Integer -> Gen Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer -> Integer) -> Integer -> Gen Integer
arbitraryPositive Integer -> Integer
next Integer
high

arbitrarySigned :: (Integer -> Integer) -> Integer -> Gen Integer
arbitrarySigned :: (Integer -> Integer) -> Integer -> Gen Integer
arbitrarySigned Integer -> Integer
next Integer
high = [(Int, Gen Integer)] -> Gen Integer
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
48, (Integer -> Integer) -> Integer -> Gen Integer
arbitraryNegative Integer -> Integer
next Integer
high)
    , (Int
4, Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0)
    , (Int
48, (Integer -> Integer) -> Integer -> Gen Integer
arbitraryPositive Integer -> Integer
next Integer
high)
    ]

-- | Same as 'shrinkIntegral' except includes the square root of the given number (or of its
-- negative if the number is negative, in which case the square root is negated too). We need the
-- former because 'shrinkIntegral' at most divides the number by two, which makes the number smaller
-- way too slow, hence we add square root to speed up the process.
--
-- >>> shrinkIntegralFast (0 :: Integer)
-- []
-- >>> shrinkIntegralFast (1 :: Integer)
-- [0]
-- >>> shrinkIntegralFast (9 :: Integer)
-- [0,3,5,7,8]
-- >>> shrinkIntegralFast (-10000 :: Integer)
-- [0,10000,-100,-5000,-7500,-8750,-9375,-9688,-9844,-9922,-9961,-9981,-9991,-9996,-9998,-9999]
shrinkIntegralFast :: Integral a => a -> [a]
shrinkIntegralFast :: forall a. Integral a => a -> [a]
shrinkIntegralFast a
x = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [a
0 | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0]
    , [-a
x | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0]
    , [a -> a
forall a. Num a => a -> a
signum a
x a -> a -> a
forall a. Num a => a -> a -> a
* Double -> a
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a. Floating a => a -> a
sqrt @Double (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
xA) | let xA :: a
xA = a -> a
forall a. Num a => a -> a
abs a
x, a
xA a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
4]
    , Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a
x a -> a -> a
forall a. Num a => a -> a -> a
-) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a -> a) -> a -> [a]
forall a. (a -> a) -> a -> [a]
iterate (a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) a
x
    ]

instance ArbitraryBuiltin Integer where
    -- See Note [QuickCheck and integral types].
    arbitraryBuiltin :: Gen Integer
arbitraryBuiltin = (Integer -> Integer) -> Integer -> Gen Integer
arbitrarySigned Integer -> Integer
nextInterestingBound Integer
highInterestingBound
    shrinkBuiltin :: Integer -> [Integer]
shrinkBuiltin = Integer -> [Integer]
forall a. Integral a => a -> [a]
shrinkIntegralFast

-- |
--
-- >>> shrinkBuiltin $ Text.pack "abcd"
-- ["","cd","ab","bcd","acd","abd","abc","aacd","abad","abbd","abca","abcb","abcc"]
instance ArbitraryBuiltin Text where
    arbitraryBuiltin :: Gen Text
arbitraryBuiltin = String -> Text
Text.pack (String -> Text)
-> (PrintableString -> String) -> PrintableString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintableString -> String
getPrintableString (PrintableString -> Text) -> Gen PrintableString -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen PrintableString
forall a. Arbitrary a => Gen a
arbitrary
    shrinkBuiltin :: Text -> [Text]
shrinkBuiltin = (PrintableString -> Text) -> [PrintableString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text)
-> (PrintableString -> String) -> PrintableString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintableString -> String
getPrintableString) ([PrintableString] -> [Text])
-> (Text -> [PrintableString]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintableString -> [PrintableString]
forall a. Arbitrary a => a -> [a]
shrink (PrintableString -> [PrintableString])
-> (Text -> PrintableString) -> Text -> [PrintableString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PrintableString
PrintableString (String -> PrintableString)
-> (Text -> String) -> Text -> PrintableString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

instance ArbitraryBuiltin ByteString where
    arbitraryBuiltin :: Gen ByteString
arbitraryBuiltin = Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Gen Text -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin
    shrinkBuiltin :: ByteString -> [ByteString]
shrinkBuiltin = (Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
Text.encodeUtf8 ([Text] -> [ByteString])
-> (ByteString -> [Text]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8

-- | Generate a tag for the 'Constr' constructor.
genConstrTag :: Gen Integer
genConstrTag :: Gen Integer
genConstrTag = [(Int, Gen Integer)] -> Gen Integer
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ -- We want to generate most plausible constructor IDs most often.
      (Int
6, (Integer, Integer) -> Gen Integer
chooseInteger (Integer
0, Integer
2))
    , -- Less plausible -- less often.
      (Int
3, (Integer, Integer) -> Gen Integer
chooseInteger (Integer
3, Integer
5))
    , -- And some meaningless garbage occasionally just to have good coverage.
      (Int
1, (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64)) (Integer -> Integer) -> Gen Integer -> Gen Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin)
    ]

-- | Generate a 'Data' object using a @spine :: [()]@ as a hint. It's helpful to make the spine a
-- list of units rather than a 'Word' or something, because we have useful functions for arbitrary
-- list splitting.
genDataFromSpine :: [()] -> Gen Data
genDataFromSpine :: [()] -> Gen Data
genDataFromSpine [] =
    [Gen Data] -> Gen Data
forall a. HasCallStack => [Gen a] -> Gen a
oneof
        [ Integer -> [Data] -> Data
Constr (Integer -> [Data] -> Data) -> Gen Integer -> Gen ([Data] -> Data)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
genConstrTag Gen ([Data] -> Data) -> Gen [Data] -> Gen Data
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Data] -> Gen [Data]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        , Data -> Gen Data
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Data -> Gen Data) -> Data -> Gen Data
forall a b. (a -> b) -> a -> b
$ [Data] -> Data
List []
        , Data -> Gen Data
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Data -> Gen Data) -> Data -> Gen Data
forall a b. (a -> b) -> a -> b
$ [(Data, Data)] -> Data
Map []
        ]
genDataFromSpine [()] = [Gen Data] -> Gen Data
forall a. HasCallStack => [Gen a] -> Gen a
oneof [Integer -> Data
I (Integer -> Data) -> Gen Integer -> Gen Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin, ByteString -> Data
B (ByteString -> Data) -> Gen ByteString -> Gen Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin]
genDataFromSpine [()]
els = [Gen Data] -> Gen Data
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Integer -> [Data] -> Data
Constr (Integer -> [Data] -> Data) -> Gen Integer -> Gen ([Data] -> Data)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
genConstrTag Gen ([Data] -> Data) -> Gen [Data] -> Gen Data
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Double -> [()] -> Gen [[()]]
forall a. Double -> [a] -> Gen [[a]]
multiSplit0 Double
0.1 [()]
els Gen [[()]] -> ([[()]] -> Gen [Data]) -> Gen [Data]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([()] -> Gen Data) -> [[()]] -> Gen [Data]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [()] -> Gen Data
genDataFromSpine)
    , [Data] -> Data
List ([Data] -> Data) -> Gen [Data] -> Gen Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> [()] -> Gen [[()]]
forall a. Double -> [a] -> Gen [[a]]
multiSplit0 Double
0.1 [()]
els Gen [[()]] -> ([[()]] -> Gen [Data]) -> Gen [Data]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([()] -> Gen Data) -> [[()]] -> Gen [Data]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [()] -> Gen Data
genDataFromSpine)
    , do
        [NonEmptyList ()]
elss <- [()] -> Gen [NonEmptyList ()]
forall a. [a] -> Gen [NonEmptyList a]
multiSplit1 [()]
els
        [(Data, Data)] -> Data
Map ([(Data, Data)] -> Data) -> Gen [(Data, Data)] -> Gen Data
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen [(Data, Data)])] -> Gen [(Data, Data)]
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
            [ -- Generate maps from 'ByteString's most often.
              (Int
6, [NonEmptyList ()]
-> (NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NonEmptyList ()]
elss ((NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)])
-> (NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)]
forall a b. (a -> b) -> a -> b
$ \(NonEmpty [()]
els') ->
                (,) (Data -> Data -> (Data, Data))
-> (ByteString -> Data) -> ByteString -> Data -> (Data, Data)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Data
B (ByteString -> Data -> (Data, Data))
-> Gen ByteString -> Gen (Data -> (Data, Data))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin Gen (Data -> (Data, Data)) -> Gen Data -> Gen (Data, Data)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [()] -> Gen Data
genDataFromSpine (Int -> [()] -> [()]
forall a. Int -> [a] -> [a]
drop Int
1 [()]
els'))
            , -- Generate maps from 'Integer's less often.
              (Int
3, [NonEmptyList ()]
-> (NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NonEmptyList ()]
elss ((NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)])
-> (NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)]
forall a b. (a -> b) -> a -> b
$ \(NonEmpty [()]
els') ->
                (,) (Data -> Data -> (Data, Data))
-> (Integer -> Data) -> Integer -> Data -> (Data, Data)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Data
I (Integer -> Data -> (Data, Data))
-> Gen Integer -> Gen (Data -> (Data, Data))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin Gen (Data -> (Data, Data)) -> Gen Data -> Gen (Data, Data)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [()] -> Gen Data
genDataFromSpine (Int -> [()] -> [()]
forall a. Int -> [a] -> [a]
drop Int
1 [()]
els'))
            , -- Occasionally generate maps with random nonsense in place of keys.
              (Int
1, [NonEmptyList ()]
-> (NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NonEmptyList ()]
elss ((NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)])
-> (NonEmptyList () -> Gen (Data, Data)) -> Gen [(Data, Data)]
forall a b. (a -> b) -> a -> b
$ \(NonEmpty [()]
els') -> do
                [NonEmptyList ()]
splitRes <- Int -> [()] -> Gen [NonEmptyList ()]
forall a. Int -> [a] -> Gen [NonEmptyList a]
multiSplit1In Int
2 [()]
els'
                case [NonEmptyList ()]
splitRes of
                    [] ->
                        (,) (Data -> Data -> (Data, Data))
-> Gen Data -> Gen (Data -> (Data, Data))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [()] -> Gen Data
genDataFromSpine [] Gen (Data -> (Data, Data)) -> Gen Data -> Gen (Data, Data)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [()] -> Gen Data
genDataFromSpine []
                    [NonEmpty [()]
elsL'] ->
                        (,) (Data -> Data -> (Data, Data))
-> Gen Data -> Gen (Data -> (Data, Data))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [()] -> Gen Data
genDataFromSpine [()]
elsL' Gen (Data -> (Data, Data)) -> Gen Data -> Gen (Data, Data)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [()] -> Gen Data
genDataFromSpine []
                    [NonEmpty [()]
elsL', NonEmpty [()]
elsR'] ->
                        (,) (Data -> Data -> (Data, Data))
-> Gen Data -> Gen (Data -> (Data, Data))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [()] -> Gen Data
genDataFromSpine [()]
elsL' Gen (Data -> (Data, Data)) -> Gen Data -> Gen (Data, Data)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [()] -> Gen Data
genDataFromSpine [()]
elsR'
                    [NonEmptyList ()]
_ -> String -> Gen (Data, Data)
forall a. HasCallStack => String -> a
error String
"Panic: 'multiSplit1In 2' returned a list longer than 2 elements")
            ]
    ]

pureIfNull :: (Foldable f, Applicative f) => a -> f a -> f a
pureIfNull :: forall (f :: * -> *) a.
(Foldable f, Applicative f) =>
a -> f a -> f a
pureIfNull a
x f a
xs = if f a -> Bool
forall a. f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f a
xs then a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x else f a
xs

instance ArbitraryBuiltin Data where
    arbitraryBuiltin :: Gen Data
arbitraryBuiltin = Gen [()]
forall a. Arbitrary a => Gen a
arbitrary Gen [()] -> ([()] -> Gen Data) -> Gen Data
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [()] -> Gen Data
genDataFromSpine

    -- We arbitrarily assume that @I 0@ is the smallest 'Data' object just so that anything else in
    -- a counterexample gives us a clue as to what the culprit may be. Hence @I 0@ needs to be
    -- reachable from all nodes apart from @I 0@ itself. For all nodes but 'I' we achieve this by
    -- returning @[I 0]@ if there's no other way to shrink the value, i.e. either shrinking keeps
    -- going or it's time to return the smallest object. The clause for @I i@ doesn't require
    -- mentioning @I 0@ explicitly, since we get it through general shrinking of @i@ (unless @i@
    -- equals @0@, as desired).
    shrinkBuiltin :: Data -> [Data]
shrinkBuiltin (Constr Integer
i [Data]
ds) = Data -> [Data] -> [Data]
forall (f :: * -> *) a.
(Foldable f, Applicative f) =>
a -> f a -> f a
pureIfNull (Integer -> Data
I Integer
0) ([Data] -> [Data]) -> [Data] -> [Data]
forall a b. (a -> b) -> a -> b
$ [[Data]] -> [Data]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Data]
ds
        , ([Data] -> Data) -> [[Data]] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> [Data] -> Data
Constr Integer
i) ([[Data]] -> [Data]) -> [[Data]] -> [Data]
forall a b. (a -> b) -> a -> b
$ [Data] -> [[Data]]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin [Data]
ds
        , (Integer -> Data) -> [Integer] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer -> [Data] -> Data) -> [Data] -> Integer -> Data
forall a b c. (a -> b -> c) -> b -> a -> c
flip Integer -> [Data] -> Data
Constr [Data]
ds) ([Integer] -> [Data]) -> [Integer] -> [Data]
forall a b. (a -> b) -> a -> b
$ Integer -> [Integer]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin Integer
i
        ]
    shrinkBuiltin (Map [(Data, Data)]
ps) = Data -> [Data] -> [Data]
forall (f :: * -> *) a.
(Foldable f, Applicative f) =>
a -> f a -> f a
pureIfNull (Integer -> Data
I Integer
0) ([Data] -> [Data]) -> [Data] -> [Data]
forall a b. (a -> b) -> a -> b
$ [[Data]] -> [Data]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ ((Data, Data) -> Data) -> [(Data, Data)] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map (Data, Data) -> Data
forall a b. (a, b) -> a
fst [(Data, Data)]
ps
        , ((Data, Data) -> Data) -> [(Data, Data)] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map (Data, Data) -> Data
forall a b. (a, b) -> b
snd [(Data, Data)]
ps
        , ([(Data, Data)] -> Data) -> [[(Data, Data)]] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map [(Data, Data)] -> Data
Map ([[(Data, Data)]] -> [Data]) -> [[(Data, Data)]] -> [Data]
forall a b. (a -> b) -> a -> b
$ [(Data, Data)] -> [[(Data, Data)]]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin [(Data, Data)]
ps
        ]
    shrinkBuiltin (List [Data]
ds) = Data -> [Data] -> [Data]
forall (f :: * -> *) a.
(Foldable f, Applicative f) =>
a -> f a -> f a
pureIfNull (Integer -> Data
I Integer
0) ([Data] -> [Data]) -> [Data] -> [Data]
forall a b. (a -> b) -> a -> b
$ [[Data]] -> [Data]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Data]
ds
        , ([Data] -> Data) -> [[Data]] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map [Data] -> Data
List ([[Data]] -> [Data]) -> [[Data]] -> [Data]
forall a b. (a -> b) -> a -> b
$ [Data] -> [[Data]]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin [Data]
ds
        ]
    shrinkBuiltin (B ByteString
b) = Data -> [Data] -> [Data]
forall (f :: * -> *) a.
(Foldable f, Applicative f) =>
a -> f a -> f a
pureIfNull (Integer -> Data
I Integer
0) ([Data] -> [Data])
-> ([ByteString] -> [Data]) -> [ByteString] -> [Data]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Data) -> [ByteString] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Data
B ([ByteString] -> [Data]) -> [ByteString] -> [Data]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin ByteString
b
    shrinkBuiltin (I Integer
i) = (Integer -> Data) -> [Integer] -> [Data]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Data
I ([Integer] -> [Data]) -> [Integer] -> [Data]
forall a b. (a -> b) -> a -> b
$ Integer -> [Integer]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin Integer
i

instance Arbitrary Data where
    arbitrary :: Gen Data
arbitrary = Gen Data
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin
    shrink :: Data -> [Data]
shrink = Data -> [Data]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin

instance ArbitraryBuiltin BLS12_381.G1.Element where
    arbitraryBuiltin :: Gen Element
arbitraryBuiltin =
      ByteString -> ByteString -> Either BLS12_381_Error Element
BLS12_381.G1.hashToGroup (ByteString -> ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString
-> Gen (ByteString -> Either BLS12_381_Error Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen (ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString -> Gen (Either BLS12_381_Error Element)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Gen ByteString
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
Data.ByteString.empty Gen (Either BLS12_381_Error Element)
-> (Either BLS12_381_Error Element -> Gen Element) -> Gen Element
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           -- We should only get a failure if the second argument is greater than 255 bytes, which
           -- it isn't.
           Left BLS12_381_Error
err -> String -> Gen Element
forall a. HasCallStack => String -> a
error (String -> Gen Element) -> String -> Gen Element
forall a b. (a -> b) -> a -> b
$ BLS12_381_Error -> String
forall a. Show a => a -> String
show BLS12_381_Error
err
           Right Element
p  -> Element -> Gen Element
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
p
    -- It's difficult to come up with a sensible shrinking function here given
    -- that there's no sensible order on the elements of G1, let alone one
    -- that's compatible with the group structure.  We can't try shrinking the
    -- x-coordinate of a known point for example because only about only about
    -- 1/10^39 of the field elements are the x-coordinate of a point in G1, so
    -- we're highly unlikely to find a suitable x value.
    shrinkBuiltin :: Element -> [Element]
shrinkBuiltin Element
_ = []

instance ArbitraryBuiltin BLS12_381.G2.Element where
    arbitraryBuiltin :: Gen Element
arbitraryBuiltin =
      ByteString -> ByteString -> Either BLS12_381_Error Element
BLS12_381.G2.hashToGroup (ByteString -> ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString
-> Gen (ByteString -> Either BLS12_381_Error Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen (ByteString -> Either BLS12_381_Error Element)
-> Gen ByteString -> Gen (Either BLS12_381_Error Element)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Gen ByteString
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
Data.ByteString.empty Gen (Either BLS12_381_Error Element)
-> (Either BLS12_381_Error Element -> Gen Element) -> Gen Element
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           -- We should only get a failure if the second argument is greater than 255 bytes, which
           -- it isn't.
           Left BLS12_381_Error
err -> String -> Gen Element
forall a. HasCallStack => String -> a
error (String -> Gen Element) -> String -> Gen Element
forall a b. (a -> b) -> a -> b
$ BLS12_381_Error -> String
forall a. Show a => a -> String
show BLS12_381_Error
err
           Right Element
p  -> Element -> Gen Element
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
p
    -- See the comment about shrinking for G1; G2 is even worse.
    shrinkBuiltin :: Element -> [Element]
shrinkBuiltin Element
_ = []

instance ArbitraryBuiltin BLS12_381.Pairing.MlResult where
    arbitraryBuiltin :: Gen MlResult
arbitraryBuiltin = Element -> Element -> MlResult
BLS12_381.Pairing.millerLoop (Element -> Element -> MlResult)
-> Gen Element -> Gen (Element -> MlResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Element
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin Gen (Element -> MlResult) -> Gen Element -> Gen MlResult
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Element
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin
    -- Shrinking here is even more difficult than for G1 and G2 since we don't
    -- have direct access to elements of MlResult.
    shrinkBuiltin :: MlResult -> [MlResult]
shrinkBuiltin MlResult
_ = []

-- | For providing an 'Arbitrary' instance deferring to 'ArbitraryBuiltin'. Useful for implementing
-- 'ArbitraryBuiltin' for a polymorphic built-in type by taking the logic for handling spines from
-- the 'Arbitrary' class and the logic for handling elements from 'ArbitraryBuiltin'.
newtype AsArbitraryBuiltin a = AsArbitraryBuiltin
    { forall a. AsArbitraryBuiltin a -> a
unAsArbitraryBuiltin :: a
    } deriving newtype (Int -> AsArbitraryBuiltin a -> ShowS
[AsArbitraryBuiltin a] -> ShowS
AsArbitraryBuiltin a -> String
(Int -> AsArbitraryBuiltin a -> ShowS)
-> (AsArbitraryBuiltin a -> String)
-> ([AsArbitraryBuiltin a] -> ShowS)
-> Show (AsArbitraryBuiltin a)
forall a. Show a => Int -> AsArbitraryBuiltin a -> ShowS
forall a. Show a => [AsArbitraryBuiltin a] -> ShowS
forall a. Show a => AsArbitraryBuiltin a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AsArbitraryBuiltin a -> ShowS
showsPrec :: Int -> AsArbitraryBuiltin a -> ShowS
$cshow :: forall a. Show a => AsArbitraryBuiltin a -> String
show :: AsArbitraryBuiltin a -> String
$cshowList :: forall a. Show a => [AsArbitraryBuiltin a] -> ShowS
showList :: [AsArbitraryBuiltin a] -> ShowS
Show)

instance ArbitraryBuiltin a => Arbitrary (AsArbitraryBuiltin a) where
    arbitrary :: Gen (AsArbitraryBuiltin a)
arbitrary = Gen a -> Gen (AsArbitraryBuiltin a)
forall a b. Coercible a b => a -> b
coerce (Gen a -> Gen (AsArbitraryBuiltin a))
-> Gen a -> Gen (AsArbitraryBuiltin a)
forall a b. (a -> b) -> a -> b
$ forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin @a
    shrink :: AsArbitraryBuiltin a -> [AsArbitraryBuiltin a]
shrink = (a -> [a]) -> AsArbitraryBuiltin a -> [AsArbitraryBuiltin a]
forall a b. Coercible a b => a -> b
coerce ((a -> [a]) -> AsArbitraryBuiltin a -> [AsArbitraryBuiltin a])
-> (a -> [a]) -> AsArbitraryBuiltin a -> [AsArbitraryBuiltin a]
forall a b. (a -> b) -> a -> b
$ forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin @a

-- We could do this and the next one generically using 'ElaborateBuiltin', but it would be more
-- code, so we keep it simple.
instance ArbitraryBuiltin a => ArbitraryBuiltin [a] where
    arbitraryBuiltin :: Gen [a]
arbitraryBuiltin = do
        [()]
spine <- Gen [()]
forall a. Arbitrary a => Gen a
arbitrary
        let len :: Int
len = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [()]
spine
        [()] -> (() -> Gen a) -> Gen [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [()]
spine ((() -> Gen a) -> Gen [a]) -> (() -> Gen a) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \() ->
            -- Scale the elements, so that generating a list of lists of lists doesn't take
            -- exponential size (and thus time).
            (Int -> Int) -> Gen a -> Gen a
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
len) (Gen a -> Gen a)
-> (Gen (AsArbitraryBuiltin a) -> Gen a)
-> Gen (AsArbitraryBuiltin a)
-> Gen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (AsArbitraryBuiltin a) -> Gen a
forall a b. Coercible a b => a -> b
coerce (Gen (AsArbitraryBuiltin a) -> Gen a)
-> Gen (AsArbitraryBuiltin a) -> Gen a
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => Gen a
arbitrary @(AsArbitraryBuiltin a)
    shrinkBuiltin :: [a] -> [[a]]
shrinkBuiltin = ([AsArbitraryBuiltin a] -> [[AsArbitraryBuiltin a]])
-> [a] -> [[a]]
forall a b. Coercible a b => a -> b
coerce (([AsArbitraryBuiltin a] -> [[AsArbitraryBuiltin a]])
 -> [a] -> [[a]])
-> ([AsArbitraryBuiltin a] -> [[AsArbitraryBuiltin a]])
-> [a]
-> [[a]]
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => a -> [a]
shrink @[AsArbitraryBuiltin a]

instance (ArbitraryBuiltin a, ArbitraryBuiltin b) => ArbitraryBuiltin (a, b) where
    arbitraryBuiltin :: Gen (a, b)
arbitraryBuiltin = do
        (,)
            (a -> b -> (a, b)) -> Gen a -> Gen (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (AsArbitraryBuiltin a) -> Gen a
forall a b. Coercible a b => a -> b
coerce ((Int -> Int)
-> Gen (AsArbitraryBuiltin a) -> Gen (AsArbitraryBuiltin a)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Gen (AsArbitraryBuiltin a) -> Gen (AsArbitraryBuiltin a))
-> Gen (AsArbitraryBuiltin a) -> Gen (AsArbitraryBuiltin a)
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => Gen a
arbitrary @(AsArbitraryBuiltin a))
            Gen (b -> (a, b)) -> Gen b -> Gen (a, b)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (AsArbitraryBuiltin b) -> Gen b
forall a b. Coercible a b => a -> b
coerce ((Int -> Int)
-> Gen (AsArbitraryBuiltin b) -> Gen (AsArbitraryBuiltin b)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Gen (AsArbitraryBuiltin b) -> Gen (AsArbitraryBuiltin b))
-> Gen (AsArbitraryBuiltin b) -> Gen (AsArbitraryBuiltin b)
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => Gen a
arbitrary @(AsArbitraryBuiltin b))
    shrinkBuiltin :: (a, b) -> [(a, b)]
shrinkBuiltin = ((AsArbitraryBuiltin a, AsArbitraryBuiltin b)
 -> [(AsArbitraryBuiltin a, AsArbitraryBuiltin b)])
-> (a, b) -> [(a, b)]
forall a b. Coercible a b => a -> b
coerce (((AsArbitraryBuiltin a, AsArbitraryBuiltin b)
  -> [(AsArbitraryBuiltin a, AsArbitraryBuiltin b)])
 -> (a, b) -> [(a, b)])
-> ((AsArbitraryBuiltin a, AsArbitraryBuiltin b)
    -> [(AsArbitraryBuiltin a, AsArbitraryBuiltin b)])
-> (a, b)
-> [(a, b)]
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => a -> [a]
shrink @(AsArbitraryBuiltin a, AsArbitraryBuiltin b)

-- | Either a fail to generate anything or a built-in type of a given kind.
data MaybeSomeTypeOf k
    = NothingSomeType
    | forall (a :: k). JustSomeType (DefaultUni (Esc a))

instance Eq (MaybeSomeTypeOf k) where
    MaybeSomeTypeOf k
NothingSomeType   == :: MaybeSomeTypeOf k -> MaybeSomeTypeOf k -> Bool
== MaybeSomeTypeOf k
NothingSomeType   = Bool
True
    JustSomeType DefaultUni (Esc a)
uni1 == JustSomeType DefaultUni (Esc a)
uni2 = DefaultUni (Esc a)
uni1 DefaultUni (Esc a) -> DefaultUni (Esc a) -> Bool
forall {k} (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Bool
`defaultEq` DefaultUni (Esc a)
uni2
    MaybeSomeTypeOf k
NothingSomeType   == JustSomeType{}    = Bool
False
    JustSomeType{}    == MaybeSomeTypeOf k
NothingSomeType   = Bool
False

-- | Forget the reflected at the type level kind.
eraseMaybeSomeTypeOf :: MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
eraseMaybeSomeTypeOf :: forall k. MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
eraseMaybeSomeTypeOf MaybeSomeTypeOf k
NothingSomeType    = Maybe (SomeTypeIn DefaultUni)
forall a. Maybe a
Nothing
eraseMaybeSomeTypeOf (JustSomeType DefaultUni (Esc a)
uni) = SomeTypeIn DefaultUni -> Maybe (SomeTypeIn DefaultUni)
forall a. a -> Maybe a
Just (SomeTypeIn DefaultUni -> Maybe (SomeTypeIn DefaultUni))
-> SomeTypeIn DefaultUni -> Maybe (SomeTypeIn DefaultUni)
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc a) -> SomeTypeIn DefaultUni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
SomeTypeIn DefaultUni (Esc a)
uni

-- | Generate a 'DefaultUniApply' if possible.
genDefaultUniApply :: KnownKind k => Gen (MaybeSomeTypeOf k)
genDefaultUniApply :: forall k. KnownKind k => Gen (MaybeSomeTypeOf k)
genDefaultUniApply = do
    -- We don't scale the function, because sizes don't matter for application heads anyway, plus
    -- the function may itself be an application and we certainly don't want type arguments that
    -- come first to be smaller than those that come latter as that would make no sense.
    MaybeSomeTypeOf (* -> k)
mayFun <- Gen (MaybeSomeTypeOf (* -> k))
forall a. Arbitrary a => Gen a
arbitrary
    -- We don't want to generate deeply nested built-in types, hence the scaling.
    MaybeSomeTypeOf (*)
mayArg <- (Int -> Int)
-> Gen (MaybeSomeTypeOf (*)) -> Gen (MaybeSomeTypeOf (*))
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) Gen (MaybeSomeTypeOf (*))
forall a. Arbitrary a => Gen a
arbitrary :: Gen (MaybeSomeTypeOf GHC.Type)
    MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k))
-> MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a b. (a -> b) -> a -> b
$ case (MaybeSomeTypeOf (* -> k)
mayFun, MaybeSomeTypeOf (*)
mayArg) of
        (JustSomeType DefaultUni (Esc a)
fun, JustSomeType DefaultUni (Esc a)
arg) -> DefaultUni (Esc (a a)) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType (DefaultUni (Esc (a a)) -> MaybeSomeTypeOf k)
-> DefaultUni (Esc (a a)) -> MaybeSomeTypeOf k
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc a)
fun DefaultUni (Esc a) -> DefaultUni (Esc a) -> DefaultUni (Esc (a a))
forall {k1} {k2} (f :: k1 -> k2) (a1 :: k1).
DefaultUni (Esc f)
-> DefaultUni (Esc a1) -> DefaultUni (Esc (f a1))
`DefaultUniApply` DefaultUni (Esc a)
arg
        (MaybeSomeTypeOf (* -> k), MaybeSomeTypeOf (*))
_                                    -> MaybeSomeTypeOf k
forall k. MaybeSomeTypeOf k
NothingSomeType

-- | Shrink a 'DefaultUniApply' to one of the elements of the spine and throw away the head
-- (because the head of an application can't be of the same kind as the whole application).
-- We don't have higher-kinded built-in types, so we don't do this kind of shrinking for any kinds
-- other than *.
shrinkToStarArgs :: DefaultUni (Esc a) -> [MaybeSomeTypeOf GHC.Type]
shrinkToStarArgs :: forall {k} (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf (*)]
shrinkToStarArgs = [MaybeSomeTypeOf (*)]
-> DefaultUni (Esc a) -> [MaybeSomeTypeOf (*)]
forall {k} (b :: k).
[MaybeSomeTypeOf (*)]
-> DefaultUni (Esc b) -> [MaybeSomeTypeOf (*)]
go [] where
    go :: [MaybeSomeTypeOf GHC.Type] -> DefaultUni (Esc b) -> [MaybeSomeTypeOf GHC.Type]
    go :: forall {k} (b :: k).
[MaybeSomeTypeOf (*)]
-> DefaultUni (Esc b) -> [MaybeSomeTypeOf (*)]
go [MaybeSomeTypeOf (*)]
args (DefaultUni (Esc f)
fun `DefaultUniApply` DefaultUni (Esc a1)
arg) =
        [MaybeSomeTypeOf (*)]
-> DefaultUni (Esc f) -> [MaybeSomeTypeOf (*)]
forall {k} (b :: k).
[MaybeSomeTypeOf (*)]
-> DefaultUni (Esc b) -> [MaybeSomeTypeOf (*)]
go ([DefaultUni (Esc a1) -> MaybeSomeTypeOf (*)
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc a1)
DefaultUni (Esc a1)
arg | SingKind k1
SingType <- [DefaultUni (Esc a1) -> SingKind k1
forall k (a :: k). DefaultUni (Esc a) -> SingKind k
forall (uni :: * -> *) k (a :: k).
ToKind uni =>
uni (Esc a) -> SingKind k
toSingKind DefaultUni (Esc a1)
arg]] [MaybeSomeTypeOf (*)]
-> [MaybeSomeTypeOf (*)] -> [MaybeSomeTypeOf (*)]
forall a. [a] -> [a] -> [a]
++ [MaybeSomeTypeOf (*)]
args) DefaultUni (Esc f)
fun
    go [MaybeSomeTypeOf (*)]
args DefaultUni (Esc b)
_ = [MaybeSomeTypeOf (*)]
args

-- | Shrink a built-in type while preserving its kind.
shrinkDropBuiltinSameKind :: DefaultUni (Esc (a :: k)) -> [MaybeSomeTypeOf k]
shrinkDropBuiltinSameKind :: forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkDropBuiltinSameKind DefaultUni (Esc a)
uni =
    case DefaultUni (Esc a) -> SingKind k
forall k (a :: k). DefaultUni (Esc a) -> SingKind k
forall (uni :: * -> *) k (a :: k).
ToKind uni =>
uni (Esc a) -> SingKind k
toSingKind DefaultUni (Esc a)
uni of
        SingKind k
SingType -> case DefaultUni (Esc a)
uni of
            -- 'DefaultUniUnit' is the "minimal" built-in type, can't shrink it any further.
            DefaultUni (Esc a)
DefaultUniUnit -> []
            -- Any other built-in type of kind @*@ shrinks to 'DefaultUniUnit' and if it happens to
            -- be a built-in type application, then also all suitable arguments of the
            -- application that are not 'DefaultUniUnit'.
            DefaultUni (Esc a)
_              ->
                let ju :: MaybeSomeTypeOf (*)
ju = DefaultUni (Esc ()) -> MaybeSomeTypeOf (*)
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc ())
DefaultUniUnit
                in MaybeSomeTypeOf k
MaybeSomeTypeOf (*)
ju MaybeSomeTypeOf k -> [MaybeSomeTypeOf k] -> [MaybeSomeTypeOf k]
forall a. a -> [a] -> [a]
: (MaybeSomeTypeOf k -> Bool)
-> [MaybeSomeTypeOf k] -> [MaybeSomeTypeOf k]
forall a. (a -> Bool) -> [a] -> [a]
filter (MaybeSomeTypeOf (*) -> MaybeSomeTypeOf (*) -> Bool
forall a. Eq a => a -> a -> Bool
/= MaybeSomeTypeOf (*)
ju) (DefaultUni (Esc a) -> [MaybeSomeTypeOf (*)]
forall {k} (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf (*)]
shrinkToStarArgs DefaultUni (Esc a)
uni)
        -- Any built-in type of kind @* -> *@ can be shrunk to @[] :: * -> *@ as long as the
        -- built-in type is not @[]@ already.
        -- If we had higher-kinded built-in types, we'd need 'shrinkToStarToStarArgs' here like with
        -- 'shrinkToStarArgs' above, so the current approach would need some generalization. But we
        -- we don't have higher-kinded built-in types and are unlikely to introduce them, so we opt
        -- for not complicating things here.
        SingKind k1
SingType `SingKindArrow` SingKind l
SingType -> case DefaultUni (Esc a)
uni of
            DefaultUni (Esc a)
DefaultUniProtoList -> []
            DefaultUni (Esc a)
_                   -> [DefaultUni (Esc []) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc [])
DefaultUni (Esc [])
DefaultUniProtoList]
        SingKind k
_ -> []

-- | Shrink a function application by shrinking either the function or the argument.
-- The kind is preserved.
shrinkDefaultUniApply :: DefaultUni (Esc (a :: k)) -> [MaybeSomeTypeOf k]
shrinkDefaultUniApply :: forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkDefaultUniApply (DefaultUni (Esc f)
fun `DefaultUniApply` DefaultUni (Esc a1)
arg) = [[MaybeSomeTypeOf k]] -> [MaybeSomeTypeOf k]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ DefaultUni (Esc (a a1)) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType (DefaultUni (Esc (a a1)) -> MaybeSomeTypeOf k)
-> DefaultUni (Esc (a a1)) -> MaybeSomeTypeOf k
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc a)
DefaultUni (Esc a)
fun' DefaultUni (Esc a)
-> DefaultUni (Esc a1) -> DefaultUni (Esc (a a1))
forall {k1} {k2} (f :: k1 -> k2) (a1 :: k1).
DefaultUni (Esc f)
-> DefaultUni (Esc a1) -> DefaultUni (Esc (f a1))
`DefaultUniApply` DefaultUni (Esc a1)
arg
      | JustSomeType DefaultUni (Esc a)
fun' <- DefaultUni (Esc f) -> [MaybeSomeTypeOf (k1 -> k2)]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkBuiltinSameKind DefaultUni (Esc f)
fun
      ]
    , [ DefaultUni (Esc (f a)) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType (DefaultUni (Esc (f a)) -> MaybeSomeTypeOf k)
-> DefaultUni (Esc (f a)) -> MaybeSomeTypeOf k
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc f)
DefaultUni (Esc f)
fun DefaultUni (Esc f) -> DefaultUni (Esc a) -> DefaultUni (Esc (f a))
forall {k1} {k2} (f :: k1 -> k2) (a1 :: k1).
DefaultUni (Esc f)
-> DefaultUni (Esc a1) -> DefaultUni (Esc (f a1))
`DefaultUniApply` DefaultUni (Esc a)
arg'
      | JustSomeType DefaultUni (Esc a)
arg' <- DefaultUni (Esc a1) -> [MaybeSomeTypeOf k1]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkBuiltinSameKind DefaultUni (Esc a1)
arg
      ]
    ]
shrinkDefaultUniApply DefaultUni (Esc a)
_ = []

-- | Kind-preserving shrinking for 'DefaultUni'.
shrinkBuiltinSameKind :: DefaultUni (Esc (a :: k)) -> [MaybeSomeTypeOf k]
shrinkBuiltinSameKind :: forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkBuiltinSameKind DefaultUni (Esc a)
uni = DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkDropBuiltinSameKind DefaultUni (Esc a)
uni [MaybeSomeTypeOf k] -> [MaybeSomeTypeOf k] -> [MaybeSomeTypeOf k]
forall a. [a] -> [a] -> [a]
++ DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkDefaultUniApply DefaultUni (Esc a)
uni

{- Note [Kind-driven generation of built-in types]
The @Arbitrary (MaybeSomeTypeOf k)@ instance is responsible for generating built-in types.

We reflect the kind at the type-level, so that

1. generation of built-in types can be kind-driven
2. and we don't need to do any kind checking at runtime (or 'unsafeCoerce'-ing) in order to
   things into our intrisically kinded representation of built-in types

I.e. we have a correct-by-construction built-in type generator.
-}

-- See Note [Kind-driven generation of built-in types].
instance KnownKind k => Arbitrary (MaybeSomeTypeOf k) where
   arbitrary :: Gen (MaybeSomeTypeOf k)
arbitrary = do
       Int
size <- Gen Int
getSize
       [Gen (MaybeSomeTypeOf k)] -> Gen (MaybeSomeTypeOf k)
forall a. HasCallStack => [Gen a] -> Gen a
oneof ([Gen (MaybeSomeTypeOf k)] -> Gen (MaybeSomeTypeOf k))
-> [Gen (MaybeSomeTypeOf k)] -> Gen (MaybeSomeTypeOf k)
forall a b. (a -> b) -> a -> b
$ case forall k. KnownKind k => SingKind k
knownKind @k of
           SingKind k
SingType ->
               [Gen (MaybeSomeTypeOf k)
forall k. KnownKind k => Gen (MaybeSomeTypeOf k)
genDefaultUniApply | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10] [Gen (MaybeSomeTypeOf k)]
-> [Gen (MaybeSomeTypeOf k)] -> [Gen (MaybeSomeTypeOf k)]
forall a. [a] -> [a] -> [a]
++ (MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k))
-> [MaybeSomeTypeOf k] -> [Gen (MaybeSomeTypeOf k)]
forall a b. (a -> b) -> [a] -> [b]
map MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
               [ DefaultUni (Esc Integer) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc Integer)
DefaultUni (Esc Integer)
DefaultUniInteger
               , DefaultUni (Esc ByteString) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc ByteString)
DefaultUni (Esc ByteString)
DefaultUniByteString
               , DefaultUni (Esc Text) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc Text)
DefaultUni (Esc Text)
DefaultUniString
               , DefaultUni (Esc ()) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc ())
DefaultUni (Esc ())
DefaultUniUnit
               , DefaultUni (Esc Bool) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc Bool)
DefaultUni (Esc Bool)
DefaultUniBool
               , DefaultUni (Esc Data) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc Data)
DefaultUni (Esc Data)
DefaultUniData
               , DefaultUni (Esc Element) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc Element)
DefaultUni (Esc Element)
DefaultUniBLS12_381_G1_Element
               , DefaultUni (Esc Element) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc Element)
DefaultUni (Esc Element)
DefaultUniBLS12_381_G2_Element
               , DefaultUni (Esc MlResult) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc MlResult)
DefaultUni (Esc MlResult)
DefaultUniBLS12_381_MlResult
               ]
           SingKind k1
SingType `SingKindArrow` SingKind l
SingType ->
               [Gen (MaybeSomeTypeOf k)
forall k. KnownKind k => Gen (MaybeSomeTypeOf k)
genDefaultUniApply | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10] [Gen (MaybeSomeTypeOf k)]
-> [Gen (MaybeSomeTypeOf k)] -> [Gen (MaybeSomeTypeOf k)]
forall a. [a] -> [a] -> [a]
++
               [MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k))
-> MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc []) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc [])
DefaultUni (Esc [])
DefaultUniProtoList]
           SingKind k1
SingType `SingKindArrow` SingKind k1
SingType `SingKindArrow` SingKind l
SingType ->
               -- No 'genDefaultUniApply', because we don't have any built-in type constructors
               -- taking three or more arguments.
               [MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k))
-> MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc (,)) -> MaybeSomeTypeOf k
forall k (a :: k). DefaultUni (Esc a) -> MaybeSomeTypeOf k
JustSomeType DefaultUni (Esc (,))
DefaultUni (Esc (,))
DefaultUniProtoPair]
           SingKind k
_ -> [MaybeSomeTypeOf k -> Gen (MaybeSomeTypeOf k)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MaybeSomeTypeOf k
forall k. MaybeSomeTypeOf k
NothingSomeType]

   shrink :: MaybeSomeTypeOf k -> [MaybeSomeTypeOf k]
shrink MaybeSomeTypeOf k
NothingSomeType    = []  -- No shrinks if you don't have anything to shrink.
   shrink (JustSomeType DefaultUni (Esc a)
uni) = DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkBuiltinSameKind DefaultUni (Esc a)
uni

instance Arbitrary (Some (ValueOf DefaultUni)) where
    arbitrary :: Gen (Some (ValueOf DefaultUni))
arbitrary = do
        MaybeSomeTypeOf (*)
mayUni <- Gen (MaybeSomeTypeOf (*))
forall a. Arbitrary a => Gen a
arbitrary
        case MaybeSomeTypeOf (*)
mayUni of
            MaybeSomeTypeOf (*)
NothingSomeType  -> String -> Gen (Some (ValueOf DefaultUni))
forall a. HasCallStack => String -> a
error String
"Panic: no *-kinded built-in types exist"
            JustSomeType DefaultUni (Esc a)
uni ->
                -- IMPORTANT: if you get a type error here saying an instance is missing, add the
                -- missing instance and also update the @Arbitrary (MaybeSomeTypeOf k)@ instance by
                -- adding the relevant type tag to the generator.
                Proxy ArbitraryBuiltin
-> DefaultUni (Esc a)
-> (ArbitraryBuiltin a => Gen (Some (ValueOf DefaultUni)))
-> Gen (Some (ValueOf DefaultUni))
forall (uni :: * -> *) (constr :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a r.
(Closed uni, Everywhere uni constr) =>
proxy constr -> uni (Esc a) -> (constr a => r) -> r
forall (constr :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a r.
Everywhere DefaultUni constr =>
proxy constr -> DefaultUni (Esc a) -> (constr a => r) -> r
bring (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @ArbitraryBuiltin) DefaultUni (Esc a)
uni ((ArbitraryBuiltin a => Gen (Some (ValueOf DefaultUni)))
 -> Gen (Some (ValueOf DefaultUni)))
-> (ArbitraryBuiltin a => Gen (Some (ValueOf DefaultUni)))
-> Gen (Some (ValueOf DefaultUni))
forall a b. (a -> b) -> a -> b
$
                    ValueOf DefaultUni a -> Some (ValueOf DefaultUni)
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some (ValueOf DefaultUni a -> Some (ValueOf DefaultUni))
-> (a -> ValueOf DefaultUni a) -> a -> Some (ValueOf DefaultUni)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultUni (Esc a) -> a -> ValueOf DefaultUni a
forall (uni :: * -> *) a. uni (Esc a) -> a -> ValueOf uni a
ValueOf DefaultUni (Esc a)
uni (a -> Some (ValueOf DefaultUni))
-> Gen a -> Gen (Some (ValueOf DefaultUni))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. ArbitraryBuiltin a => Gen a
arbitraryBuiltin

    shrink :: Some (ValueOf DefaultUni) -> [Some (ValueOf DefaultUni)]
shrink (Some (ValueOf DefaultUni (Esc a)
DefaultUniUnit ())) = []
    shrink (Some (ValueOf DefaultUni (Esc a)
uni a
x))             = () -> Some (ValueOf DefaultUni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
someValue () Some (ValueOf DefaultUni)
-> [Some (ValueOf DefaultUni)] -> [Some (ValueOf DefaultUni)]
forall a. a -> [a] -> [a]
:
        Proxy ArbitraryBuiltin
-> DefaultUni (Esc a)
-> (ArbitraryBuiltin a => [Some (ValueOf DefaultUni)])
-> [Some (ValueOf DefaultUni)]
forall (uni :: * -> *) (constr :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a r.
(Closed uni, Everywhere uni constr) =>
proxy constr -> uni (Esc a) -> (constr a => r) -> r
forall (constr :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a r.
Everywhere DefaultUni constr =>
proxy constr -> DefaultUni (Esc a) -> (constr a => r) -> r
bring (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @ArbitraryBuiltin) DefaultUni (Esc a)
uni ((a -> Some (ValueOf DefaultUni))
-> [a] -> [Some (ValueOf DefaultUni)]
forall a b. (a -> b) -> [a] -> [b]
map (ValueOf DefaultUni a -> Some (ValueOf DefaultUni)
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some (ValueOf DefaultUni a -> Some (ValueOf DefaultUni))
-> (a -> ValueOf DefaultUni a) -> a -> Some (ValueOf DefaultUni)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultUni (Esc a) -> a -> ValueOf DefaultUni a
forall (uni :: * -> *) a. uni (Esc a) -> a -> ValueOf uni a
ValueOf DefaultUni (Esc a)
uni) ([a] -> [Some (ValueOf DefaultUni)])
-> [a] -> [Some (ValueOf DefaultUni)]
forall a b. (a -> b) -> a -> b
$ a -> [a]
forall a. ArbitraryBuiltin a => a -> [a]
shrinkBuiltin a
x)

-- | Generate a built-in type of a given kind.
genBuiltinTypeOf :: Kind () -> Gen (Maybe (SomeTypeIn DefaultUni))
genBuiltinTypeOf :: Kind () -> Gen (Maybe (SomeTypeIn DefaultUni))
genBuiltinTypeOf Kind ()
kind =
    -- See Note [Kind-driven generation of built-in types].
    Kind ()
-> (forall {k}.
    KnownKind k =>
    Proxy k -> Gen (Maybe (SomeTypeIn DefaultUni)))
-> Gen (Maybe (SomeTypeIn DefaultUni))
forall ann r.
Kind ann -> (forall k. KnownKind k => Proxy k -> r) -> r
withKnownKind Kind ()
kind ((forall {k}.
  KnownKind k =>
  Proxy k -> Gen (Maybe (SomeTypeIn DefaultUni)))
 -> Gen (Maybe (SomeTypeIn DefaultUni)))
-> (forall {k}.
    KnownKind k =>
    Proxy k -> Gen (Maybe (SomeTypeIn DefaultUni)))
-> Gen (Maybe (SomeTypeIn DefaultUni))
forall a b. (a -> b) -> a -> b
$ \(Proxy k
_ :: Proxy kind) ->
        MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
forall k. MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
eraseMaybeSomeTypeOf (MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni))
-> Gen (MaybeSomeTypeOf k) -> Gen (Maybe (SomeTypeIn DefaultUni))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary @(MaybeSomeTypeOf kind)

-- | Shrink a built-in type by dropping a part of it or dropping the whole built-in type in favor of
-- a some minimal one (see 'shrinkDropBuiltinSameKind'). The kind is not preserved in the general
-- case.
shrinkDropBuiltin :: DefaultUni (Esc (a :: k)) -> [SomeTypeIn DefaultUni]
shrinkDropBuiltin :: forall k (a :: k). DefaultUni (Esc a) -> [SomeTypeIn DefaultUni]
shrinkDropBuiltin DefaultUni (Esc a)
uni = [[SomeTypeIn DefaultUni]] -> [SomeTypeIn DefaultUni]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ case DefaultUni (Esc a) -> SingKind k
forall k (a :: k). DefaultUni (Esc a) -> SingKind k
forall (uni :: * -> *) k (a :: k).
ToKind uni =>
uni (Esc a) -> SingKind k
toSingKind DefaultUni (Esc a)
uni of
          SingKind k1
SingType `SingKindArrow` SingKind l
_ -> DefaultUni (Esc (a ())) -> [SomeTypeIn DefaultUni]
forall k (a :: k). DefaultUni (Esc a) -> [SomeTypeIn DefaultUni]
shrinkDropBuiltin (DefaultUni (Esc (a ())) -> [SomeTypeIn DefaultUni])
-> DefaultUni (Esc (a ())) -> [SomeTypeIn DefaultUni]
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc a)
DefaultUni (Esc a)
uni DefaultUni (Esc a)
-> DefaultUni (Esc ()) -> DefaultUni (Esc (a ()))
forall {k1} {k2} (f :: k1 -> k2) (a1 :: k1).
DefaultUni (Esc f)
-> DefaultUni (Esc a1) -> DefaultUni (Esc (f a1))
`DefaultUniApply` DefaultUni (Esc ())
DefaultUniUnit
          SingKind k
_                          -> []
    , (MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni))
-> [MaybeSomeTypeOf k] -> [SomeTypeIn DefaultUni]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
forall k. MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
eraseMaybeSomeTypeOf ([MaybeSomeTypeOf k] -> [SomeTypeIn DefaultUni])
-> [MaybeSomeTypeOf k] -> [SomeTypeIn DefaultUni]
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkDropBuiltinSameKind DefaultUni (Esc a)
uni
    ]

-- TODO: have proper tests
-- >>> :set -XTypeApplications
-- >>> import PlutusCore.Pretty
-- >>> import PlutusCore.Default
-- >>> mapM_ (putStrLn . display) . shrinkBuiltinType $ someType @_ @[Bool]
-- unit
-- bool
-- (list unit)
-- >>> mapM_ (putStrLn . display) . shrinkBuiltinType $ someType @_ @(,)
-- unit
-- list
-- >>> mapM_ (putStrLn . display) . shrinkBuiltinType $ someType @_ @((,) Integer)
-- unit
-- integer
-- list
-- (pair unit)
-- >>> mapM_ (putStrLn . display) . shrinkBuiltinType $ someType @_ @((), Integer)
-- unit
-- integer
-- (list integer)
-- (pair unit unit)
-- >>> mapM_ (putStrLn . display) . shrinkBuiltinType $ someType @_ @([Bool], Integer)
-- unit
-- (list bool)
-- integer
-- (list integer)
-- (pair unit integer)
-- (pair bool integer)
-- (pair (list unit) integer)
-- (pair (list bool) unit)
-- | Non-kind-preserving shrinking for 'DefaultUni'.
shrinkBuiltinType :: SomeTypeIn DefaultUni -> [SomeTypeIn DefaultUni]
shrinkBuiltinType :: SomeTypeIn DefaultUni -> [SomeTypeIn DefaultUni]
shrinkBuiltinType (SomeTypeIn DefaultUni (Esc a)
uni) = [[SomeTypeIn DefaultUni]] -> [SomeTypeIn DefaultUni]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ DefaultUni (Esc a) -> [SomeTypeIn DefaultUni]
forall k (a :: k). DefaultUni (Esc a) -> [SomeTypeIn DefaultUni]
shrinkDropBuiltin DefaultUni (Esc a)
uni
    , (MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni))
-> [MaybeSomeTypeOf k] -> [SomeTypeIn DefaultUni]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
forall k. MaybeSomeTypeOf k -> Maybe (SomeTypeIn DefaultUni)
eraseMaybeSomeTypeOf ([MaybeSomeTypeOf k] -> [SomeTypeIn DefaultUni])
-> [MaybeSomeTypeOf k] -> [SomeTypeIn DefaultUni]
forall a b. (a -> b) -> a -> b
$ DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
forall k (a :: k). DefaultUni (Esc a) -> [MaybeSomeTypeOf k]
shrinkDefaultUniApply DefaultUni (Esc a)
uni
    ]

instance Arbitrary (SomeTypeIn DefaultUni) where
    arbitrary :: Gen (SomeTypeIn DefaultUni)
arbitrary = Gen (Kind ())
genKindOfBuiltin Gen (Kind ())
-> (Kind () -> Gen (SomeTypeIn DefaultUni))
-> Gen (SomeTypeIn DefaultUni)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Gen (Maybe (SomeTypeIn DefaultUni))
-> (Maybe (SomeTypeIn DefaultUni) -> Maybe (SomeTypeIn DefaultUni))
-> Gen (SomeTypeIn DefaultUni)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` Maybe (SomeTypeIn DefaultUni) -> Maybe (SomeTypeIn DefaultUni)
forall a. a -> a
id) (Gen (Maybe (SomeTypeIn DefaultUni))
 -> Gen (SomeTypeIn DefaultUni))
-> (Kind () -> Gen (Maybe (SomeTypeIn DefaultUni)))
-> Kind ()
-> Gen (SomeTypeIn DefaultUni)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind () -> Gen (Maybe (SomeTypeIn DefaultUni))
genBuiltinTypeOf where
        genKindOfBuiltin :: Gen (Kind ())
genKindOfBuiltin = [(Int, Gen (Kind ()))] -> Gen (Kind ())
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
            [ (Int
8, Kind () -> Gen (Kind ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind () -> Gen (Kind ())) -> Kind () -> Gen (Kind ())
forall a b. (a -> b) -> a -> b
$ () -> Kind ()
forall ann. ann -> Kind ann
Type ())
            , (Int
1, Kind () -> Gen (Kind ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind () -> Gen (Kind ()))
-> (Kind () -> Kind ()) -> Kind () -> Gen (Kind ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Kind () -> Kind () -> Kind ()
forall ann. ann -> Kind ann -> Kind ann -> Kind ann
KindArrow () (() -> Kind ()
forall ann. ann -> Kind ann
Type ()) (Kind () -> Gen (Kind ())) -> Kind () -> Gen (Kind ())
forall a b. (a -> b) -> a -> b
$ () -> Kind ()
forall ann. ann -> Kind ann
Type ())
            , (Int
1, Kind () -> Gen (Kind ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind () -> Gen (Kind ()))
-> (Kind () -> Kind ()) -> Kind () -> Gen (Kind ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Kind () -> Kind () -> Kind ()
forall ann. ann -> Kind ann -> Kind ann -> Kind ann
KindArrow () (() -> Kind ()
forall ann. ann -> Kind ann
Type ()) (Kind () -> Kind ()) -> (Kind () -> Kind ()) -> Kind () -> Kind ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Kind () -> Kind () -> Kind ()
forall ann. ann -> Kind ann -> Kind ann -> Kind ann
KindArrow () (() -> Kind ()
forall ann. ann -> Kind ann
Type ()) (Kind () -> Gen (Kind ())) -> Kind () -> Gen (Kind ())
forall a b. (a -> b) -> a -> b
$ () -> Kind ()
forall ann. ann -> Kind ann
Type ())
            ]
    shrink :: SomeTypeIn DefaultUni -> [SomeTypeIn DefaultUni]
shrink = SomeTypeIn DefaultUni -> [SomeTypeIn DefaultUni]
shrinkBuiltinType