From 8981601cbdc469c0da71809425b64ed66f7c8dfe Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 16:38:20 +0800 Subject: [PATCH 01/20] swtich to general progress --- ghcide/src/Development/IDE/Core/Compile.hs | 84 ++++--------------- ghcide/src/Development/IDE/Core/OfInterest.hs | 4 +- .../Development/IDE/Core/ProgressReporting.hs | 36 ++++---- ghcide/src/Development/IDE/Core/Shake.hs | 6 +- 4 files changed, 40 insertions(+), 90 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index f295e568c6..aad6bdd3c7 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -129,6 +129,7 @@ import GHC.Driver.Config.CoreToStg.Prep #if MIN_VERSION_ghc(9,7,0) import Data.Foldable (toList) import GHC.Unit.Module.Warnings +import Development.IDE.Core.ProgressReporting (progressReporting, ProgressReporting (..)) #else import Development.IDE.Core.FileStore (shareFilePath) #endif @@ -898,6 +899,7 @@ indexHieFile se mod_summary srcPath !hash hf = do _ -> do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} + -- todo, this is the real pending count modifyTVar' indexPending $ HashMap.insert srcPath hash writeTQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread @@ -911,69 +913,20 @@ 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 $ - withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') + tok <- modifyVar indexProgressToken $ fmap (first Just . dupe) . \case + Just x -> return x + -- create a progressReport if we don't already have one + Nothing -> do + tt <- progressReporting (lspEnv se) "Indexing" optProgressStyle + progressUpdate tt ProgressStarted + return tt + inProgress tok srcPath + (withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')) + `finally` post 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 - } - -- Report the progress once we are done indexing this file post = do mdone <- atomically $ do @@ -988,16 +941,11 @@ 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 -> + whenJust mdone $ \_ -> 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" - } + case tok of + Just token -> progressUpdate token ProgressCompleted + Nothing -> return () -- We are done with the current indexing cycle, so destroy the token pure Nothing diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index abcf6342a8..a33e0202cb 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 + liftIO $ progressUpdate progress ProgressStarted -- 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 + 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 11b904624d..f06fff8d3e 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -23,7 +23,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,19 +32,20 @@ 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 + = ProgressStarted + | ProgressCompleted -data ProgressReporting = ProgressReporting +data ProgressReporting m = ProgressReporting { progressUpdate :: ProgressEvent -> IO () - , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a + , inProgress :: forall a. NormalizedFilePath -> m a -> m a , progressStop :: IO () } -noProgressReporting :: IO ProgressReporting +noProgressReporting :: IO (ProgressReporting m) noProgressReporting = return $ ProgressReporting { progressUpdate = const $ pure () , inProgress = const id @@ -63,10 +63,10 @@ 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 start (Event ProgressStarted) NotStarted = Running <$> async start +updateState start (Event ProgressStarted) (Running job) = cancel job >> Running <$> async start +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 @@ -100,11 +100,13 @@ recordProgress InProgressState{..} file shift = do alter x = let x' = maybe (shift 0) shift x in Just x' progressReporting - :: Maybe (LSP.LanguageContextEnv c) + :: (MonadUnliftIO m, MonadIO m) + => Maybe (LSP.LanguageContextEnv c) + -> T.Text -> ProgressReportingStyle - -> IO ProgressReporting -progressReporting Nothing _optProgressStyle = noProgressReporting -progressReporting (Just lspEnv) optProgressStyle = do + -> IO (ProgressReporting m) +progressReporting Nothing _title _optProgressStyle = noProgressReporting +progressReporting (Just lspEnv) title optProgressStyle = do inProgressState <- newInProgress progressState <- newVar NotStarted let progressUpdate event = updateStateVar $ Event event @@ -115,7 +117,7 @@ progressReporting (Just lspEnv) optProgressStyle = do where lspShakeProgressNew :: InProgressState -> IO () lspShakeProgressNew InProgressState{..} = - LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0 + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 where loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound loop update prevPct = do @@ -131,7 +133,7 @@ progressReporting (Just lspEnv) optProgressStyle = do update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) loop update nextPct - updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const + updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ 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. diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d426ba34f8..b571614037 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -255,7 +255,7 @@ data 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) + , indexProgressToken :: Var (Maybe (ProgressReporting IO)) -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock } @@ -306,7 +306,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 @@ -710,7 +710,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer progress <- if reportProgress - then progressReporting lspEnv optProgressStyle + then progressReporting lspEnv "Processing" optProgressStyle else noProgressReporting actionQueue <- newQueue From ae83626045f459b0fc13ca23f6c3ca441f1e54c3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 16:46:51 +0800 Subject: [PATCH 02/20] fix --- ghcide/src/Development/IDE/Core/Compile.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index aad6bdd3c7..7b3050b2e8 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -80,6 +80,7 @@ import Development.IDE.GHC.Compat hiding (loadInterface, 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, ProgressReporting (..)) import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () @@ -129,7 +130,6 @@ import GHC.Driver.Config.CoreToStg.Prep #if MIN_VERSION_ghc(9,7,0) import Data.Foldable (toList) import GHC.Unit.Module.Warnings -import Development.IDE.Core.ProgressReporting (progressReporting, ProgressReporting (..)) #else import Development.IDE.Core.FileStore (shareFilePath) #endif @@ -944,9 +944,10 @@ indexHieFile se mod_summary srcPath !hash hf = do whenJust mdone $ \_ -> modifyVar_ indexProgressToken $ \tok -> do case tok of - Just token -> progressUpdate token ProgressCompleted + Just token -> progressUpdate token ProgressCompleted >> progressStop token Nothing -> return () -- We are done with the current indexing cycle, so destroy the token + pure Nothing writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] From 8800d2a72cc3fb91bb364ecdc95009531da02199 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 16:48:26 +0800 Subject: [PATCH 03/20] format --- ghcide/src/Development/IDE/Core/Compile.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 7b3050b2e8..37dddbad59 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -947,7 +947,6 @@ indexHieFile se mod_summary srcPath !hash hf = do Just token -> progressUpdate token ProgressCompleted >> progressStop token Nothing -> return () -- We are done with the current indexing cycle, so destroy the token - pure Nothing writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] From f3cc5b03074ceb9f4cd71f733b7d163c8af35c7e Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 18:14:56 +0800 Subject: [PATCH 04/20] add `progressReportingOutsideState` --- ghcide/src/Development/IDE/Core/Compile.hs | 22 +++--- .../Development/IDE/Core/ProgressReporting.hs | 68 +++++++++++++------ 2 files changed, 61 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 37dddbad59..c710ba7af8 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -80,7 +80,7 @@ import Development.IDE.GHC.Compat hiding (loadInterface, 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, ProgressReporting (..)) +import Development.IDE.Core.ProgressReporting (progressReporting, ProgressReporting (..), progressReportingOutsideState) import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () @@ -913,20 +913,22 @@ 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. - tok <- modifyVar indexProgressToken $ fmap (first Just . dupe) . \case + bracket (pre optProgressStyle) (const 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 + pre optProgressStyle = modifyVar_ indexProgressToken $ fmap Just . \case Just x -> return x -- create a progressReport if we don't already have one Nothing -> do - tt <- progressReporting (lspEnv se) "Indexing" optProgressStyle + tt <- progressReportingOutsideState + (liftM2 (+) (HashMap.size <$> readTVar indexPending) (readTVar indexCompleted)) + (readTVar indexCompleted) + (lspEnv se) "Indexing" optProgressStyle progressUpdate tt ProgressStarted return tt - inProgress tok srcPath - (withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')) - `finally` post - where - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location - HieDbWriter{..} = hiedbWriter se -- Report the progress once we are done indexing this file post = do mdone <- atomically $ do diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index f06fff8d3e..61d9fffeab 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -3,6 +3,7 @@ module Development.IDE.Core.ProgressReporting , ProgressReporting(..) , noProgressReporting , progressReporting + , progressReportingOutsideState -- utilities, reexported for use in Core.Shake , mRunLspT , mRunLspTCallback @@ -12,6 +13,7 @@ module Development.IDE.Core.ProgressReporting ) where +import Control.Concurrent.STM (STM) import Control.Concurrent.STM.Stats (TVar, atomically, atomicallyNamed, modifyTVar', newTVarIO, readTVar, retry) @@ -76,11 +78,17 @@ data InProgressState = InProgressState , doneVar :: TVar Int -- ^ Number of files done , currentVar :: STM.Map NormalizedFilePath Int } + | InProgressStateOutSide { + todo :: STM Int -- ^ Number of files to do + , done :: STM Int -- ^ Number of files done + } + 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 @@ -99,15 +107,36 @@ recordProgress InProgressState{..} file shift = do return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' + progressReporting :: (MonadUnliftIO m, MonadIO m) => Maybe (LSP.LanguageContextEnv c) -> T.Text -> ProgressReportingStyle -> IO (ProgressReporting m) -progressReporting Nothing _title _optProgressStyle = noProgressReporting -progressReporting (Just lspEnv) title optProgressStyle = do - inProgressState <- newInProgress +progressReporting = progressReporting' newInProgress + +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 = updateStateVar $ Event event progressStop = updateStateVar StopProgress @@ -116,23 +145,24 @@ progressReporting (Just lspEnv) title optProgressStyle = do return ProgressReporting{..} where lspShakeProgressNew :: InProgressState -> IO () + lspShakeProgressNew InProgressStateOutSide{..} = + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 todo done lspShakeProgressNew InProgressState{..} = - 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 <- 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 + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 (readTVar todoVar) (readTVar doneVar) + loop _ _ _todoSTM _doneSTM | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound + loop update prevPct todoSTM doneSTM = do + (todo, done, nextPct) <- liftIO $ atomically $ do + todo <- todoSTM + done <- doneSTM + 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) + + void $ update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + loop update nextPct todoSTM doneSTM updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ 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 From dde4c1dee7ea35367ba04a1f6a740d3aeefedb99 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 19:05:13 +0800 Subject: [PATCH 05/20] format with stylish --- .../Development/IDE/Core/ProgressReporting.hs | 250 +++++++++--------- 1 file changed, 128 insertions(+), 122 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 61d9fffeab..92fb1c12bb 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -1,17 +1,17 @@ module Development.IDE.Core.ProgressReporting - ( ProgressEvent(..) - , ProgressReporting(..) - , noProgressReporting - , progressReporting - , progressReportingOutsideState - -- 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, @@ -38,146 +38,152 @@ import UnliftIO (Async, MonadUnliftIO, async, bracket, cancel) data ProgressEvent - = ProgressStarted - | ProgressCompleted + = ProgressStarted + | ProgressCompleted data ProgressReporting m = ProgressReporting - { progressUpdate :: ProgressEvent -> IO () - , inProgress :: forall a. NormalizedFilePath -> m a -> m a - , progressStop :: IO () + { progressUpdate :: ProgressEvent -> IO (), + inProgress :: forall a. NormalizedFilePath -> m a -> m a, + progressStop :: IO () } noProgressReporting :: IO (ProgressReporting m) -noProgressReporting = return $ ProgressReporting - { progressUpdate = const $ pure () - , inProgress = const id - , progressStop = pure () - } +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 ProgressStarted) NotStarted = Running <$> async start -updateState start (Event ProgressStarted) (Running job) = cancel job >> Running <$> async start -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 +updateState _ _ Stopped = pure Stopped +updateState start (Event ProgressStarted) NotStarted = Running <$> async start +updateState start (Event ProgressStarted) (Running job) = cancel job >> Running <$> async start +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 - } - | InProgressStateOutSide { - todo :: STM Int -- ^ Number of files to do - , done :: STM Int -- ^ Number of files done - } - +data InProgressState + = InProgressState + { -- | Number of files to do + todoVar :: TVar Int, + -- | Number of files done + doneVar :: TVar Int, + currentVar :: STM.Map NormalizedFilePath Int + } + | InProgressStateOutSide + { -- | 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 () +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 - :: (MonadUnliftIO m, MonadIO m) - => Maybe (LSP.LanguageContextEnv c) - -> T.Text - -> ProgressReportingStyle - -> IO (ProgressReporting m) +progressReporting :: + (MonadUnliftIO m, MonadIO m) => + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO (ProgressReporting m) progressReporting = progressReporting' newInProgress -progressReportingOutsideState - :: (MonadUnliftIO m, MonadIO m) - => STM Int - -> STM Int - -> Maybe (LSP.LanguageContextEnv c) - -> T.Text - -> ProgressReportingStyle - -> IO (ProgressReporting m) +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 = updateStateVar $ Event event - progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) - inProgress = updateStateForFile inProgressState - return ProgressReporting{..} - where - lspShakeProgressNew :: InProgressState -> IO () - lspShakeProgressNew InProgressStateOutSide{..} = - LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 todo done - lspShakeProgressNew InProgressState{..} = - LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 (readTVar todoVar) (readTVar doneVar) - loop _ _ _todoSTM _doneSTM | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound - loop update prevPct todoSTM doneSTM = do - (todo, done, nextPct) <- liftIO $ atomically $ do - todo <- todoSTM - done <- doneSTM - 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) - - void $ update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) - loop update nextPct todoSTM doneSTM - updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ 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' :: + (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 = updateStateVar $ Event event + progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) + inProgress = updateStateForFile inProgressState + return ProgressReporting {..} + where + lspShakeProgressNew :: InProgressState -> IO () + lspShakeProgressNew InProgressStateOutSide {..} = + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 todo done + lspShakeProgressNew InProgressState {..} = + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 (readTVar todoVar) (readTVar doneVar) + loop _ _ _todoSTM _doneSTM | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound + loop update prevPct todoSTM doneSTM = do + (todo, done, nextPct) <- liftIO $ atomically $ do + todo <- todoSTM + done <- doneSTM + 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) + + void $ update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + loop update nextPct todoSTM doneSTM + 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 + +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 From e0471c7d2aa892829a927e8ed29a6a8b14608dce Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 19:07:28 +0800 Subject: [PATCH 06/20] clean up --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index c710ba7af8..2dd7bc131c 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -913,7 +913,7 @@ 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) (const post) $ \_ -> + bracket_ (pre optProgressStyle) post $ withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') where mod_location = ms_location mod_summary From 3767e81ea231063ce942f29a2da3ccb2a0312d7d Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 19:07:33 +0800 Subject: [PATCH 07/20] cleanup --- ghcide/src/Development/IDE/Core/Compile.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 2dd7bc131c..6f6266a8f9 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 @@ -80,7 +79,7 @@ import Development.IDE.GHC.Compat hiding (loadInterface, 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, ProgressReporting (..), progressReportingOutsideState) +import Development.IDE.Core.ProgressReporting (ProgressReporting (..), progressReportingOutsideState) import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () @@ -97,7 +96,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 From 85c7cd05d6c320d525b7575de7976cb6982cf109 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 13 Jun 2024 19:07:58 +0800 Subject: [PATCH 08/20] clean up --- ghcide/src/Development/IDE/Core/Compile.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 6f6266a8f9..99e2ef8751 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -897,7 +897,6 @@ indexHieFile se mod_summary srcPath !hash hf = do _ -> do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} - -- todo, this is the real pending count modifyTVar' indexPending $ HashMap.insert srcPath hash writeTQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread From 43abadd6c397999623b5e9b3102621905835c4b5 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 06:17:43 -0400 Subject: [PATCH 09/20] add comment --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 92fb1c12bb..20f47adab0 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -84,6 +84,7 @@ data InProgressState 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 From 0c9325ea0b25b0324828471a2b1c4de19cc7201e Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 06:29:02 -0400 Subject: [PATCH 10/20] adjust to use `progressCounter` --- .../Development/IDE/Core/ProgressReporting.hs | 43 +++++++++++-------- 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 20f47adab0..01f5999376 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -150,24 +150,31 @@ progressReporting' newState (Just lspEnv) title optProgressStyle = do return ProgressReporting {..} where lspShakeProgressNew :: InProgressState -> IO () - lspShakeProgressNew InProgressStateOutSide {..} = - LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 todo done - lspShakeProgressNew InProgressState {..} = - LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 (readTVar todoVar) (readTVar doneVar) - loop _ _ _todoSTM _doneSTM | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound - loop update prevPct todoSTM doneSTM = do - (todo, done, nextPct) <- liftIO $ atomically $ do - todo <- todoSTM - done <- doneSTM - 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) - - void $ update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) - loop update nextPct todoSTM doneSTM + lspShakeProgressNew InProgressStateOutSide {..} = progressCounter lspEnv todo done + lspShakeProgressNew InProgressState {..} = progressCounter lspEnv (readTVar todoVar) (readTVar doneVar) + -- Kill this to complete the progress session + progressCounter + :: LSP.LanguageContextEnv c + -> STM Int + -> STM Int + -> IO () + progressCounter lspEnv 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 updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const where -- This functions are deliberately eta-expanded to avoid space leaks. From e83f3bc48f7710c3d8c5b1d19e7399743a0245d0 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 06:43:45 -0400 Subject: [PATCH 11/20] Extract progressCounter Co-authored-by: Michael Peyton Jones --- .../Development/IDE/Core/ProgressReporting.hs | 53 ++++++++++--------- 1 file changed, 28 insertions(+), 25 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 01f5999376..0cb1b9532d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -150,31 +150,8 @@ progressReporting' newState (Just lspEnv) title optProgressStyle = do return ProgressReporting {..} where lspShakeProgressNew :: InProgressState -> IO () - lspShakeProgressNew InProgressStateOutSide {..} = progressCounter lspEnv todo done - lspShakeProgressNew InProgressState {..} = progressCounter lspEnv (readTVar todoVar) (readTVar doneVar) - -- Kill this to complete the progress session - progressCounter - :: LSP.LanguageContextEnv c - -> STM Int - -> STM Int - -> IO () - progressCounter lspEnv 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 + 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. @@ -183,6 +160,32 @@ progressReporting' newState (Just lspEnv) title optProgressStyle = do 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 () From ad25018b53a78e814b4ed03c71ebc850bf2775f0 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 07:10:14 -0400 Subject: [PATCH 12/20] IO switch to m in progressUpdate --- ghcide/src/Development/IDE/Core/OfInterest.hs | 4 ++-- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index a33e0202cb..702261bfde 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 ProgressStarted + progressUpdate progress ProgressStarted -- 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 ProgressCompleted + 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 0cb1b9532d..79625c07e0 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -42,12 +42,12 @@ data ProgressEvent | ProgressCompleted data ProgressReporting m = ProgressReporting - { progressUpdate :: ProgressEvent -> IO (), + { progressUpdate :: ProgressEvent -> m (), inProgress :: forall a. NormalizedFilePath -> m a -> m a, progressStop :: IO () } -noProgressReporting :: IO (ProgressReporting m) +noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) noProgressReporting = return $ ProgressReporting @@ -143,7 +143,7 @@ progressReporting' _newState Nothing _title _optProgressStyle = noProgressReport progressReporting' newState (Just lspEnv) title optProgressStyle = do inProgressState <- newState progressState <- newVar NotStarted - let progressUpdate event = updateStateVar $ Event event + let progressUpdate event = liftIO $ updateStateVar $ Event event progressStop = updateStateVar StopProgress updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState) inProgress = updateStateForFile inProgressState From 1a75a36d259d824efb88f66b5961b4ccf22e0608 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 07:18:11 -0400 Subject: [PATCH 13/20] format --- .../Development/IDE/Core/ProgressReporting.hs | 130 ++++++++++-------- 1 file changed, 73 insertions(+), 57 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 79625c07e0..fb814f1659 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -13,29 +13,45 @@ module Development.IDE.Core.ProgressReporting ) where -import Control.Concurrent.STM (STM) -import Control.Concurrent.STM.Stats (TVar, atomically, - atomicallyNamed, modifyTVar', - newTVarIO, readTVar, retry) -import Control.Concurrent.Strict (modifyVar_, newVar, - threadDelay) -import Control.Monad.Extra hiding (loop) -import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Data.Functor (($>)) -import qualified Data.Text as T -import Development.IDE.GHC.Orphans () -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import qualified Focus -import Language.LSP.Protocol.Types -import Language.LSP.Server (ProgressAmount (..), - ProgressCancellable (..), - withProgress) -import qualified Language.LSP.Server as LSP -import qualified StmContainers.Map as STM -import UnliftIO (Async, MonadUnliftIO, async, - bracket, cancel) +import Control.Concurrent.STM (STM) +import Control.Concurrent.STM.Stats + ( TVar, + atomically, + atomicallyNamed, + modifyTVar', + newTVarIO, + readTVar, + retry, + ) +import Control.Concurrent.Strict + ( modifyVar_, + newVar, + threadDelay, + ) +import Control.Monad.Extra hiding (loop) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import Data.Functor (($>)) +import Data.Text qualified as T +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import Focus qualified +import Language.LSP.Protocol.Types +import Language.LSP.Server + ( ProgressAmount (..), + ProgressCancellable (..), + withProgress, + ) +import Language.LSP.Server qualified as LSP +import StmContainers.Map qualified as STM +import UnliftIO + ( Async, + MonadUnliftIO, + async, + bracket, + cancel, + ) data ProgressEvent = ProgressStarted @@ -43,8 +59,8 @@ data ProgressEvent data ProgressReporting m = ProgressReporting { progressUpdate :: ProgressEvent -> m (), - inProgress :: forall a. NormalizedFilePath -> m a -> m a, - progressStop :: IO () + inProgress :: forall a. NormalizedFilePath -> m a -> m a, + progressStop :: IO () } noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) @@ -78,13 +94,13 @@ updateState _ StopProgress st = pure st data InProgressState = InProgressState { -- | Number of files to do - todoVar :: TVar Int, + todoVar :: TVar Int, -- | Number of files done - doneVar :: TVar Int, + doneVar :: TVar Int, currentVar :: STM.Map NormalizedFilePath Int } | InProgressStateOutSide - -- we transform the outside state into STM Int for progress reporting purposes + -- we transform the outside state into STM Int for progress reporting purposes { -- | Number of files to do todo :: STM Int, -- | Number of files done @@ -102,10 +118,10 @@ recordProgress InProgressState {..} file shift = 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 () + (Just 0, 0) -> pure () + (Just 0, _) -> modifyTVar' doneVar pred + (Just _, 0) -> modifyTVar' doneVar (+ 1) + (Just _, _) -> pure () where alterPrevAndNew = do prev <- Focus.lookup @@ -161,34 +177,34 @@ progressReporting' newState (Just lspEnv) title optProgressStyle = do 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 :: + 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 + 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 () +mRunLspT Nothing _ = pure () mRunLspTCallback :: (Monad m) => @@ -197,4 +213,4 @@ mRunLspTCallback :: m a -> m a mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) -mRunLspTCallback Nothing _ g = g +mRunLspTCallback Nothing _ g = g From fb44ba883e666e1a234e8f18e5b2d704849e0480 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 08:14:23 -0400 Subject: [PATCH 14/20] try to start at the beginning --- ghcide/src/Development/IDE/Core/Compile.hs | 23 ++++--------------- .../Development/IDE/Core/ProgressReporting.hs | 3 +++ ghcide/src/Development/IDE/Core/Shake.hs | 9 +++++--- 3 files changed, 13 insertions(+), 22 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 479781768e..73d94649ae 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -889,7 +889,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 @@ -910,22 +909,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 - pre optProgressStyle = modifyVar_ indexProgressToken $ fmap Just . \case - Just x -> return x - -- create a progressReport if we don't already have one - Nothing -> do - tt <- progressReportingOutsideState - (liftM2 (+) (HashMap.size <$> readTVar indexPending) (readTVar indexCompleted)) - (readTVar indexCompleted) - (lspEnv se) "Indexing" optProgressStyle - progressUpdate tt ProgressStarted - return tt + + pre = progressUpdate indexProgressReporting ProgressTryToStart -- Report the progress once we are done indexing this file post = do mdone <- atomically $ do @@ -940,13 +931,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 $ \_ -> - modifyVar_ indexProgressToken $ \tok -> do - case tok of - Just token -> progressUpdate token ProgressCompleted >> progressStop token - Nothing -> return () - -- 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/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index fb814f1659..a158388a6d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -56,6 +56,7 @@ import UnliftIO data ProgressEvent = ProgressStarted | ProgressCompleted + | ProgressTryToStart data ProgressReporting m = ProgressReporting { progressUpdate :: ProgressEvent -> m (), @@ -85,6 +86,8 @@ updateState :: IO () -> Transition -> State -> IO State updateState _ _ Stopped = pure Stopped updateState start (Event ProgressStarted) NotStarted = Running <$> async start updateState start (Event ProgressStarted) (Running job) = cancel job >> Running <$> async start +updateState start (Event ProgressTryToStart) NotStarted = Running <$> async start +updateState _ (Event ProgressTryToStart) (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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 102f5bcc53..c13f9c2798 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -255,8 +255,7 @@ data HieDbWriter { indexQueue :: IndexQueue , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing , indexCompleted :: TVar Int -- ^ to report progress - , indexProgressToken :: Var (Maybe (ProgressReporting IO)) - -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock + , indexProgressReporting :: ProgressReporting IO } -- | Actions to queue up on the index worker thread @@ -677,6 +676,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer restartQueue = tRestartQueue threadQueue loaderQueue = tLoaderQueue threadQueue + #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames #else @@ -697,7 +697,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 From b3a44569beeeb788e9ad968551cec3e4790caeee Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 08:43:30 -0400 Subject: [PATCH 15/20] rename --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 2 +- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 10 +++++----- ghcide/src/Development/IDE/Core/Shake.hs | 1 + 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 73d94649ae..b6b07ce255 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -916,7 +916,7 @@ indexHieFile se mod_summary srcPath !hash hf = do targetPath = Compat.ml_hie_file mod_location HieDbWriter{..} = hiedbWriter se - pre = progressUpdate indexProgressReporting ProgressTryToStart + pre = progressUpdate indexProgressReporting ProgressStarted -- Report the progress once we are done indexing this file post = do mdone <- atomically $ do diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 702261bfde..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") - progressUpdate progress ProgressStarted + progressUpdate progress ProgressNewStarted -- Update the exports map results <- uses GenerateCore files diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index a158388a6d..737f5d686d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -54,9 +54,9 @@ import UnliftIO ) data ProgressEvent - = ProgressStarted + = ProgressNewStarted | ProgressCompleted - | ProgressTryToStart + | ProgressStarted data ProgressReporting m = ProgressReporting { progressUpdate :: ProgressEvent -> m (), @@ -84,10 +84,10 @@ data Transition = Event ProgressEvent | StopProgress updateState :: IO () -> Transition -> State -> IO State 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 start (Event ProgressStarted) (Running job) = cancel job >> Running <$> async start -updateState start (Event ProgressTryToStart) NotStarted = Running <$> async start -updateState _ (Event ProgressTryToStart) (Running job) = return (Running job) +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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c13f9c2798..78228db59f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -778,6 +778,7 @@ shakeShut IdeState{..} = do for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + progressStop $ progress shakeExtras stopMonitoring From 46711436b44b5fdf85cc573cba694e5adaff59a1 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 08:45:00 -0400 Subject: [PATCH 16/20] stylish --- .../Development/IDE/Core/ProgressReporting.hs | 82 ++++++++----------- 1 file changed, 33 insertions(+), 49 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 737f5d686d..d708454ad6 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -13,45 +13,29 @@ module Development.IDE.Core.ProgressReporting ) where -import Control.Concurrent.STM (STM) -import Control.Concurrent.STM.Stats - ( TVar, - atomically, - atomicallyNamed, - modifyTVar', - newTVarIO, - readTVar, - retry, - ) -import Control.Concurrent.Strict - ( modifyVar_, - newVar, - threadDelay, - ) -import Control.Monad.Extra hiding (loop) -import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Data.Functor (($>)) -import Data.Text qualified as T -import Development.IDE.GHC.Orphans () -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import Focus qualified -import Language.LSP.Protocol.Types -import Language.LSP.Server - ( ProgressAmount (..), - ProgressCancellable (..), - withProgress, - ) -import Language.LSP.Server qualified as LSP -import StmContainers.Map qualified as STM -import UnliftIO - ( Async, - MonadUnliftIO, - async, - bracket, - cancel, - ) +import Control.Concurrent.STM (STM) +import Control.Concurrent.STM.Stats (TVar, atomically, + atomicallyNamed, modifyTVar', + newTVarIO, readTVar, retry) +import Control.Concurrent.Strict (modifyVar_, newVar, + threadDelay) +import Control.Monad.Extra hiding (loop) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import Data.Functor (($>)) +import qualified Data.Text as T +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import qualified Focus +import Language.LSP.Protocol.Types +import Language.LSP.Server (ProgressAmount (..), + ProgressCancellable (..), + withProgress) +import qualified Language.LSP.Server as LSP +import qualified StmContainers.Map as STM +import UnliftIO (Async, MonadUnliftIO, async, + bracket, cancel) data ProgressEvent = ProgressNewStarted @@ -60,8 +44,8 @@ data ProgressEvent data ProgressReporting m = ProgressReporting { progressUpdate :: ProgressEvent -> m (), - inProgress :: forall a. NormalizedFilePath -> m a -> m a, - progressStop :: IO () + inProgress :: forall a. NormalizedFilePath -> m a -> m a, + progressStop :: IO () } noProgressReporting :: (MonadUnliftIO m) => IO (ProgressReporting m) @@ -97,9 +81,9 @@ updateState _ StopProgress st = pure st data InProgressState = InProgressState { -- | Number of files to do - todoVar :: TVar Int, + todoVar :: TVar Int, -- | Number of files done - doneVar :: TVar Int, + doneVar :: TVar Int, currentVar :: STM.Map NormalizedFilePath Int } | InProgressStateOutSide @@ -121,10 +105,10 @@ recordProgress InProgressState {..} file shift = 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 () + (Just 0, 0) -> pure () + (Just 0, _) -> modifyTVar' doneVar pred + (Just _, 0) -> modifyTVar' doneVar (+ 1) + (Just _, _) -> pure () where alterPrevAndNew = do prev <- Focus.lookup @@ -207,7 +191,7 @@ progressCounter lspEnv title optProgressStyle getTodo getDone = mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f -mRunLspT Nothing _ = pure () +mRunLspT Nothing _ = pure () mRunLspTCallback :: (Monad m) => @@ -216,4 +200,4 @@ mRunLspTCallback :: m a -> m a mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) -mRunLspTCallback Nothing _ g = g +mRunLspTCallback Nothing _ g = g From 477e481120d55518b7657e9900777b0eb2b5d439 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 17 Jun 2024 08:49:33 -0400 Subject: [PATCH 17/20] add shutdown --- ghcide/src/Development/IDE/Core/Shake.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 78228db59f..e201347669 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -252,9 +252,9 @@ 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 + { indexQueue :: IndexQueue + , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing + , indexCompleted :: TVar Int -- ^ to report progress , indexProgressReporting :: ProgressReporting IO } @@ -778,7 +778,7 @@ shakeShut IdeState{..} = do for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras - progressStop $ progress shakeExtras + progressStop $ indexProgressReporting $ hiedbWriter shakeExtras stopMonitoring From 51acba74b70eb2d84774623c48cd6aa0f80e7604 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 20 Jun 2024 13:59:29 +0800 Subject: [PATCH 18/20] add note --- .../Development/IDE/Core/ProgressReporting.hs | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index d708454ad6..7586ff496c 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -45,9 +45,28 @@ data ProgressEvent 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. } +{- 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 $ @@ -78,6 +97,7 @@ updateState _ StopProgress (Running job) = cancel job $> Stopped updateState _ StopProgress st = pure st -- | Data structure to track progress across the project +-- see Note [ProgressReporting API and InProgressState] data InProgressState = InProgressState { -- | Number of files to do From 0b3808f8c1d555361fa7a56c46672405b92717ad Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 20 Jun 2024 14:03:52 +0800 Subject: [PATCH 19/20] add Note --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 7586ff496c..7815a984ca 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -137,6 +137,10 @@ recordProgress InProgressState {..} file shift = do return (prev, new) 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) -> @@ -145,6 +149,9 @@ progressReporting :: 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 -> From d21ba21840410140fd63fa40ad37e8e9eaa5aa53 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 21 Jun 2024 01:02:00 +0800 Subject: [PATCH 20/20] fix --- ghcide/src/Development/IDE/Core/Shake.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6d0e993560..7c53b09c7b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -664,11 +664,6 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer restartQueue = tRestartQueue threadQueue loaderQueue = tLoaderQueue threadQueue -<<<<<<< soulomoon/wait-for-token-indexHieFile - -#if MIN_VERSION_ghc(9,3,0) -======= ->>>>>>> master ideNc <- initNameCache 'r' knownKeyNames shakeExtras <- do globals <- newTVarIO HMap.empty