{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Cardano.Api.Experimental.Plutus.Internal.Script
  ( AnyPlutusScript (..)
  , decodeAnyPlutusScript
  , serialiseAnyPlutusScriptToTextEnvelope
  , deserialiseAnyPlutusScriptFromTextEnvelope
  , AnyPlutusScriptLanguage (..)
  , PlutusScriptInEra (..)
  , PlutusLangInEra (..)
  , plutusLangInEra
  , plutusLangInShelleyBasedEra
  , PlutusScriptOrReferenceInput (..)
  , AsType (..)
  , deserialisePlutusScriptInEra
  , plutusLanguageNotSupportedInEraError
  , hashPlutusScriptInEra
  , plutusScriptInEraLanguage
  , plutusScriptInEraSLanguage
  , plutusScriptInEraToScript
  , plutusLanguageToText
  , textToPlutusLanguage
  , obtainLangConstraints
  )
where

import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
  ( IsShelleyBasedEra (..)
  , ShelleyLedgerEra
  , shelleyBasedEraConstraints
  )
import Cardano.Api.Experimental.Era
import Cardano.Api.Experimental.Plutus.Internal.Language
import Cardano.Api.HasTypeProxy
import Cardano.Api.Ledger.Internal.Reexport qualified as L
import Cardano.Api.Plutus.Internal.Script (removePlutusScriptDoubleEncoding)
import Cardano.Api.Serialise.Cbor
import Cardano.Api.Serialise.TextEnvelope.Internal
import Cardano.Api.Tx.Internal.TxIn (TxIn)

import Cardano.Binary qualified as CBOR
import Cardano.Ledger.Alonzo.Plutus.Context qualified as L
  ( EraPlutusTxInfo
  , mkSupportedPlutusScript
  )
import Cardano.Ledger.Core qualified as L
import Cardano.Ledger.Plutus.Language (PlutusRunnable)
import Cardano.Ledger.Plutus.Language qualified as L
import Cardano.Ledger.Plutus.Language qualified as Plutus

import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Short qualified as SBS
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable
import Prettyprinter

-- | A Plutus script in a particular era.
-- Why PlutusRunnable? Mainly for deserialization benefits.
-- The deserialization of this type looks at the
-- major protocol version and the script language to determine if
-- indeed the script is runnable. This is a dramatic improvement over the old api
-- which essentially read a 'ByteString' and hoped for the best.
-- Any failures due to malformed/invalid scripts were caught upon transaction
-- submission or running the script when attempting to predict the necessary execution units.
--
-- Where do we get the major protocol version from?
-- In order to access the major protocol version we pass in an 'era` type parameter which
-- can be translated to the major protocol version.
--
-- Where do we get the script language from?
-- The serialized version of 'PlutusRunnable' encodes the script language.
-- See `DecCBOR (PlutusRunnable l)` in cardano-ledger for more details.
--
-- The constructor carries 'L.EraPlutusTxInfo' evidence, so a value can only exist
-- for a language and era pairing the ledger supports. That evidence is what makes
-- the conversion to the ledger's own script type total; see 'plutusScriptInEraToScript'.
data PlutusScriptInEra (lang :: L.Language) era where
  PlutusScriptInEra
    :: L.EraPlutusTxInfo lang era
    => PlutusRunnable lang
    -> PlutusScriptInEra lang era

deriving instance Show (PlutusScriptInEra lang era)

deriving instance Eq (PlutusScriptInEra lang era)

instance
  (Typeable era, Typeable lang, HasTypeProxy (Plutus.SLanguage lang))
  => HasTypeProxy (PlutusScriptInEra lang era)
  where
  data AsType (PlutusScriptInEra lang era) = AsPlutusScriptInEra (AsType (L.SLanguage lang))
  proxyToAsType :: Proxy (PlutusScriptInEra lang era)
-> AsType (PlutusScriptInEra lang era)
proxyToAsType Proxy (PlutusScriptInEra lang era)
_ = AsType (SLanguage lang) -> AsType (PlutusScriptInEra lang era)
forall (lang :: Language) era.
AsType (SLanguage lang) -> AsType (PlutusScriptInEra lang era)
AsPlutusScriptInEra (Proxy (SLanguage lang) -> AsType (SLanguage lang)
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(L.SLanguage lang)))

