Add getInitializeResponse

[lsp-test.git] / src / Language / Haskell / LSP / Test.hs

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index f4fb5c15021aa7563395feb5a405d7eb38ca032f..8da0cbbee8ba065533e8e0d06ac79e3f35ee4612 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -54,6 +54,7 @@ module Language.Haskell.LSP.Test
   , (<|>)
   , satisfy
   -- * Utilities
+  , getInitializeResponse
   , openDoc
   , getDocItem
   , getDocUri
@@ -81,10 +82,11 @@ import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing
 
 -- | Starts a new session.
-runSession :: FilePath -- ^ The filepath to the root directory for the session.
+runSession :: String -- ^ The command to run the server.
+           -> FilePath -- ^ The filepath to the root directory for the session.
            -> Session a -- ^ The session to run.
            -> IO ()
-runSession rootDir session = do
+runSession serverExe rootDir session = do
   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
 
@@ -95,12 +97,17 @@ runSession rootDir session = do
                                           def
                                           (Just TraceOff)
 
-  runSessionWithHandler listenServer rootDir $ do
+  runSessionWithHandler listenServer serverExe rootDir $ do
 
     -- Wrap the session around initialize and shutdown calls
     sendRequest Initialize initializeParams
-    initRsp <- response :: Session InitializeResponse
-    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
+    initRspMsg <- response :: Session InitializeResponse
+
+    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
+
+    initRspVar <- initRsp <$> ask
+    liftIO $ putMVar initRspVar initRspMsg
+    
 
     sendNotification Initialized InitializedParams
 
@@ -112,15 +119,15 @@ runSession rootDir session = do
 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 -- It also does not automatically send initialize and exit messages.
 runSessionWithHandler :: (Handle -> Session ())
+                      -> String
                       -> FilePath
                       -> Session a
                       -> IO a
-runSessionWithHandler serverHandler rootDir session = do
+runSessionWithHandler serverHandler serverExe rootDir session = do
   absRootDir <- canonicalizePath rootDir
 
-  (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
-    (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
-    { std_in = CreatePipe, std_out = CreatePipe }
+  let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
+  (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc
 
   hSetBuffering serverIn  NoBuffering
   hSetBuffering serverOut NoBuffering
@@ -128,14 +135,16 @@ runSessionWithHandler serverHandler rootDir session = do
   reqMap <- newMVar newRequestMap
   messageChan <- newChan
   meaninglessChan <- newChan
+  initRsp <- newEmptyMVar
 
-  let context = SessionContext serverIn absRootDir messageChan reqMap
+  let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
       initState = SessionState (IdInt 9)
 
-  forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
+  threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
   (result, _) <- runSession' messageChan context initState session
 
   terminateProcess serverProc
+  killThread threadId
 
   return result
 
@@ -222,6 +231,12 @@ sendMessage msg = do
   h <- serverIn <$> ask
   liftIO $ B.hPut h $ addHeader (encode msg)
 
+-- | Returns the initialize response that was received from the server.
+-- The initialize requests and responses are not included the session,
+-- so if you need to test it use this.
+getInitializeResponse :: Session InitializeResponse
+getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
+
 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 openDoc file languageId = do