Handle receiving messages in between the initialize sequence

[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 22091c3451c16f00d6848502a60dafc0a9edd928..b3f535f3ca59f1616cee0bfb1dc1898ff68e1472 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -37,6 +37,7 @@ module Language.Haskell.LSP.Test
   , module Language.Haskell.LSP.Test.Parsing
   -- * Utilities
   -- | Quick helper functions for common tasks.
+
   -- ** Initialization
   , initializeResponse
   -- ** Documents
@@ -109,10 +110,10 @@ import Language.Haskell.LSP.Test.Exceptions
 import Language.Haskell.LSP.Test.Parsing
 import Language.Haskell.LSP.Test.Session
 import Language.Haskell.LSP.Test.Server
+import System.Environment
 import System.IO
 import System.Directory
 import System.FilePath
-import qualified Data.Rope.UTF16 as Rope
 
 -- | Starts a new session.
 --
@@ -136,10 +137,12 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session
                      -> FilePath -- ^ The filepath to the root directory for the session.
                      -> Session a -- ^ The session to run.
                      -> IO a
-runSessionWithConfig config serverExe caps rootDir session = do
+runSessionWithConfig config' serverExe caps rootDir session = do
   pid <- getCurrentProcessID
   absRootDir <- canonicalizePath rootDir
 
+  config <- envOverrideConfig config'
+
   let initializeParams = InitializeParams (Just pid)
                                           (Just $ T.pack absRootDir)
                                           (Just $ filePathToUri absRootDir)
@@ -150,7 +153,12 @@ 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
+
+      -- Because messages can be sent in between the request and response,
+      -- collect them and then...
+      (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
 
       liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 
@@ -162,6 +170,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
@@ -184,12 +198,33 @@ 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
+    logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
+    logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
+    return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
+    where checkEnv :: String -> IO (Maybe Bool)
+          checkEnv s = fmap convertVal <$> lookupEnv s
+          convertVal "0" = False
+          convertVal _ = True
+
 -- | The current text contents of a document.
 documentContents :: TextDocumentIdentifier -> Session T.Text
 documentContents doc = do
   vfs <- vfs <$> get
-  let file = vfs Map.! toNormalizedUri (doc ^. uri)
-  return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
+  let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
+  return (virtualFileText file)
 
 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 -- and returns the new content
@@ -273,7 +308,7 @@ sendNotification TextDocumentDidOpen params = do
       n :: DidOpenTextDocumentNotification
       n = NotificationMessage "2.0" TextDocumentDidOpen params'
   oldVFS <- vfs <$> get
-  newVFS <- liftIO $ openVFS oldVFS n
+  let (newVFS,_) = openVFS oldVFS n
   modify (\s -> s { vfs = newVFS })
   sendMessage n
 
@@ -283,7 +318,7 @@ sendNotification TextDocumentDidClose params = do
       n :: DidCloseTextDocumentNotification
       n = NotificationMessage "2.0" TextDocumentDidClose params'
   oldVFS <- vfs <$> get
-  newVFS <- liftIO $ closeVFS oldVFS n
+  let (newVFS,_) = closeVFS oldVFS n
   modify (\s -> s { vfs = newVFS })
   sendMessage n
 
@@ -292,7 +327,7 @@ sendNotification TextDocumentDidChange params = do
         n :: DidChangeTextDocumentNotification
         n = NotificationMessage "2.0" TextDocumentDidChange params'
     oldVFS <- vfs <$> get
-    newVFS <- liftIO $ changeFromClientVFS oldVFS n
+    let (newVFS,_) = changeFromClientVFS oldVFS n
     modify (\s -> s { vfs = newVFS })
     sendMessage n
 
@@ -449,10 +484,10 @@ executeCodeAction action = do
 -- | Adds the current version to the document, as tracked by the session.
 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
 getVersionedDoc (TextDocumentIdentifier uri) = do
-  fs <- vfs <$> get
+  fs <- vfsMap . vfs <$> get
   let ver =
         case fs Map.!? toNormalizedUri uri of
-          Just (VirtualFile v _ _) -> Just v
+          Just vf -> Just (virtualFileVersion vf)
           _ -> Nothing
   return (VersionedTextDocumentIdentifier uri ver)