use senRequest instead of request_ in executeCommand to avoid gobbling up messages

[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 80ea0e3b386f60560cabd1accbdbc79d1783ca16..1ed07d5e06211ed583251cd066271385d2310565 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -155,7 +155,16 @@ runSessionWithConfig config' serverExe caps rootDir session = do
   withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
     runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session
 
-
+-- | Starts a new session, using the specified handles to communicate with the
+-- server. You can use this to host the server within the same process.
+-- An example with haskell-lsp might look like:
+--
+-- > (hinRead, hinWrite) <- createPipe
+-- > (houtRead, houtWrite) <- createPipe
+-- > 
+-- > forkIO $ void $ runWithHandles hinRead houtWrite initCallbacks handlers def
+-- > Test.runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do
+-- >   -- ...
 runSessionWithHandles :: Handle -- ^ The input handle
                       -> Handle -- ^ The output handle
                       -> SessionConfig
@@ -188,7 +197,7 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
                                           Nothing
                                           caps
                                           (Just TraceOff)
-                                          Nothing
+                                          (List <$> initialWorkspaceFolders config)
   runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
     -- Wrap the session around initialize and shutdown calls
     -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
@@ -196,7 +205,7 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
 
     -- Because messages can be sent in between the request and response,
     -- collect them and then...
-    (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
+    (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId)
 
     case initRspMsg ^. LSP.result of
       Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
@@ -221,7 +230,7 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
   where
   -- | Asks the server to shutdown and exit politely
   exitServer :: Session ()
-  exitServer = request_ SShutdown (Nothing :: Maybe Value) >> sendNotification SExit Empty
+  exitServer = request_ SShutdown Empty >> sendNotification SExit Empty
 
   -- | Listens to the server output until the shutdown ack,
   -- makes sure it matches the record and signals any semaphores
@@ -229,10 +238,9 @@ runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir sessio
   listenServer serverOut context = do
     msgBytes <- getNextMessage serverOut
 
-    msg <- modifyMVar (requestMap context) $ \reqMap -> do
-      let (msg, newReqMap) = decodeFromServerMsg reqMap msgBytes
+    msg <- modifyMVar (requestMap context) $ \reqMap ->
+      pure $ decodeFromServerMsg reqMap msgBytes
     writeChan (messageChan context) (ServerMessage msg)
-      pure (newReqMap, msg)
 
     case msg of
       (FromServerRsp SShutdown _) -> return ()
@@ -296,7 +304,7 @@ getDocumentEdit doc = do
 -- @
 -- Note: will skip any messages in between the request and the response.
 request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)
-request m = sendRequest m >=> skipManyTill anyMessage . responseForId
+request m = sendRequest m >=> skipManyTill anyMessage . responseForId m
 
 -- | The same as 'sendRequest', but discard the response.
 request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()
@@ -488,8 +496,8 @@ getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol]
 getDocumentSymbols doc = do
   ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) :: Session DocumentSymbolsResponse
   case res of
-    Right (L (List xs)) -> return (Left xs)
-    Right (R (List xs)) -> return (Right xs)
+    Right (InL (List xs)) -> return (Left xs)
+    Right (InR (List xs)) -> return (Right xs)
     Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
 
 -- | Returns the code actions in the specified range.
@@ -535,7 +543,7 @@ executeCommand :: Command -> Session ()
 executeCommand cmd = do
   let args = decode $ encode $ fromJust $ cmd ^. arguments
       execParams = ExecuteCommandParams Nothing (cmd ^. command) args
-  request_ SWorkspaceExecuteCommand execParams
+  void $ sendRequest SWorkspaceExecuteCommand execParams
 
 -- | Executes a code action.
 -- Matching with the specification, if a code action
@@ -596,8 +604,8 @@ getCompletions doc pos = do
   rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing)
 
   case getResponseResult rsp of
-    L (List items) -> return items
-    R (CompletionList _ (List items)) -> return items
+    InL (List items) -> return items
+    InR (CompletionList _ (List items)) -> return items
 
 -- | Returns the references for the position in the document.
 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
@@ -648,9 +656,9 @@ getDeclarationyRequest method paramCons doc pos = do
   let params = paramCons doc pos Nothing Nothing
   rsp <- request method params
   case getResponseResult rsp of
-      L loc -> pure (L [loc])
-      R (L (List locs)) -> pure (L locs)
-      R (R (List locLinks)) -> pure (R locLinks)
+      InL loc -> pure (InL [loc])
+      InR (InL (List locs)) -> pure (InL locs)
+      InR (InR (List locLinks)) -> pure (InR locLinks)
 
 -- | Renames the term at the specified position.
 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
@@ -662,7 +670,7 @@ rename doc pos newName = do
   updateState (FromServerMess SWorkspaceApplyEdit req)
 
 -- | Returns the hover information at the specified position.
-getHover :: TextDocumentIdentifier -> Position -> Session Hover
+getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
 getHover doc pos =
   let params = HoverParams doc pos Nothing
   in getResponseResult <$> request STextDocumentHover params