track progress sessions

[lsp-test.git] / src / Language / LSP / Test / Session.hs

diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs
index 5839a15619a18963296a35d632a1f4233a95944c..4e3b1777298c78e4024f526aa37b36de3a56bacf 100644 (file)
--- a/src/Language/LSP/Test/Session.hs
+++ b/src/Language/LSP/Test/Session.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
 
 module Language.LSP.Test.Session
   ( Session(..)
@@ -28,6 +29,7 @@ module Language.LSP.Test.Session
   , bumpTimeoutId
   , logMsg
   , LogMsgType(..)
+  , documentChangeUri
   )
 
 where
@@ -55,6 +57,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
@@ -134,7 +137,7 @@ data SessionContext = SessionContext
   -- Keep curTimeoutId in SessionContext, as its tied to messageChan
   , curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on
   , requestMap :: MVar RequestMap
-  , initRsp :: MVar InitializeResponse
+  , initRsp :: MVar (ResponseMessage Initialize)
   , config :: SessionConfig
   , sessionCapabilities :: ClientCapabilities
   }
@@ -173,6 +176,7 @@ data SessionState = SessionState
   , curDynCaps :: Map.Map T.Text SomeRegistration
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
+  , curProgressSessions :: Set.Set ProgressToken
   }
 
 class Monad m => HasState s m where
@@ -263,7 +267,7 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
   mainThreadId <- myThreadId
 
   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
-      initState vfs = SessionState 0 vfs mempty False Nothing mempty
+      initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty
       runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
@@ -274,7 +278,10 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
         let cleanup
               | Just sp <- mServerProc = do
                   -- 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 sp)
+#endif
                   cleanupProcess (Just serverIn, Just serverOut, Nothing, sp)
               | otherwise = pure ()
         finally (timeout msgTimeoutMs (runSession' exitServer))
@@ -292,8 +299,22 @@ updateStateC = awaitForever $ \msg -> do
   updateState msg
   yield msg
 
+-- extract Uri out from DocumentChange
+-- didn't put this in `lsp-types` because TH was getting in the way
+documentChangeUri :: DocumentChange -> Uri
+documentChangeUri (InL x) = x ^. textDocument . uri
+documentChangeUri (InR (InL x)) = x ^. uri
+documentChangeUri (InR (InR (InL x))) = x ^. oldUri
+documentChangeUri (InR (InR (InR x))) = x ^. uri
+
 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
             => FromServerMessage -> m ()
+updateState (FromServerMess SProgress req) = case req ^. params . value of
+  Begin _ ->
+    modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }
+  End _ ->
+    modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }
+  _ -> pure ()
 
 -- Keep track of dynamic capability registration
 updateState (FromServerMess SClientRegisterCapability req) = do
@@ -319,8 +340,8 @@ updateState (FromServerMess SWorkspaceApplyEdit 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
+      mapM_ (checkIfNeedsOpened . documentChangeUri) cs
+      return $ mapMaybe getParamsFromDocumentChange cs
     -- Then fall back to the changes field
     Nothing -> case r ^. params . edit . changes of
       Just cs -> do
@@ -367,10 +388,16 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
               let (newVFS,_) = openVFS (vfs s) msg
               return $ s { vfs = newVFS }
 
-        getParams (TextDocumentEdit docId (List edits)) =
+        getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
+        getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = 
           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
             in DidChangeTextDocumentParams docId (List changeEvents)
 
+        getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams
+        getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit
+        getParamsFromDocumentChange _ = Nothing
+
+
         -- For a uri returns an infinite list of versions [n,n+1,n+2,...]
         -- where n is the current version
         textDocumentVersions uri = do
@@ -383,8 +410,8 @@ updateState (FromServerMess SWorkspaceApplyEdit r) = do
           vers <- textDocumentVersions uri
           pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits
 
-        getChangeParams uri (List edits) =
-          map <$> pure getParams <*> textDocumentEdits uri (reverse edits)
+        getChangeParams uri (List edits) = do 
+          map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits)
 
         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))