X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=36841e8be6173406c4347a434d4bf7560e799c8c;hb=ddf9bc17ce8a548a927c201c6b0edb8cf1c9fcad;hp=bca640f532c712ea051c28ad34f506bf3c501238;hpb=d9ee1a3a044d2aaa88333717d061da41b1d53cd2;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index bca640f..36841e8 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -114,7 +114,6 @@ import System.Environment
 import System.IO
 import System.Directory
 import System.FilePath
-import qualified Data.Rope.UTF16 as Rope
 
 -- | Starts a new session.
 --
@@ -154,9 +153,16 @@ runSessionWithConfig config' serverExe caps rootDir session = do
   withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
     runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
       -- Wrap the session around initialize and shutdown calls
-      initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
+      -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
+      initReqId <- sendRequest Initialize initializeParams
 
-      liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
+      -- Because messages can be sent in between the request and response,
+      -- collect them and then...
+      (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
+
+      case initRspMsg ^. LSP.result of
+        Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
+        Right _ -> pure ()
 
       initRspVar <- initRsp <$> ask
       liftIO $ putMVar initRspVar initRspMsg
@@ -166,6 +172,12 @@ runSessionWithConfig config' serverExe caps rootDir session = do
         Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
         Nothing -> return ()
 
+      -- ... relay them back to the user Session so they can match on them!
+      -- As long as they are allowed.
+      forM_ inBetween checkLegalBetweenMessage
+      msgChan <- asks messageChan
+      liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)
+
       -- Run the actual test
       session
   where
@@ -188,6 +200,16 @@ runSessionWithConfig config' serverExe caps rootDir session = do
       (RspShutdown _) -> return ()
       _               -> listenServer serverOut context
 
+  -- | Is this message allowed to be sent by the server between the intialize
+  -- request and response?
+  -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize
+  checkLegalBetweenMessage :: FromServerMessage -> Session ()
+  checkLegalBetweenMessage (NotShowMessage _) = pure ()
+  checkLegalBetweenMessage (NotLogMessage _) = pure ()
+  checkLegalBetweenMessage (NotTelemetry _) = pure ()
+  checkLegalBetweenMessage (ReqShowMessage _) = pure ()
+  checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
+
   -- | Check environment variables to override the config
   envOverrideConfig :: SessionConfig -> IO SessionConfig
   envOverrideConfig cfg = do
@@ -204,7 +226,7 @@ documentContents :: TextDocumentIdentifier -> Session T.Text
 documentContents doc = do
   vfs <- vfs <$> get
   let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
-  return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
+  return (virtualFileText file)
 
 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 -- and returns the new content
@@ -392,12 +414,11 @@ noDiagnostics = do
 -- | Returns the symbols in a document.
 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
 getDocumentSymbols doc = do
-  ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
-  maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
-  case mRes of
-    Just (DSDocumentSymbols (List xs)) -> return (Left xs)
-    Just (DSSymbolInformation (List xs)) -> return (Right xs)
-    Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
+  ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
+  case res of
+    Right (DSDocumentSymbols (List xs)) -> return (Left xs)
+    Right (DSSymbolInformation (List xs)) -> return (Right xs)
+    Left err -> throw (UnexpectedResponseError rspLid err)
 
 -- | Returns the code actions in the specified range.
 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
@@ -406,8 +427,8 @@ getCodeActions doc range = do
   rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
 
   case rsp ^. result of
-    Just (List xs) -> return xs
-    _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
+    Right (List xs) -> return xs
+    Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error)
 
 -- | Returns all the code actions in a document by
 -- querying the code actions at each of the current
@@ -421,13 +442,11 @@ getAllCodeActions doc = do
   where
     go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
     go ctx acc diag = do
-      ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
+      ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
 
-      case mErr of
-        Just e -> throw (UnexpectedResponseError rspLid e)
-        Nothing ->
-          let Just (List cmdOrCAs) = mRes
-            in return (acc ++ cmdOrCAs)
+      case res of
+        Left e -> throw (UnexpectedResponseError rspLid e)
+        Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
 
 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
 getCodeActionContext doc = do
@@ -561,9 +580,10 @@ getHighlights doc pos =
 -- | Checks the response for errors and throws an exception if needed.
 -- Returns the result if successful.
 getResponseResult :: ResponseMessage a -> a
-getResponseResult rsp = fromMaybe exc (rsp ^. result)
-  where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
-                                              (fromJust $ rsp ^. LSP.error)
+getResponseResult rsp =
+  case rsp ^. result of
+    Right x -> x
+    Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err
 
 -- | Applies formatting to the specified document.
 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()