diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 62f43dd91d..a8dad581bc 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -67,7 +67,6 @@ import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra (dupe) -import Data.Unique as Unique import Debug.Trace import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor @@ -81,6 +80,7 @@ import Development.IDE.GHC.Compat hiding (assert, import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.Core.ProgressReporting (ProgressReporting (..), progressReportingOutsideState) import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () @@ -97,7 +97,6 @@ import GHC.Serialized import HieDb hiding (withHieDb) import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types (DiagnosticTag (..)) -import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Prelude hiding (mod) import System.Directory @@ -785,7 +784,6 @@ spliceExpressions Splices{..} = -- indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do - IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do pending <- readTVar indexPending case HashMap.lookup srcPath pending of @@ -806,69 +804,14 @@ indexHieFile se mod_summary srcPath !hash hf = do 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 $ + bracket_ pre post $ withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') 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 - } - + pre = progressUpdate indexProgressReporting ProgressStarted -- Report the progress once we are done indexing this file post = do mdone <- atomically $ do @@ -883,18 +826,7 @@ indexHieFile se mod_summary srcPath !hash hf = do when (coerce $ ideTesting se) $ LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath srcPath - whenJust mdone $ \done -> - 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" - } - -- We are done with the current indexing cycle, so destroy the token - pure Nothing + whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index abcf6342a8..e85bfeaac2 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/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 + progressUpdate progress ProgressNewStarted -- 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 + progressUpdate progress ProgressCompleted GarbageCollectVar var <- getIdeGlobalAction garbageCollectionScheduled <- liftIO $ readVar var diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index b8c8a34d6f..7815a984ca 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -1,17 +1,19 @@ module Development.IDE.Core.ProgressReporting - ( ProgressEvent(..) - , ProgressReporting(..) - , noProgressReporting - , progressReporting - -- utilities, reexported for use in Core.Shake - , mRunLspT - , mRunLspTCallback - -- for tests - , recordProgress - , InProgressState(..) + ( ProgressEvent (..), + ProgressReporting (..), + noProgressReporting, + progressReporting, + progressReportingOutsideState, + -- utilities, reexported for use in Core.Shake + mRunLspT, + mRunLspTCallback, + -- for tests + recordProgress, + InProgressState (..), ) - where +where +import Control.Concurrent.STM (STM) import Control.Concurrent.STM.Stats (TVar, atomically, atomicallyNamed, modifyTVar', newTVarIO, readTVar, retry) @@ -23,7 +25,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,119 +34,197 @@ 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 + = ProgressNewStarted + | ProgressCompleted + | ProgressStarted -data ProgressReporting = ProgressReporting - { progressUpdate :: ProgressEvent -> IO () - , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a - , progressStop :: IO () +data ProgressReporting m = ProgressReporting + { progressUpdate :: ProgressEvent -> m (), + inProgress :: forall a. NormalizedFilePath -> m a -> m a, + -- ^ see Note [ProgressReporting API and InProgressState] + progressStop :: IO () + -- ^ we are using IO here because creating and stopping the `ProgressReporting` + -- is different from how we use it. } -noProgressReporting :: IO ProgressReporting -noProgressReporting = return $ ProgressReporting - { progressUpdate = const $ pure () - , inProgress = const id - , progressStop = pure () - } +{- Note [ProgressReporting API and InProgressState] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The progress of tasks can be tracked in two ways: + +1. `InProgressState`: This is an internal state that actively tracks the progress. + Changes to the progress are made directly to this state. + +2. `InProgressStateOutSide`: This is an external state that tracks the progress. + The external state is converted into an STM Int for the purpose of reporting progress. + +The `inProgress` function is only useful when we are using `InProgressState`. + +An alternative design could involve using GADTs to eliminate this discrepancy between +`InProgressState` and `InProgressStateOutSide`. +-} + +noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) +noProgressReporting = + return $ + ProgressReporting + { progressUpdate = const $ pure (), + inProgress = const id, + progressStop = pure () + } -- | State used in 'delayedProgressReporting' data State - = NotStarted - | Stopped - | Running (Async ()) + = NotStarted + | Stopped + | Running (Async ()) -- | State transitions used in 'delayedProgressReporting' 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 _ StopProgress (Running job) = cancel job $> Stopped -updateState _ StopProgress st = pure st +updateState _ _ Stopped = pure Stopped +updateState start (Event ProgressNewStarted) NotStarted = Running <$> async start +updateState start (Event ProgressNewStarted) (Running job) = cancel job >> Running <$> async start +updateState start (Event ProgressStarted) NotStarted = Running <$> async start +updateState _ (Event ProgressStarted) (Running job) = return (Running job) +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 -- | Data structure to track progress across the project -data InProgressState = InProgressState - { todoVar :: TVar Int -- ^ Number of files to do - , doneVar :: TVar Int -- ^ Number of files done - , currentVar :: STM.Map NormalizedFilePath Int - } +-- see Note [ProgressReporting API and InProgressState] +data InProgressState + = InProgressState + { -- | Number of files to do + todoVar :: TVar Int, + -- | Number of files done + doneVar :: TVar Int, + currentVar :: STM.Map NormalizedFilePath Int + } + | InProgressStateOutSide + -- we transform the outside state into STM Int for progress reporting purposes + { -- | Number of files to do + todo :: STM Int, + -- | Number of files done + done :: STM Int + } newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () -recordProgress InProgressState{..} file shift = do - (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar - atomicallyNamed "recordProgress2" $ do - case (prev,new) of - (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1) - (Nothing,_) -> modifyTVar' todoVar (+1) - (Just 0, 0) -> pure () - (Just 0, _) -> modifyTVar' doneVar pred - (Just _, 0) -> modifyTVar' doneVar (+1) - (Just _, _) -> pure () +recordProgress InProgressStateOutSide {} _ _ = return () +recordProgress InProgressState {..} file shift = do + (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar + atomicallyNamed "recordProgress2" $ do + case (prev, new) of + (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1) + (Nothing, _) -> modifyTVar' todoVar (+ 1) + (Just 0, 0) -> pure () + (Just 0, _) -> modifyTVar' doneVar pred + (Just _, 0) -> modifyTVar' doneVar (+ 1) + (Just _, _) -> pure () where alterPrevAndNew = do - prev <- Focus.lookup - Focus.alter alter - new <- Focus.lookupWithDefault 0 - return (prev, new) + prev <- Focus.lookup + Focus.alter alter + new <- Focus.lookupWithDefault 0 + return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' -progressReporting - :: Maybe (LSP.LanguageContextEnv c) - -> ProgressReportingStyle - -> IO ProgressReporting -progressReporting Nothing _optProgressStyle = noProgressReporting -progressReporting (Just lspEnv) optProgressStyle = do - inProgressState <- newInProgress - progressState <- newVar NotStarted - let progressUpdate event = updateStateVar $ Event event - progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) - inProgress = updateStateForFile inProgressState - return ProgressReporting{..} - where - lspShakeProgressNew :: InProgressState -> IO () - lspShakeProgressNew InProgressState{..} = - LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0 - where - loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound - loop update prevPct = do - (todo, done, nextPct) <- liftIO $ atomically $ do - todo <- readTVar todoVar - done <- readTVar doneVar - let nextFrac :: Double - nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo - nextPct :: UInt - nextPct = floor $ 100 * nextFrac - when (nextPct == prevPct) retry - pure (todo, done, nextPct) - - _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) - loop update nextPct - updateStateForFile inProgress file = actionBracket (f succ) (const $ 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. - where - f shift = recordProgress inProgress file shift - -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () + +-- | `progressReporting` initiates a new progress reporting session. +-- It necessitates the active tracking of progress using the `inProgress` function. +-- Refer to Note [ProgressReporting API and InProgressState] for more details. +progressReporting :: + (MonadUnliftIO m, MonadIO m) => + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO (ProgressReporting m) +progressReporting = progressReporting' newInProgress + +-- | `progressReportingOutsideState` initiates a new progress reporting session. +-- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking. +-- Refer to Note [ProgressReporting API and InProgressState] for more details. +progressReportingOutsideState :: + (MonadUnliftIO m, MonadIO m) => + STM Int -> + STM Int -> + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO (ProgressReporting m) +progressReportingOutsideState todo done = progressReporting' (pure $ InProgressStateOutSide todo done) + +progressReporting' :: + (MonadUnliftIO m, MonadIO m) => + IO InProgressState -> + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO (ProgressReporting m) +progressReporting' _newState Nothing _title _optProgressStyle = noProgressReporting +progressReporting' newState (Just lspEnv) title optProgressStyle = do + inProgressState <- newState + progressState <- newVar NotStarted + let progressUpdate event = liftIO $ updateStateVar $ Event event + progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) + inProgress = updateStateForFile inProgressState + return ProgressReporting {..} + where + lspShakeProgressNew :: InProgressState -> IO () + lspShakeProgressNew InProgressStateOutSide {..} = progressCounter lspEnv title optProgressStyle todo done + lspShakeProgressNew InProgressState {..} = progressCounter lspEnv title optProgressStyle (readTVar todoVar) (readTVar doneVar) + updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const + where + -- 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. + + f shift = recordProgress inProgress file shift + +-- Kill this to complete the progress session +progressCounter :: + LSP.LanguageContextEnv c -> + T.Text -> + ProgressReportingStyle -> + STM Int -> + STM Int -> + IO () +progressCounter lspEnv title optProgressStyle getTodo getDone = + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 + where + loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound + loop update prevPct = do + (todo, done, nextPct) <- liftIO $ atomically $ do + todo <- getTodo + done <- getDone + let nextFrac :: Double + nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo + nextPct :: UInt + nextPct = floor $ 100 * nextFrac + when (nextPct == prevPct) retry + pure (todo, done, nextPct) + + _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + loop update nextPct + +mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f mRunLspT Nothing _ = pure () -mRunLspTCallback :: Monad m - => Maybe (LSP.LanguageContextEnv c) - -> (LSP.LspT c m a -> LSP.LspT c m a) - -> m a - -> m a +mRunLspTCallback :: + (Monad m) => + Maybe (LSP.LanguageContextEnv c) -> + (LSP.LspT c m a -> LSP.LspT c m a) -> + m a -> + m a mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) mRunLspTCallback Nothing _ g = g diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d8f162b43e..7c53b09c7b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -244,11 +244,10 @@ instance Pretty Log where -- a worker thread. data HieDbWriter = HieDbWriter - { 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) - -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock + { indexQueue :: IndexQueue + , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing + , indexCompleted :: TVar Int -- ^ to report progress + , indexProgressReporting :: ProgressReporting IO } -- | Actions to queue up on the index worker thread @@ -298,7 +297,7 @@ data ShakeExtras = ShakeExtras -- 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 @@ -680,7 +679,10 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 semanticTokensId <- newTVarIO 0 - indexProgressToken <- newVar Nothing + indexProgressReporting <- progressReportingOutsideState + (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted)) + (readTVar indexCompleted) + lspEnv "Indexing" optProgressStyle let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb @@ -693,7 +695,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer progress <- if reportProgress - then progressReporting lspEnv optProgressStyle + then progressReporting lspEnv "Processing" optProgressStyle else noProgressReporting actionQueue <- newQueue @@ -758,6 +760,7 @@ shakeShut IdeState{..} = do for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + progressStop $ indexProgressReporting $ hiedbWriter shakeExtras stopMonitoring