X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=4b93e71bb5843c2f99fccf8f93bc5b2ade98dd4a;hb=23b1dcf20f37869d29158ebc38402503894bcd80;hp=56e206d8bc8d1681cc4b5b3440fdae1a9b1db1c3;hpb=71f5ececdaa02c87b026c40d70fb55c4a0d05044;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 56e206d..4b93e71 100644
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -71,7 +71,7 @@ import Language.Haskell.LSP.Test.Exceptions
 import System.Console.ANSI
 import System.Directory
 import System.IO
-import System.Process (ProcessHandle())
+import System.Process (waitForProcess, ProcessHandle())
 import System.Timeout
 
 -- | A session representing one instance of launching and connecting to a server.
@@ -264,10 +264,15 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro
       serverListenerLauncher =
         forkIO $ catch (serverHandler serverOut context) errorHandler
       server = (Just serverIn, Just serverOut, Nothing, serverProc)
+      msgTimeoutMs = messageTimeout config * 10^6
       serverAndListenerFinalizer tid = do
-        finally (timeout (messageTimeout config * 1^6)
-                         (runSession' exitServer))
-                (cleanupProcess server >> killThread tid)
+        finally (timeout msgTimeoutMs (runSession' exitServer)) $ do
+          -- Make sure to kill the listener first, before closing
+          -- handles etc via cleanupProcess
+          killThread tid
+          -- Give the server some time to exit cleanly
+          timeout msgTimeoutMs (waitForProcess serverProc)
+          cleanupProcess server
 
   (result, _) <- bracket serverListenerLauncher
                          serverAndListenerFinalizer
@@ -303,15 +308,18 @@ updateState (NotPublishDiagnostics n) = do
 
 updateState (ReqApplyWorkspaceEdit r) = do
 
+  -- First, prefer the versioned documentChanges field
   allChangeParams <- case r ^. params . edit . documentChanges of
     Just (List cs) -> do
       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
       return $ map getParams cs
+    -- Then fall back to the changes field
     Nothing -> case r ^. params . edit . changes of
       Just cs -> do
         mapM_ checkIfNeedsOpened (HashMap.keys cs)
-        return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
-      Nothing -> error "No changes!"
+        concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs)
+      Nothing ->
+        error "WorkspaceEdit contains neither documentChanges nor changes!"
 
   modifyM $ \s -> do
     newVFS <- liftIO $ changeFromServerVFS (vfs s) r
@@ -355,11 +363,20 @@ updateState (ReqApplyWorkspaceEdit r) = do
           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
             in DidChangeTextDocumentParams docId (List changeEvents)
 
-        textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]
+        -- For a uri returns an infinite list of versions [n,n+1,n+2,...]
+        -- where n is the current version
+        textDocumentVersions uri = do
+          m <- vfsMap . vfs <$> get
+          let curVer = fromMaybe 0 $
+                _lsp_version <$> m Map.!? (toNormalizedUri uri)
+          pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..]
 
-        textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
+        textDocumentEdits uri edits = do
+          vers <- textDocumentVersions uri
+          pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits
 
-        getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
+        getChangeParams uri (List edits) =
+          map <$> pure getParams <*> textDocumentEdits uri (reverse edits)
 
         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))