From 7acc4562785745a116a14b96d64fafb0998075f4 Mon Sep 17 00:00:00 2001
From: Zubin Duggal <zubin@cmi.ac.in>
Date: Mon, 25 Jan 2021 02:51:35 +0530
Subject: [PATCH] track progress sessions

---
 src/Language/Haskell/LSP/Test.hs         | 6 ++++++
 src/Language/Haskell/LSP/Test/Session.hs | 8 +++++++-
 2 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index dbfc801..19baf96 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -56,6 +56,7 @@ module Language.Haskell.LSP.Test
   , waitForDiagnosticsSource
   , noDiagnostics
   , getCurrentDiagnostics
+  , getIncompleteProgressSessions
   -- ** Commands
   , executeCommand
   -- ** Code Actions
@@ -93,6 +94,7 @@ import Control.Monad.IO.Class
 import Control.Exception
 import Control.Lens hiding ((.=), List)
 import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
@@ -517,6 +519,10 @@ getCodeActionContext doc = do
 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
 
+-- | Returns the tokens of all progress sessions that have started but not yet ended.
+getIncompleteProgressSessions :: Session (Set.Set ProgressToken)
+getIncompleteProgressSessions = curProgressSessions <$> get
+
 -- | Executes a command.
 executeCommand :: Command -> Session ()
 executeCommand cmd = do
diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 9e4aa81..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
@@ -170,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
@@ -260,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 ()
@@ -292,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
-- 
2.30.2