Merge pull request #113 from mlabs-haskell/atrium

Ability to applied compiled plutarch script to closed term and compile further

cardano-simple/src/Cardano/Simple/PlutusLedgerApi/V1/Scripts.hs

@@ -6,26 +6,31 @@ module Cardano.Simple.PlutusLedgerApi.V1.Scripts (
   mkValidatorScriptPlutarch,
   mkMintingPolicyScriptPlutarch,
   mkStakeValidatorScriptPlutarch,
+  mkPlutarchTypedScript,
+  applyPlutarchTypedScript,
   Script (..),
   Validator (..),
   MintingPolicy (..),
   StakeValidator (..),
   ValidatorHash (..),
   StakeValidatorHash (..),
   MintingPolicyHash (..),
+  PlutarchTypedScript (getPlutarchTypedScript),
 ) where
 
 import Prelude qualified as Haskell
 
 import Codec.CBOR.Decoding as CBOR
 import Codec.Serialise (Serialise (..), serialise)
 import Control.DeepSeq (NFData)
+import Control.Monad.Except (MonadError (throwError), when)
 import Data.ByteString.Lazy qualified as BSL
+import Data.Eq qualified as GHC
 import Data.Text (Text)
 import Flat qualified
 import Flat.Decoder qualified as Flat
 import GHC.Generics (Generic)
-import Plutarch (ClosedTerm, Config, compile)
+import Plutarch (ClosedTerm, Config, compile, (:-->))
 import Plutarch.Script qualified as Plutarch
 import PlutusCore qualified as PLC
 import PlutusPrelude (over)
@@ -78,6 +83,32 @@ mkStakeValidatorScriptPlutarch :: Config -> ClosedTerm a -> Either Text StakeVal
 mkStakeValidatorScriptPlutarch conf term =
   StakeValidator . Script . Plutarch.unScript <$> compile conf term
 
+mkPlutarchTypedScript :: Config -> ClosedTerm a -> Either Text (PlutarchTypedScript a)
+mkPlutarchTypedScript config term =
+  PlutarchTypedScript . Script . Plutarch.unScript <$> Plutarch.compile config term
+
+applyPlutarchTypedScript ::
+  Config ->
+  PlutarchTypedScript (a :--> b) ->
+  ClosedTerm a ->
+  Either Text (PlutarchTypedScript b)
+applyPlutarchTypedScript
+  config
+  (PlutarchTypedScript (Script (UPLC.Program _ v1 t1)))
+  term = do
+    (Plutarch.Script (UPLC.Program _ v2 t2)) <- Plutarch.compile config term
+
+    when (v1 GHC./= v2) $ throwError "Script versions differ"
+
+    pure $
+      PlutarchTypedScript $
+        Script $
+          UPLC.Program () v1 $
+            UPLC.Apply () t1 t2
+
+-- | 'PlutarchTypedScript' represents a compiled plutarch script while preserving type of the script
+newtype PlutarchTypedScript s = PlutarchTypedScript {getPlutarchTypedScript :: Script}
+
 -- | 'Validator' is a wrapper around 'Script's which are used as validators in transaction outputs.
 newtype Validator = Validator {getValidator :: Script}
   deriving stock (Generic)

psm/plutus-simple-model.cabal

@@ -185,6 +185,7 @@ test-suite plutus-simple-model-test
     Suites.Plutus.Model.Util
 
   build-depends:
+    , cardano-simple
     , plutus-simple-model
     , plutus-tx-plugin
 

psm/src/Plutus/Model/Validator/V2.hs

@@ -9,6 +9,8 @@ module Plutus.Model.Validator.V2 (
   toBuiltinValidator,
   toBuiltinPolicy,
   toBuiltinStake,
+  mkTypedValidatorPlutarchTypedScript,
+  mkTypedPolicyPlutarchTypedScript,
 ) where
 
 import PlutusLedgerApi.V2
