Migrate indexHieFile progress notification to ProgressReporting API

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

@@ -69,7 +69,7 @@
 import           Data.Tuple.Extra                  (dupe)
 import           Data.Unique                       as Unique
 import           Debug.Trace
 import           Development.IDE.Core.FileStore    (resetInterfaceStore)
 import           Development.IDE.Core.Preprocessor
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
@@ -129,6 +129,7 @@
 #if MIN_VERSION_ghc(9,7,0)
 import           Data.Foldable                     (toList)
 import           GHC.Unit.Module.Warnings
+import Development.IDE.Core.ProgressReporting (progressReporting, ProgressReporting (..))
 #else
 import           Development.IDE.Core.FileStore    (shareFilePath)
 #endif
@@ -898,6 +899,7 @@
     _ -> do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
+      -- todo, this is the real pending count
       modifyTVar' indexPending $ HashMap.insert srcPath hash
       writeTQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
@@ -911,69 +913,20 @@
         unless newerScheduled $ do
           -- Using bracket, so even if an exception happen during withHieDb call,
           -- the `post` (which clean the progress indicator) will still be called.
-          bracket_ (pre optProgressStyle) post $
-            withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')
+          tok <- modifyVar indexProgressToken $ fmap (first Just . dupe) . \case
+              Just x -> return x
+              -- create a progressReport if we don't already have one
+              Nothing -> do
+                  tt <- progressReporting (lspEnv se) "Indexing" optProgressStyle
+                  progressUpdate tt ProgressStarted
+                  return tt
+          inProgress tok srcPath
+            (withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf'))
+            `finally` post
   where
     mod_location    = ms_location mod_summary
     targetPath      = Compat.ml_hie_file mod_location
     HieDbWriter{..} = hiedbWriter se
-
-    -- Get a progress token to report progress and update it for the current file
-    pre style = do
-      tok <- modifyVar indexProgressToken $ fmap dupe . \case
-        x@(Just _) -> pure x
-        -- Create a token if we don't already have one
-        Nothing -> do
-          case lspEnv se of
-            Nothing -> pure Nothing
-            Just env -> LSP.runLspT env $ do
-              u <- LSP.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.newUnique
-              -- TODO: Wait for the progress create response to use the token
-              _ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())
-              LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $
-                toJSON $ LSP.WorkDoneProgressBegin
-                  { _kind = LSP.AString @"begin"
-                  ,  _title = "Indexing"
-                  , _cancellable = Nothing
-                  , _message = Nothing
-                  , _percentage = Nothing
-                  }
-              pure (Just u)
-
-      (!done, !remaining) <- atomically $ do
-        done <- readTVar indexCompleted
-        remaining <- HashMap.size <$> readTVar indexPending
-        pure (done, remaining)
-      let
-        progressFrac :: Double
-        progressFrac = fromIntegral done / fromIntegral (done + remaining)
-        progressPct :: LSP.UInt
-        progressPct = floor $ 100 * progressFrac
-
-      whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $
-        LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $
-          toJSON $
-            case style of
-                Percentage -> LSP.WorkDoneProgressReport
-                    { _kind = LSP.AString @"report"
-                    , _cancellable = Nothing
-                    , _message = Nothing
-                    , _percentage = Just progressPct
-                    }
-                Explicit -> LSP.WorkDoneProgressReport
-                    { _kind = LSP.AString @"report"
-                    , _cancellable = Nothing
-                    , _message = Just $
-                        T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."
-                    , _percentage = Nothing
-                    }
-                NoProgress -> LSP.WorkDoneProgressReport
-                  { _kind = LSP.AString @"report"
-                  , _cancellable = Nothing
-                  , _message = Nothing
-                  , _percentage = Nothing
-                  }
-
     -- Report the progress once we are done indexing this file
     post = do
       mdone <- atomically $ do
@@ -988,16 +941,11 @@
         when (coerce $ ideTesting se) $
           LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
             toJSON $ fromNormalizedFilePath srcPath
-      whenJust mdone $ \done ->
+      whenJust mdone $ \_ ->
         modifyVar_ indexProgressToken $ \tok -> do
-          whenJust (lspEnv se) $ \env -> LSP.runLspT env $
-            whenJust tok $ \token ->
-              LSP.sendNotification LSP.SMethod_Progress  $ LSP.ProgressParams token $
-                toJSON $
-                LSP.WorkDoneProgressEnd
-                  { _kind = LSP.AString @"end"
-                  , _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"
-                  }
+          case tok of
+            Just token -> progressUpdate token ProgressCompleted
+            Nothing -> return ()
           -- We are done with the current indexing cycle, so destroy the token
           pure Nothing
 

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

@@ -141,7 +141,7 @@ kick = do
                 toJSON $ map fromNormalizedFilePath files
 
     signal (Proxy @"kick/start")
-    liftIO $ progressUpdate progress KickStarted
+    liftIO $ progressUpdate progress ProgressStarted
 
     -- Update the exports map
     results <- uses GenerateCore files
@@ -152,7 +152,7 @@ kick = do
     let mguts = catMaybes results
     void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts)
 
-    liftIO $ progressUpdate progress KickCompleted
+    liftIO $ progressUpdate progress ProgressCompleted
 
     GarbageCollectVar var <- getIdeGlobalAction
     garbageCollectionScheduled <- liftIO $ readVar var

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

