X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FServer.hs;h=ff667480bf4e64ff1d94316cb4cd3e2781d10b7d;hb=ba3255afa89fd1faf4c8ed1a01ba482ec5755264;hp=c59a755979314316d4759765088f883df873c73a;hpb=502c8dc3ff63383487536922176330a3f459a462;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs
index c59a755..ff66748 100644
--- a/src/Language/Haskell/LSP/Test/Server.hs
+++ b/src/Language/Haskell/LSP/Test/Server.hs
@@ -2,27 +2,28 @@ module Language.Haskell.LSP.Test.Server (withServer) where
 
 import Control.Concurrent
 import Control.Monad
+import Control.Monad.IO.Class
 import Language.Haskell.LSP.Test.Compat
 import System.IO
 import System.Process
 
-withServer :: String -> (Handle -> Handle -> Int -> IO a) -> IO a
-withServer serverExe f = do
+withServer :: MonadIO m => String -> Bool -> (Handle -> Handle -> Int -> m a) -> m a
+withServer serverExe logStdErr f = do
   -- TODO Probably should just change runServer to accept
   -- separate command and arguments
   let cmd:args = words serverExe
       createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
-  (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc
+  (Just serverIn, Just serverOut, Just serverErr, serverProc) <- liftIO $ createProcess createProc
 
   -- Need to continuously consume to stderr else it gets blocked
   -- Can't pass NoStream either to std_err
-  hSetBuffering serverErr NoBuffering
-  errSinkThread <- forkIO $ forever $ hGetLine serverErr
+  liftIO $ hSetBuffering serverErr NoBuffering
+  errSinkThread <- liftIO $ forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn
 
-  pid <- getProcessID serverProc
+  pid <- liftIO $ getProcessID serverProc
 
   result <- f serverIn serverOut pid
 
-  killThread errSinkThread
-  terminateProcess serverProc
+  liftIO $ killThread errSinkThread
+  liftIO $ terminateProcess serverProc
   return result