From 480927125202f6af627cca0b94e0951663b2a615 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 14:03:49 +0100 Subject: [PATCH 01/12] factor out progress reporting --- ghcide/src/Development/IDE/Core/Shake.hs | 65 +++++++++++++++++------- 1 file changed, 46 insertions(+), 19 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index badb8628f9..3362819fad 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -183,8 +184,8 @@ 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 -- accumlation of all previous mappings. - ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) - -- ^ How many rules are running for each file + ,inProgress :: forall a . NormalizedFilePath -> Action a -> Action a + -- ^ Report progress for a rule ,progressUpdate :: ProgressEvent -> IO () ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants @@ -473,9 +474,8 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> Rules () -> IO IdeState shakeOpen lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo + shakeProfileDir (IdeReportProgress inProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo - inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) (shakeExtras, stopProgressReporting) <- do @@ -487,23 +487,23 @@ shakeOpen lspEnv defaultConfig logger debouncer positionMapping <- newVar HMap.empty knownTargetsVar <- newVar $ hashed HMap.empty let restartShakeSession = shakeRestart ideState - mostRecentProgressEvent <- newTVarIO KickCompleted persistentKeys <- newVar HMap.empty - let progressUpdate = atomically . writeTVar mostRecentProgressEvent indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 indexProgressToken <- newVar Nothing let hiedbWriter = HieDbWriter{..} - progressAsync <- async $ - when reportProgress $ - progressThread optProgressStyle mostRecentProgressEvent inProgress exportsMap <- newVar mempty + ProgressReporting{..} <- + if inProgress + then delayedProgressReporting lspEnv optProgressStyle + else noProgressReporting actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv + extras = ShakeExtras{..} - pure (ShakeExtras{..}, cancel progressAsync) + pure (extras, progressStop) (shakeDbM, shakeClose) <- shakeOpenDatabase opts { shakeExtra = newShakeExtra shakeExtras } @@ -520,6 +520,34 @@ shakeOpen lspEnv defaultConfig logger debouncer startTelemetry otProfilingEnabled logger $ state shakeExtras return ideState + +data ProgressReporting = ProgressReporting + { progressUpdate :: ProgressEvent -> IO () + , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a + , progressStop :: IO () + } + +noProgressReporting :: IO ProgressReporting +noProgressReporting = return $ ProgressReporting + { progressUpdate = const $ pure () + , inProgress = const id + , progressStop = pure () + } + +delayedProgressReporting + :: Maybe (LSP.LanguageContextEnv c) + -> ProgressReportingStyle + -> IO ProgressReporting +delayedProgressReporting lspEnv optProgressStyle = do + inProgressVar <- newVar HMap.empty + mostRecentProgressEvent <- newTVarIO KickCompleted + progressAsync <- async $ + progressThread optProgressStyle mostRecentProgressEvent inProgressVar + let progressUpdate = atomically . writeTVar mostRecentProgressEvent + progressStop = cancel progressAsync + inProgress :: NormalizedFilePath -> Action a -> Action a + inProgress = withProgressVar inProgressVar + return ProgressReporting{..} where -- The progress thread is a state machine with two states: -- 1. Idle @@ -550,7 +578,7 @@ shakeOpen lspEnv defaultConfig logger debouncer lspShakeProgress = do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ unless testing $ sleep 0.1 + liftIO $ sleep 0.1 u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate @@ -608,6 +636,12 @@ shakeOpen lspEnv defaultConfig logger debouncer } loop id next + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) + -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do @@ -952,7 +986,7 @@ defineEarlyCutoff' defineEarlyCutoff' doDiagnostics key file old mode action = do extras@ShakeExtras{state, inProgress, logger} <- getShakeExtras options <- getIdeOptions - (if optSkipProgress options key then id else withProgressVar inProgress file) $ do + (if optSkipProgress options key then id else inProgress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do v <- liftIO $ getValues state key file @@ -1001,13 +1035,6 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do A res where - withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) - isSuccess :: RunResult (A v) -> Bool isSuccess (RunResult _ _ (A Failed{})) = False isSuccess _ = True From 3d9fbdd185844805033abe705c71e694c73023e1 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 09:28:14 +0100 Subject: [PATCH 02/12] extract out progress reporting --- ghcide/ghcide.cabal | 1 + .../Development/IDE/Core/ProgressReporting.hs | 168 ++++++++++++++++ ghcide/src/Development/IDE/Core/Shake.hs | 186 +++--------------- 3 files changed, 193 insertions(+), 162 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/ProgressReporting.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 216fb1f5f0..f91fe08535 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -150,6 +150,7 @@ library Development.IDE.Core.OfInterest Development.IDE.Core.PositionMapping Development.IDE.Core.Preprocessor + Development.IDE.Core.ProgressReporting Development.IDE.Core.Rules Development.IDE.Core.RuleTypes Development.IDE.Core.Service diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs new file mode 100644 index 0000000000..70b95e4351 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE RankNTypes #-} +module Development.IDE.Core.ProgressReporting + ( ProgressEvent(..) + , ProgressReporting(..) + , noProgressReporting + , delayedProgressReporting + -- utilities, reexported for use in Core.Shake + , mRunLspT + , mRunLspTCallback + ) + where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.Strict +import Control.Monad.Extra +import Control.Monad.IO.Class +import qualified Control.Monad.STM as STM +import Control.Monad.Trans.Class (lift) +import qualified Data.HashMap.Strict as HMap +import qualified Data.Text as T +import Data.Unique +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import System.Time.Extra +import UnliftIO.Exception (bracket_) + +data ProgressEvent + = KickStarted + | KickCompleted + +data ProgressReporting = ProgressReporting + { progressUpdate :: ProgressEvent -> IO () + , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a + , progressStop :: IO () + } + +noProgressReporting :: IO ProgressReporting +noProgressReporting = return $ ProgressReporting + { progressUpdate = const $ pure () + , inProgress = const id + , progressStop = pure () + } + +delayedProgressReporting + :: Maybe (LSP.LanguageContextEnv c) + -> ProgressReportingStyle + -> IO ProgressReporting +delayedProgressReporting lspEnv optProgressStyle = do + inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) + mostRecentProgressEvent <- newTVarIO KickCompleted + progressAsync <- async $ + progressThread optProgressStyle mostRecentProgressEvent inProgressVar + let progressUpdate = atomically . writeTVar mostRecentProgressEvent + progressStop = cancel progressAsync + inProgress :: NormalizedFilePath -> Action a -> Action a + inProgress = withProgressVar inProgressVar + return ProgressReporting{..} + where + -- The progress thread is a state machine with two states: + -- 1. Idle + -- 2. Reporting a kick event + -- And two transitions, modelled by 'ProgressEvent': + -- 1. KickCompleted - transitions from Reporting into Idle + -- 2. KickStarted - transitions from Idle into Reporting + progressThread style mostRecentProgressEvent inProgress = progressLoopIdle + where + progressLoopIdle = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickCompleted -> STM.retry + KickStarted -> return () + asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress + progressLoopReporting asyncReporter + progressLoopReporting asyncReporter = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickStarted -> STM.retry + KickCompleted -> return () + cancel asyncReporter + progressLoopIdle + + lspShakeProgress :: LSP.LspM config () + lspShakeProgress = do + -- first sleep a bit, so we only show progress messages if it's going to take + -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) + liftIO $ sleep 0.1 + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + + bracket_ + (start u) + (stop u) + (loop u 0) + where + start id = LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Begin $ WorkDoneProgressBeginParams + { _title = "Processing" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + stop id = LSP.sendNotification LSP.SProgress + LSP.ProgressParams + { _token = id + , _value = LSP.End WorkDoneProgressEndParams + { _message = Nothing + } + } + sample = 0.1 + loop id prev = do + liftIO $ sleep sample + current <- liftIO $ readVar inProgress + let done = length $ filter (== 0) $ HMap.elems current + let todo = HMap.size current + let next = 100 * fromIntegral done / fromIntegral todo + when (next /= prev) $ + LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Report $ case style of + Explicit -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack $ show done <> "/" <> show todo + , _percentage = Nothing + } + Percentage -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Just next + } + NoProgress -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + loop id next + + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) + +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 (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) +mRunLspTCallback Nothing _ g = g diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 3362819fad..30aac9eb5d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -85,35 +85,35 @@ import Control.DeepSeq import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader -import qualified Control.Monad.STM as STM import Control.Monad.Trans.Maybe -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS import Data.Dynamic -import qualified Data.HashMap.Strict as HMap +import qualified Data.HashMap.Strict as HMap import Data.Hashable -import Data.List.Extra (partition, takeEnd) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.List.Extra (partition, takeEnd) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set -import qualified Data.SortedList as SL -import qualified Data.Text as T +import qualified Data.Set as Set +import qualified Data.SortedList as SL +import qualified Data.Text as T import Data.Time import Data.Traversable import Data.Tuple.Extra import Data.Typeable import Data.Unique -import Data.Vector (Vector) -import qualified Data.Vector as Vector +import Data.Vector (Vector) +import qualified Data.Vector as Vector import Development.IDE.Core.Debouncer import Development.IDE.Core.PositionMapping +import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing -import Development.IDE.GHC.Compat (NameCacheUpdater (..), - upNameCache) -import Development.IDE.GHC.Orphans () -import Development.IDE.Graph hiding (ShakeValue) -import qualified Development.IDE.Graph as Shake +import Development.IDE.GHC.Compat (NameCacheUpdater (..), + upNameCache) +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Classes import Development.IDE.Graph.Database import Development.IDE.Graph.Rule @@ -122,17 +122,17 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding (Priority) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger hiding (Priority) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Development.IDE.Types.Shake import GHC.Generics import Language.LSP.Diagnostics -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.Types -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types as LSP import Language.LSP.VFS -import System.FilePath hiding (makeRelative) +import System.FilePath hiding (makeRelative) import System.Time.Extra import Data.IORef @@ -143,13 +143,12 @@ import OpenTelemetry.Eventlog import PrelInfo import UniqSupply -import Control.Exception.Extra hiding (bracket_) +import Control.Exception.Extra hiding (bracket_) import Data.Default import HieDb.Types import Ide.Plugin.Config -import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) -import UnliftIO.Exception (bracket_) +import qualified Ide.PluginUtils as HLS +import Ide.Types (PluginId) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -213,10 +212,6 @@ type WithProgressFunc = forall a. type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a -data ProgressEvent - = KickStarted - | KickCompleted - type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) getShakeExtras :: Action ShakeExtras @@ -521,127 +516,6 @@ shakeOpen lspEnv defaultConfig logger debouncer return ideState -data ProgressReporting = ProgressReporting - { progressUpdate :: ProgressEvent -> IO () - , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a - , progressStop :: IO () - } - -noProgressReporting :: IO ProgressReporting -noProgressReporting = return $ ProgressReporting - { progressUpdate = const $ pure () - , inProgress = const id - , progressStop = pure () - } - -delayedProgressReporting - :: Maybe (LSP.LanguageContextEnv c) - -> ProgressReportingStyle - -> IO ProgressReporting -delayedProgressReporting lspEnv optProgressStyle = do - inProgressVar <- newVar HMap.empty - mostRecentProgressEvent <- newTVarIO KickCompleted - progressAsync <- async $ - progressThread optProgressStyle mostRecentProgressEvent inProgressVar - let progressUpdate = atomically . writeTVar mostRecentProgressEvent - progressStop = cancel progressAsync - inProgress :: NormalizedFilePath -> Action a -> Action a - inProgress = withProgressVar inProgressVar - return ProgressReporting{..} - where - -- The progress thread is a state machine with two states: - -- 1. Idle - -- 2. Reporting a kick event - -- And two transitions, modelled by 'ProgressEvent': - -- 1. KickCompleted - transitions from Reporting into Idle - -- 2. KickStarted - transitions from Idle into Reporting - progressThread style mostRecentProgressEvent inProgress = progressLoopIdle - where - progressLoopIdle = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickCompleted -> STM.retry - KickStarted -> return () - asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress - progressLoopReporting asyncReporter - progressLoopReporting asyncReporter = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickStarted -> STM.retry - KickCompleted -> return () - cancel asyncReporter - progressLoopIdle - - lspShakeProgress :: LSP.LspM config () - lspShakeProgress = do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ sleep 0.1 - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique - - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) - - bracket_ - (start u) - (stop u) - (loop u 0) - where - start id = LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop id = LSP.sendNotification LSP.SProgress - LSP.ProgressParams - { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing - } - } - sample = 0.1 - loop id prev = do - liftIO $ sleep sample - current <- liftIO $ readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current - let next = 100 * fromIntegral done / fromIntegral todo - when (next /= prev) $ - LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Report $ case style of - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack $ show done <> "/" <> show todo - , _percentage = Nothing - } - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Just next - } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - loop id next - - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) - -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do @@ -802,18 +676,6 @@ instantiateDelayedAction (DelayedAction _ s p a) = do d' = DelayedAction (Just u) s p a' return (b, d') -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 (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) -mRunLspTCallback Nothing _ g = g - getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do val <- readVar diagnostics From 9850aa36cdfb2854d010c8c5e9aed62a8229e304 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 09:33:48 +0100 Subject: [PATCH 03/12] direct progress reporting --- .../Development/IDE/Core/ProgressReporting.hs | 253 +++++++++++------- ghcide/src/Development/IDE/Core/Shake.hs | 9 +- 2 files changed, 163 insertions(+), 99 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 70b95e4351..70c3d4a014 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -4,11 +4,11 @@ module Development.IDE.Core.ProgressReporting , ProgressReporting(..) , noProgressReporting , delayedProgressReporting + , directProgressReporting -- utilities, reexported for use in Core.Shake , mRunLspT , mRunLspTCallback - ) - where + ) where import Control.Concurrent.Async import Control.Concurrent.STM @@ -17,13 +17,18 @@ import Control.Monad.Extra import Control.Monad.IO.Class import qualified Control.Monad.STM as STM import Control.Monad.Trans.Class (lift) +import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap +import Data.IORef import qualified Data.Text as T import Data.Unique import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options +import GHC.IORef (atomicModifyIORef'_, + atomicSwapIORef) import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP @@ -47,113 +52,169 @@ noProgressReporting = return $ ProgressReporting , progressStop = pure () } +-- | A 'ProgressReporting' that sends the WorkDone Begin and End notifications +-- synchronously. Progress notifications are sent from a sampling thread. +directProgressReporting + :: Double -- ^ sampling rate + -> Maybe (LSP.LanguageContextEnv config) + -> ProgressReportingStyle + -> IO ProgressReporting +directProgressReporting sample env style = do + st <- newIORef Nothing + inProgressVar <- newIORef (HMap.empty @NormalizedFilePath @Int) + + let progressUpdate KickStarted = do + u <- newProgressToken + writeIORef st (Just u) + mRunLspT env $ start u + progressUpdate KickCompleted = do + mbToken <- atomicSwapIORef st Nothing + for_ mbToken $ \u -> + mRunLspT env $ stop u + + inProgress file = actionBracket (f file succ) (const $ f file pred) . const + -- This function is deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + f file shift = atomicModifyIORef'_ inProgressVar $ + HMap.insertWith (\_ x -> shift x) file (shift 0) + + progressLoop :: Double -> LSP.LspM a () + progressLoop prev = do + mbToken <- liftIO $ readIORef st + case mbToken of + Nothing -> + liftIO (sleep sample) >> progressLoop 0 + Just t -> do + current <- liftIO $ readIORef inProgressVar + prev <- progress style prev current t + liftIO $ sleep sample + progressLoop prev + + progressThread <- async $ mRunLspT env $ progressLoop 0 + let progressStop = cancel progressThread + + pure ProgressReporting {..} + +-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new +-- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives +-- before the end of the grace period). +-- Avoid using in tests where progress notifications are used to assert invariants. delayedProgressReporting - :: Maybe (LSP.LanguageContextEnv c) + :: Double -- ^ sampling rate, also used as grace period before Begin + -> Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting -delayedProgressReporting lspEnv optProgressStyle = do +delayedProgressReporting sample lspEnv style = do inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) mostRecentProgressEvent <- newTVarIO KickCompleted progressAsync <- async $ - progressThread optProgressStyle mostRecentProgressEvent inProgressVar + progressThread mostRecentProgressEvent inProgressVar let progressUpdate = atomically . writeTVar mostRecentProgressEvent progressStop = cancel progressAsync inProgress :: NormalizedFilePath -> Action a -> Action a inProgress = withProgressVar inProgressVar return ProgressReporting{..} - where - -- The progress thread is a state machine with two states: - -- 1. Idle - -- 2. Reporting a kick event - -- And two transitions, modelled by 'ProgressEvent': - -- 1. KickCompleted - transitions from Reporting into Idle - -- 2. KickStarted - transitions from Idle into Reporting - progressThread style mostRecentProgressEvent inProgress = progressLoopIdle - where - progressLoopIdle = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickCompleted -> STM.retry - KickStarted -> return () - asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress - progressLoopReporting asyncReporter - progressLoopReporting asyncReporter = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickStarted -> STM.retry - KickCompleted -> return () - cancel asyncReporter - progressLoopIdle - - lspShakeProgress :: LSP.LspM config () - lspShakeProgress = do + where + -- The progress thread is a state machine with two states: + -- 1. Idle + -- 2. Reporting a kick event + -- And two transitions, modelled by 'ProgressEvent': + -- 1. KickCompleted - transitions from Reporting into Idle + -- 2. KickStarted - transitions from Idle into Reporting + progressThread mostRecentProgressEvent inProgress = progressLoopIdle + where + progressLoopIdle = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickCompleted -> STM.retry + KickStarted -> return () + asyncReporter <- async $ mRunLspT lspEnv $ do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ sleep 0.1 - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique - - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) - - bracket_ - (start u) - (stop u) - (loop u 0) - where - start id = LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop id = LSP.sendNotification LSP.SProgress - LSP.ProgressParams - { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing - } - } - sample = 0.1 - loop id prev = do - liftIO $ sleep sample - current <- liftIO $ readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current - let next = 100 * fromIntegral done / fromIntegral todo - when (next /= prev) $ - LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Report $ case style of - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack $ show done <> "/" <> show todo - , _percentage = Nothing - } - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Just next - } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - loop id next - - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) + liftIO $ sleep sample + lspShakeProgress style inProgress + progressLoopReporting asyncReporter + progressLoopReporting asyncReporter = do + atomically $ do + v <- readTVar mostRecentProgressEvent + case v of + KickStarted -> STM.retry + KickCompleted -> return () + cancel asyncReporter + progressLoopIdle + + lspShakeProgress style inProgress = do + u <- liftIO newProgressToken + + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + + bracket_ (start u) (stop u) (loop u 0) + where + loop id prev = do + liftIO $ sleep sample + current <- liftIO $ readVar inProgress + next <- progress style prev current id + loop id next + + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) + +newProgressToken :: IO ProgressToken +newProgressToken = ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + + +start :: LSP.MonadLsp config f => ProgressToken -> f () +start id = LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Begin $ WorkDoneProgressBeginParams + { _title = "Processing" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } +stop :: LSP.MonadLsp config f => ProgressToken -> f () +stop id = LSP.sendNotification LSP.SProgress + LSP.ProgressParams + { _token = id + , _value = LSP.End WorkDoneProgressEndParams + { _message = Nothing + } + } + +progress :: (LSP.MonadLsp config f) => + ProgressReportingStyle -> Double -> HashMap NormalizedFilePath Int -> ProgressToken -> f Double +progress style prev current id = do + let done = length $ filter (== 0) $ HMap.elems current + let todo = HMap.size current + let next = 100 * fromIntegral done / fromIntegral todo + when (next /= prev) $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams + { _token = id + , _value = LSP.Report $ case style of + Explicit -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack $ show done <> "/" <> show todo + , _percentage = Nothing + } + Percentage -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Just next + } + NoProgress -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + return next mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 30aac9eb5d..d3a27f023f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -469,7 +469,7 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> Rules () -> IO IdeState shakeOpen lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress inProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -490,8 +490,11 @@ shakeOpen lspEnv defaultConfig logger debouncer exportsMap <- newVar mempty ProgressReporting{..} <- - if inProgress - then delayedProgressReporting lspEnv optProgressStyle + if reportProgress + then (if testing + then directProgressReporting + else delayedProgressReporting + ) 0.1 lspEnv optProgressStyle else noProgressReporting actionQueue <- newQueue From 4725002fd9d8dc4f8361ead06f75f1994b3a0f9f Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 12:38:10 +0100 Subject: [PATCH 04/12] hlint --- ghcide/src/Development/IDE/Core/Shake.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d3a27f023f..9c66e958f0 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -898,7 +898,6 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - where isSuccess :: RunResult (A v) -> Bool isSuccess (RunResult _ _ (A Failed{})) = False From c969332c43d85e9cb7a074950af1d74ae3ee6bc7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 13:26:39 +0100 Subject: [PATCH 05/12] compat with 8.6 --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 70c3d4a014..2d5c9e9d1b 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -21,14 +21,13 @@ import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap import Data.IORef +import Data.IORef.Extra (atomicModifyIORef'_) import qualified Data.Text as T import Data.Unique import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC.IORef (atomicModifyIORef'_, - atomicSwapIORef) import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP @@ -68,7 +67,7 @@ directProgressReporting sample env style = do writeIORef st (Just u) mRunLspT env $ start u progressUpdate KickCompleted = do - mbToken <- atomicSwapIORef st Nothing + mbToken <- atomicModifyIORef st (Nothing,) for_ mbToken $ \u -> mRunLspT env $ stop u From a02f4954656585b8ead6fbf784e9f807dd289694 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 16:46:08 +0100 Subject: [PATCH 06/12] apply feedbacks --- ghcide/src/Development/IDE/Core/OfInterest.hs | 7 +-- .../Development/IDE/Core/ProgressReporting.hs | 46 +++++++++++++------ ghcide/src/Development/IDE/Core/Shake.hs | 28 +++++------ 3 files changed, 48 insertions(+), 33 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index ee56addafa..2ccca48c0c 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -32,6 +32,7 @@ import Control.Monad.Trans.Maybe import qualified Data.ByteString.Lazy as LBS import Data.List.Extra (nubOrd) import Data.Maybe (catMaybes) +import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.Import.DependencyInformation @@ -95,8 +96,8 @@ modifyFilesOfInterest state f = do kick :: Action () kick = do files <- HashMap.keys <$> getFilesOfInterest - ShakeExtras{progressUpdate} <- getShakeExtras - liftIO $ progressUpdate KickStarted + ShakeExtras{progress} <- getShakeExtras + liftIO $ progressUpdate progress KickStarted -- Update the exports map for FOIs results <- uses GenerateCore files <* uses GetHieAst files @@ -116,4 +117,4 @@ kick = do !exportsMap'' = maybe mempty createExportsMap ifaces void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>) - liftIO $ progressUpdate KickCompleted + liftIO $ progressUpdate progress KickCompleted diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2d5c9e9d1b..adc8673c61 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -53,8 +53,10 @@ noProgressReporting = return $ ProgressReporting -- | A 'ProgressReporting' that sends the WorkDone Begin and End notifications -- synchronously. Progress notifications are sent from a sampling thread. +-- +-- This 'ProgressReporting' is currently used only in tests. directProgressReporting - :: Double -- ^ sampling rate + :: Seconds -- ^ sampling rate -> Maybe (LSP.LanguageContextEnv config) -> ProgressReportingStyle -> IO ProgressReporting @@ -64,8 +66,11 @@ directProgressReporting sample env style = do let progressUpdate KickStarted = do u <- newProgressToken - writeIORef st (Just u) - mRunLspT env $ start u + mRunLspT env $ do + ready <- create u + for_ ready $ \_ -> do + start u + liftIO $ writeIORef st (Just u) progressUpdate KickCompleted = do mbToken <- atomicModifyIORef st (Nothing,) for_ mbToken $ \u -> @@ -78,17 +83,17 @@ directProgressReporting sample env style = do f file shift = atomicModifyIORef'_ inProgressVar $ HMap.insertWith (\_ x -> shift x) file (shift 0) - progressLoop :: Double -> LSP.LspM a () + progressLoop :: Seconds -> LSP.LspM a () progressLoop prev = do mbToken <- liftIO $ readIORef st - case mbToken of + next <- case mbToken of Nothing -> - liftIO (sleep sample) >> progressLoop 0 + pure 0 Just t -> do current <- liftIO $ readIORef inProgressVar - prev <- progress style prev current t - liftIO $ sleep sample - progressLoop prev + progress style prev current t + liftIO $ sleep sample + progressLoop next progressThread <- async $ mRunLspT env $ progressLoop 0 let progressStop = cancel progressThread @@ -100,7 +105,7 @@ directProgressReporting sample env style = do -- before the end of the grace period). -- Avoid using in tests where progress notifications are used to assert invariants. delayedProgressReporting - :: Double -- ^ sampling rate, also used as grace period before Begin + :: Seconds -- ^ sampling rate, also used as grace period before Begin -> Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting @@ -121,6 +126,9 @@ delayedProgressReporting sample lspEnv style = do -- And two transitions, modelled by 'ProgressEvent': -- 1. KickCompleted - transitions from Reporting into Idle -- 2. KickStarted - transitions from Idle into Reporting + -- When transitioning from Idle to Reporting a new async is spawned that + -- sends progress updates in a loop. The async is cancelled when transitioning + -- from Reporting to Idle. progressThread mostRecentProgressEvent inProgress = progressLoopIdle where progressLoopIdle = do @@ -147,10 +155,10 @@ delayedProgressReporting sample lspEnv style = do lspShakeProgress style inProgress = do u <- liftIO newProgressToken - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + ready <- create u - bracket_ (start u) (stop u) (loop u 0) + for_ ready $ \_ -> + bracket_ (start u) (stop u) (loop u 0) where loop id prev = do liftIO $ sleep sample @@ -167,6 +175,16 @@ delayedProgressReporting sample lspEnv style = do newProgressToken :: IO ProgressToken newProgressToken = ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique +create + :: LSP.MonadLsp config f + => ProgressToken + -> f (Either ResponseError Empty) +create u = do + b <- liftIO newBarrier + _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } + (liftIO . signalBarrier b) + liftIO $ waitBarrier b start :: LSP.MonadLsp config f => ProgressToken -> f () start id = LSP.sendNotification LSP.SProgress $ @@ -189,7 +207,7 @@ stop id = LSP.sendNotification LSP.SProgress } progress :: (LSP.MonadLsp config f) => - ProgressReportingStyle -> Double -> HashMap NormalizedFilePath Int -> ProgressToken -> f Double + ProgressReportingStyle -> Seconds -> HashMap NormalizedFilePath Int -> ProgressToken -> f Seconds progress style prev current id = do let done = length $ filter (== 0) $ HMap.elems current let todo = HMap.size current diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9c66e958f0..ba0973550d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -183,9 +183,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 -- accumlation of all previous mappings. - ,inProgress :: forall a . NormalizedFilePath -> Action a -> Action a - -- ^ Report progress for a rule - ,progressUpdate :: ProgressEvent -> IO () + ,progress :: ProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession :: [DelayedAction ()] -> IO () @@ -378,12 +376,11 @@ newtype ShakeSession = ShakeSession -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState - {shakeDb :: ShakeDatabase - ,shakeSession :: MVar ShakeSession - ,shakeClose :: IO () - ,shakeExtras :: ShakeExtras - ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) - ,stopProgressReporting :: IO () + {shakeDb :: ShakeDatabase + ,shakeSession :: MVar ShakeSession + ,shakeClose :: IO () + ,shakeExtras :: ShakeExtras + ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) } @@ -473,7 +470,7 @@ shakeOpen lspEnv defaultConfig logger debouncer us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) - (shakeExtras, stopProgressReporting) <- do + shakeExtras <- do globals <- newVar HMap.empty state <- newVar HMap.empty diagnostics <- newVar mempty @@ -489,7 +486,7 @@ shakeOpen lspEnv defaultConfig logger debouncer let hiedbWriter = HieDbWriter{..} exportsMap <- newVar mempty - ProgressReporting{..} <- + progress <- if reportProgress then (if testing then directProgressReporting @@ -499,9 +496,8 @@ shakeOpen lspEnv defaultConfig logger debouncer actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - extras = ShakeExtras{..} - pure (extras, progressStop) + pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase opts { shakeExtra = newShakeExtra shakeExtras } @@ -534,7 +530,7 @@ shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do -- request so we first abort that. void $ cancelShakeSession runner shakeClose - stopProgressReporting + progressStop $ progress shakeExtras -- | This is a variant of withMVar where the first argument is run unmasked and if it throws @@ -849,9 +845,9 @@ defineEarlyCutoff' -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics key file old mode action = do - extras@ShakeExtras{state, inProgress, logger} <- getShakeExtras + extras@ShakeExtras{state, progress, logger} <- getShakeExtras options <- getIdeOptions - (if optSkipProgress options key then id else inProgress file) $ do + (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do v <- liftIO $ getValues state key file From be621ee1b4c26c956ab4ab0d2e62e59a626bd0b1 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 21:00:32 +0100 Subject: [PATCH 07/12] Fix benchmarks --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index adc8673c61..5e603da7df 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -17,7 +17,7 @@ import Control.Monad.Extra import Control.Monad.IO.Class import qualified Control.Monad.STM as STM import Control.Monad.Trans.Class (lift) -import Data.Foldable (for_) +import Data.Foldable (for_, traverse_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap import Data.IORef @@ -65,6 +65,7 @@ directProgressReporting sample env style = do inProgressVar <- newIORef (HMap.empty @NormalizedFilePath @Int) let progressUpdate KickStarted = do + readIORef st >>= traverse_ (mRunLspT env . stop) u <- newProgressToken mRunLspT env $ do ready <- create u From 794a48f0c7610807b21fcf7103e17cff728b96b2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 25 Apr 2021 09:24:17 +0100 Subject: [PATCH 08/12] Fix splice plugin tests --- hls-test-utils/src/Test/Hls.hs | 17 ++++++++++++++++- plugins/hls-splice-plugin/test/Main.hs | 5 +++-- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 71418fe61d..f14fd084d5 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} module Test.Hls ( module Test.Tasty.HUnit, @@ -14,6 +15,7 @@ module Test.Hls runSessionWithServer, runSessionWithServerFormatter, runSessionWithServer', + waitForProgressDone, PluginDescriptor, IdeState, ) @@ -23,17 +25,18 @@ import Control.Applicative.Combinators import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base +import Control.Monad (unless) import Control.Monad.IO.Class import Data.ByteString.Lazy (ByteString) import Data.Default (def) import qualified Data.Text as T import Development.IDE (IdeState, hDuplicateTo', noLogging) +import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Types.Options -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import GHC.IO.Handle import Ide.Plugin.Config (Config, formattingProvider) import Ide.PluginUtils (pluginDescToIdePlugins) @@ -134,3 +137,15 @@ runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurren (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" pure x + +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return +waitForProgressDone :: Session () +waitForProgressDone = loop + where + loop = do + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + _ -> Nothing + done <- null <$> getIncompleteProgressSessions + unless done loop diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 517fafa7a5..3fed1435df 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -99,7 +99,8 @@ goldenTestWithEdit input tc line col = { _start = Position 0 0 , _end = Position (length lns + 1) 1 } - liftIO $ sleep 3 + waitForProgressDone -- cradle + waitForProgressDone alt <- liftIO $ T.readFile (input <.> "error") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] @@ -131,5 +132,5 @@ pointRange -- | Get the title of a code action. codeActionTitle :: (Command |? CodeAction) -> Maybe Text -codeActionTitle InL{} = Nothing +codeActionTitle InL{} = Nothing codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title From 5c2cf2feb4d65761642b96d8a6d60a64ceb581bc Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 25 Apr 2021 14:40:44 +0100 Subject: [PATCH 09/12] fix client settings test --- ghcide/test/exe/Main.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 94529222ed..86b1fd8ea3 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4997,18 +4997,16 @@ clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do void $ skipManyTill anyMessage $ message SClientRegisterCapability + waitForProgressDone sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) - nots <- skipManyTill anyMessage $ count 3 loggingNotification - isMessagePresent "Restarting build session" (map getLogMessage nots) + skipManyTill anyMessage restartingBuildSession ] - where getLogMessage :: FromServerMessage -> T.Text - getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg - getLogMessage _ = "" - - isMessagePresent expectedMsg actualMsgs = liftIO $ - assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs) - (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs) + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message referenceTests :: TestTree referenceTests = testGroup "references" From 47bf559b18ee1f195e1241b02fadb10ce0409cc3 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 30 Apr 2021 21:31:33 +0100 Subject: [PATCH 10/12] Sacrifice delayedProgressReporting --- .../Development/IDE/Core/ProgressReporting.hs | 86 ++----------------- ghcide/src/Development/IDE/Core/Shake.hs | 9 +- 2 files changed, 11 insertions(+), 84 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 5e603da7df..6faf258d81 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -3,19 +3,16 @@ module Development.IDE.Core.ProgressReporting ( ProgressEvent(..) , ProgressReporting(..) , noProgressReporting - , delayedProgressReporting - , directProgressReporting + , makeProgressReporting -- utilities, reexported for use in Core.Shake , mRunLspT , mRunLspTCallback ) where import Control.Concurrent.Async -import Control.Concurrent.STM import Control.Concurrent.Strict import Control.Monad.Extra import Control.Monad.IO.Class -import qualified Control.Monad.STM as STM import Control.Monad.Trans.Class (lift) import Data.Foldable (for_, traverse_) import Data.HashMap.Strict (HashMap) @@ -32,7 +29,6 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP import System.Time.Extra -import UnliftIO.Exception (bracket_) data ProgressEvent = KickStarted @@ -55,14 +51,16 @@ noProgressReporting = return $ ProgressReporting -- synchronously. Progress notifications are sent from a sampling thread. -- -- This 'ProgressReporting' is currently used only in tests. -directProgressReporting +makeProgressReporting :: Seconds -- ^ sampling rate + -> Seconds -- ^ initial delay -> Maybe (LSP.LanguageContextEnv config) -> ProgressReportingStyle -> IO ProgressReporting -directProgressReporting sample env style = do +makeProgressReporting sample delay env style = do st <- newIORef Nothing inProgressVar <- newIORef (HMap.empty @NormalizedFilePath @Int) + delayVar <- newIORef delay let progressUpdate KickStarted = do readIORef st >>= traverse_ (mRunLspT env . stop) @@ -86,6 +84,8 @@ directProgressReporting sample env style = do progressLoop :: Seconds -> LSP.LspM a () progressLoop prev = do + delayActual <- liftIO $ atomicModifyIORef delayVar (0,) + liftIO $ sleep delayActual mbToken <- liftIO $ readIORef st next <- case mbToken of Nothing -> @@ -101,78 +101,6 @@ directProgressReporting sample env style = do pure ProgressReporting {..} --- | A 'ProgressReporting' that enqueues Begin and End notifications in a new --- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives --- before the end of the grace period). --- Avoid using in tests where progress notifications are used to assert invariants. -delayedProgressReporting - :: Seconds -- ^ sampling rate, also used as grace period before Begin - -> Maybe (LSP.LanguageContextEnv c) - -> ProgressReportingStyle - -> IO ProgressReporting -delayedProgressReporting sample lspEnv style = do - inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) - mostRecentProgressEvent <- newTVarIO KickCompleted - progressAsync <- async $ - progressThread mostRecentProgressEvent inProgressVar - let progressUpdate = atomically . writeTVar mostRecentProgressEvent - progressStop = cancel progressAsync - inProgress :: NormalizedFilePath -> Action a -> Action a - inProgress = withProgressVar inProgressVar - return ProgressReporting{..} - where - -- The progress thread is a state machine with two states: - -- 1. Idle - -- 2. Reporting a kick event - -- And two transitions, modelled by 'ProgressEvent': - -- 1. KickCompleted - transitions from Reporting into Idle - -- 2. KickStarted - transitions from Idle into Reporting - -- When transitioning from Idle to Reporting a new async is spawned that - -- sends progress updates in a loop. The async is cancelled when transitioning - -- from Reporting to Idle. - progressThread mostRecentProgressEvent inProgress = progressLoopIdle - where - progressLoopIdle = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickCompleted -> STM.retry - KickStarted -> return () - asyncReporter <- async $ mRunLspT lspEnv $ do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ sleep sample - lspShakeProgress style inProgress - progressLoopReporting asyncReporter - progressLoopReporting asyncReporter = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickStarted -> STM.retry - KickCompleted -> return () - cancel asyncReporter - progressLoopIdle - - lspShakeProgress style inProgress = do - u <- liftIO newProgressToken - - ready <- create u - - for_ ready $ \_ -> - bracket_ (start u) (stop u) (loop u 0) - where - loop id prev = do - liftIO $ sleep sample - current <- liftIO $ readVar inProgress - next <- progress style prev current id - loop id next - - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) - newProgressToken :: IO ProgressToken newProgressToken = ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index ba0973550d..526f5a6325 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -486,12 +486,11 @@ shakeOpen lspEnv defaultConfig logger debouncer let hiedbWriter = HieDbWriter{..} exportsMap <- newVar mempty - progress <- + progress <- do + let delay = if testing then 0 else 0.1 + sampling = 0.1 if reportProgress - then (if testing - then directProgressReporting - else delayedProgressReporting - ) 0.1 lspEnv optProgressStyle + then makeProgressReporting delay sampling lspEnv optProgressStyle else noProgressReporting actionQueue <- newQueue From 7ae8b1680eae8b52f006fb5df8be8fd7ce106532 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 1 May 2021 10:24:02 +0100 Subject: [PATCH 11/12] round 2 --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 12 +++++------- ghcide/src/Development/IDE/Core/Shake.hs | 6 +++--- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 6faf258d81..3c4d87d01e 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -52,15 +52,14 @@ noProgressReporting = return $ ProgressReporting -- -- This 'ProgressReporting' is currently used only in tests. makeProgressReporting - :: Seconds -- ^ sampling rate - -> Seconds -- ^ initial delay + :: Seconds -- ^ sleep before reporting + -> Seconds -- ^ sleep after reporting -> Maybe (LSP.LanguageContextEnv config) -> ProgressReportingStyle -> IO ProgressReporting -makeProgressReporting sample delay env style = do +makeProgressReporting before after env style = do st <- newIORef Nothing inProgressVar <- newIORef (HMap.empty @NormalizedFilePath @Int) - delayVar <- newIORef delay let progressUpdate KickStarted = do readIORef st >>= traverse_ (mRunLspT env . stop) @@ -84,8 +83,7 @@ makeProgressReporting sample delay env style = do progressLoop :: Seconds -> LSP.LspM a () progressLoop prev = do - delayActual <- liftIO $ atomicModifyIORef delayVar (0,) - liftIO $ sleep delayActual + liftIO $ sleep before mbToken <- liftIO $ readIORef st next <- case mbToken of Nothing -> @@ -93,7 +91,7 @@ makeProgressReporting sample delay env style = do Just t -> do current <- liftIO $ readIORef inProgressVar progress style prev current t - liftIO $ sleep sample + liftIO $ sleep after progressLoop next progressThread <- async $ mRunLspT env $ progressLoop 0 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 526f5a6325..d23ec29d72 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -487,10 +487,10 @@ shakeOpen lspEnv defaultConfig logger debouncer exportsMap <- newVar mempty progress <- do - let delay = if testing then 0 else 0.1 - sampling = 0.1 + let before = if testing then 0 else 0.1 + after = if testing then 0.1 else 0 if reportProgress - then makeProgressReporting delay sampling lspEnv optProgressStyle + then makeProgressReporting before after lspEnv optProgressStyle else noProgressReporting actionQueue <- newQueue From 58a6a579eb577ff37719ea03dc87a4419f6db2d1 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 1 May 2021 10:42:41 +0100 Subject: [PATCH 12/12] Avoid empty report messages in the NoProgress style --- 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 3c4d87d01e..2f77ef71d7 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -135,6 +135,7 @@ stop id = LSP.sendNotification LSP.SProgress progress :: (LSP.MonadLsp config f) => ProgressReportingStyle -> Seconds -> HashMap NormalizedFilePath Int -> ProgressToken -> f Seconds +progress NoProgress _ _ _ = return 0 progress style prev current id = do let done = length $ filter (== 0) $ HMap.elems current let todo = HMap.size current