{-# 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.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 = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Twiddle a => Version -> a -> Gen Term
twiddle Version
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => Version -> a -> Term
toTerm Version
v

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