X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FServer.hs;h=e66ed0adb9fbfbb221ec030a7590b625b0d7b46a;hb=d7dc40224e71d16d319f725556e217c0343cee18;hp=65011fd3f106b0947243590c8b86af6b014dffd6;hpb=5170a20560a68b8fcaed83ecaf6146d84a147992;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs
index 65011fd..e66ed0a 100644
--- a/src/Language/Haskell/LSP/Test/Server.hs
+++ b/src/Language/Haskell/LSP/Test/Server.hs
@@ -1,25 +1,22 @@
-module Language.Haskell.LSP.Test.Server where
+module Language.Haskell.LSP.Test.Server (withServer) where
 
-import Control.Concurrent
+import Control.Concurrent.Async
 import Control.Monad
-import Data.Maybe
+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
-  let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
-  (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc
+import System.Process hiding (withCreateProcess)
 
+withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO 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 }
+  withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do
     -- 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
-  
-  pid <- fromIntegral . fromJust <$> getPid serverProc
-
-  result <- f serverIn serverOut pid
-
-  killThread errSinkThread
-  terminateProcess serverProc
-  return result
\ No newline at end of file
+    hSetBinaryMode serverErr True
+    let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn
+    withAsync errSinkThread $ \_ -> do
+      f serverIn serverOut serverProc