{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Babbage.Serialisation.Generators where

import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Tx
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.Binary (Sized, Term (..))
import Cardano.Ledger.Shelley.PParams (Update (..))
import Cardano.Ledger.Val (Val)
import Data.Maybe (catMaybes)
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Binary.Twiddle (Twiddle (..), emptyOrNothing, toTerm, twiddleStrictMaybe)
import Test.QuickCheck

instance EraPParams era => Twiddle (Update era) where
  twiddle :: Version -> Update era -> Gen Term
twiddle Version
v = Version -> Term -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Term -> Gen Term)
-> (Update era -> Term) -> Update era -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Update era -> Term
forall a. EncCBOR a => Version -> a -> Term
toTerm Version
v

instance Twiddle a => Twiddle (Sized a)

instance (EraScript era, Val (Value era)) => Twiddle (BabbageTxOut era) where
  twiddle :: Version -> BabbageTxOut era -> Gen Term
twiddle Version
v = Version -> Term -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Term -> Gen Term)
-> (BabbageTxOut era -> Term) -> BabbageTxOut era -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> BabbageTxOut era -> Term
forall a. EncCBOR a => Version -> a -> Term
toTerm Version
v

instance Twiddle (TxBody BabbageEra) where
  twiddle :: Version -> TxBody BabbageEra -> Gen Term
twiddle Version
v TxBody BabbageEra
txBody = do
    Term
inputs' <- Version -> Set TxIn -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Set TxIn -> Gen Term) -> Set TxIn -> Gen Term
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> Set TxIn
btbInputs TxBody BabbageEra
txBody
    Term
outputs' <- Version -> StrictSeq (Sized (TxOut BabbageEra)) -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (StrictSeq (Sized (TxOut BabbageEra)) -> Gen Term)
-> StrictSeq (Sized (TxOut BabbageEra)) -> Gen Term
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictSeq (Sized (TxOut BabbageEra))
btbOutputs TxBody BabbageEra
txBody
    Term
fee' <- Version -> Coin -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Coin -> Gen Term) -> Coin -> Gen Term
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> Coin
btbTxFee TxBody BabbageEra
txBody
    -- Empty collateral can be represented by empty set or the
    -- value can be omitted entirely
    Maybe Term
