Test case demostrates that CaseOfCase UPLC transform doesn't preserve…

… program semantics.
IntersectMBO · May 7, 2024 · ea8c8c3 · ea8c8c3
1 parent ea4050a
commit ea8c8c3
Showing 1 changed file with 47 additions and 5 deletions.
diff --git a/plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs b/plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs
@@ -1,15 +1,27 @@
+{-# LANGUAGE BlockArguments    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 
 module Transform.CaseOfCase.Test where
 
 import Data.Vector qualified as V
 import PlutusCore qualified as PLC
+import PlutusCore.Evaluation.Machine.BuiltinCostModel (BuiltinCostModel)
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel,
+                                                          defaultCekMachineCosts)
+import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..), MachineParameters,
+                                                        mkMachineParameters)
 import PlutusCore.MkPlc (mkConstant, mkIterApp)
-import PlutusCore.Quote (freshName, runQuote)
+import PlutusCore.Quote (freshName, runQuote, runQuoteT)
+import PlutusPrelude (Default (def))
 import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
 import Transform.Simplify.Lib (goldenVsSimplified)
-import UntypedPlutusCore (Name, Term (..))
+import UntypedPlutusCore (DefaultFun, DefaultUni, Name, Term (..), defaultSimplifyOpts,
+                          simplifyTerm)
+import UntypedPlutusCore.Core qualified as UPLC
+import UntypedPlutusCore.Evaluation.Machine.Cek (CekMachineCosts, CekValue, EvaluationResult (..),
+                                                 noEmitter, unsafeEvaluateCek)
 
 test_caseOfCase :: TestTree
 test_caseOfCase =
@@ -18,10 +30,11 @@ test_caseOfCase =
     [ goldenVsSimplified "CaseOfCase/1" caseOfCase1
     , goldenVsSimplified "CaseOfCase/2" caseOfCase2
     , goldenVsSimplified "CaseOfCase/3" caseOfCase3
+    , caseOfCaseWithError
     ]
 
 caseOfCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun ()
-caseOfCase1 = runQuote $ do
+caseOfCase1 = runQuote do
   b <- freshName "b"
   let ite = Force () (Builtin () PLC.IfThenElse)
       true = Constr () 0 []
@@ -34,7 +47,7 @@ Unless both branches are known constructors, the case-of-case transformation
 may increase the program size.
 -}
 caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun ()
-caseOfCase2 = runQuote $ do
+caseOfCase2 = runQuote do
   b <- freshName "b"
   t <- freshName "t"
   let ite = Force () (Builtin () PLC.IfThenElse)
@@ -47,7 +60,7 @@ caseOfCase2 = runQuote $ do
 @[Integer]@ rather than Bool (note that @Constr 0@ has two parameters, @x@ and @xs@).
 -}
 caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun ()
-caseOfCase3 = runQuote $ do
+caseOfCase3 = runQuote do
   b <- freshName "b"
   x <- freshName "x"
   xs <- freshName "xs"
@@ -59,3 +72,32 @@ caseOfCase3 = runQuote $ do
       altFalse = mkConstant @Integer () 2
       alts = V.fromList [altTrue, altFalse]
   pure $ Case () (mkIterApp ite [((), Var () b), ((), true), ((), false)]) alts
+
+caseOfCaseWithError :: TestTree
+caseOfCaseWithError =
+  testCase "Transformation doesn't evaluate error eagerly" do
+    let
+      originalTerm =
+        Case
+          ()
+          ( mkIterApp
+              (Force () (Builtin () PLC.IfThenElse))
+              [ ((), mkConstant @Bool () True)
+              , ((), Constr () 0 []) -- True
+              , ((), Constr () 1 []) -- False
+              ]
+          )
+          (V.fromList [mkConstant @() () (), Error ()])
+    simplifiedTerm <- runQuoteT $ simplifyTerm defaultSimplifyOpts def originalTerm
+    evaluateUplc simplifiedTerm @?= evaluateUplc originalTerm
+
+evaluateUplc
+  :: UPLC.Term Name DefaultUni DefaultFun ()
+  -> EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ())
+evaluateUplc = fst <$> unsafeEvaluateCek noEmitter machineParameters
+ where
+  costModel :: CostModel CekMachineCosts BuiltinCostModel =
+    CostModel defaultCekMachineCosts defaultBuiltinCostModel
+  machineParameters
+    :: MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) =
+      mkMachineParameters def costModel