instance
  ( Plutus.PlutusLanguage lang
  , L.Era era
  , L.EraPlutusTxInfo lang era
  , HasTypeProxy (Plutus.SLanguage lang)
  )
  => HasTextEnvelope (PlutusScriptInEra lang era)
  where
  textEnvelopeTypes :: AsType (PlutusScriptInEra lang era) -> NonEmpty TextEnvelopeType
textEnvelopeTypes AsType (PlutusScriptInEra lang era)
_ =
    TextEnvelopeType -> NonEmpty TextEnvelopeType
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TextEnvelopeType -> NonEmpty TextEnvelopeType)
-> (AnyPlutusScriptLanguage -> TextEnvelopeType)
-> AnyPlutusScriptLanguage
-> NonEmpty TextEnvelopeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TextEnvelopeType
forall a. IsString a => String -> a
fromString (String -> TextEnvelopeType)
-> (AnyPlutusScriptLanguage -> String)
-> AnyPlutusScriptLanguage
-> TextEnvelopeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String)
-> (AnyPlutusScriptLanguage -> Text)
-> AnyPlutusScriptLanguage
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyPlutusScriptLanguage -> Text
plutusLanguageToText (AnyPlutusScriptLanguage -> NonEmpty TextEnvelopeType)
-> AnyPlutusScriptLanguage -> NonEmpty TextEnvelopeType
forall a b. (a -> b) -> a -> b
$
      SLanguage lang -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage (SLanguage lang -> AnyPlutusScriptLanguage)
-> SLanguage lang -> AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$
        Proxy lang -> SLanguage lang
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> SLanguage l
L.plutusSLanguage (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @lang)

-- TODO: Round trip
plutusLanguageToText :: AnyPlutusScriptLanguage -> Text
plutusLanguageToText :: AnyPlutusScriptLanguage -> Text
plutusLanguageToText (AnyPlutusScriptLanguage SLanguage lang
slang) =
  case SLanguage lang
slang of
    SLanguage lang
L.SPlutusV1 -> Text
"PlutusScriptV1"
    SLanguage lang
L.SPlutusV2 -> Text
"PlutusScriptV2"
    SLanguage lang
L.SPlutusV3 -> Text
"PlutusScriptV3"
    SLanguage lang
L.SPlutusV4 -> Text
"PlutusScriptV4"

textToPlutusLanguage :: Text -> Maybe AnyPlutusScriptLanguage
textToPlutusLanguage :: Text -> Maybe AnyPlutusScriptLanguage
textToPlutusLanguage Text
txt =
  case Text
txt of
    Text
"PlutusScriptV1" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV1
L.SPlutusV1
    Text
"PlutusScriptV2" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV2
L.SPlutusV2
    Text
"PlutusScriptV3" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV3
L.SPlutusV3
    Text
"PlutusScriptV4" -> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a. a -> Maybe a
Just (AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage -> Maybe AnyPlutusScriptLanguage
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV4 -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage 'PlutusV4
L.SPlutusV4
    Text
_ -> Maybe AnyPlutusScriptLanguage
forall a. Maybe a
Nothing

instance
  ( L.Era era
  , Typeable era
  , Typeable lang
  , L.EraPlutusTxInfo lang era
  , HasTypeProxy (Plutus.SLanguage lang)
  )
  => SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era)
  where
  -- The 'PlutusBinary' stored in the 'PlutusRunnable' already contains
  -- CBOR-wrapped Flat-encoded UPLC bytes (see 'Cardano.Ledger.Plutus.Language'),
  -- so we extract them directly rather than re-encoding with 'L.serialize''.
  serialiseToCBOR :: PlutusScriptInEra lang era -> ByteString
