{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Cardano.Ledger.Huddle.Gen (
  -- * MonadGen
  module GenT,

  -- * Custom core
  module CustomCore,

  -- * Term generators
  module CustomGen,
  Term (..),
  RuleTerm (..),
  Name (..),
  genRule,
  generateFromName,
  generateFromGRef,
  genArrayTerm,
  genBytesTerm,
  genStringTerm,
  genMapTerm,
  unwrapSingleOrError,

  -- * Term validators
  module CustomValidator,
  validateFromName,
  validateFromGRef,
  validateInt,
  validateUInt,
  validateNInt,
  validateArrayTerm,
  validateBytesTerm,
  validateStringTerm,
  validateMapTerm,
  unwrapSingle,

  -- * Lifted generators
  arbitrary,
  scale,
  shuffle,

  -- * Antigen
  module AntiGen,
  antiVectorOfUnique,
  antiVectorOfUniqueBy,
  antiVectorOfUniqueOn,
) where

import Cardano.Ledger.Binary (Term (..))
import Cardano.Ledger.Huddle (HuddleRule ())
import Codec.CBOR.Cuddle.CBOR.Gen (generateFromGRef, generateFromName)
import Codec.CBOR.Cuddle.CBOR.Validator (validateFromGRef, validateFromName)
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.CDDL.CTree (nintMin, uintMax)
import Codec.CBOR.Cuddle.CDDL.Custom.Core as CustomCore
import Codec.CBOR.Cuddle.CDDL.Custom.Generator as CustomGen
import Codec.CBOR.Cuddle.CDDL.Custom.Validator as CustomValidator
import Control.Monad.Reader (asks)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Function (on)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import GHC.TypeLits (symbolVal)
import Test.AntiGen as AntiGen
import qualified Test.QuickCheck as QC
import Test.QuickCheck.GenT as GenT

-- | A function for generating a term from a rule. The @HuddleRule@ constraint
-- ensures that the rule is actually defined in that era.
genRule :: forall rule era. HuddleRule rule era => CBORGen Term
genRule :: forall (rule :: Symbol) era. HuddleRule rule era => CBORGen Term
genRule = HasCallStack => Name -> CBORGen Term
Name -> CBORGen Term
generateFromName (Text -> Name
Name (Text -> Name) -> (Proxy rule -> Text) -> Proxy rule -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Proxy rule -> String) -> Proxy rule -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy rule -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy rule -> Name) -> Proxy rule -> Name
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @rule)

-- Lifted Gen functions

arbitrary :: forall a m. (MonadGen m, QC.Arbitrary a) => m a
arbitrary :: forall a (m :: * -> *). (MonadGen m, Arbitrary a) => m a
arbitrary = Gen a -> m a
forall a. Gen a -> m a
forall (g :: * -> *) a. MonadGen g => Gen a -> g a
liftGen Gen a
forall a. Arbitrary a => Gen a
QC.arbitrary

scale :: MonadGen m => (Int -> Int) -> m a -> m a
scale :: forall (m :: * -> *) a. MonadGen m => (Int -> Int) -> m a -> m a
scale Int -> Int
f m a
m = (Int -> m a) -> m a
forall a. (Int -> m a) -> m a
forall (g :: * -> *) a. MonadGen g => (Int -> g a) -> g a
sized ((Int -> m a) -> m a) -> (Int -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Int
sz -> Int -> m a -> m a
forall a. Int -> m a -> m a
forall (g :: * -> *) a. MonadGen g => Int -> g a -> g a
resize (Int -> Int
f Int
sz) m a
m

shuffle :: MonadGen m => [a] -> m [a]
shuffle :: forall (m :: * -> *) a. MonadGen m => [a] -> m [a]
shuffle = Gen [a] -> m [a]
forall a. Gen a -> m a
forall (g :: * -> *) a. MonadGen g => Gen a -> g a
liftGen (Gen [a] -> m [a]) -> ([a] -> Gen [a]) -> [a] -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Gen [a]
forall a. [a] -> Gen [a]
QC.shuffle

-- Term generators

-- | Generate a list of @n@ pairwise-distinct elements. Returns 'Nothing' if
-- the underlying generator could not produce enough distinct elements within
-- the per-element retry budget.
antiVectorOfUnique :: Eq a => Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUnique :: forall a. Eq a => Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUnique = (a -> a -> Bool) -> Int -> AntiGen a -> AntiGen (Maybe [a])
forall a.
(a -> a -> Bool) -> Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUniqueBy a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | Like 'antiVectorOfUnique', but compares elements by a key projection.
antiVectorOfUniqueOn :: Eq b => (a -> b) -> Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUniqueOn :: forall b a.
Eq b =>
(a -> b) -> Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUniqueOn a -> b
key = (a -> a -> Bool) -> Int -> AntiGen a -> AntiGen (Maybe [a])
forall a.
(a -> a -> Bool) -> Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUniqueBy (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool) -> (a -> b) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
key)

