Enhance testing progress reporting

- Introduce TestReporting style for progress reporting in IDE options.

Author: soulomoon

ghcide/src/Development/IDE/Core/ProgressReporting.hs

@@ -23,24 +23,31 @@ import           Control.Concurrent.STM         (STM)
 import           Control.Concurrent.STM.Stats   (TVar, atomically,
                                                  atomicallyNamed, modifyTVar',
                                                  newTVarIO, readTVar, retry)
-import           Control.Concurrent.Strict      (modifyVar_, newVar,
-                                                 threadDelay)
+import           Control.Concurrent.Strict      (modifyVar_, newBarrier, newVar,
+                                                 signalBarrier, threadDelay,
+                                                 waitBarrier)
 import           Control.Monad.Extra            hiding (loop)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      (lift)
+import qualified Data.Aeson                     as J
 import           Data.Functor                   (($>))
 import qualified Data.Text                      as T
+import           Data.Unique                    (hashUnique, newUnique)
 import           Development.IDE.GHC.Orphans    ()
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import qualified Focus
+import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import           Language.LSP.Server            (ProgressAmount (..),
+import qualified Language.LSP.Protocol.Types    as L
+import           Language.LSP.Server            (MonadLsp, ProgressAmount (..),
                                                  ProgressCancellable (..),
+                                                 sendNotification, sendRequest,
                                                  withProgress)
 import qualified Language.LSP.Server            as LSP
 import qualified StmContainers.Map              as STM
 import           UnliftIO                       (Async, async, bracket, cancel)
+import qualified UnliftIO.Exception             as UE
 
 data ProgressEvent
   = ProgressNewStarted
@@ -168,7 +175,7 @@ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do
   let _progressUpdate event = liftIO $ updateStateVar $ Event event
       _progressStop = updateStateVar StopProgress
       updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done)
-  return ProgressReporting {..}
+  return ProgressReporting {_progressUpdate, _progressStop}
 
 -- | `progressReporting` initiates a new progress reporting session.
 -- It necessitates the active tracking of progress using the `inProgress` function.
@@ -196,6 +203,25 @@ progressReporting (Just lspEnv) title optProgressStyle = do
 
         f = recordProgress inProgress file
 
+withProgressDummy ::
+  forall c m a.
+  MonadLsp c m =>
+  T.Text ->
+  Maybe ProgressToken ->
+  ProgressCancellable ->
+  ((ProgressAmount -> m ()) -> m a) ->
+  m a
+withProgressDummy title _ _ f = do
+    t <- L.ProgressToken . L.InR . T.pack . show . hashUnique <$> liftIO newUnique
+    r <- liftIO newBarrier
+    _ <- sendRequest SMethod_WindowWorkDoneProgressCreate (WorkDoneProgressCreateParams t) $
+        \_ -> liftIO $ signalBarrier r ()
+    -- liftIO $ waitBarrier r
+    sendProgressReport t $ WorkDoneProgressBegin L.AString title Nothing Nothing Nothing
+    f (const $ return ()) `UE.finally` sendProgressReport t (WorkDoneProgressEnd L.AString Nothing)
+  where
+    sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report
+
 -- Kill this to complete the progress session
 progressCounter ::
   LSP.LanguageContextEnv c ->
@@ -205,8 +231,12 @@ progressCounter ::
   STM Int ->
   IO ()
 progressCounter lspEnv title optProgressStyle getTodo getDone =
-  LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0
+  LSP.runLspT lspEnv $ withProgressChoice title Nothing NotCancellable $ \update -> loop update 0
   where
+    withProgressChoice = case optProgressStyle of
+        TestReporting -> withProgressDummy
+        _             -> withProgress
+
     loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
     loop update prevPct = do
       (todo, done, nextPct) <- liftIO $ atomically $ do

ghcide/src/Development/IDE/Main.hs

@@ -77,8 +77,9 @@ import           Development.IDE.Types.Location           (NormalizedUri,
                                                            toNormalizedFilePath')
 import           Development.IDE.Types.Monitoring         (Monitoring)
 import           Development.IDE.Types.Options            (IdeGhcSession,
-                                                           IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
+                                                           IdeOptions (..),
                                                            IdeTesting (IdeTesting),
+                                                           ProgressReportingStyle (TestReporting),
                                                            clientSupportsProgress,
                                                            defaultIdeOptions,
                                                            optModifyDynFlags,
@@ -276,7 +277,10 @@ testing recorder projectRoot plugins =
       let
         defOptions = argsIdeOptions config sessionLoader
       in
-        defOptions{ optTesting = IdeTesting True }
+        defOptions{
+            optTesting = IdeTesting True
+            , optProgressStyle = TestReporting
+            }
     lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }
   in
     arguments

ghcide/src/Development/IDE/Types/Options.hs

@@ -107,6 +107,7 @@ newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling    Bool
 data ProgressReportingStyle
     = Percentage -- ^ Report using the LSP @_percentage@ field
     | Explicit   -- ^ Report using explicit 123/456 text
+    | TestReporting -- ^ Special mode for testing, reports only start/stop
     | NoProgress -- ^ Do not report any percentage
     deriving Eq