serialiseToCBOR (PlutusScriptInEra PlutusRunnable lang
s) =
    ShortByteString -> ByteString
SBS.fromShort (ShortByteString -> ByteString)
-> (Plutus lang -> ShortByteString) -> Plutus lang -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusBinary -> ShortByteString
L.unPlutusBinary (PlutusBinary -> ShortByteString)
-> (Plutus lang -> PlutusBinary) -> Plutus lang -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus lang -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
L.plutusBinary (Plutus lang -> ByteString) -> Plutus lang -> ByteString
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
s

  deserialiseFromCBOR :: AsType (PlutusScriptInEra lang era)
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialiseFromCBOR AsType (PlutusScriptInEra lang era)
_ = ByteString -> Either DecoderError (PlutusScriptInEra lang era)
forall era (lang :: Language).
EraPlutusTxInfo lang era =>
ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra

-- | Decode a script of a language the era supports. The 'L.EraPlutusTxInfo'
-- constraint is the proof, so only malformed bytes fail.
deserialisePlutusScriptInEra
  :: forall era lang
   . L.EraPlutusTxInfo lang era
  => BS.ByteString
  -> Either CBOR.DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra :: forall era (lang :: Language).
EraPlutusTxInfo lang era =>
ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra ByteString
bs = do
  let v :: Version
v = forall era. Era era => Version
L.eraProtVerHigh @era
      scriptShortBs :: ShortByteString
scriptShortBs = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
removePlutusScriptDoubleEncoding (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs
  let plutusScript :: Plutus.Plutus lang
      plutusScript :: Plutus lang
plutusScript = PlutusBinary -> Plutus lang
forall (l :: Language). PlutusBinary -> Plutus l
L.Plutus (PlutusBinary -> Plutus lang) -> PlutusBinary -> Plutus lang
forall a b. (a -> b) -> a -> b
$ ShortByteString -> PlutusBinary
L.PlutusBinary ShortByteString
scriptShortBs

  let plutusRunnable :: PlutusRunnable lang
plutusRunnable = Version -> Plutus lang -> PlutusRunnable lang
forall (l :: Language).
PlutusLanguage l =>
Version -> Plutus l -> PlutusRunnable l
Plutus.decodePlutusRunnable Version
v Plutus lang
plutusScript
  case PlutusRunnable lang -> Either ScriptDecodeError ScriptForEvaluation
forall (l :: Language).
PlutusRunnable l -> Either ScriptDecodeError ScriptForEvaluation
Plutus.plutusRunnableResult PlutusRunnable lang
plutusRunnable of
    Left ScriptDecodeError
e ->
      DecoderError -> Either DecoderError (PlutusScriptInEra lang era)
forall a b. a -> Either a b
Left (DecoderError -> Either DecoderError (PlutusScriptInEra lang era))
-> DecoderError -> Either DecoderError (PlutusScriptInEra lang era)
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> DecoderError
CBOR.DecoderErrorCustom Text
"PlutusLedgerApi.Common.ScriptDecodeError" (Doc (ZonkAny 0) -> Text
forall a. Show a => a -> Text
Text.show (Doc (ZonkAny 0) -> Text) -> Doc (ZonkAny 0) -> Text
forall a b. (a -> b) -> a -> b
$ ScriptDecodeError -> Doc (ZonkAny 0)
forall a ann. Pretty a => a -> Doc ann
forall ann. ScriptDecodeError -> Doc ann
pretty ScriptDecodeError
e)
    Right{} -> PlutusScriptInEra lang era
-> Either DecoderError (PlutusScriptInEra lang era)
forall a. a -> Either DecoderError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlutusScriptInEra lang era
 -> Either DecoderError (PlutusScriptInEra lang era))
