{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Babbage.Tx (
  AlonzoTx (..),
  BabbageTxBody (..),
  module X,
)
where

import Cardano.Ledger.Allegra.Tx (validateTimelock)
import Cardano.Ledger.Alonzo.Tx as X
import Cardano.Ledger.Alonzo.TxSeq (
  AlonzoTxSeq (AlonzoTxSeq, txSeqTxns),
  hashAlonzoTxSeq,
 )
import Cardano.Ledger.Babbage.Era (BabbageEra)
import Cardano.Ledger.Babbage.TxAuxData ()
import Cardano.Ledger.Babbage.TxBody (
  BabbageTxBody (..),
  BabbageTxBodyUpgradeError,
 )
import Cardano.Ledger.Babbage.TxWits ()
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto
import Control.Arrow (left)

newtype BabbageTxUpgradeError
  = BTUEBodyUpgradeError BabbageTxBodyUpgradeError
  deriving (BabbageTxUpgradeError -> BabbageTxUpgradeError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BabbageTxUpgradeError -> BabbageTxUpgradeError -> Bool
$c/= :: BabbageTxUpgradeError -> BabbageTxUpgradeError -> Bool
== :: BabbageTxUpgradeError -> BabbageTxUpgradeError -> Bool
$c== :: BabbageTxUpgradeError -> BabbageTxUpgradeError -> Bool
Eq, Int -> BabbageTxUpgradeError -> ShowS
[BabbageTxUpgradeError] -> ShowS
BabbageTxUpgradeError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BabbageTxUpgradeError] -> ShowS
$cshowList :: [BabbageTxUpgradeError] -> ShowS
show :: BabbageTxUpgradeError -> String
$cshow :: BabbageTxUpgradeError -> String
showsPrec :: Int -> BabbageTxUpgradeError -> ShowS
$cshowsPrec :: Int -> BabbageTxUpgradeError -> ShowS
Show)

instance Crypto c => EraTx (BabbageEra c) where
  {-# SPECIALIZE instance EraTx (BabbageEra StandardCrypto) #-}

  type Tx (BabbageEra c) = AlonzoTx (BabbageEra c)
  type TxUpgradeError (BabbageEra c) = BabbageTxUpgradeError

  mkBasicTx :: TxBody (BabbageEra c) -> Tx (BabbageEra c)
mkBasicTx = forall era. Monoid (TxWits era) => TxBody era -> AlonzoTx era
mkBasicAlonzoTx

  bodyTxL :: Lens' (Tx (BabbageEra c)) (TxBody (BabbageEra c))
bodyTxL = forall era. Lens' (AlonzoTx era) (TxBody era)
bodyAlonzoTxL
  {-# INLINE bodyTxL #-}

  witsTxL :: Lens' (Tx (BabbageEra c)) (TxWits (BabbageEra c))
witsTxL = forall era. Lens' (AlonzoTx era) (TxWits era)
witsAlonzoTxL
  {-# INLINE witsTxL #-}

  auxDataTxL :: Lens'
  (Tx (BabbageEra c)) (StrictMaybe (AuxiliaryData (BabbageEra c)))
auxDataTxL = forall era. Lens' (AlonzoTx era) (StrictMaybe (TxAuxData era))
auxDataAlonzoTxL
  {-# INLINE auxDataTxL #-}

  sizeTxF :: SimpleGetter (Tx (BabbageEra c)) Integer
sizeTxF = forall era. EraTx era => SimpleGetter (AlonzoTx era) Integer
sizeAlonzoTxF
  {-# INLINE sizeTxF #-}

  wireSizeTxF :: SimpleGetter (Tx (BabbageEra c)) Word32
wireSizeTxF = forall era. EraTx era => SimpleGetter (AlonzoTx era) Word32
wireSizeAlonzoTxF
  {-# INLINE wireSizeTxF #-}

  validateNativeScript :: Tx (BabbageEra c) -> NativeScript (BabbageEra c) -> Bool
validateNativeScript = forall era.
(EraTx era, AllegraEraTxBody era, AllegraEraScript era) =>
Tx era -> NativeScript era -> Bool
validateTimelock
  {-# INLINE validateNativeScript #-}

  getMinFeeTx :: PParams (BabbageEra c) -> Tx (BabbageEra c) -> Int -> Coin
getMinFeeTx PParams (BabbageEra c)
pp Tx (BabbageEra c)
tx Int
_ = forall era.
(EraTx era, AlonzoEraTxWits era, AlonzoEraPParams era) =>
PParams era -> Tx era -> Coin
alonzoMinFeeTx PParams (BabbageEra c)
pp Tx (BabbageEra c)
tx

  upgradeTx :: EraTx (PreviousEra (BabbageEra c)) =>
Tx (PreviousEra (BabbageEra c))
-> Either (TxUpgradeError (BabbageEra c)) (Tx (BabbageEra c))
upgradeTx (AlonzoTx TxBody (AlonzoEra c)
b TxWits (AlonzoEra c)
w IsValid
valid StrictMaybe (TxAuxData (AlonzoEra c))
aux) =
    forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left BabbageTxBodyUpgradeError -> BabbageTxUpgradeError
BTUEBodyUpgradeError (forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (AlonzoEra c)
b)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (AlonzoEra c)
w)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure IsValid
valid
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData StrictMaybe (TxAuxData (AlonzoEra c))
aux)

instance Crypto c => AlonzoEraTx (BabbageEra c) where
  {-# SPECIALIZE instance AlonzoEraTx (BabbageEra StandardCrypto) #-}

  isValidTxL :: Lens' (Tx (BabbageEra c)) IsValid
isValidTxL = forall era. Lens' (AlonzoTx era) IsValid
isValidAlonzoTxL
  {-# INLINE isValidTxL #-}

instance Crypto c => EraSegWits (BabbageEra c) where
  type TxSeq (BabbageEra c) = AlonzoTxSeq (BabbageEra c)
  fromTxSeq :: TxSeq (BabbageEra c) -> StrictSeq (Tx (BabbageEra c))
fromTxSeq = forall era. AlonzoTxSeq era -> StrictSeq (Tx era)
txSeqTxns
  toTxSeq :: StrictSeq (Tx (BabbageEra c)) -> TxSeq (BabbageEra c)
toTxSeq = forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> AlonzoTxSeq era
AlonzoTxSeq
  hashTxSeq :: TxSeq (BabbageEra c)
-> Hash (HASH (EraCrypto (BabbageEra c))) EraIndependentBlockBody
hashTxSeq = forall era.
Era era =>
AlonzoTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody
hashAlonzoTxSeq
  numSegComponents :: Word64
numSegComponents = Word64
4