Use SupportedLanguage for script generation

Make generators more era agnostic

Author: lehins

eras/alonzo/impl/CHANGELOG.md

@@ -18,6 +18,7 @@
 
 ### `testlib`
 
+* Change type signature of `genPlutusScript`, `genNativeScript`, `genAlonzoScript`, `alwaysSucceedsLang` and `alwaysFailsLang`.
 * Remove `TxInfoLanguage` and `mkTxInfoLanguage`
 * Added `Era` module with `AlonzoEraTest` class
 

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,
@@ -101,7 +102,6 @@ library
     text,
     transformers,
     validation-selective,
-    FailT,
 
   if !impl(ghc >=9.2)
     ghc-options: -Wno-name-shadowing

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

@@ -38,7 +38,12 @@ 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),
+  SupportedLanguage (..),
+  mkSupportedPlutusScript,
+  supportedLanguages,
+ )
 import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError)
 import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError)
 import Cardano.Ledger.Alonzo.Rules (
@@ -78,11 +83,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 +201,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])
@@ -448,13 +451,21 @@ alwaysFails ::
   Script era
 alwaysFails n = mkPlutusScript' (alwaysFailsPlutus @l n)
 
-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' ::

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs

@@ -10,8 +10,8 @@
 
 module Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec (spec) where
 
-import Cardano.Ledger.Allegra.Scripts (Timelock)
 import Cardano.Ledger.Alonzo.Core
+import Cardano.Ledger.Alonzo.Plutus.Context
 import Cardano.Ledger.Alonzo.Scripts
 import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..))
 import Cardano.Ledger.BaseTypes
@@ -20,17 +20,17 @@ import Cardano.Ledger.Binary.Decoding
 import Cardano.Ledger.Binary.Encoding
 import Cardano.Ledger.Plutus.Language
 import Data.List (isPrefixOf)
+import qualified Data.List.NonEmpty as NE (toList)
 import qualified Data.Map as Map
-import qualified Data.Maybe as Maybe (mapMaybe)
 import Test.Cardano.Ledger.Alonzo.Arbitrary
 import Test.Cardano.Ledger.Alonzo.Binary.Annotator ()
 import Test.Cardano.Ledger.Common
 
 spec ::
   forall era.
-  ( AlonzoEraScript era
-  , Script era ~ AlonzoScript era
-  , NativeScript era ~ Timelock era
+  ( EraPlutusContext era
+  , Arbitrary (NativeScript era)
+  , DecCBOR (Annotator (NativeScript era))
   ) =>
   Spec
 spec = do
@@ -60,9 +60,8 @@ emptyFieldsProps = do
 
 plutusScriptsProp ::
   forall era.
-  ( AlonzoEraScript era
+  ( EraPlutusContext era
   , DecCBOR (Annotator (NativeScript era))
-  , Script era ~ AlonzoScript era
   ) =>
   Spec
 plutusScriptsProp = do
@@ -71,7 +70,7 @@ plutusScriptsProp = do
       [ distinctProp
       , duplicateProp
       ]
-        <*> [minBound .. eraMaxLanguage @era]
+        <*> NE.toList (supportedLanguages @era)
   where
     distinctProp lang =
       forAllShow (genEncoding lang False) (showEnc @era) $
@@ -85,26 +84,23 @@ plutusScriptsProp = do
             enc
             "Final number of elements"
 
-    genEncoding :: Language -> Bool -> Gen Encoding
-    genEncoding lang duplicate = do
-      sc <- genPlutusScript @era lang
-      let scs
-            | duplicate = [sc, sc]
-            | otherwise = [sc]
-      let plutusBins = withSLanguage lang $ \slang ->
-            Maybe.mapMaybe
-              (\x -> plutusBinary <$> (toPlutusScript x >>= toPlutusSLanguage slang))
-              scs
-      pure $ encCBOR $ Map.singleton (keys lang) (encCBOR plutusBins)
-    keys PlutusV1 = 3 :: Int
-    keys PlutusV2 = 6
-    keys PlutusV3 = 7
+    genEncoding :: SupportedLanguage era -> Bool -> Gen Encoding
+    genEncoding supportedLanguage@(SupportedLanguage slang) duplicate = do
+      plutusScript <- genPlutusScript supportedLanguage
+      let plutusScripts
+            | duplicate = [plutusScript, plutusScript]
+            | otherwise = [plutusScript]
+      pure $ encCBOR $ Map.singleton (keys slang) (encCBOR (plutusScriptBinary <$> plutusScripts))
+    keys :: SLanguage l -> Int
+    keys SPlutusV1 = 3
+    keys SPlutusV2 = 6
+    keys SPlutusV3 = 7
 
 nativeScriptsProp ::
   forall era.
   ( AlonzoEraScript era
-  , Script era ~ AlonzoScript era
-  , NativeScript era ~ Timelock era
+  , Arbitrary (NativeScript era)
+  , DecCBOR (Annotator (NativeScript era))
   ) =>
   Spec
 nativeScriptsProp = do
@@ -127,13 +123,12 @@ nativeScriptsProp = do
 
     genEncoding :: Bool -> Gen Encoding
     genEncoding duplicate = do
-      sc <- genNativeScript @era
-      let scs
-            | duplicate = [sc, sc]
-            | otherwise = [sc]
+      nativeScript <- genNativeScript @era
+      let nativeScripts
+            | duplicate = [nativeScript, nativeScript]
+            | otherwise = [nativeScript]
 
-      let natives = Maybe.mapMaybe getNativeScript scs
-      pure $ encCBOR $ Map.singleton (1 :: Int) (encCBOR natives)
+      pure $ encCBOR $ Map.singleton (1 :: Int) (encCBOR nativeScripts)
 
 expectDeserialiseSuccess ::
   forall era.

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs

@@ -20,7 +20,6 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
   LedgerTxInfo (..),
   PlutusTxInfo,
   SupportedLanguage (..),
-  supportedLanguages,
   toPlutusTxInfo,
  )
 import Cardano.Ledger.Alonzo.TxWits (Redeemers)
@@ -30,7 +29,6 @@ import Cardano.Ledger.State (UTxO (..))
 import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
 import Cardano.Slotting.Slot (EpochSize (..))
 import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
-import qualified Data.List.NonEmpty as NE (toList)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
@@ -76,8 +74,8 @@ genTranslationInstance ::
   Gen (TranslationInstance era)
 genTranslationInstance = do
   protVer <- arbitrary
-  supportedLanguage <- elements $ NE.toList (supportedLanguages @era)
-  tx <- tgTx @era supportedLanguage
+  supportedLanguage :: SupportedLanguage era <- arbitrary
+  tx <- tgTx supportedLanguage
   utxo <- tgUtxo supportedLanguage tx
   let lti =
         LedgerTxInfo

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs

@@ -12,6 +12,7 @@
 module Test.Cardano.Ledger.Generic.Functions where
 
 import Cardano.Ledger.Address (Addr (..))
+import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext, mkSupportedLanguageM)
 import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage)
 import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..))
 import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..))
