From c9e5f6a702c124203d81824129ff6a21213eac76 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Thu, 10 Sep 2020 17:48:30 +0100 Subject: [PATCH] Use UPLC in the ledger This is a wide-ranging PR. Some highlights: - We didn't have `Program` for UPLC, so I added it. - The prettyprinting for UPLC didn't include the (new) types for constants. - We didn't have a CBOR instance for UPLC. - We need to rejig a bunch of the testing infrastructure to account for UPLC. I tidied it up a little bit - Using UPLC for golden tests means that we need De Bruijn conversion for UPLC so we can have stable test output. Fortuantely it's an easy port. I reorganize the TPLC one so it was easier to share most of it. - We can no longer typecheck validators. We used to do this during tx validation, and also in the typed tx interface. Now you're on your own if you submit ill-typed code, but that's the deal we made. --- hie-cabal.yaml | 4 + nix/stack.materialized/plutus-core.nix | 4 + nix/stack.materialized/plutus-tx-plugin.nix | 1 + plutus-core/common/PlcTestUtils.hs | 133 +++++--- plutus-core/exe/Main.hs | 5 +- plutus-core/plutus-core.cabal | 4 + plutus-core/plutus-ir-test/Spec.hs | 40 +-- plutus-core/plutus-ir-test/TestLib.hs | 58 +++- .../datatypes/listMatchEval.golden | 2 +- .../plutus-ir-test/recursion/even3Eval.golden | 8 +- plutus-core/src/Language/PlutusCore.hs | 1 - plutus-core/src/Language/PlutusCore/CBOR.hs | 73 +---- .../src/Language/PlutusCore/DeBruijn.hs | 136 +-------- .../Language/PlutusCore/DeBruijn/Internal.hs | 165 ++++++++++ plutus-core/test/Spec.hs | 7 - .../Language/UntypedPlutusCore.hs | 12 +- .../UntypedPlutusCore/Core/Instance.hs | 1 + .../UntypedPlutusCore/Core/Instance/CBOR.hs | 114 +++++++ .../Core/Instance/Pretty/Classic.hs | 10 +- .../Core/Instance/Pretty/Plc.hs | 3 + .../Core/Instance/Pretty/Readable.hs | 6 + .../Language/UntypedPlutusCore/Core/Type.hs | 16 +- .../Language/UntypedPlutusCore/DeBruijn.hs | 95 ++++++ .../Language/UntypedPlutusCore/Size.hs | 32 ++ plutus-ledger/src/Ledger/Index.hs | 4 +- plutus-ledger/src/Ledger/Scripts.hs | 108 +++---- plutus-ledger/src/Ledger/Typed/Tx.hs | 36 +-- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + .../src/Language/PlutusTx/PLCTypes.hs | 7 +- .../src/Language/PlutusTx/Plugin.hs | 11 +- plutus-tx-plugin/test/Lib.hs | 36 +++ plutus-tx-plugin/test/Lift/Spec.hs | 41 ++- .../test/Lift/boolInterop.plc.golden | 10 +- .../test/Lift/bytestring.plc.golden | 26 +- plutus-tx-plugin/test/Lift/list.plc.golden | 73 ++--- plutus-tx-plugin/test/Lift/mono.plc.golden | 50 +-- plutus-tx-plugin/test/Lift/nested.plc.golden | 135 ++------ plutus-tx-plugin/test/Lift/poly.plc.golden | 67 +--- plutus-tx-plugin/test/Lift/record.plc.golden | 26 +- plutus-tx-plugin/test/Lift/syn.plc.golden | 55 +--- plutus-tx-plugin/test/Lift/tuple.plc.golden | 47 +-- plutus-tx-plugin/test/Plugin/Basic/Spec.hs | 6 +- plutus-tx-plugin/test/Plugin/Data/Spec.hs | 26 +- .../Data/recursive/sameEmptyRose.plc.golden | 287 ++++-------------- .../recursive/sameEmptyRoseEval.plc.golden | 165 +++------- plutus-tx-plugin/test/Plugin/Errors/Spec.hs | 15 +- .../Plugin/Errors/literalCaseOther.plc.golden | 230 ++++---------- .../test/Plugin/Functions/Spec.hs | 12 +- .../Functions/recursive/even3.plc.golden | 8 +- .../Functions/recursive/even4.plc.golden | 8 +- plutus-tx-plugin/test/Plugin/Laziness/Spec.hs | 6 +- .../Plugin/Laziness/joinErrorEval.plc.golden | 2 +- plutus-tx-plugin/test/Plugin/Lib.hs | 13 +- .../test/Plugin/Primitives/Spec.hs | 24 +- .../Plugin/Primitives/andApply.plc.golden | 6 +- .../Primitives/equalsByteString.plc.golden | 6 +- .../Plugin/Primitives/intEqApply.plc.golden | 6 +- .../Plugin/Primitives/ltByteString.plc.golden | 6 +- .../test/Plugin/Typeclasses/Spec.hs | 10 +- plutus-tx-plugin/test/StdLib/Spec.hs | 5 +- plutus-tx-plugin/test/TH/Spec.hs | 27 +- plutus-tx-plugin/test/TH/all.plc.golden | 8 +- plutus-tx/src/Language/PlutusTx.hs | 5 +- plutus-tx/src/Language/PlutusTx/Code.hs | 21 +- plutus-tx/src/Language/PlutusTx/Evaluation.hs | 25 +- plutus-tx/src/Language/PlutusTx/Lift.hs | 52 +--- plutus-use-cases/bench/Bench.hs | 19 +- .../test/Spec/crowdfundingTestOutput.txt | 38 +-- .../test/Spec/renderCrowdfunding.txt | 48 +-- plutus-use-cases/test/Spec/renderGuess.txt | 20 +- plutus-use-cases/test/Spec/renderVesting.txt | 22 +- 71 files changed, 1179 insertions(+), 1610 deletions(-) create mode 100644 plutus-core/src/Language/PlutusCore/DeBruijn/Internal.hs create mode 100644 plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/CBOR.hs create mode 100644 plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/DeBruijn.hs create mode 100644 plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Size.hs create mode 100644 plutus-tx-plugin/test/Lib.hs diff --git a/hie-cabal.yaml b/hie-cabal.yaml index c55f937f549..88b0991c4b6 100644 --- a/hie-cabal.yaml +++ b/hie-cabal.yaml @@ -6,12 +6,16 @@ cradle: config: { cradle: { cabal: { component: "lib:plutus-core" } } } - path: ./plutus-core/src config: { cradle: { cabal: { component: "lib:plutus-core" } } } + - path: ./plutus-core/untyped-plutus-core + config: { cradle: { cabal: { component: "lib:untyped-plutus-core" } } } - path: ./plutus-core/plutus-ir config: { cradle: { cabal: { component: "lib:plutus-core" } } } - path: ./plutus-core/common config: { cradle: { cabal: { component: "lib:plutus-core" } } } - path: ./plutus-core/test config: { cradle: { cabal: { component: "plutus-core:plutus-core-test" } } } + - path: ./plutus-core/untyped-plutus-core-test + config: { cradle: { cabal: { component: "lib:untyped-plutus-core-test" } } } - path: ./plutus-core/plutus-ir-test config: { cradle: { cabal: { component: "plutus-core:plutus-ir-test" } } } - path: ./plutus-core/bench diff --git a/nix/stack.materialized/plutus-core.nix b/nix/stack.materialized/plutus-core.nix index 7ff945a5f14..c1a57833456 100644 --- a/nix/stack.materialized/plutus-core.nix +++ b/nix/stack.materialized/plutus-core.nix @@ -120,6 +120,7 @@ "Language/PlutusCore/Constant/Function" "Language/PlutusCore/Constant/Name" "Language/PlutusCore/Constant/Typed" + "Language/PlutusCore/DeBruijn/Internal" "Language/PlutusCore/Lexer/Type" "Language/PlutusCore/Eq" "Language/PlutusCore/Mark" @@ -164,7 +165,9 @@ "Language/UntypedPlutusCore/Core/Instance/Pretty/Classic" "Language/UntypedPlutusCore/Core/Instance/Pretty/Plc" "Language/UntypedPlutusCore/Core/Instance/Pretty/Readable" + "Language/UntypedPlutusCore/Core/Instance/CBOR" "Language/UntypedPlutusCore/Core/Type" + "Language/UntypedPlutusCore/Size" "Language/UntypedPlutusCore/Subst" "Data/Aeson/THReader" "Data/Functor/Foldable/Monadic" @@ -239,6 +242,7 @@ "Language/PlutusIR/Transform/Inline" "Language/PlutusIR/TypeCheck" "Language/UntypedPlutusCore" + "Language/UntypedPlutusCore/DeBruijn" "Language/UntypedPlutusCore/Evaluation/Machine/Cek" "PlutusPrelude" "Common" diff --git a/nix/stack.materialized/plutus-tx-plugin.nix b/nix/stack.materialized/plutus-tx-plugin.nix index ca86bfbdaa0..ed6037843b6 100644 --- a/nix/stack.materialized/plutus-tx-plugin.nix +++ b/nix/stack.materialized/plutus-tx-plugin.nix @@ -104,6 +104,7 @@ "StdLib/Spec" "TH/Spec" "TH/TestTH" + "Lib" ]; hsSourceDirs = [ "test" ]; mainPath = [ "Spec.hs" ]; diff --git a/plutus-core/common/PlcTestUtils.hs b/plutus-core/common/PlcTestUtils.hs index 4c9998e0662..6bedd30d4a5 100644 --- a/plutus-core/common/PlcTestUtils.hs +++ b/plutus-core/common/PlcTestUtils.hs @@ -6,27 +6,37 @@ {-# LANGUAGE UndecidableInstances #-} module PlcTestUtils ( - GetProgram(..), + ToTPlc(..), + ToUPlc(..), pureTry, catchAll, rethrow, - trivialProgram, - runPlc, - goldenPlc, - goldenPlcCatch, - goldenEval, - goldenEvalCatch) where + runTPlc, + runUPlc, + goldenTPlc, + goldenTPlcCatch, + goldenUPlc, + goldenUPlcCatch, + goldenTEval, + goldenUEval, + goldenTEvalCatch, + goldenUEvalCatch) where import PlutusPrelude import Common -import Language.PlutusCore +import qualified Language.PlutusCore as TPLC import Language.PlutusCore.DeBruijn -import Language.PlutusCore.Evaluation.Machine.Cek +import qualified Language.PlutusCore.Evaluation.Machine.Cek as TPLC import Language.PlutusCore.Evaluation.Machine.ExBudgetingDefaults import Language.PlutusCore.Evaluation.Machine.ExMemory import Language.PlutusCore.Pretty +import Language.PlutusCore.Universe + +import qualified Language.UntypedPlutusCore as UPLC +import qualified Language.UntypedPlutusCore.DeBruijn as UPLC +import qualified Language.UntypedPlutusCore.Evaluation.Machine.Cek as UPLC import Control.Exception import Control.Monad.Except @@ -35,14 +45,23 @@ import System.IO.Unsafe -- | Class for ad-hoc overloading of things which can be turned into a PLC program. Any errors -- from the process should be caught. -class GetProgram a uni | a -> uni where - getProgram :: a -> ExceptT SomeException IO (Program TyName Name uni ()) +class ToTPlc a uni | a -> uni where + toTPlc :: a -> ExceptT SomeException IO (TPLC.Program TPLC.TyName TPLC.Name uni ()) + +instance ToTPlc a uni => ToTPlc (ExceptT SomeException IO a) uni where + toTPlc a = a >>= toTPlc + +instance ToTPlc (TPLC.Program TPLC.TyName TPLC.Name uni ()) uni where + toTPlc = pure -instance GetProgram a uni => GetProgram (ExceptT SomeException IO a) uni where - getProgram a = a >>= getProgram +class ToUPlc a uni | a -> uni where + toUPlc :: a -> ExceptT SomeException IO (UPLC.Program TPLC.Name uni ()) -instance GetProgram (Program TyName Name uni ()) uni where - getProgram = pure +instance ToUPlc a uni => ToUPlc (ExceptT SomeException IO a) uni where + toUPlc a = a >>= toUPlc + +instance ToUPlc (UPLC.Program TPLC.Name uni ()) uni where + toUPlc = pure pureTry :: Exception e => a -> Either e a pureTry = unsafePerformIO . try . evaluate @@ -53,19 +72,27 @@ catchAll value = ExceptT $ try @SomeException (evaluate value) rethrow :: ExceptT SomeException IO a -> IO a rethrow = fmap (either throw id) . runExceptT -trivialProgram :: Term TyName Name uni () -> Program TyName Name uni () -trivialProgram = Program () (defaultVersion ()) - -runPlc - :: ( GetProgram a uni, GShow uni, GEq uni, DefaultUni <: uni +runTPlc + :: ( ToTPlc a uni, GShow uni, GEq uni, DefaultUni <: uni , Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni ) - => [a] -> ExceptT SomeException IO (EvaluationResult (Plain Term uni)) -runPlc values = do - ps <- traverse getProgram values - let p = foldl1 applyProgram ps - liftEither . first toException . extractEvaluationResult . evaluateCek mempty defaultCostModel $ toTerm p + => [a] -> ExceptT SomeException IO (TPLC.EvaluationResult (TPLC.Term TPLC.TyName TPLC.Name uni ())) +runTPlc values = do + ps <- traverse toTPlc values + let (TPLC.Program _ _ t) = foldl1 TPLC.applyProgram ps + liftEither $ first toException $ TPLC.extractEvaluationResult $ TPLC.evaluateCek mempty defaultCostModel t + +runUPlc + :: ( ToUPlc a uni, GShow uni, GEq uni, DefaultUni <: uni + , Closed uni, uni `Everywhere` ExMemoryUsage, + uni `Everywhere` PrettyConst, Typeable uni + ) + => [a] -> ExceptT SomeException IO (UPLC.EvaluationResult (UPLC.Term TPLC.Name uni ())) +runUPlc values = do + ps <- traverse toUPlc values + let (UPLC.Program _ _ t) = foldl1 UPLC.applyProgram ps + liftEither $ first toException $ TPLC.extractEvaluationResult $ UPLC.evaluateCek mempty defaultCostModel t ppCatch :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann) ppCatch value = either (PP.pretty . show) prettyPlcClassicDebug <$> runExceptT value @@ -73,30 +100,58 @@ ppCatch value = either (PP.pretty . show) prettyPlcClassicDebug <$> runExceptT v ppThrow :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann) ppThrow value = rethrow $ prettyPlcClassicDebug <$> value -goldenPlc - :: (GetProgram a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst) +goldenTPlc + :: (ToTPlc a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst) => String -> a -> TestNested -goldenPlc name value = nestedGoldenVsDocM name $ ppThrow $ do - p <- getProgram value +goldenTPlc name value = nestedGoldenVsDocM name $ ppThrow $ do + p <- toTPlc value withExceptT toException $ deBruijnProgram p -goldenPlcCatch - :: (GetProgram a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst) +goldenTPlcCatch + :: (ToTPlc a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst) => String -> a -> TestNested -goldenPlcCatch name value = nestedGoldenVsDocM name $ ppCatch $ do - p <- getProgram value +goldenTPlcCatch name value = nestedGoldenVsDocM name $ ppCatch $ do + p <- toTPlc value withExceptT toException $ deBruijnProgram p -goldenEval - :: ( GetProgram a uni, GShow uni, GEq uni, DefaultUni <: uni +goldenUPlc + :: (ToUPlc a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst) + => String -> a -> TestNested +goldenUPlc name value = nestedGoldenVsDocM name $ ppThrow $ do + p <- toUPlc value + withExceptT toException $ UPLC.deBruijnProgram p + +goldenUPlcCatch + :: (ToUPlc a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst) + => String -> a -> TestNested +goldenUPlcCatch name value = nestedGoldenVsDocM name $ ppCatch $ do + p <- toUPlc value + withExceptT toException $ UPLC.deBruijnProgram p + +goldenTEval + :: ( ToTPlc a uni, GShow uni, GEq uni, DefaultUni <: uni + , Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni + ) + => String -> [a] -> TestNested +goldenTEval name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runTPlc values) + +goldenUEval + :: ( ToUPlc a uni, GShow uni, GEq uni, DefaultUni <: uni + , Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni + ) + => String -> [a] -> TestNested +goldenUEval name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runUPlc values) + +goldenTEvalCatch + :: ( ToTPlc a uni, GShow uni, GEq uni, DefaultUni <: uni , Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni ) => String -> [a] -> TestNested -goldenEval name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runPlc values) +goldenTEvalCatch name values = nestedGoldenVsDocM name $ ppCatch $ runTPlc values -goldenEvalCatch - :: ( GetProgram a uni, GShow uni, GEq uni, DefaultUni <: uni +goldenUEvalCatch + :: ( ToUPlc a uni, GShow uni, GEq uni, DefaultUni <: uni , Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni ) => String -> [a] -> TestNested -goldenEvalCatch name values = nestedGoldenVsDocM name $ ppCatch $ runPlc values +goldenUEvalCatch name values = nestedGoldenVsDocM name $ ppCatch $ runUPlc values diff --git a/plutus-core/exe/Main.hs b/plutus-core/exe/Main.hs index d772afe8cd3..e5c67f03ecd 100644 --- a/plutus-core/exe/Main.hs +++ b/plutus-core/exe/Main.hs @@ -23,6 +23,7 @@ import qualified Language.PlutusCore.StdLib.Data.ChurchNat as P import qualified Language.PlutusCore.StdLib.Data.Integer as PLC import qualified Language.PlutusCore.StdLib.Data.Unit as PLC +import Codec.Serialise import Control.DeepSeq (rnf) import Control.Monad import Control.Monad.Trans.Except (runExceptT) @@ -250,7 +251,7 @@ getCborInput (FileInput file) = BSL.readFile file loadPlcFromCborFile :: Input -> IO PlainProgram loadPlcFromCborFile inp = do p <- getCborInput inp -- The type is constrained in the Right case below. - case deserialiseRestoringUnitsOrFail p of -- See Note [Annotation Types] + case deserialiseOrFail p of Left (DeserialiseFailure offset msg) -> do putStrLn $ "Deserialisation failure at offset " ++ show offset ++ ": " ++ msg @@ -330,7 +331,7 @@ runPrint (PrintOptions inp mode) = runPlcToCbor :: PlcToCborOptions -> IO () runPlcToCbor (PlcToCborOptions inp outp) = do p <- parsePlcFile inp - let cbor = serialiseOmittingUnits (() <$ p) -- Change annotations to (): see Note [Annotation types]. + let cbor = serialise (() <$ p) -- Change annotations to (): see Note [Annotation types]. case outp of FileOutput file -> BSL.writeFile file cbor StdOutput -> BSL.putStr cbor *> putStrLn "" diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index e333d4f4a6d..ae0381df6d4 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -118,6 +118,7 @@ library Language.PlutusIR.TypeCheck Language.UntypedPlutusCore + Language.UntypedPlutusCore.DeBruijn Language.UntypedPlutusCore.Evaluation.Machine.Cek PlutusPrelude @@ -149,6 +150,7 @@ library Language.PlutusCore.Constant.Function Language.PlutusCore.Constant.Name Language.PlutusCore.Constant.Typed + Language.PlutusCore.DeBruijn.Internal Language.PlutusCore.Lexer.Type Language.PlutusCore.Eq Language.PlutusCore.Mark @@ -196,7 +198,9 @@ library Language.UntypedPlutusCore.Core.Instance.Pretty.Classic Language.UntypedPlutusCore.Core.Instance.Pretty.Plc Language.UntypedPlutusCore.Core.Instance.Pretty.Readable + Language.UntypedPlutusCore.Core.Instance.CBOR Language.UntypedPlutusCore.Core.Type + Language.UntypedPlutusCore.Size Language.UntypedPlutusCore.Subst Data.Aeson.THReader diff --git a/plutus-core/plutus-ir-test/Spec.hs b/plutus-core/plutus-ir-test/Spec.hs index e19ca20ed16..35c52d4bd0b 100644 --- a/plutus-core/plutus-ir-test/Spec.hs +++ b/plutus-core/plutus-ir-test/Spec.hs @@ -8,7 +8,6 @@ module Main (main) where import Common -import PlcTestUtils import PlutusPrelude import TestLib @@ -17,53 +16,18 @@ import ParserSpec import TransformSpec import TypeSpec -import Language.PlutusCore.Pretty (PrettyConst) -import Language.PlutusCore.Quote - import Language.PlutusIR -import Language.PlutusIR.Compiler -import Language.PlutusIR.Parser hiding (Error) +import Language.PlutusIR.Parser hiding (Error) -import qualified Language.PlutusCore as PLC +import qualified Language.PlutusCore as PLC import Test.Tasty import Codec.Serialise -import Control.Exception -import Control.Monad.Except -import Control.Monad.Morph -import Control.Monad.Reader -import Control.Lens hiding (transform) main :: IO () main = defaultMain $ runTestNestedIn ["plutus-ir-test"] tests -instance ( PLC.GShow uni, PLC.GEq uni, PLC.DefaultUni PLC.<: uni - , PLC.Closed uni, uni `PLC.Everywhere` PrettyConst, Pretty a, Typeable a, Typeable uni, Ord a - ) => GetProgram (Term TyName Name uni a) uni where - getProgram = asIfThrown . fmap (trivialProgram . void) . compileAndMaybeTypecheck True - --- | Adapt an computation that keeps its errors in an 'Except' into one that looks as if it caught them in 'IO'. -asIfThrown - :: Exception e - => Except e a - -> ExceptT SomeException IO a -asIfThrown = withExceptT SomeException . hoist (pure . runIdentity) - -compileAndMaybeTypecheck - :: (PLC.GShow uni, PLC.GEq uni, PLC.DefaultUni PLC.<: uni, Ord a) - => Bool - -> Term TyName Name uni a - -> Except (Error uni (Provenance a)) (PLC.Term TyName Name uni (Provenance a)) -compileAndMaybeTypecheck doTypecheck pir = flip runReaderT defaultCompilationCtx $ runQuoteT $ do - compiled <- compileTerm doTypecheck pir - when doTypecheck $ do - -- PLC errors are parameterized over PLC.Terms, whereas PIR errors over PIR.Terms and as such, these prism errors cannot be unified. - -- We instead run the ExceptT, collect any PLC error and explicitly lift into a PIR error by wrapping with PIR._PLCError - plcConcrete <- runExceptT $ void $ PLC.inferType PLC.defConfig compiled - liftEither $ first (view (re _PLCError)) plcConcrete - pure compiled - tests :: TestNested tests = testGroup "plutus-ir" <$> sequence [ prettyprinting diff --git a/plutus-core/plutus-ir-test/TestLib.hs b/plutus-core/plutus-ir-test/TestLib.hs index 9af51b1a48e..7917ab3163c 100644 --- a/plutus-core/plutus-ir-test/TestLib.hs +++ b/plutus-core/plutus-ir-test/TestLib.hs @@ -1,7 +1,11 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module TestLib where import Common @@ -11,22 +15,58 @@ import PlutusPrelude import Control.Exception import Control.Monad.Except import Control.Monad.Reader as Reader +import Control.Monad.Morph +import Control.Lens hiding (transform, op) +import qualified Language.PlutusCore as PLC import qualified Language.PlutusCore.DeBruijn as PLC import Language.PlutusCore.Name import Language.PlutusCore.Pretty import Language.PlutusCore.Quote -import qualified Language.PlutusCore.Universe as PLC import Language.PlutusIR as PIR -import Language.PlutusIR.Error as PIR +import Language.PlutusIR.Compiler as PIR import Language.PlutusIR.Parser as Parser import Language.PlutusIR.TypeCheck +import qualified Language.UntypedPlutusCore as UPLC import System.FilePath (joinPath, ()) import Text.Megaparsec.Pos import qualified Data.Text as T import qualified Data.Text.IO as T + +instance ( PLC.GShow uni, PLC.GEq uni, PLC.DefaultUni PLC.<: uni + , PLC.Closed uni, uni `PLC.Everywhere` PrettyConst, Pretty a, Typeable a, Typeable uni, Ord a + ) => ToTPlc (PIR.Term TyName Name uni a) uni where + toTPlc = asIfThrown . fmap (PLC.Program () (PLC.defaultVersion ()) . void) . compileAndMaybeTypecheck True + +instance ( PLC.GShow uni, PLC.GEq uni, PLC.DefaultUni PLC.<: uni , PLC.Closed uni, uni `PLC.Everywhere` PrettyConst, Pretty a, Typeable a, Typeable uni, Ord a + ) => ToUPlc (PIR.Term TyName Name uni a) uni where + toUPlc t = do + p' <- toTPlc t + pure $ UPLC.eraseProgram p' + +-- | Adapt an computation that keeps its errors in an 'Except' into one that looks as if it caught them in 'IO'. +asIfThrown + :: Exception e + => Except e a + -> ExceptT SomeException IO a +asIfThrown = withExceptT SomeException . hoist (pure . runIdentity) + +compileAndMaybeTypecheck + :: (PLC.GShow uni, PLC.GEq uni, PLC.DefaultUni PLC.<: uni, Ord a) + => Bool + -> Term TyName Name uni a + -> Except (PIR.Error uni (PIR.Provenance a)) (PLC.Term TyName Name uni (PIR.Provenance a)) +compileAndMaybeTypecheck doTypecheck pir = flip runReaderT defaultCompilationCtx $ runQuoteT $ do + compiled <- compileTerm doTypecheck pir + when doTypecheck $ do + -- PLC errors are parameterized over PLC.Terms, whereas PIR errors over PIR.Terms and as such, these prism errors cannot be unified. + -- We instead run the ExceptT, collect any PLC error and explicitly lift into a PIR error by wrapping with PIR._PLCError + plcConcrete <- runExceptT $ void $ PLC.inferType PLC.defConfig compiled + liftEither $ first (view (re _PLCError)) plcConcrete + pure compiled + withGoldenFileM :: String -> (T.Text -> IO T.Text) -> TestNested withGoldenFileM name op = do dir <- currentDir @@ -49,19 +89,18 @@ ppThrow = fmap render . rethrow . fmap prettyPlcClassicDebug ppCatch :: PrettyPlc a => ExceptT SomeException IO a -> IO T.Text ppCatch value = render <$> (either (pretty . show) prettyPlcClassicDebug <$> runExceptT value) -goldenPlcFromPir :: GetProgram a PLC.DefaultUni => Parser a -> String -> TestNested +goldenPlcFromPir :: ToTPlc a PLC.DefaultUni => Parser a -> String -> TestNested goldenPlcFromPir = goldenPirM (\ast -> ppThrow $ do - p <- getProgram ast + p <- toTPlc ast withExceptT toException $ PLC.deBruijnProgram p) -goldenPlcFromPirCatch :: GetProgram a PLC.DefaultUni => Parser a -> String -> TestNested +goldenPlcFromPirCatch :: ToTPlc a PLC.DefaultUni => Parser a -> String -> TestNested goldenPlcFromPirCatch = goldenPirM (\ast -> ppCatch $ do - p <- getProgram ast + p <- toTPlc ast withExceptT toException $ PLC.deBruijnProgram p) -goldenEvalPir :: (GetProgram a PLC.DefaultUni) => Parser a -> String -> TestNested -goldenEvalPir = goldenPirM (\ast -> ppThrow $ runPlc [ast]) - +goldenEvalPir :: (ToUPlc a PLC.DefaultUni) => Parser a -> String -> TestNested +goldenEvalPir = goldenPirM (\ast -> ppThrow $ runUPlc [ast]) goldenTypeFromPir :: forall a. (Pretty a, Typeable a) => Parser (Term TyName Name PLC.DefaultUni a) -> String -> TestNested @@ -73,7 +112,6 @@ goldenTypeFromPirCatch :: forall a. (Pretty a, Typeable a) goldenTypeFromPirCatch = goldenPirM (\ast -> ppCatch $ withExceptT (toException :: PIR.Error PLC.DefaultUni a -> SomeException) $ runQuoteT $ inferType defConfig ast) - -- TODO: perhaps move to Common.hs instance Pretty SourcePos where pretty = pretty . sourcePosPretty diff --git a/plutus-core/plutus-ir-test/datatypes/listMatchEval.golden b/plutus-core/plutus-ir-test/datatypes/listMatchEval.golden index ccd428c22db..a988d507254 100644 --- a/plutus-core/plutus-ir-test/datatypes/listMatchEval.golden +++ b/plutus-core/plutus-ir-test/datatypes/listMatchEval.golden @@ -1 +1 @@ -(abs a_11 (type) (lam x_12 a_11 x_12)) \ No newline at end of file +(delay (lam x_12 x_12)) \ No newline at end of file diff --git a/plutus-core/plutus-ir-test/recursion/even3Eval.golden b/plutus-core/plutus-ir-test/recursion/even3Eval.golden index 215b70fa1c6..20bdc69eb03 100644 --- a/plutus-core/plutus-ir-test/recursion/even3Eval.golden +++ b/plutus-core/plutus-ir-test/recursion/even3Eval.golden @@ -1,7 +1 @@ -(abs - out_Bool_132 - (type) - (lam - case_True_133 out_Bool_132 (lam case_False_134 out_Bool_132 case_False_134) - ) -) \ No newline at end of file +(delay (lam case_True_133 (lam case_False_134 case_False_134))) \ No newline at end of file diff --git a/plutus-core/src/Language/PlutusCore.hs b/plutus-core/src/Language/PlutusCore.hs index 7d24076900a..70d7cccc549 100644 --- a/plutus-core/src/Language/PlutusCore.hs +++ b/plutus-core/src/Language/PlutusCore.hs @@ -209,5 +209,4 @@ format cfg = runQuoteT . fmap (displayBy cfg) . (rename <=< parseProgramDef) -- | Take one PLC program and apply it to another. applyProgram :: Program tyname name uni () -> Program tyname name uni () -> Program tyname name uni () --- TODO: some kind of version checking applyProgram (Program _ _ t1) (Program _ _ t2) = Program () (defaultVersion ()) (Apply () t1 t2) diff --git a/plutus-core/src/Language/PlutusCore/CBOR.hs b/plutus-core/src/Language/PlutusCore/CBOR.hs index 00abc9046ae..1a3d31fcfb5 100644 --- a/plutus-core/src/Language/PlutusCore/CBOR.hs +++ b/plutus-core/src/Language/PlutusCore/CBOR.hs @@ -14,10 +14,8 @@ module Language.PlutusCore.CBOR ( encode , decode - , OmitUnitAnnotations (..) - , serialiseOmittingUnits - , deserialiseRestoringUnits - , deserialiseRestoringUnitsOrFail + , encodeConstructorTag + , decodeConstructorTag , DeserialiseFailure (..) ) where -- Codec.CBOR.DeserialiseFailure is re-exported from this module for use with deserialiseRestoringUnitsOrFail @@ -28,13 +26,10 @@ import Language.PlutusCore.Lexer.Type import Language.PlutusCore.MkPlc (TyVarDecl (..), VarDecl (..)) import Language.PlutusCore.Name import Language.PlutusCore.Universe -import PlutusPrelude - import Codec.CBOR.Decoding import Codec.CBOR.Encoding import Codec.Serialise -import qualified Data.ByteString.Lazy as BSL import Data.Proxy {- Note [Stable encoding of PLC] @@ -284,67 +279,3 @@ instance Serialise DeBruijn where instance Serialise TyDeBruijn where encode (TyDeBruijn n) = encode n decode = TyDeBruijn <$> decode - - -{- Note [Serialising unit annotations] - -Serialising the unit annotation takes up space: () is converted to the -CBOR `null` value, which is encoded as the byte 0xF6. In typical -examples these account for 30% or more of the bytes in a serialised -PLC program. We don't actually need to serialise unit annotations -since we know where they're going to appear when we're deserialising, -and we know what the value has to be. The `InvisibleUnit` type below -has instances which takes care of this for us: if we have an -`InvisibleUnit`-annotated program `prog` then `serialise prog` will -serialise a program omitting the annotations, and `deserialise` (with -an appropriate type ascription) will give us back an -`InvisibleUnit`-annotated program. - -We usually deal with ()-annotated ASTs, so the annotations have to be -converted to and from `InvisibleUnit` if we wish to save space. The -obvious way to do this is to use `InvisibleUnit <$ ...` and -`() <$ ...`, but these have the disadvantage that they have to traverse the -entire AST and visit every annotation, adding an extra cost which may -be undesirable when deserialising things on-chain. However, -`InvisibleUnit` has the same underlying representation as `()`, and -we can exploit this using Data.Coerce.coerce to convert entire ASTs -with no run-time overhead. --} - -newtype InvisibleUnit = InvisibleUnit () - -instance Serialise InvisibleUnit where - encode = mempty - decode = pure (InvisibleUnit ()) - -{- Note [Serialising Scripts] - -At first sight, all we need to do to serialise a script without unit -annotations appearing in the CBOR is to coerce from `()` to -`InvisibleUnit` and then apply `serialise` as normal. However, this -isn't sufficient for the ledger code. There are a number of places in -Ledger.Scripts and elsewhere where hashes of objects (`Tx`, for -example) are calculated by serialising the entire object and -calculating a hash, and these objects can contain Scripts themselves. -Serialisation is achieved using the Generic instance of `Serialise`, -which will just use `encode` on everything, including unit -annotations. we could overcome this by writing explicit `Serialise` -instances for everything. This would be more space-efficient than the -Generic encoding, but would introduce a lot of extra code. Instead, -we provide a wrapper class with an instance which performs the -coercions for us. This is used in `Ledger.Scripts.Script` to -derive a suitable instance of `Serialise` for scripts. -} - -newtype OmitUnitAnnotations uni = OmitUnitAnnotations { restoreUnitAnnotations :: Program TyName Name uni () } - deriving Serialise via Program TyName Name uni InvisibleUnit - -{-| Convenience functions for serialisation/deserialisation without units -} -serialiseOmittingUnits :: (Closed uni, uni `Everywhere` Serialise) => Program TyName Name uni () -> BSL.ByteString -serialiseOmittingUnits = serialise . OmitUnitAnnotations - -deserialiseRestoringUnits :: (Closed uni, uni `Everywhere` Serialise) => BSL.ByteString -> Program TyName Name uni () -deserialiseRestoringUnits = restoreUnitAnnotations <$> deserialise - -deserialiseRestoringUnitsOrFail :: (Closed uni, uni `Everywhere` Serialise) => - BSL.ByteString -> Either DeserialiseFailure (Program TyName Name uni ()) -deserialiseRestoringUnitsOrFail = second restoreUnitAnnotations <$> deserialiseOrFail diff --git a/plutus-core/src/Language/PlutusCore/DeBruijn.hs b/plutus-core/src/Language/PlutusCore/DeBruijn.hs index 2a9ce682246..fce33d6c941 100644 --- a/plutus-core/src/Language/PlutusCore/DeBruijn.hs +++ b/plutus-core/src/Language/PlutusCore/DeBruijn.hs @@ -17,146 +17,16 @@ module Language.PlutusCore.DeBruijn , unDeBruijnProgram ) where +import Language.PlutusCore.DeBruijn.Internal + import Language.PlutusCore.Core import Language.PlutusCore.Name -import Language.PlutusCore.Pretty import Language.PlutusCore.Quote -import Control.Exception -import Control.Lens hiding (Index, Level, index, ix) import Control.Monad.Except import Control.Monad.Reader -import qualified Data.Bimap as BM -import qualified Data.Text as T -import Data.Typeable - -import Numeric.Natural - -import GHC.Generics - --- | A relative index used for de Bruijn identifiers. -newtype Index = Index Natural - deriving stock Generic - deriving newtype (Show, Num, Eq, Ord) - --- | A term name as a de Bruijn index. -data DeBruijn = DeBruijn { dbnString :: T.Text, dbnIndex :: Index } - deriving (Show, Generic) - --- | A type name as a de Bruijn index. -newtype TyDeBruijn = TyDeBruijn DeBruijn - deriving (Show, Generic, PrettyBy config) -instance Wrapped TyDeBruijn - -instance HasPrettyConfigName config => PrettyBy config DeBruijn where - prettyBy config (DeBruijn txt (Index ix)) - | showsUnique = pretty txt <> "_i" <> pretty ix - | otherwise = pretty txt - where PrettyConfigName showsUnique = toPrettyConfigName config - -class HasIndex a where - index :: Lens' a Index - -instance HasIndex DeBruijn where - index = lens g s where - g = dbnIndex - s n i = n{dbnIndex=i} - -instance HasIndex TyDeBruijn where - index = _Wrapped' . index - --- Converting from normal names to DeBruijn indices, and vice versa - -{- Note [Levels and indices] -The indices ('Index') that we actually store as our de Bruijn indices in the program -are *relative* - that is, they say how many levels above the *current* level to look for -the binder. - -However, when doing conversions it is easier to record the *absolute* level of a variable, -in our state, since that way we don't have to adjust our mapping when we go under a binder (whereas -for relative indices we would need to increment them all by one, as the current level has increased). - -However, this means that we *do* need to do an adjustment when we store an index as a level or extract -a level to use it as an index. The adjustment is fairly straightforward: -- An index `i` points to a binder `i` levels above (smaller than) the current level, so the level - of `i` is `current - i`. -- A level `l` which is `i` levels above (smaller than) the current level has an index of `i`, so it - is also calculated as `current - l`. - -We use a newtype to keep these separate, since getting it wrong will leads to annoying bugs. --} - --- | An absolute level in the program. -newtype Level = Level Index deriving newtype (Eq, Ord, Num) -data Levels = Levels Level (BM.Bimap Unique Level) - --- | Compute the absolute 'Level' of a relative 'Index' relative to the current 'Level'. -ixToLevel :: Level -> Index -> Level -ixToLevel (Level current) ix = Level (current - ix) - --- | Compute the relative 'Index' of a absolute 'Level' relative to the current 'Level'. -levelToIndex :: Level -> Level -> Index -levelToIndex (Level current) (Level l) = current - l - --- | Declare a name with a unique, recording the mapping to a 'Level'. -declareUnique :: (MonadReader Levels m, HasUnique name unique) => name -> m a -> m a -declareUnique n = - local $ \(Levels current ls) -> Levels current $ BM.insert (n ^. theUnique) current ls - --- | Declare a name with an index, recording the mapping from the corresponding 'Level' to a fresh unique. -declareIndex :: (MonadReader Levels m, MonadQuote m, HasIndex name) => name -> m a -> m a -declareIndex n act = do - newU <- freshUnique - local (\(Levels current ls) -> Levels current $ BM.insert newU (ixToLevel current (n ^. index)) ls) act - --- | Enter a scope, incrementing the current 'Level' by one -withScope :: MonadReader Levels m => m a -> m a -withScope = local $ \(Levels current ls) -> Levels (current+1) ls - --- | We cannot do a correct translation to or from de Bruijn indices if the program is not well-scoped. --- So we throw an error in such a case. -data FreeVariableError - = FreeUnique Unique - | FreeIndex Index - deriving (Show, Typeable, Eq, Ord) -instance Exception FreeVariableError - --- | Get the 'Index' corresponding to a given 'Unique'. -getIndex :: (MonadReader Levels m, MonadError FreeVariableError m) => Unique -> m Index -getIndex u = do - Levels current ls <- ask - case BM.lookup u ls of - Just ix -> pure $ levelToIndex current ix - Nothing -> throwError $ FreeUnique u - --- | Get the 'Unique' corresponding to a given 'Index'. -getUnique :: (MonadReader Levels m, MonadError FreeVariableError m) => Index -> m Unique -getUnique ix = do - Levels current ls <- ask - case BM.lookupR (ixToLevel current ix) ls of - Just u -> pure u - Nothing -> throwError $ FreeIndex ix - -nameToDeBruijn - :: (MonadReader Levels m, MonadError FreeVariableError m) - => Name -> m DeBruijn -nameToDeBruijn (Name str u) = DeBruijn str <$> getIndex u - -tyNameToDeBruijn - :: (MonadReader Levels m, MonadError FreeVariableError m) - => TyName -> m TyDeBruijn -tyNameToDeBruijn (TyName n) = TyDeBruijn <$> nameToDeBruijn n - -deBruijnToName - :: (MonadReader Levels m, MonadError FreeVariableError m) - => DeBruijn -> m Name -deBruijnToName (DeBruijn str ix) = Name str <$> getUnique ix - -deBruijnToTyName - :: (MonadReader Levels m, MonadError FreeVariableError m) - => TyDeBruijn -> m TyName -deBruijnToTyName (TyDeBruijn n) = TyName <$> deBruijnToName n +import qualified Data.Bimap as BM -- | Convert a 'Type' with 'TyName's into a 'Type' with 'TyDeBruijn's. deBruijnTy diff --git a/plutus-core/src/Language/PlutusCore/DeBruijn/Internal.hs b/plutus-core/src/Language/PlutusCore/DeBruijn/Internal.hs new file mode 100644 index 00000000000..176a2f363a9 --- /dev/null +++ b/plutus-core/src/Language/PlutusCore/DeBruijn/Internal.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Support for using de Bruijn indices for term and type names. +module Language.PlutusCore.DeBruijn.Internal + ( Index (..) + , DeBruijn (..) + , TyDeBruijn (..) + , FreeVariableError (..) + , Level (..) + , Levels (..) + , ixToLevel + , levelToIndex + , declareUnique + , declareIndex + , withScope + , getIndex + , getUnique + , nameToDeBruijn + , tyNameToDeBruijn + , deBruijnToName + , deBruijnToTyName + ) where + +import Language.PlutusCore.Name +import Language.PlutusCore.Pretty +import Language.PlutusCore.Quote + +import Control.Exception +import Control.Lens hiding (Index, Level, index, ix) +import Control.Monad.Except +import Control.Monad.Reader + +import qualified Data.Bimap as BM +import qualified Data.Text as T +import Data.Typeable + +import Numeric.Natural + +import GHC.Generics + +-- | A relative index used for de Bruijn identifiers. +newtype Index = Index Natural + deriving stock Generic + deriving newtype (Show, Num, Eq, Ord) + +-- | A term name as a de Bruijn index. +data DeBruijn = DeBruijn { dbnString :: T.Text, dbnIndex :: Index } + deriving (Show, Generic) + +-- | A type name as a de Bruijn index. +newtype TyDeBruijn = TyDeBruijn DeBruijn + deriving (Show, Generic, PrettyBy config) +instance Wrapped TyDeBruijn + +instance HasPrettyConfigName config => PrettyBy config DeBruijn where + prettyBy config (DeBruijn txt (Index ix)) + | showsUnique = pretty txt <> "_i" <> pretty ix + | otherwise = pretty txt + where PrettyConfigName showsUnique = toPrettyConfigName config + +class HasIndex a where + index :: Lens' a Index + +instance HasIndex DeBruijn where + index = lens g s where + g = dbnIndex + s n i = n{dbnIndex=i} + +instance HasIndex TyDeBruijn where + index = _Wrapped' . index + +-- Converting from normal names to DeBruijn indices, and vice versa + +{- Note [Levels and indices] +The indices ('Index') that we actually store as our de Bruijn indices in the program +are *relative* - that is, they say how many levels above the *current* level to look for +the binder. + +However, when doing conversions it is easier to record the *absolute* level of a variable, +in our state, since that way we don't have to adjust our mapping when we go under a binder (whereas +for relative indices we would need to increment them all by one, as the current level has increased). + +However, this means that we *do* need to do an adjustment when we store an index as a level or extract +a level to use it as an index. The adjustment is fairly straightforward: +- An index `i` points to a binder `i` levels above (smaller than) the current level, so the level + of `i` is `current - i`. +- A level `l` which is `i` levels above (smaller than) the current level has an index of `i`, so it + is also calculated as `current - l`. + +We use a newtype to keep these separate, since getting it wrong will leads to annoying bugs. +-} + +-- | An absolute level in the program. +newtype Level = Level Index deriving newtype (Eq, Ord, Num) +data Levels = Levels Level (BM.Bimap Unique Level) + +-- | Compute the absolute 'Level' of a relative 'Index' relative to the current 'Level'. +ixToLevel :: Level -> Index -> Level +ixToLevel (Level current) ix = Level (current - ix) + +-- | Compute the relative 'Index' of a absolute 'Level' relative to the current 'Level'. +levelToIndex :: Level -> Level -> Index +levelToIndex (Level current) (Level l) = current - l + +-- | Declare a name with a unique, recording the mapping to a 'Level'. +declareUnique :: (MonadReader Levels m, HasUnique name unique) => name -> m a -> m a +declareUnique n = + local $ \(Levels current ls) -> Levels current $ BM.insert (n ^. theUnique) current ls + +-- | Declare a name with an index, recording the mapping from the corresponding 'Level' to a fresh unique. +declareIndex :: (MonadReader Levels m, MonadQuote m, HasIndex name) => name -> m a -> m a +declareIndex n act = do + newU <- freshUnique + local (\(Levels current ls) -> Levels current $ BM.insert newU (ixToLevel current (n ^. index)) ls) act + +-- | Enter a scope, incrementing the current 'Level' by one +withScope :: MonadReader Levels m => m a -> m a +withScope = local $ \(Levels current ls) -> Levels (current+1) ls + +-- | We cannot do a correct translation to or from de Bruijn indices if the program is not well-scoped. +-- So we throw an error in such a case. +data FreeVariableError + = FreeUnique Unique + | FreeIndex Index + deriving (Show, Typeable, Eq, Ord) +instance Exception FreeVariableError + +-- | Get the 'Index' corresponding to a given 'Unique'. +getIndex :: (MonadReader Levels m, MonadError FreeVariableError m) => Unique -> m Index +getIndex u = do + Levels current ls <- ask + case BM.lookup u ls of + Just ix -> pure $ levelToIndex current ix + Nothing -> throwError $ FreeUnique u + +-- | Get the 'Unique' corresponding to a given 'Index'. +getUnique :: (MonadReader Levels m, MonadError FreeVariableError m) => Index -> m Unique +getUnique ix = do + Levels current ls <- ask + case BM.lookupR (ixToLevel current ix) ls of + Just u -> pure u + Nothing -> throwError $ FreeIndex ix + +nameToDeBruijn + :: (MonadReader Levels m, MonadError FreeVariableError m) + => Name -> m DeBruijn +nameToDeBruijn (Name str u) = DeBruijn str <$> getIndex u + +tyNameToDeBruijn + :: (MonadReader Levels m, MonadError FreeVariableError m) + => TyName -> m TyDeBruijn +tyNameToDeBruijn (TyName n) = TyDeBruijn <$> nameToDeBruijn n + +deBruijnToName + :: (MonadReader Levels m, MonadError FreeVariableError m) + => DeBruijn -> m Name +deBruijnToName (DeBruijn str ix) = Name str <$> getUnique ix + +deBruijnToTyName + :: (MonadReader Levels m, MonadError FreeVariableError m) + => TyDeBruijn -> m TyName +deBruijnToTyName (TyDeBruijn n) = TyName <$> deBruijnToName n diff --git a/plutus-core/test/Spec.hs b/plutus-core/test/Spec.hs index ab6ff1af91a..2242a048eb7 100644 --- a/plutus-core/test/Spec.hs +++ b/plutus-core/test/Spec.hs @@ -15,7 +15,6 @@ import Pretty.Readable import TypeSynthesis.Spec (test_typecheck) import Language.PlutusCore -import Language.PlutusCore.CBOR import Language.PlutusCore.DeBruijn import Language.PlutusCore.Evaluation.Machine.Cek (unsafeEvaluateCek) import Language.PlutusCore.Evaluation.Machine.ExBudgetingDefaults @@ -98,11 +97,6 @@ propCBOR = property $ do prog <- forAllPretty $ runAstGen genProgram Hedgehog.tripping prog serialise deserialiseOrFail -propCBORnoUnits :: Property -propCBORnoUnits = property $ do - prog <- forAllPretty $ runAstGen genProgram - Hedgehog.tripping prog serialiseOmittingUnits deserialiseRestoringUnitsOrFail - -- Generate a random 'Program', pretty-print it, and parse the pretty-printed -- text, hopefully returning the same thing. propParser :: Property @@ -143,7 +137,6 @@ allTests plcFiles rwFiles typeFiles typeErrorFiles evalFiles = testGroup "all te [ tests , testProperty "parser round-trip" propParser , testProperty "serialization round-trip" propCBOR - , testProperty "serialization round-trip without units" propCBORnoUnits , testProperty "equality survives renaming" propRename , testProperty "equality does not survive mangling" propMangle , testGroup "de Bruijn transformation round-trip" $ diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore.hs index 9e92db74978..23d4929cf46 100644 --- a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore.hs +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore.hs @@ -1,5 +1,15 @@ module Language.UntypedPlutusCore ( module Export + , applyProgram ) where -import Language.UntypedPlutusCore.Core as Export +import Language.UntypedPlutusCore.Core as Export +import Language.UntypedPlutusCore.Size as Export +-- Also has some functions +import Language.UntypedPlutusCore.Core.Instance.CBOR as Export + +import qualified Language.PlutusCore as PLC + +-- | Take one PLC program and apply it to another. +applyProgram :: Program name uni () -> Program name uni () -> Program name uni () +applyProgram (Program _ _ t1) (Program _ _ t2) = Program () (PLC.defaultVersion ()) (Apply () t1 t2) diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance.hs index b5662d52e50..b3bb683a1ce 100644 --- a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance.hs +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance.hs @@ -1,4 +1,5 @@ module Language.UntypedPlutusCore.Core.Instance () where +import Language.UntypedPlutusCore.Core.Instance.CBOR () import Language.UntypedPlutusCore.Core.Instance.Eq () import Language.UntypedPlutusCore.Core.Instance.Pretty () diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/CBOR.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/CBOR.hs new file mode 100644 index 00000000000..01b22f28eef --- /dev/null +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/CBOR.hs @@ -0,0 +1,114 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.UntypedPlutusCore.Core.Instance.CBOR where + +import Language.UntypedPlutusCore.Core.Type + +import Language.PlutusCore.CBOR +import Language.PlutusCore.Name +import Language.PlutusCore.Universe + +import Codec.Serialise + +import qualified Data.ByteString.Lazy as BSL + +instance ( Closed uni + , uni `Everywhere` Serialise + , Serialise ann + , Serialise name + ) => Serialise (Term name uni ann) where + encode = \case + Var ann n -> encodeConstructorTag 0 <> encode ann <> encode n + Delay ann t -> encodeConstructorTag 1 <> encode ann <> encode t + LamAbs ann n t -> encodeConstructorTag 2 <> encode ann <> encode n <> encode t + Apply ann t t' -> encodeConstructorTag 3 <> encode ann <> encode t <> encode t' + Constant ann c -> encodeConstructorTag 4 <> encode ann <> encode c + Force ann t -> encodeConstructorTag 5 <> encode ann <> encode t + Error ann -> encodeConstructorTag 6 <> encode ann + Builtin ann bn -> encodeConstructorTag 7 <> encode ann <> encode bn + + decode = go =<< decodeConstructorTag + where go 0 = Var <$> decode <*> decode + go 1 = Delay <$> decode <*> decode + go 2 = LamAbs <$> decode <*> decode <*> decode + go 3 = Apply <$> decode <*> decode <*> decode + go 4 = Constant <$> decode <*> decode + go 5 = Force <$> decode <*> decode + go 6 = Error <$> decode + go 7 = Builtin <$> decode <*> decode + go _ = fail "Failed to decode Term TyName Name ()" + +instance ( Closed uni + , uni `Everywhere` Serialise + , Serialise ann + , Serialise name + ) => Serialise (Program name uni ann) where + encode (Program ann v t) = encode ann <> encode v <> encode t + decode = Program <$> decode <*> decode <*> decode + +{- Note [Serialising unit annotations] + +Serialising the unit annotation takes up space: () is converted to the +CBOR `null` value, which is encoded as the byte 0xF6. In typical +examples these account for 30% or more of the bytes in a serialised +PLC program. We don't actually need to serialise unit annotations +since we know where they're going to appear when we're deserialising, +and we know what the value has to be. The `InvisibleUnit` type below +has instances which takes care of this for us: if we have an +`InvisibleUnit`-annotated program `prog` then `serialise prog` will +serialise a program omitting the annotations, and `deserialise` (with +an appropriate type ascription) will give us back an +`InvisibleUnit`-annotated program. + +We usually deal with ()-annotated ASTs, so the annotations have to be +converted to and from `InvisibleUnit` if we wish to save space. The +obvious way to do this is to use `InvisibleUnit <$ ...` and +`() <$ ...`, but these have the disadvantage that they have to traverse the +entire AST and visit every annotation, adding an extra cost which may +be undesirable when deserialising things on-chain. However, +`InvisibleUnit` has the same underlying representation as `()`, and +we can exploit this using Data.Coerce.coerce to convert entire ASTs +with no run-time overhead. +-} + +newtype InvisibleUnit = InvisibleUnit () + +instance Serialise InvisibleUnit where + encode = mempty + decode = pure (InvisibleUnit ()) + +{- Note [Serialising Scripts] + +At first sight, all we need to do to serialise a script without unit +annotations appearing in the CBOR is to coerce from `()` to +`InvisibleUnit` and then apply `serialise` as normal. However, this +isn't sufficient for the ledger code. There are a number of places in +Ledger.Scripts and elsewhere where hashes of objects (`Tx`, for +example) are calculated by serialising the entire object and +calculating a hash, and these objects can contain Scripts themselves. +Serialisation is achieved using the Generic instance of `Serialise`, +which will just use `encode` on everything, including unit +annotations. we could overcome this by writing explicit `Serialise` +instances for everything. This would be more space-efficient than the +Generic encoding, but would introduce a lot of extra code. Instead, +we provide a wrapper class with an instance which performs the +coercions for us. This is used in `Ledger.Scripts.Script` to +derive a suitable instance of `Serialise` for scripts. -} + +newtype OmitUnitAnnotations uni = OmitUnitAnnotations { restoreUnitAnnotations :: Program Name uni () } + deriving Serialise via Program Name uni InvisibleUnit + +{-| Convenience functions for serialisation/deserialisation without units -} +serialiseOmittingUnits :: (Closed uni, uni `Everywhere` Serialise) => Program Name uni () -> BSL.ByteString +serialiseOmittingUnits = serialise . OmitUnitAnnotations + +deserialiseRestoringUnits :: (Closed uni, uni `Everywhere` Serialise) => BSL.ByteString -> Program Name uni () +deserialiseRestoringUnits = restoreUnitAnnotations <$> deserialise + +deserialiseRestoringUnitsOrFail :: (Closed uni, uni `Everywhere` Serialise) => + BSL.ByteString -> Either DeserialiseFailure (Program Name uni ()) +deserialiseRestoringUnitsOrFail bs = restoreUnitAnnotations <$> deserialiseOrFail bs diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs index e1467e6c319..2e05a6ba466 100644 --- a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs @@ -19,12 +19,13 @@ import Language.PlutusCore.Pretty.Classic import Language.PlutusCore.Pretty.PrettyConst import Language.PlutusCore.Universe +import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Custom instance (PrettyClassicBy configName name, GShow uni, Closed uni, uni `Everywhere` PrettyConst) => PrettyBy (PrettyConfigClassic configName) (Term name uni a) where prettyBy config = go where - go (Constant _ val) = parens' $ "con" pretty val -- NB: actually calls prettyConst + go (Constant _ val) = parens' $ "con" prettyTypeOf val pretty val -- NB: actually calls prettyConst go (Builtin _ bi) = parens' $ "builtin" pretty bi go (Var _ name) = prettyName name go (LamAbs _ name body) = parens' $ "lam" vsep' [prettyName name, go body] @@ -35,3 +36,10 @@ instance (PrettyClassicBy configName name, GShow uni, Closed uni, uni `Everywher prettyName :: PrettyClassicBy configName n => n -> Doc ann prettyName = prettyBy config + + prettyTypeOf :: GShow t => Some (ValueOf t) -> Doc ann + prettyTypeOf (Some (ValueOf uni _ )) = pretty $ TypeIn uni + +instance PrettyClassicBy configName (Term name uni a) => + PrettyBy (PrettyConfigClassic configName) (Program name uni a) where + prettyBy config (Program _ version term) = parens' $ "program" <+> pretty version prettyBy config term diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs index eb300dfd0cd..22be4683ea5 100644 --- a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs @@ -17,3 +17,6 @@ import Language.PlutusCore.Pretty.Plc deriving via PrettyAny (Term name uni ann) instance DefaultPrettyPlcStrategy (Term name uni ann) => PrettyBy PrettyConfigPlc (Term name uni ann) +deriving via PrettyAny (Program name uni ann) + instance DefaultPrettyPlcStrategy (Program name uni ann) => + PrettyBy PrettyConfigPlc (Program name uni ann) diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs index 637950ec137..df67cce0378 100644 --- a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs @@ -41,3 +41,9 @@ instance sequenceDocM ToTheRight juxtFixity $ \prettyEl -> "force" <+> prettyEl term Error _ -> unitDocM "error" + +instance PrettyReadableBy configName (Term name uni a) => + PrettyBy (PrettyConfigReadable configName) (Program name uni a) where + prettyBy = inContextM $ \(Program _ version term) -> + sequenceDocM ToTheRight juxtFixity $ \prettyEl -> + "program" <+> pretty version <+> prettyEl term diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Type.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Type.hs index 33a92ac78ea..d5c900b7f94 100644 --- a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Type.hs +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Core/Type.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -9,8 +11,10 @@ module Language.UntypedPlutusCore.Core.Type , TPLC.DynamicBuiltinName (..) , TPLC.BuiltinName (..) , Term (..) + , Program (..) , termAnn , erase + , eraseProgram ) where import PlutusPrelude @@ -43,7 +47,13 @@ data Term name uni ann | Delay ann (Term name uni ann) | Force ann (Term name uni ann) | Error ann - deriving (Show, Functor, Generic) + deriving stock (Show, Functor, Generic) + deriving anyclass (NFData) + +-- | A 'Program' is simply a 'Term' coupled with a 'Version' of the core language. +data Program name uni ann = Program ann (TPLC.Version ann) (Term name uni ann) + deriving stock (Show, Functor, Generic) + deriving anyclass (NFData) type instance TPLC.UniOf (Term name uni ann) = uni @@ -88,3 +98,7 @@ erase (TPLC.TyInst ann term _) = Force ann (erase term) erase (TPLC.Unwrap _ term) = erase term erase (TPLC.IWrap _ _ _ term) = erase term erase (TPLC.Error ann _) = Error ann + +-- | Erase a Typed Plutus Core Program to its untyped counterpart. +eraseProgram :: TPLC.Program tyname name uni ann -> Program name uni ann +eraseProgram (TPLC.Program a v t) = Program a v $ erase t diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/DeBruijn.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/DeBruijn.hs new file mode 100644 index 00000000000..afe57f74d40 --- /dev/null +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/DeBruijn.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Support for using de Bruijn indices for term names. +module Language.UntypedPlutusCore.DeBruijn + ( Index (..) + , DeBruijn (..) + , TyDeBruijn (..) + , FreeVariableError (..) + , deBruijnTerm + , deBruijnProgram + , unDeBruijnTerm + , unDeBruijnProgram + ) where + +import Language.PlutusCore.DeBruijn.Internal + +import Language.PlutusCore.Name +import Language.PlutusCore.Quote +import Language.UntypedPlutusCore.Core + +import Control.Monad.Except +import Control.Monad.Reader + +import qualified Data.Bimap as BM + +{- Note [Comparison with typed deBruijn conversion] +This module is just a boring port of the typed version. +-} + +-- | Convert a 'Term' with 'TyName's and 'Name's into a 'Term' with 'TyDeBruijn's and 'DeBruijn's. +deBruijnTerm + :: MonadError FreeVariableError m + => Term Name uni ann -> m (Term DeBruijn uni ann) +deBruijnTerm = flip runReaderT (Levels 0 BM.empty) . deBruijnTermM + +-- | Convert a 'Program' with 'TyName's and 'Name's into a 'Program' with 'TyDeBruijn's and 'DeBruijn's. +deBruijnProgram + :: MonadError FreeVariableError m + => Program Name uni ann -> m (Program DeBruijn uni ann) +deBruijnProgram (Program ann ver term) = Program ann ver <$> deBruijnTerm term + +deBruijnTermM + :: (MonadReader Levels m, MonadError FreeVariableError m) + => Term Name uni ann + -> m (Term DeBruijn uni ann) +deBruijnTermM = \case + -- variable case + Var ann n -> Var ann <$> nameToDeBruijn n + -- binder cases + LamAbs ann n t -> declareUnique n $ do + n' <- nameToDeBruijn n + withScope $ LamAbs ann n' <$> deBruijnTermM t + -- boring recursive cases + Apply ann t1 t2 -> Apply ann <$> deBruijnTermM t1 <*> deBruijnTermM t2 + Delay ann t -> Delay ann <$> deBruijnTermM t + Force ann t -> Force ann <$> deBruijnTermM t + -- boring non-recursive cases + Constant ann con -> pure $ Constant ann con + Builtin ann bn -> pure $ Builtin ann bn + Error ann -> pure $ Error ann + +-- | Convert a 'Term' with 'TyDeBruijn's and 'DeBruijn's into a 'Term' with 'TyName's and 'Name's. +unDeBruijnTerm + :: (MonadQuote m, MonadError FreeVariableError m) + => Term DeBruijn uni ann -> m (Term Name uni ann) +unDeBruijnTerm = flip runReaderT (Levels 0 BM.empty) . unDeBruijnTermM + +-- | Convert a 'Program' with 'TyDeBruijn's and 'DeBruijn's into a 'Program' with 'TyName's and 'Name's. +unDeBruijnProgram + :: (MonadQuote m, MonadError FreeVariableError m) + => Program DeBruijn uni ann -> m (Program Name uni ann) +unDeBruijnProgram (Program ann ver term) = Program ann ver <$> unDeBruijnTerm term + +unDeBruijnTermM + :: (MonadReader Levels m, MonadQuote m, MonadError FreeVariableError m) + => Term DeBruijn uni ann + -> m (Term Name uni ann) +unDeBruijnTermM = \case + -- variable case + Var ann n -> Var ann <$> deBruijnToName n + -- binder cases + LamAbs ann n t -> declareIndex n $ do + n' <- deBruijnToName n + withScope $ LamAbs ann n' <$> unDeBruijnTermM t + -- boring recursive cases + Apply ann t1 t2 -> Apply ann <$> unDeBruijnTermM t1 <*> unDeBruijnTermM t2 + Delay ann t -> Delay ann <$> unDeBruijnTermM t + Force ann t -> Force ann <$> unDeBruijnTermM t + -- boring non-recursive cases + Constant ann con -> pure $ Constant ann con + Builtin ann bn -> pure $ Builtin ann bn + Error ann -> pure $ Error ann diff --git a/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Size.hs b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Size.hs new file mode 100644 index 00000000000..e1b2252b30c --- /dev/null +++ b/plutus-core/untyped-plutus-core/Language/UntypedPlutusCore/Size.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} + +module Language.UntypedPlutusCore.Size + ( termSize + , programSize + , serialisedSize + ) where + +import Language.UntypedPlutusCore.Core + +import Codec.Serialise +import qualified Data.ByteString.Lazy as BSL + +-- | Count the number of AST nodes in a term. +termSize :: Term name uni ann -> Integer +termSize = \case + Var{} -> 1 + Delay _ t -> 1 + termSize t + Apply _ t t' -> 1 + termSize t + termSize t' + LamAbs _ _ t -> 1 + termSize t + Constant{} -> 1 + Builtin{} -> 1 + Force _ t -> 1 + termSize t + Error _ -> 1 + +-- | Count the number of AST nodes in a program. +programSize :: Program name uni ann -> Integer +programSize (Program _ _ t) = termSize t + +-- | Compute the size of the serializabled form of a value. +serialisedSize :: Serialise a => a -> Integer +serialisedSize = fromIntegral . BSL.length . serialise diff --git a/plutus-ledger/src/Ledger/Index.hs b/plutus-ledger/src/Ledger/Index.hs index efda64b5b55..c6037e0c5d4 100644 --- a/plutus-ledger/src/Ledger/Index.hs +++ b/plutus-ledger/src/Ledger/Index.hs @@ -218,7 +218,7 @@ checkForgingScripts tx = do mkVd i = PolicyCtx { policyCtxPolicy = monetaryPolicyHash $ mpss !! fromIntegral i, policyCtxTxInfo = txinfo } forM_ (mpss `zip` (mkVd <$> [0..])) $ \(vl, ptx') -> let vd = Context $ toData ptx' - in case runExcept $ runMonetaryPolicyScript Typecheck vd vl of + in case runExcept $ runMonetaryPolicyScript vd vl of Left e -> throwError $ ScriptFailure e Right _ -> pure () @@ -273,7 +273,7 @@ checkMatch txinfo = \case let ptx' = ValidatorCtx { valCtxTxInfo = txinfo, valCtxInput = ix } vd = Context (toData ptx') - case runExcept $ runScript Typecheck vd vl d r of + case runExcept $ runScript vd vl d r of Left e -> throwError $ ScriptFailure e Right _ -> pure () PubKeyMatch msg pk sig -> unless (signedBy sig pk msg) $ throwError $ InvalidSignature pk sig diff --git a/plutus-ledger/src/Ledger/Scripts.hs b/plutus-ledger/src/Ledger/Scripts.hs index 895cc629ce9..94fbd0dc79c 100644 --- a/plutus-ledger/src/Ledger/Scripts.hs +++ b/plutus-ledger/src/Ledger/Scripts.hs @@ -23,7 +23,6 @@ module Ledger.Scripts( Script (..), scriptSize, fromCompiledCode, - Checking (..), ScriptError (..), evaluateScript, runScript, @@ -55,57 +54,43 @@ module Ledger.Scripts( acceptingMonetaryPolicy ) where -import qualified Prelude as Haskell - -import Codec.Serialise (Serialise, serialise) -import Control.DeepSeq (NFData) -import Control.Monad.Except (MonadError, runExcept, throwError) -import Crypto.Hash (Digest, SHA256, hash) -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import qualified Data.Aeson as JSON -import qualified Data.Aeson.Extras as JSON -import qualified Data.ByteArray as BA -import qualified Data.ByteString.Lazy as BSL -import Data.Functor (void) -import Data.Hashable (Hashable) +import qualified Prelude as Haskell + +import Codec.Serialise (Serialise, serialise) +import Control.DeepSeq (NFData) +import Control.Monad.Except (MonadError, throwError) +import Crypto.Hash (Digest, SHA256, hash) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Extras as JSON +import qualified Data.ByteArray as BA +import qualified Data.ByteString.Lazy as BSL +import Data.Hashable (Hashable) import Data.String import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Extras -import GHC.Generics (Generic) -import IOTS (IotsType (iotsDefinition)) -import qualified Language.PlutusCore as PLC -import Language.PlutusCore.CBOR -import qualified Language.PlutusCore.Constant.Dynamic as PLC -import qualified Language.PlutusCore.Pretty as PLC -import Language.PlutusTx (CompiledCode, IsData (..), compile, getPlc, makeLift) -import Language.PlutusTx.Builtins as Builtins -import Language.PlutusTx.Evaluation (ErrorWithCause (..), EvaluationError (..), evaluateCekTrace) -import Language.PlutusTx.Lift (liftCode) +import GHC.Generics (Generic) +import IOTS (IotsType (iotsDefinition)) +import qualified Language.PlutusCore as PLC +import Language.PlutusTx (CompiledCode, IsData (..), compile, getPlc, makeLift) +import Language.PlutusTx.Builtins as Builtins +import Language.PlutusTx.Evaluation (ErrorWithCause (..), EvaluationError (..), evaluateCekTrace) +import Language.PlutusTx.Lift (liftCode) import Language.PlutusTx.Prelude -import Ledger.Orphans () -import LedgerBytes (LedgerBytes (..)) +import qualified Language.UntypedPlutusCore as UPLC +import Ledger.Orphans () +import LedgerBytes (LedgerBytes (..)) -- | A script on the chain. This is an opaque type as far as the chain is concerned. --- --- Note: the program inside the 'Script' should have normalized types. -newtype Script = Script { unScript :: PLC.Program PLC.TyName PLC.Name PLC.DefaultUni () } +newtype Script = Script { unScript :: UPLC.Program PLC.Name PLC.DefaultUni () } deriving stock Generic - deriving Serialise via OmitUnitAnnotations PLC.DefaultUni + deriving Serialise via UPLC.OmitUnitAnnotations PLC.DefaultUni -- | Don't include unit annotations in the CBOR when serialising. -- See Note [Serialising Scripts] in Language.PlutusCore.CBOR instance IotsType Script where iotsDefinition = iotsDefinition @Haskell.String -{- Note [Normalized types in Scripts] -The Plutus Tx plugin and lifting machinery does not necessarily produce programs -with normalized types, but we are supposed to put programs on the chain *with* -normalized types. - -So we normalize types when we turn things into 'Script's. The only operation we -do after that is applying 'Script's together, which preserves type normalization. --} - {- Note [Eq and Ord for Scripts] We need `Eq` and `Ord` instances for `Script`s mostly so we can put them in `Set`s. However, the `Eq` instance for `Program`s is *alpha-equivalence*, and we don't @@ -141,38 +126,32 @@ instance Haskell.Ord Script where instance NFData Script -data Checking = Typecheck | DontCheck - -- | The size of a 'Script'. No particular interpretation is given to this, other than that it is -- proportional to the serialized size of the script. scriptSize :: Script -> Integer -scriptSize (Script s) = PLC.programSize s +scriptSize (Script s) = UPLC.programSize s -- See Note [Normalized types in Scripts] -- | Turn a 'CompiledCode' (usually produced by 'compile') into a 'Script' for use with this package. fromCompiledCode :: CompiledCode PLC.DefaultUni a -> Script fromCompiledCode = fromPlc . getPlc -fromPlc :: PLC.Program PLC.TyName PLC.Name PLC.DefaultUni () -> Script +fromPlc :: UPLC.Program PLC.Name PLC.DefaultUni () -> Script fromPlc = Script -- | Given two 'Script's, compute the 'Script' that consists of applying the first to the second. applyScript :: Script -> Script -> Script -applyScript (unScript -> s1) (unScript -> s2) = Script $ s1 `PLC.applyProgram` s2 +applyScript (unScript -> s1) (unScript -> s2) = Script $ s1 `UPLC.applyProgram` s2 data ScriptError = - TypecheckError Haskell.String -- ^ Incorrect type at runtime - | EvaluationError [Haskell.String] -- ^ Expected behavior of the engine (e.g. user-provided error) + EvaluationError [Haskell.String] -- ^ Expected behavior of the engine (e.g. user-provided error) | EvaluationException Haskell.String -- ^ Unexpected behavior of the engine (a bug) deriving (Haskell.Show, Haskell.Eq, Generic, NFData) deriving anyclass (ToJSON, FromJSON) -- | Evaluate a script, returning the trace log. -evaluateScript :: forall m . (MonadError ScriptError m) => Checking -> Script -> m [Haskell.String] -evaluateScript checking s = do - case checking of - DontCheck -> Haskell.pure () - Typecheck -> void $ typecheckScript s +evaluateScript :: forall m . (MonadError ScriptError m) => Script -> m [Haskell.String] +evaluateScript s = do let (logOut, _tally, result) = evaluateCekTrace (unScript s) case result of Right _ -> Haskell.pure () @@ -181,19 +160,6 @@ evaluateScript checking s = do UserEvaluationError {} -> EvaluationError logOut -- TODO fix this error channel fuckery Haskell.pure logOut -typecheckScript :: (MonadError ScriptError m) => Script -> m (PLC.Type PLC.TyName PLC.DefaultUni ()) -typecheckScript (unScript -> p) = - either (throwError . TypecheckError . show . PLC.prettyPlcDef) Haskell.pure act - where - act :: Either (PLC.Error PLC.DefaultUni ()) (PLC.Type PLC.TyName PLC.DefaultUni ()) - act = runExcept $ PLC.runQuoteT $ do - types <- PLC.getStringBuiltinTypes () - -- We should be normalized, so we can use the on-chain config - -- See Note [Normalized types in Scripts] - -- FIXME - let config = PLC.defConfig { PLC._tccDynamicBuiltinNameTypes = types } - PLC.unNormalized Haskell.<$> PLC.typecheckPipeline config p - instance ToJSON Script where toJSON = JSON.String . JSON.encodeSerialise @@ -349,26 +315,24 @@ newtype Context = Context Data -- | Evaluate a validator script with the given arguments, returning the log. runScript :: (MonadError ScriptError m) - => Checking - -> Context + => Context -> Validator -> Datum -> Redeemer -> m [Haskell.String] -runScript checking (Context valData) (Validator validator) (Datum datum) (Redeemer redeemer) = do +runScript (Context valData) (Validator validator) (Datum datum) (Redeemer redeemer) = do let appliedValidator = ((validator `applyScript` (fromCompiledCode $ liftCode datum)) `applyScript` (fromCompiledCode $ liftCode redeemer)) `applyScript` (fromCompiledCode $ liftCode valData) - evaluateScript checking appliedValidator + evaluateScript appliedValidator -- | Evaluate a monetary policy script with just the validation context, returning the log. runMonetaryPolicyScript :: (MonadError ScriptError m) - => Checking - -> Context + => Context -> MonetaryPolicy -> m [Haskell.String] -runMonetaryPolicyScript checking (Context valData) (MonetaryPolicy validator) = do +runMonetaryPolicyScript (Context valData) (MonetaryPolicy validator) = do let appliedValidator = validator `applyScript` (fromCompiledCode $ liftCode valData) - evaluateScript checking appliedValidator + evaluateScript appliedValidator -- | @()@ as a datum. unitDatum :: Datum diff --git a/plutus-ledger/src/Ledger/Typed/Tx.hs b/plutus-ledger/src/Ledger/Typed/Tx.hs index ee605f05bce..da731e1c183 100644 --- a/plutus-ledger/src/Ledger/Typed/Tx.hs +++ b/plutus-ledger/src/Ledger/Typed/Tx.hs @@ -25,27 +25,20 @@ -- validation time. module Ledger.Typed.Tx where -import Ledger.Address hiding (scriptAddress) +import Ledger.Address hiding (scriptAddress) import Ledger.Crypto import Ledger.Scripts import Ledger.Tx import Ledger.TxId import Ledger.Typed.Scripts -import qualified Ledger.Value as Value - -import qualified Language.PlutusCore as PLC -import qualified Language.PlutusCore.Pretty as PLC +import qualified Ledger.Value as Value import Language.PlutusTx -import Language.PlutusTx.Lift as Lift - -import qualified Language.PlutusIR.Compiler as PIR -import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object), object, (.:), (.=)) -import Data.Aeson.Types (typeMismatch) -import Data.Proxy -import Data.Text.Prettyprint.Doc (Pretty (pretty), viaShow, (<+>)) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object), object, (.:), (.=)) +import Data.Aeson.Types (typeMismatch) +import Data.Text.Prettyprint.Doc (Pretty (pretty), viaShow, (<+>)) +import GHC.Generics (Generic) import Control.Monad.Except @@ -178,18 +171,6 @@ checkValidatorAddress ct actualAddr = do let expectedAddr = scriptAddress ct unless (expectedAddr == actualAddr) $ throwError $ WrongValidatorAddress expectedAddr actualAddr --- | Checks that the given validator script has the right type. -checkValidatorScript - :: forall a m - . (MonadError ConnectionError m) - => ScriptInstance a - -> Validator - -> m (CompiledCode PLC.DefaultUni WrappedValidatorType) -checkValidatorScript _ (unValidatorScript -> (Script prog)) = - case PLC.runQuote $ runExceptT @(PIR.Error PLC.DefaultUni (PIR.Provenance ())) $ Lift.typeCode (Proxy @WrappedValidatorType) prog of - Right code -> pure code - Left e -> throwError $ WrongValidatorType $ show $ PLC.prettyPlcDef e - -- | Checks that the given redeemer script has the right type. checkRedeemer :: forall inn m @@ -224,10 +205,11 @@ typeScriptTxIn -> TxIn -> m (TypedScriptTxIn inn) typeScriptTxIn lookupRef si TxIn{txInRef,txInType} = do - (vs, rs, ds) <- case txInType of + (_, rs, ds) <- case txInType of ConsumeScriptAddress vs rs ds -> pure (vs, rs, ds) x -> throwError $ WrongInType x - _ <- checkValidatorScript si vs + -- It would be nice to typecheck the validadator script here (we used to do that when we + -- had typed on-chain code), but we can't do that with untyped code! rsVal <- checkRedeemer si rs _ <- checkDatum si ds typedOut <- typeScriptTxOutRef @inn lookupRef si txInRef diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 77c77c84aff..711f92e8711 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -90,6 +90,7 @@ test-suite plutus-tx-tests StdLib.Spec TH.Spec TH.TestTH + Lib default-language: Haskell2010 build-depends: base >=4.9 && <5, diff --git a/plutus-tx-plugin/src/Language/PlutusTx/PLCTypes.hs b/plutus-tx-plugin/src/Language/PlutusTx/PLCTypes.hs index cdf3d77e12a..c4697d37084 100644 --- a/plutus-tx-plugin/src/Language/PlutusTx/PLCTypes.hs +++ b/plutus-tx-plugin/src/Language/PlutusTx/PLCTypes.hs @@ -1,7 +1,8 @@ module Language.PlutusTx.PLCTypes where -import qualified Language.PlutusCore as PLC -import qualified Language.PlutusCore.MkPlc as PLC +import qualified Language.PlutusCore as PLC +import qualified Language.PlutusCore.MkPlc as PLC +import qualified Language.UntypedPlutusCore as UPLC type PLCKind = PLC.Kind () type PLCType uni = PLC.Type PLC.TyName uni () @@ -10,3 +11,5 @@ type PLCProgram uni = PLC.Program PLC.TyName PLC.Name uni () type PLCVar uni = PLC.VarDecl PLC.TyName PLC.Name uni () type PLCTyVar = PLC.TyVarDecl PLC.TyName () + +type UPLCProgram uni = UPLC.Program PLC.Name uni () diff --git a/plutus-tx-plugin/src/Language/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/Language/PlutusTx/Plugin.hs index a3e01739b5d..b41a5293318 100644 --- a/plutus-tx-plugin/src/Language/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/Language/PlutusTx/Plugin.hs @@ -31,6 +31,8 @@ import qualified Language.PlutusCore as PLC import qualified Language.PlutusCore.Constant.Dynamic as PLC import Language.PlutusCore.Quote +import qualified Language.UntypedPlutusCore as UPLC + import qualified Language.PlutusIR as PIR import qualified Language.PlutusIR.Compiler as PIR import qualified Language.PlutusIR.Compiler.Definitions as PIR @@ -283,9 +285,9 @@ compileCoreExpr (opts, famEnvs) locStr codeTy origE = do pure $ GHC.mkRuntimeErrorApp GHC.rUNTIME_ERROR_ID (GHC.mkTyConApp tc args) shown -- this will actually terminate compilation else failCompilation shown - Right (pirP, plcP) -> do + Right (pirP, _, uplcP) -> do bsLitPir <- makeByteStringLiteral $ BSL.toStrict $ serialise pirP - bsLitPlc <- makeByteStringLiteral $ BSL.toStrict $ serialise plcP + bsLitPlc <- makeByteStringLiteral $ BSL.toStrict $ serialise uplcP builder <- GHC.lookupId =<< thNameToGhcNameOrFail 'mkCompiledCode @@ -299,7 +301,7 @@ runCompiler :: forall uni m . (uni ~ PLC.DefaultUni, MonadReader (CompileContext uni) m, MonadState CompileState m, MonadQuote m, MonadError (CompileError uni) m, MonadIO m) => PluginOptions -> GHC.CoreExpr - -> m (PIRProgram uni, PLCProgram uni) + -> m (PIRProgram uni, PLCProgram uni, UPLCProgram uni) runCompiler opts expr = do -- trick here to take out the concrete plc.error tcConfigConcrete <- @@ -333,4 +335,5 @@ runCompiler opts expr = do -- also wrap the PLC Error annotations into Original provenances, to match our expected compileerror liftEither $ first (view (re PIR._PLCError) . fmap PIR.Original) tcConcrete - pure (pirP, plcP) + let uplcP = UPLC.eraseProgram plcP + pure (pirP, plcP, uplcP) diff --git a/plutus-tx-plugin/test/Lib.hs b/plutus-tx-plugin/test/Lib.hs new file mode 100644 index 00000000000..ad5b34fcada --- /dev/null +++ b/plutus-tx-plugin/test/Lib.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Lib where + +import Common +import PlcTestUtils + +import Language.Haskell.TH +import Language.PlutusTx.Prelude + +import qualified Language.PlutusTx.Builtins as Builtins +import Language.PlutusTx.Code +import Language.PlutusTx.Evaluation +import Language.PlutusTx.Prelude +import Language.PlutusTx.TH + +import Language.PlutusCore.Pretty (PrettyConst) +import qualified Language.PlutusCore.Universe as PLC +import qualified Language.UntypedPlutusCore as UPLC + +import Codec.Serialise (Serialise) +import Data.Text.Prettyprint.Doc + +instance (PLC.Closed uni, uni `PLC.Everywhere` Serialise) => + ToUPlc (CompiledCode uni a) uni where + toUPlc = catchAll . getPlc + +goldenPir + :: (PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PrettyConst, uni `PLC.Everywhere` Serialise) + => String -> CompiledCode uni a -> TestNested +goldenPir name value = nestedGoldenVsDoc name $ pretty $ getPir value diff --git a/plutus-tx-plugin/test/Lift/Spec.hs b/plutus-tx-plugin/test/Lift/Spec.hs index 7da6417e29f..f01e7015bf3 100644 --- a/plutus-tx-plugin/test/Lift/Spec.hs +++ b/plutus-tx-plugin/test/Lift/Spec.hs @@ -7,19 +7,16 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Lift.Spec where -import Plugin.Data.Spec -import Plugin.Primitives.Spec - import Common +import Lib import PlcTestUtils +import Plugin.Data.Spec +import Plugin.Primitives.Spec import qualified Language.PlutusTx.Builtins as Builtins import Language.PlutusTx.Code import qualified Language.PlutusTx.Lift as Lift --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - Lift.makeLift ''MyMonoData Lift.makeLift ''MyMonoRecord Lift.makeLift ''MyPolyData @@ -49,20 +46,20 @@ Lift.makeLift ''SynExample tests :: TestNested tests = testNested "Lift" [ - goldenPlc "int" (Lift.liftProgramDef (1::Integer)) - , goldenPlc "tuple" (Lift.liftProgramDef (1::Integer, 2::Integer)) - , goldenPlc "mono" (Lift.liftProgramDef (Mono2 2)) - , goldenEval "monoInterop" [ getPlc monoCase, Lift.liftProgramDef (Mono1 1 2) ] - , goldenPlc "poly" (Lift.liftProgramDef (Poly1 (1::Integer) (2::Integer))) - , goldenEval "polyInterop" [ getPlc defaultCasePoly, Lift.liftProgramDef (Poly1 (1::Integer) (2::Integer)) ] - , goldenPlc "record" (Lift.liftProgramDef (MyMonoRecord 1 2)) - , goldenEval "boolInterop" [ getPlc andPlc, Lift.liftProgramDef True, Lift.liftProgramDef True ] - , goldenPlc "list" (Lift.liftProgramDef ([1]::[Integer])) - , goldenEval "listInterop" [ getPlc listMatch, Lift.liftProgramDef ([1]::[Integer]) ] - , goldenPlc "nested" (Lift.liftProgramDef (NestedRecord (Just (1, 2)))) - , goldenPlc "bytestring" (Lift.liftProgramDef (WrappedBS "hello")) - , goldenPlc "newtypeInt" (Lift.liftProgramDef (NewtypeInt 1)) - , goldenPlc "newtypeInt2" (Lift.liftProgramDef (Newtype2 $ NewtypeInt 1)) - , goldenPlc "newtypeInt3" (Lift.liftProgramDef (Newtype3 $ Newtype2 $ NewtypeInt 1)) - , goldenPlc "syn" (Lift.liftProgramDef (SynExample $ Z $ 1)) + goldenUPlc "int" (Lift.liftProgramDef (1::Integer)) + , goldenUPlc "tuple" (Lift.liftProgramDef (1::Integer, 2::Integer)) + , goldenUPlc "mono" (Lift.liftProgramDef (Mono2 2)) + , goldenUEval "monoInterop" [ getPlc monoCase, Lift.liftProgramDef (Mono1 1 2) ] + , goldenUPlc "poly" (Lift.liftProgramDef (Poly1 (1::Integer) (2::Integer))) + , goldenUEval "polyInterop" [ getPlc defaultCasePoly, Lift.liftProgramDef (Poly1 (1::Integer) (2::Integer)) ] + , goldenUPlc "record" (Lift.liftProgramDef (MyMonoRecord 1 2)) + , goldenUEval "boolInterop" [ getPlc andPlc, Lift.liftProgramDef True, Lift.liftProgramDef True ] + , goldenUPlc "list" (Lift.liftProgramDef ([1]::[Integer])) + , goldenUEval "listInterop" [ getPlc listMatch, Lift.liftProgramDef ([1]::[Integer]) ] + , goldenUPlc "nested" (Lift.liftProgramDef (NestedRecord (Just (1, 2)))) + , goldenUPlc "bytestring" (Lift.liftProgramDef (WrappedBS "hello")) + , goldenUPlc "newtypeInt" (Lift.liftProgramDef (NewtypeInt 1)) + , goldenUPlc "newtypeInt2" (Lift.liftProgramDef (Newtype2 $ NewtypeInt 1)) + , goldenUPlc "newtypeInt3" (Lift.liftProgramDef (Newtype3 $ Newtype2 $ NewtypeInt 1)) + , goldenUPlc "syn" (Lift.liftProgramDef (SynExample $ Z $ 1)) ] diff --git a/plutus-tx-plugin/test/Lift/boolInterop.plc.golden b/plutus-tx-plugin/test/Lift/boolInterop.plc.golden index 8288ca36c5d..8f5232a0d1c 100644 --- a/plutus-tx-plugin/test/Lift/boolInterop.plc.golden +++ b/plutus-tx-plugin/test/Lift/boolInterop.plc.golden @@ -1,9 +1,3 @@ -(abs - out_GHC_Types_Bool_6 - (type) - (lam - case_GHC_Types_True_7 - out_GHC_Types_Bool_6 - (lam case_GHC_Types_False_8 out_GHC_Types_Bool_6 case_GHC_Types_True_7) - ) +(delay + (lam case_GHC_Types_True_7 (lam case_GHC_Types_False_8 case_GHC_Types_True_7)) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/bytestring.plc.golden b/plutus-tx-plugin/test/Lift/bytestring.plc.golden index c97b94307ce..7b4e206fd06 100644 --- a/plutus-tx-plugin/test/Lift/bytestring.plc.golden +++ b/plutus-tx-plugin/test/Lift/bytestring.plc.golden @@ -1,40 +1,26 @@ (program 1.0.0 [ [ - { - (abs - Lift_Spec_WrappedBS_i0 - (type) + (force + (delay (lam Lift_Spec_WrappedBS_i0 - (fun (con bytestring) Lift_Spec_WrappedBS_i2) (lam match_Lift_Spec_WrappedBS_i0 - (fun Lift_Spec_WrappedBS_i3 (all out_Lift_Spec_WrappedBS_i0 (type) (fun (fun (con bytestring) out_Lift_Spec_WrappedBS_i1) out_Lift_Spec_WrappedBS_i1))) [ Lift_Spec_WrappedBS_i2 (con bytestring #68656c6c6f) ] ) ) ) - (all out_Lift_Spec_WrappedBS_i0 (type) (fun (fun (con bytestring) out_Lift_Spec_WrappedBS_i1) out_Lift_Spec_WrappedBS_i1)) - } + ) (lam arg_0_i0 - (con bytestring) - (abs - out_Lift_Spec_WrappedBS_i0 - (type) + (delay (lam - case_Lift_Spec_WrappedBS_i0 - (fun (con bytestring) out_Lift_Spec_WrappedBS_i2) - [ case_Lift_Spec_WrappedBS_i1 arg_0_i3 ] + case_Lift_Spec_WrappedBS_i0 [ case_Lift_Spec_WrappedBS_i1 arg_0_i2 ] ) ) ) ] - (lam - x_i0 - (all out_Lift_Spec_WrappedBS_i0 (type) (fun (fun (con bytestring) out_Lift_Spec_WrappedBS_i1) out_Lift_Spec_WrappedBS_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/list.plc.golden b/plutus-tx-plugin/test/Lift/list.plc.golden index 95488522028..1ad3bdde5e0 100644 --- a/plutus-tx-plugin/test/Lift/list.plc.golden +++ b/plutus-tx-plugin/test/Lift/list.plc.golden @@ -2,74 +2,43 @@ [ [ [ - { - (abs - GHC_Types_List_i0 - (fun (type) (type)) + (force + (delay (lam GHC_Types_Nil_i0 - (all a_i0 (type) [GHC_Types_List_i3 a_i1]) (lam GHC_Types_Cons_i0 - (all a_i0 (type) (fun a_i1 (fun [GHC_Types_List_i4 a_i1] [GHC_Types_List_i4 a_i1]))) (lam match_GHC_Types_Nil_i0 - (all a_i0 (type) (fun [GHC_Types_List_i5 a_i1] (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i6 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) [ - [ { GHC_Types_Cons_i2 (con integer) } (con integer 1) ] - { GHC_Types_Nil_i3 (con integer) } + [ (force GHC_Types_Cons_i2) (con integer 1) ] + (force GHC_Types_Nil_i3) ] ) ) ) ) - (lam a_i0 (type) (ifix (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) a_i1)) - } - (abs - a_i0 - (type) - (iwrap - (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) - a_i1 - (abs - out_GHC_Types_List_i0 - (type) - (lam - case_GHC_Types_Nil_i0 - out_GHC_Types_List_i2 - (lam - case_GHC_Types_Cons_i0 - (fun a_i4 (fun [(lam a_i0 (type) (ifix (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) a_i1)) a_i4] out_GHC_Types_List_i3)) - case_GHC_Types_Nil_i2 - ) - ) + ) + (delay + (delay + (lam + case_GHC_Types_Nil_i0 + (lam case_GHC_Types_Cons_i0 case_GHC_Types_Nil_i2) ) ) ) ] - (abs - a_i0 - (type) + (delay (lam arg_0_i0 - a_i2 (lam arg_1_i0 - [(lam a_i0 (type) (ifix (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) a_i1)) a_i3] - (iwrap - (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) - a_i3 - (abs - out_GHC_Types_List_i0 - (type) + (delay + (lam + case_GHC_Types_Nil_i0 (lam - case_GHC_Types_Nil_i0 - out_GHC_Types_List_i2 - (lam - case_GHC_Types_Cons_i0 - (fun a_i6 (fun [(lam a_i0 (type) (ifix (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) a_i1)) a_i6] out_GHC_Types_List_i3)) - [ [ case_GHC_Types_Cons_i1 arg_0_i5 ] arg_1_i4 ] - ) + case_GHC_Types_Cons_i0 + [ [ case_GHC_Types_Cons_i1 arg_0_i4 ] arg_1_i3 ] ) ) ) @@ -77,14 +46,6 @@ ) ) ] - (abs - a_i0 - (type) - (lam - x_i0 - [(lam a_i0 (type) (ifix (lam GHC_Types_List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_GHC_Types_List_i0 (type) (fun out_GHC_Types_List_i1 (fun (fun a_i2 (fun [GHC_Types_List_i3 a_i2] out_GHC_Types_List_i1)) out_GHC_Types_List_i1))))) a_i1)) a_i2] - (unwrap x_i1) - ) - ) + (delay (lam x_i0 x_i1)) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/mono.plc.golden b/plutus-tx-plugin/test/Lift/mono.plc.golden index 7efaf69aa85..8163fe4dd33 100644 --- a/plutus-tx-plugin/test/Lift/mono.plc.golden +++ b/plutus-tx-plugin/test/Lift/mono.plc.golden @@ -3,49 +3,35 @@ [ [ [ - { - (abs - Plugin_Data_Spec_MyMonoData_i0 - (type) + (force + (delay (lam Plugin_Data_Spec_Mono1_i0 - (fun (con integer) (fun (con integer) Plugin_Data_Spec_MyMonoData_i2)) (lam Plugin_Data_Spec_Mono2_i0 - (fun (con integer) Plugin_Data_Spec_MyMonoData_i3) (lam Plugin_Data_Spec_Mono3_i0 - (fun (con integer) Plugin_Data_Spec_MyMonoData_i4) (lam match_Plugin_Data_Spec_MyMonoData_i0 - (fun Plugin_Data_Spec_MyMonoData_i5 (all out_Plugin_Data_Spec_MyMonoData_i0 (type) (fun (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1)) (fun (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1) (fun (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1) out_Plugin_Data_Spec_MyMonoData_i1))))) [ Plugin_Data_Spec_Mono2_i3 (con integer 2) ] ) ) ) ) ) - (all out_Plugin_Data_Spec_MyMonoData_i0 (type) (fun (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1)) (fun (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1) (fun (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1) out_Plugin_Data_Spec_MyMonoData_i1)))) - } + ) (lam arg_0_i0 - (con integer) (lam arg_1_i0 - (con integer) - (abs - out_Plugin_Data_Spec_MyMonoData_i0 - (type) + (delay (lam case_Plugin_Data_Spec_Mono1_i0 - (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i2)) (lam case_Plugin_Data_Spec_Mono2_i0 - (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i3) (lam case_Plugin_Data_Spec_Mono3_i0 - (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i4) - [ [ case_Plugin_Data_Spec_Mono1_i3 arg_0_i6 ] arg_1_i5 ] + [ [ case_Plugin_Data_Spec_Mono1_i3 arg_0_i5 ] arg_1_i4 ] ) ) ) @@ -55,20 +41,14 @@ ] (lam arg_0_i0 - (con integer) - (abs - out_Plugin_Data_Spec_MyMonoData_i0 - (type) + (delay (lam case_Plugin_Data_Spec_Mono1_i0 - (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i2)) (lam case_Plugin_Data_Spec_Mono2_i0 - (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i3) (lam case_Plugin_Data_Spec_Mono3_i0 - (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i4) - [ case_Plugin_Data_Spec_Mono2_i2 arg_0_i5 ] + [ case_Plugin_Data_Spec_Mono2_i2 arg_0_i4 ] ) ) ) @@ -77,30 +57,20 @@ ] (lam arg_0_i0 - (con integer) - (abs - out_Plugin_Data_Spec_MyMonoData_i0 - (type) + (delay (lam case_Plugin_Data_Spec_Mono1_i0 - (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i2)) (lam case_Plugin_Data_Spec_Mono2_i0 - (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i3) (lam case_Plugin_Data_Spec_Mono3_i0 - (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i4) - [ case_Plugin_Data_Spec_Mono3_i1 arg_0_i5 ] + [ case_Plugin_Data_Spec_Mono3_i1 arg_0_i4 ] ) ) ) ) ) ] - (lam - x_i0 - (all out_Plugin_Data_Spec_MyMonoData_i0 (type) (fun (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1)) (fun (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1) (fun (fun (con integer) out_Plugin_Data_Spec_MyMonoData_i1) out_Plugin_Data_Spec_MyMonoData_i1)))) - x_i1 - ) + (lam x_i0 x_i1) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/nested.plc.golden b/plutus-tx-plugin/test/Lift/nested.plc.golden index 63c0ae82ee5..55e19d84beb 100644 --- a/plutus-tx-plugin/test/Lift/nested.plc.golden +++ b/plutus-tx-plugin/test/Lift/nested.plc.golden @@ -2,59 +2,39 @@ [ [ [ - { - (abs - GHC_Maybe_Maybe_i0 - (fun (type) (type)) + (force + (delay (lam GHC_Maybe_Just_i0 - (all a_i0 (type) (fun a_i1 [GHC_Maybe_Maybe_i3 a_i1])) (lam GHC_Maybe_Nothing_i0 - (all a_i0 (type) [GHC_Maybe_Maybe_i4 a_i1]) (lam match_GHC_Maybe_Maybe_i0 - (all a_i0 (type) (fun [GHC_Maybe_Maybe_i5 a_i1] (all out_GHC_Maybe_Maybe_i0 (type) (fun (fun a_i2 out_GHC_Maybe_Maybe_i1) (fun out_GHC_Maybe_Maybe_i1 out_GHC_Maybe_Maybe_i1))))) [ [ - { - (abs - GHC_Tuple_Tuple2_i0 - (fun (type) (fun (type) (type))) + (force + (delay (lam GHC_Tuple_Tuple2_i0 - (all a_i0 (type) (all b_i0 (type) (fun a_i2 (fun b_i1 [[GHC_Tuple_Tuple2_i4 a_i2] b_i1])))) (lam match_GHC_Tuple_Tuple2_i0 - (all a_i0 (type) (all b_i0 (type) (fun [[GHC_Tuple_Tuple2_i5 a_i2] b_i1] (all out_GHC_Tuple_Tuple2_i0 (type) (fun (fun a_i3 (fun b_i2 out_GHC_Tuple_Tuple2_i1)) out_GHC_Tuple_Tuple2_i1))))) [ [ - { - (abs - Lift_Spec_NestedRecord_i0 - (type) + (force + (delay (lam Lift_Spec_NestedRecord_i0 - (fun [GHC_Maybe_Maybe_i9 [[GHC_Tuple_Tuple2_i5 (con integer)] (con integer)]] Lift_Spec_NestedRecord_i2) (lam match_Lift_Spec_NestedRecord_i0 - (fun Lift_Spec_NestedRecord_i3 (all out_Lift_Spec_NestedRecord_i0 (type) (fun (fun [GHC_Maybe_Maybe_i11 [[GHC_Tuple_Tuple2_i7 (con integer)] (con integer)]] out_Lift_Spec_NestedRecord_i1) out_Lift_Spec_NestedRecord_i1))) [ Lift_Spec_NestedRecord_i2 [ - { - GHC_Maybe_Just_i9 - [[GHC_Tuple_Tuple2_i6 (con integer)] (con integer)] - } + (force GHC_Maybe_Just_i7) [ [ - { - { - GHC_Tuple_Tuple2_i5 - (con integer) - } - (con integer) - } + (force + (force GHC_Tuple_Tuple2_i4) + ) (con integer 1) ] (con integer 2) @@ -64,57 +44,38 @@ ) ) ) - (all out_Lift_Spec_NestedRecord_i0 (type) (fun (fun [GHC_Maybe_Maybe_i8 [[GHC_Tuple_Tuple2_i4 (con integer)] (con integer)]] out_Lift_Spec_NestedRecord_i1) out_Lift_Spec_NestedRecord_i1)) - } + ) (lam arg_0_i0 - [GHC_Maybe_Maybe_i8 [[GHC_Tuple_Tuple2_i4 (con integer)] (con integer)]] - (abs - out_Lift_Spec_NestedRecord_i0 - (type) + (delay (lam case_Lift_Spec_NestedRecord_i0 - (fun [GHC_Maybe_Maybe_i10 [[GHC_Tuple_Tuple2_i6 (con integer)] (con integer)]] out_Lift_Spec_NestedRecord_i2) [ case_Lift_Spec_NestedRecord_i1 - arg_0_i3 + arg_0_i2 ] ) ) ) ] - (lam - x_i0 - (all out_Lift_Spec_NestedRecord_i0 (type) (fun (fun [GHC_Maybe_Maybe_i9 [[GHC_Tuple_Tuple2_i5 (con integer)] (con integer)]] out_Lift_Spec_NestedRecord_i1) out_Lift_Spec_NestedRecord_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) ) ) - (lam a_i0 (type) (lam b_i0 (type) (all out_GHC_Tuple_Tuple2_i0 (type) (fun (fun a_i3 (fun b_i2 out_GHC_Tuple_Tuple2_i1)) out_GHC_Tuple_Tuple2_i1)))) - } - (abs - a_i0 - (type) - (abs - b_i0 - (type) + ) + (delay + (delay (lam arg_0_i0 - a_i3 (lam arg_1_i0 - b_i3 - (abs - out_GHC_Tuple_Tuple2_i0 - (type) + (delay (lam case_GHC_Tuple_Tuple2_i0 - (fun a_i6 (fun b_i5 out_GHC_Tuple_Tuple2_i2)) [ - [ case_GHC_Tuple_Tuple2_i1 arg_0_i4 ] - arg_1_i3 + [ case_GHC_Tuple_Tuple2_i1 arg_0_i3 ] + arg_1_i2 ] ) ) @@ -123,74 +84,36 @@ ) ) ] - (abs - a_i0 - (type) - (abs - b_i0 - (type) - (lam - x_i0 - [[(lam a_i0 (type) (lam b_i0 (type) (all out_GHC_Tuple_Tuple2_i0 (type) (fun (fun a_i3 (fun b_i2 out_GHC_Tuple_Tuple2_i1)) out_GHC_Tuple_Tuple2_i1)))) a_i3] b_i2] - x_i1 - ) - ) - ) + (delay (delay (lam x_i0 x_i1))) ] ) ) ) ) - (lam a_i0 (type) (all out_GHC_Maybe_Maybe_i0 (type) (fun (fun a_i2 out_GHC_Maybe_Maybe_i1) (fun out_GHC_Maybe_Maybe_i1 out_GHC_Maybe_Maybe_i1)))) - } - (abs - a_i0 - (type) + ) + (delay (lam arg_0_i0 - a_i2 - (abs - out_GHC_Maybe_Maybe_i0 - (type) + (delay (lam case_GHC_Maybe_Just_i0 - (fun a_i4 out_GHC_Maybe_Maybe_i2) (lam - case_GHC_Maybe_Nothing_i0 - out_GHC_Maybe_Maybe_i3 - [ case_GHC_Maybe_Just_i2 arg_0_i4 ] + case_GHC_Maybe_Nothing_i0 [ case_GHC_Maybe_Just_i2 arg_0_i3 ] ) ) ) ) ) ] - (abs - a_i0 - (type) - (abs - out_GHC_Maybe_Maybe_i0 - (type) + (delay + (delay (lam case_GHC_Maybe_Just_i0 - (fun a_i3 out_GHC_Maybe_Maybe_i2) - (lam - case_GHC_Maybe_Nothing_i0 - out_GHC_Maybe_Maybe_i3 - case_GHC_Maybe_Nothing_i1 - ) + (lam case_GHC_Maybe_Nothing_i0 case_GHC_Maybe_Nothing_i1) ) ) ) ] - (abs - a_i0 - (type) - (lam - x_i0 - [(lam a_i0 (type) (all out_GHC_Maybe_Maybe_i0 (type) (fun (fun a_i2 out_GHC_Maybe_Maybe_i1) (fun out_GHC_Maybe_Maybe_i1 out_GHC_Maybe_Maybe_i1)))) a_i2] - x_i1 - ) - ) + (delay (lam x_i0 x_i1)) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/poly.plc.golden b/plutus-tx-plugin/test/Lift/poly.plc.golden index 8f4d4f2c147..a5ffecf313e 100644 --- a/plutus-tx-plugin/test/Lift/poly.plc.golden +++ b/plutus-tx-plugin/test/Lift/poly.plc.golden @@ -2,26 +2,17 @@ [ [ [ - { - (abs - Plugin_Data_Spec_MyPolyData_i0 - (fun (type) (fun (type) (type))) + (force + (delay (lam Plugin_Data_Spec_Poly1_i0 - (all a_i0 (type) (all b_i0 (type) (fun a_i2 (fun b_i1 [[Plugin_Data_Spec_MyPolyData_i4 a_i2] b_i1])))) (lam Plugin_Data_Spec_Poly2_i0 - (all a_i0 (type) (all b_i0 (type) (fun a_i2 [[Plugin_Data_Spec_MyPolyData_i5 a_i2] b_i1]))) (lam match_Plugin_Data_Spec_MyPolyData_i0 - (all a_i0 (type) (all b_i0 (type) (fun [[Plugin_Data_Spec_MyPolyData_i6 a_i2] b_i1] (all out_Plugin_Data_Spec_MyPolyData_i0 (type) (fun (fun a_i3 (fun b_i2 out_Plugin_Data_Spec_MyPolyData_i1)) (fun (fun a_i3 out_Plugin_Data_Spec_MyPolyData_i1) out_Plugin_Data_Spec_MyPolyData_i1)))))) [ [ - { - { Plugin_Data_Spec_Poly1_i3 (con integer) } - (con integer) - } - (con integer 1) + (force (force Plugin_Data_Spec_Poly1_i3)) (con integer 1) ] (con integer 2) ] @@ -29,30 +20,19 @@ ) ) ) - (lam a_i0 (type) (lam b_i0 (type) (all out_Plugin_Data_Spec_MyPolyData_i0 (type) (fun (fun a_i3 (fun b_i2 out_Plugin_Data_Spec_MyPolyData_i1)) (fun (fun a_i3 out_Plugin_Data_Spec_MyPolyData_i1) out_Plugin_Data_Spec_MyPolyData_i1))))) - } - (abs - a_i0 - (type) - (abs - b_i0 - (type) + ) + (delay + (delay (lam arg_0_i0 - a_i3 (lam arg_1_i0 - b_i3 - (abs - out_Plugin_Data_Spec_MyPolyData_i0 - (type) + (delay (lam case_Plugin_Data_Spec_Poly1_i0 - (fun a_i6 (fun b_i5 out_Plugin_Data_Spec_MyPolyData_i2)) (lam case_Plugin_Data_Spec_Poly2_i0 - (fun a_i7 out_Plugin_Data_Spec_MyPolyData_i3) - [ [ case_Plugin_Data_Spec_Poly1_i2 arg_0_i5 ] arg_1_i4 ] + [ [ case_Plugin_Data_Spec_Poly1_i2 arg_0_i4 ] arg_1_i3 ] ) ) ) @@ -61,25 +41,16 @@ ) ) ] - (abs - a_i0 - (type) - (abs - b_i0 - (type) + (delay + (delay (lam arg_0_i0 - a_i3 - (abs - out_Plugin_Data_Spec_MyPolyData_i0 - (type) + (delay (lam case_Plugin_Data_Spec_Poly1_i0 - (fun a_i5 (fun b_i4 out_Plugin_Data_Spec_MyPolyData_i2)) (lam case_Plugin_Data_Spec_Poly2_i0 - (fun a_i6 out_Plugin_Data_Spec_MyPolyData_i3) - [ case_Plugin_Data_Spec_Poly2_i1 arg_0_i4 ] + [ case_Plugin_Data_Spec_Poly2_i1 arg_0_i3 ] ) ) ) @@ -87,18 +58,6 @@ ) ) ] - (abs - a_i0 - (type) - (abs - b_i0 - (type) - (lam - x_i0 - [[(lam a_i0 (type) (lam b_i0 (type) (all out_Plugin_Data_Spec_MyPolyData_i0 (type) (fun (fun a_i3 (fun b_i2 out_Plugin_Data_Spec_MyPolyData_i1)) (fun (fun a_i3 out_Plugin_Data_Spec_MyPolyData_i1) out_Plugin_Data_Spec_MyPolyData_i1))))) a_i3] b_i2] - x_i1 - ) - ) - ) + (delay (delay (lam x_i0 x_i1))) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/record.plc.golden b/plutus-tx-plugin/test/Lift/record.plc.golden index 0536201574d..c7a5ce47a5d 100644 --- a/plutus-tx-plugin/test/Lift/record.plc.golden +++ b/plutus-tx-plugin/test/Lift/record.plc.golden @@ -1,16 +1,12 @@ (program 1.0.0 [ [ - { - (abs - Plugin_Data_Spec_MyMonoRecord_i0 - (type) + (force + (delay (lam Plugin_Data_Spec_MyMonoRecord_i0 - (fun (con integer) (fun (con integer) Plugin_Data_Spec_MyMonoRecord_i2)) (lam match_Plugin_Data_Spec_MyMonoRecord_i0 - (fun Plugin_Data_Spec_MyMonoRecord_i3 (all out_Plugin_Data_Spec_MyMonoRecord_i0 (type) (fun (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoRecord_i1)) out_Plugin_Data_Spec_MyMonoRecord_i1))) [ [ Plugin_Data_Spec_MyMonoRecord_i2 (con integer 1) ] (con integer 2) @@ -18,30 +14,20 @@ ) ) ) - (all out_Plugin_Data_Spec_MyMonoRecord_i0 (type) (fun (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoRecord_i1)) out_Plugin_Data_Spec_MyMonoRecord_i1)) - } + ) (lam arg_0_i0 - (con integer) (lam arg_1_i0 - (con integer) - (abs - out_Plugin_Data_Spec_MyMonoRecord_i0 - (type) + (delay (lam case_Plugin_Data_Spec_MyMonoRecord_i0 - (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoRecord_i2)) - [ [ case_Plugin_Data_Spec_MyMonoRecord_i1 arg_0_i4 ] arg_1_i3 ] + [ [ case_Plugin_Data_Spec_MyMonoRecord_i1 arg_0_i3 ] arg_1_i2 ] ) ) ) ) ] - (lam - x_i0 - (all out_Plugin_Data_Spec_MyMonoRecord_i0 (type) (fun (fun (con integer) (fun (con integer) out_Plugin_Data_Spec_MyMonoRecord_i1)) out_Plugin_Data_Spec_MyMonoRecord_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/syn.plc.golden b/plutus-tx-plugin/test/Lift/syn.plc.golden index 4286fb0aa87..3b7dea200cf 100644 --- a/plutus-tx-plugin/test/Lift/syn.plc.golden +++ b/plutus-tx-plugin/test/Lift/syn.plc.golden @@ -1,80 +1,49 @@ (program 1.0.0 [ [ - { - (abs - Lift_Spec_Z_i0 - (type) + (force + (delay (lam Lift_Spec_Z_i0 - (fun (con integer) Lift_Spec_Z_i2) (lam match_Lift_Spec_Z_i0 - (fun Lift_Spec_Z_i3 (all out_Lift_Spec_Z_i0 (type) (fun (fun (con integer) out_Lift_Spec_Z_i1) out_Lift_Spec_Z_i1))) [ [ - { - (abs - Lift_Spec_SynExample_i0 - (type) + (force + (delay (lam Lift_Spec_SynExample_i0 - (fun Lift_Spec_Z_i5 Lift_Spec_SynExample_i2) (lam match_Lift_Spec_SynExample_i0 - (fun Lift_Spec_SynExample_i3 (all out_Lift_Spec_SynExample_i0 (type) (fun (fun Lift_Spec_Z_i7 out_Lift_Spec_SynExample_i1) out_Lift_Spec_SynExample_i1))) [ Lift_Spec_SynExample_i2 - [ Lift_Spec_Z_i5 (con integer 1) ] + [ Lift_Spec_Z_i4 (con integer 1) ] ] ) ) ) - (all out_Lift_Spec_SynExample_i0 (type) (fun (fun Lift_Spec_Z_i4 out_Lift_Spec_SynExample_i1) out_Lift_Spec_SynExample_i1)) - } + ) (lam arg_0_i0 - Lift_Spec_Z_i4 - (abs - out_Lift_Spec_SynExample_i0 - (type) + (delay (lam case_Lift_Spec_SynExample_i0 - (fun Lift_Spec_Z_i6 out_Lift_Spec_SynExample_i2) - [ case_Lift_Spec_SynExample_i1 arg_0_i3 ] + [ case_Lift_Spec_SynExample_i1 arg_0_i2 ] ) ) ) ] - (lam - x_i0 - (all out_Lift_Spec_SynExample_i0 (type) (fun (fun Lift_Spec_Z_i5 out_Lift_Spec_SynExample_i1) out_Lift_Spec_SynExample_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) ) ) - (all out_Lift_Spec_Z_i0 (type) (fun (fun (con integer) out_Lift_Spec_Z_i1) out_Lift_Spec_Z_i1)) - } + ) (lam arg_0_i0 - (con integer) - (abs - out_Lift_Spec_Z_i0 - (type) - (lam - case_Lift_Spec_Z_i0 - (fun (con integer) out_Lift_Spec_Z_i2) - [ case_Lift_Spec_Z_i1 arg_0_i3 ] - ) - ) + (delay (lam case_Lift_Spec_Z_i0 [ case_Lift_Spec_Z_i1 arg_0_i2 ])) ) ] - (lam - x_i0 - (all out_Lift_Spec_Z_i0 (type) (fun (fun (con integer) out_Lift_Spec_Z_i1) out_Lift_Spec_Z_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/tuple.plc.golden b/plutus-tx-plugin/test/Lift/tuple.plc.golden index c45eb02c0df..d1a881bb72d 100644 --- a/plutus-tx-plugin/test/Lift/tuple.plc.golden +++ b/plutus-tx-plugin/test/Lift/tuple.plc.golden @@ -1,47 +1,30 @@ (program 1.0.0 [ [ - { - (abs - GHC_Tuple_Tuple2_i0 - (fun (type) (fun (type) (type))) + (force + (delay (lam GHC_Tuple_Tuple2_i0 - (all a_i0 (type) (all b_i0 (type) (fun a_i2 (fun b_i1 [[GHC_Tuple_Tuple2_i4 a_i2] b_i1])))) (lam match_GHC_Tuple_Tuple2_i0 - (all a_i0 (type) (all b_i0 (type) (fun [[GHC_Tuple_Tuple2_i5 a_i2] b_i1] (all out_GHC_Tuple_Tuple2_i0 (type) (fun (fun a_i3 (fun b_i2 out_GHC_Tuple_Tuple2_i1)) out_GHC_Tuple_Tuple2_i1))))) [ - [ - { { GHC_Tuple_Tuple2_i2 (con integer) } (con integer) } - (con integer 1) - ] + [ (force (force GHC_Tuple_Tuple2_i2)) (con integer 1) ] (con integer 2) ] ) ) ) - (lam a_i0 (type) (lam b_i0 (type) (all out_GHC_Tuple_Tuple2_i0 (type) (fun (fun a_i3 (fun b_i2 out_GHC_Tuple_Tuple2_i1)) out_GHC_Tuple_Tuple2_i1)))) - } - (abs - a_i0 - (type) - (abs - b_i0 - (type) + ) + (delay + (delay (lam arg_0_i0 - a_i3 (lam arg_1_i0 - b_i3 - (abs - out_GHC_Tuple_Tuple2_i0 - (type) + (delay (lam case_GHC_Tuple_Tuple2_i0 - (fun a_i6 (fun b_i5 out_GHC_Tuple_Tuple2_i2)) - [ [ case_GHC_Tuple_Tuple2_i1 arg_0_i4 ] arg_1_i3 ] + [ [ case_GHC_Tuple_Tuple2_i1 arg_0_i3 ] arg_1_i2 ] ) ) ) @@ -49,18 +32,6 @@ ) ) ] - (abs - a_i0 - (type) - (abs - b_i0 - (type) - (lam - x_i0 - [[(lam a_i0 (type) (lam b_i0 (type) (all out_GHC_Tuple_Tuple2_i0 (type) (fun (fun a_i3 (fun b_i2 out_GHC_Tuple_Tuple2_i1)) out_GHC_Tuple_Tuple2_i1)))) a_i3] b_i2] - x_i1 - ) - ) - ) + (delay (delay (lam x_i0 x_i1))) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Basic/Spec.hs b/plutus-tx-plugin/test/Plugin/Basic/Spec.hs index f36487703aa..5be23948ec4 100644 --- a/plutus-tx-plugin/test/Plugin/Basic/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Basic/Spec.hs @@ -9,6 +9,7 @@ module Plugin.Basic.Spec where import Common +import Lib import PlcTestUtils import Plugin.Lib @@ -20,9 +21,6 @@ import qualified Language.PlutusCore.Universe as PLC import Data.Proxy --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - basic :: TestNested basic = testNested "Basic" [ goldenPir "monoId" monoId @@ -31,7 +29,7 @@ basic = testNested "Basic" [ -- must keep the scrutinee as it evaluates to error , goldenPir "ifOpt" ifOpt -- should fail - , goldenEval "ifOptEval" [ifOpt] + , goldenUEval "ifOptEval" [ifOpt] ] monoId :: CompiledCode PLC.DefaultUni (Integer -> Integer) diff --git a/plutus-tx-plugin/test/Plugin/Data/Spec.hs b/plutus-tx-plugin/test/Plugin/Data/Spec.hs index 126d6cf67c7..d0c635d577e 100644 --- a/plutus-tx-plugin/test/Plugin/Data/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Data/Spec.hs @@ -9,6 +9,7 @@ module Plugin.Data.Spec where import Common import PlcTestUtils +import Lib import Plugin.Lib import qualified Language.PlutusTx.Builtins as Builtins @@ -19,9 +20,6 @@ import qualified Language.PlutusCore.Universe as PLC import Data.Proxy --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - datat :: TestNested datat = testNested "Data" [ monoData @@ -38,11 +36,11 @@ monoData = testNested "monomorphic" [ , goldenPir "monoConstructor" monoConstructor , goldenPir "monoConstructed" monoConstructed , goldenPir "monoCase" monoCase - , goldenEval "monoConstDest" [ getProgram monoCase, getProgram monoConstructed ] + , goldenUEval "monoConstDest" [ toUPlc monoCase, toUPlc monoConstructed ] , goldenPir "defaultCase" defaultCase , goldenPir "irrefutableMatch" irrefutableMatch , goldenPir "atPattern" atPattern - , goldenEval "monoConstDestDefault" [ getProgram monoCase, getProgram monoConstructed ] + , goldenUEval "monoConstDestDefault" [ toUPlc monoCase, toUPlc monoConstructed ] , goldenPir "monoRecord" monoRecord , goldenPir "recordNewtype" recordNewtype , goldenPir "nonValueCase" nonValueCase @@ -130,7 +128,7 @@ newtypes = testNested "newtypes" [ , goldenPir "newtypeId" newtypeId , goldenPir "newtypeCreate2" newtypeCreate2 , goldenPir "nestedNewtypeMatch" nestedNewtypeMatch - , goldenEval "newtypeCreatDest" [ getProgram $ newtypeMatch, getProgram $ newtypeCreate2 ] + , goldenUEval "newtypeCreatDest" [ toUPlc $ newtypeMatch, toUPlc $ newtypeCreate2 ] , goldenPir "paramNewtype" paramNewtype ] @@ -168,15 +166,15 @@ recursiveTypes = testNested "recursive" [ , goldenPir "listConstruct2" listConstruct2 , goldenPir "listConstruct3" listConstruct3 , goldenPir "listMatch" listMatch - , goldenEval "listConstDest" [ getProgram listMatch, getProgram listConstruct ] - , goldenEval "listConstDest2" [ getProgram listMatch, getProgram listConstruct2 ] + , goldenUEval "listConstDest" [ toUPlc listMatch, toUPlc listConstruct ] + , goldenUEval "listConstDest2" [ toUPlc listMatch, toUPlc listConstruct2 ] , goldenPir "ptreeConstruct" ptreeConstruct , goldenPir "ptreeMatch" ptreeMatch - , goldenEval "ptreeConstDest" [ getProgram ptreeMatch, getProgram ptreeConstruct ] - , goldenEval "polyRecEval" [ getProgram polyRec, getProgram ptreeConstruct ] - , goldenEval "ptreeFirstEval" [ getProgram ptreeFirst, getProgram ptreeConstruct ] - , goldenEval "sameEmptyRoseEval" [ getProgram sameEmptyRose, getProgram emptyRoseConstruct ] - , goldenPlc "sameEmptyRose" sameEmptyRose + , goldenUEval "ptreeConstDest" [ toUPlc ptreeMatch, toUPlc ptreeConstruct ] + , goldenUEval "polyRecEval" [ toUPlc polyRec, toUPlc ptreeConstruct ] + , goldenUEval "ptreeFirstEval" [ toUPlc ptreeFirst, toUPlc ptreeConstruct ] + , goldenUEval "sameEmptyRoseEval" [ toUPlc sameEmptyRose, toUPlc emptyRoseConstruct ] + , goldenUPlc "sameEmptyRose" sameEmptyRose ] listConstruct :: CompiledCode PLC.DefaultUni [Integer] @@ -246,7 +244,7 @@ typeFamilies = testNested "families" [ , goldenPir "associated" associated , goldenPir "associatedParam" associatedParam , goldenPir "basicData" basicData - , goldenPlcCatch "irreducible" irreducible + , goldenUPlcCatch "irreducible" irreducible ] type family BasicClosed a where diff --git a/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRose.plc.golden b/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRose.plc.golden index 9188d88306a..6583c4cf989 100644 --- a/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRose.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRose.plc.golden @@ -2,118 +2,84 @@ [ (lam fix1_i0 - (all a_i0 (type) (all b_i0 (type) (fun (fun (fun a_i2 b_i1) (fun a_i2 b_i1)) (fun a_i2 b_i1)))) [ [ [ - { - (abs - List_i0 - (fun (type) (type)) + (force + (delay (lam Nil_i0 - (all a_i0 (type) [List_i3 a_i1]) (lam Cons_i0 - (all a_i0 (type) (fun a_i1 (fun [List_i4 a_i1] [List_i4 a_i1]))) (lam Nil_match_i0 - (all a_i0 (type) (fun [List_i5 a_i1] (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i6 a_i2] out_List_i1)) out_List_i1))))) [ [ - { - (abs - EmptyRose_i0 - (type) + (force + (delay (lam EmptyRose_i0 - (fun [List_i6 EmptyRose_i2] EmptyRose_i2) (lam EmptyRose_match_i0 - (fun EmptyRose_i3 (all out_EmptyRose_i0 (type) (fun (fun [List_i8 EmptyRose_i4] out_EmptyRose_i1) out_EmptyRose_i1))) [ [ - { - (abs - Unit_i0 - (type) + (force + (delay (lam Unit_i0 - Unit_i2 (lam Unit_match_i0 - (fun Unit_i3 (all out_Unit_i0 (type) (fun out_Unit_i1 out_Unit_i1))) [ (lam tup_i0 - (all r_i0 (type) (fun (fun (fun (fun EmptyRose_i8 EmptyRose_i8) (fun [List_i12 EmptyRose_i8] [List_i12 EmptyRose_i8])) r_i1) r_i1)) [ (lam map_i0 - (fun (fun EmptyRose_i8 EmptyRose_i8) (fun [List_i12 EmptyRose_i8] [List_i12 EmptyRose_i8])) [ (lam tup_i0 - (all r_i0 (type) (fun (fun (fun EmptyRose_i10 EmptyRose_i10) r_i1) r_i1)) [ - (lam - go_i0 - (fun EmptyRose_i10 EmptyRose_i10) - go_i1 - ) + (lam go_i0 go_i1) [ - { - tup_i1 - (fun EmptyRose_i9 EmptyRose_i9) - } + (force tup_i1) (lam arg_0_i0 - (fun EmptyRose_i10 EmptyRose_i10) arg_0_i1 ) ] ] ) - (abs - r_i0 - (type) + (delay (lam f_i0 - (fun (fun EmptyRose_i10 EmptyRose_i10) r_i2) [ f_i1 [ - { - { - fix1_i15 - EmptyRose_i10 - } - EmptyRose_i10 - } + (force + (force + fix1_i11 + ) + ) (lam go_i0 - (fun EmptyRose_i11 EmptyRose_i11) (lam x_i0 - EmptyRose_i12 [ - EmptyRose_i11 + EmptyRose_i9 [ [ - map_i5 + map_i4 go_i2 ] [ - { + (force [ - EmptyRose_match_i10 + EmptyRose_match_i8 x_i1 ] - [List_i16 EmptyRose_i12] - } + ) (lam x_i0 - [List_i17 EmptyRose_i13] x_i1 ) ] @@ -128,80 +94,53 @@ ] ) [ - { - tup_i1 - (fun (fun EmptyRose_i7 EmptyRose_i7) (fun [List_i11 EmptyRose_i7] [List_i11 EmptyRose_i7])) - } - (lam - arg_0_i0 - (fun (fun EmptyRose_i8 EmptyRose_i8) (fun [List_i12 EmptyRose_i8] [List_i12 EmptyRose_i8])) - arg_0_i1 - ) + (force tup_i1) + (lam arg_0_i0 arg_0_i1) ] ] ) - (abs - r_i0 - (type) + (delay (lam f_i0 - (fun (fun (fun EmptyRose_i8 EmptyRose_i8) (fun [List_i12 EmptyRose_i8] [List_i12 EmptyRose_i8])) r_i2) [ f_i1 [ - { - { - fix1_i13 - (fun EmptyRose_i8 EmptyRose_i8) - } - (fun [List_i12 EmptyRose_i8] [List_i12 EmptyRose_i8]) - } + (force (force fix1_i9)) (lam map_i0 - (fun (fun EmptyRose_i9 EmptyRose_i9) (fun [List_i13 EmptyRose_i9] [List_i13 EmptyRose_i9])) (lam ds_i0 - (fun EmptyRose_i10 EmptyRose_i10) (lam ds_i0 - [List_i15 EmptyRose_i11] [ [ [ - { + (force [ - { - Nil_match_i12 - EmptyRose_i11 - } + (force + Nil_match_i9 + ) ds_i1 ] - (fun Unit_i8 [List_i15 EmptyRose_i11]) - } + ) (lam thunk_i0 - Unit_i9 - { - Nil_i15 - EmptyRose_i12 - } + (force + Nil_i12 + ) ) ] (lam x_i0 - EmptyRose_i12 (lam xs_i0 - [List_i17 EmptyRose_i13] (lam thunk_i0 - Unit_i11 [ [ - { - Cons_i16 - EmptyRose_i14 - } + (force + Cons_i13 + ) [ ds_i5 x_i3 @@ -219,7 +158,7 @@ ) ) ] - Unit_i7 + Unit_i6 ] ) ) @@ -232,173 +171,65 @@ ) ) ) - (all out_Unit_i0 (type) (fun out_Unit_i1 out_Unit_i1)) - } - (abs - out_Unit_i0 - (type) - (lam - case_Unit_i0 out_Unit_i2 case_Unit_i1 - ) ) + (delay (lam case_Unit_i0 case_Unit_i1)) ] - (lam - x_i0 - (all out_Unit_i0 (type) (fun out_Unit_i1 out_Unit_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) ) ) - (ifix (lam rec_i0 (fun (fun (type) (type)) (type)) (lam f_i0 (fun (type) (type)) [f_i1 [rec_i2 f_i1]])) (lam EmptyRose_i0 (type) (all out_EmptyRose_i0 (type) (fun (fun [List_i6 EmptyRose_i2] out_EmptyRose_i1) out_EmptyRose_i1)))) - } + ) (lam arg_0_i0 - [List_i5 (ifix (lam rec_i0 (fun (fun (type) (type)) (type)) (lam f_i0 (fun (type) (type)) [f_i1 [rec_i2 f_i1]])) (lam EmptyRose_i0 (type) (all out_EmptyRose_i0 (type) (fun (fun [List_i7 EmptyRose_i2] out_EmptyRose_i1) out_EmptyRose_i1))))] - (iwrap - (lam rec_i0 (fun (fun (type) (type)) (type)) (lam f_i0 (fun (type) (type)) [f_i1 [rec_i2 f_i1]])) - (lam EmptyRose_i0 (type) (all out_EmptyRose_i0 (type) (fun (fun [List_i7 EmptyRose_i2] out_EmptyRose_i1) out_EmptyRose_i1))) - (abs - out_EmptyRose_i0 - (type) - (lam - case_EmptyRose_i0 - (fun [List_i7 (ifix (lam rec_i0 (fun (fun (type) (type)) (type)) (lam f_i0 (fun (type) (type)) [f_i1 [rec_i2 f_i1]])) (lam EmptyRose_i0 (type) (all out_EmptyRose_i0 (type) (fun (fun [List_i9 EmptyRose_i2] out_EmptyRose_i1) out_EmptyRose_i1))))] out_EmptyRose_i2) - [ case_EmptyRose_i1 arg_0_i3 ] - ) + (delay + (lam + case_EmptyRose_i0 [ case_EmptyRose_i1 arg_0_i2 ] ) ) ) ] - (lam - x_i0 - (ifix (lam rec_i0 (fun (fun (type) (type)) (type)) (lam f_i0 (fun (type) (type)) [f_i1 [rec_i2 f_i1]])) (lam EmptyRose_i0 (type) (all out_EmptyRose_i0 (type) (fun (fun [List_i7 EmptyRose_i2] out_EmptyRose_i1) out_EmptyRose_i1)))) - (unwrap x_i1) - ) + (lam x_i0 x_i1) ] ) ) ) ) - (lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) - } - (abs - a_i0 - (type) - (iwrap - (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) - a_i1 - (abs - out_List_i0 - (type) - (lam - case_Nil_i0 - out_List_i2 - (lam - case_Cons_i0 - (fun a_i4 (fun [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i4] out_List_i3)) - case_Nil_i2 - ) - ) - ) - ) ) + (delay (delay (lam case_Nil_i0 (lam case_Cons_i0 case_Nil_i2)))) ] - (abs - a_i0 - (type) + (delay (lam arg_0_i0 - a_i2 (lam arg_1_i0 - [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i3] - (iwrap - (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) - a_i3 - (abs - out_List_i0 - (type) - (lam - case_Nil_i0 - out_List_i2 - (lam - case_Cons_i0 - (fun a_i6 (fun [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i6] out_List_i3)) - [ [ case_Cons_i1 arg_0_i5 ] arg_1_i4 ] - ) - ) + (delay + (lam + case_Nil_i0 + (lam case_Cons_i0 [ [ case_Cons_i1 arg_0_i4 ] arg_1_i3 ]) ) ) ) ) ) ] - (abs - a_i0 - (type) - (lam - x_i0 - [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i2] - (unwrap x_i1) - ) - ) + (delay (lam x_i0 x_i1)) ] ) - (abs - a_i0 - (type) - (abs - b_i0 - (type) + (delay + (delay (lam f_i0 - (fun (fun a_i3 b_i2) (fun a_i3 b_i2)) [ - { - (abs - a_i0 - (type) - (lam - s_i0 - [(lam a_i0 (type) (ifix (lam self_i0 (fun (type) (type)) (lam a_i0 (type) (fun [self_i2 a_i1] a_i1))) a_i1)) a_i2] - [ (unwrap s_i1) s_i1 ] - ) - ) - (fun a_i3 b_i2) - } - (iwrap - (lam self_i0 (fun (type) (type)) (lam a_i0 (type) (fun [self_i2 a_i1] a_i1))) - (fun a_i3 b_i2) + (force (delay (lam s_i0 [ s_i1 s_i1 ]))) + (lam + s_i0 (lam - s_i0 - [(lam a_i0 (type) (ifix (lam self_i0 (fun (type) (type)) (lam a_i0 (type) (fun [self_i2 a_i1] a_i1))) a_i1)) (fun a_i4 b_i3)] - (lam - x_i0 - a_i5 - [ - [ - f_i3 - [ - { - (abs - a_i0 - (type) - (lam - s_i0 - [(lam a_i0 (type) (ifix (lam self_i0 (fun (type) (type)) (lam a_i0 (type) (fun [self_i2 a_i1] a_i1))) a_i1)) a_i2] - [ (unwrap s_i1) s_i1 ] - ) - ) - (fun a_i5 b_i4) - } - s_i2 - ] - ] - x_i1 - ] - ) + x_i0 + [ + [ f_i3 [ (force (delay (lam s_i0 [ s_i1 s_i1 ]))) s_i2 ] ] + x_i1 + ] ) ) ] diff --git a/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRoseEval.plc.golden b/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRoseEval.plc.golden index 91ca02569cc..219ca6cbda2 100644 --- a/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRoseEval.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Data/recursive/sameEmptyRoseEval.plc.golden @@ -1,138 +1,59 @@ -(iwrap - (lam rec_116 (fun (fun (type) (type)) (type)) (lam f_117 (fun (type) (type)) [f_117 [rec_116 f_117]])) - (lam EmptyRose_118 (type) (all out_EmptyRose_119 (type) (fun (fun [List_64 EmptyRose_118] out_EmptyRose_119) out_EmptyRose_119))) - (abs - out_EmptyRose_120 - (type) - (lam +(delay + (lam + case_EmptyRose_121 + [ case_EmptyRose_121 - (fun [List_64 (ifix (lam rec_122 (fun (fun (type) (type)) (type)) (lam f_123 (fun (type) (type)) [f_123 [rec_122 f_123]])) (lam EmptyRose_124 (type) (all out_EmptyRose_125 (type) (fun (fun [List_64 EmptyRose_124] out_EmptyRose_125) out_EmptyRose_125))))] out_EmptyRose_120) - [ - case_EmptyRose_121 - (iwrap - (lam List_153 (fun (type) (type)) (lam a_154 (type) (all out_List_155 (type) (fun out_List_155 (fun (fun a_154 (fun [List_153 a_154] out_List_155)) out_List_155))))) - a_146 - (abs - out_List_156 - (type) - (lam - case_Nil_157 - out_List_156 - (lam + (delay + (lam + case_Nil_157 + (lam + case_Cons_158 + [ + [ case_Cons_158 - (fun a_146 (fun [(lam a_159 (type) (ifix (lam List_160 (fun (type) (type)) (lam a_161 (type) (all out_List_162 (type) (fun out_List_162 (fun (fun a_161 (fun [List_160 a_161] out_List_162)) out_List_162))))) a_159)) a_146] out_List_156)) - [ - [ + (delay + (lam + case_EmptyRose_121 + [ + case_EmptyRose_121 + (delay (lam case_Nil_140 (lam case_Cons_141 case_Nil_140)) + ) + ] + ) + ) + ] + (delay + (lam + case_Nil_157 + (lam case_Cons_158 - (iwrap - (lam rec_116 (fun (fun (type) (type)) (type)) (lam f_117 (fun (type) (type)) [f_117 [rec_116 f_117]])) - (lam EmptyRose_118 (type) (all out_EmptyRose_119 (type) (fun (fun [List_64 EmptyRose_118] out_EmptyRose_119) out_EmptyRose_119))) - (abs - out_EmptyRose_120 - (type) - (lam - case_EmptyRose_121 - (fun [List_64 (ifix (lam rec_122 (fun (fun (type) (type)) (type)) (lam f_123 (fun (type) (type)) [f_123 [rec_122 f_123]])) (lam EmptyRose_124 (type) (all out_EmptyRose_125 (type) (fun (fun [List_64 EmptyRose_124] out_EmptyRose_125) out_EmptyRose_125))))] out_EmptyRose_120) - [ + [ + [ + case_Cons_158 + (delay + (lam case_EmptyRose_121 - (iwrap - (lam List_136 (fun (type) (type)) (lam a_137 (type) (all out_List_138 (type) (fun out_List_138 (fun (fun a_137 (fun [List_136 a_137] out_List_138)) out_List_138))))) - a_135 - (abs - out_List_139 - (type) - (lam - case_Nil_140 - out_List_139 - (lam - case_Cons_141 - (fun a_135 (fun [(lam a_142 (type) (ifix (lam List_143 (fun (type) (type)) (lam a_144 (type) (all out_List_145 (type) (fun out_List_145 (fun (fun a_144 (fun [List_143 a_144] out_List_145)) out_List_145))))) a_142)) a_135] out_List_139)) - case_Nil_140 - ) - ) - ) - ) - ] - ) - ) - ) - ] - (iwrap - (lam List_153 (fun (type) (type)) (lam a_154 (type) (all out_List_155 (type) (fun out_List_155 (fun (fun a_154 (fun [List_153 a_154] out_List_155)) out_List_155))))) - a_146 - (abs - out_List_156 - (type) - (lam - case_Nil_157 - out_List_156 - (lam - case_Cons_158 - (fun a_146 (fun [(lam a_159 (type) (ifix (lam List_160 (fun (type) (type)) (lam a_161 (type) (all out_List_162 (type) (fun out_List_162 (fun (fun a_161 (fun [List_160 a_161] out_List_162)) out_List_162))))) a_159)) a_146] out_List_156)) - [ [ - case_Cons_158 - (iwrap - (lam rec_116 (fun (fun (type) (type)) (type)) (lam f_117 (fun (type) (type)) [f_117 [rec_116 f_117]])) - (lam EmptyRose_118 (type) (all out_EmptyRose_119 (type) (fun (fun [List_64 EmptyRose_118] out_EmptyRose_119) out_EmptyRose_119))) - (abs - out_EmptyRose_120 - (type) - (lam - case_EmptyRose_121 - (fun [List_64 (ifix (lam rec_122 (fun (fun (type) (type)) (type)) (lam f_123 (fun (type) (type)) [f_123 [rec_122 f_123]])) (lam EmptyRose_124 (type) (all out_EmptyRose_125 (type) (fun (fun [List_64 EmptyRose_124] out_EmptyRose_125) out_EmptyRose_125))))] out_EmptyRose_120) - [ - case_EmptyRose_121 - (iwrap - (lam List_136 (fun (type) (type)) (lam a_137 (type) (all out_List_138 (type) (fun out_List_138 (fun (fun a_137 (fun [List_136 a_137] out_List_138)) out_List_138))))) - a_135 - (abs - out_List_139 - (type) - (lam - case_Nil_140 - out_List_139 - (lam - case_Cons_141 - (fun a_135 (fun [(lam a_142 (type) (ifix (lam List_143 (fun (type) (type)) (lam a_144 (type) (all out_List_145 (type) (fun out_List_145 (fun (fun a_144 (fun [List_143 a_144] out_List_145)) out_List_145))))) a_142)) a_135] out_List_139)) - case_Nil_140 - ) - ) - ) - ) - ] - ) - ) - ) - ] - (iwrap - (lam List_136 (fun (type) (type)) (lam a_137 (type) (all out_List_138 (type) (fun out_List_138 (fun (fun a_137 (fun [List_136 a_137] out_List_138)) out_List_138))))) - a_135 - (abs - out_List_139 - (type) + case_EmptyRose_121 + (delay (lam - case_Nil_140 - out_List_139 - (lam - case_Cons_141 - (fun a_135 (fun [(lam a_142 (type) (ifix (lam List_143 (fun (type) (type)) (lam a_144 (type) (all out_List_145 (type) (fun out_List_145 (fun (fun a_144 (fun [List_143 a_144] out_List_145)) out_List_145))))) a_142)) a_135] out_List_139)) - case_Nil_140 - ) + case_Nil_140 (lam case_Cons_141 case_Nil_140) ) ) - ) - ] + ] + ) ) + ] + (delay (lam case_Nil_140 (lam case_Cons_141 case_Nil_140)) ) - ) + ] ) - ] + ) ) - ) + ] ) ) - ] - ) + ) + ] ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs index e94522c82c1..88c5a39bcd8 100644 --- a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs @@ -9,6 +9,7 @@ module Plugin.Errors.Spec where import Common +import Lib import PlcTestUtils import Plugin.Lib @@ -30,15 +31,15 @@ import GHC.Integer.GMP.Internals errors :: TestNested errors = testNested "Errors" [ - goldenPlcCatch "machInt" machInt + goldenUPlcCatch "machInt" machInt -- FIXME: This fails differently in nix, possibly due to slightly different optimization settings -- , goldenPlcCatch "negativeInt" negativeInt - , goldenPlcCatch "caseInt" caseInt - , goldenPlcCatch "recursiveNewtype" recursiveNewtype - , goldenPlcCatch "mutualRecursionUnfoldingsLocal" mutualRecursionUnfoldingsLocal - , goldenPlcCatch "literalCaseInt" literalCaseInt - , goldenPlcCatch "literalCaseBs" literalCaseBs - , goldenPlcCatch "literalCaseOther" literalCaseOther + , goldenUPlcCatch "caseInt" caseInt + , goldenUPlcCatch "recursiveNewtype" recursiveNewtype + , goldenUPlcCatch "mutualRecursionUnfoldingsLocal" mutualRecursionUnfoldingsLocal + , goldenUPlcCatch "literalCaseInt" literalCaseInt + , goldenUPlcCatch "literalCaseBs" literalCaseBs + , goldenUPlcCatch "literalCaseOther" literalCaseOther ] machInt :: CompiledCode PLC.DefaultUni Int diff --git a/plutus-tx-plugin/test/Plugin/Errors/literalCaseOther.plc.golden b/plutus-tx-plugin/test/Plugin/Errors/literalCaseOther.plc.golden index 2894dc46784..551da48e1c2 100644 --- a/plutus-tx-plugin/test/Plugin/Errors/literalCaseOther.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Errors/literalCaseOther.plc.golden @@ -1,100 +1,76 @@ (program 1.0.0 [ [ - { - (abs - AType_i0 - (type) + (force + (delay (lam AType_i0 - AType_i2 (lam AType_match_i0 - (fun AType_i3 (all out_AType_i0 (type) (fun out_AType_i1 out_AType_i1))) [ [ - { - (abs - Unit_i0 - (type) + (force + (delay (lam Unit_i0 - Unit_i2 (lam Unit_match_i0 - (fun Unit_i3 (all out_Unit_i0 (type) (fun out_Unit_i1 out_Unit_i1))) [ [ [ - { - (abs - Bool_i0 - (type) + (force + (delay (lam True_i0 - Bool_i2 (lam False_i0 - Bool_i3 (lam Bool_match_i0 - (fun Bool_i4 (all out_Bool_i0 (type) (fun out_Bool_i1 (fun out_Bool_i1 out_Bool_i1)))) [ (lam c_i0 - (fun AType_i11 (fun AType_i11 Bool_i5)) [ [ [ - { - (abs - List_i0 - (fun (type) (type)) + (force + (delay (lam Nil_i0 - (all a_i0 (type) [List_i3 a_i1]) (lam Cons_i0 - (all a_i0 (type) (fun a_i1 (fun [List_i4 a_i1] [List_i4 a_i1]))) (lam Nil_match_i0 - (all a_i0 (type) (fun [List_i5 a_i1] (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i6 a_i2] out_List_i1)) out_List_i1))))) [ (lam cfromString_i0 - (fun [List_i5 (con char)] AType_i16) [ (lam fromString_i0 - (all a_i0 (type) (fun [(lam a_i0 (type) (fun [List_i8 (con char)] a_i1)) a_i1] (fun [List_i7 (con char)] a_i1))) (lam x_i0 - AType_i18 [ [ [ - { + (force [ - Bool_match_i9 + Bool_match_i8 [ [ - c_i8 + c_i7 x_i1 ] [ [ - { + (force fromString_i2 - AType_i18 - } + ) cfromString_i3 ] [ [ - { + (force Cons_i5 - (con char) - } + ) (con char 'a' @@ -102,10 +78,9 @@ ] [ [ - { + (force Cons_i5 - (con char) - } + ) (con char 'b' @@ -113,61 +88,51 @@ ] [ [ - { + (force Cons_i5 - (con char) - } + ) (con char 'c' ) ] - { + (force Nil_i6 - (con char) - } + ) ] ] ] ] ] ] - (fun Unit_i15 AType_i18) - } + ) (lam thunk_i0 - Unit_i16 [ [ - { + (force fromString_i3 - AType_i19 - } + ) cfromString_i4 ] - { + (force Nil_i7 - (con char) - } + ) ] ) ] (lam thunk_i0 - Unit_i16 x_i2 ) ] - Unit_i14 + Unit_i12 ] ) ) - (abs - a_i0 - (type) + (delay (lam v_i0 - [(lam a_i0 (type) (fun [List_i8 (con char)] a_i1)) a_i2] v_i1 ) ) @@ -175,67 +140,43 @@ ) (lam ds_i0 - [List_i5 (con char)] - AType_i15 + AType_i12 ) ] ) ) ) ) - (lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) - } - (abs - a_i0 - (type) - (iwrap - (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) - a_i1 - (abs - out_List_i0 - (type) + ) + (delay + (delay + (lam + case_Nil_i0 (lam - case_Nil_i0 - out_List_i2 - (lam - case_Cons_i0 - (fun a_i4 (fun [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i4] out_List_i3)) - case_Nil_i2 - ) + case_Cons_i0 + case_Nil_i2 ) ) ) ) ] - (abs - a_i0 - (type) + (delay (lam arg_0_i0 - a_i2 (lam arg_1_i0 - [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i3] - (iwrap - (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) - a_i3 - (abs - out_List_i0 - (type) + (delay + (lam + case_Nil_i0 (lam - case_Nil_i0 - out_List_i2 - (lam - case_Cons_i0 - (fun a_i6 (fun [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i6] out_List_i3)) + case_Cons_i0 + [ [ - [ - case_Cons_i1 - arg_0_i5 - ] - arg_1_i4 + case_Cons_i1 + arg_0_i4 ] - ) + arg_1_i3 + ] ) ) ) @@ -243,52 +184,35 @@ ) ) ] - (abs - a_i0 - (type) - (lam - x_i0 - [(lam a_i0 (type) (ifix (lam List_i0 (fun (type) (type)) (lam a_i0 (type) (all out_List_i0 (type) (fun out_List_i1 (fun (fun a_i2 (fun [List_i3 a_i2] out_List_i1)) out_List_i1))))) a_i1)) a_i2] - (unwrap x_i1) - ) - ) + (delay (lam x_i0 x_i1)) ] ) (lam ds_i0 - AType_i11 (lam ds_i0 - AType_i12 [ [ - { - [ AType_match_i10 ds_i2 ] - (fun Unit_i9 Bool_i6) - } + (force + [ AType_match_i8 ds_i2 ] + ) (lam thunk_i0 - Unit_i10 [ [ - { + (force [ - AType_match_i11 + AType_match_i9 ds_i2 ] - (fun Unit_i10 Bool_i7) - } - (lam - thunk_i0 - Unit_i11 - True_i7 ) + (lam thunk_i0 True_i7) ] - Unit_i9 + Unit_i8 ] ) ] - Unit_i8 + Unit_i7 ] ) ) @@ -297,58 +221,36 @@ ) ) ) - (all out_Bool_i0 (type) (fun out_Bool_i1 (fun out_Bool_i1 out_Bool_i1))) - } - (abs - out_Bool_i0 - (type) + ) + (delay (lam case_True_i0 - out_Bool_i2 - (lam case_False_i0 out_Bool_i3 case_True_i2) + (lam case_False_i0 case_True_i2) ) ) ] - (abs - out_Bool_i0 - (type) + (delay (lam - case_True_i0 - out_Bool_i2 - (lam case_False_i0 out_Bool_i3 case_False_i1) + case_True_i0 (lam case_False_i0 case_False_i1) ) ) ] - (lam - x_i0 - (all out_Bool_i0 (type) (fun out_Bool_i1 (fun out_Bool_i1 out_Bool_i1))) - x_i1 - ) + (lam x_i0 x_i1) ] ) ) ) - (all out_Unit_i0 (type) (fun out_Unit_i1 out_Unit_i1)) - } - (abs - out_Unit_i0 - (type) - (lam case_Unit_i0 out_Unit_i2 case_Unit_i1) ) + (delay (lam case_Unit_i0 case_Unit_i1)) ] - (lam - x_i0 - (all out_Unit_i0 (type) (fun out_Unit_i1 out_Unit_i1)) - x_i1 - ) + (lam x_i0 x_i1) ] ) ) ) - (all out_AType_i0 (type) (fun out_AType_i1 out_AType_i1)) - } - (abs out_AType_i0 (type) (lam case_AType_i0 out_AType_i2 case_AType_i1)) + ) + (delay (lam case_AType_i0 case_AType_i1)) ] - (lam x_i0 (all out_AType_i0 (type) (fun out_AType_i1 out_AType_i1)) x_i1) + (lam x_i0 x_i1) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Functions/Spec.hs b/plutus-tx-plugin/test/Plugin/Functions/Spec.hs index c1582b969e2..c2e17646460 100644 --- a/plutus-tx-plugin/test/Plugin/Functions/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Functions/Spec.hs @@ -7,6 +7,7 @@ module Plugin.Functions.Spec where import Common +import Lib import PlcTestUtils import Plugin.Lib @@ -20,9 +21,6 @@ import qualified Language.PlutusCore.Universe as PLC import Data.Proxy --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - functions :: TestNested functions = testNested "Functions" [ recursiveFunctions @@ -32,12 +30,12 @@ functions = testNested "Functions" [ recursiveFunctions :: TestNested recursiveFunctions = testNested "recursive" [ goldenPir "fib" fib - , goldenEval "fib4" [ getProgram fib, getProgram $ plc (Proxy @"4") (4::Integer) ] + , goldenUEval "fib4" [ toUPlc fib, toUPlc $ plc (Proxy @"4") (4::Integer) ] , goldenPir "sum" sumDirect - , goldenEval "sumList" [ getProgram sumDirect, getProgram listConstruct3 ] + , goldenUEval "sumList" [ toUPlc sumDirect, toUPlc listConstruct3 ] , goldenPir "even" evenMutual - , goldenEval "even3" [ getProgram evenMutual, getProgram $ plc (Proxy @"3") (3::Integer) ] - , goldenEval "even4" [ getProgram evenMutual, getProgram $ plc (Proxy @"4") (4::Integer) ] + , goldenUEval "even3" [ toUPlc evenMutual, toUPlc $ plc (Proxy @"3") (3::Integer) ] + , goldenUEval "even4" [ toUPlc evenMutual, toUPlc $ plc (Proxy @"4") (4::Integer) ] ] fib :: CompiledCode PLC.DefaultUni (Integer -> Integer) diff --git a/plutus-tx-plugin/test/Plugin/Functions/recursive/even3.plc.golden b/plutus-tx-plugin/test/Plugin/Functions/recursive/even3.plc.golden index 88338f786d7..96b34684256 100644 --- a/plutus-tx-plugin/test/Plugin/Functions/recursive/even3.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Functions/recursive/even3.plc.golden @@ -1,7 +1 @@ -(abs - out_Bool_106 - (type) - (lam - case_True_107 out_Bool_106 (lam case_False_108 out_Bool_106 case_False_108) - ) -) \ No newline at end of file +(delay (lam case_True_107 (lam case_False_108 case_False_108))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Functions/recursive/even4.plc.golden b/plutus-tx-plugin/test/Plugin/Functions/recursive/even4.plc.golden index 8c424069297..565ee7406be 100644 --- a/plutus-tx-plugin/test/Plugin/Functions/recursive/even4.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Functions/recursive/even4.plc.golden @@ -1,7 +1 @@ -(abs - out_Bool_103 - (type) - (lam - case_True_104 out_Bool_103 (lam case_False_105 out_Bool_103 case_True_104) - ) -) \ No newline at end of file +(delay (lam case_True_104 (lam case_False_105 case_True_104))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs b/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs index 7b66d312da9..a7542b8f790 100644 --- a/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs @@ -7,6 +7,7 @@ module Plugin.Laziness.Spec where import Common +import Lib import PlcTestUtils import Plugin.Lib @@ -18,13 +19,10 @@ import qualified Language.PlutusCore.Universe as PLC import Data.Proxy --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - laziness :: TestNested laziness = testNested "Laziness" [ goldenPir "joinError" joinErrorPir - , goldenEval "joinErrorEval" [ getProgram joinErrorPir, getProgram $ plc (Proxy @"T") True, getProgram $ plc (Proxy @"F") False] + , goldenUEval "joinErrorEval" [ toUPlc joinErrorPir, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False] , goldenPir "lazyDepUnit" lazyDepUnit ] diff --git a/plutus-tx-plugin/test/Plugin/Laziness/joinErrorEval.plc.golden b/plutus-tx-plugin/test/Plugin/Laziness/joinErrorEval.plc.golden index 09bb36ee4c3..13d7a784edf 100644 --- a/plutus-tx-plugin/test/Plugin/Laziness/joinErrorEval.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Laziness/joinErrorEval.plc.golden @@ -1 +1 @@ -(abs out_Unit_36 (type) (lam case_Unit_37 out_Unit_36 case_Unit_37)) \ No newline at end of file +(delay (lam case_Unit_37 case_Unit_37)) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Lib.hs b/plutus-tx-plugin/test/Plugin/Lib.hs index d85bf4983c2..837d6e5de1b 100644 --- a/plutus-tx-plugin/test/Plugin/Lib.hs +++ b/plutus-tx-plugin/test/Plugin/Lib.hs @@ -21,22 +21,11 @@ import Language.PlutusTx.TH import Language.PlutusCore.Pretty (PrettyConst) import qualified Language.PlutusCore.Universe as PLC +import qualified Language.UntypedPlutusCore as UPLC import Codec.Serialise (Serialise) import Data.Text.Prettyprint.Doc -{-# ANN module "HLint: ignore" #-} - -instance (PLC.Closed uni, uni `PLC.Everywhere` Serialise) => - GetProgram (CompiledCode uni a) uni where - getProgram = catchAll . getPlc - -goldenPir - :: (PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PrettyConst, uni `PLC.Everywhere` Serialise) - => String -> CompiledCode uni a -> TestNested -goldenPir name value = nestedGoldenVsDoc name $ pretty $ getPir value - - -- This is here for the Plugin spec, but we're testing using things from a different module andExternal :: Bool -> Bool -> Bool andExternal a b = if a then b else False diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs index cb670a99d3e..8ebe6af6cc6 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs @@ -7,6 +7,7 @@ module Plugin.Primitives.Spec where import Common +import Lib import PlcTestUtils import Plugin.Lib @@ -22,9 +23,6 @@ import Data.Proxy import GHC.Magic --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - primitives :: TestNested primitives = testNested "Primitives" [ goldenPir "string" string @@ -32,27 +30,27 @@ primitives = testNested "Primitives" [ , goldenPir "int2" int2 , goldenPir "bool" bool , goldenPir "and" andPlc - , goldenEval "andApply" [ getProgram andPlc, getProgram $ plc (Proxy @"T") True, getProgram $ plc (Proxy @"F") False ] + , goldenUEval "andApply" [ toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False ] , goldenPir "tuple" tuple , goldenPir "tupleMatch" tupleMatch - , goldenEval "tupleConstDest" [ getProgram tupleMatch, getProgram tuple ] + , goldenUEval "tupleConstDest" [ toUPlc tupleMatch, toUPlc tuple ] , goldenPir "intCompare" intCompare , goldenPir "intEq" intEq - , goldenEval "intEqApply" [ getProgram intEq, getProgram int, getProgram int ] + , goldenUEval "intEqApply" [ toUPlc intEq, toUPlc int, toUPlc int ] , goldenPir "void" void , goldenPir "intPlus" intPlus , goldenPir "intDiv" intDiv - , goldenEval "intPlusApply" [ getProgram intPlus, getProgram int, getProgram int2 ] + , goldenUEval "intPlusApply" [ toUPlc intPlus, toUPlc int, toUPlc int2 ] , goldenPir "error" errorPlc , goldenPir "ifThenElse" ifThenElse - , goldenEval "ifThenElseApply" [ getProgram ifThenElse, getProgram int, getProgram int2 ] + , goldenUEval "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ] , goldenPir "emptyByteString" emptyByteString - , goldenEval "emptyByteStringApply" [ getPlc emptyByteString, liftProgram Builtins.emptyByteString ] + , goldenUEval "emptyByteStringApply" [ getPlc emptyByteString, liftProgram Builtins.emptyByteString ] , goldenPir "bytestring" bytestring - , goldenEval "bytestringApply" [ getPlc bytestring, liftProgram ("hello"::Builtins.ByteString) ] - , goldenEval "sha2_256" [ getPlc sha2, liftProgram ("hello" :: Builtins.ByteString)] - , goldenEval "equalsByteString" [ getPlc bsEquals, liftProgram ("hello" :: Builtins.ByteString), liftProgram ("hello" :: Builtins.ByteString)] - , goldenEval "ltByteString" [ getPlc bsLt, liftProgram ("hello" :: Builtins.ByteString), liftProgram ("world" :: Builtins.ByteString)] + , goldenUEval "bytestringApply" [ getPlc bytestring, liftProgram ("hello"::Builtins.ByteString) ] + , goldenUEval "sha2_256" [ getPlc sha2, liftProgram ("hello" :: Builtins.ByteString)] + , goldenUEval "equalsByteString" [ getPlc bsEquals, liftProgram ("hello" :: Builtins.ByteString), liftProgram ("hello" :: Builtins.ByteString)] + , goldenUEval "ltByteString" [ getPlc bsLt, liftProgram ("hello" :: Builtins.ByteString), liftProgram ("world" :: Builtins.ByteString)] , goldenPir "verify" verify , goldenPir "trace" trace , goldenPir "stringLiteral" stringLiteral diff --git a/plutus-tx-plugin/test/Plugin/Primitives/andApply.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/andApply.plc.golden index c1af81b65cb..c74eab200a4 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/andApply.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/andApply.plc.golden @@ -1,5 +1 @@ -(abs - out_Bool_9 - (type) - (lam case_True_10 out_Bool_9 (lam case_False_11 out_Bool_9 case_False_11)) -) \ No newline at end of file +(delay (lam case_True_10 (lam case_False_11 case_False_11))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden index 264d62e0dee..5bc69decf75 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden @@ -1,5 +1 @@ -(abs - out_Bool_12 - (type) - (lam case_True_13 out_Bool_12 (lam case_False_14 out_Bool_12 case_True_13)) -) \ No newline at end of file +(delay (lam case_True_13 (lam case_False_14 case_True_13))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/intEqApply.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/intEqApply.plc.golden index 264d62e0dee..5bc69decf75 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/intEqApply.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/intEqApply.plc.golden @@ -1,5 +1 @@ -(abs - out_Bool_12 - (type) - (lam case_True_13 out_Bool_12 (lam case_False_14 out_Bool_12 case_True_13)) -) \ No newline at end of file +(delay (lam case_True_13 (lam case_False_14 case_True_13))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden index 264d62e0dee..5bc69decf75 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden @@ -1,5 +1 @@ -(abs - out_Bool_12 - (type) - (lam case_True_13 out_Bool_12 (lam case_False_14 out_Bool_12 case_True_13)) -) \ No newline at end of file +(delay (lam case_True_13 (lam case_False_14 case_True_13))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs b/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs index 04a2ba8ab18..20427396a0c 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs @@ -8,25 +8,21 @@ module Plugin.Typeclasses.Spec where import Common +import Lib import PlcTestUtils -import Plugin.Lib - import Plugin.Data.Spec +import Plugin.Lib +import Plugin.Typeclasses.Lib import qualified Language.PlutusTx.Builtins as Builtins import Language.PlutusTx.Code import Language.PlutusTx.Plugin import qualified Language.PlutusTx.Prelude as P -import Plugin.Typeclasses.Lib - import qualified Language.PlutusCore.Universe as PLC import Data.Proxy --- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} - typeclasses :: TestNested typeclasses = testNested "Typeclasses" [ goldenPir "sizedBasic" sizedBasic diff --git a/plutus-tx-plugin/test/StdLib/Spec.hs b/plutus-tx-plugin/test/StdLib/Spec.hs index ef9cb433d4d..1ac6c4e377b 100644 --- a/plutus-tx-plugin/test/StdLib/Spec.hs +++ b/plutus-tx-plugin/test/StdLib/Spec.hs @@ -14,6 +14,7 @@ import Hedgehog (Gen, MonadGen, Property) import qualified Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import Lib import PlcTestUtils import Plugin.Lib import Test.Tasty (TestName) @@ -34,15 +35,13 @@ import qualified Language.PlutusCore.Universe as PLC import Data.Proxy -{-# ANN module ("HLint: ignore"::String) #-} - roundPlc :: CompiledCode PLC.DefaultUni (Ratio.Rational -> Integer) roundPlc = plc (Proxy @"roundPlc") Ratio.round tests :: TestNested tests = testNested "StdLib" - [ goldenEval "ratioInterop" [ getPlc roundPlc, Lift.liftProgram (Ratio.fromGHC 3.75) ] + [ goldenUEval "ratioInterop" [ getPlc roundPlc, Lift.liftProgram (Ratio.fromGHC 3.75) ] , testRatioProperty "round" Ratio.round round , testRatioProperty "truncate" Ratio.truncate truncate , testRatioProperty "abs" (fmap Ratio.toGHC Ratio.abs) abs diff --git a/plutus-tx-plugin/test/TH/Spec.hs b/plutus-tx-plugin/test/TH/Spec.hs index ff3a699e02a..192982a46da 100644 --- a/plutus-tx-plugin/test/TH/Spec.hs +++ b/plutus-tx-plugin/test/TH/Spec.hs @@ -15,6 +15,7 @@ module TH.Spec (tests) where import Common +import Lib import PlcTestUtils import PlutusPrelude (view) @@ -31,9 +32,11 @@ import Language.PlutusTx.TH import qualified Language.PlutusIR as PIR -import Language.PlutusCore +import qualified Language.PlutusCore as PLC import Language.PlutusCore.Pretty import qualified Language.PlutusCore.Universe as PLC +import Language.UntypedPlutusCore +import qualified Language.UntypedPlutusCore as UPLC import Control.Exception import Control.Lens.Combinators (_1) @@ -42,30 +45,24 @@ import Control.Monad.Except import Data.Text.Prettyprint.Doc import Test.Tasty -instance uni ~ PLC.DefaultUni => GetProgram (CompiledCode uni a) uni where - getProgram = catchAll . getPlc - -goldenPir :: String -> CompiledCode PLC.DefaultUni a -> TestNested -goldenPir name value = nestedGoldenVsDoc name $ pretty $ getPir value - -runPlcCek :: GetProgram a PLC.DefaultUni => [a] -> ExceptT SomeException IO (Plain Term PLC.DefaultUni) +runPlcCek :: ToUPlc a PLC.DefaultUni => [a] -> ExceptT SomeException IO (Term PLC.Name PLC.DefaultUni ()) runPlcCek values = do - ps <- Haskell.traverse getProgram values - let p = foldl1 applyProgram ps + ps <- Haskell.traverse toUPlc values + let p = foldl1 UPLC.applyProgram ps either (throwError . SomeException) Haskell.pure $ evaluateCek p -runPlcCekTrace :: GetProgram a PLC.DefaultUni => [a] -> ExceptT SomeException IO ([String], CekExTally, (Plain Term PLC.DefaultUni)) +runPlcCekTrace :: ToUPlc a PLC.DefaultUni => [a] -> ExceptT SomeException IO ([String], CekExTally, (Term PLC.Name PLC.DefaultUni ())) runPlcCekTrace values = do - ps <- Haskell.traverse getProgram values - let p = foldl1 applyProgram ps + ps <- Haskell.traverse toUPlc values + let p = foldl1 UPLC.applyProgram ps let (logOut, tally, result) = evaluateCekTrace p res <- either (throwError . SomeException) Haskell.pure result Haskell.pure (logOut, tally, res) -goldenEvalCek :: GetProgram a PLC.DefaultUni => String -> [a] -> TestNested +goldenEvalCek :: ToUPlc a PLC.DefaultUni => String -> [a] -> TestNested goldenEvalCek name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug Haskell.<$> (rethrow $ runPlcCek values) -goldenEvalCekLog :: GetProgram a PLC.DefaultUni => String -> [a] -> TestNested +goldenEvalCekLog :: ToUPlc a PLC.DefaultUni => String -> [a] -> TestNested goldenEvalCekLog name values = nestedGoldenVsDocM name $ (pretty . (view _1)) Haskell.<$> (rethrow $ runPlcCekTrace values) tests :: TestNested diff --git a/plutus-tx-plugin/test/TH/all.plc.golden b/plutus-tx-plugin/test/TH/all.plc.golden index c4e6518d53e..5a66c240bfb 100644 --- a/plutus-tx-plugin/test/TH/all.plc.golden +++ b/plutus-tx-plugin/test/TH/all.plc.golden @@ -1,7 +1 @@ -(abs - out_Bool_122 - (type) - (lam - case_True_123 out_Bool_122 (lam case_False_124 out_Bool_122 case_True_123) - ) -) \ No newline at end of file +(delay (lam case_True_123 (lam case_False_124 case_True_123))) \ No newline at end of file diff --git a/plutus-tx/src/Language/PlutusTx.hs b/plutus-tx/src/Language/PlutusTx.hs index 8d8529ba1d2..9919b359d44 100644 --- a/plutus-tx/src/Language/PlutusTx.hs +++ b/plutus-tx/src/Language/PlutusTx.hs @@ -12,12 +12,11 @@ module Language.PlutusTx ( Typeable, makeLift, safeLiftCode, - liftCode, - constCode) where + liftCode) where import Language.PlutusTx.Code (CompiledCode, applyCode, getPir, getPlc) import Language.PlutusTx.Data (Data (..)) import Language.PlutusTx.IsData (IsData (..), makeIsData, makeIsDataIndexed) -import Language.PlutusTx.Lift (constCode, liftCode, makeLift, safeLiftCode) +import Language.PlutusTx.Lift (liftCode, makeLift, safeLiftCode) import Language.PlutusTx.Lift.Class (Lift, Typeable) import Language.PlutusTx.TH as Export diff --git a/plutus-tx/src/Language/PlutusTx/Code.hs b/plutus-tx/src/Language/PlutusTx/Code.hs index 88447fab27e..6a83d2d8449 100644 --- a/plutus-tx/src/Language/PlutusTx/Code.hs +++ b/plutus-tx/src/Language/PlutusTx/Code.hs @@ -9,13 +9,12 @@ {-# LANGUAGE ViewPatterns #-} module Language.PlutusTx.Code where -import qualified Language.PlutusTx.Lift.Class as Lift import Language.PlutusTx.Lift.Instances () import qualified Language.PlutusIR as PIR -import qualified Language.PlutusIR.MkPir as PIR import qualified Language.PlutusCore as PLC +import qualified Language.UntypedPlutusCore as UPLC import Codec.Serialise (DeserialiseFailure, Serialise, deserialiseOrFail) import Control.Exception @@ -33,26 +32,26 @@ import qualified Data.ByteString.Lazy as BSL -- Note: the compiled PLC program does *not* have normalized types, -- if you want to put it on the chain you must normalize the types first. data CompiledCode uni a = - -- | Serialized PLC code and possibly serialized PIR code. + -- | Serialized UPLC code and possibly serialized PIR code. SerializedCode BS.ByteString (Maybe BS.ByteString) - -- | Deserialized PLC program and possibly deserialized PIR program. - | DeserializedCode (PLC.Program PLC.TyName PLC.Name uni ()) (Maybe (PIR.Program PLC.TyName PLC.Name uni ())) + -- | Deserialized UPLC program and possibly deserialized PIR program. + | DeserializedCode (UPLC.Program PLC.Name uni ()) (Maybe (PIR.Program PLC.TyName PLC.Name uni ())) -- Note that we do *not* have a TypeablePlc instance, since we don't know what the type is. We could in principle store it after the plugin -- typechecks the code, but we don't currently. -instance (PLC.Closed uni, uni `PLC.Everywhere` Serialise, uni ~ uni') => - Lift.Lift uni' (CompiledCode uni a) where - lift (getPlc -> (PLC.Program () _ body)) = PIR.embed <$> PLC.rename body +--instance (PLC.Closed uni, uni `PLC.Everywhere` Serialise, uni ~ uni') => + --Lift.Lift uni' (CompiledCode uni a) where + --lift (getPlc -> (PLC.Program () _ body)) = PIR.embed <$> PLC.rename body -- | Apply a compiled function to a compiled argument. applyCode :: (PLC.Closed uni, uni `PLC.Everywhere` Serialise) => CompiledCode uni (a -> b) -> CompiledCode uni a -> CompiledCode uni b -applyCode fun arg = DeserializedCode (getPlc fun `PLC.applyProgram` getPlc arg) Nothing +applyCode fun arg = DeserializedCode (getPlc fun `UPLC.applyProgram` getPlc arg) Nothing -- | The size of a 'CompiledCode', in AST nodes. sizePlc :: (PLC.Closed uni, uni `PLC.Everywhere` Serialise) => CompiledCode uni a -> Integer -sizePlc = PLC.programSize . getPlc +sizePlc = UPLC.programSize . getPlc {- Note [Deserializing the AST] The types suggest that we can fail to deserialize the AST that we embedded in the program. @@ -67,7 +66,7 @@ instance Exception ImpossibleDeserialisationFailure -- | Get the actual Plutus Core program out of a 'CompiledCode'. getPlc :: (PLC.Closed uni, uni `PLC.Everywhere` Serialise) - => CompiledCode uni a -> PLC.Program PLC.TyName PLC.Name uni () + => CompiledCode uni a -> UPLC.Program PLC.Name uni () getPlc wrapper = case wrapper of SerializedCode plc _ -> case deserialiseOrFail (BSL.fromStrict plc) of Left e -> throw $ ImpossibleDeserialisationFailure e diff --git a/plutus-tx/src/Language/PlutusTx/Evaluation.hs b/plutus-tx/src/Language/PlutusTx/Evaluation.hs index 408aa8894e7..41332ead951 100644 --- a/plutus-tx/src/Language/PlutusTx/Evaluation.hs +++ b/plutus-tx/src/Language/PlutusTx/Evaluation.hs @@ -16,14 +16,17 @@ where import PlutusPrelude -import Language.PlutusCore import Language.PlutusCore.Constant import Language.PlutusCore.Constant.Dynamic -import Language.PlutusCore.Evaluation.Machine.Cek hiding (evaluateCek, unsafeEvaluateCek) -import qualified Language.PlutusCore.Evaluation.Machine.Cek as PLC (evaluateCek, unsafeEvaluateCek) import qualified Language.PlutusCore.Evaluation.Machine.ExBudgetingDefaults as PLC import Language.PlutusCore.Evaluation.Machine.ExMemory +import Language.PlutusCore.Name import Language.PlutusCore.Pretty (PrettyConst) +import Language.PlutusCore.Universe + +import Language.UntypedPlutusCore +import Language.UntypedPlutusCore.Evaluation.Machine.Cek hiding (evaluateCek, unsafeEvaluateCek) +import qualified Language.UntypedPlutusCore.Evaluation.Machine.Cek as UPLC (evaluateCek, unsafeEvaluateCek) import qualified Control.Exception import System.IO.Unsafe @@ -40,16 +43,16 @@ stringBuiltins = -- | Evaluate a program in the CEK machine with the usual string dynamic builtins. evaluateCek :: (GShow uni, GEq uni, DefaultUni <: uni, Closed uni, uni `Everywhere` ExMemoryUsage) - => Program TyName Name uni () -> Either (CekEvaluationException uni) (Plain Term uni) -evaluateCek = PLC.evaluateCek stringBuiltins PLC.defaultCostModel . toTerm + => Program Name uni () -> Either (CekEvaluationException uni) (Term Name uni ()) +evaluateCek (Program _ _ t) = UPLC.evaluateCek stringBuiltins PLC.defaultCostModel t -- | Evaluate a program in the CEK machine with the usual string dynamic builtins. May throw. unsafeEvaluateCek :: ( GShow uni, GEq uni, DefaultUni <: uni, Closed uni, uni `Everywhere` ExMemoryUsage , Typeable uni, uni `Everywhere` PrettyConst ) - => Program TyName Name uni () -> EvaluationResult (Plain Term uni) -unsafeEvaluateCek = PLC.unsafeEvaluateCek stringBuiltins PLC.defaultCostModel . toTerm + => Program Name uni () -> EvaluationResult (Term Name uni ()) +unsafeEvaluateCek (Program _ _ t) = UPLC.unsafeEvaluateCek stringBuiltins PLC.defaultCostModel t -- TODO: pretty sure we shouldn't need the unsafePerformIOs here, we should expose a pure interface even if it has IO hacks under the hood @@ -57,14 +60,14 @@ unsafeEvaluateCek = PLC.unsafeEvaluateCek stringBuiltins PLC.defaultCostModel . -- returning the trace output. evaluateCekTrace :: (GShow uni, GEq uni, DefaultUni <: uni, Closed uni, uni `Everywhere` ExMemoryUsage) - => Program TyName Name uni () - -> ([String], CekExTally, Either (CekEvaluationException uni) (Plain Term uni)) -evaluateCekTrace p = + => Program Name uni () + -> ([String], CekExTally, Either (CekEvaluationException uni) (Term Name uni ())) +evaluateCekTrace (Program _ _ t) = let (lg, (res, state)) = unsafePerformIO $ withEmit $ \emit -> do let logName = dynamicTraceName logDefinition = dynamicCallAssign logName emit (\_ -> ExBudget 1 1) env = insertDynamicBuiltinNameDefinition logDefinition stringBuiltins - Control.Exception.evaluate $ runCekCounting env PLC.defaultCostModel $ toTerm p + Control.Exception.evaluate $ runCekCounting env PLC.defaultCostModel t in (lg, view exBudgetStateTally state, res) diff --git a/plutus-tx/src/Language/PlutusTx/Lift.hs b/plutus-tx/src/Language/PlutusTx/Lift.hs index fa338ac62f0..8ead9d8b2f8 100644 --- a/plutus-tx/src/Language/PlutusTx/Lift.hs +++ b/plutus-tx/src/Language/PlutusTx/Lift.hs @@ -8,12 +8,10 @@ module Language.PlutusTx.Lift ( safeLift, safeLiftProgram, safeLiftCode, - safeConstCode, lift, liftProgram, liftProgramDef, liftCode, - constCode, typeCheckAgainst, typeCode) where @@ -35,9 +33,9 @@ import qualified Language.PlutusCore.Constant.Dynamic as PLC import Language.PlutusCore.Pretty (PrettyConst) import Language.PlutusCore.Quote import qualified Language.PlutusCore.StdLib.Data.Function as PLC -import qualified Language.PlutusCore.StdLib.Meta.Data.Function as PLC -import Codec.Serialise +import qualified Language.UntypedPlutusCore as UPLC + import Control.Exception import Control.Monad.Except hiding (lift) import Control.Monad.Reader hiding (lift) @@ -56,12 +54,12 @@ safeLift , PLC.DefaultUni PLC.<: uni , AsError e uni (Provenance ()), MonadError e m, MonadQuote m ) - => a -> m (PLC.Term TyName Name uni ()) + => a -> m (UPLC.Term Name uni ()) safeLift x = do lifted <- liftQuote $ runDefT () $ Lift.lift x -- note: we typecheck&compile the plutus-tx term inside an empty builtin context (PLC.defConfig) compiled <- flip runReaderT defaultCompilationCtx $ compileTerm True lifted - pure $ void compiled + pure $ void $ UPLC.erase compiled -- | Get a Plutus Core program corresponding to the given value. safeLiftProgram @@ -70,8 +68,8 @@ safeLiftProgram , PIR.AsTypeErrorExt e uni (Provenance ()) , PLC.DefaultUni PLC.<: uni , AsError e uni (Provenance ()), MonadError e m, MonadQuote m) - => a -> m (PLC.Program TyName Name uni ()) -safeLiftProgram x = PLC.Program () (PLC.defaultVersion ()) <$> safeLift x + => a -> m (UPLC.Program Name uni ()) +safeLiftProgram x = UPLC.Program () (PLC.defaultVersion ()) <$> safeLift x safeLiftCode :: (Lift.Lift uni a @@ -81,25 +79,6 @@ safeLiftCode => a -> m (CompiledCode uni a) safeLiftCode x = DeserializedCode <$> safeLiftProgram x <*> pure Nothing -safeConstCode - :: ( Lift.Typeable uni a, AsError e uni (Provenance ()), MonadError e m, MonadQuote m - , PIR.AsTypeError e (PIR.Term TyName Name uni ()) uni (Provenance ()), PLC.GShow uni, PLC.GEq uni - , PIR.AsTypeErrorExt e uni (Provenance ()) - , PLC.DefaultUni PLC.<: uni - , PLC.Closed uni, uni `PLC.Everywhere` Serialise - ) - => Proxy a - -> CompiledCode uni b - -> m (CompiledCode uni (a -> b)) -safeConstCode proxy code = do - newTerm <- liftQuote $ runDefT () $ do - term <- Lift.lift code - ty <- Lift.typeRep proxy - pure $ TyInst () (PLC.constPartial term) ty - -- FIXME: we need to pass the real dynamic builtin tcconfig map in compileterm - compiled <- flip runReaderT defaultCompilationCtx $ compileTerm True newTerm - pure $ DeserializedCode (PLC.Program () (PLC.defaultVersion ()) (void compiled)) Nothing - unsafely :: Throwable uni => ExceptT (Error uni (Provenance ())) Quote a -> a unsafely ma = runQuote $ do run <- runExceptT ma @@ -108,30 +87,21 @@ unsafely ma = runQuote $ do Right t -> pure t -- | Get a Plutus Core term corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. -lift :: (Lift.Lift uni a, Throwable uni) => a -> PLC.Term TyName Name uni () +lift :: (Lift.Lift uni a, Throwable uni) => a -> UPLC.Term Name uni () lift a = unsafely $ safeLift a -- | Get a Plutus Core program corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. -liftProgram :: (Lift.Lift uni a, Throwable uni) => a -> PLC.Program TyName Name uni () -liftProgram x = PLC.Program () (PLC.defaultVersion ()) $ lift x +liftProgram :: (Lift.Lift uni a, Throwable uni) => a -> UPLC.Program Name uni () +liftProgram x = UPLC.Program () (PLC.defaultVersion ()) $ lift x -- | Get a Plutus Core program in the default universe corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. -liftProgramDef :: Lift.Lift PLC.DefaultUni a => a -> PLC.Program TyName Name PLC.DefaultUni () +liftProgramDef :: Lift.Lift PLC.DefaultUni a => a -> UPLC.Program Name PLC.DefaultUni () liftProgramDef = liftProgram -- | Get a Plutus Core program corresponding to the given value as a 'CompiledCode', throwing any errors that occur as exceptions and ignoring fresh names. liftCode :: (Lift.Lift uni a, Throwable uni) => a -> CompiledCode uni a liftCode x = unsafely $ safeLiftCode x --- | Creates a program that ignores an argument of the given type and returns the program given. -constCode - :: (Lift.Typeable uni a, Throwable uni - , uni `PLC.Everywhere` Serialise) - => Proxy a - -> CompiledCode uni b - -> CompiledCode uni (a -> b) -constCode proxy b = unsafely $ safeConstCode proxy b - {- Note [Checking the type of a term with Typeable] Checking the type of a term should be simple, right? We can just use 'checkType', easy peasy. @@ -193,4 +163,4 @@ typeCode -> m (CompiledCode uni a) typeCode p prog@(PLC.Program _ _ term) = do _ <- typeCheckAgainst p term - pure $ DeserializedCode prog Nothing + pure $ DeserializedCode (UPLC.eraseProgram prog) Nothing diff --git a/plutus-use-cases/bench/Bench.hs b/plutus-use-cases/bench/Bench.hs index 53b028b2235..ae08911cee1 100644 --- a/plutus-use-cases/bench/Bench.hs +++ b/plutus-use-cases/bench/Bench.hs @@ -199,10 +199,7 @@ validators = bgroup "validators" [ trivial, multisig ] -- | The trivial validator script that just returns 'True'. trivial :: Benchmark -trivial = bgroup "trivial" [ - bench "nocheck" $ nf runScriptNoCheck (validationData1, validator, unitDatum, unitRedeemer), - bench "typecheck" $ nf runScriptCheck (validationData1, validator, unitDatum, unitRedeemer) - ] +trivial = bench "trivial" $ nf runScript' (validationData1, validator, unitDatum, unitRedeemer) where validator = mkValidatorScript $$(PlutusTx.compile [|| \(_ :: PlutusTx.Data) (_ :: PlutusTx.Data) (_ :: PlutusTx.Data) -> () ||]) @@ -210,22 +207,22 @@ trivial = bgroup "trivial" [ -- Note that multisig also does some signature verification! multisig :: Benchmark multisig = bgroup "multisig" [ - bench "1of1" $ nf runScriptNoCheck + bench "1of1" $ nf runScript' (validationData2 , Scripts.validatorScript $ MS.scriptInstance msScen1of1 , unitDatum , unitRedeemer), - bench "1of2" $ nf runScriptNoCheck + bench "1of2" $ nf runScript' (validationData2 , Scripts.validatorScript $ MS.scriptInstance msScen1of2 , unitDatum , unitRedeemer), - bench "2of2" $ nf runScriptNoCheck + bench "2of2" $ nf runScript' (validationData2 , Scripts.validatorScript $ MS.scriptInstance msScen2of2 , unitDatum , unitRedeemer), - bench "typecheck" $ nf runScriptCheck + bench "typecheck" $ nf runScript' (validationData2 , Scripts.validatorScript $ MS.scriptInstance msScen1of1 , unitDatum @@ -241,10 +238,8 @@ multisig = bgroup "multisig" [ verifySignature :: (PubKey, Digest SHA256, Signature) -> Bool verifySignature (PubKey (LedgerBytes k), m, Signature s) = P.verifySignature k (BSL.fromStrict $ BA.convert m) s -runScriptNoCheck :: (Context, Validator, Datum, Redeemer) -> Either ScriptError [String] -runScriptNoCheck (vd, v, d, r) = runScript DontCheck vd v d r -runScriptCheck :: (Context, Validator, Datum, Redeemer) -> Either ScriptError [String] -runScriptCheck (vd, v, d, r) = runScript Typecheck vd v d r +runScript' :: (Context, Validator, Datum, Redeemer) -> Either ScriptError [String] +runScript' (vd, v, d, r) = runScript vd v d r privk1 :: PrivateKey privk1 = Crypto.knownPrivateKeys !! 0 diff --git a/plutus-use-cases/test/Spec/crowdfundingTestOutput.txt b/plutus-use-cases/test/Spec/crowdfundingTestOutput.txt index 1295a5e5a67..2e223a7c630 100644 --- a/plutus-use-cases/test/Spec/crowdfundingTestOutput.txt +++ b/plutus-use-cases/test/Spec/crowdfundingTestOutput.txt @@ -21,25 +21,25 @@ Events by wallet: - Iteration: 3 Requests: 4: {utxo-at: - ScriptAddress: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8} + ScriptAddress: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4} Response: ( 4 , {utxo-at: - Utxo at ScriptAddress: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 = - a9df1faa344fb4a6c326cf14bf7b5b97a1edffae940ba84c00e5c65c0a245433!1: PayToScript: 49cd69a6941f191e3d14ce83834e0f2ce175318995b40380854e3201171c0baa Value {getValue = Map {unMap = [(,Map {unMap = [(,10)]})]}} - c811f9a55d3220377df1d4b16ae2fa256b060f60e6572509d97fdb5afcd33605!1: PayToScript: 4c592448cff8d2b2ee40a509e1d5224260ef29f5b22cd920616e39cad65f466c Value {getValue = Map {unMap = [(,Map {unMap = [(,1)]})]}} - eadd62c687f18e6c30283f5318b269eba5d7664c99cd335830fb529ef49371f1!1: PayToScript: b8324180800f57f26dee2ad65990e0a762a5dab9424d32e49855abd495f7196b Value {getValue = Map {unMap = [(,Map {unMap = [(,10)]})]}}} ) + Utxo at ScriptAddress: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 = + 1c7f3a99fd9ce160b72bfcaa6201a31ee54cfdb8ced477df9555a0a9509b31b3!1: PayToScript: 49cd69a6941f191e3d14ce83834e0f2ce175318995b40380854e3201171c0baa Value {getValue = Map {unMap = [(,Map {unMap = [(,10)]})]}} + 37d9fc96c3ffee49b5aeb980b1643bf3e648c0f2f6b0e1da3ef6bb6e58379b14!1: PayToScript: 4c592448cff8d2b2ee40a509e1d5224260ef29f5b22cd920616e39cad65f466c Value {getValue = Map {unMap = [(,Map {unMap = [(,1)]})]}} + 88f5f7103105159edf2b7cf41a7fb07a36e18b29b94e7af3c3f6719b760fe4e3!1: PayToScript: b8324180800f57f26dee2ad65990e0a762a5dab9424d32e49855abd495f7196b Value {getValue = Map {unMap = [(,Map {unMap = [(,10)]})]}}} ) - Iteration: 4 Requests: 5: {tx: Tx: - Tx dbd65bc2b348d80727fdcb0c052d76415bdf3a76ac43018344e2508f3198dd4e: + Tx e5b6f783158aa6cf79d5e86ed72c2d15ebcbae407183b84a3b3f65375de5cc27: {inputs: - - a9df1faa344fb4a6c326cf14bf7b5b97a1edffae940ba84c00e5c65c0a245433!1 + - 1c7f3a99fd9ce160b72bfcaa6201a31ee54cfdb8ced477df9555a0a9509b31b3!1 Redeemer: <> - - c811f9a55d3220377df1d4b16ae2fa256b060f60e6572509d97fdb5afcd33605!1 + - 37d9fc96c3ffee49b5aeb980b1643bf3e648c0f2f6b0e1da3ef6bb6e58379b14!1 Redeemer: <> - - eadd62c687f18e6c30283f5318b269eba5d7664c99cd335830fb529ef49371f1!1 + - 88f5f7103105159edf2b7cf41a7fb07a36e18b29b94e7af3c3f6719b760fe4e3!1 Redeemer: <> outputs: forge: Value {getValue = Map {unMap = []}} @@ -52,7 +52,7 @@ Events by wallet: Response: ( 5 , {tx: - WriteTxSuccess: 4d18d295930d525fa415486ae492aad245eccc26b733d06f6c150a12ec7a7857} ) + WriteTxSuccess: bcb5bebcafa63d1ac85fefed9d7f086041e3b7596cff3bd8ac832a2c01c153af} ) Events for W2: - Iteration: 1 Requests: @@ -78,11 +78,11 @@ Events by wallet: Requests: 3: {tx: Tx: - Tx 931292a9b68b1bdee499b71141fa94417e64a913f79a1fb61d4c15dfb1d5b462: + Tx 52baec4f0dd2c246a86477246de00df52cbe1ba95b2a8e186d91086ebd75f2e2: {inputs: outputs: - Value {getValue = Map {unMap = [(,Map {unMap = [(,10)]})]}} addressed to - ScriptAddress: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + ScriptAddress: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 forge: Value {getValue = Map {unMap = []}} fee: Value {getValue = Map {unMap = []}} mps: @@ -94,7 +94,7 @@ Events by wallet: Response: ( 3 , {tx: - WriteTxSuccess: eadd62c687f18e6c30283f5318b269eba5d7664c99cd335830fb529ef49371f1} ) + WriteTxSuccess: 88f5f7103105159edf2b7cf41a7fb07a36e18b29b94e7af3c3f6719b760fe4e3} ) Events for W3: - Iteration: 1 Requests: @@ -120,11 +120,11 @@ Events by wallet: Requests: 3: {tx: Tx: - Tx f4a42eb1af418352fd883c4537c0c45f5457cdeab81550ea94d41c9af52eeeca: + Tx 344f2d1d3fd79f9d3565656cf2aa2ef418f27d487d2146cbed3f1125aab4536d: {inputs: outputs: - Value {getValue = Map {unMap = [(,Map {unMap = [(,10)]})]}} addressed to - ScriptAddress: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + ScriptAddress: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 forge: Value {getValue = Map {unMap = []}} fee: Value {getValue = Map {unMap = []}} mps: @@ -136,7 +136,7 @@ Events by wallet: Response: ( 3 , {tx: - WriteTxSuccess: a9df1faa344fb4a6c326cf14bf7b5b97a1edffae940ba84c00e5c65c0a245433} ) + WriteTxSuccess: 1c7f3a99fd9ce160b72bfcaa6201a31ee54cfdb8ced477df9555a0a9509b31b3} ) Events for W4: - Iteration: 1 Requests: @@ -162,11 +162,11 @@ Events by wallet: Requests: 3: {tx: Tx: - Tx ab7bddbefe201497bbfd6d321bad7828ebdc86abbf41cb5019672cf253cd7b36: + Tx 727c15744945b987236969f640244b15a297b1e83a06f1f5adf92a290684b5a9: {inputs: outputs: - Value {getValue = Map {unMap = [(,Map {unMap = [(,1)]})]}} addressed to - ScriptAddress: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + ScriptAddress: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 forge: Value {getValue = Map {unMap = []}} fee: Value {getValue = Map {unMap = []}} mps: @@ -178,7 +178,7 @@ Events by wallet: Response: ( 3 , {tx: - WriteTxSuccess: c811f9a55d3220377df1d4b16ae2fa256b060f60e6572509d97fdb5afcd33605} ) + WriteTxSuccess: 37d9fc96c3ffee49b5aeb980b1643bf3e648c0f2f6b0e1da3ef6bb6e58379b14} ) Contract result by wallet: Wallet: W1 Done diff --git a/plutus-use-cases/test/Spec/renderCrowdfunding.txt b/plutus-use-cases/test/Spec/renderCrowdfunding.txt index cf5258a372b..66ec416b8aa 100644 --- a/plutus-use-cases/test/Spec/renderCrowdfunding.txt +++ b/plutus-use-cases/test/Spec/renderCrowdfunding.txt @@ -101,11 +101,11 @@ Balances Carried Forward: Ada: Lovelace: 10000 ==== Slot #1, Tx #0 ==== -TxId: eadd62c687f18e6c30283f5318b269eba5d7664c99cd335830fb529ef49371f1 +TxId: 88f5f7103105159edf2b7cf41a7fb07a36e18b29b94e7af3c3f6719b760fe4e3 Fee: - Forge: - Signatures PubKey: fc51cd8e6218a1a38da47ed00230f0580816ed13... - Signature: 5f582085f7c6ee2ae57d989ef2e58b5a6b6551c1... + Signature: 5f5820a4b37730a972daf4ba32583ba6301673f5... Inputs: ---- Input 0 ---- Destination: PubKeyHash: 03d200a81ee0feace8fb845e5ec950a6f9add837... (Wallet 2) @@ -124,7 +124,7 @@ Outputs: Ada: Lovelace: 9990 ---- Output 1 ---- - Destination: Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Destination: Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 10 @@ -170,16 +170,16 @@ Balances Carried Forward: Value: Ada: Lovelace: 10000 - Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 10 ==== Slot #2, Tx #0 ==== -TxId: a9df1faa344fb4a6c326cf14bf7b5b97a1edffae940ba84c00e5c65c0a245433 +TxId: 1c7f3a99fd9ce160b72bfcaa6201a31ee54cfdb8ced477df9555a0a9509b31b3 Fee: - Forge: - Signatures PubKey: 98a5e3a36e67aaba89888bf093de1ad963e77401... - Signature: 5f58205d705e40c00cfa8319a7880fa0cf9cc39f... + Signature: 5f58202a192124cfa5f9dd8c80336ca51df427fe... Inputs: ---- Input 0 ---- Destination: PubKeyHash: feb345e86b9c2a7add2bfc695fa8aecd4ac5b0df... (Wallet 3) @@ -198,7 +198,7 @@ Outputs: Ada: Lovelace: 9990 ---- Output 1 ---- - Destination: Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Destination: Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 10 @@ -244,16 +244,16 @@ Balances Carried Forward: Value: Ada: Lovelace: 9990 - Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 20 ==== Slot #3, Tx #0 ==== -TxId: c811f9a55d3220377df1d4b16ae2fa256b060f60e6572509d97fdb5afcd33605 +TxId: 37d9fc96c3ffee49b5aeb980b1643bf3e648c0f2f6b0e1da3ef6bb6e58379b14 Fee: - Forge: - Signatures PubKey: f81fb54a825fced95eb033afcd64314075abfb0a... - Signature: 5f5820cd59400b21792ebd9d93f4f9ab3fc3675e... + Signature: 5f5820d82763e995b6b979e896b5761a7e786fda... Inputs: ---- Input 0 ---- Destination: PubKeyHash: 5aebc31421e7af1bdb47326709c27f3fd9381b00... (Wallet 4) @@ -272,7 +272,7 @@ Outputs: Ada: Lovelace: 9999 ---- Output 1 ---- - Destination: Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Destination: Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 1 @@ -318,43 +318,43 @@ Balances Carried Forward: Value: Ada: Lovelace: 9990 - Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 21 ==== Slot #20, Tx #0 ==== -TxId: 4d18d295930d525fa415486ae492aad245eccc26b733d06f6c150a12ec7a7857 +TxId: bcb5bebcafa63d1ac85fefed9d7f086041e3b7596cff3bd8ac832a2c01c153af Fee: - Forge: - Signatures PubKey: 3d4017c3e843895a92b70aa74d1b7ebc9c982ccf... - Signature: 5f58204aa94509801983c2b6f8af43f52885903f... + Signature: 5f5820723b691997de04c5687c9bbfdaed4e29d6... Inputs: ---- Input 0 ---- - Destination: Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Destination: Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 10 Source: - Tx: a9df1faa344fb4a6c326cf14bf7b5b97a1edffae940ba84c00e5c65c0a245433 + Tx: 1c7f3a99fd9ce160b72bfcaa6201a31ee54cfdb8ced477df9555a0a9509b31b3 Output #1 - Script: 01000003030264666978311829036161182a0003... + Script: 0100000303026466697831182903030305010267... ---- Input 1 ---- - Destination: Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Destination: Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 1 Source: - Tx: c811f9a55d3220377df1d4b16ae2fa256b060f60e6572509d97fdb5afcd33605 + Tx: 37d9fc96c3ffee49b5aeb980b1643bf3e648c0f2f6b0e1da3ef6bb6e58379b14 Output #1 - Script: 01000003030264666978311829036161182a0003... + Script: 0100000303026466697831182903030305010267... ---- Input 2 ---- - Destination: Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Destination: Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 10 Source: - Tx: eadd62c687f18e6c30283f5318b269eba5d7664c99cd335830fb529ef49371f1 + Tx: 88f5f7103105159edf2b7cf41a7fb07a36e18b29b94e7af3c3f6719b760fe4e3 Output #1 - Script: 01000003030264666978311829036161182a0003... + Script: 0100000303026466697831182903030305010267... Outputs: @@ -405,6 +405,6 @@ Balances Carried Forward: Value: Ada: Lovelace: 9990 - Script: 341a0bbb1c806a631096906013213f66c6b0efc0077db79d1272d1ab135babc8 + Script: 3af10d1b7897316845ce650f33dd2d1d943356d7860abd08b721396c6669f8a4 Value: Ada: Lovelace: 0 \ No newline at end of file diff --git a/plutus-use-cases/test/Spec/renderGuess.txt b/plutus-use-cases/test/Spec/renderGuess.txt index 3c1d9c485ae..94bf8612181 100644 --- a/plutus-use-cases/test/Spec/renderGuess.txt +++ b/plutus-use-cases/test/Spec/renderGuess.txt @@ -101,11 +101,11 @@ Balances Carried Forward: Ada: Lovelace: 10000 ==== Slot #1, Tx #0 ==== -TxId: b2de8f6bd31d94387f29318ecfc90dcba6eafba43a7b19a71640ba06b97c3f7f +TxId: a0e57b223d92c0ef77fbd8672f1abd0cf5ce0d9c86e8cd17ae2f4dbe33ce217b Fee: - Forge: - Signatures PubKey: 3d4017c3e843895a92b70aa74d1b7ebc9c982ccf... - Signature: 5f582002c06b31d9d8a3e5d6a564eab3188df1ae... + Signature: 5f58208c1446ff898c1dea8b8e3f246de93cb83d... Inputs: ---- Input 0 ---- Destination: PubKeyHash: 2721f657e9ed91d2fc2a282f7ff5ed81ae48f48b... (Wallet 1) @@ -124,7 +124,7 @@ Outputs: Ada: Lovelace: 9990 ---- Output 1 ---- - Destination: Script: 24e42aaa59d60b5523a3a19b5e0cb98c6389da21a6c775e42c24909ed9fe06b6 + Destination: Script: fec788f28d901e2aaefb8bb55bef113323047083ba3df652674fa5844a7f317f Value: Ada: Lovelace: 10 @@ -170,25 +170,25 @@ Balances Carried Forward: Value: Ada: Lovelace: 10000 - Script: 24e42aaa59d60b5523a3a19b5e0cb98c6389da21a6c775e42c24909ed9fe06b6 + Script: fec788f28d901e2aaefb8bb55bef113323047083ba3df652674fa5844a7f317f Value: Ada: Lovelace: 10 ==== Slot #2, Tx #0 ==== -TxId: 3f4576498b7b0f587e68523235e66b62af0b282a8a06c126acf5f31f748b39f7 +TxId: 7795bbf711693bab674d4ad3dfbcb85c545e71ae6f41d1f7749bccb995632478 Fee: - Forge: - Signatures PubKey: fc51cd8e6218a1a38da47ed00230f0580816ed13... - Signature: 5f5820eac28e6d4500c43cf7204489b2c7be638d... + Signature: 5f58208cb9b632fe1375145b0180098f45b445f5... Inputs: ---- Input 0 ---- - Destination: Script: 24e42aaa59d60b5523a3a19b5e0cb98c6389da21a6c775e42c24909ed9fe06b6 + Destination: Script: fec788f28d901e2aaefb8bb55bef113323047083ba3df652674fa5844a7f317f Value: Ada: Lovelace: 10 Source: - Tx: b2de8f6bd31d94387f29318ecfc90dcba6eafba43a7b19a71640ba06b97c3f7f + Tx: a0e57b223d92c0ef77fbd8672f1abd0cf5ce0d9c86e8cd17ae2f4dbe33ce217b Output #1 - Script: 01000003030264666978311829036161182a0003... + Script: 0100000303026466697831182903030501026455... Outputs: @@ -239,6 +239,6 @@ Balances Carried Forward: Value: Ada: Lovelace: 10000 - Script: 24e42aaa59d60b5523a3a19b5e0cb98c6389da21a6c775e42c24909ed9fe06b6 + Script: fec788f28d901e2aaefb8bb55bef113323047083ba3df652674fa5844a7f317f Value: Ada: Lovelace: 0 \ No newline at end of file diff --git a/plutus-use-cases/test/Spec/renderVesting.txt b/plutus-use-cases/test/Spec/renderVesting.txt index 6939323f5e6..d00d05bee36 100644 --- a/plutus-use-cases/test/Spec/renderVesting.txt +++ b/plutus-use-cases/test/Spec/renderVesting.txt @@ -101,11 +101,11 @@ Balances Carried Forward: Ada: Lovelace: 10000 ==== Slot #1, Tx #0 ==== -TxId: b0ef53e817d637923ef6e0f7cf1af6a537929cd9ba35e6e26dcfb6e931bceec0 +TxId: af686f89e87cad4e67a58ed91c01ce220e3b9d8130317a1ee224f6c5f514d018 Fee: - Forge: - Signatures PubKey: fc51cd8e6218a1a38da47ed00230f0580816ed13... - Signature: 5f5820732c88b56f57e1a294c504021a5953a572... + Signature: 5f58207b32921a9f156ed973dd03608b58b96605... Inputs: ---- Input 0 ---- Destination: PubKeyHash: 03d200a81ee0feace8fb845e5ec950a6f9add837... (Wallet 2) @@ -124,7 +124,7 @@ Outputs: Ada: Lovelace: 9940 ---- Output 1 ---- - Destination: Script: ef242ba23ef9ea6a0f0ef8d86ff9dccd64a0631dd9989fb51d2fe5fc4bca61c5 + Destination: Script: 75f4d28b67521d49c3443373d48ee8fe8b4430242bfbd91d478119f1537a2e4f Value: Ada: Lovelace: 60 @@ -170,25 +170,25 @@ Balances Carried Forward: Value: Ada: Lovelace: 10000 - Script: ef242ba23ef9ea6a0f0ef8d86ff9dccd64a0631dd9989fb51d2fe5fc4bca61c5 + Script: 75f4d28b67521d49c3443373d48ee8fe8b4430242bfbd91d478119f1537a2e4f Value: Ada: Lovelace: 60 ==== Slot #12, Tx #0 ==== -TxId: 39f41e2518aaf58d12a200ca7d3825d5dca8853979d3bba22bdb10c81f2e8d81 +TxId: c1b55c4b4100e65b3388f7114f2bac69c5dc5b6084bd0cec39c9ea5d15e125d3 Fee: - Forge: - Signatures PubKey: 3d4017c3e843895a92b70aa74d1b7ebc9c982ccf... - Signature: 5f5820fdcf3dc67670dadfde9737f195ccfd29ec... + Signature: 5f58203c5903a4a3e9ab4e6cc029e185461686fd... Inputs: ---- Input 0 ---- - Destination: Script: ef242ba23ef9ea6a0f0ef8d86ff9dccd64a0631dd9989fb51d2fe5fc4bca61c5 + Destination: Script: 75f4d28b67521d49c3443373d48ee8fe8b4430242bfbd91d478119f1537a2e4f Value: Ada: Lovelace: 60 Source: - Tx: b0ef53e817d637923ef6e0f7cf1af6a537929cd9ba35e6e26dcfb6e931bceec0 + Tx: af686f89e87cad4e67a58ed91c01ce220e3b9d8130317a1ee224f6c5f514d018 Output #1 - Script: 01000003030264666978311829036161182a0003... + Script: 0100000303026466697831182903030305010264... Outputs: @@ -198,7 +198,7 @@ Outputs: Ada: Lovelace: 10 ---- Output 1 ---- - Destination: Script: ef242ba23ef9ea6a0f0ef8d86ff9dccd64a0631dd9989fb51d2fe5fc4bca61c5 + Destination: Script: 75f4d28b67521d49c3443373d48ee8fe8b4430242bfbd91d478119f1537a2e4f Value: Ada: Lovelace: 50 @@ -244,6 +244,6 @@ Balances Carried Forward: Value: Ada: Lovelace: 10000 - Script: ef242ba23ef9ea6a0f0ef8d86ff9dccd64a0631dd9989fb51d2fe5fc4bca61c5 + Script: 75f4d28b67521d49c3443373d48ee8fe8b4430242bfbd91d478119f1537a2e4f Value: Ada: Lovelace: 50 \ No newline at end of file