eval: Capture stdout and stderr

Author: dschrempf

haskell-language-server.cabal

@@ -494,6 +494,7 @@ library hls-eval-plugin
     , megaparsec            >=9.0
     , mtl
     , parser-combinators    >=1.2
+    , silently
     , text
     , text-rope
     , transformers

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns      #-}
 {-# OPTIONS_GHC -Wwarn #-}
@@ -15,14 +14,17 @@ import qualified Data.Text                   as T
 import           Development.IDE.GHC.Compat
 import           GHC                         (ExecOptions, ExecResult (..),
                                               execStmt)
+import           GHC.Driver.Monad            (reflectGhc, reifyGhc)
 import           Ide.Plugin.Eval.Types       (Language (Plain), Loc,
                                               Located (..),
                                               Section (sectionLanguage),
                                               Test (..), Txt, locate, locate0)
 import qualified Language.LSP.Protocol.Lens  as L
 import           Language.LSP.Protocol.Types (Position (Position),
                                               Range (Range))
+import           System.IO                   (stderr, stdout)
 import           System.IO.Extra             (newTempFile, readFile')
+import           System.IO.Silently          (hCapture)
 
 -- | Return the ranges of the expression and result parts of the given test
 testRanges :: Test -> (Range, Range)
@@ -79,20 +81,31 @@ asStmts (Example e _ _) = NE.toList e
 asStmts (Property t _ _) =
     ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"]
 
-
-
 -- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result
 myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))
 myExecStmt stmt opts = do
     (temp, purge) <- liftIO newTempFile
     evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile " <> show temp <> " (P.show x)")
     modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}
-    result <- execStmt stmt opts >>= \case
-              ExecComplete (Left err) _ -> pure $ Left $ show err
-              ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp
-              ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported"
+    -- NB: We capture output to @stdout@ and @stderr@ induced as a possible side
+    -- effect by the statement being evaluated. This is fragile because the
+    -- output may be scrambled in a concurrent setting when HLS is writing to
+    -- one of these file handles from a different thread.
+    (output, execResult) <- reifyGhc $ \session ->
+      hCapture [stdout, stderr] (reflectGhc (execStmt stmt opts) session)
+    evalResult <- case execResult of
+      ExecComplete (Left err) _ ->
+        pure $ Left $ show err
+      ExecComplete (Right _) _ ->
+        liftIO $ Right . fromList . (output <>) <$> readFile' temp
+      ExecBreak{} ->
+        pure $ Right $ Just "breakpoints are not supported"
     liftIO purge
-    pure result
+    pure evalResult
+  where
+    fromList :: String -> Maybe String
+    fromList x | null x    = Nothing
+               | otherwise = Just x
 
 {- |GHC declarations required to execute test properties
 

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs

@@ -399,9 +399,12 @@ Either a pure value:
 >>> 'h' : "askell"
 "haskell"
 
-Or an 'IO a' (output on stdout/stderr is ignored):
->>> print "OK" >> return "ABC"
-"ABC"
+Or an 'IO a' (output on stdout/stderr is captured):
+>>> putStrLn "Hello," >> pure "World!"
+Hello,
+"World!"
+
+Note the quotes around @World!@, which are a result of using 'show'.
 
 Nothing is returned for a correct directive:
 
@@ -425,11 +428,18 @@ A, possibly multi line, error is returned for a wrong declaration, directive or
 Some flags have not been recognized: -XNonExistent
 
 >>> cls C
-Variable not in scope: cls :: t0 -> t
-Data constructor not in scope: C
+WAS Variable not in scope: cls :: t0 -> t
+WAS Data constructor not in scope: C
+NOW Illegal term-level use of the class `C'
+NOW   defined at <interactive>:1:2
+NOW In the first argument of `cls', namely `C'
+NOW In the expression: cls C
+NOW In an equation for `it_a5Zks': it_a5Zks = cls C
+NOW Variable not in scope: cls :: t0_a5ZlS[tau:1] -> t1_a5ZlU[tau:1]
 
 >>> "A
-lexical error in string/character literal at end of input
+WAS lexical error in string/character literal at end of input
+NOW lexical error at end of input
 
 Exceptions are shown as if printed, but it can be configured to include prefix like
 in GHCi or doctest. This allows it to be used as a hack to simulate print until we
@@ -445,7 +455,9 @@ bad times
 Or for a value that does not have a Show instance and can therefore not be displayed:
 >>> data V = V
 >>> V
-No instance for (Show V) arising from a use of ‘evalPrint’
+WAS No instance for (Show V) arising from a use of ‘evalPrint’
+NOW No instance for `Show V' arising from a use of `evalPrint'
+NOW In a stmt of an interactive GHCi command: evalPrint it_a5ZwT
 -}
 evals :: Recorder (WithPriority Log) -> Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]
 evals recorder mark_exception fp df stmts = do
@@ -454,7 +466,7 @@ evals recorder mark_exception fp df stmts = do
         Left err -> errorLines err
         Right rs -> concat . catMaybes $ rs
   where
-    dbg = logWith recorder Debug
+    dbg  = logWith recorder Debug
     eval :: Statement -> Ghc (Maybe [Text])
     eval (Located l stmt)
         | -- GHCi flags