{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Figure 2: Functions related to fees and collateral
--   Babbage Specification
module Cardano.Ledger.Babbage.Collateral where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo.Tx (isTwoPhaseScriptAddressFromMap)
import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO (txscripts))
import Cardano.Ledger.Babbage.TxBody
  ( TxBody (..),
    TxOut (..),
    collateralReturn',
    outputs',
  )
import Cardano.Ledger.BaseTypes (TxIx (..), txIxFromIntegral)
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Era (Crypto), ValidateScript (..))
import Cardano.Ledger.Shelley.UTxO (UTxO (..), balance)
import Cardano.Ledger.TxIn (TxIn (..), txid)
import Cardano.Ledger.Val ((<->))
import Control.SetAlgebra (eval, (◁))
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Set (Set)
import Data.Word (Word16, Word64)
import GHC.Records (HasField (..))

-- ============================================================

isTwoPhaseScriptAddress ::
  forall era.
  ( ValidateScript era,
    ExtendedUTxO era
  ) =>
  Core.Tx era ->
  UTxO era ->
  Addr (Crypto era) ->
  Bool
isTwoPhaseScriptAddress :: Tx era -> UTxO era -> Addr (Crypto era) -> Bool
isTwoPhaseScriptAddress Tx era
tx UTxO era
utxo = Map (ScriptHash (Crypto era)) (Script era)
-> Addr (Crypto era) -> Bool
forall era.
ValidateScript era =>
Map (ScriptHash (Crypto era)) (Script era)
-> Addr (Crypto era) -> Bool
isTwoPhaseScriptAddressFromMap @era (UTxO era -> Tx era -> Map (ScriptHash (Crypto era)) (Script era)
forall era.
ExtendedUTxO era =>
UTxO era -> Tx era -> Map (ScriptHash (Crypto era)) (Script era)
txscripts UTxO era
utxo Tx era
tx)

collBalance ::
  forall era.
  ( Era era,
    HasField "collateralReturn" (Core.TxBody era) (StrictMaybe (TxOut era)),
    HasField "collateral" (Core.TxBody era) (Set (TxIn (Crypto era)))
  ) =>
  Core.TxBody era ->
  UTxO era ->
  Core.Value era
collBalance :: TxBody era -> UTxO era -> Value era
collBalance TxBody era
txb (UTxO Map (TxIn (Crypto era)) (TxOut era)
m) =
  case TxBody era -> StrictMaybe (TxOut era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"collateralReturn" TxBody era
txb of
    StrictMaybe (TxOut era)
SNothing -> Value era
colbal
    SJust (TxOut Addr (Crypto era)
_ Value era
retval Datum era
_ StrictMaybe (Script era)
_) -> Value era
colbal Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<-> Value era
retval
  where
    col :: UTxO era
col = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO (Exp (Map (TxIn (Crypto era)) (TxOut era))
-> Map (TxIn (Crypto era)) (TxOut era)
forall s t. Embed s t => Exp t -> s
eval (TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"collateral" TxBody era
txb Set (TxIn (Crypto era))
-> Map (TxIn (Crypto era)) (TxOut era)
-> Exp (Map (TxIn (Crypto era)) (TxOut era))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (TxIn (Crypto era)) (TxOut era)
m))
    colbal :: Value era
colbal = UTxO era -> Value era
forall era. Era era => UTxO era -> Value era
balance @era UTxO era
col

collOuts ::
  ( Era era,
    Core.TxBody era ~ TxBody era,
    Core.TxOut era ~ TxOut era
  ) =>
  TxBody era ->
  UTxO era
collOuts :: TxBody era -> UTxO era
collOuts TxBody era
txb =
  case TxBody era -> StrictMaybe (TxOut era)
forall era. TxBody era -> StrictMaybe (TxOut era)
collateralReturn' TxBody era
txb of
    StrictMaybe (TxOut era)
SNothing -> Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
forall k a. Map k a
Map.empty
    SJust TxOut era
txout -> Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO (TxIn (Crypto era)
-> TxOut era -> Map (TxIn (Crypto era)) (TxOut era)
forall k a. k -> a -> Map k a
Map.singleton (TxId (Crypto era) -> TxIx -> TxIn (Crypto era)
forall crypto. TxId crypto -> TxIx -> TxIn crypto
TxIn (TxBody era -> TxId (Crypto era)
forall era c.
(HashAlgorithm (HASH c),
 HashAnnotated (TxBody era) EraIndependentTxBody c) =>
TxBody era -> TxId c
txid TxBody era
TxBody era
txb) TxIx
index) TxOut era
txout)
      where
        index :: TxIx
index = case Int -> Maybe TxIx
forall a. Integral a => a -> Maybe TxIx
txIxFromIntegral (StrictSeq (TxOut era) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxBody era -> StrictSeq (TxOut era)
forall era. TxBody era -> StrictSeq (TxOut era)
outputs' TxBody era
txb)) of
          Just TxIx
i -> TxIx
i
          -- In the impossible event that there are more transaction outputs
          -- in the transaction than will fit into a Word16 (which backs the TxIx),
          -- we give the collateral return output an index of maxBound.
          Maybe TxIx
Nothing -> Word64 -> TxIx
TxIx ((Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word16 -> Word64) (Word16
forall a. Bounded a => a
maxBound :: Word16))