Improve test infra for errors using expect, expect-that and expect-fa…

…ilure

pact-lsp/Pact/Core/LanguageServer.hs

@@ -231,7 +231,6 @@ setupAndProcessFile
           ,M.Map NormalizedUri  [EvalTopLevel ReplCoreBuiltin SpanInfo]))
 setupAndProcessFile nuri content = do
   pdb <- mockPactDb serialisePact_repl_spaninfo
-  gasLog <- newIORef Nothing
   let
     builtinMap = if isReplScript fp
                  then replBuiltinMap
@@ -242,7 +241,6 @@ setupAndProcessFile nuri content = do
       src = SourceCode (takeFileName fp) content
       rstate = ReplState
           { _replFlags = mempty
-          , _replEvalLog = gasLog
           , _replCurrSource = src
           , _replEvalEnv = ee
           , _replTx = Nothing
@@ -253,6 +251,7 @@ setupAndProcessFile nuri content = do
           -- Once this is possible, we can set it to `False` as is the default
           , _replNativesEnabled = True
           , _replOutputLine = const (pure ())
+          , _replTestResults = []
           }
   stateRef <- newIORef rstate
   res <- runReplT stateRef (processFile Repl.interpretEvalBigStep nuri content)

pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs

@@ -67,10 +67,27 @@ corePrint info b _env = \case
     return (VLiteral LUnit)
   args -> argsError info b args
 
+returnTestFailure
+  :: SpanInfo
+  -> Text
+  -> Text
+  -> EvalM ReplRuntime b SpanInfo (EvalValue ReplRuntime b SpanInfo)
+returnTestFailure info testName msg = do
+  recordTestFailure testName info msg
+  return (VLiteral (LString msg))
+
+returnTestSuccess
+  :: SpanInfo
+  -> Text
+  -> Text
+  -> EvalM ReplRuntime b SpanInfo (EvalValue ReplRuntime b SpanInfo)
+returnTestSuccess info testName msg = do
+  recordTestSuccess testName info
+  return (VString msg)
 
 coreExpect :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo
 coreExpect info b _env = \case
-  [VLiteral (LString msg), VClosure expected, VClosure provided] -> do
+  [VLiteral (LString testName), VClosure expected, VClosure provided] -> do
     es <- get
     tryError (applyLamUnsafe provided []) >>= \case
       Right (VPactValue v2) -> do
@@ -79,52 +96,56 @@ coreExpect info b _env = \case
             if v1 /= v2 then do
                 let v1s = prettyShowValue (VPactValue v1)
                     v2s = prettyShowValue (VPactValue v2)
-                return $ VLiteral $ LString $ "FAILURE: " <> msg <> " expected: " <> v1s <> ", received: " <> v2s
-            else return (VLiteral (LString ("Expect: success " <> msg)))
-      Right _v ->
-        throwUserRecoverableError info $ UserEnforceError "FAILURE: expect expression did not return a pact value for comparison"
+                returnTestFailure info testName $ "FAILURE: " <> testName <> " expected: " <> v1s <> ", received: " <> v2s
+            else returnTestSuccess info testName ("Expect: success " <> testName)
+      Right _v -> do
+        let failureMsg = "FAILURE: expect expression did not return a pact value for comparison"
+        recordTestFailure testName info failureMsg
+        throwUserRecoverableError info $ UserEnforceError failureMsg
       Left err -> do
         put es
         currSource <- useReplState replCurrSource
-        return $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message:\n" <>
+        returnTestFailure info testName $ "FAILURE: " <> testName <> " evaluation of actual failed with error message:\n" <>
           replError currSource err
   args -> argsError info b args
 
 coreExpectThat :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo
 coreExpectThat info b _env = \case
-  [VLiteral (LString msg), VClosure vclo, v] -> do
+  [VLiteral (LString testName), VClosure vclo, v] -> do
     applyLamUnsafe vclo [v] >>= \case
       VLiteral (LBool c) ->
-        if c then return (VLiteral (LString ("Expect-that: success " <> msg)))
-        else return (VLiteral (LString ("FAILURE: Expect-that: Did not satisfy condition: " <> msg)))
-      _ -> throwNativeExecutionError info b "Expect-that: condition did not return a boolean"
+        if c then returnTestSuccess info testName ("Expect-that: success " <> testName)
+        else returnTestFailure info testName ("FAILURE: Expect-that: Did not satisfy condition: " <> testName)
+      _ -> do
+        recordTestFailure testName info "FAILURE: expect-that expression did not return a boolean"
+        throwNativeExecutionError info b "Expect-that: condition did not return a boolean"
   args -> argsError info b args
 
 coreExpectFailure :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo
 coreExpectFailure info b _env = \case