-> PlutusScriptInEra lang era
-> Either DecoderError (PlutusScriptInEra lang era)
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> PlutusScriptInEra lang era
forall (lang :: Language) era.
EraPlutusTxInfo lang era =>
PlutusRunnable lang -> PlutusScriptInEra lang era
PlutusScriptInEra PlutusRunnable lang
plutusRunnable

hashPlutusScriptInEra
  :: forall era lang. IsEra era => PlutusScriptInEra lang (LedgerEra era) -> L.ScriptHash
hashPlutusScriptInEra :: forall era (lang :: Language).
IsEra era =>
PlutusScriptInEra lang (LedgerEra era) -> ScriptHash
hashPlutusScriptInEra (PlutusScriptInEra PlutusRunnable lang
pr) =
  case forall era. IsEra era => Era era
useEra @era of
    Era era
ConwayEra -> Plutus lang -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
L.hashPlutusScript (Plutus lang -> ScriptHash) -> Plutus lang -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
pr
    Era era
DijkstraEra -> Plutus lang -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
L.hashPlutusScript (Plutus lang -> ScriptHash) -> Plutus lang -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
pr

plutusScriptInEraSLanguage
  :: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.SLanguage lang
plutusScriptInEraSLanguage :: forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusScriptInEra lang era -> SLanguage lang
plutusScriptInEraSLanguage PlutusScriptInEra{} =
  Proxy lang -> SLanguage lang
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> SLanguage l
L.plutusSLanguage (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @lang)

plutusScriptInEraLanguage
  :: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.Language
plutusScriptInEraLanguage :: forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusScriptInEra lang era -> Language
plutusScriptInEraLanguage PlutusScriptInEra{} =
  Proxy lang -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
L.plutusLanguage (forall {k} (t :: k). Proxy t
forall (t :: Language). Proxy t
Proxy @lang)

-- | The 'L.EraPlutusTxInfo' evidence in the constructor is the proof the ledger
-- needs, so 'L.mkSupportedPlutusScript' cannot fail here.
plutusScriptInEraToScript
  :: forall lang era. PlutusScriptInEra lang era -> L.Script era
plutusScriptInEraToScript :: forall (lang :: Language) era.
PlutusScriptInEra lang era -> Script era
plutusScriptInEraToScript (PlutusScriptInEra PlutusRunnable lang
pr) =
  PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
L.fromPlutusScript (PlutusScript era -> Script era) -> PlutusScript era -> Script era
forall a b. (a -> b) -> a -> b
$ Plutus lang -> PlutusScript era
forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Plutus l -> PlutusScript era
L.mkSupportedPlutusScript (PlutusRunnable lang -> Plutus lang
forall (l :: Language). PlutusRunnable l -> Plutus l
L.plutusFromRunnable PlutusRunnable lang
pr)

-- | You can provide the plutus script directly in the transaction
-- or a reference input that points to the script in the UTxO.
-- Using a reference script saves space in your transaction.
data PlutusScriptOrReferenceInput lang era
  = PScript (PlutusScriptInEra lang era)
  | PReferenceScript TxIn
  deriving (Int -> PlutusScriptOrReferenceInput lang era -> ShowS
[PlutusScriptOrReferenceInput lang era] -> ShowS
PlutusScriptOrReferenceInput lang era -> String
(Int -> PlutusScriptOrReferenceInput lang era -> ShowS)
-> (PlutusScriptOrReferenceInput lang era -> String)
-> ([PlutusScriptOrReferenceInput lang era] -> ShowS)
-> Show (PlutusScriptOrReferenceInput lang era)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (lang :: Language) era.
Int -> PlutusScriptOrReferenceInput lang era -> ShowS
forall (lang :: Language) era.
[PlutusScriptOrReferenceInput lang era] -> ShowS
forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era -> String
$cshowsPrec :: forall (lang :: Language) era.
Int -> PlutusScriptOrReferenceInput lang era -> ShowS
showsPrec :: Int -> PlutusScriptOrReferenceInput lang era -> ShowS
$cshow :: forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era -> String
show :: PlutusScriptOrReferenceInput lang era -> String
$cshowList :: forall (lang :: Language) era.
[PlutusScriptOrReferenceInput lang era] -> ShowS
showList :: [PlutusScriptOrReferenceInput lang era] -> ShowS
Show, PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
(PlutusScriptOrReferenceInput lang era
 -> PlutusScriptOrReferenceInput lang era -> Bool)
-> (PlutusScriptOrReferenceInput lang era
    -> PlutusScriptOrReferenceInput lang era -> Bool)
-> Eq (PlutusScriptOrReferenceInput lang era)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
$c== :: forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
== :: PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
$c/= :: forall (lang :: Language) era.
PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
/= :: PlutusScriptOrReferenceInput lang era
-> PlutusScriptOrReferenceInput lang era -> Bool
Eq)

