{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Cardano.Ledger.Alonzo.Plutus.Context (
  LedgerTxInfo (..),
  EraPlutusTxInfo (..),
  EraPlutusContext (..),
  toPlutusWithContext,

  -- * Language dependent translation
  PlutusTxInfo,
  PlutusTxCert,
  PlutusScriptPurpose,
  PlutusScriptContext,
)
where

import Cardano.Ledger.Alonzo.Scripts (
  AlonzoEraScript,
  AsIxItem (..),
  PlutusPurpose,
  PlutusScript (..),
  hoistPlutusPurpose,
  toAsItem,
 )
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (getSpendingDatum))
import Cardano.Ledger.BaseTypes (ProtVer (..))
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus (
  CostModel,
  Data,
  ExUnits,
  Language (..),
  Plutus,
  PlutusArgs,
  PlutusLanguage,
  PlutusRunnable,
  PlutusScriptContext,
  PlutusWithContext (..),
 )
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.DeepSeq (NFData)
import Data.Aeson (ToJSON)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import NoThunks.Class (NoThunks)
import qualified PlutusLedgerApi.V1 as PV1
import qualified PlutusLedgerApi.V2 as PV2
import qualified PlutusLedgerApi.V3 as PV3

-- | All information that is necessary from the ledger to construct Plutus' TxInfo.
data LedgerTxInfo era = LedgerTxInfo
  { forall era. LedgerTxInfo era -> ProtVer
ltiProtVer :: !ProtVer
  , forall era. LedgerTxInfo era -> EpochInfo (Either Text)
ltiEpochInfo :: !(EpochInfo (Either Text))
  , forall era. LedgerTxInfo era -> SystemStart
ltiSystemStart :: !SystemStart
  , forall era. LedgerTxInfo era -> UTxO era
ltiUTxO :: !(UTxO era)
  , forall era. LedgerTxInfo era -> Tx era
ltiTx :: !(Tx era)
  }

class (PlutusLanguage l, EraPlutusContext era) => EraPlutusTxInfo (l :: Language) era where
  toPlutusTxCert ::
    proxy l ->
    ProtVer ->
    TxCert era ->
    Either (ContextError era) (PlutusTxCert l)

  toPlutusScriptPurpose ::
    proxy l ->
    ProtVer ->
    PlutusPurpose AsIxItem era ->
    Either (ContextError era) (PlutusScriptPurpose l)

  toPlutusTxInfo ::
    proxy l ->
    LedgerTxInfo era ->
    Either (ContextError era) (PlutusTxInfo l)

  toPlutusArgs ::
    proxy l ->
    ProtVer ->
    PlutusTxInfo l ->
    PlutusPurpose AsIxItem era ->
    Maybe (Data era) ->
    Data era ->
    Either (ContextError era) (PlutusArgs l)

class
  ( AlonzoEraScript era
  , Eq (ContextError era)
  , Show (ContextError era)
  , NFData (ContextError era)
  , NoThunks (ContextError era)
  , EncCBOR (ContextError era)
  , DecCBOR (ContextError era)
  , ToJSON (ContextError era)
  ) =>
  EraPlutusContext era
  where
  type ContextError era = (r :: Type) | r -> era

  mkPlutusWithContext ::
    PlutusScript era ->
    ScriptHash ->
    PlutusPurpose AsIxItem era ->
    LedgerTxInfo era ->
    (Data era, ExUnits) ->
    CostModel ->
    Either (ContextError era) PlutusWithContext

toPlutusWithContext ::
  forall l era.
  (EraPlutusTxInfo l era, AlonzoEraUTxO era) =>
  Either (Plutus l) (PlutusRunnable l) ->
  ScriptHash ->
  PlutusPurpose AsIxItem era ->
  LedgerTxInfo era ->
  (Data era, ExUnits) ->
  CostModel ->
  Either (ContextError era) PlutusWithContext
toPlutusWithContext :: forall (l :: Language) era.
(EraPlutusTxInfo l era, AlonzoEraUTxO era) =>
Either (Plutus l) (PlutusRunnable l)
-> ScriptHash
-> PlutusPurpose AsIxItem era
-> LedgerTxInfo era
-> (Data era, ExUnits)
-> CostModel
-> Either (ContextError era) PlutusWithContext
toPlutusWithContext Either (Plutus l) (PlutusRunnable l)
script ScriptHash
scriptHash PlutusPurpose AsIxItem era
plutusPurpose LedgerTxInfo era
lti (Data era
redeemerData, ExUnits
exUnits) CostModel
costModel = do
  let proxy :: Proxy l
proxy = forall {k} (t :: k). Proxy t
Proxy @l
      maybeSpendingDatum :: Maybe (Data era)
maybeSpendingDatum =
        forall era.
AlonzoEraUTxO era =>
UTxO era -> Tx era -> PlutusPurpose AsItem era -> Maybe (Data era)
getSpendingDatum (forall era. LedgerTxInfo era -> UTxO era
ltiUTxO LedgerTxInfo era
lti) (forall era. LedgerTxInfo era -> Tx era
ltiTx LedgerTxInfo era
lti) (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
plutusPurpose)
  PlutusTxInfo l
txInfo <- forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfo Proxy l
proxy LedgerTxInfo era
lti
  PlutusArgs l
plutusArgs <-
    forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> PlutusTxInfo l
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs l)
toPlutusArgs Proxy l
proxy (forall era. LedgerTxInfo era -> ProtVer
ltiProtVer LedgerTxInfo era
lti) PlutusTxInfo l
txInfo PlutusPurpose AsIxItem era
plutusPurpose Maybe (Data era)
maybeSpendingDatum Data era
redeemerData
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    PlutusWithContext
      { pwcProtocolVersion :: Version
pwcProtocolVersion = ProtVer -> Version
pvMajor (forall era. LedgerTxInfo era -> ProtVer
ltiProtVer LedgerTxInfo era
lti)
      , pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript = Either (Plutus l) (PlutusRunnable l)
script
      , pwcScriptHash :: ScriptHash
pwcScriptHash = ScriptHash
scriptHash
      , pwcArgs :: PlutusArgs l
pwcArgs = PlutusArgs l
plutusArgs
      , pwcExUnits :: ExUnits
pwcExUnits = ExUnits
exUnits
      , pwcCostModel :: CostModel
pwcCostModel = CostModel
costModel
      }

-- =============================================
-- Type families that specify Plutus types that are different from one version to another

type family PlutusTxCert (l :: Language) where
  PlutusTxCert 'PlutusV1 = PV1.DCert
  PlutusTxCert 'PlutusV2 = PV2.DCert
  PlutusTxCert 'PlutusV3 = PV3.TxCert

type family PlutusScriptPurpose (l :: Language) where
  PlutusScriptPurpose 'PlutusV1 = PV1.ScriptPurpose
  PlutusScriptPurpose 'PlutusV2 = PV2.ScriptPurpose
  PlutusScriptPurpose 'PlutusV3 = PV3.ScriptPurpose

type family PlutusTxInfo (l :: Language) where
  PlutusTxInfo 'PlutusV1 = PV1.TxInfo
  PlutusTxInfo 'PlutusV2 = PV2.TxInfo
  PlutusTxInfo 'PlutusV3 = PV3.TxInfo