-  [VString doc, VClosure vclo] -> do
+  [VString testName, VClosure vclo] -> do
     es <- get
     tryError (applyLamUnsafe vclo []) >>= \case
       Left (PEUserRecoverableError _ _ _) -> do
         put es
-        return $ VLiteral $ LString $ "Expect failure: Success: " <> doc
+        returnTestSuccess info testName $ "Expect failure: Success: " <> testName
       Left _err -> do
         put es
-        return $ VLiteral $ LString $ "Expect failure: Success: " <> doc
+        returnTestSuccess info testName $ "Expect failure: Success: " <> testName
       Right _ ->
-        return $ VLiteral $ LString $ "FAILURE: " <> doc <> ": expected failure, got result"
-  [VString desc, VString toMatch, VClosure vclo] -> do
+        returnTestFailure info testName $ "FAILURE: " <> testName <> ": expected failure, got result"
+  [VString testName, VString toMatch, VClosure vclo] -> do
     es <- get
     tryError (applyLamUnsafe vclo []) >>= \case
       Left userErr -> do
         put es
         let err = renderCompactText userErr
         if toMatch `T.isInfixOf` err
-          then return $ VLiteral $ LString $ "Expect failure: Success: " <> desc
-          else return $ VLiteral $ LString $
-               "FAILURE: " <> desc <> ": expected error message '" <> toMatch <> "', got '" <> err <> "'"
+          then returnTestSuccess info testName $ "Expect failure: Success: " <> testName
+          else returnTestFailure info testName $
+               "FAILURE: " <> testName <> ": expected error message '" <> toMatch <> "', got '" <> err <> "'"
       Right v ->
-        return $ VLiteral $ LString $ "FAILURE: " <> toMatch <> ": expected failure, got result: " <> prettyShowValue v
+        returnTestFailure info testName $ "FAILURE: " <> toMatch <> ": expected failure, got result: " <> prettyShowValue v
   args -> argsError info b args
 
 

pact-repl/Pact/Core/Repl.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds #-}
 
 
 -- |
@@ -14,7 +15,7 @@
 --
 
 
-module Pact.Core.Repl(runRepl, execScript) where
+module Pact.Core.Repl(runRepl, execScript, mkReplState) where
 
 import Control.Monad.IO.Class
 import Control.Exception.Safe
@@ -39,12 +40,10 @@ import Pact.Core.Errors
 execScript :: Bool -> FilePath -> IO (Either (PactError SpanInfo) [ReplCompileValue])
 execScript dolog f = do
   pdb <- mockPactDb serialisePact_repl_spaninfo
-  evalLog <- newIORef Nothing
   ee <- defaultEvalEnv pdb replBuiltinMap
-  ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False logger)
+  ref <- newIORef (mkReplState ee logger)
   runReplT ref $ loadFile f interpretEvalDirect
   where
-  defaultSrc = SourceCode "(interactive)" mempty
   logger :: Text -> EvalM e b i ()
   logger
     | dolog = liftIO . T.putStrLn
@@ -53,10 +52,9 @@ execScript dolog f = do
 runRepl :: IO ()
 runRepl = do
   pdb <- mockPactDb serialisePact_repl_spaninfo
-  evalLog <- newIORef Nothing
   ee <- defaultEvalEnv pdb replBuiltinMap
   let display' rcv = runInputT replSettings (displayOutput rcv)