data AnyPlutusScript era where
  AnyPlutusScript
    :: (L.Era era, L.EraPlutusTxInfo lang era, Typeable lang, L.PlutusLanguage lang)
    => PlutusScriptInEra lang era -> AnyPlutusScript era

instance Show (AnyPlutusScript era) where
  show :: AnyPlutusScript era -> String
show (AnyPlutusScript PlutusScriptInEra lang era
ps) = String
"AnyPlutusScript " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlutusScriptInEra lang era -> String
forall a. Show a => a -> String
show PlutusScriptInEra lang era
ps

instance Eq (AnyPlutusScript era) where
  AnyPlutusScript (PlutusScriptInEra lang era
ps1 :: PlutusScriptInEra lang1 era) == :: AnyPlutusScript era -> AnyPlutusScript era -> Bool
== AnyPlutusScript (PlutusScriptInEra lang era
ps2 :: PlutusScriptInEra lang2 era) =
    case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall (a :: Language) (b :: Language).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @lang1 @lang2 of
      Just lang :~: lang
Refl -> PlutusScriptInEra lang era
ps1 PlutusScriptInEra lang era -> PlutusScriptInEra lang era -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusScriptInEra lang era
PlutusScriptInEra lang era
ps2
      Maybe (lang :~: lang)
Nothing -> Bool
False

-- | The ledger era @era@ comes first for type applications; @apiEra@ follows from it.
decodeAnyPlutusScript
  :: forall era apiEra
   . (IsShelleyBasedEra apiEra, era ~ ShelleyLedgerEra apiEra)
  => ByteString
  -> AnyPlutusScriptLanguage
  -> Either CBOR.DecoderError (AnyPlutusScript era)
decodeAnyPlutusScript :: forall era apiEra.
(IsShelleyBasedEra apiEra, era ~ ShelleyLedgerEra apiEra) =>
ByteString
-> AnyPlutusScriptLanguage
-> Either DecoderError (AnyPlutusScript era)
decodeAnyPlutusScript ByteString
bs (AnyPlutusScriptLanguage (SLanguage lang
lang :: L.SLanguage lang)) =
  case forall era (lang :: Language).
(IsShelleyBasedEra era, PlutusLanguage lang) =>
SLanguage lang
-> Maybe (PlutusLangInEra lang (ShelleyLedgerEra era))
plutusLangInEra @apiEra SLanguage lang
lang of
    Maybe (PlutusLangInEra lang (ShelleyLedgerEra apiEra))
Nothing ->
      ShelleyBasedEra apiEra
-> (ShelleyBasedEraConstraints apiEra =>
    Either DecoderError (AnyPlutusScript era))
-> Either DecoderError (AnyPlutusScript era)
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints (forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra @apiEra) ((ShelleyBasedEraConstraints apiEra =>
  Either DecoderError (AnyPlutusScript era))
 -> Either DecoderError (AnyPlutusScript era))
