Civilized indexing progress reporting (haskell#1633)

* Civilized indexing progress reporting * optProgressStyle * Consistency: Indexing references ==> Indexing * Fix progress tests
berberman · Apr 4, 2021 · f0b89fd · f0b89fd
1 parent 6089686
commit f0b89fd
Show file tree

Hide file tree

Showing 4 changed files with 61 additions and 26 deletions.
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -507,7 +507,9 @@ spliceExpresions Splices{..} =
 -- can just increment the 'indexCompleted' TVar and exit.
 --
 indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO ()
-indexHieFile se mod_summary srcPath hash hf = atomically $ do
+indexHieFile se mod_summary srcPath hash hf = do
+ IdeOptions{optProgressStyle} <- getIdeOptionsIO se
+ atomically $ do
   pending <- readTVar indexPending
   case HashMap.lookup srcPath pending of
     Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled
@@ -523,7 +525,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
             -- If the hash in the pending list doesn't match the current hash, then skip
             Just pendingHash -> pendingHash /= hash
         unless newerScheduled $ do
-          pre
+          pre optProgressStyle
           addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf
           post
   where
@@ -532,7 +534,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
     HieDbWriter{..} = hiedbWriter se
 
     -- Get a progress token to report progress and update it for the current file
-    pre = do
+    pre style = do
       tok <- modifyVar indexProgressToken $ fmap dupe . \case
         x@(Just _) -> pure x
         -- Create a token if we don't already have one
@@ -545,7 +547,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
               _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())
               LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $
                 LSP.Begin $ LSP.WorkDoneProgressBeginParams
-                  { _title = "Indexing references from:"
+                  { _title = "Indexing"
                   , _cancellable = Nothing
                   , _message = Nothing
                   , _percentage = Nothing
@@ -557,15 +559,26 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
         remaining <- HashMap.size <$> readTVar indexPending
         pure (done, remaining)
 
-      let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."
-
       whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $
         LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $
-          LSP.Report $ LSP.WorkDoneProgressReportParams
-            { _cancellable = Nothing
-            , _message = Just $ T.pack (fromNormalizedFilePath srcPath) <> progress
-            , _percentage = Nothing
-            }
+          LSP.Report $
+            case style of
+                Percentage -> LSP.WorkDoneProgressReportParams
+                    { _cancellable = Nothing
+                    , _message = Nothing
+                    , _percentage = Just (100 * fromIntegral done / fromIntegral (done + remaining) )
+                    }
+                Explicit -> LSP.WorkDoneProgressReportParams
+                    { _cancellable = Nothing
+                    , _message = Just $
+                        T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."
+                    , _percentage = Nothing
+                    }
+                NoProgress -> LSP.WorkDoneProgressReportParams
+                  { _cancellable = Nothing
+                  , _message = Nothing
+                  , _percentage = Nothing
+                  }
 
     -- Report the progress once we are done indexing this file
     post = do

diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
@@ -499,7 +499,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
         let hiedbWriter = HieDbWriter{..}
         progressAsync <- async $
             when reportProgress $
-                progressThread mostRecentProgressEvent inProgress
+                progressThread optProgressStyle mostRecentProgressEvent inProgress
         exportsMap <- newVar mempty
 
         actionQueue <- newQueue
@@ -517,7 +517,10 @@ shakeOpen lspEnv defaultConfig logger debouncer
     shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir
     let ideState = IdeState{..}
 
-    IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras
+    IdeOptions
+        { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled
+        , optProgressStyle
+        } <- getIdeOptionsIO shakeExtras
     startTelemetry otProfilingEnabled logger $ state shakeExtras
 
     return ideState
@@ -528,7 +531,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
         -- And two transitions, modelled by 'ProgressEvent':
         --   1. KickCompleted - transitions from Reporting into Idle
         --   2. KickStarted - transitions from Idle into Reporting
-        progressThread mostRecentProgressEvent inProgress = progressLoopIdle
+        progressThread style mostRecentProgressEvent inProgress = progressLoopIdle
           where
             progressLoopIdle = do
                 atomically $ do
@@ -560,7 +563,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
                 bracket_
                   (start u)
                   (stop u)
-                  (loop u Nothing)
+                  (loop u 0)
                 where
                     start id = LSP.sendNotification LSP.SProgress $
                         LSP.ProgressParams
@@ -585,16 +588,27 @@ shakeOpen lspEnv defaultConfig logger debouncer
                         current <- liftIO $ readVar inProgress
                         let done = length $ filter (== 0) $ HMap.elems current
                         let todo = HMap.size current
-                        let next = Just $ T.pack $ show done <> "/" <> show todo
+                        let next = 100 * fromIntegral done / fromIntegral todo
                         when (next /= prev) $
                           LSP.sendNotification LSP.SProgress $
                           LSP.ProgressParams
                               { _token = id
-                              , _value = LSP.Report $ LSP.WorkDoneProgressReportParams
-                                { _cancellable = Nothing
-                                , _message = next
-                                , _percentage = Nothing
-                                }
+                              , _value = LSP.Report $ case style of
+                                  Explicit -> LSP.WorkDoneProgressReportParams
+                                    { _cancellable = Nothing
+                                    , _message = Just $ T.pack $ show done <> "/" <> show todo
+                                    , _percentage = Nothing
+                                    }
+                                  Percentage -> LSP.WorkDoneProgressReportParams
+                                    { _cancellable = Nothing
+                                    , _message = Nothing
+                                    , _percentage = Just next
+                                    }
+                                  NoProgress -> LSP.WorkDoneProgressReportParams
+                                    { _cancellable = Nothing
+                                    , _message = Nothing
+                                    , _percentage = Nothing
+                                    }
                               }
                         loop id next
 

diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs
@@ -16,6 +16,7 @@ module Development.IDE.Types.Options
   , IdeResult
   , IdeGhcSession(..)
   , OptHaddockParse(..)
+  , ProgressReportingStyle(..)
   ,optShakeFiles) where
 
 import qualified Data.Text                         as T
@@ -78,6 +79,7 @@ data IdeOptions = IdeOptions
   , optShakeOptions       :: ShakeOptions
   , optSkipProgress       :: forall a. Typeable a => a -> Bool
       -- ^ Predicate to select which rule keys to exclude from progress reporting.
+  , optProgressStyle      :: ProgressReportingStyle
   }
 
 optShakeFiles :: IdeOptions -> Maybe FilePath
