{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableSuperClasses #-}
-- Recursive definition constraints of `EraPlutusContext` and `EraPlutusTxInfo` lead to a wrongful
-- redundant constraint warning in the definition of `lookupTxInfoResult`.
--
-- Also `mkSupportedPlutusScript` has a constraint that is not required by the type system, but is
-- necessary for the safety of the function.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Cardano.Ledger.Alonzo.Plutus.Context (
  LedgerTxInfo (..),
  EraPlutusTxInfo (..),
  EraPlutusContext (..),
  toPlutusWithContext,
  lookupTxInfoResultImpossible,
  SupportedLanguage (..),
  mkSupportedLanguageM,
  supportedLanguages,
  mkSupportedPlutusScript,
  mkSupportedBinaryPlutusScript,

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

import Cardano.Ledger.Alonzo.Scripts (
  AlonzoEraScript (eraMaxLanguage, mkPlutusScript),
  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,
  PlutusBinary,
  PlutusLanguage,
  PlutusRunnable,
  PlutusScriptContext,
  PlutusWithContext (..),
  SLanguage (..),
  asSLanguage,
  isLanguage,
  plutusLanguage,
 )
import Cardano.Ledger.State (UTxO (..))
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Fail.String (errorFail)
import Data.Aeson (ToJSON)
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Text (Text)
import GHC.Stack
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

  -- | This data type family is used to memoize the results of `toPlutusTxInfo`, so the outcome can
  -- be shared between execution of different scripts with the same language version.
  data TxInfoResult era :: Type

  mkSupportedLanguage :: Language -> Maybe (SupportedLanguage era)

  -- | Construct `PlutusTxInfo` for all supported languages in this era.
  mkTxInfoResult :: LedgerTxInfo era -> TxInfoResult era

  -- | `TxInfo` for the same language can be shared between executions of every script of the same
  -- version in a single transaction.
  --
  -- /Note/ - The `EraPlutusTxInfo` is here only to enforce this function is not called with an
  -- unsupported plutus language version.
  lookupTxInfoResult ::
    EraPlutusTxInfo l era =>
    SLanguage l ->
    TxInfoResult era ->
    Either (ContextError era) (PlutusTxInfo l)

  mkPlutusWithContext ::
    PlutusScript era ->
    ScriptHash ->
    PlutusPurpose AsIxItem era ->
    LedgerTxInfo era ->
    TxInfoResult 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 ->
  TxInfoResult 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
-> TxInfoResult 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 TxInfoResult era
txInfoResult (Data era
redeemerData, ExUnits
exUnits) CostModel
costModel = do
  let slang :: SLanguage l
slang = forall (l :: Language). PlutusLanguage l => SLanguage l
isLanguage @l
      maybeSpendingDatum :: Maybe (Data era)
maybeSpendingDatum =
        UTxO era -> Tx era -> PlutusPurpose AsItem era -> Maybe (Data era)
forall era.
AlonzoEraUTxO era =>
UTxO era -> Tx era -> PlutusPurpose AsItem era -> Maybe (Data era)
getSpendingDatum (LedgerTxInfo era -> UTxO era
forall era. LedgerTxInfo era -> UTxO era
ltiUTxO LedgerTxInfo era
lti) (LedgerTxInfo era -> Tx era
forall era. LedgerTxInfo era -> Tx era
ltiTx LedgerTxInfo era
lti) ((forall ix it. AsIxItem ix it -> AsItem ix it)
-> PlutusPurpose AsIxItem era -> PlutusPurpose AsItem era
forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
forall (g :: * -> * -> *) (f :: * -> * -> *).
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose AsIxItem ix it -> AsItem ix it
forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
plutusPurpose)
  PlutusTxInfo l
txInfo <- SLanguage l
-> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
forall era (l :: Language).
(EraPlutusContext era, EraPlutusTxInfo l era) =>
SLanguage l
-> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
forall (l :: Language).
EraPlutusTxInfo l era =>
SLanguage l
-> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
lookupTxInfoResult SLanguage l
slang TxInfoResult era
txInfoResult
  PlutusArgs l
plutusArgs <-
    SLanguage l
-> ProtVer
-> PlutusTxInfo l
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs l)
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)
forall (proxy :: Language -> *).
proxy l
-> ProtVer
-> PlutusTxInfo l
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs l)
toPlutusArgs SLanguage l
slang (LedgerTxInfo era -> ProtVer
forall era. LedgerTxInfo era -> ProtVer
ltiProtVer LedgerTxInfo era
lti) PlutusTxInfo l
txInfo PlutusPurpose AsIxItem era
plutusPurpose Maybe (Data era)
maybeSpendingDatum Data era
redeemerData
  PlutusWithContext -> Either (ContextError era) PlutusWithContext
