SCP-2973: Switch CEK to NamedDeBruijn, keeping test interface unchanged

.hlint.yaml

@@ -23,3 +23,5 @@
 - fixity: infixr 3 ***
 - fixity: infixr 3 &&&
 - fixity: infixr 1 <=<
+# first is too lazy, see:  https://github.com/input-output-hk/plutus/issues/3876
+- ignore: {name: Use first, within: [UntypedPlutusCore.Evaluation.Machine.Cek]}

plutus-benchmark/cek-calibration/Main.hs

@@ -24,6 +24,7 @@ import UntypedPlutusCore as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek
 
 import Control.Exception
+import Control.Lens
 import Control.Monad.Except
 import Criterion.Main
 import Criterion.Types qualified as C
@@ -80,7 +81,7 @@ mkListBMs ns = bgroup "List" [mkListBM n | n <- ns]
 
 writePlc :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun () -> Haskell.IO ()
 writePlc p =
-    case runExcept @UPLC.FreeVariableError $ runQuoteT $ UPLC.unDeBruijnProgram p of
+    case runExcept @UPLC.FreeVariableError $ runQuoteT $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p of
       Left e   -> throw e
       Right p' -> Haskell.print . PP.prettyPlcClassicDebug $ p'
 

plutus-benchmark/plutus-benchmark.cabal

@@ -248,3 +248,4 @@ benchmark cek-calibration
       , plutus-tx-plugin -any
       , criterion >= 1.5.9.0
       , mtl -any
+      , lens -any

plutus-benchmark/validation/Bench.hs

@@ -79,7 +79,7 @@ loadFlat file = do
   case unflat contents of
     Left e  -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ file ++ ": " ++ show e
     Right prog -> do
-        let t = unDeBruijnAnonTerm $ UPLC.toTerm prog
+        let t = unDeBruijnAnonTerm $ UPLC._progTerm prog
         return $! force t
         -- `force` to try to ensure that deserialiation is not included in benchmarking time.
 

plutus-core/common/PlcTestUtils.hs

@@ -57,7 +57,7 @@ import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC
 
 import Control.Exception
-import Control.Lens.Combinators (_2)
+import Control.Lens
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.State
@@ -112,7 +112,7 @@ instance ToUPlc (UPLC.Program TPLC.Name uni fun ()) uni fun where
     toUPlc = pure
 
 instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun ()) uni fun where
-    toUPlc p = withExceptT @_ @FreeVariableError toException $ TPLC.runQuoteT $ UPLC.unDeBruijnProgram p
+    toUPlc p = withExceptT @_ @FreeVariableError toException $ TPLC.runQuoteT $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p
 
 pureTry :: Exception e => a -> Either e a
 pureTry = unsafePerformIO . try . evaluate
@@ -180,28 +180,28 @@ goldenTPlc
     => String -> a -> TestNested
 goldenTPlc name value = nestedGoldenVsDocM name $ ppThrow $ do
     p <- toTPlc value
-    withExceptT @_ @FreeVariableError toException $ deBruijnProgram p
+    withExceptT @_ @FreeVariableError toException $ traverseOf TPLC.progTerm deBruijnTerm p
 
 goldenTPlcCatch
     :: ToTPlc a DefaultUni TPLC.DefaultFun
     => String -> a -> TestNested
 goldenTPlcCatch name value = nestedGoldenVsDocM name $ ppCatch $ do
     p <- toTPlc value
-    withExceptT @_ @FreeVariableError toException $ deBruijnProgram p
+    withExceptT @_ @FreeVariableError toException $ traverseOf TPLC.progTerm deBruijnTerm p
 
 goldenUPlc
     :: ToUPlc a DefaultUni TPLC.DefaultFun
      => String -> a -> TestNested
 goldenUPlc name value = nestedGoldenVsDocM name $ ppThrow $ do
     p <- toUPlc value
-    withExceptT @_ @FreeVariableError toException $ UPLC.deBruijnProgram p
+    withExceptT @_ @FreeVariableError toException $ traverseOf UPLC.progTerm UPLC.deBruijnTerm p
 
 goldenUPlcCatch
     :: ToUPlc a DefaultUni TPLC.DefaultFun
     => String -> a -> TestNested
 goldenUPlcCatch name value = nestedGoldenVsDocM name $ ppCatch $ do
     p <- toUPlc value
-    withExceptT @_ @FreeVariableError toException $ UPLC.deBruijnProgram p
+    withExceptT @_ @FreeVariableError toException $ traverseOf UPLC.progTerm UPLC.deBruijnTerm p
 
 goldenTEval
     :: ToTPlc a DefaultUni TPLC.DefaultFun