@@ -17,7 +19,17 @@ import PlutusTx.Prelude (Bool, (.))
 import PlutusTx.Prelude qualified as Plutus
 
 import Cardano.Simple.Ledger.Scripts (toV2)
-import Cardano.Simple.PlutusLedgerApi.V1.Scripts
+import Cardano.Simple.PlutusLedgerApi.V1.Scripts (
+  MintingPolicy (MintingPolicy),
+  PlutarchTypedScript (getPlutarchTypedScript),
+  Validator (Validator),
+  mkMintingPolicyScript,
+  mkMintingPolicyScriptPlutarch,
+  mkStakeValidatorScript,
+  mkStakeValidatorScriptPlutarch,
+  mkValidatorScript,
+  mkValidatorScriptPlutarch,
+ )
 import Plutarch.Api.V2 (PMintingPolicy, PStakeValidator, PValidator)
 import Plutus.Model.Validator (TypedPolicy (..), TypedStake (..), TypedValidator (..))
 
@@ -49,6 +61,14 @@ mkTypedPolicyPlutarch conf term = TypedPolicy . toV2 <$> mkMintingPolicyScriptPl
 mkTypedStakePlutarch :: Config -> ClosedTerm PStakeValidator -> Either Text (TypedStake redeemer)
 mkTypedStakePlutarch conf term = TypedStake . toV2 <$> mkStakeValidatorScriptPlutarch conf term
 
