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

@@ -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

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,50 +72,86 @@ 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
 
 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

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 ""

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

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