ttl' <- Version -> StrictMaybe SlotNo -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe SlotNo -> Gen (Maybe Term))
-> (ValidityInterval -> StrictMaybe SlotNo)
-> ValidityInterval
-> Gen (Maybe Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidityInterval -> StrictMaybe SlotNo
invalidHereafter (ValidityInterval -> Gen (Maybe Term))
-> ValidityInterval -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> ValidityInterval
btbValidityInterval TxBody BabbageEra
txBody
    Maybe Term
cert' <- Version -> StrictSeq (TxCert BabbageEra) -> Gen (Maybe Term)
forall (t :: * -> *) b.
(Foldable t, Twiddle (t Void), Monoid (t Void), Twiddle (t b)) =>
Version -> t b -> Gen (Maybe Term)
emptyOrNothing Version
v (StrictSeq (TxCert BabbageEra) -> Gen (Maybe Term))
-> StrictSeq (TxCert BabbageEra) -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictSeq (TxCert BabbageEra)
btbCerts TxBody BabbageEra
txBody
    Term
withdrawals' <- Version -> Withdrawals -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (Withdrawals -> Gen Term) -> Withdrawals -> Gen Term
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> Withdrawals
btbWithdrawals TxBody BabbageEra
txBody
    Maybe Term
update' <- Version -> StrictMaybe (Update BabbageEra) -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe (Update BabbageEra) -> Gen (Maybe Term))
-> StrictMaybe (Update BabbageEra) -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictMaybe (Update BabbageEra)
btbUpdate TxBody BabbageEra
txBody
    Maybe Term
auxDataHash' <- Version -> StrictMaybe TxAuxDataHash -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe TxAuxDataHash -> Gen (Maybe Term))
-> StrictMaybe TxAuxDataHash -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictMaybe TxAuxDataHash
btbAuxDataHash TxBody BabbageEra
txBody
    Maybe Term
validityStart' <- Version -> StrictMaybe SlotNo -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe SlotNo -> Gen (Maybe Term))
-> (ValidityInterval -> StrictMaybe SlotNo)
-> ValidityInterval
-> Gen (Maybe Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidityInterval -> StrictMaybe SlotNo
invalidBefore (ValidityInterval -> Gen (Maybe Term))
-> ValidityInterval -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> ValidityInterval
btbValidityInterval TxBody BabbageEra
txBody
    Term
mint' <- Version -> MultiAsset -> Gen Term
forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v (MultiAsset -> Gen Term) -> MultiAsset -> Gen Term
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> MultiAsset
btbMint TxBody BabbageEra
txBody
    Maybe Term
scriptDataHash' <- Version -> StrictMaybe ScriptIntegrityHash -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe ScriptIntegrityHash -> Gen (Maybe Term))
-> StrictMaybe ScriptIntegrityHash -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictMaybe ScriptIntegrityHash
btbScriptIntegrityHash TxBody BabbageEra
txBody
    Maybe Term
collateral' <- Version -> Set TxIn -> Gen (Maybe Term)
forall (t :: * -> *) b.
(Foldable t, Twiddle (t Void), Monoid (t Void), Twiddle (t b)) =>
Version -> t b -> Gen (Maybe Term)
emptyOrNothing Version
v (Set TxIn -> Gen (Maybe Term)) -> Set TxIn -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> Set TxIn
btbCollateral TxBody BabbageEra
txBody
    Maybe Term
requiredSigners' <- Version -> Set (KeyHash 'Witness) -> Gen (Maybe Term)
forall (t :: * -> *) b.
(Foldable t, Twiddle (t Void), Monoid (t Void), Twiddle (t b)) =>
Version -> t b -> Gen (Maybe Term)
emptyOrNothing Version
v (Set (KeyHash 'Witness) -> Gen (Maybe Term))
-> Set (KeyHash 'Witness) -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> Set (KeyHash 'Witness)
btbReqSignerHashes TxBody BabbageEra
txBody
    Maybe Term
networkId' <- Version -> StrictMaybe Network -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe Network -> Gen (Maybe Term))
-> StrictMaybe Network -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictMaybe Network
btbTxNetworkId TxBody BabbageEra
txBody
    Maybe Term
collateralReturn <- Version
-> StrictMaybe (Sized (TxOut BabbageEra)) -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe (Sized (TxOut BabbageEra)) -> Gen (Maybe Term))
-> StrictMaybe (Sized (TxOut BabbageEra)) -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictMaybe (Sized (TxOut BabbageEra))
btbCollateralReturn TxBody BabbageEra
txBody
    Maybe Term
totalCollateral <- Version -> StrictMaybe Coin -> Gen (Maybe Term)
forall a. Twiddle a => Version -> StrictMaybe a -> Gen (Maybe Term)
twiddleStrictMaybe Version
v (StrictMaybe Coin -> Gen (Maybe Term))
-> StrictMaybe Coin -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> StrictMaybe Coin
btbTotalCollateral TxBody BabbageEra
txBody
    Maybe Term
referenceInputs <- Version -> Set TxIn -> Gen (Maybe Term)
forall (t :: * -> *) b.
(Foldable t, Twiddle (t Void), Monoid (t Void), Twiddle (t b)) =>
Version -> t b -> Gen (Maybe Term)
emptyOrNothing Version
v (Set TxIn -> Gen (Maybe Term)) -> Set TxIn -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ TxBody BabbageEra -> Set TxIn
btbReferenceInputs TxBody BabbageEra
txBody
    [(Term, Term)] -> Term
mp <- [[(Term, Term)] -> Term] -> Gen ([(Term, Term)] -> Term)
forall a. HasCallStack => [a] -> Gen a
elements [[(Term, Term)] -> Term
TMap, [(Term, Term)] -> Term
TMapI]
    let fields :: [(Term, Term)]
fields =
          [ (Int -> Term
TInt Int
0, Term
inputs')
          , (Int -> Term
TInt Int
1, Term
outputs')
          , (Int -> Term
TInt Int
2, Term
fee')
          ]
            [(Term, Term)] -> [(Term, Term)] -> [(Term, Term)]
forall a. Semigroup a => a -> a -> a
<> [Maybe (Term, Term)] -> [(Term, Term)]
forall a. [Maybe a] -> [a]
catMaybes
              [ (Int -> Term
TInt Int
3,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
ttl'
              , (Int -> Term
TInt Int
4,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
cert'
              , (Int -> Term
TInt Int
5,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Maybe Term
forall a. a -> Maybe a
Just Term
withdrawals'
              , (Int -> Term
TInt Int
6,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
update'
              , (Int -> Term
TInt Int
7,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
auxDataHash'
              , (Int -> Term
TInt Int
8,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
validityStart'
              , (Int -> Term
TInt Int
9,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Maybe Term
forall a. a -> Maybe a
Just Term
mint'
              , (Int -> Term
TInt Int
11,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
scriptDataHash'
              , (Int -> Term
TInt Int
13,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
collateral'
              , (Int -> Term
TInt Int
14,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
requiredSigners'
              , (Int -> Term
TInt Int
15,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
networkId'
              , (Int -> Term
TInt Int
16,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
collateralReturn
              , (Int -> Term
TInt Int
17,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
totalCollateral
              , (Int -> Term
TInt Int
18,) (Term -> (Term, Term)) -> Maybe Term -> Maybe (Term, Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term
referenceInputs
              ]
    [(Term, Term)]
fields' <- [(Term, Term)] -> Gen [(Term, Term)]
forall a. [a] -> Gen [a]
shuffle [(Term, Term)]
fields
    Term -> Gen Term
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> Gen Term) -> Term -> Gen Term
forall a b. (a -> b) -> a -> b
$ [(Term, Term)] -> Term
mp [(Term, Term)]
fields'