diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 928e2f09cf..ff8f5f1c0c 100644 --- 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 index c67c2e6c5e..4965cb8b82 100644 --- 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 index c09bd4a40b..612d2c743b 100644 --- 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 index 58e0e8bbe8..e35e83da41 100644 --- 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