diff --git a/plugins/hls-eval-plugin/README.md b/plugins/hls-eval-plugin/README.md index 46343191d9..122e477693 100644 --- a/plugins/hls-eval-plugin/README.md +++ b/plugins/hls-eval-plugin/README.md @@ -180,11 +180,11 @@ N + M + 1 :: Nat "Other" ``` -IO expressions can also be evaluated but their output to stdout/stderr is NOT captured: +IO expressions can also be evaluated and their output to `stdout`/`stderr` is captured: ``` >>> print "foo" -() +"foo" ``` ### Properties diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index afd723863f..69d5ba6076 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -117,7 +117,7 @@ execStmtCaptureResult :: execStmtCaptureResult recorder stmt opts = do (result, (output, execResultE)) <- withCaptureResult recorder $ - withCaptureStdHandles opts $ + withCaptureStdHandles recorder opts $ gStrictTry (execStmt stmt opts) case execResultE of Left exc -> @@ -146,16 +146,19 @@ execStmtCaptureResult recorder stmt opts = do where trimmed = dropWhileEnd (== '\n') output --- 'System.IO.Extra.withTempFile' is specialized to 'IO'. +-- | Provide a fresh temporary file, removed once @k@ returns. +-- ('System.IO.Extra.withTempFile' is specialized to 'IO'.) +withTempFile_ :: (MonadIO m, MonadMask m) => (FilePath -> m b) -> m b +withTempFile_ k = + bracket (liftIO newTempFile) (liftIO . snd) (k . fst) + +-- | Like 'withTempFile_', but also read the file's contents back once @k@ +-- | returns. withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m b) -> m (String, b) -withTempFile k = do - bracket - (liftIO newTempFile) - (\(_, purgeTempFile) -> liftIO purgeTempFile) - (\(tempFile, _) -> do - r <- k tempFile - o <- liftIO $ readFile' tempFile - pure (o, r)) +withTempFile k = withTempFile_ $ \tempFile -> do + r <- k tempFile + o <- liftIO $ readFile' tempFile + pure (o, r) -- | Capture the value the statement evaluates to (printed by GHCi via the -- interactive print function) by writing it to a temporary file. @@ -187,31 +190,74 @@ withCaptureResult recorder action = withTempFile $ \resultTemp -> do -- may leak. base provides no per-thread standard handles, so this is -- unavoidable with this approach. withCaptureStdHandles :: - ExecOptions + Recorder (WithPriority Log) + -> ExecOptions -> Ghc a -> Ghc (String, a) -withCaptureStdHandles opts action = withTempFile $ \outputTemp -> do +withCaptureStdHandles recorder opts action = + -- @outputTemp@ collects the captured @stdout@/@stderr@; its contents are the + -- returned 'String'. @inputTemp@ is a separate, empty file standing in for + -- @stdin@: redirecting from it (rather than closing @stdin@) means reads in + -- the evaluated code hit EOF immediately -- as if the program were run with + -- @< /dev/null@ -- instead of raising "handle is closed". This is portable + -- (no @/dev/null@/@NUL@ path) and keeps @stdin@ open so 'captureTeardown' + -- can restore it cleanly. + withTempFile $ \outputTemp -> + withTempFile_ $ \inputTemp -> + withRedirectedStdHandles recorder opts outputTemp inputTemp action + +-- | Redirect the interpreted standard handles ('captureSetup') around @action@, +-- restoring them ('captureTeardown') no matter how it terminates. +withRedirectedStdHandles :: + Recorder (WithPriority Log) + -> ExecOptions + -> FilePath -- ^ File the interpreted @stdout@/@stderr@ are written to. + -> FilePath -- ^ File the interpreted @stdin@ is read from. + -> Ghc a + -> Ghc a +withRedirectedStdHandles recorder opts outputTemp inputTemp action = bracket - (execStmt (captureSetup outputTemp) opts) - -- Restore the handles no matter how the statement terminated. - (\_ -> execStmt captureTeardown opts) + (execStmtCheck recorder "capture setup" (captureSetup outputTemp inputTemp) opts) + (\_ -> execStmtCheck recorder "capture teardown" captureTeardown opts) (\_ -> action) --- Open a temporary file and redirect the interpreted @stdout@/@stderr@ to --- it, saving the original handles in interactive bindings so 'captureTeardown' --- can restore them. Bound to a tuple (rather than evaluated as a bare --- expression) so GHCi does not pass it to the interactive print function. -captureSetup :: FilePath -> String +-- | Run an internal handle-redirection statement (capture setup/teardown) and +-- log on failure. +execStmtCheck :: + Recorder (WithPriority Log) + -> String + -> String + -> ExecOptions + -> Ghc () +execStmtCheck recorder phase stmt opts = do + result <- execStmt stmt opts + case result of + ExecComplete (Left err) _ -> + logWith recorder Log.Warning $ LogEvalCaptureStdHandles phase (show err) + _ -> pure () + +-- | Capture setup +-- +-- Redirect the interpreted @stdout@/@stderr@ to a temporary file. +-- +-- Redirect @stdin@ from an (empty) @inputTemp@ file. +-- +-- The original handles are saved in interactive bindings so 'captureTeardown' +-- can restore them. +captureSetup :: FilePath -> FilePath -> String -- Squeeze into one line (executed by GHCi). -captureSetup outputTemp = unwords - [ "(__hls_captureHandle, __hls_savedStdout, __hls_savedStderr) <- do {" - , " __hls_h <- System.IO.openFile", show outputTemp, "System.IO.WriteMode;" - , " System.IO.hSetBuffering __hls_h System.IO.LineBuffering;" - , " __hls_o <- GHC.IO.Handle.hDuplicate System.IO.stdout;" - , " __hls_e <- GHC.IO.Handle.hDuplicate System.IO.stderr;" - , " GHC.IO.Handle.hDuplicateTo __hls_h System.IO.stdout;" - , " GHC.IO.Handle.hDuplicateTo __hls_h System.IO.stderr;" - , " P.return (__hls_h, __hls_o, __hls_e);" +captureSetup outputTemp inputTemp = unwords + [ "(__hls_captureOut, __hls_captureIn, __hls_stdout, __hls_stderr, __hls_stdin) <- do {" + , " __hls_co <- System.IO.openFile", show outputTemp, "System.IO.WriteMode;" + , " System.IO.hSetBuffering __hls_co System.IO.LineBuffering;" + , " __hls_ci <- System.IO.openFile", show inputTemp, "System.IO.ReadMode;" + , " __hls_so <- GHC.IO.Handle.hDuplicate System.IO.stdout;" + , " __hls_se <- GHC.IO.Handle.hDuplicate System.IO.stderr;" + , " __hls_si <- GHC.IO.Handle.hDuplicate System.IO.stdin;" + , " GHC.IO.Handle.hDuplicateTo __hls_co System.IO.stdout;" + , " GHC.IO.Handle.hDuplicateTo __hls_co System.IO.stderr;" + , " GHC.IO.Handle.hDuplicateTo __hls_ci System.IO.stdin;" + , " P.return (__hls_co, __hls_ci, __hls_so, __hls_se, __hls_si);" , " }" ] @@ -223,11 +269,15 @@ captureTeardown = unwords [ "__hls_restored <- do {" , " System.IO.hFlush System.IO.stdout;" , " System.IO.hFlush System.IO.stderr;" - , " GHC.IO.Handle.hDuplicateTo __hls_savedStdout System.IO.stdout;" - , " GHC.IO.Handle.hDuplicateTo __hls_savedStderr System.IO.stderr;" - , " System.IO.hClose __hls_savedStdout;" - , " System.IO.hClose __hls_savedStderr;" - , " System.IO.hClose __hls_captureHandle;" + -- stdin is an input handle, so it has nothing to flush. + , " GHC.IO.Handle.hDuplicateTo __hls_stdout System.IO.stdout;" + , " GHC.IO.Handle.hDuplicateTo __hls_stderr System.IO.stderr;" + , " GHC.IO.Handle.hDuplicateTo __hls_stdin System.IO.stdin;" + , " System.IO.hClose __hls_stdout;" + , " System.IO.hClose __hls_stderr;" + , " System.IO.hClose __hls_stdin;" + , " System.IO.hClose __hls_captureOut;" + , " System.IO.hClose __hls_captureIn;" , " }" ] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 7d83419f40..01a0890839 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -76,6 +76,7 @@ data Log | LogEvalImport String | LogEvalDeclaration String | LogEvalFailedSettingInteractivePrintFunction + | LogEvalCaptureStdHandles String String instance Pretty Log where pretty = \case @@ -99,15 +100,18 @@ instance Pretty Log where LogEvalFlags flags -> "{:SET" <+> pretty flags LogEvalPreSetDynFlags dynFlags -> "pre set" <+> pretty (showDynFlags dynFlags) LogEvalParsedFlags eans -> "parsed flags" <+> viaShow (eans - <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings)) + <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings)) LogEvalPostSetDynFlags dynFlags -> "post set" <+> pretty (showDynFlags dynFlags) LogEvalStmtStart stmt -> "{STMT" <+> pretty stmt LogEvalStmtResult result -> "STMT}" <+> pretty result LogEvalImport stmt -> "{IMPORT" <+> pretty stmt LogEvalDeclaration stmt -> "{DECL" <+> pretty stmt LogEvalFailedSettingInteractivePrintFunction -> pretty $ - "Return value will not be captured: " - ++ "Failed setting the interactive print function." + "Return value will not be captured: " + ++ "Failed setting the interactive print function." + LogEvalCaptureStdHandles phase err -> pretty $ + "Redirecting stdout/stderr failed during " + ++ phase ++ ": " ++ err -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index ff2a5d3b59..fd12694009 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -128,8 +128,9 @@ tests = evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" "-- id :: forall a. a -> a" , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" - , goldenWithEval "Support IO expressions, capture and show stdout/stderr output" "TIO" "hs" - , goldenWithEval "Support IO expressions, close handles on errors" "TIOError" "hs" + , goldenWithEval "Support IO expressions (stdout), capture and show stdout output" "TIOStdout" "hs" + , goldenWithEval "Support IO expressions (stderr), capture and show stderr output" "TIOStderr" "hs" + , goldenWithEval "Support IO expressions (stdin)" "TIOStdin" "hs" , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs" , knownBrokenInWindowsBeforeGHC912 "The output has path separators in it, which on Windows look different. Just skip it there" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" $ diff --git a/plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOStderr.expected.hs similarity index 56% rename from plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs rename to plugins/hls-eval-plugin/test/testdata/TIOStderr.expected.hs index 8e0de471be..99911639fe 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIOStderr.expected.hs @@ -5,7 +5,14 @@ module TIOError where import Control.Exception -{- +{- We do not see the error value constructor. + +>>> throwIO (TypeError "Doh") +Doh +-} + +{- Do we capture `stderr` repeatedly? + >>> throwIO (TypeError "Doh") Doh -} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOError.hs b/plugins/hls-eval-plugin/test/testdata/TIOStderr.hs similarity index 54% rename from plugins/hls-eval-plugin/test/testdata/TIOError.hs rename to plugins/hls-eval-plugin/test/testdata/TIOStderr.hs index 6b39667e3b..99911639fe 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIOError.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIOStderr.hs @@ -5,6 +5,14 @@ module TIOError where import Control.Exception -{- +{- We do not see the error value constructor. + +>>> throwIO (TypeError "Doh") +Doh +-} + +{- Do we capture `stderr` repeatedly? + >>> throwIO (TypeError "Doh") +Doh -} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOStdin.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdin.expected.hs new file mode 100644 index 0000000000..44a45a50cc --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIOStdin.expected.hs @@ -0,0 +1,18 @@ +-- 1. Support `stdin` +module TIOStdin where + +{- Feed `stdin` with empty data. + +Avoid server hangs indefinitely, waiting for `stdin` to terminate. + +Shows a clear error message. + +>>> getLine >>= print +: hGetLine: end of file +-} + +{- Check that feeding `stdin` works repeatedly. + +>>> getLine >>= print +: hGetLine: end of file +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOStdin.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdin.hs new file mode 100644 index 0000000000..44a45a50cc --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIOStdin.hs @@ -0,0 +1,18 @@ +-- 1. Support `stdin` +module TIOStdin where + +{- Feed `stdin` with empty data. + +Avoid server hangs indefinitely, waiting for `stdin` to terminate. + +Shows a clear error message. + +>>> getLine >>= print +: hGetLine: end of file +-} + +{- Check that feeding `stdin` works repeatedly. + +>>> getLine >>= print +: hGetLine: end of file +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdout.expected.hs similarity index 68% rename from plugins/hls-eval-plugin/test/testdata/TIO.expected.hs rename to plugins/hls-eval-plugin/test/testdata/TIOStdout.expected.hs index 0be985ae3c..778c69646f 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIOStdout.expected.hs @@ -1,7 +1,7 @@ -- 1. Support IO expressions -- -- 2. Capture and show stdout -module TIO where +module TIOStdout where import Control.Concurrent (threadDelay) @@ -13,3 +13,10 @@ Has a delay in order to show progress reporting. "ABC" "XYZ" -} + +{- Check that capturing `stdout` works repeatedly. + +>>> print "ABC" >> return "XYZ" +"ABC" +"XYZ" +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdout.hs similarity index 65% rename from plugins/hls-eval-plugin/test/testdata/TIO.hs rename to plugins/hls-eval-plugin/test/testdata/TIOStdout.hs index 455c19d5b8..778c69646f 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIO.hs +++ b/plugins/hls-eval-plugin/test/testdata/TIOStdout.hs @@ -1,7 +1,7 @@ -- 1. Support IO expressions -- -- 2. Capture and show stdout -module TIO where +module TIOStdout where import Control.Concurrent (threadDelay) @@ -10,4 +10,13 @@ import Control.Concurrent (threadDelay) Has a delay in order to show progress reporting. >>> threadDelay 2000000 >> print "ABC" >> return "XYZ" +"ABC" +"XYZ" +-} + +{- Check that capturing `stdout` works repeatedly. + +>>> print "ABC" >> return "XYZ" +"ABC" +"XYZ" -} diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 9b3bffb901..a74cfd896a 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -37,20 +37,19 @@ tests = [] , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do - doc <- openDoc "TIO.hs" "haskell" + doc <- openDoc "TIOStdout.hs" "haskell" lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) (codeLensResponse, createdProgressTokens, activeProgressTokens) <- expectProgressMessagesTill (responseForId SMethod_TextDocumentCodeLens lspId) - ["Setting up testdata (for TIO.hs)"] + ["Setting up testdata (for TIOStdout.hs)"] ["Processing", "Indexing"] [] [] - -- this is a test so exceptions result in fails let response = getMessageResult codeLensResponse case response of - InL [evalLens] -> do + InL [evalLens, _evalLens] -> do let command = evalLens ^?! L.command . _Just _ <- sendRequest SMethod_WorkspaceExecuteCommand $ @@ -90,6 +89,7 @@ data ProgressMessage | ProgressBegin ProgressToken WorkDoneProgressBegin | ProgressReport ProgressToken WorkDoneProgressReport | ProgressEnd ProgressToken WorkDoneProgressEnd + deriving (Show) data InterestingMessage a = InterestingMessage a