-> (ShelleyBasedEraConstraints apiEra =>
    Either DecoderError (AnyPlutusScript era))
-> Either DecoderError (AnyPlutusScript era)
forall a b. (a -> b) -> a -> b
$
        DecoderError -> Either DecoderError (AnyPlutusScript era)
forall a b. a -> Either a b
Left (DecoderError -> Either DecoderError (AnyPlutusScript era))
-> DecoderError -> Either DecoderError (AnyPlutusScript era)
forall a b. (a -> b) -> a -> b
$
          forall era (lang :: Language).
Era era =>
SLanguage lang -> DecoderError
plutusLanguageNotSupportedInEraError @era SLanguage lang
lang
    Just (PlutusLangInEra SLanguage lang
_) ->
      PlutusScriptInEra lang era -> AnyPlutusScript era
forall era (lang :: Language).
(Era era, EraPlutusTxInfo lang era, Typeable lang,
 PlutusLanguage lang) =>
PlutusScriptInEra lang era -> AnyPlutusScript era
AnyPlutusScript
        (PlutusScriptInEra lang era -> AnyPlutusScript era)
-> Either DecoderError (PlutusScriptInEra lang era)
-> Either DecoderError (AnyPlutusScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    Either DecoderError (PlutusScriptInEra lang era))
-> Either DecoderError (PlutusScriptInEra lang era)
forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    a)
-> a
obtainLangConstraints SLanguage lang
lang (forall era (lang :: Language).
EraPlutusTxInfo lang era =>
ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra @era @lang ByteString
bs)

-- | The decoder error reported when a script's language is not in the era's
-- 'PlutusLangInEra' table. Names both the unsupported language and the era.
plutusLanguageNotSupportedInEraError
  :: forall era lang. L.Era era => L.SLanguage lang -> CBOR.DecoderError
plutusLanguageNotSupportedInEraError :: forall era (lang :: Language).
Era era =>
SLanguage lang -> DecoderError
plutusLanguageNotSupportedInEraError SLanguage lang
lang =
  Text -> Text -> DecoderError
CBOR.DecoderErrorCustom Text
"PlutusScriptInEra" (Text -> DecoderError) -> Text -> DecoderError
forall a b. (a -> b) -> a -> b
$
    Text
"Plutus language "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AnyPlutusScriptLanguage -> Text
plutusLanguageToText (SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    AnyPlutusScriptLanguage)
-> AnyPlutusScriptLanguage
forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    a)
-> a
obtainLangConstraints SLanguage lang
lang (SLanguage lang -> AnyPlutusScriptLanguage
forall (lang :: Language).
PlutusLanguage lang =>
SLanguage lang -> AnyPlutusScriptLanguage
AnyPlutusScriptLanguage SLanguage lang
lang))
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not supported in the "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall era. Era era => String
L.eraName @era)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" era"

obtainLangConstraints
  :: L.SLanguage lang
  -> ((Plutus.PlutusLanguage lang, Typeable lang, HasTypeProxy (Plutus.SLanguage lang)) => a)
  -> a
