Merge pull request #5021 from IntersectMBO/lehins/add-supported-languages

Add `SupportedLanguage`

Author: lehins

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.14.0.0
 
+* Add `supportedLanguages` to `EraPlutusContext`
+* Add `SupportedLanguage`, `mkSupportedBinaryPlutusScript` and `mkSupportedPlutusScript`.
 * Deprecate `inputs'`, `collateral'`, `outputs'`, `certs'`, `withdrawals'`, `txfee'`,
   `vldt'`, `update'`, `reqSignerHashes'`, `adHash'`, `mint'`, `scriptIntegrityHash'`,
   and `txnetworkid'`
@@ -16,6 +18,9 @@
 
 ### `testlib`
 
+* Deprecated `mkPlutusScript'`
+* Change type signature of `genPlutusScript`, `genNativeScript`, `genAlonzoScript`, `alwaysSucceedsLang` and `alwaysFailsLang`.
+* Remove `TxInfoLanguage` and `mkTxInfoLanguage`
 * Added `Era` module with `AlonzoEraTest` class
 
 ## 1.13.0.0

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -76,6 +76,7 @@ library
     -Wunused-packages
 
   build-depends:
+    FailT,
     aeson >=2.2,
     base >=4.14 && <5,
     base64-bytestring,
@@ -142,7 +143,6 @@ library testlib
 
   build-depends:
     HUnit,
-    QuickCheck,
     base,
     bytestring,
     cardano-data:{cardano-data, testlib},

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs

