-- 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.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 'Int64' 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 at least occasionally generate some larger ones, which is what the 'Arbitrary'
instance for 'Int64' does:

    >>> import Data.Int
    >>> fmap (any ((> 10000) . abs) . concat . concat . concat) . sample' $ arbitrary @[[[Int64]]]
    True

For this reason we use 'Int64' when dealing with QuickCheck.
-}

-- | A list of ranges: @[(0, 10), (11, 100), (101, 1000), ... (10^n + 1, high)]@ when
-- @base = 10@.
magnitudesPositive :: Integral a => a -> a -> [(a, a)]
magnitudesPositive :: forall a. Integral a => a -> a -> [(a, a)]
magnitudesPositive a
base a
high =
    (a -> a -> (a, a)) -> [a] -> [a] -> [(a, a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a
lo a
hi -> (a
lo a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, a
hi)) [a]
borders ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
borders)
  where
    preborders :: [a]
preborders = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail ([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. Ord a => a -> a -> Bool
< a
high a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
base) ([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. Num a => a -> a -> a
* a
base) a
1
    borders :: [a]
borders = -a
1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
preborders [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [[a] -> a
forall a. HasCallStack => [a] -> a
last [a]
preborders a -> a -> a
forall a. Num a => a -> a -> a
* a
base, a
high]

-- | Like 'chooseBoundedIntegral', but doesn't require the 'Bounded' constraint (and hence is slower
-- for 'Word64' and 'Int64').
chooseIntegral :: Integral a => (a, a) -> Gen a
chooseIntegral :: forall a. Integral a => (a, a) -> Gen a
chooseIntegral (a
lo, a
hi) = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a) -> Gen Integer -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
chooseInteger (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
lo, a -> Integer
forall a. Integral a => a -> Integer
toInteger a
hi)

-- | Generate asymptotically greater positive numbers with exponentially lower chance.
arbitraryPositive :: Integral a => a -> a -> Gen a
arbitraryPositive :: forall a. Integral a => a -> a -> Gen a
arbitraryPositive a
base a
high =
    [(Int, Gen a)] -> Gen a
forall a. [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen a)] -> Gen a)
-> ([(a, a)] -> [(Int, Gen a)]) -> [(a, a)] -> Gen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Gen a] -> [(Int, Gen a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
freqs ([Gen a] -> [(Int, Gen a)])
-> ([(a, a)] -> [Gen a]) -> [(a, a)] -> [(Int, Gen a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Gen a] -> [Gen a]
forall a. [a] -> [a]
reverse ([Gen a] -> [Gen a])
-> ([(a, a)] -> [Gen a]) -> [(a, a)] -> [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, a) -> Gen a) -> [(a, a)] -> [Gen a]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> Gen a
forall a. Integral a => (a, a) -> Gen a
chooseIntegral ([(a, a)] -> Gen a) -> [(a, a)] -> Gen a
forall a b. (a -> b) -> a -> b
$ a -> a -> [(a, a)]
forall a. Integral a => a -> a -> [(a, a)]
magnitudesPositive a
base a
high
  where
    freqs :: [Int]
freqs = (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.3) (Double
2 :: Double)

-- | Generate asymptotically greater negative numbers with exponentially lower chance.
arbitraryNegative :: Integral a => a -> a -> Gen a
arbitraryNegative :: forall a. Integral a => a -> a -> Gen a
arbitraryNegative a
base a
high = a -> a
forall a. Num a => a -> a
negate (a -> a) -> Gen a -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> Gen a
forall a. Integral a => a -> a -> Gen a
arbitraryPositive a
base a
high

-- | Generate asymptotically greater numbers with exponentially lower chance.
arbitrarySigned :: Integral a => a -> a -> Gen a
arbitrarySigned :: forall a. Integral a => a -> a -> Gen a
arbitrarySigned a
base a
high = [Gen a] -> Gen a
forall a. [Gen a] -> Gen a
oneof [a -> a -> Gen a
forall a. Integral a => a -> a -> Gen a
arbitraryPositive a
base a
high, a -> a -> Gen a
forall a. Integral a => a -> a -> Gen a
arbitraryNegative a
base a
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
    arbitraryBuiltin :: Gen Integer
arbitraryBuiltin = [(Int, Gen Integer)] -> Gen Integer
forall a. [(Int, Gen a)] -> Gen a
frequency
        [ (Int
4, forall a. Arbitrary a => Gen a
arbitrary @Integer)
        -- See Note [QuickCheck and integral types].
        , (Int
1, Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Gen Int64 -> Gen Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> Int64 -> Gen Int64
forall a. Integral a => a -> a -> Gen a
arbitrarySigned Int64
10 (Int64
forall a. Bounded a => a
maxBound :: Int64))
        ]
    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. [(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
forall a. Num a => a -> a
abs (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. [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. [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. [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. [(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. [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 ->
                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
-- >>> 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
    ]