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/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 new file mode 100644 index 0000000000..c87fa182ec --- /dev/null +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -0,0 +1,178 @@ +{-# 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.Strict +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 Data.Maybe (isJust) +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 () + } + +-- | State used in 'delayedProgressReporting' +data State + = NotStarted + | Stopped + | Running (Async ()) + +-- | State transitions used in 'delayedProgressReporting' +data Transition = Event ProgressEvent | StopProgress + +updateState :: IO () -> Transition -> State -> IO State +updateState _ _ Stopped = pure Stopped +updateState start (Event KickStarted) NotStarted = Running <$> async start +updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> async start +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 + +-- | 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 + ((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). +delayedProgressReporting + :: Seconds -- ^ Grace period before starting + -> Seconds -- ^ sampling delay + -> Maybe (LSP.LanguageContextEnv c) + -> ProgressReportingStyle + -> IO ProgressReporting +delayedProgressReporting before after lspEnv optProgressStyle = do + inProgressVar <- newVar $ InProgress 0 0 mempty + progressState <- newVar NotStarted + 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{..} + where + 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 + + 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 + } + } + 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 + when (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 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 = 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 +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 badb8628f9..52463e51f6 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 #-} @@ -84,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 @@ -121,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 @@ -142,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 @@ -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 :: Var (HMap.HashMap NormalizedFilePath Int) - -- ^ How many rules are running for each file - ,progressUpdate :: ProgressEvent -> IO () + ,progress :: ProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession :: [DelayedAction ()] -> IO () @@ -212,10 +210,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 @@ -382,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) } @@ -475,10 +468,9 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config) shakeOpen lspEnv defaultConfig logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo - inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) - (shakeExtras, stopProgressReporting) <- do + shakeExtras <- do globals <- newVar HMap.empty state <- newVar HMap.empty diagnostics <- newVar mempty @@ -487,23 +479,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 + 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 - pure (ShakeExtras{..}, cancel progressAsync) + pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase opts { shakeExtra = newShakeExtra shakeExtras } @@ -520,93 +512,6 @@ shakeOpen lspEnv defaultConfig logger debouncer startTelemetry otProfilingEnabled logger $ state shakeExtras return ideState - 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 $ unless testing $ 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 -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () @@ -623,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 @@ -768,18 +673,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 @@ -950,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 withProgressVar 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 @@ -999,14 +892,6 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ 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 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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index c61a93de62..7bf97280bc 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5087,18 +5087,17 @@ 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))) - 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" diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 71418fe61d..6b09450bd2 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 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"