{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Babbage.Binary.Twiddle () 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.Binary.Twiddle ()
import Test.Cardano.Ledger.Binary.Twiddle (Twiddle (..), emptyOrNothing, toTerm, twiddleStrictMaybe)
import Test.Cardano.Ledger.Common

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'