-- | Like 'antiVectorOfUnique', but takes a user-supplied equivalence relation.
antiVectorOfUniqueBy :: (a -> a -> Bool) -> Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUniqueBy :: forall a.
(a -> a -> Bool) -> Int -> AntiGen a -> AntiGen (Maybe [a])
antiVectorOfUniqueBy a -> a -> Bool
eq Int
n AntiGen a
gen = do
  disallowDuplicates <- Bool -> AntiGen Bool
faultyBool Bool
True
  let
    triesPerElement = Int
10 :: Int
    go t
_ Int
0 [a]
_ = Maybe [a] -> AntiGen (Maybe [a])
forall a. a -> AntiGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [a]
forall a. Maybe a
Nothing
    go t
m Int
tries [a]
elems
      | t
m t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0 = do
          x <- AntiGen a
gen
          if disallowDuplicates && any (eq x) elems
            then go m (tries - 1) elems
            else go (m - 1) triesPerElement (x : elems)
      | Bool
otherwise = Maybe [a] -> AntiGen (Maybe [a])
forall a. a -> AntiGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
elems)
  go n triesPerElement []

genArrayTerm :: [Term] -> CBORGen Term
genArrayTerm :: [Term] -> CBORGen Term
genArrayTerm [Term]
es =
  CBORGen Term -> CBORGen Term -> CBORGen Term
forall a. CBORGen a -> CBORGen a -> CBORGen a
ifTwiddle ([Term] -> CBORGen Term
forall (m :: * -> *) a. MonadGen m => [a] -> m a
GenT.elements [[Term] -> Term
TList [Term]
es, [Term] -> Term
TListI [Term]
es]) (Term -> CBORGen Term
forall a. a -> CBORGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> CBORGen Term) -> Term -> CBORGen Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Term
TList [Term]
es)

genBytesTerm :: ByteString -> CBORGen Term
genBytesTerm :: ByteString -> CBORGen Term
genBytesTerm ByteString
bs =
  CBORGen Term -> CBORGen Term -> CBORGen Term
forall a. CBORGen a -> CBORGen a -> CBORGen a
ifTwiddle ([Term] -> CBORGen Term
forall (m :: * -> *) a. MonadGen m => [a] -> m a
GenT.elements [ByteString -> Term
TBytes ByteString
bs, ByteString -> Term
TBytesI (ByteString -> Term) -> ByteString -> Term
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs]) (Term -> CBORGen Term
forall a. a -> CBORGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> CBORGen Term) -> Term -> CBORGen Term
forall a b. (a -> b) -> a -> b
$ ByteString -> Term
TBytes ByteString
bs)

genStringTerm :: T.Text -> CBORGen Term
genStringTerm :: Text -> CBORGen Term
genStringTerm Text
t =
  CBORGen Term -> CBORGen Term -> CBORGen Term
forall a. CBORGen a -> CBORGen a -> CBORGen a
ifTwiddle ([Term] -> CBORGen Term
forall (m :: * -> *) a. MonadGen m => [a] -> m a
GenT.elements [Text -> Term
TString Text
t, Text -> Term
TStringI (Text -> Term) -> Text -> Term
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.fromStrict Text
t]) (Term -> CBORGen Term
forall a. a -> CBORGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> CBORGen Term) -> Term -> CBORGen Term
forall a b. (a -> b) -> a -> b
$ Text -> Term
TString Text
t)

genMapTerm :: [(Term, Term)] -> CBORGen Term
genMapTerm :: [(Term, Term)] -> CBORGen Term
genMapTerm [(Term, Term)]
m =
  CBORGen Term -> CBORGen Term -> CBORGen Term
