From 4e138c6f36a3e03587c5f25cd71fff86b0f8a425 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Thu, 9 Jan 2025 13:53:52 -0500 Subject: [PATCH] Improve test infra for errors using expect, expect-that and expect-failure --- pact-lsp/Pact/Core/LanguageServer.hs | 2 - .../Pact/Core/IR/Eval/Direct/ReplBuiltin.hs | 59 ++++++++---- pact-repl/Pact/Core/Repl.hs | 10 +- .../Pact/Core/Repl/Runtime/ReplBuiltin.hs | 94 ++++++++++++++----- pact-repl/Pact/Core/Repl/Utils.hs | 21 ++++- pact-tests/Pact/Core/Test/GasGolden.hs | 13 +-- pact-tests/Pact/Core/Test/ReplTests.hs | 39 +++----- pact-tests/Pact/Core/Test/StaticErrorTests.hs | 15 +-- pact-tests/pact-tests/stackleak.repl | 6 +- pact/Pact/Core/Environment/Types.hs | 37 +++++++- 10 files changed, 188 insertions(+), 108 deletions(-) diff --git a/pact-lsp/Pact/Core/LanguageServer.hs b/pact-lsp/Pact/Core/LanguageServer.hs index 771d79e07..e33d9b9e9 100644 --- a/pact-lsp/Pact/Core/LanguageServer.hs +++ b/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 diff --git a/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs b/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs index 260d717cd..513f8a84b 100644 --- a/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs +++ b/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 diff --git a/pact-repl/Pact/Core/Repl.hs b/pact-repl/Pact/Core/Repl.hs index 35eb27b3f..f77e6039e 100644 --- a/pact-repl/Pact/Core/Repl.hs +++ b/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:" diff --git a/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 3847b8c1e..6e88ec553 100644 --- a/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/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 diff --git a/pact-repl/Pact/Core/Repl/Utils.hs b/pact-repl/Pact/Core/Repl/Utils.hs index c1d544925..52f247686 100644 --- a/pact-repl/Pact/Core/Repl/Utils.hs +++ b/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 diff --git a/pact-tests/Pact/Core/Test/GasGolden.hs b/pact-tests/Pact/Core/Test/GasGolden.hs index ab469512a..2036e180a 100644 --- a/pact-tests/Pact/Core/Test/GasGolden.hs +++ b/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 diff --git a/pact-tests/Pact/Core/Test/ReplTests.hs b/pact-tests/Pact/Core/Test/ReplTests.hs index 8a26c1b7e..0fa24d3e3 100644 --- a/pact-tests/Pact/Core/Test/ReplTests.hs +++ b/pact-tests/Pact/Core/Test/ReplTests.hs @@ -21,16 +21,13 @@ import System.FilePath import qualified Data.Text as T import qualified Data.Text.IO as T -import Pact.Core.Literal import Pact.Core.Persistence.MockPersistence import Pact.Core.Repl.Utils import Pact.Core.Persistence.SQLite (withSqlitePactDb) import Pact.Core.Info (SpanInfo) -import Pact.Core.Compile import Pact.Core.Repl.Compile -import Pact.Core.PactValue import Pact.Core.Environment import Pact.Core.Builtin import Pact.Core.Errors @@ -83,27 +80,16 @@ runReplTest -> Interpreter -> Assertion runReplTest (ReplSourceDir path) pdb file src interp = do - gasLog <- newIORef Nothing ee <- defaultEvalEnv pdb replBuiltinMap let source = SourceCode (path 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 (interp source) >>= \case Left e -> let rendered = replError (SourceCode file src) e in assertFailure (T.unpack rendered) - Right output -> do - traverse_ ensurePassing output + Right _ -> do + traverse_ ensurePassing . _replTestResults =<< readIORef stateRef ensureModuleHashesMatch where moduleHashMatches mn = void $ runMaybeT $ do @@ -117,10 +103,15 @@ runReplTest (ReplSourceDir path) pdb file src interp = do ensureModuleHashesMatch = do keys <- ignoreGas def $ _pdbKeys pdb DModules traverse_ moduleHashMatches keys - ensurePassing = \case - RCompileValue (InterpretValue v i) -> case v of - PLiteral (LString msg) -> do - let render = replError (SourceCode file src) (PEExecutionError (EvalError msg) [] i) - when (T.isPrefixOf "FAILURE:" msg) $ assertFailure (T.unpack render) - _ -> pure () - _ -> pure () + ensurePassing (ReplTestResult _testName loc _ res) = case res of + ReplTestPassed -> pure() + ReplTestFailed msg -> do + let render = replError (SourceCode file src) (PEExecutionError (EvalError msg) [] loc) + assertFailure (T.unpack render) + + -- RCompileValue (InterpretValue v i) -> case v of + -- PLiteral (LString msg) -> do + -- let render = replError (SourceCode file src) (PEExecutionError (EvalError msg) [] i) + -- when (T.isPrefixOf "FAILURE:" msg) $ assertFailure (T.unpack render) + -- _ -> pure () + -- _ -> pure () diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index 9d8b9db35..c02fc7357 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/pact-tests/Pact/Core/Test/StaticErrorTests.hs @@ -34,21 +34,12 @@ isUserRecoverableError p s = has (_PEUserRecoverableError . _1 . p) s runStaticTest :: String -> Text -> ReplInterpreter -> (PactErrorI -> Bool) -> Assertion runStaticTest label src interp predicate = do - gasLog <- newIORef Nothing pdb <- mockPactDb serialisePact_repl_spaninfo ee <- defaultEvalEnv pdb replBuiltinMap let source = SourceCode label src - rstate = ReplState - { _replFlags = mempty - , _replEvalLog = gasLog - , _replCurrSource = source - , _replEvalEnv = ee - , _replUserDocs = mempty - , _replTLDefPos = mempty - , _replTx = Nothing - , _replNativesEnabled = True - , _replOutputLine = const (pure ()) - } + rstate = mkReplState ee (const (pure ())) + & replCurrSource .~ source + & replNativesEnabled .~ True stateRef <- newIORef rstate v <- runReplT stateRef (interpretReplProgram interp source) case v of diff --git a/pact-tests/pact-tests/stackleak.repl b/pact-tests/pact-tests/stackleak.repl index ea5f6103b..92f826425 100644 --- a/pact-tests/pact-tests/stackleak.repl +++ b/pact-tests/pact-tests/stackleak.repl @@ -3,7 +3,7 @@ ; our repl natives have to be able to bypass some stepwise mechanics to make their ; functionality work (E.g, running a suspended subexpression until it reduces to a value), ; so if they ever catch a thrown runtime error, it can leak the state of the stack. -; this is a simple test taht ensures that despite thrown errors, we do not leak the stack +; this is a simple test that ensures that despite thrown errors, we do not leak the stack (module stackleak g (defcap g () true) @@ -12,8 +12,8 @@ ) (let* - ((unusedResult1 (expect "leaks stack frame" 1 (leaks-stack))) - (unusedResult2 (expect-failure "leaks stack frame" (leaks-stack))) + ((unusedResult1 (expect-failure "leaks stack frame" (leaks-stack))) + (unusedResult2 (expect-failure "leaks stack frame2" (leaks-stack))) ) 1 ) diff --git a/pact/Pact/Core/Environment/Types.hs b/pact/Pact/Core/Environment/Types.hs index b2cc1fa2a..4c9b20aa3 100644 --- a/pact/Pact/Core/Environment/Types.hs +++ b/pact/Pact/Core/Environment/Types.hs @@ -64,7 +64,6 @@ module Pact.Core.Environment.Types , EvalM(..) , RuntimeMode(..) , replFlags - , replEvalLog , replEvalEnv , replUserDocs , replTLDefPos @@ -72,6 +71,8 @@ module Pact.Core.Environment.Types , replCurrSource , replTx , replOutputLine + , replTestResults + , mkReplState , ReplM , ReplDebugFlag(..) , SourceCode(..) @@ -81,6 +82,10 @@ module Pact.Core.Environment.Types , newDefaultWarningStack , pushWarning , getWarningStack + , ReplTestResult(..) + , ReplTestStatus(..) + , _ReplTestFailed + , _ReplTestPassed ) where @@ -340,13 +345,28 @@ defaultEvalEnv pdb m = do , _eeWarnings = Just warningRef } +data ReplTestStatus + = ReplTestPassed + | ReplTestFailed Text + deriving (Show, Eq) + +data ReplTestResult + = ReplTestResult + { _trName :: Text + , _trLoc :: SpanInfo + , _trSourceFile :: String + , _trResult :: ReplTestStatus + } deriving (Show, Eq) + -- | Passed in repl environment data ReplState b = ReplState { _replFlags :: Set ReplDebugFlag + -- ^ The currently enabled debug flags , _replEvalEnv :: EvalEnv b SpanInfo - , _replEvalLog :: IORef (Maybe [(Text, Gas)]) + -- ^ The current eval environment , _replCurrSource :: SourceCode + -- ^ The current source code for source being evaluated , _replUserDocs :: Map QualifiedName Text -- ^ Used by Repl and LSP Server, reflects the user -- annotated @doc string. @@ -354,9 +374,13 @@ data ReplState b -- ^ Used by LSP Server, reflects the span information -- of the TL definitions for the qualified name. , _replTx :: Maybe (TxId, Maybe Text) + -- ^ The current repl tx, if one has been initiated , _replNativesEnabled :: Bool - -- ^ + -- ^ Are repl natives enabled in module code , _replOutputLine :: !(Text -> EvalM 'ReplRuntime b SpanInfo ()) + -- ^ The output line function, as an entry in the repl env + -- to allow for custom output handling, e.g haskeline + , _replTestResults :: [ReplTestResult] } data RuntimeMode @@ -404,3 +428,10 @@ runEvalMResult env st (EvalM action) = {-# INLINEABLE runEvalMResult #-} makeLenses ''ReplState +makePrisms ''ReplTestStatus + +mkReplState :: EvalEnv b SpanInfo -> (Text -> EvalM 'ReplRuntime b SpanInfo ()) -> ReplState b +mkReplState ee printfn = + ReplState mempty ee defaultSrc mempty mempty Nothing False printfn [] + where + defaultSrc = SourceCode "(interactive)" mempty