X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=4ee9cf98185f4259d7ca9c0b20ffce62524f091a;hb=98ff10016bbd4eda3534ba04edcbc6e2ab9fd197;hp=9076a8e5e02e9ed819479a7d10c2f3a2d4ffc21a;hpb=133940df94b1e8745598699a492e5c9534644d75;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 9076a8e..4ee9cf9 100644
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -54,6 +54,7 @@ import Data.Default
 import Data.Foldable
 import Data.List
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.HashMap.Strict as HashMap
@@ -72,6 +73,9 @@ import System.Console.ANSI
 import System.Directory
 import System.IO
 import System.Process (ProcessHandle())
+#ifndef mingw32_HOST_OS
+import System.Process (waitForProcess)
+#endif
 import System.Timeout
 
 -- | A session representing one instance of launching and connecting to a server.
@@ -167,6 +171,7 @@ data SessionState = SessionState
   , curDynCaps :: Map.Map T.Text Registration
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
+  , curProgressSessions :: Set.Set ProgressToken
   }
 
 class Monad m => HasState s m where
@@ -257,19 +262,25 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro
   mainThreadId <- myThreadId
 
   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
-      initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty
+      initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty
       runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
       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))
+        finally (timeout msgTimeoutMs (runSession' exitServer)) $ do
           -- Make sure to kill the listener first, before closing
           -- handles etc via cleanupProcess
-                (killThread tid >> cleanupProcess server)
+          killThread tid
+          -- Give the server some time to exit cleanly
+          -- It makes the server hangs in windows so we have to avoid it
+#ifndef mingw32_HOST_OS
+          timeout msgTimeoutMs (waitForProcess serverProc)
+#endif
+          cleanupProcess server
 
   (result, _) <- bracket serverListenerLauncher
                          serverAndListenerFinalizer
@@ -283,6 +294,10 @@ updateStateC = awaitForever $ \msg -> do
 
 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
             => FromServerMessage -> m ()
+updateState (NotWorkDoneProgressBegin req) =
+  modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }
+updateState (NotWorkDoneProgressEnd req) =
+  modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }
 
 -- Keep track of dynamic capability registration
 updateState (ReqRegisterCapability req) = do
@@ -305,15 +320,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
@@ -357,11 +375,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))