ghcide-bench: fix stderr capturing

haskell · Aug 21, 2022 · 084e1be · 084e1be
1 parent 4de119c
commit 084e1be
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 5 deletions.
diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal
@@ -13,7 +13,6 @@ description:        An LSP client for running performance experiments on HLS
 homepage:           https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme
 bug-reports:        https://github.com/haskell/haskell-language-server/issues
 tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4
-extra-source-files: README.md
 
 executable ghcide-bench
     default-language: Haskell2010
@@ -68,6 +67,7 @@ library
         Development.IDE.Test.Diagnostic
     build-depends:
         aeson,
+        async,
         base == 4.*,
         binary,
         bytestring,

diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs
@@ -24,9 +24,11 @@ module Experiments
 , exampleToOptions
 ) where
 import           Control.Applicative.Combinators (skipManyTill)
+import           Control.Concurrent.Async        (withAsync)
 import           Control.Exception.Safe          (IOException, handleAny, try)
-import           Control.Monad.Extra             (allM, forM, forM_, unless,
-                                                  void, whenJust, (&&^))
+import           Control.Monad.Extra             (allM, forM, forM_, forever,
+                                                  unless, void, when, whenJust,
+                                                  (&&^))
 import           Control.Monad.Fail              (MonadFail)
 import           Control.Monad.IO.Class
 import           Data.Aeson                      (Value (Null),
@@ -55,10 +57,12 @@ import           Options.Applicative
 import           System.Directory
 import           System.Environment.Blank        (getEnv)
 import           System.FilePath                 ((<.>), (</>))
+import           System.IO
 import           System.Process
 import           System.Time.Extra
 import           Text.ParserCombinators.ReadP    (readP_to_S)
 import           Text.Printf
+
 charEdit :: Position -> TextDocumentContentChangeEvent
 charEdit p =
     TextDocumentContentChangeEvent
@@ -341,8 +345,15 @@ runBenchmarksFun dir allBenchmarks = do
         }
   results <- forM benchmarks $ \b@Bench{name} ->  do
     let p = (proc (ghcide ?config) (allArgs name dir))
-                { std_in = CreatePipe, std_out = CreatePipe }
-        run sess = withCreateProcess p $ \(Just inH) (Just outH) _errH _pH ->
+                { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
+        run sess = withCreateProcess p $ \(Just inH) (Just outH) (Just errH) _pH -> do
+                    -- Need to continuously consume to stderr else it gets blocked
+                    -- Can't pass NoStream either to std_err
+                    hSetBuffering errH NoBuffering
+                    hSetBinaryMode errH True
+                    let errSinkThread =
+                            forever $ hGetLine errH >>= when (verbose ?config). putStrLn
+                    withAsync errSinkThread $ \_ -> do
                         runSessionWithHandles inH outH conf lspTestCaps dir sess
     (b,) <$> runBench run b