{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.TxOut (upgradeBabbageTxOut) where

import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.TxOut (
  BabbageTxOut (..),
  addrEitherBabbageTxOutL,
  babbageMinUTxOValue,
  dataBabbageTxOutL,
  dataHashBabbageTxOutL,
  datumBabbageTxOutL,
  getDatumBabbageTxOut,
  referenceScriptBabbageTxOutL,
  valueEitherBabbageTxOutL,
 )
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Conway.PParams ()
import Cardano.Ledger.Conway.Scripts ()
import Cardano.Ledger.Plutus.Data (Datum (..), translateDatum)
import Data.Coerce (coerce)
import Data.Maybe.Strict (StrictMaybe (..))
import Lens.Micro

instance EraTxOut ConwayEra where
  type TxOut ConwayEra = BabbageTxOut ConwayEra

  mkBasicTxOut :: HasCallStack => Addr -> Value ConwayEra -> TxOut ConwayEra
mkBasicTxOut Addr
addr Value ConwayEra
vl = Addr
-> Value ConwayEra
-> Datum ConwayEra
-> StrictMaybe (Script ConwayEra)
-> BabbageTxOut ConwayEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut Addr
addr Value ConwayEra
vl Datum ConwayEra
forall era. Datum era
NoDatum StrictMaybe (Script ConwayEra)
StrictMaybe (AlonzoScript ConwayEra)
forall a. StrictMaybe a
SNothing

  upgradeTxOut :: EraTxOut (PreviousEra ConwayEra) =>
TxOut (PreviousEra ConwayEra) -> TxOut ConwayEra
upgradeTxOut = TxOut (PreviousEra ConwayEra) -> TxOut ConwayEra
BabbageTxOut (PreviousEra ConwayEra) -> BabbageTxOut ConwayEra
forall era.
(Value era ~ Value (PreviousEra era), EraScript (PreviousEra era),
 EraScript era) =>
BabbageTxOut (PreviousEra era) -> BabbageTxOut era
upgradeBabbageTxOut

  addrEitherTxOutL :: Lens' (TxOut ConwayEra) (Either Addr CompactAddr)
addrEitherTxOutL = (Either Addr CompactAddr -> f (Either Addr CompactAddr))
-> TxOut ConwayEra -> f (TxOut ConwayEra)
(Either Addr CompactAddr -> f (Either Addr CompactAddr))
-> BabbageTxOut ConwayEra -> f (BabbageTxOut ConwayEra)
forall era.
EraTxOut era =>
Lens' (BabbageTxOut era) (Either Addr CompactAddr)
Lens' (BabbageTxOut ConwayEra) (Either Addr CompactAddr)
addrEitherBabbageTxOutL
  {-# INLINE addrEitherTxOutL #-}

  valueEitherTxOutL :: Lens'
  (TxOut ConwayEra)
  (Either (Value ConwayEra) (CompactForm (Value ConwayEra)))
valueEitherTxOutL = (Either (Value ConwayEra) (CompactForm (Value ConwayEra))
 -> f (Either (Value ConwayEra) (CompactForm (Value ConwayEra))))
-> TxOut ConwayEra -> f (TxOut ConwayEra)
(Either (Value ConwayEra) (CompactForm (Value ConwayEra))
 -> f (Either (Value ConwayEra) (CompactForm (Value ConwayEra))))
-> BabbageTxOut ConwayEra -> f (BabbageTxOut ConwayEra)
forall era.
EraTxOut era =>
Lens'
  (BabbageTxOut era) (Either (Value era) (CompactForm (Value era)))
Lens'
  (BabbageTxOut ConwayEra)
  (Either (Value ConwayEra) (CompactForm (Value ConwayEra)))
valueEitherBabbageTxOutL
  {-# INLINE valueEitherTxOutL #-}

  getMinCoinSizedTxOut :: PParams ConwayEra -> Sized (TxOut ConwayEra) -> Coin
getMinCoinSizedTxOut = PParams ConwayEra -> Sized (TxOut ConwayEra) -> Coin
PParams ConwayEra -> Sized (BabbageTxOut ConwayEra) -> Coin
forall era a.
BabbageEraPParams era =>
PParams era -> Sized a -> Coin
babbageMinUTxOValue

instance AlonzoEraTxOut ConwayEra where
  dataHashTxOutL :: Lens' (TxOut ConwayEra) (StrictMaybe DataHash)
dataHashTxOutL = (StrictMaybe DataHash -> f (StrictMaybe DataHash))
-> TxOut ConwayEra -> f (TxOut ConwayEra)
(StrictMaybe DataHash -> f (StrictMaybe DataHash))
-> BabbageTxOut ConwayEra -> f (BabbageTxOut ConwayEra)
forall era.
EraTxOut era =>
Lens' (BabbageTxOut era) (StrictMaybe DataHash)
Lens' (BabbageTxOut ConwayEra) (StrictMaybe DataHash)
dataHashBabbageTxOutL
  {-# INLINE dataHashTxOutL #-}

  datumTxOutF :: SimpleGetter (TxOut ConwayEra) (Datum ConwayEra)
datumTxOutF = (BabbageTxOut ConwayEra -> Datum ConwayEra)
-> SimpleGetter (BabbageTxOut ConwayEra) (Datum ConwayEra)
forall s a. (s -> a) -> SimpleGetter s a
to BabbageTxOut ConwayEra -> Datum ConwayEra
forall era. BabbageTxOut era -> Datum era
getDatumBabbageTxOut
  {-# INLINE datumTxOutF #-}

instance BabbageEraTxOut ConwayEra where
  dataTxOutL :: Lens' (TxOut ConwayEra) (StrictMaybe (Data ConwayEra))
dataTxOutL = (StrictMaybe (Data ConwayEra) -> f (StrictMaybe (Data ConwayEra)))
-> TxOut ConwayEra -> f (TxOut ConwayEra)
(StrictMaybe (Data ConwayEra) -> f (StrictMaybe (Data ConwayEra)))
-> BabbageTxOut ConwayEra -> f (BabbageTxOut ConwayEra)
forall era.
EraTxOut era =>
Lens' (BabbageTxOut era) (StrictMaybe (Data era))
Lens' (BabbageTxOut ConwayEra) (StrictMaybe (Data ConwayEra))
dataBabbageTxOutL
  {-# INLINE dataTxOutL #-}

  datumTxOutL :: Lens' (TxOut ConwayEra) (Datum ConwayEra)
datumTxOutL = (Datum ConwayEra -> f (Datum ConwayEra))
-> TxOut ConwayEra -> f (TxOut ConwayEra)
(Datum ConwayEra -> f (Datum ConwayEra))
-> BabbageTxOut ConwayEra -> f (BabbageTxOut ConwayEra)
forall era. EraTxOut era => Lens' (BabbageTxOut era) (Datum era)
Lens' (BabbageTxOut ConwayEra) (Datum ConwayEra)
datumBabbageTxOutL
  {-# INLINE datumTxOutL #-}

  referenceScriptTxOutL :: Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL = (StrictMaybe (Script ConwayEra)
 -> f (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra -> f (TxOut ConwayEra)
(StrictMaybe (Script ConwayEra)
 -> f (StrictMaybe (Script ConwayEra)))
-> BabbageTxOut ConwayEra -> f (BabbageTxOut ConwayEra)
forall era.
EraTxOut era =>
Lens' (BabbageTxOut era) (StrictMaybe (Script era))
Lens' (BabbageTxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptBabbageTxOutL
  {-# INLINE referenceScriptTxOutL #-}

upgradeBabbageTxOut ::
  ( Value era ~ Value (PreviousEra era)
  , EraScript (PreviousEra era)
  , EraScript era
  ) =>
  BabbageTxOut (PreviousEra era) ->
  BabbageTxOut era
upgradeBabbageTxOut :: forall era.
(Value era ~ Value (PreviousEra era), EraScript (PreviousEra era),
 EraScript era) =>
BabbageTxOut (PreviousEra era) -> BabbageTxOut era
upgradeBabbageTxOut = \case
  TxOutCompact' CompactAddr
ca CompactForm (Value (PreviousEra era))
cv -> CompactAddr -> CompactForm (Value era) -> BabbageTxOut era
forall era.
CompactAddr -> CompactForm (Value era) -> BabbageTxOut era
TxOutCompact' CompactAddr
ca CompactForm (Value era)
CompactForm (Value (PreviousEra era))
cv
  TxOutCompactDH' CompactAddr
ca CompactForm (Value (PreviousEra era))
cv DataHash
dh -> CompactAddr
-> CompactForm (Value era) -> DataHash -> BabbageTxOut era
forall era.
CompactAddr
-> CompactForm (Value era) -> DataHash -> BabbageTxOut era
TxOutCompactDH' CompactAddr
ca CompactForm (Value era)
CompactForm (Value (PreviousEra era))
cv DataHash
dh
  TxOutCompactDatum CompactAddr
ca CompactForm (Value (PreviousEra era))
cv BinaryData (PreviousEra era)
bd -> CompactAddr
-> CompactForm (Value era) -> BinaryData era -> BabbageTxOut era
forall era.
CompactAddr
-> CompactForm (Value era) -> BinaryData era -> BabbageTxOut era
TxOutCompactDatum CompactAddr
ca CompactForm (Value era)
CompactForm (Value (PreviousEra era))
cv (BinaryData (PreviousEra era) -> BinaryData era
forall a b. Coercible a b => a -> b
coerce BinaryData (PreviousEra era)
bd)
  TxOutCompactRefScript CompactAddr
ca CompactForm (Value (PreviousEra era))
cv Datum (PreviousEra era)
d Script (PreviousEra era)
s -> CompactAddr
-> CompactForm (Value era)
-> Datum era
-> Script era
-> BabbageTxOut era
forall era.
CompactAddr
-> CompactForm (Value era)
-> Datum era
-> Script era
-> BabbageTxOut era
TxOutCompactRefScript CompactAddr
ca CompactForm (Value era)
CompactForm (Value (PreviousEra era))
cv (Datum (PreviousEra era) -> Datum era
forall era1 era2. Datum era1 -> Datum era2
translateDatum Datum (PreviousEra era)
d) (Script (PreviousEra era) -> Script era
forall era.
(EraScript era, EraScript (PreviousEra era)) =>
Script (PreviousEra era) -> Script era
upgradeScript Script (PreviousEra era)
s)
  TxOut_AddrHash28_AdaOnly Credential 'Staking
c Addr28Extra
a28e CompactForm Coin
cc -> Credential 'Staking
-> Addr28Extra -> CompactForm Coin -> BabbageTxOut era
forall era.
Credential 'Staking
-> Addr28Extra -> CompactForm Coin -> BabbageTxOut era
TxOut_AddrHash28_AdaOnly Credential 'Staking
c Addr28Extra
a28e CompactForm Coin
cc
  TxOut_AddrHash28_AdaOnly_DataHash32 Credential 'Staking
c Addr28Extra
a28e CompactForm Coin
cc DataHash32
dh32 -> Credential 'Staking
-> Addr28Extra
-> CompactForm Coin
-> DataHash32
-> BabbageTxOut era
forall era.
Credential 'Staking
-> Addr28Extra
-> CompactForm Coin
-> DataHash32
-> BabbageTxOut era
TxOut_AddrHash28_AdaOnly_DataHash32 Credential 'Staking
c Addr28Extra
a28e CompactForm Coin
cc DataHash32
dh32