eval: feed stdin from an empty temporary file to avoid hangs

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

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;"
     , "  }"
     ]
 

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}

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" $

plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs → 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
 -}

plugins/hls-eval-plugin/test/testdata/TIOError.hs → 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
 -}

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
+<stdin>: hGetLine: end of file
+-}
+
+{- Check that feeding `stdin` works repeatedly.
+
+>>> getLine >>= print
+<stdin>: hGetLine: end of file
+-}

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
+<stdin>: hGetLine: end of file
+-}
+
+{- Check that feeding `stdin` works repeatedly.
+
+>>> getLine >>= print
+<stdin>: hGetLine: end of file
+-}

plugins/hls-eval-plugin/test/testdata/TIO.expected.hs → 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"
+-}

plugins/hls-eval-plugin/test/testdata/TIO.hs → 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"
 -}

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