From 20b43047741929007e532d4d0d8048685aeb0934 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 01:14:38 +0800 Subject: [PATCH 01/10] add ProgressReportingNoTrace --- ghcide/src/Development/IDE/Core/Compile.hs | 3 +- .../Development/IDE/Core/ProgressReporting.hs | 108 +++++++++++------- ghcide/src/Development/IDE/Core/Shake.hs | 4 +- 3 files changed, 68 insertions(+), 47 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 600ea9777e..860af4accf 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -71,7 +71,8 @@ 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 (ProgressReporting (..), + progressReportingNoTrace, 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/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 7815a984ca..75da961262 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 (..), + ProgressReportingNoTrace, noProgressReporting, progressReporting, - progressReportingOutsideState, + progressReportingNoTrace, -- utilities, reexported for use in Core.Shake mRunLspT, mRunLspTCallback, -- for tests recordProgress, InProgressState (..), + progressStop, + progressUpdate ) where @@ -42,15 +48,37 @@ data ProgressEvent | 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 ProgressReportingNoTrace m = ProgressReportingNoTrace + { progressUpdateI :: ProgressEvent -> m (), + progressStopI :: IO () -- ^ we are using IO here because creating and stopping the `ProgressReporting` -- is different from how we use it. } +data ProgressReporting m = ProgressReporting + { + inProgress :: forall a. NormalizedFilePath -> m a -> m a, + -- ^ see Note [ProgressReporting API and InProgressState] + progressReportingInner :: ProgressReportingNoTrace m + } + + +class ProgressReportingClass a where + type M a :: * -> * + progressUpdate :: a -> ProgressEvent -> M a () + progressStop :: a -> IO () + +instance ProgressReportingClass (ProgressReportingNoTrace m) where + type M (ProgressReportingNoTrace m) = m + progressUpdate = progressUpdateI + progressStop = progressStopI + +instance ProgressReportingClass (ProgressReporting m) where + type M (ProgressReporting m) = m + progressUpdate :: ProgressReporting m -> ProgressEvent -> M (ProgressReporting m) () + progressUpdate = progressUpdateI . progressReportingInner + progressStop = progressStopI . progressReportingInner + {- Note [ProgressReporting API and InProgressState] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The progress of tasks can be tracked in two ways: @@ -67,13 +95,17 @@ An alternative design could involve using GADTs to eliminate this discrepancy be `InProgressState` and `InProgressStateOutSide`. -} +noProgressReportingNoTrace :: (MonadUnliftIO m) => (ProgressReportingNoTrace m) +noProgressReportingNoTrace = ProgressReportingNoTrace + { progressUpdateI = const $ pure (), + progressStopI = pure () + } noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) noProgressReporting = return $ ProgressReporting - { progressUpdate = const $ pure (), - inProgress = const id, - progressStop = pure () + { inProgress = const id, + progressReportingInner = noProgressReportingNoTrace } -- | State used in 'delayedProgressReporting' @@ -106,19 +138,12 @@ 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 @@ -138,50 +163,45 @@ 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 :: +progressReportingNoTrace :: (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) + IO (ProgressReportingNoTrace m) +progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReportingNoTrace +progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do + progressState <- newVar NotStarted + let progressUpdateI event = liftIO $ updateStateVar $ Event event + progressStopI = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) + return ProgressReportingNoTrace {..} -progressReporting' :: +-- | `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 :: + forall c m. (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) +progressReporting Nothing _title _optProgressStyle = noProgressReporting +progressReporting (Just lspEnv) title optProgressStyle = do + inProgressState <- newInProgress + progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) + (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle + let + inProgress :: forall a. NormalizedFilePath -> m a -> m a 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. diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d8db7f67ca..45e8488579 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -244,7 +244,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 :: ProgressReportingNoTrace IO } -- | Actions to queue up on the index worker thread @@ -676,7 +676,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 From faceb5460c5913df42e4ed28ce4107e74beef279 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 01:18:53 +0800 Subject: [PATCH 02/10] fix doc --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 75da961262..b75e9b95e1 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -83,16 +83,13 @@ instance ProgressReportingClass (ProgressReporting m) where ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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. `ProgressReportingNoTrace`: 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`. -} noProgressReportingNoTrace :: (MonadUnliftIO m) => (ProgressReportingNoTrace m) From 5527b119d7e8a7811d756867a9bda34bbdfc4d79 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 01:22:32 +0800 Subject: [PATCH 03/10] cleanup --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index b75e9b95e1..2ee8f5c86a 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -194,8 +194,7 @@ progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle - let - inProgress :: forall a. NormalizedFilePath -> m a -> m a + let inProgress :: forall a. NormalizedFilePath -> m a -> m a inProgress = updateStateForFile inProgressState return ProgressReporting {..} where From acaa7ba831e264d486f10baf2d19f4899a3700f2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 01:23:13 +0800 Subject: [PATCH 04/10] stylish --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2ee8f5c86a..ce3dfbc4c1 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -62,7 +62,6 @@ data ProgressReporting m = ProgressReporting progressReportingInner :: ProgressReportingNoTrace m } - class ProgressReportingClass a where type M a :: * -> * progressUpdate :: a -> ProgressEvent -> M a () @@ -136,7 +135,6 @@ data InProgressState currentVar :: STM.Map NormalizedFilePath Int } - newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO From f17af2b3c21119abffa6846d88638d3cb2df4fe6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 06:20:57 +0800 Subject: [PATCH 05/10] turn ProgressReporting into IO --- ghcide/src/Development/IDE/Core/OfInterest.hs | 4 +- .../Development/IDE/Core/ProgressReporting.hs | 56 ++++++++----------- ghcide/src/Development/IDE/Core/Shake.hs | 8 ++- 3 files changed, 31 insertions(+), 37 deletions(-) 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 ce3dfbc4c1..ed24a04d7d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -40,41 +40,36 @@ 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 ProgressReportingNoTrace m = ProgressReportingNoTrace - { progressUpdateI :: ProgressEvent -> m (), +data ProgressReportingNoTrace = ProgressReportingNoTrace + { progressUpdateI :: ProgressEvent -> IO (), progressStopI :: IO () -- ^ we are using IO here because creating and stopping the `ProgressReporting` -- is different from how we use it. } -data ProgressReporting m = ProgressReporting +data ProgressReporting = ProgressReporting { - inProgress :: forall a. NormalizedFilePath -> m a -> m a, + inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, -- ^ see Note [ProgressReporting API and InProgressState] - progressReportingInner :: ProgressReportingNoTrace m + progressReportingInner :: ProgressReportingNoTrace } class ProgressReportingClass a where - type M a :: * -> * - progressUpdate :: a -> ProgressEvent -> M a () + progressUpdate :: a -> ProgressEvent -> IO () progressStop :: a -> IO () -instance ProgressReportingClass (ProgressReportingNoTrace m) where - type M (ProgressReportingNoTrace m) = m +instance ProgressReportingClass ProgressReportingNoTrace where progressUpdate = progressUpdateI progressStop = progressStopI -instance ProgressReportingClass (ProgressReporting m) where - type M (ProgressReporting m) = m - progressUpdate :: ProgressReporting m -> ProgressEvent -> M (ProgressReporting m) () +instance ProgressReportingClass ProgressReporting where progressUpdate = progressUpdateI . progressReportingInner progressStop = progressStopI . progressReportingInner @@ -91,12 +86,12 @@ The progress of tasks can be tracked in two ways: The `inProgress` function is only useful when we are using `ProgressReporting`. -} -noProgressReportingNoTrace :: (MonadUnliftIO m) => (ProgressReportingNoTrace m) +noProgressReportingNoTrace :: ProgressReportingNoTrace noProgressReportingNoTrace = ProgressReportingNoTrace { progressUpdateI = const $ pure (), progressStopI = pure () } -noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) +noProgressReporting :: IO ProgressReporting noProgressReporting = return $ ProgressReporting @@ -141,14 +136,13 @@ 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 () + 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 @@ -162,13 +156,12 @@ recordProgress InProgressState {..} file shift = do -- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking. -- Refer to Note [ProgressReporting API and InProgressState] for more details. progressReportingNoTrace :: - (MonadUnliftIO m, MonadIO m) => STM Int -> STM Int -> Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> - IO (ProgressReportingNoTrace m) + IO ProgressReportingNoTrace progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReportingNoTrace progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do progressState <- newVar NotStarted @@ -181,19 +174,18 @@ progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do -- It necessitates the active tracking of progress using the `inProgress` function. -- Refer to Note [ProgressReporting API and InProgressState] for more details. progressReporting :: - forall c m. - (MonadUnliftIO m, MonadIO m) => Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> - IO (ProgressReporting m) + IO ProgressReporting progressReporting Nothing _title _optProgressStyle = noProgressReporting progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle - let inProgress :: forall a. NormalizedFilePath -> m a -> m a - inProgress = updateStateForFile inProgressState + let + inProgress :: NormalizedFilePath -> IO a -> IO a + inProgress = updateStateForFile inProgressState return ProgressReporting {..} where updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const @@ -202,7 +194,7 @@ progressReporting (Just lspEnv) title optProgressStyle = do -- 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 45e8488579..0ad1a126ef 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 :: ProgressReportingNoTrace IO + , indexProgressReporting :: ProgressReportingNoTrace } -- | 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 :: ProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession @@ -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 From 03961fa0854310bf8ad19b16741da52576a5fe61 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 06:22:46 +0800 Subject: [PATCH 06/10] rename --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index ed24a04d7d..6d8bb8ba35 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -56,9 +56,9 @@ data ProgressReportingNoTrace = ProgressReportingNoTrace data ProgressReporting = ProgressReporting { - inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, + inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, -- ^ see Note [ProgressReporting API and InProgressState] - progressReportingInner :: ProgressReportingNoTrace + progressReporter :: ProgressReportingNoTrace } class ProgressReportingClass a where @@ -70,8 +70,8 @@ instance ProgressReportingClass ProgressReportingNoTrace where progressStop = progressStopI instance ProgressReportingClass ProgressReporting where - progressUpdate = progressUpdateI . progressReportingInner - progressStop = progressStopI . progressReportingInner + progressUpdate = progressUpdateI . progressReporter + progressStop = progressStopI . progressReporter {- Note [ProgressReporting API and InProgressState] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -96,7 +96,7 @@ noProgressReporting = return $ ProgressReporting { inProgress = const id, - progressReportingInner = noProgressReportingNoTrace + progressReporter = noProgressReportingNoTrace } -- | State used in 'delayedProgressReporting' @@ -181,7 +181,7 @@ progressReporting :: progressReporting Nothing _title _optProgressStyle = noProgressReporting progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress - progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) + progressReporter <- progressReportingNoTrace (readTVar $ todoVar inProgressState) (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle let inProgress :: NormalizedFilePath -> IO a -> IO a From 99e37f241d6b66b63c01364ddb8ce412cebcbbab Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 06:23:38 +0800 Subject: [PATCH 07/10] Revert "rename" This reverts commit 03961fa0854310bf8ad19b16741da52576a5fe61. --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 6d8bb8ba35..ed24a04d7d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -56,9 +56,9 @@ data ProgressReportingNoTrace = ProgressReportingNoTrace data ProgressReporting = ProgressReporting { - inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, + inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, -- ^ see Note [ProgressReporting API and InProgressState] - progressReporter :: ProgressReportingNoTrace + progressReportingInner :: ProgressReportingNoTrace } class ProgressReportingClass a where @@ -70,8 +70,8 @@ instance ProgressReportingClass ProgressReportingNoTrace where progressStop = progressStopI instance ProgressReportingClass ProgressReporting where - progressUpdate = progressUpdateI . progressReporter - progressStop = progressStopI . progressReporter + progressUpdate = progressUpdateI . progressReportingInner + progressStop = progressStopI . progressReportingInner {- Note [ProgressReporting API and InProgressState] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -96,7 +96,7 @@ noProgressReporting = return $ ProgressReporting { inProgress = const id, - progressReporter = noProgressReportingNoTrace + progressReportingInner = noProgressReportingNoTrace } -- | State used in 'delayedProgressReporting' @@ -181,7 +181,7 @@ progressReporting :: progressReporting Nothing _title _optProgressStyle = noProgressReporting progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress - progressReporter <- progressReportingNoTrace (readTVar $ todoVar inProgressState) + progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle let inProgress :: NormalizedFilePath -> IO a -> IO a From 201946e25e133de0183ffc1f888551c245d77f23 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 06:24:22 +0800 Subject: [PATCH 08/10] rename --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index ed24a04d7d..7b0e2ae934 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -61,15 +61,15 @@ data ProgressReporting = ProgressReporting progressReportingInner :: ProgressReportingNoTrace } -class ProgressReportingClass a where +class ProgressReporter a where progressUpdate :: a -> ProgressEvent -> IO () progressStop :: a -> IO () -instance ProgressReportingClass ProgressReportingNoTrace where +instance ProgressReporter ProgressReportingNoTrace where progressUpdate = progressUpdateI progressStop = progressStopI -instance ProgressReportingClass ProgressReporting where +instance ProgressReporter ProgressReporting where progressUpdate = progressUpdateI . progressReportingInner progressStop = progressStopI . progressReportingInner From a3397efa94728c4b46a63f6b4e2dfc5dcb09950a Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 06:32:42 +0800 Subject: [PATCH 09/10] rename to PerFileProgressReporting --- ghcide/src/Development/IDE/Core/Compile.hs | 3 +- .../Development/IDE/Core/ProgressReporting.hs | 42 +++++++++---------- ghcide/src/Development/IDE/Core/Shake.hs | 6 +-- 3 files changed, 25 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 860af4accf..96b87608bd 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -71,8 +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 (..), - progressReportingNoTrace, progressUpdate) +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/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 7b0e2ae934..2d518d81c4 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -3,9 +3,9 @@ module Development.IDE.Core.ProgressReporting ( ProgressEvent (..), - ProgressReporting (..), - ProgressReportingNoTrace, - noProgressReporting, + PerFileProgressReporting (..), + ProgressReporting, + noPerFileProgressReporting, progressReporting, progressReportingNoTrace, -- utilities, reexported for use in Core.Shake @@ -47,29 +47,29 @@ data ProgressEvent | ProgressCompleted | ProgressStarted -data ProgressReportingNoTrace = ProgressReportingNoTrace +data ProgressReporting = ProgressReporting { progressUpdateI :: ProgressEvent -> IO (), progressStopI :: IO () -- ^ we are using IO here because creating and stopping the `ProgressReporting` -- is different from how we use it. } -data ProgressReporting = ProgressReporting +data PerFileProgressReporting = PerFileProgressReporting { inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, -- ^ see Note [ProgressReporting API and InProgressState] - progressReportingInner :: ProgressReportingNoTrace + progressReportingInner :: ProgressReporting } class ProgressReporter a where progressUpdate :: a -> ProgressEvent -> IO () progressStop :: a -> IO () -instance ProgressReporter ProgressReportingNoTrace where +instance ProgressReporter ProgressReporting where progressUpdate = progressUpdateI progressStop = progressStopI -instance ProgressReporter ProgressReporting where +instance ProgressReporter PerFileProgressReporting where progressUpdate = progressUpdateI . progressReportingInner progressStop = progressStopI . progressReportingInner @@ -80,23 +80,23 @@ The progress of tasks can be tracked in two ways: 1. `ProgressReporting`: we have an internal state that actively tracks the progress. Changes to the progress are made directly to this state. -2. `ProgressReportingNoTrace`: there 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 `ProgressReporting`. -} -noProgressReportingNoTrace :: ProgressReportingNoTrace -noProgressReportingNoTrace = ProgressReportingNoTrace +noProgressReporting :: ProgressReporting +noProgressReporting = ProgressReporting { progressUpdateI = const $ pure (), progressStopI = pure () } -noProgressReporting :: IO ProgressReporting -noProgressReporting = +noPerFileProgressReporting :: IO PerFileProgressReporting +noPerFileProgressReporting = return $ - ProgressReporting + PerFileProgressReporting { inProgress = const id, - progressReportingInner = noProgressReportingNoTrace + progressReportingInner = noProgressReporting } -- | State used in 'delayedProgressReporting' @@ -161,14 +161,14 @@ progressReportingNoTrace :: Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> - IO ProgressReportingNoTrace -progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReportingNoTrace + IO ProgressReporting +progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do progressState <- newVar NotStarted let progressUpdateI event = liftIO $ updateStateVar $ Event event progressStopI = updateStateVar StopProgress updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) - return ProgressReportingNoTrace {..} + return ProgressReporting {..} -- | `progressReporting` initiates a new progress reporting session. -- It necessitates the active tracking of progress using the `inProgress` function. @@ -177,8 +177,8 @@ progressReporting :: Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> - IO ProgressReporting -progressReporting Nothing _title _optProgressStyle = noProgressReporting + IO PerFileProgressReporting +progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) @@ -186,7 +186,7 @@ progressReporting (Just lspEnv) title optProgressStyle = do let inProgress :: NormalizedFilePath -> IO a -> IO a inProgress = updateStateForFile inProgressState - return ProgressReporting {..} + return PerFileProgressReporting {..} where updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const where diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0ad1a126ef..921dfe3e6d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -245,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 :: ProgressReportingNoTrace + , indexProgressReporting :: ProgressReporting } -- | Actions to queue up on the index worker thread @@ -295,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 + ,progress :: PerFileProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession @@ -694,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 From 448675bed449e83877b42faf513d7656cf7f1122 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 29 Jun 2024 06:36:21 +0800 Subject: [PATCH 10/10] prefix hidden field with `_` --- .../Development/IDE/Core/ProgressReporting.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2d518d81c4..3d8a2bf989 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -48,8 +48,8 @@ data ProgressEvent | ProgressStarted data ProgressReporting = ProgressReporting - { progressUpdateI :: ProgressEvent -> IO (), - progressStopI :: IO () + { _progressUpdate :: ProgressEvent -> IO (), + _progressStop :: IO () -- ^ we are using IO here because creating and stopping the `ProgressReporting` -- is different from how we use it. } @@ -66,12 +66,12 @@ class ProgressReporter a where progressStop :: a -> IO () instance ProgressReporter ProgressReporting where - progressUpdate = progressUpdateI - progressStop = progressStopI + progressUpdate = _progressUpdate + progressStop = _progressStop instance ProgressReporter PerFileProgressReporting where - progressUpdate = progressUpdateI . progressReportingInner - progressStop = progressStopI . progressReportingInner + progressUpdate = _progressUpdate . progressReportingInner + progressStop = _progressStop . progressReportingInner {- Note [ProgressReporting API and InProgressState] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -88,8 +88,8 @@ The `inProgress` function is only useful when we are using `ProgressReporting`. noProgressReporting :: ProgressReporting noProgressReporting = ProgressReporting - { progressUpdateI = const $ pure (), - progressStopI = pure () + { _progressUpdate = const $ pure (), + _progressStop = pure () } noPerFileProgressReporting :: IO PerFileProgressReporting noPerFileProgressReporting = @@ -165,8 +165,8 @@ progressReportingNoTrace :: progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do progressState <- newVar NotStarted - let progressUpdateI event = liftIO $ updateStateVar $ Event event - progressStopI = updateStateVar StopProgress + let _progressUpdate event = liftIO $ updateStateVar $ Event event + _progressStop = updateStateVar StopProgress updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) return ProgressReporting {..}