diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 600ea9777e..96b87608bd 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -71,7 +71,7 @@ import Data.Tuple.Extra (dupe) import Debug.Trace import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor -import Development.IDE.Core.ProgressReporting (ProgressReporting (..)) +import Development.IDE.Core.ProgressReporting (progressUpdate) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.Core.Tracing (withTrace) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index e85bfeaac2..19e0f40e24 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") - progressUpdate progress ProgressNewStarted + liftIO $ 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) - progressUpdate progress ProgressCompleted + liftIO $ 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 7815a984ca..3d8a2bf989 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -1,15 +1,21 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + module Development.IDE.Core.ProgressReporting ( ProgressEvent (..), - ProgressReporting (..), - noProgressReporting, + PerFileProgressReporting (..), + ProgressReporting, + noPerFileProgressReporting, progressReporting, - progressReportingOutsideState, + progressReportingNoTrace, -- utilities, reexported for use in Core.Shake mRunLspT, mRunLspTCallback, -- for tests recordProgress, InProgressState (..), + progressStop, + progressUpdate ) where @@ -34,46 +40,63 @@ import Language.LSP.Server (ProgressAmount (..), withProgress) import qualified Language.LSP.Server as LSP import qualified StmContainers.Map as STM -import UnliftIO (Async, MonadUnliftIO, async, - bracket, cancel) +import UnliftIO (Async, async, bracket, cancel) data ProgressEvent = ProgressNewStarted | ProgressCompleted | ProgressStarted -data ProgressReporting m = ProgressReporting - { progressUpdate :: ProgressEvent -> m (), - inProgress :: forall a. NormalizedFilePath -> m a -> m a, - -- ^ see Note [ProgressReporting API and InProgressState] - progressStop :: IO () +data ProgressReporting = ProgressReporting + { _progressUpdate :: ProgressEvent -> IO (), + _progressStop :: IO () -- ^ we are using IO here because creating and stopping the `ProgressReporting` -- is different from how we use it. } +data PerFileProgressReporting = PerFileProgressReporting + { + inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, + -- ^ see Note [ProgressReporting API and InProgressState] + progressReportingInner :: ProgressReporting + } + +class ProgressReporter a where + progressUpdate :: a -> ProgressEvent -> IO () + progressStop :: a -> IO () + +instance ProgressReporter ProgressReporting where + progressUpdate = _progressUpdate + progressStop = _progressStop + +instance ProgressReporter PerFileProgressReporting where + progressUpdate = _progressUpdate . progressReportingInner + progressStop = _progressStop . progressReportingInner + {- 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. +1. `ProgressReporting`: we have 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. +2. `ProgressReporting`: there 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`. +The `inProgress` function is only useful when we are using `ProgressReporting`. -} -noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) -noProgressReporting = +noProgressReporting :: ProgressReporting +noProgressReporting = ProgressReporting + { _progressUpdate = const $ pure (), + _progressStop = pure () + } +noPerFileProgressReporting :: IO PerFileProgressReporting +noPerFileProgressReporting = return $ - ProgressReporting - { progressUpdate = const $ pure (), - inProgress = const id, - progressStop = pure () + PerFileProgressReporting + { inProgress = const id, + progressReportingInner = noProgressReporting } -- | State used in 'delayedProgressReporting' @@ -106,29 +129,20 @@ data InProgressState 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 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 () + atomicallyNamed "recordProgress2" $ 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 @@ -138,57 +152,49 @@ recordProgress InProgressState {..} file shift = do alter x = let x' = maybe (shift 0) shift x in Just x' --- | `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. +-- | `progressReportingNoTrace` 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) => +progressReportingNoTrace :: STM Int -> STM Int -> Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> - IO (ProgressReporting m) -progressReportingOutsideState todo done = progressReporting' (pure $ InProgressStateOutSide todo done) + IO ProgressReporting +progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting +progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do + progressState <- newVar NotStarted + let _progressUpdate event = liftIO $ updateStateVar $ Event event + _progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) + return ProgressReporting {..} -progressReporting' :: - (MonadUnliftIO m, MonadIO m) => - IO InProgressState -> +-- | `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 :: 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 {..} + IO PerFileProgressReporting +progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting +progressReporting (Just lspEnv) title optProgressStyle = do + inProgressState <- newInProgress + progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) + (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle + let + inProgress :: NormalizedFilePath -> IO a -> IO a + inProgress = updateStateForFile inProgressState + return PerFileProgressReporting {..} 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 + f = recordProgress inProgress file -- Kill this to complete the progress session progressCounter :: diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d8db7f67ca..921dfe3e6d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -174,6 +174,7 @@ import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +import UnliftIO (MonadUnliftIO (withRunInIO)) data Log @@ -244,7 +245,7 @@ data HieDbWriter { indexQueue :: IndexQueue , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing , indexCompleted :: TVar Int -- ^ to report progress - , indexProgressReporting :: ProgressReporting IO + , indexProgressReporting :: ProgressReporting } -- | Actions to queue up on the index worker thread @@ -294,7 +295,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 Action + ,progress :: PerFileProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession @@ -676,7 +677,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 semanticTokensId <- newTVarIO 0 - indexProgressReporting <- progressReportingOutsideState + indexProgressReporting <- progressReportingNoTrace (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted)) (readTVar indexCompleted) lspEnv "Indexing" optProgressStyle @@ -693,7 +694,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer progress <- if reportProgress then progressReporting lspEnv "Processing" optProgressStyle - else noProgressReporting + else noPerFileProgressReporting actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv @@ -1216,7 +1217,8 @@ defineEarlyCutoff' defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions - (if optSkipProgress options key then id else inProgress progress file) $ do + let trans g x = withRunInIO $ \run -> g (run x) + (if optSkipProgress options key then id else trans (inProgress progress file)) $ do val <- case mbOld of Just old | mode == RunDependenciesSame -> do mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file