forall a. CBORGen a -> CBORGen a -> CBORGen a
ifTwiddle ([Term] -> CBORGen Term
forall (m :: * -> *) a. MonadGen m => [a] -> m a
GenT.elements [[(Term, Term)] -> Term
TMap [(Term, Term)]
m, [(Term, Term)] -> Term
TMapI [(Term, Term)]
m]) (Term -> CBORGen Term
forall a. a -> CBORGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> CBORGen Term) -> Term -> CBORGen Term
forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Term
TMap [(Term, Term)]
m)

ifTwiddle :: CBORGen a -> CBORGen a -> CBORGen a
ifTwiddle :: forall a. CBORGen a -> CBORGen a -> CBORGen a
ifTwiddle CBORGen a
yes CBORGen a
no = do
  twiddle <- (GenEnv -> Bool) -> CBORGen Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (GenConfig -> Bool
gcTwiddle (GenConfig -> Bool) -> (GenEnv -> GenConfig) -> GenEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEnv -> GenConfig
geConfig)
  if twiddle then yes else no

-- Term validators

validateInt :: Term -> Validator Integer
validateInt :: Term -> Validator Integer
validateInt (TInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger -> Integer
x))
  | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
nintMin Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
uintMax = Integer -> Validator Integer
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  | Bool
otherwise = String -> Validator Integer
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Number not in int range"
validateInt Term
_ = String -> Validator Integer
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected int"

validateUInt :: Term -> Validator Integer
validateUInt :: Term -> Validator Integer
validateUInt (TInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger -> Integer
x))
  | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
uintMax = Integer -> Validator Integer
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  | Bool
otherwise = String -> Validator Integer
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Number not in uint range"
validateUInt Term
_ = String -> Validator Integer
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected uint"

validateNInt :: Term -> Validator Integer
validateNInt :: Term -> Validator Integer
validateNInt (TInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger -> Integer
x))
  | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
nintMin Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = Integer -> Validator Integer
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
x
  | Bool
otherwise = String -> Validator Integer
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Number not in nint range"
validateNInt Term
_ = String -> Validator Integer
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected nint"

validateArrayTerm :: Term -> Validator [Term]
validateArrayTerm :: Term -> Validator [Term]
validateArrayTerm (TList [Term]
xs) = [Term] -> Validator [Term]
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term]
xs
validateArrayTerm (TListI [Term]
xs) = [Term] -> Validator [Term]
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term]
xs
validateArrayTerm Term
_ = String -> Validator [Term]
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected list"

validateBytesTerm :: Term -> Validator ByteString
validateBytesTerm :: Term -> Validator ByteString
validateBytesTerm (TBytes ByteString
bs) = ByteString -> Validator ByteString
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
validateBytesTerm (TBytesI ByteString
bs) = ByteString -> Validator ByteString
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Validator ByteString)
-> ByteString -> Validator ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
bs
validateBytesTerm Term
_ = String -> Validator ByteString
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected bytes"

validateStringTerm :: Term -> Validator Text
validateStringTerm :: Term -> Validator Text
validateStringTerm (TString Text
x) = Text -> Validator Text
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
validateStringTerm (TStringI Text
x) = Text -> Validator Text
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Validator Text) -> Text -> Validator Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict Text
x
validateStringTerm Term
_ = String -> Validator Text
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected string"

validateMapTerm :: Term -> Validator [(Term, Term)]
validateMapTerm :: Term -> Validator [(Term, Term)]
validateMapTerm (TMap [(Term, Term)]
xs) = [(Term, Term)] -> Validator [(Term, Term)]
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Term, Term)]
xs
validateMapTerm (TMapI [(Term, Term)]
xs) = [(Term, Term)] -> Validator [(Term, Term)]
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Term, Term)]
xs
validateMapTerm Term
_ = String -> Validator [(Term, Term)]
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected map"

unwrapSingle :: RuleTerm -> Validator Term
unwrapSingle :: RuleTerm -> Validator Term
unwrapSingle (SingleTerm Term
x) = Term -> Validator Term
forall a. a -> Validator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
x
unwrapSingle RuleTerm
_ = String -> Validator Term
forall a. String -> Validator a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected a single term"

unwrapSingleOrError :: RuleTerm -> Term
unwrapSingleOrError :: RuleTerm -> Term
unwrapSingleOrError (SingleTerm Term
x) = Term
x
unwrapSingleOrError RuleTerm
_ = String -> Term
forall a. HasCallStack => String -> a
error String
"Expected a single term"