-  ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False display')
+  ref <- newIORef (mkReplState ee display')
   runReplT ref (runInputT replSettings loop) >>= \case
     Left err -> do
       putStrLn "Exited repl session with error:"

pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs

@@ -65,75 +65,117 @@ corePrint info b cont handler _env = \case
     returnCEKValue cont handler (VLiteral LUnit)
   args -> argsError info b args
 
+returnTestFailure
+  :: IsBuiltin b
+  => SpanInfo
+  -> Text
+  -> Cont ReplRuntime b SpanInfo
+  -> CEKErrorHandler ReplRuntime b SpanInfo
+  -> Text
+  -> EvalM ReplRuntime b SpanInfo (EvalResult ReplRuntime b SpanInfo)
+returnTestFailure info testName cont handler msg = do
+  recordTestFailure testName info msg
+  returnCEKValue cont handler (VLiteral (LString msg))
+
+returnTestSuccess
+  :: IsBuiltin b
+  => SpanInfo
+  -> Text
+  -> Cont ReplRuntime b SpanInfo
+  -> CEKErrorHandler ReplRuntime b SpanInfo
+  -> Text
+  -> EvalM ReplRuntime b SpanInfo (EvalResult ReplRuntime b SpanInfo)
+returnTestSuccess info testName cont handler msg = do
+  recordTestSuccess testName info
+  returnCEKValue cont handler (VString msg)
+
+
 coreExpect :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo
 coreExpect info b cont handler _env = \case
-  [VLiteral (LString msg), VClosure expected, VClosure provided] -> do
+  [VLiteral (LString testName), VClosure expected, VClosure provided] -> do
+    -- Get the state of execution before running the test
     es <- get
     tryError (applyLamUnsafe provided [] Mt CEKNoHandler) >>= \case
       Right (EvalValue (VPactValue v2)) -> do
         applyLamUnsafe expected [] Mt CEKNoHandler >>= \case
           EvalValue (VPactValue v1) -> do
+            -- If v1 /= v2, the test has failed
             if v1 /= v2 then do
                 let v1s = prettyShowValue (VPactValue v1)
                     v2s = prettyShowValue (VPactValue v2)
-                returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> msg <> " expected: " <> v1s <> ", received: " <> v2s
-            else returnCEKValue cont handler (VLiteral (LString ("Expect: success " <> msg)))
-          _ -> returnCEKError info cont handler $ UserEnforceError "evaluation within expect did not return a pact value"
+                let failureMsg = "FAILURE: " <> testName <> " expected: " <> v1s <> ", received: " <> v2s
+                returnTestFailure info testName cont handler failureMsg
+            else returnTestSuccess info testName cont handler ("Expect: success " <> testName)
+          _ -> do
+            recordTestFailure testName info "FAILURE: expect expression did not return a pact value for comparison"
+            returnCEKError info cont handler $ UserEnforceError "evaluation within expect did not return a pact value"
       Right (VError _ errMsg _) -> do
+        -- Restore state on error, which resets things like cap grants, etc.
         put es
-        returnCEKValue cont handler $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message: " <> renderCompactText errMsg
-      Right _v ->
+        let failureMsg = "FAILURE: " <> testName <> " evaluation of actual failed with error message: " <> renderCompactText errMsg
+        returnTestFailure info testName cont handler failureMsg
+      Right _v -> do
+        recordTestFailure testName info "FAILURE: expect expression did not return a pact value for comparison"
         returnCEKError info cont handler $ UserEnforceError "FAILURE: expect expression did not return a pact value for comparison"
       Left err -> do
         put es
         currSource <- useReplState replCurrSource
-        returnCEKValue cont handler $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message:\n" <>
-          replError currSource err
+        let failureMsg = "FAILURE: " <> testName <> " evaluation of actual failed with error message:\n" <> replError currSource err
+        returnTestFailure info testName cont handler failureMsg
   args -> argsError info b args
 
 coreExpectThat :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo
 coreExpectThat info b cont handler _env = \case
-  [VLiteral (LString msg), VClosure vclo, v] -> do
+  [VLiteral (LString testName), VClosure vclo, v] -> do
     applyLamUnsafe vclo [v] Mt CEKNoHandler >>= \case
-      EvalValue (VLiteral (LBool c)) ->
-        if c then returnCEKValue cont handler (VLiteral (LString ("Expect-that: success " <> msg)))
-        else returnCEKValue cont handler  (VLiteral (LString ("FAILURE: Expect-that: Did not satisfy condition: " <> msg)))
-      EvalValue _ -> throwNativeExecutionError info b "Expect-that: condition did not return a boolean"
-      ve@VError{} -> returnCEK cont handler ve
+      EvalValue (VBool c) ->
+        if c then do
+          let successMsg = "Expect-that: success " <> testName
+          returnTestSuccess info testName cont handler successMsg
+        else do
+          let failureMsg = "FAILURE: Expect-that: Did not satisfy condition: " <> testName
+          returnTestFailure info testName cont handler failureMsg
+      EvalValue _ -> do
+        recordTestFailure testName info "FAILURE: expect-that expression did not return a boolean"
+        throwNativeExecutionError info b "Expect-that: condition did not return a boolean"
+      ve@(VError _ errMsg _) -> do
+        let failureMsg = "FAILURE: Expect-that: condition failed with error: " <> renderCompactText errMsg
+        recordTestFailure testName info failureMsg
+        returnCEK cont handler ve
   args -> argsError info b args
 
 coreExpectFailure :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo
 coreExpectFailure info b cont handler _env = \case
-  [VString doc, VClosure vclo] -> do
+  [VString testName, VClosure vclo] -> do
     es <- get
     tryError (applyLamUnsafe vclo [] Mt CEKNoHandler) >>= \case
       Right (VError _ _ _) -> do
         put es
-        returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> doc
+        returnTestSuccess info testName cont handler $ "Expect failure: Success: " <> testName
       Left _err -> do
         put es
-        returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> doc
+        returnTestSuccess info testName cont handler $ "Expect failure: Success: " <> testName
       Right _ ->
-        returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> doc <> ": expected failure, got result"
-  [VString desc, VString toMatch, VClosure vclo] -> do
+        returnTestFailure info testName cont handler $ "FAILURE: " <> testName <> ": expected failure, got result"
+  [VString testName, VString toMatch, VClosure vclo] -> do
     es <- get
     tryError (applyLamUnsafe vclo [] Mt CEKNoHandler) >>= \case
       Right (VError _ errMsg _) -> do
         put es
         let err = renderCompactText errMsg
         if toMatch `T.isInfixOf` err
-          then returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> desc
-          else returnCEKValue cont handler $ VLiteral $ LString $
-               "FAILURE: " <> desc <> ": expected error message '" <> toMatch <> "', got '" <> err <> "'"
+          then returnTestSuccess info testName cont handler $ "Expect failure: Success: " <> testName
+          else returnTestFailure info testName cont handler $
+               "FAILURE: " <> testName <> ": expected error message '" <> toMatch <> "', got '" <> err <> "'"
       Left errMsg -> do
         put es
         let err = renderCompactText errMsg
         if toMatch `T.isInfixOf` err
-          then returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> desc
-          else returnCEKValue cont handler $ VLiteral $ LString $
-               "FAILURE: " <> desc <> ": expected error message '" <> toMatch <> "', got '" <> err <> "'"
+          then returnTestSuccess info testName cont handler $ "Expect failure: Success: " <> testName
+          else returnTestFailure info testName cont handler $
+               "FAILURE: " <> testName <> ": expected error message '" <> toMatch <> "', got '" <> err <> "'"
       Right (EvalValue v) ->
-        returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> toMatch <> ": expected failure, got result: " <> prettyShowValue v
+        returnTestFailure info testName cont handler $ "FAILURE: " <> toMatch <> ": expected failure, got result: " <> prettyShowValue v
   args -> argsError info b args
 
 

pact-repl/Pact/Core/Repl/Utils.hs

@@ -19,7 +19,6 @@ module Pact.Core.Repl.Utils
  , runReplT
  , ReplState(..)
  , replFlags
- , replEvalLog
  , replEvalEnv
  , replUserDocs
  , replTLDefPos
@@ -42,6 +41,8 @@ module Pact.Core.Repl.Utils
  , gasLogEntrytoPactValue
  , replPrintLn
  , replPrintLn'
+ , recordTestSuccess
+ , recordTestFailure
  ) where
 
 import Control.Lens
