{-# 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 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 EraTx BabbageEra where
  type Tx BabbageEra = AlonzoTx BabbageEra
  type TxUpgradeError BabbageEra = BabbageTxUpgradeError

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

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

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

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

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

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

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

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

  upgradeTx :: EraTx (PreviousEra BabbageEra) =>
Tx (PreviousEra BabbageEra)
-> Either (TxUpgradeError BabbageEra) (Tx BabbageEra)
upgradeTx (AlonzoTx TxBody AlonzoEra
b TxWits AlonzoEra
w IsValid
valid StrictMaybe (TxAuxData AlonzoEra)
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
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
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)
aux)

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

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