@@ -8,7 +8,10 @@
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 -- Recursive definition constraints of `EraPlutusContext` and `EraPlutusTxInfo` lead to a wrongful
--- redundant constraint warning in the definition of `lookupTxInfoResult`
+-- 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 (
@@ -17,6 +20,11 @@ module Cardano.Ledger.Alonzo.Plutus.Context (
   EraPlutusContext (..),
   toPlutusWithContext,
   lookupTxInfoResultImpossible,
+  SupportedLanguage (..),
+  mkSupportedLanguageM,
+  supportedLanguages,
+  mkSupportedPlutusScript,
+  mkSupportedBinaryPlutusScript,
 
   -- * Language dependent translation
   PlutusTxInfo,
@@ -27,7 +35,7 @@ module Cardano.Ledger.Alonzo.Plutus.Context (
 where
 
 import Cardano.Ledger.Alonzo.Scripts (
-  AlonzoEraScript,
+  AlonzoEraScript (eraMaxLanguage, mkPlutusScript),
   AsIxItem (..),
   PlutusPurpose,
   PlutusScript (..),
@@ -43,21 +51,26 @@ import Cardano.Ledger.Plutus (
   Data,
   ExUnits,
   Language (..),
-  Plutus,
+  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)
@@ -119,6 +132,8 @@ class
   -- 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
 
@@ -129,7 +144,9 @@ class
   -- unsupported plutus language version.
   lookupTxInfoResult ::
     EraPlutusTxInfo l era =>
-    SLanguage l -> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
+    SLanguage l ->
+    TxInfoResult era ->
+    Either (ContextError era) (PlutusTxInfo l)
 
   mkPlutusWithContext ::
     PlutusScript era ->
@@ -193,3 +210,78 @@ 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 plutus =
+  case mkPlutusScript plutus of
+    Nothing ->
+      error $
+        "Impossible: "
+          ++ show plutus
+          ++ " language version should be supported by the "
+          ++ eraName @era
+    Just plutusScript -> 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 supportedLanguage plutus =
+  case supportedLanguage of
+    SupportedLanguage sLang ->
+      mkSupportedPlutusScript (asSLanguage sLang (Plutus plutus))
+
+data SupportedLanguage era where
+  SupportedLanguage :: EraPlutusTxInfo l era => SLanguage l -> SupportedLanguage era
+
+instance Show (SupportedLanguage era) where
+  show (SupportedLanguage sLang) = "(SupportedLanguage (" ++ show sLang ++ "))"
+
+instance Eq (SupportedLanguage era) where
+  SupportedLanguage sLang1 == SupportedLanguage sLang2 =
+    plutusLanguage sLang1 == plutusLanguage sLang2
+
+instance Ord (SupportedLanguage era) where
+  compare (SupportedLanguage sLang1) (SupportedLanguage sLang2) =
+    compare (plutusLanguage sLang1) (plutusLanguage sLang2)
+
+instance Era era => EncCBOR (SupportedLanguage era) where
+  encCBOR (SupportedLanguage sLang) = encCBOR sLang
+
+instance EraPlutusContext era => DecCBOR (SupportedLanguage era) where
+  decCBOR = decCBOR >>= mkSupportedLanguageM
+
+supportedLanguages ::
+  forall era.
+  (HasCallStack, EraPlutusContext era) =>
+  NonEmpty (SupportedLanguage era)
+supportedLanguages =
+  let langs =
+        [ errorFail (mkSupportedLanguageM lang)
+        | lang <- [minBound .. eraMaxLanguage @era]
+        ]
+   in case nonEmpty langs of
+        Nothing -> error "Impossible: there are no supported languages"
+        Just neLangs -> neLangs
+
+mkSupportedLanguageM ::
+  forall era m.
+  (EraPlutusContext era, MonadFail m) =>
+  Language ->
+  m (SupportedLanguage era)
+mkSupportedLanguageM lang =
+  case mkSupportedLanguage lang of
+    Nothing -> fail $ show lang ++ " language is not supported in " ++ eraName @era
+    Just supportedLanguage -> pure supportedLanguage

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs

@@ -165,6 +165,10 @@ instance EraPlutusContext AlonzoEra where
   newtype TxInfoResult AlonzoEra
     = AlonzoTxInfoResult (Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1))
 
+  mkSupportedLanguage = \case
+    PlutusV1 -> Just $ SupportedLanguage SPlutusV1
+    _lang -> Nothing
+
   mkTxInfoResult = AlonzoTxInfoResult . toPlutusTxInfo SPlutusV1
 
   lookupTxInfoResult SPlutusV1 (AlonzoTxInfoResult tirPlutusV1) = tirPlutusV1

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs

@@ -38,7 +38,13 @@ import Cardano.Ledger.Alonzo (AlonzoEra)
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
 import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (AlonzoPParams), OrdExUnits (OrdExUnits))
-import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
+import Cardano.Ledger.Alonzo.Plutus.Context (
+  EraPlutusContext (ContextError),
+  EraPlutusTxInfo,
+  SupportedLanguage (..),
+  mkSupportedPlutusScript,
+  supportedLanguages,
+ )
 import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError)
 import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError)
 import Cardano.Ledger.Alonzo.Rules (
@@ -78,11 +84,11 @@ import Cardano.Ledger.Plutus.Language (
   PlutusLanguage,
   asSLanguage,
   plutusLanguage,
-  withSLanguage,
  )
 import Cardano.Ledger.Shelley.Rules (PredicateFailure, ShelleyUtxowPredFailure)
 import Data.Functor.Identity (Identity)
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Data.List.NonEmpty as NE (toList)
 import qualified Data.Map.Strict as Map
 import qualified Data.MapExtras as Map (fromElems)
 import qualified Data.Set as Set
@@ -196,41 +202,39 @@ instance
 genEraLanguage :: forall era. AlonzoEraScript era => Gen Language
 genEraLanguage = choose (minBound, eraMaxLanguage @era)
 
+instance EraPlutusContext era => Arbitrary (SupportedLanguage era) where
+  arbitrary = elements $ NE.toList (supportedLanguages @era)
+
 instance
-  ( AlonzoEraScript era
+  ( EraPlutusContext era
   , Script era ~ AlonzoScript era
   , NativeScript era ~ Timelock era
   ) =>
   Arbitrary (AlonzoScript era)
   where
-  arbitrary = genEraLanguage @era >>= genAlonzoScript
+  arbitrary = arbitrary >>= genAlonzoScript
 
 genAlonzoScript ::
-  ( AlonzoEraScript era
+  ( EraPlutusContext era
   , Script era ~ AlonzoScript era
   , NativeScript era ~ Timelock era
   ) =>
-  Language ->
+  SupportedLanguage era ->
   Gen (AlonzoScript era)
 genAlonzoScript lang =
   frequency
-    [ (2, genPlutusScript lang)
-    , (8, genNativeScript)
+    [ (2, fromPlutusScript <$> genPlutusScript lang)
+    , (8, fromNativeScript <$> genNativeScript)
     ]
 
 genNativeScript ::
-  ( AlonzoEraScript era
-  , NativeScript era ~ Timelock era
-  ) =>
-  Gen (AlonzoScript era)
-genNativeScript = TimelockScript <$> arbitrary
+  Arbitrary (NativeScript era) =>
+  Gen (NativeScript era)
+genNativeScript = arbitrary
 
 genPlutusScript ::
-  ( AlonzoEraScript era
-  , Script era ~ AlonzoScript era
-  ) =>
-  Language ->
-  Gen (AlonzoScript era)
+  SupportedLanguage era ->
+  Gen (PlutusScript era)
 genPlutusScript lang =
   frequency
     [ (5, alwaysSucceedsLang lang <$> elements [1, 2, 3])
@@ -436,25 +440,33 @@ instance Arbitrary AlonzoGenesis where
 
 alwaysSucceeds ::
   forall l era.
-  (HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
+  (HasCallStack, EraPlutusTxInfo l era) =>
   Natural ->
   Script era
-alwaysSucceeds n = mkPlutusScript' (alwaysSucceedsPlutus @l n)
+alwaysSucceeds = fromPlutusScript . mkSupportedPlutusScript . alwaysSucceedsPlutus @l
 
 alwaysFails ::
   forall l era.
-  (HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
+  (HasCallStack, EraPlutusTxInfo l era) =>
   Natural ->
   Script era
-alwaysFails n = mkPlutusScript' (alwaysFailsPlutus @l n)
+alwaysFails = fromPlutusScript . mkSupportedPlutusScript . alwaysFailsPlutus @l
 
-alwaysSucceedsLang :: (HasCallStack, AlonzoEraScript era) => Language -> Natural -> Script era
-alwaysSucceedsLang lang n =
-  withSLanguage lang $ \slang -> mkPlutusScript' $ asSLanguage slang (alwaysSucceedsPlutus n)
+alwaysSucceedsLang ::
+  SupportedLanguage era ->
+  Natural ->
+  PlutusScript era
+alwaysSucceedsLang supportedLanguage n =
+  case supportedLanguage of
+    SupportedLanguage slang -> mkSupportedPlutusScript $ asSLanguage slang (alwaysSucceedsPlutus n)
 
-alwaysFailsLang :: (HasCallStack, AlonzoEraScript era) => Language -> Natural -> Script era
-alwaysFailsLang lang n =
-  withSLanguage lang $ \slang -> mkPlutusScript' $ asSLanguage slang (alwaysFailsPlutus n)
+alwaysFailsLang ::
+  SupportedLanguage era ->
+  Natural ->
+  PlutusScript era
+alwaysFailsLang supportedLanguage n =
+  case supportedLanguage of
+    SupportedLanguage slang -> mkSupportedPlutusScript $ asSLanguage slang (alwaysFailsPlutus n)
 
 -- | Partial version of `mkPlutusScript`
 mkPlutusScript' ::
@@ -468,3 +480,4 @@ mkPlutusScript' plutus =
       error $
         "Plutus version " ++ show (plutusLanguage plutus) ++ " is not supported in " ++ eraName @era
     Just plutusScript -> fromPlutusScript plutusScript
+{-# DEPRECATED mkPlutusScript' "In favor of `fromPlutusScript` . `mkSupportedPlutusScript`" #-}