@@ -23,7 +23,6 @@ import           Control.Monad.Trans.Class      (lift)
 import           Data.Functor                   (($>))
 import qualified Data.Text                      as T
 import           Development.IDE.GHC.Orphans    ()
-import           Development.IDE.Graph          hiding (ShakeValue)
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import qualified Focus
@@ -33,19 +32,20 @@ import           Language.LSP.Server            (ProgressAmount (..),
                                                  withProgress)
 import qualified Language.LSP.Server            as LSP
 import qualified StmContainers.Map              as STM
-import           UnliftIO                       (Async, async, cancel)
+import           UnliftIO                       (Async, MonadUnliftIO, async,
+                                                 bracket, cancel)
 
 data ProgressEvent
-    = KickStarted
-    | KickCompleted
+    = ProgressStarted
+    | ProgressCompleted
 
-data ProgressReporting  = ProgressReporting
+data ProgressReporting m = ProgressReporting
   { progressUpdate :: ProgressEvent -> IO ()
-  , inProgress     :: forall a. NormalizedFilePath -> Action a -> Action a
+  , inProgress     :: forall a. NormalizedFilePath -> m a -> m a
   , progressStop   :: IO ()
   }
 
-noProgressReporting :: IO ProgressReporting
+noProgressReporting :: IO (ProgressReporting m)
 noProgressReporting = return $ ProgressReporting
   { progressUpdate = const $ pure ()
   , inProgress = const id
@@ -63,10 +63,10 @@ data Transition = Event ProgressEvent | StopProgress
 
 updateState :: IO () -> Transition -> State -> IO State
 updateState _      _                    Stopped       = pure Stopped
-updateState start (Event KickStarted)   NotStarted    = Running <$> async start
-updateState start (Event KickStarted)   (Running job) = cancel job >> Running <$> async start
-updateState _     (Event KickCompleted) (Running job) = cancel job $> NotStarted
-updateState _     (Event KickCompleted) st            = pure st
+updateState start (Event ProgressStarted)   NotStarted    = Running <$> async start
+updateState start (Event ProgressStarted)   (Running job) = cancel job >> Running <$> async start
+updateState _     (Event ProgressCompleted) (Running job) = cancel job $> NotStarted
+updateState _     (Event ProgressCompleted) st            = pure st
 updateState _     StopProgress          (Running job) = cancel job $> Stopped
 updateState _     StopProgress          st            = pure st
 
@@ -100,11 +100,13 @@ recordProgress InProgressState{..} file shift = do
     alter x = let x' = maybe (shift 0) shift x in Just x'
 
 progressReporting
-  :: Maybe (LSP.LanguageContextEnv c)
+  :: (MonadUnliftIO m, MonadIO m)
+  => Maybe (LSP.LanguageContextEnv c)
+  -> T.Text
   -> ProgressReportingStyle
-  -> IO ProgressReporting
-progressReporting Nothing _optProgressStyle = noProgressReporting
-progressReporting (Just lspEnv) optProgressStyle = do
+  -> IO (ProgressReporting m)
+progressReporting Nothing _title  _optProgressStyle = noProgressReporting
+progressReporting (Just lspEnv) title  optProgressStyle = do
     inProgressState <- newInProgress
     progressState <- newVar NotStarted
     let progressUpdate event = updateStateVar $ Event event
@@ -115,7 +117,7 @@ progressReporting (Just lspEnv) optProgressStyle = do
     where
         lspShakeProgressNew :: InProgressState -> IO ()
         lspShakeProgressNew InProgressState{..} =
-            LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0
+            LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0
             where
                 loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
                 loop update prevPct = do
@@ -131,7 +133,7 @@ progressReporting (Just lspEnv) optProgressStyle = do
 
                     update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))
                     loop update nextPct
-        updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
+        updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const
             -- This functions are deliberately eta-expanded to avoid space leaks.
             -- Do not remove the eta-expansion without profiling a session with at
             -- least 1000 modifications.

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

@@ -125,7 +125,7 @@
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Tracing
 import           Development.IDE.Core.WorkerThread
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          initNameCache,
                                                          knownKeyNames)
 import           Development.IDE.GHC.Orphans            ()
@@ -255,7 +255,7 @@
   { indexQueue         :: IndexQueue
   , indexPending       :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing
   , indexCompleted     :: TVar Int -- ^ to report progress
-  , indexProgressToken :: Var (Maybe LSP.ProgressToken)
+  , indexProgressToken :: Var (Maybe (ProgressReporting IO))
   -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock
   }
 
@@ -306,7 +306,7 @@
     -- positions in a version of that document to positions in the latest version
     -- First mapping is delta from previous version and second one is an
     -- accumulation to the current version.
-    ,progress :: ProgressReporting
+    ,progress :: ProgressReporting Action
     ,ideTesting :: IdeTesting
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
     ,restartShakeSession
@@ -710,7 +710,7 @@
 
         progress <-
             if reportProgress
-                then progressReporting lspEnv optProgressStyle
+                then progressReporting lspEnv "Processing" optProgressStyle
                 else noProgressReporting
         actionQueue <- newQueue