forall a. a -> Either (ContextError era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlutusWithContext -> Either (ContextError era) PlutusWithContext)
-> PlutusWithContext -> Either (ContextError era) PlutusWithContext
forall a b. (a -> b) -> a -> b
$
    PlutusWithContext
      { pwcProtocolVersion :: Version
pwcProtocolVersion = ProtVer -> Version
pvMajor (LedgerTxInfo era -> ProtVer
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
      }

-- | Helper function to use when implementing `lookupTxInfoResult` for plutus languages that are not
-- supported by the era.
lookupTxInfoResultImpossible ::
  (HasCallStack, EraPlutusTxInfo l era) => SLanguage l -> Either (ContextError era) (PlutusTxInfo l)
lookupTxInfoResultImpossible :: forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
SLanguage l -> Either (ContextError era) (PlutusTxInfo l)
lookupTxInfoResultImpossible SLanguage l
slang =
  [Char] -> Either (ContextError era) (PlutusTxInfo l)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either (ContextError era) (PlutusTxInfo l))
-> [Char] -> Either (ContextError era) (PlutusTxInfo l)
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: Attempt to lookup TxInfoResult for an unsupported language: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SLanguage l -> [Char]
forall a. Show a => a -> [Char]
show SLanguage l
slang

-- =============================================
-- 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

-- | This is just like `mkPlutusScript`, except it is guaranteed to be total through the enforcement
-- of support by the type system and `EraPlutusTxInfo` type class instances for supported plutus
-- versions.
mkSupportedPlutusScript ::
  forall l era.
  (HasCallStack, EraPlutusTxInfo l era) =>
  Plutus l ->
  PlutusScript era
mkSupportedPlutusScript :: forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Plutus l -> PlutusScript era
mkSupportedPlutusScript Plutus l
plutus =
  case Plutus l -> Maybe (PlutusScript era)
forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
forall (l :: Language).
PlutusLanguage l =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript Plutus l
plutus of
    Maybe (PlutusScript era)
Nothing ->
      [Char] -> PlutusScript era
forall a. HasCallStack => [Char] -> a
error ([Char] -> PlutusScript era) -> [Char] -> PlutusScript era
forall a b. (a -> b) -> a -> b
$
        [Char]
"Impossible: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Plutus l -> [Char]
forall a. Show a => a -> [Char]
show Plutus l
plutus
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" language version should be supported by the "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @era
    Just PlutusScript era
plutusScript -> PlutusScript era
plutusScript