obtainLangConstraints :: forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    a)
-> a
obtainLangConstraints SLanguage lang
L.SPlutusV1 (PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f
obtainLangConstraints SLanguage lang
L.SPlutusV2 (PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f
obtainLangConstraints SLanguage lang
L.SPlutusV3 (PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f
obtainLangConstraints SLanguage lang
L.SPlutusV4 (PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f = a
(PlutusLanguage lang, Typeable lang,
 HasTypeProxy (SLanguage lang)) =>
a
f

data AnyPlutusScriptLanguage where
  AnyPlutusScriptLanguage
    :: L.PlutusLanguage lang
    => L.SLanguage lang -> AnyPlutusScriptLanguage

instance Show AnyPlutusScriptLanguage where
  show :: AnyPlutusScriptLanguage -> String
show = Text -> String
Text.unpack (Text -> String)
-> (AnyPlutusScriptLanguage -> Text)
-> AnyPlutusScriptLanguage
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyPlutusScriptLanguage -> Text
plutusLanguageToText

-- | Serialise an 'AnyPlutusScript' to a 'TextEnvelope'. The text envelope type
-- is determined by the Plutus language version of the script.
serialiseAnyPlutusScriptToTextEnvelope
  :: Maybe TextEnvelopeDescr -> AnyPlutusScript era -> TextEnvelope
serialiseAnyPlutusScriptToTextEnvelope :: forall era.
Maybe TextEnvelopeDescr -> AnyPlutusScript era -> TextEnvelope
serialiseAnyPlutusScriptToTextEnvelope Maybe TextEnvelopeDescr
mbDescr (AnyPlutusScript script :: PlutusScriptInEra lang era
script@PlutusScriptInEra{}) =
  SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    TextEnvelope)
-> TextEnvelope
forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    a)
-> a
obtainLangConstraints (PlutusScriptInEra lang era -> SLanguage lang
forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusScriptInEra lang era -> SLanguage lang
plutusScriptInEraSLanguage PlutusScriptInEra lang era
script) (((PlutusLanguage lang, Typeable lang,
   HasTypeProxy (SLanguage lang)) =>
  TextEnvelope)
 -> TextEnvelope)
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    TextEnvelope)
-> TextEnvelope
forall a b. (a -> b) -> a -> b
$
    Maybe TextEnvelopeDescr
-> PlutusScriptInEra lang era -> TextEnvelope
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope Maybe TextEnvelopeDescr
mbDescr PlutusScriptInEra lang era
script

-- | Deserialise an 'AnyPlutusScript' from a 'TextEnvelope'. The text envelope type
-- is matched against the Plutus language versions from 'Plutus.nonNativeLanguages'
-- that the era supports, so new language versions are picked up automatically.
-- The ledger era @era@ comes first for type applications; @apiEra@ follows from it.
deserialiseAnyPlutusScriptFromTextEnvelope
  :: forall era apiEra
   . (IsShelleyBasedEra apiEra, era ~ ShelleyLedgerEra apiEra)
  => TextEnvelope
  -> Either TextEnvelopeError (AnyPlutusScript era)
deserialiseAnyPlutusScriptFromTextEnvelope :: forall era apiEra.
(IsShelleyBasedEra apiEra, era ~ ShelleyLedgerEra apiEra) =>
TextEnvelope -> Either TextEnvelopeError (AnyPlutusScript era)
deserialiseAnyPlutusScriptFromTextEnvelope TextEnvelope
te =
  case Text -> Maybe AnyPlutusScriptLanguage
textToPlutusLanguage (String -> Text
Text.pack String
envType) of
    Just (AnyPlutusScriptLanguage SLanguage lang
slang)
      | Maybe (PlutusLangInEra lang (ShelleyLedgerEra apiEra))
Nothing <- forall era (lang :: Language).
(IsShelleyBasedEra era, PlutusLanguage lang) =>
SLanguage lang
-> Maybe (PlutusLangInEra lang (ShelleyLedgerEra era))
plutusLangInEra @apiEra SLanguage lang
slang ->
          ShelleyBasedEra apiEra
-> (ShelleyBasedEraConstraints apiEra =>
    Either TextEnvelopeError (AnyPlutusScript era))
-> Either TextEnvelopeError (AnyPlutusScript era)
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints (forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra @apiEra) ((ShelleyBasedEraConstraints apiEra =>
  Either TextEnvelopeError (AnyPlutusScript era))
 -> Either TextEnvelopeError (AnyPlutusScript era))
-> (ShelleyBasedEraConstraints apiEra =>
    Either TextEnvelopeError (AnyPlutusScript era))
-> Either TextEnvelopeError (AnyPlutusScript era)
forall a b. (a -> b) -> a -> b
$
            TextEnvelopeError -> Either TextEnvelopeError (AnyPlutusScript era)
forall a b. a -> Either a b
Left (TextEnvelopeError
 -> Either TextEnvelopeError (AnyPlutusScript era))
-> (DecoderError -> TextEnvelopeError)
-> DecoderError
-> Either TextEnvelopeError (AnyPlutusScript era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> TextEnvelopeError
TextEnvelopeDecodeError (DecoderError -> Either TextEnvelopeError (AnyPlutusScript era))
-> DecoderError -> Either TextEnvelopeError (AnyPlutusScript era)
forall a b. (a -> b) -> a -> b
$
              forall era (lang :: Language).
Era era =>
SLanguage lang -> DecoderError
plutusLanguageNotSupportedInEraError @era SLanguage lang
slang
    Maybe AnyPlutusScriptLanguage
_ -> [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
-> TextEnvelope -> Either TextEnvelopeError (AnyPlutusScript era)
forall b.
[FromSomeType HasTextEnvelope b]
-> TextEnvelope -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
textEnvTypes TextEnvelope
te
 where
  TextEnvelopeType String
envType = TextEnvelope -> TextEnvelopeType
teType TextEnvelope
te

  -- Only the era's languages are listed; an envelope for another language
  -- is rejected above with 'plutusLanguageNotSupportedInEraError'.
  textEnvTypes :: [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
  textEnvTypes :: [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
textEnvTypes =
    (Language -> [FromSomeType HasTextEnvelope (AnyPlutusScript era)])
-> [Language]
-> [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      ( \Language
l ->
          Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l
    -> [FromSomeType HasTextEnvelope (AnyPlutusScript era)])
-> [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
Plutus.withSLanguage Language
l ((forall (l :: Language).
  PlutusLanguage l =>
  SLanguage l
  -> [FromSomeType HasTextEnvelope (AnyPlutusScript era)])
 -> [FromSomeType HasTextEnvelope (AnyPlutusScript era)])
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l
    -> [FromSomeType HasTextEnvelope (AnyPlutusScript era)])
-> [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
forall a b. (a -> b) -> a -> b
$ \(SLanguage l
slang :: Plutus.SLanguage l) ->
            case forall era (lang :: Language).
(IsShelleyBasedEra era, PlutusLanguage lang) =>
SLanguage lang
-> Maybe (PlutusLangInEra lang (ShelleyLedgerEra era))
plutusLangInEra @apiEra SLanguage l
slang of
              Just (PlutusLangInEra SLanguage l
_) ->
                SLanguage l
-> ((PlutusLanguage l, Typeable l, HasTypeProxy (SLanguage l)) =>
    [FromSomeType HasTextEnvelope (AnyPlutusScript era)])
-> [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
forall (lang :: Language) a.
SLanguage lang
-> ((PlutusLanguage lang, Typeable lang,
     HasTypeProxy (SLanguage lang)) =>
    a)
-> a
obtainLangConstraints SLanguage l
slang [AsType (PlutusScriptInEra l era)
-> (PlutusScriptInEra l era -> AnyPlutusScript era)
-> FromSomeType HasTextEnvelope (AnyPlutusScript era)
forall (c :: * -> Constraint) a b.
c a =>
AsType a -> (a -> b) -> FromSomeType c b
FromSomeType (forall t. HasTypeProxy t => AsType t
asType @(PlutusScriptInEra l era)) PlutusScriptInEra l era -> AnyPlutusScript era
forall era (lang :: Language).
(Era era, EraPlutusTxInfo lang era, Typeable lang,
 PlutusLanguage lang) =>
PlutusScriptInEra lang era -> AnyPlutusScript era
AnyPlutusScript]
              Maybe (PlutusLangInEra l (ShelleyLedgerEra apiEra))
Nothing -> []
      )
      [Language]
Plutus.nonNativeLanguages