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

@@ -34,6 +34,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, op)
 import Control.Monad.Except
 import Data.Aeson qualified as Aeson
 import Data.Bifunctor (second)
@@ -123,16 +124,16 @@ typedDeBruijnNotSupportedError =
 -- | Convert an untyped program to one where the 'name' type is de Bruijn indices.
 toDeBruijn :: UplcProg ann -> IO (UPLC.Program UPLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ann)
 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
 
 -- | Convert an untyped program to one where the 'name' type is textual names with de Bruijn indices.
 toNamedDeBruijn :: UplcProg ann -> IO (UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun ann)
 toNamedDeBruijn 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 v ix) -> UPLC.NamedDeBruijn v ix) p
+    Right p -> return p
 
 
 ---------------- Printing budgets and costs ----------------
@@ -249,7 +250,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 ::
@@ -320,7 +321,7 @@ type UntypedProgramDeBruijn ann = UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni
 -- with a Unique for disambiguation).  Again, we don't support typed programs.
 fromDeBruijn :: UntypedProgramDeBruijn ann -> IO (UplcProg ann)
 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
 
@@ -344,7 +345,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)
 
@@ -129,7 +129,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

@@ -21,6 +21,7 @@ import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek
 
 import Control.DeepSeq (NFData, rnf)
+import Control.Lens
 import Options.Applicative
 import System.Exit (exitFailure)
 import System.IO (hPrint, stderr)
@@ -35,7 +36,7 @@ uplcInfoCommand = plutus uplcHelpText
 data BudgetMode  = Silent
                  | Verbose SomeBudgetMode
 
-data SomeBudgetMode = forall cost. (Eq cost, NFData cost, PrintBudgetState cost) => SomeBudgetMode (Cek.ExBudgetMode cost PLC.DefaultUni PLC.DefaultFun)
+data SomeBudgetMode = forall cost. (Eq cost, NFData cost, PrintBudgetState cost, Monoid cost) => SomeBudgetMode (Cek.ExBudgetMode cost PLC.DefaultUni PLC.DefaultFun)
 
 data EvalOptions = EvalOptions Input Format PrintMode BudgetMode TraceMode Output TimingMode CekModel
 
@@ -156,7 +157,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
@@ -166,7 +167,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

plutus-core/generators/PlutusCore/Generators/NEAT/Spec.hs

@@ -254,7 +254,7 @@ data TestFail
   | AgdaErrorP ()
   | FVErrorP FreeVariableError
   | CkP (CkEvaluationException DefaultUni DefaultFun)
-  | UCekP (U.CekEvaluationException DefaultUni DefaultFun)
+  | UCekP (U.CekEvaluationException Name DefaultUni DefaultFun)
   | Ctrex Ctrex
 
 data Ctrex

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

@@ -38,17 +38,18 @@ instance DeBruijnEnv (BRAL.RAList a) where
     unsafeIndex = BRAL.index
 
 -- | 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
+data RelativizedMap a = RelativizedMap (IM.IntMap a) {-# UNPACK #-} !Word
+    deriving Show
 
 instance DeBruijnEnv (RelativizedMap a) where
     type Element (RelativizedMap a) = a
 
     {-# INLINABLE empty #-}
     empty = RelativizedMap mempty 0
     {-# INLINABLE cons #-}
-    cons a (RelativizedMap im l) = RelativizedMap (IM.insert l a im) (l+1)
+    cons a (RelativizedMap im l) = RelativizedMap (IM.insert (fromIntegral l) a im) (l+1)
     {-# INLINABLE index #-}
-    index (RelativizedMap im l) w = IM.lookup (l - fromIntegral w) im
+    index (RelativizedMap im l) w = IM.lookup (fromIntegral l - fromIntegral w) im
 
 instance DeBruijnEnv (RAL.RAList  a) where
     type Element (RAL.RAList a) = a

plutus-core/plutus-core.cabal

@@ -318,7 +318,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