@@ -104,6 +106,12 @@ newtype IdeDefer             = IdeDefer          Bool
 newtype IdeTesting           = IdeTesting        Bool
 newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling    Bool
 
+data ProgressReportingStyle
+    = Percentage -- ^ Report using the LSP @_percentage@ field
+    | Explicit   -- ^ Report using explicit 123/456 text
+    | NoProgress -- ^ Do not report any percentage
+
+
 clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
 clientSupportsProgress caps = IdeReportProgress $ Just True ==
     (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
@@ -131,6 +139,7 @@ defaultIdeOptions session = IdeOptions
     ,optHaddockParse = HaddockParse
     ,optCustomDynFlags = id
     ,optSkipProgress = defaultSkipProgress
+    ,optProgressStyle = Explicit
     }
 
 defaultSkipProgress :: Typeable a => a -> Bool

diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs
@@ -28,11 +28,11 @@ tests =
             runSession hlsCommand progressCaps "test/testdata" $ do
                 let path = "hlint" </> "ApplyRefact2.hs"
                 _ <- openDoc path "haskell"
-                expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing"]
+                expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing", "Indexing"]
         , testCase "eval plugin sends progress reports" $
             runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do
                 doc <- openDoc "T1.hs" "haskell"
-                expectProgressReports ["Setting up testdata (for T1.hs)", "Processing"]
+                expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"]
                 [evalLens] <- getCodeLenses doc
                 let cmd = evalLens ^?! L.command . _Just
                 _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments)
@@ -41,14 +41,14 @@ tests =
             runSession hlsCommand progressCaps "test/testdata/format" $ do
                 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu"))
                 doc <- openDoc "Format.hs" "haskell"
-                expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
+                expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"]
                 _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
                 expectProgressReports ["Formatting Format.hs"]
         , testCase "fourmolu plugin sends progress notifications" $ do
             runSession hlsCommand progressCaps "test/testdata/format" $ do
                 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu"))
                 doc <- openDoc "Format.hs" "haskell"
-                expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"]
+                expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"]
                 _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
                 expectProgressReports ["Formatting Format.hs"]
         , ignoreTestBecause "no liquid Haskell support" $
@@ -90,7 +90,6 @@ expectProgressReports xs = expectProgressReports' [] xs
                 CreateM msg ->
                     expectProgressReports' (token msg : tokens) expectedTitles
                 BeginM msg -> do
-                    liftIO $ title msg `expectElem` ("Indexing references from:":xs)
                     liftIO $ token msg `expectElem` tokens
                     expectProgressReports' tokens (delete (title msg) expectedTitles)
                 ProgressM msg -> do