@@ -48,6 +49,7 @@ import qualified Cardano.Ledger.UMap as UM
 import Cardano.Ledger.Val (Val ((<+>), (<->)), inject)
 import Cardano.Slotting.EpochInfo.API (epochInfoSize)
 import Control.Monad.Reader (runReader)
+import Control.Monad.Trans.Fail.String (errorFail)
 import Data.Default (Default (def))
 import qualified Data.Foldable as Fold (fold, toList)
 import qualified Data.List as List
@@ -300,24 +302,32 @@ primaryLanguage Alonzo = Just PlutusV1
 primaryLanguage _ = Nothing
 {-# NOINLINE primaryLanguage #-}
 
+alwaysSucceedsLang' :: forall era. EraPlutusContext era => Language -> Natural -> Script era
+alwaysSucceedsLang' l =
+  fromPlutusScript . alwaysSucceedsLang (errorFail (mkSupportedLanguageM @era l))
+
+alwaysFailsLang' :: forall era. EraPlutusContext era => Language -> Natural -> Script era
+alwaysFailsLang' l =
+  fromPlutusScript . alwaysFailsLang (errorFail (mkSupportedLanguageM @era l))
+
 alwaysTrue :: forall era. Proof era -> Maybe Language -> Natural -> Script era
-alwaysTrue Conway (Just l) n = alwaysSucceedsLang @era l n
+alwaysTrue Conway (Just l) n = alwaysSucceedsLang' @era l n
 alwaysTrue p@Conway Nothing _ = fromNativeScript $ Scriptic.allOf [] p
-alwaysTrue Babbage (Just l) n = alwaysSucceedsLang @era l n
+alwaysTrue Babbage (Just l) n = alwaysSucceedsLang' @era l n
 alwaysTrue p@Babbage Nothing _ = fromNativeScript $ Scriptic.allOf [] p
-alwaysTrue Alonzo (Just l) n = alwaysSucceedsLang @era l n
+alwaysTrue Alonzo (Just l) n = alwaysSucceedsLang' @era l n
 alwaysTrue p@Alonzo Nothing _ = fromNativeScript $ Scriptic.allOf [] p
 alwaysTrue p@Mary _ n = always n p
 alwaysTrue p@Allegra _ n = always n p
 alwaysTrue p@Shelley _ n = always n p
 {-# NOINLINE alwaysTrue #-}
 
 alwaysFalse :: forall era. Proof era -> Maybe Language -> Natural -> Script era
-alwaysFalse Conway (Just l) n = alwaysFailsLang @era l n
+alwaysFalse Conway (Just l) n = alwaysFailsLang' @era l n
 alwaysFalse p@Conway Nothing _ = fromNativeScript $ Scriptic.anyOf [] p
-alwaysFalse Babbage (Just l) n = alwaysFailsLang @era l n
+alwaysFalse Babbage (Just l) n = alwaysFailsLang' @era l n
 alwaysFalse p@Babbage Nothing _ = fromNativeScript $ Scriptic.anyOf [] p
-alwaysFalse Alonzo (Just l) n = alwaysFailsLang @era l n
+alwaysFalse Alonzo (Just l) n = alwaysFailsLang' @era l n
 alwaysFalse p@Alonzo Nothing _ = fromNativeScript $ Scriptic.anyOf [] p
 alwaysFalse p@Mary _ n = never n p
 alwaysFalse p@Allegra _ n = never n p