+mkTypedValidatorPlutarchTypedScript :: PlutarchTypedScript PValidator -> TypedValidator datum redeemer
+mkTypedValidatorPlutarchTypedScript script =
+  TypedValidator . toV2 . Validator Plutus.$ getPlutarchTypedScript script
+
+mkTypedPolicyPlutarchTypedScript :: PlutarchTypedScript PMintingPolicy -> TypedPolicy redeemer
+mkTypedPolicyPlutarchTypedScript script =
+  TypedPolicy . toV2 . MintingPolicy Plutus.$ getPlutarchTypedScript script
+
 -- | Coverts to low-level validator representation
 {-# INLINEABLE toBuiltinValidator #-}
 toBuiltinValidator ::

psm/test/Suites/Plutarch.hs

@@ -5,14 +5,15 @@ module Suites.Plutarch (tests) where
 import Plutarch.Prelude
 import Prelude
 
+import Cardano.Simple.PlutusLedgerApi.V1.Scripts (applyPlutarchTypedScript, mkPlutarchTypedScript)
 import Control.Monad (void)
 import Data.Default (def)
 import Data.Either (fromRight)
 import Plutarch.Api.V2 (PValidator)
 import Plutarch.Monadic qualified as P
 import Plutus.Model (DatumMode (..), Run (..), TypedValidator (..), adaValue, defaultBabbageV2, mustFail, newUser, payToKey, payToScript, sendTx, signTx, spend, spendScript, userSpend, utxoAt)
 import Plutus.Model.Contract (testNoErrors)
-import Plutus.Model.V2 (mkTypedValidatorPlutarch)
+import Plutus.Model.V2 (mkTypedValidatorPlutarch, mkTypedValidatorPlutarchTypedScript)
 import PlutusLedgerApi.V1 (toBuiltin)
 import PlutusLedgerApi.V2 (BuiltinByteString)
 import Test.Tasty (TestTree, testGroup)
@@ -21,25 +22,32 @@ tests :: TestTree
 tests =
   testGroup
     "Plutarch"
-    [ good "Good guess" (testValidator "aa")
-    , bad "Bad guess" (testValidator "bb")
+    [ testGroup
+        "Game version with datums"
+        [ good "Good guess" (testValidatorWithDatum "aa")
+        , bad "Bad guess" (testValidatorWithDatum "bb")
+        ]
+    , testGroup
+        "Game version with parametrized validator"
+        [ good "Good guess" (testValidatorParametrized "aa")
+        , bad "Bad guess" (testValidatorParametrized "bb")
+        ]
     ]
   where
     bad msg = good msg . mustFail
     good = testNoErrors (adaValue 10_000_000) cfg
     cfg = defaultBabbageV2
 
-testValidator :: BuiltinByteString -> Run ()
-testValidator guess = do
+pHash :: Term s PByteString
+pHash = phexByteStr "961b6dd3ede3cb8ecbaacbd68de040cd78eb2ed5889130cceb4c49268ea4d506"
+
+testValidator :: GameValidator -> BuiltinByteString -> Run ()
+testValidator validator guess = do
   u1 <- newUser (adaValue 1_000_000)
   u2 <- newUser (adaValue 1_000_000)
   let amt = adaValue 100
       -- magic string is from 'echo -n aa | sha256sum'
-      datum =
-        toBuiltin $
-          plift $
-            phexByteStr
-              "961b6dd3ede3cb8ecbaacbd68de040cd78eb2ed5889130cceb4c49268ea4d506"
+      datum = toBuiltin $ plift pHash
   do
     -- initialize
     sp <- spend u1 amt
@@ -57,16 +65,56 @@ testValidator guess = do
           <> payToKey u2 amt
     void $ sendTx tx
 
-validator :: TypedValidator BuiltinByteString BuiltinByteString
-validator =
+testValidatorWithDatum :: BuiltinByteString -> Run ()
+testValidatorWithDatum = testValidator validatorWithDatum
+
+testValidatorParametrized :: BuiltinByteString -> Run ()
+testValidatorParametrized = testValidator validatorParametrized
+
+type GameValidator = TypedValidator BuiltinByteString BuiltinByteString
+
+validatorWithDatum :: GameValidator
+validatorWithDatum =
   fromRight (error "no validator") $
-    mkTypedValidatorPlutarch def gameContractPlutarch
+    mkTypedValidatorPlutarch def gameContractPlutarchWithDatum
+
+validatorParametrized :: GameValidator
+validatorParametrized =
+  fromRight (error "no validator") $ do
+    -- Execution time of `mkTypedValidatorPlutarch` and `mkPlutarchTypedScript`
+    -- can take up to 2 seconds for large validators.
+    -- One definitely should avoid calling these functions in every test.
+    -- It's recommended to compile a validator exactly once
+    -- to keep low psm tests execution time.
+    compiledParametrizedScript <-
+      mkPlutarchTypedScript def gameContractPlutarchParametrized
+
+    -- Once we have access to compiled (parametrized) validator script
+    -- we can apply it to some parameters which is usually very cheap.
+    -- This can be done in every test -
+    -- especially if validator's parameter varies across tests.
+    validator <-
+      applyPlutarchTypedScript def compiledParametrizedScript pHash
 
-gameContractPlutarch :: ClosedTerm PValidator
-gameContractPlutarch = plam $ \d' r' _ -> popaque $ P.do
+    pure $ mkTypedValidatorPlutarchTypedScript validator
+
+-- Datum is used to submit a hash of a puzzle
+gameContractPlutarchWithDatum :: ClosedTerm PValidator
+gameContractPlutarchWithDatum = plam $ \d' r' _ -> popaque $ P.do
   (r :: Term s (PAsData PByteString), _) <- ptryFrom r'
   (d :: Term s (PAsData PByteString), _) <- ptryFrom d'
   pif
     (psha2_256 # pfromData r #== pfromData d)
     (pconstant ())
     perror
+
+-- Script is parametrized by a hash of a puzzle; Datum does not matter
+-- The hash is set once and for all.
+-- For a new game the term below needs to be applied to a new hash.
+gameContractPlutarchParametrized :: ClosedTerm (PByteString :--> PValidator)
+gameContractPlutarchParametrized = plam $ \expectedHash _ r' _ -> popaque $ P.do
+  (r :: Term s (PAsData PByteString), _) <- ptryFrom r'
+  pif
+    (psha2_256 # pfromData r #== expectedHash)
+    (pconstant ())
+    perror