-- | This is just like `mkBinaryPlutusScript`, except it is guaranteed to be total through the enforcement
-- of support by the type system and `EraPlutusTxInfo` type class instances (via calling `mkSupportedPlutusScript) for supported plutus
-- versions.
mkSupportedBinaryPlutusScript ::
  forall era.
  (HasCallStack, AlonzoEraScript era) =>
  SupportedLanguage era ->
  PlutusBinary ->
  PlutusScript era
mkSupportedBinaryPlutusScript :: forall era.
(HasCallStack, AlonzoEraScript era) =>
SupportedLanguage era -> PlutusBinary -> PlutusScript era
mkSupportedBinaryPlutusScript SupportedLanguage era
supportedLanguage PlutusBinary
plutus =
  case SupportedLanguage era
supportedLanguage of
    SupportedLanguage SLanguage l
sLang ->
      Plutus l -> PlutusScript era
forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Plutus l -> PlutusScript era
mkSupportedPlutusScript (SLanguage l -> Plutus l -> Plutus l
forall (l :: Language) (proxy :: Language -> *).
SLanguage l -> proxy l -> proxy l
asSLanguage SLanguage l
sLang (PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus PlutusBinary
plutus))

data SupportedLanguage era where
  SupportedLanguage :: EraPlutusTxInfo l era => SLanguage l -> SupportedLanguage era

instance Show (SupportedLanguage era) where
  show :: SupportedLanguage era -> [Char]
show (SupportedLanguage SLanguage l
sLang) = [Char]
"(SupportedLanguage (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SLanguage l -> [Char]
forall a. Show a => a -> [Char]
show SLanguage l
sLang [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))"

instance Eq (SupportedLanguage era) where
  SupportedLanguage SLanguage l
sLang1 == :: SupportedLanguage era -> SupportedLanguage era -> Bool
== SupportedLanguage SLanguage l
sLang2 =
    SLanguage l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage SLanguage l
sLang1 Language -> Language -> Bool
forall a. Eq a => a -> a -> Bool
== SLanguage l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage SLanguage l
sLang2

instance Ord (SupportedLanguage era) where
  compare :: SupportedLanguage era -> SupportedLanguage era -> Ordering
compare (SupportedLanguage SLanguage l
sLang1) (SupportedLanguage SLanguage l
sLang2) =
    Language -> Language -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SLanguage l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage SLanguage l
sLang1) (SLanguage l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage SLanguage l
sLang2)

instance Era era => EncCBOR (SupportedLanguage era) where
  encCBOR :: SupportedLanguage era -> Encoding
encCBOR (SupportedLanguage SLanguage l
sLang) = SLanguage l -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SLanguage l
sLang

instance EraPlutusContext era => DecCBOR (SupportedLanguage era) where
  decCBOR :: forall s. Decoder s (SupportedLanguage era)
decCBOR = Decoder s Language
forall s. Decoder s Language
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s Language
-> (Language -> Decoder s (SupportedLanguage era))
-> Decoder s (SupportedLanguage era)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Language -> Decoder s (SupportedLanguage era)
forall era (m :: * -> *).
(EraPlutusContext era, MonadFail m) =>
Language -> m (SupportedLanguage era)
mkSupportedLanguageM

supportedLanguages ::
  forall era.
  (HasCallStack, EraPlutusContext era) =>
  NonEmpty (SupportedLanguage era)
supportedLanguages :: forall era.
(HasCallStack, EraPlutusContext era) =>
NonEmpty (SupportedLanguage era)
supportedLanguages =
  let langs :: [SupportedLanguage era]
langs =
        [ Fail (SupportedLanguage era) -> SupportedLanguage era
forall a. HasCallStack => Fail a -> a
errorFail (Language -> Fail (SupportedLanguage era)
forall era (m :: * -> *).
(EraPlutusContext era, MonadFail m) =>
Language -> m (SupportedLanguage era)
mkSupportedLanguageM Language
lang)
        | Language
lang <- [Language
forall a. Bounded a => a
minBound .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era]
        ]
   in case [SupportedLanguage era] -> Maybe (NonEmpty (SupportedLanguage era))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [SupportedLanguage era]
langs of
        Maybe (NonEmpty (SupportedLanguage era))
Nothing -> [Char] -> NonEmpty (SupportedLanguage era)
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: there are no supported languages"
        Just NonEmpty (SupportedLanguage era)
neLangs -> NonEmpty (SupportedLanguage era)
neLangs

mkSupportedLanguageM ::
  forall era m.
  (EraPlutusContext era, MonadFail m) =>
  Language ->
  m (SupportedLanguage era)
mkSupportedLanguageM :: forall era (m :: * -> *).
(EraPlutusContext era, MonadFail m) =>
Language -> m (SupportedLanguage era)
mkSupportedLanguageM Language
lang =
  case Language -> Maybe (SupportedLanguage era)
forall era.
EraPlutusContext era =>
Language -> Maybe (SupportedLanguage era)
mkSupportedLanguage Language
lang of
    Maybe (SupportedLanguage era)
Nothing -> [Char] -> m (SupportedLanguage era)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m (SupportedLanguage era))
-> [Char] -> m (SupportedLanguage era)
forall a b. (a -> b) -> a -> b
$ Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" language is not supported in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @era
    Just SupportedLanguage era
supportedLanguage -> SupportedLanguage era -> m (SupportedLanguage era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SupportedLanguage era
supportedLanguage