@@ -249,6 +250,24 @@ replPrintLn' p = do
   r <- getReplState
   _replOutputLine r p
 
+recordTestResult
+  :: Text
+  -- ^ Test name
+  -> SpanInfo
+  -- ^ Test location
+  -> ReplTestStatus
+  -> ReplM b ()
+recordTestResult name loc status = do
+  SourceCode file _src <- useReplState replCurrSource
+  let testResult = ReplTestResult name loc file status
+  replTestResults %== (testResult :)
+
+recordTestSuccess :: Text -> SpanInfo -> ReplM b ()
+recordTestSuccess name loc = recordTestResult name loc ReplTestPassed
+
+recordTestFailure :: Text -> SpanInfo -> Text -> ReplM b ()
+recordTestFailure name loc failmsg = recordTestResult name loc (ReplTestFailed failmsg)
+
 -- This orphan instance allows us to separate
 -- the repl declaration out, as ugly as it is
 instance DebugPrintable 'ReplRuntime (ReplBuiltin CoreBuiltin) where

pact-tests/Pact/Core/Test/GasGolden.hs

@@ -108,22 +108,11 @@ runGasTest :: FilePath -> InterpretPact -> IO (Maybe MilliGas)
 runGasTest file interpret = do
   src <- T.readFile file
   pdb <- mockPactDb serialisePact_repl_spaninfo
-  gasLog <- newIORef Nothing
   ee <- defaultEvalEnv pdb replBuiltinMap
   let ee' = ee & eeGasEnv . geGasModel .~ replTableGasModel (Just (maxBound :: MilliGasLimit))
       gasRef = ee' ^. eeGasEnv . geGasRef
   let source = SourceCode file src
-  let rstate = ReplState
-            { _replFlags = mempty
-            , _replEvalLog = gasLog
-            , _replCurrSource = source
-            , _replEvalEnv = ee'
-            , _replUserDocs = mempty
-            , _replTLDefPos = mempty
-            , _replTx = Nothing
-            , _replNativesEnabled = False
-            , _replOutputLine = const (pure ())
-            }
+  let rstate = mkReplState ee' (const (pure ())) & replCurrSource .~ source
   stateRef <- newIORef rstate
   runReplT stateRef (interpret source) >>= \case
     Left _ -> pure Nothing