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

module Cardano.Ledger.Babbage.Tx (
  AlonzoTx (..),
  TxBody (..),
  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 (
  BabbageTxBodyUpgradeError,
  TxBody (..),
 )
import Cardano.Ledger.Babbage.TxWits ()
import Cardano.Ledger.Core
import Control.Arrow (left)

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

instance EraTx BabbageEra where
  type Tx BabbageEra = AlonzoTx BabbageEra
  type TxUpgradeError BabbageEra = BabbageTxUpgradeError

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

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

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

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

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

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

  validateNativeScript :: Tx BabbageEra -> NativeScript BabbageEra -> Bool
validateNativeScript = Tx BabbageEra -> NativeScript BabbageEra -> Bool
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
_ = PParams BabbageEra -> Tx BabbageEra -> Coin
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) =
    TxBody BabbageEra
-> TxWits BabbageEra
-> IsValid
-> StrictMaybe (TxAuxData BabbageEra)
-> AlonzoTx BabbageEra
TxBody BabbageEra
-> AlonzoTxWits BabbageEra
-> IsValid
-> StrictMaybe (AlonzoTxAuxData BabbageEra)
-> AlonzoTx BabbageEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx
      (TxBody BabbageEra
 -> AlonzoTxWits BabbageEra
 -> IsValid
 -> StrictMaybe (AlonzoTxAuxData BabbageEra)
 -> AlonzoTx BabbageEra)
-> Either BabbageTxUpgradeError (TxBody BabbageEra)
-> Either
     BabbageTxUpgradeError
     (AlonzoTxWits BabbageEra
      -> IsValid
      -> StrictMaybe (AlonzoTxAuxData BabbageEra)
      -> AlonzoTx BabbageEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BabbageTxBodyUpgradeError -> BabbageTxUpgradeError)
-> Either BabbageTxBodyUpgradeError (TxBody BabbageEra)
-> Either BabbageTxUpgradeError (TxBody BabbageEra)
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left BabbageTxBodyUpgradeError -> BabbageTxUpgradeError
BTUEBodyUpgradeError (TxBody (PreviousEra BabbageEra)
-> Either (TxBodyUpgradeError BabbageEra) (TxBody BabbageEra)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra BabbageEra)
TxBody AlonzoEra
b)
      Either
  BabbageTxUpgradeError
  (AlonzoTxWits BabbageEra
   -> IsValid
   -> StrictMaybe (AlonzoTxAuxData BabbageEra)
   -> AlonzoTx BabbageEra)
-> Either BabbageTxUpgradeError (AlonzoTxWits BabbageEra)
-> Either
     BabbageTxUpgradeError
     (IsValid
      -> StrictMaybe (AlonzoTxAuxData BabbageEra) -> AlonzoTx BabbageEra)
forall a b.
Either BabbageTxUpgradeError (a -> b)
-> Either BabbageTxUpgradeError a -> Either BabbageTxUpgradeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AlonzoTxWits BabbageEra
-> Either BabbageTxUpgradeError (AlonzoTxWits BabbageEra)
forall a. a -> Either BabbageTxUpgradeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxWits (PreviousEra BabbageEra) -> TxWits BabbageEra
forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (PreviousEra BabbageEra)
TxWits AlonzoEra
w)
      Either
  BabbageTxUpgradeError
  (IsValid
   -> StrictMaybe (AlonzoTxAuxData BabbageEra) -> AlonzoTx BabbageEra)
-> Either BabbageTxUpgradeError IsValid
-> Either
     BabbageTxUpgradeError
     (StrictMaybe (AlonzoTxAuxData BabbageEra) -> AlonzoTx BabbageEra)
forall a b.
Either BabbageTxUpgradeError (a -> b)
-> Either BabbageTxUpgradeError a -> Either BabbageTxUpgradeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IsValid -> Either BabbageTxUpgradeError IsValid
forall a. a -> Either BabbageTxUpgradeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IsValid
valid
      Either
  BabbageTxUpgradeError
  (StrictMaybe (AlonzoTxAuxData BabbageEra) -> AlonzoTx BabbageEra)
-> Either
     BabbageTxUpgradeError (StrictMaybe (AlonzoTxAuxData BabbageEra))
-> Either BabbageTxUpgradeError (AlonzoTx BabbageEra)
forall a b.
Either BabbageTxUpgradeError (a -> b)
-> Either BabbageTxUpgradeError a -> Either BabbageTxUpgradeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictMaybe (AlonzoTxAuxData BabbageEra)
-> Either
     BabbageTxUpgradeError (StrictMaybe (AlonzoTxAuxData BabbageEra))
forall a. a -> Either BabbageTxUpgradeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxAuxData (PreviousEra BabbageEra) -> AlonzoTxAuxData BabbageEra)
-> StrictMaybe (TxAuxData (PreviousEra BabbageEra))
-> StrictMaybe (AlonzoTxAuxData BabbageEra)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxAuxData (PreviousEra BabbageEra) -> TxAuxData BabbageEra
TxAuxData (PreviousEra BabbageEra) -> AlonzoTxAuxData BabbageEra
forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData StrictMaybe (TxAuxData (PreviousEra BabbageEra))
StrictMaybe (TxAuxData AlonzoEra)
aux)

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

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