Merge pull request #84 from wz1000/progress

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

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 4b93e71bb5843c2f99fccf8f93bc5b2ade98dd4a..4ee9cf98185f4259d7ca9c0b20ffce62524f091a 100644 (file)
--- 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
@@ -71,7 +72,10 @@ import Language.Haskell.LSP.Test.Exceptions
 import System.Console.ANSI
 import System.Directory
 import System.IO
-import System.Process (waitForProcess, ProcessHandle())
+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,7 +262,7 @@ 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 ()
@@ -271,7 +276,10 @@ runSessionWithHandles serverIn serverOut serverProc serverHandler config caps ro
           -- handles etc via cleanupProcess
           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
@@ -286,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