plutus-core/executables/Common.hs

@@ -29,6 +29,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek
 import UntypedPlutusCore.Parser qualified as UPLC (parseProgram)
 
 import Control.DeepSeq (NFData, rnf)
+import Control.Lens hiding (ix)
 import Control.Monad.Except
 import Data.Bifunctor (second)
 import Data.ByteString.Lazy qualified as BSL
@@ -106,7 +107,7 @@ typedDeBruijnNotSupportedError =
 -- | Convert an untyped program to one where the 'name' type is de Bruijn indices.
 toDeBruijn :: UplcProg b -> IO (UPLC.Program UPLC.DeBruijn PLC.DefaultUni PLC.DefaultFun b)
 toDeBruijn prog =
-  case runExcept @UPLC.FreeVariableError (UPLC.deBruijnProgram prog) of
+  case runExcept @UPLC.FreeVariableError $ traverseOf UPLC.progTerm UPLC.deBruijnTerm prog of
     Left e  -> errorWithoutStackTrace $ show e
     Right p -> return $ UPLC.programMapNames (\(UPLC.NamedDeBruijn _ ix) -> UPLC.DeBruijn ix) p
 
@@ -225,7 +226,7 @@ instance Show Format where
 
 data ConvertOptions   = ConvertOptions Input Format Output Format PrintMode
 data PrintOptions     = PrintOptions Input PrintMode
-data ExampleOptions   = ExampleOptions ExampleMode
+newtype ExampleOptions   = ExampleOptions ExampleMode
 data ApplyOptions     = ApplyOptions Files Format Output Format PrintMode
 
 helpText ::
@@ -296,7 +297,7 @@ type UntypedProgramDeBruijn a = UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni P
 -- with a Unique for disambiguation).  Again, we don't support typed programs.
 fromDeBruijn :: UntypedProgramDeBruijn a -> IO (UplcProg a)
 fromDeBruijn prog = do
-    case PLC.runQuote $ runExceptT @UPLC.FreeVariableError $ UPLC.unDeBruijnProgram prog of
+    case PLC.runQuote $ runExceptT @UPLC.FreeVariableError $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm prog of
       Left e  -> errorWithoutStackTrace $ show e
       Right p -> return p
 
@@ -320,7 +321,7 @@ loadUplcASTfromFlat flatMode inp = do
          Named    -> handleResult $ unflat input
          DeBruijn -> do
              deserialised <- handleResult $ unflat input
-             let namedProgram = UPLC.programMapNames (\(UPLC.DeBruijn ix) -> UPLC.NamedDeBruijn "v" ix) deserialised
+             let namedProgram = UPLC.programMapNames UPLC.fakeNameDeBruijn deserialised
              fromDeBruijn namedProgram
          NamedDeBruijn -> do
              deserialised <- handleResult $ unflat input

plutus-core/executables/plc/Main.hs

@@ -11,11 +11,11 @@ import PlutusCore.Pretty qualified as PP
 
 import UntypedPlutusCore qualified as UPLC (eraseProgram)
 
-import Data.Function ((&))
 import Data.Functor (void)
 import Data.Text.IO qualified as T
 
 import Control.DeepSeq (rnf)
+import Control.Lens
 import Options.Applicative
 import System.Exit (exitSuccess)
 
@@ -121,7 +121,7 @@ runEval :: EvalOptions -> IO ()
 runEval (EvalOptions inp ifmt printMode timingMode) = do
   prog <- getProgram ifmt inp
   let evaluate = Ck.evaluateCkNoEmit PLC.defaultBuiltinsRuntime
-      term = void . PLC.toTerm $ prog
+      term = void $ prog ^. PLC.progTerm
       !_ = rnf term
       -- Force evaluation of body to ensure that we're not timing parsing/deserialisation.
       -- The parser apparently returns a fully-evaluated AST, but let's be on the safe side.

plutus-core/executables/uplc/Main.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedStrings         #-}
 {-# LANGUAGE PartialTypeSignatures     #-}
 {-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE TypeApplications          #-}
 
 module Main (main) where
 
@@ -16,7 +17,6 @@ import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..))
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as BSL
 import Data.Foldable (asum)
-import Data.Functor (void)
 import Data.List (nub)
 import Data.List.Split (splitOn)
 import Data.Maybe (fromJust)
@@ -25,6 +25,9 @@ import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek
 
 import Control.DeepSeq (NFData, rnf)
+import Control.Lens
+import Control.Monad.Except
+import Data.Either
 import Data.Text qualified as T
 import Options.Applicative
 import System.Exit (exitFailure)
