From a7aa9f03fe5b121aa2eb9be7116544ed77a8222c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 18 Apr 2021 14:03:49 +0100 Subject: [PATCH 01/18] 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 583bb1215394061070427523e99b82e87062cbeb Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 09:28:14 +0100 Subject: [PATCH 02/18] 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 288c535592..7a47339e7f 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 8f497d9b03229158b424edb1356de51d1600222d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 12:38:10 +0100 Subject: [PATCH 03/18] 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 30aac9eb5d..bd80f598ab 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -895,7 +895,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 b8d0191fbb3f525628d0f866ecc787712be4ca44 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 24 Apr 2021 16:46:08 +0100 Subject: [PATCH 04/18] clean ups --- ghcide/src/Development/IDE/Core/OfInterest.hs | 7 ++-- .../Development/IDE/Core/ProgressReporting.hs | 15 +++++--- ghcide/src/Development/IDE/Core/Shake.hs | 35 +++++++++---------- 3 files changed, 30 insertions(+), 27 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 70b95e4351..eb35382ae7 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -47,11 +47,17 @@ noProgressReporting = return $ ProgressReporting , progressStop = pure () } +-- | 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) + :: Seconds -- ^ Grace period before starting + -> Seconds -- ^ sampling delay + -> Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting -delayedProgressReporting lspEnv optProgressStyle = do +delayedProgressReporting before after lspEnv optProgressStyle = do inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) mostRecentProgressEvent <- newTVarIO KickCompleted progressAsync <- async $ @@ -91,7 +97,7 @@ delayedProgressReporting lspEnv optProgressStyle = do 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 + liftIO $ sleep before u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate @@ -119,9 +125,8 @@ delayedProgressReporting lspEnv optProgressStyle = do { _message = Nothing } } - sample = 0.1 loop id prev = do - liftIO $ sleep sample + liftIO $ sleep after current <- liftIO $ readVar inProgress 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 bd80f598ab..52463e51f6 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) } @@ -469,11 +466,11 @@ 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) - (shakeExtras, stopProgressReporting) <- do + shakeExtras <- do globals <- newVar HMap.empty state <- newVar HMap.empty diagnostics <- newVar mempty @@ -489,16 +486,16 @@ shakeOpen lspEnv defaultConfig logger debouncer let hiedbWriter = HieDbWriter{..} exportsMap <- newVar mempty - ProgressReporting{..} <- - if inProgress - then delayedProgressReporting lspEnv optProgressStyle + progress <- do + let (before, after) = if testing then (0,0.1) else (0.1,0.1) + if reportProgress + then delayedProgressReporting before after lspEnv optProgressStyle else noProgressReporting actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - extras = ShakeExtras{..} - pure (extras, progressStop) + pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase opts { shakeExtra = newShakeExtra shakeExtras } @@ -531,7 +528,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 @@ -846,9 +843,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 432f9019dc183fc0c854c8a861cee159c089543c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 25 Apr 2021 09:24:17 +0100 Subject: [PATCH 05/18] 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 cef8d9b7772471b67d029b2e84d146c96ece73c6 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 25 Apr 2021 14:40:44 +0100 Subject: [PATCH 06/18] 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 c61a93de62..cfb02e9aec 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5087,18 +5087,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 6e87c6c9538c4169d5a5968bdd1cd258fcf89911 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 1 May 2021 10:42:41 +0100 Subject: [PATCH 07/18] Avoid empty report messages in the NoProgress style --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 8 ++------ ghcide/src/Development/IDE/Types/Options.hs | 1 + 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index eb35382ae7..2210e8e7b7 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -131,7 +131,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do let done = length $ filter (== 0) $ HMap.elems current let todo = HMap.size current let next = 100 * fromIntegral done / fromIntegral todo - when (next /= prev) $ + when (style /= NoProgress && next /= prev) $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams { _token = id @@ -146,11 +146,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do , _message = Nothing , _percentage = Just next } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } + NoProgress -> error "unreachable" } loop id next diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index f2f9bda8e3..cd07c88116 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -110,6 +110,7 @@ data ProgressReportingStyle = Percentage -- ^ Report using the LSP @_percentage@ field | Explicit -- ^ Report using explicit 123/456 text | NoProgress -- ^ Do not report any percentage + deriving Eq clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress From ca9d893afa0da13aefbe8fd01e6bdeba969dbb40 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 10:38:21 +0100 Subject: [PATCH 08/18] avoid div by zero --- .../Development/IDE/Core/ProgressReporting.hs | 41 ++++++++++--------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 2210e8e7b7..04f6da986b 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -126,29 +126,30 @@ delayedProgressReporting before after lspEnv optProgressStyle = do } } loop id prev = do - liftIO $ sleep after 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 (style /= NoProgress && 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 -> error "unreachable" - } - loop id next + if todo == 0 then loop id 0 else do + let next = 100 * fromIntegral done / fromIntegral todo + liftIO $ sleep after + when (style /= NoProgress && 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 -> error "unreachable" + } + loop id next withProgressVar var file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. From 572b16f6563e2ff2e8b307e8324046b7829dc84b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 10:40:35 +0100 Subject: [PATCH 09/18] wait for progress create response --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 04f6da986b..258a19ff8d 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -17,6 +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 qualified Data.HashMap.Strict as HMap import qualified Data.Text as T import Data.Unique @@ -100,13 +101,12 @@ delayedProgressReporting before after lspEnv optProgressStyle = do liftIO $ sleep before u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + b <- liftIO newBarrier void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) + LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b + ready <- liftIO $ waitBarrier b - bracket_ - (start u) - (stop u) - (loop u 0) + for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) where start id = LSP.sendNotification LSP.SProgress $ LSP.ProgressParams From 0b8c12d19247f71c0ac863fc2b913217dfd04aa0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 10:47:04 +0100 Subject: [PATCH 10/18] simplify the outer loop away --- .../Development/IDE/Core/ProgressReporting.hs | 141 +++++++----------- 1 file changed, 56 insertions(+), 85 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 258a19ff8d..5be1ddb001 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -11,11 +11,9 @@ module Development.IDE.Core.ProgressReporting 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_) import qualified Data.HashMap.Strict as HMap @@ -60,96 +58,69 @@ delayedProgressReporting -> IO ProgressReporting delayedProgressReporting before after 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 + progressThread <- newVar =<< async (pure ()) + let progressUpdate KickStarted = writeVar progressThread =<< async (mRunLspT lspEnv $ lspShakeProgress inProgressVar) + progressUpdate KickCompleted = readVar progressThread >>= cancel + progressStop = progressUpdate KickCompleted 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 inProgress = 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 before + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique - 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 before - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + b <- liftIO newBarrier + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b + ready <- liftIO $ waitBarrier b - b <- liftIO newBarrier - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - ready <- liftIO $ waitBarrier b - - for_ ready $ const $ 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 + for_ ready $ const $ 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 + } + } + loop id prev = do + current <- liftIO $ readVar inProgress + let done = length $ filter (== 0) $ HMap.elems current + let todo = HMap.size current + if todo == 0 then loop id 0 else do + let next = 100 * fromIntegral done / fromIntegral todo + liftIO $ sleep after + when (optProgressStyle /= NoProgress && next /= prev) $ + LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Report $ case optProgressStyle 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 -> error "unreachable" } - } - loop id prev = do - current <- liftIO $ readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current - if todo == 0 then loop id 0 else do - let next = 100 * fromIntegral done / fromIntegral todo - liftIO $ sleep after - when (style /= NoProgress && 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 -> error "unreachable" - } - loop id next + loop id next withProgressVar var file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. From 0dda71b795cd8749e2b69643ff251a42d19500ed Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 10:58:23 +0100 Subject: [PATCH 11/18] correctly implement progressStop --- .../Development/IDE/Core/ProgressReporting.hs | 26 ++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 5be1ddb001..b6385bb836 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -16,6 +16,7 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Foldable (for_) +import Data.Functor (($>)) import qualified Data.HashMap.Strict as HMap import qualified Data.Text as T import Data.Unique @@ -46,6 +47,24 @@ noProgressReporting = return $ ProgressReporting , progressStop = pure () } +data State + = NotStarted + | Completed + | Stopped + | Running (Async ()) + +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) Completed = Running <$> async start +updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> async start +updateState _ (Event KickCompleted) (Running a) = cancel a $> Completed +updateState _ (Event KickCompleted) st = pure st +updateState _ StopProgress (Running a) = cancel a $> Stopped +updateState _ StopProgress st = pure st + -- | 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). @@ -58,10 +77,9 @@ delayedProgressReporting -> IO ProgressReporting delayedProgressReporting before after lspEnv optProgressStyle = do inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) - progressThread <- newVar =<< async (pure ()) - let progressUpdate KickStarted = writeVar progressThread =<< async (mRunLspT lspEnv $ lspShakeProgress inProgressVar) - progressUpdate KickCompleted = readVar progressThread >>= cancel - progressStop = progressUpdate KickCompleted + progressState <- newVar NotStarted + let progressUpdate event = modifyVar_ progressState $ updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) (Event event) + progressStop = modifyVar_ progressState $ updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) StopProgress inProgress :: NormalizedFilePath -> Action a -> Action a inProgress = withProgressVar inProgressVar return ProgressReporting{..} From 6f83ff09b215585c999014c7014a7b74d5019125 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 11:22:29 +0100 Subject: [PATCH 12/18] Improve asymptotics --- .../Development/IDE/Core/ProgressReporting.hs | 20 +++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index b6385bb836..ceeea9f834 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -18,6 +18,7 @@ import Control.Monad.Trans.Class (lift) import Data.Foldable (for_) import Data.Functor (($>)) import qualified Data.HashMap.Strict as HMap +import Data.Maybe (isJust) import qualified Data.Text as T import Data.Unique import Development.IDE.GHC.Orphans () @@ -46,7 +47,6 @@ noProgressReporting = return $ ProgressReporting , inProgress = const id , progressStop = pure () } - data State = NotStarted | Completed @@ -65,6 +65,8 @@ updateState _ (Event KickCompleted) st = pure st updateState _ StopProgress (Running a) = cancel a $> Stopped updateState _ StopProgress st = pure st +data InProgress = InProgress {todo, done :: !Int, current :: !(HMap.HashMap NormalizedFilePath Int)} + -- | 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). @@ -76,7 +78,7 @@ delayedProgressReporting -> ProgressReportingStyle -> IO ProgressReporting delayedProgressReporting before after lspEnv optProgressStyle = do - inProgressVar <- newVar (HMap.empty @NormalizedFilePath @Int) + inProgressVar <- newVar $ InProgress 0 0 mempty progressState <- newVar NotStarted let progressUpdate event = modifyVar_ progressState $ updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) (Event event) progressStop = modifyVar_ progressState $ updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) StopProgress @@ -115,9 +117,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do } } loop id prev = do - current <- liftIO $ readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current + InProgress{..} <- liftIO $ readVar inProgress if todo == 0 then loop id 0 else do let next = 100 * fromIntegral done / fromIntegral todo liftIO $ sleep after @@ -144,7 +144,15 @@ delayedProgressReporting before after lspEnv optProgressStyle = do -- 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) + where + f shift = void $ modifyVar' var $ \InProgress{..} -> + case HMap.alterF alter file current of + ((prev, new), m') -> + let todo' = if isJust prev then todo else todo + 1 + done' = if new == 0 then done+1 else done + in InProgress todo' done' m' + where + alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f From 7f0c06dcf877ab9ee31130306f5f61c9a26d5a52 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 11:45:35 +0100 Subject: [PATCH 13/18] Increase the parallelism used in hlint tests --- test/utils/Test/Hls/Command.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/utils/Test/Hls/Command.hs b/test/utils/Test/Hls/Command.hs index 656aca1beb..799174b32b 100644 --- a/test/utils/Test/Hls/Command.hs +++ b/test/utils/Test/Hls/Command.hs @@ -23,7 +23,7 @@ hlsCommand :: String {-# NOINLINE hlsCommand #-} hlsCommand = unsafePerformIO $ do testExe <- fromMaybe "haskell-language-server" <$> lookupEnv "HLS_TEST_EXE" - pure $ testExe ++ " --lsp -d -j2 -l test-logs/" ++ logFilePath + pure $ testExe ++ " --lsp -d -j4 -l test-logs/" ++ logFilePath hlsCommandVomit :: String hlsCommandVomit = hlsCommand ++ " --vomit" From 32de9de931d22abb0d28cc497f0bc48a9e4e4981 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 11:53:52 +0100 Subject: [PATCH 14/18] extract recordProgress --- .../Development/IDE/Core/ProgressReporting.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index ceeea9f834..15c5965378 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -67,6 +67,15 @@ updateState _ StopProgress st = pure st data InProgress = InProgress {todo, done :: !Int, current :: !(HMap.HashMap NormalizedFilePath Int)} +recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress +recordProgress file shift InProgress{..} = case HMap.alterF alter file current of + ((prev, new), m') -> + let todo' = if isJust prev then todo else todo + 1 + done' = if new == 0 then done+1 else done + in InProgress todo' done' m' + where + alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') + -- | 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). @@ -145,14 +154,7 @@ delayedProgressReporting before after lspEnv optProgressStyle = do -- Do not remove the eta-expansion without profiling a session with at -- least 1000 modifications. where - f shift = void $ modifyVar' var $ \InProgress{..} -> - case HMap.alterF alter file current of - ((prev, new), m') -> - let todo' = if isJust prev then todo else todo + 1 - done' = if new == 0 then done+1 else done - in InProgress todo' done' m' - where - alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') + f shift = modifyVar' var $ recordProgress file shift mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f From 9c856412b6c124beede5ae7c6eb773c0049b9af4 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 11:56:34 +0100 Subject: [PATCH 15/18] comments --- ghcide/src/Development/IDE/Core/ProgressReporting.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 15c5965378..b50696e0ff 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -47,12 +47,15 @@ noProgressReporting = return $ ProgressReporting , inProgress = const id , progressStop = pure () } + +-- | State used in 'delayedProgressReporting' data State = NotStarted | Completed | Stopped | Running (Async ()) +-- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress updateState :: IO () -> Transition -> State -> IO State @@ -65,7 +68,12 @@ updateState _ (Event KickCompleted) st = pure st updateState _ StopProgress (Running a) = cancel a $> Stopped updateState _ StopProgress st = pure st -data InProgress = InProgress {todo, done :: !Int, current :: !(HMap.HashMap NormalizedFilePath Int)} +-- | Data structure to track progress across the project +data InProgress = InProgress + { todo :: !Int -- ^ Number of files to do + , done :: !Int -- ^ Number of files done + , current :: !(HMap.HashMap NormalizedFilePath Int) + } recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress recordProgress file shift InProgress{..} = case HMap.alterF alter file current of @@ -79,7 +87,6 @@ recordProgress file shift InProgress{..} = case HMap.alterF alter file current o -- | 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 -- ^ Grace period before starting -> Seconds -- ^ sampling delay From d5ebab37a077a3825d0a4acda0494638740223c0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 2 May 2021 12:42:35 +0100 Subject: [PATCH 16/18] fix test --- ghcide/test/exe/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index cfb02e9aec..7bf97280bc 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5087,6 +5087,7 @@ clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do void $ skipManyTill anyMessage $ message SClientRegisterCapability + void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) skipManyTill anyMessage restartingBuildSession From ac0c0b9e1bd24c4212c3381b2b7ee620826a11de Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 3 May 2021 09:00:03 +0100 Subject: [PATCH 17/18] remove unnecessary tilde --- hls-test-utils/src/Test/Hls.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index f14fd084d5..6b09450bd2 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -144,7 +144,7 @@ waitForProgressDone :: Session () waitForProgressDone = loop where loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + () <- skipManyTill anyMessage $ satisfyMaybe $ \case FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions From 3850495a3ca4a5c13e7f2247906b4217bce8849c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 3 May 2021 09:00:16 +0100 Subject: [PATCH 18/18] apply review feedbacks --- .../Development/IDE/Core/ProgressReporting.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index b50696e0ff..c87fa182ec 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -51,7 +51,6 @@ noProgressReporting = return $ ProgressReporting -- | State used in 'delayedProgressReporting' data State = NotStarted - | Completed | Stopped | Running (Async ()) @@ -61,9 +60,8 @@ 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) Completed = Running <$> async start updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> async start -updateState _ (Event KickCompleted) (Running a) = cancel a $> Completed +updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted updateState _ (Event KickCompleted) st = pure st updateState _ StopProgress (Running a) = cancel a $> Stopped updateState _ StopProgress st = pure st @@ -96,8 +94,10 @@ delayedProgressReporting delayedProgressReporting before after lspEnv optProgressStyle = do inProgressVar <- newVar $ InProgress 0 0 mempty progressState <- newVar NotStarted - let progressUpdate event = modifyVar_ progressState $ updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) (Event event) - progressStop = modifyVar_ progressState $ updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) StopProgress + let progressUpdate event = updateStateVar $ Event event + progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) + inProgress :: NormalizedFilePath -> Action a -> Action a inProgress = withProgressVar inProgressVar return ProgressReporting{..} @@ -132,12 +132,14 @@ delayedProgressReporting before after lspEnv optProgressStyle = do { _message = Nothing } } + loop _ _ | optProgressStyle == NoProgress = + forever $ liftIO $ threadDelay maxBound loop id prev = do InProgress{..} <- liftIO $ readVar inProgress + liftIO $ sleep after if todo == 0 then loop id 0 else do let next = 100 * fromIntegral done / fromIntegral todo - liftIO $ sleep after - when (optProgressStyle /= NoProgress && next /= prev) $ + when (next /= prev) $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams { _token = id