module Language.LSP.Test.Server (withServer) where

import Control.Concurrent.Async
import Control.Monad
import Language.LSP.Test.Compat
import System.IO
import System.Process hiding (withCreateProcess)

withServer :: String -> Bool -> (CreateProcess -> CreateProcess) -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a
withServer :: forall a.
String
-> Bool
-> (CreateProcess -> CreateProcess)
-> (Handle -> Handle -> ProcessHandle -> IO a)
-> IO a
withServer String
serverExe Bool
logStdErr CreateProcess -> CreateProcess
modifyCreateProcess Handle -> Handle -> ProcessHandle -> IO a
f = do
  -- TODO Probably should just change runServer to accept
  -- separate command and arguments
  let String
cmd:[String]
args = String -> [String]
words String
serverExe
      createProc :: CreateProcess
createProc = (String -> [String] -> CreateProcess
proc String
cmd [String]
args) { std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe }
  forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (CreateProcess -> CreateProcess
modifyCreateProcess CreateProcess
createProc) forall a b. (a -> b) -> a -> b
$ \(Just Handle
serverIn) (Just Handle
serverOut) (Just Handle
serverErr) ProcessHandle
serverProc -> do
    -- Need to continuously consume to stderr else it gets blocked
    -- Can't pass NoStream either to std_err
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
serverErr BufferMode
NoBuffering
    Handle -> Bool -> IO ()
hSetBinaryMode Handle
serverErr Bool
True
    let errSinkThread :: IO b
errSinkThread = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
serverErr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logStdErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
    forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync forall {b}. IO b
errSinkThread forall a b. (a -> b) -> a -> b
$ \Async Any
_ -> do
      Handle -> Handle -> ProcessHandle -> IO a
f Handle
serverIn Handle
serverOut ProcessHandle
serverProc