@@ -157,7 +160,7 @@ runApply :: ApplyOptions -> IO ()
 runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do
   scripts <- mapM ((getProgram ifmt ::  Input -> IO (UplcProg PLC.AlexPosn)) . FileInput) inputfiles
   let appliedScript =
-        case map (\case p -> () <$ p) scripts of
+        case void <$> scripts of
           []          -> errorWithoutStackTrace "No input files"
           progAndargs -> foldl1 UPLC.applyProgram progAndargs
   writeProgram outp ofmt mode appliedScript
@@ -167,7 +170,7 @@ runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do
 runEval :: EvalOptions -> IO ()
 runEval (EvalOptions inp ifmt printMode budgetMode traceMode outputMode timingMode cekModel) = do
     prog <- getProgram ifmt inp
-    let term = void . UPLC.toTerm $ prog
+    let term = void $ prog ^. UPLC.progTerm
         !_ = rnf term
         cekparams = case cekModel of
                     Default -> PLC.defaultCekParameters  -- AST nodes are charged according to the default cost model
@@ -185,7 +188,7 @@ runEval (EvalOptions inp ifmt printMode budgetMode traceMode outputMode timingMo
     case budgetM of
         SomeBudgetMode bm -> evalWithTiming term >>= handleResults term
             where
-                evaluate = Cek.runCek cekparams bm emitM
+                evaluate = Cek.runCek cekparams bm emitM . fromRight (error "input contains free variables") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm
                 evalWithTiming t = case timingMode of
                         NoTiming -> pure $ evaluate t
                         Timing n -> do
@@ -194,7 +197,7 @@ runEval (EvalOptions inp ifmt printMode budgetMode traceMode outputMode timingMo
                                 [a] -> pure a
                                 _   -> error "Timing evaluations returned inconsistent results"
                 handleResults t (res, budget, logs) = do
-                    case res of
+                    case Cek.unDeBruijnResult res of
                         Left err -> hPrint stderr err >> exitFailure
                         Right v  -> writeToFileOrStd outputMode (show (getPrintMethod printMode v))
                     case budgetMode of

plutus-core/index-envs/src/Data/DeBruijnEnv.hs

@@ -39,6 +39,7 @@ instance DeBruijnEnv (BRAL.RAList a) where
 
 -- | A sequence implemented by a map from "levels" to values and a counter giving the "current" level.
 data RelativizedMap a = RelativizedMap (IM.IntMap a) {-# UNPACK #-} !Int
+    deriving Show
 
 instance DeBruijnEnv (RelativizedMap a) where
     type Element (RelativizedMap a) = a

plutus-core/plutus-core.cabal

@@ -320,7 +320,8 @@ library
         unordered-containers -any,
         witherable -any,
         word-array -any,
-        cardano-crypto-class -any
+        cardano-crypto-class -any,
+        index-envs
 
 test-suite satint-test
   import: lang
@@ -447,7 +448,8 @@ executable plc
         optparse-applicative -any,
         prettyprinter -any,
         text -any,
-        transformers -any
+        transformers -any,
+        lens -any
 
 executable uplc
     import: lang
@@ -469,7 +471,8 @@ executable uplc
         prettyprinter -any,
         split -any,
         text -any,
-        transformers -any
+        transformers -any,
+        lens -any
 
 executable pir
     import: lang

plutus-core/plutus-core/src/PlutusCore.hs

@@ -55,7 +55,6 @@ module PlutusCore
     , Normalized (..)
     , defaultVersion
     , allKeywords
-    , toTerm
     , termAnn
     , typeAnn
     , tyVarDeclAnn
@@ -67,13 +66,14 @@ module PlutusCore
     , tyDeclAnn
     , tyDeclType
     , tyDeclKind
+    , progAnn
+    , progVer
+    , progTerm
     , mapFun
     -- * DeBruijn representation
     , DeBruijn (..)
     , NamedDeBruijn (..)
-    , deBruijnProgram
     , deBruijnTerm
-    , unDeBruijnProgram
     , unDeBruijnTerm
     -- * Lexer
     , AlexPosn (..)

plutus-core/plutus-core/src/PlutusCore/Core/Instance.hs

@@ -1,6 +1,6 @@
 module PlutusCore.Core.Instance (module Export) where
 
-import PlutusCore.Core.Instance.Eq as Export
+import PlutusCore.Core.Instance.Eq ()
 import PlutusCore.Core.Instance.Pretty ()
 import PlutusCore.Core.Instance.Recursive as Export
 import PlutusCore.Core.Instance.Scoping ()