Debugging. Log empty atm.

IntersectMBO · Sep 13, 2021 · 34f5b97 · 34f5b97
1 parent 0b10020
commit 34f5b97
Show file tree

Hide file tree

Showing 4 changed files with 18 additions and 40 deletions.
diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-tx-plugin.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-tx-plugin.nix
diff --git a/plutus-core/common/PlcTestUtils.hs b/plutus-core/common/PlcTestUtils.hs
@@ -56,9 +56,11 @@ import qualified UntypedPlutusCore.Evaluation.Machine.Cek             as UPLC
 import           UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode (logWithTimeEmitter)
 
 import           Control.Exception
+import           Control.Lens.Combinators                             (_2)
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Control.Monad.State
+import           Data.Text                                            (Text)
 import qualified Data.Text.Prettyprint.Doc                            as PP
 import           Hedgehog
 import           System.IO.Unsafe
@@ -138,20 +140,18 @@ runUPlc values = do
     let (UPLC.Program _ _ t) = foldl1 UPLC.applyProgram ps
     liftEither $ first toException $ TPLC.extractEvaluationResult $ UPLC.evaluateCekNoEmit TPLC.defaultCekParameters t
 
-runUPlcProfile :: (Traversable t, ToUPlc a DefaultUni UPLC.DefaultFun) =>
-    t a
+runUPlcProfile :: ToUPlc a DefaultUni UPLC.DefaultFun =>
+    [a]
     -> ExceptT
      SomeException
      IO
-     (UPLC.EvaluationResult
-        (UPLC.Term UPLC.Name DefaultUni UPLC.DefaultFun ()))
+     (UPLC.Term UPLC.Name DefaultUni UPLC.DefaultFun (), [Text])
 runUPlcProfile values = do
     ps <- traverse toUPlc values
     let (UPLC.Program _ _ t) = foldl1 UPLC.applyProgram ps
-    liftEither
-        $ first toException
-            $ TPLC.extractEvaluationResult
-                $ fst $ UPLC.evaluateCek logWithTimeEmitter TPLC.defaultCekParameters t
+        (result, logOut) = UPLC.evaluateCek logWithTimeEmitter TPLC.defaultCekParameters t
+    res <- either (throwError . SomeException) pure result
+    pure (res, logOut)
 
 ppCatch :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann)
 ppCatch value = either (PP.pretty . show) prettyPlcClassicDebug <$> runExceptT value
@@ -211,7 +211,7 @@ goldenUEvalCatch name values = nestedGoldenVsDocM name $ ppCatch $ runUPlc value
 goldenUEvalProfile
     :: ToUPlc a DefaultUni TPLC.DefaultFun
     => String -> [a] -> TestNested
-goldenUEvalProfile name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runUPlcProfile values)
+goldenUEvalProfile name values = nestedGoldenVsDocM name $ pretty . view _2 <$> (rethrow $ runUPlcProfile values)
 
 -- See Note [Marking].
 -- | A version of 'RenameT' that fails to take free variables into account.

diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs
@@ -1,8 +1,10 @@
 -- | The API to the CEK machine.
 
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators    #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+{-# LANGUAGE OverloadedStrings #-}
 
 module UntypedPlutusCore.Evaluation.Machine.Cek
     (
@@ -113,7 +115,7 @@ evaluateCek
     -> (Either (CekEvaluationException uni fun) (Term Name uni fun ()), [Text])
 evaluateCek emitMode params term =
     case runCek params restrictingEnormous emitMode term of
-        (errOrRes, _, logs) -> (errOrRes, logs)
+         (errOrRes, _, logs) -> (errOrRes, "testing evaluateCek log empty" : logs)
 
 -- | Evaluate a term using the CEK machine with logging disabled.
 evaluateCekNoEmit

diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Profiling.hs b/plutus-tx-plugin/test/Plugin/Primitives/Profiling.hs
@@ -32,29 +32,13 @@ import           Data.Text                  (Text)
 import           GHC.Magic
 
 primitives :: TestNested
-primitives = testNested "Primitives" [
-    goldenPir "string" string
-  , goldenPir "int" int
-  , goldenPir "int2" int2
-  , goldenPir "bool" bool
-  , goldenPir "and" andPlc
-  , goldenUEvalProfile "andApply" [ toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False ]
-  , goldenPir "tuple" tuple
-  , goldenPir "tupleMatch" tupleMatch
+primitives = testNested "Primitives with profiling" [
+  goldenUEvalProfile "andApply" [ toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False ]
   , goldenUEvalProfile "tupleConstDest" [ toUPlc tupleMatch, toUPlc tuple ]
-  , goldenPir "intCompare" intCompare
-  , goldenPir "intEq" intEq
   , goldenUEvalProfile "intEqApply" [ toUPlc intEq, toUPlc int, toUPlc int ]
-  , goldenPir "void" void
-  , goldenPir "intPlus" intPlus
-  , goldenPir "intDiv" intDiv
   , goldenUEvalProfile "intPlusApply" [ toUPlc intPlus, toUPlc int, toUPlc int2 ]
-  , goldenPir "error" errorPlc
-  , goldenPir "ifThenElse" ifThenElse
   , goldenUEvalProfile "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ]
-  , goldenPir "emptyByteString" emptyByteString
   , goldenUEvalProfile "emptyByteStringApply" [ getPlc emptyByteString, liftProgram Builtins.emptyByteString ]
-  , goldenPir "bytestring" bytestring
   , goldenUEvalProfile "bytestringApply" [ getPlc bytestring, liftProgram ("hello" ::Builtins.BuiltinByteString) ]
   , goldenUEvalProfile "sha2_256" [ getPlc sha2, liftProgram ("hello" :: Builtins.BuiltinByteString)]
   , goldenUEvalProfile "equalsByteString" [ getPlc bsEquals, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram ("hello" :: Builtins.BuiltinByteString)]
@@ -63,20 +47,11 @@ primitives = testNested "Primitives" [
   , goldenUEvalProfile "lengthOfByteString" [ getPlc bsLength, liftProgram ("hello" :: Builtins.BuiltinByteString)]
   , goldenUEvalProfile "indexByteString" [ getPlc bsIndex, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram (0 :: Integer)]
   , goldenUEvalProfile "consByteString" [ getPlc bsCons, liftProgram (104 :: Integer), liftProgram ("ello" :: Builtins.BuiltinByteString)]
-  , goldenPir "verify" verify
-  , goldenPir "trace" trace
-  , goldenPir "traceComplex" traceComplex
-  , goldenPir "stringLiteral" stringLiteral
   , goldenUEvalProfile "equalsString" [ getPlc stringEquals, liftProgram ("hello" :: Builtins.BuiltinString), liftProgram ("hello" :: Builtins.BuiltinString)]
-  , goldenPir "encodeUtf8" stringEncode
   , goldenUEvalProfile "constructData1" [ constructData1 ]
-  -- It's interesting to look at one of these to make sure all the specialisation is working out nicely and for
-  -- debugging when it isn't
-  , goldenPir "deconstructorData1" deconstructData1
   -- Check that matchData works (and isn't too strict)
   , goldenUEvalProfile "matchData1" [ toUPlc matchData1, toUPlc constructData1 ]
   , goldenUEvalProfile "deconstructData1" [ toUPlc deconstructData1, toUPlc constructData1 ]
-  , goldenPir "deconstructorData2" deconstructData2
   , goldenUEvalProfile "deconstructData2" [ toUPlc deconstructData2, toUPlc constructData2 ]
   , goldenUEvalProfile "deconstructData3" [ toUPlc deconstructData3, toUPlc constructData3 ]
   ]