diff --git a/.github/workflows/flakiness.yml b/.github/workflows/flakiness.yml new file mode 100644 index 0000000000..4341946542 --- /dev/null +++ b/.github/workflows/flakiness.yml @@ -0,0 +1,109 @@ +name: flakiness + +defaults: + run: + shell: bash + +concurrency: + group: ${{ github.head_ref }}-${{ github.workflow }} + cancel-in-progress: true + +on: + # Run on PRs that touch relevant areas and on manual dispatch + pull_request: + branches: + - '**' + paths: + - 'scripts/flaky-test-loop.sh' + - 'scripts/flaky-test-patterns.txt' + - 'ghcide/**' + - 'ghcide-test/**' + - 'hls-test-utils/**' + - 'src/**' + - 'exe/**' + - 'plugins/**' + - 'cabal.project' + - 'stack.yaml' + - 'haskell-language-server.cabal' + - '.github/workflows/flakiness.yml' + workflow_dispatch: + inputs: + max_iter: + description: 'Maximum iterations to attempt' + required: false + default: '1000' + sleep_secs: + description: 'Seconds to sleep between iterations' + required: false + default: '0' + test_patterns: + description: 'Comma-separated Tasty patterns to run each iteration (overrides default)' + required: false + default: '' + +jobs: + loop: + name: Flakiness Test (broken pipe and test failures) + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + - macos-latest + # - windows-latest + + steps: + - uses: actions/checkout@v4 + + - name: Setup GHC and caching + uses: ./.github/actions/setup-build + with: + ghc: '9.12' + os: ${{ runner.os }} + + - name: Show cabal and GHC versions + run: | + cabal --version + ghc --version + - name: Build + env: + PATTERN_FILE: 'scripts/flaky-test-patterns.txt' + RUN_MODE: 'build' + run: HLS_TEST_EXE="$(cabal exec which hls)" bash scripts/flaky-test-loop.sh + + - name: Run flakiness loop + id: run-loop + # Let this run for a while; build is done once inside the script + timeout-minutes: 60 + env: + # Use workflow_dispatch inputs when present, else defaults + SLEEP_SECS: ${{ github.event.inputs.sleep_secs || '0' }} + LOG_STDERR: '1' + TEST_PATTERNS: ${{ github.event.inputs.test_patterns }} + PATTERN_FILE: 'scripts/flaky-test-patterns.txt' + NO_BUILD_ONCE: '1' + RUN_MODE: 'run' + # HLS_TEST_EXE: 'hls' # HLS_WRAPPER_TEST_EXE: 'hls-wrapper' + run: | + # Run with a sensible default of 500 iterations on PRs; + max_iter="${{ github.event.inputs.max_iter }}" + max_iter="${max_iter:-500}" + # copy hls to current dir so the script can find it + HLS_TEST_EXE="$(cabal exec which hls)" bash scripts/flaky-test-loop.sh "${max_iter}" + ec=$? + # Interpret exit codes from flaky-test-loop.sh + # 0 => no issues reproduced within MAX_ITER -> pass job + # 1 => issue reproduced (broken pipe or test failure) -> fail job + # 2+ => setup/infra error -> fail job + if [[ $ec -eq 1 ]]; then + echo "Issue reproduced (broken pipe or test failure): failing job" + exit 1 + elif [[ $ec -eq 0 ]]; then + echo "No issues reproduced within MAX_ITER=${max_iter}: passing" + exit 0 + else + echo "Loop script error (exit $ec): failing" + exit $ec + fi + diff --git a/cabal.project b/cabal.project index 8d8bd080af..d83e432492 100644 --- a/cabal.project +++ b/cabal.project @@ -56,3 +56,9 @@ if impl(ghc >= 9.11) allow-newer: cabal-install-parsers:base, cabal-install-parsers:time, + +source-repository-package + type: git + location: https://github.com/soulomoon/lsp.git + tag: 640c7c755bf16128e3cb19c257688aa3305ff9f5 + subdir: lsp lsp-types lsp-test diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dde1cfdea5..84ad33bbd0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -104,8 +104,7 @@ import qualified Data.HashSet as Set import qualified Data.Set as OS import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Core.WorkerThread (awaitRunInThread, - withWorkerQueue) +import Development.IDE.Core.WorkerThread import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.Session.Diagnostics (renderCradleError) import Development.IDE.Types.Shake (WithHieDb, @@ -149,10 +148,12 @@ data Log | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) | LogHieBios HieBios.Log | LogSessionLoadingChanged + | LogSessionWorkerThread LogWorkerThread deriving instance Show Log instance Pretty Log where pretty = \case + LogSessionWorkerThread msg -> pretty msg LogNoneCradleFound path -> "None cradle found for" <+> pretty path <+> ", ignoring the file" LogSettingInitialDynFlags -> @@ -381,8 +382,8 @@ runWithDb recorder fp = ContT $ \k -> do _ <- withWriteDbRetryable deleteMissingRealFiles _ <- withWriteDbRetryable garbageCollectTypeNames - runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan -> - withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) + runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable)) + $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) where writer withHieDbRetryable l = do -- TODO: probably should let exceptions be caught/logged/handled by top level handler @@ -415,7 +416,7 @@ getHieDbLoc dir = do -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef [] diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 48439e2ff3..5a3039c5fe 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -75,6 +75,7 @@ import Development.IDE.Core.Preprocessor import Development.IDE.Core.ProgressReporting (progressUpdate) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.Core.WorkerThread (writeTaskQueue) import Development.IDE.Core.Tracing (withTrace) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as GHC @@ -882,7 +883,7 @@ indexHieFile se mod_summary srcPath !hash hf = do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} modifyTVar' indexPending $ HashMap.insert srcPath hash - writeTQueue indexQueue $ \withHieDb -> do + writeTaskQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index e545ec7b14..37177a22d1 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -45,6 +45,7 @@ import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -252,8 +253,8 @@ getVersionedTextDoc doc = do maybe (pure Nothing) getVirtualFile $ uriToNormalizedFilePath $ toNormalizedUri uri let ver = case mvf of - Just (VirtualFile lspver _ _) -> lspver - Nothing -> 0 + Just (VirtualFile lspver _ _ _) -> lspver + Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () @@ -304,7 +305,7 @@ typecheckParentsAction recorder nfp = do setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 964d6d379b..b78ad21641 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -516,8 +516,8 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybe vfsRef <- asks vfsVar vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of - Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + Just (Open vf) -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + _ -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6fc9a4d00e..7356d673d7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -25,7 +25,7 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, - IdeRule, IdeResult, + IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue, @@ -254,12 +254,15 @@ data HieDbWriter -- | Actions to queue up on the index worker thread -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality -type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type RestartQueue = TaskQueue (IO ()) +type LoaderQueue = TaskQueue (IO ()) + data ThreadQueue = ThreadQueue { tIndexQueue :: IndexQueue - , tRestartQueue :: TQueue (IO ()) - , tLoaderQueue :: TQueue (IO ()) + , tRestartQueue :: RestartQueue + , tLoaderQueue :: LoaderQueue } -- Note [Semantic Tokens Cache Location] @@ -330,9 +333,9 @@ data ShakeExtras = ShakeExtras -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run - , restartQueue :: TQueue (IO ()) + , restartQueue :: RestartQueue -- ^ Queue of restart actions to be run. - , loaderQueue :: TQueue (IO ()) + , loaderQueue :: LoaderQueue -- ^ Queue of loader actions to be run. } @@ -390,11 +393,16 @@ addPersistentRule k getVal = do class Typeable a => IsIdeGlobal a where +-- data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile +getOpenFile :: VirtualFileEntry -> Maybe VirtualFile +getOpenFile (Open vf) = Just vf +getOpenFile _ = Nothing -- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras - pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map + let file = getOpenFile =<< Map.lookup (filePathToUri' nf) vfs + pure $! file -- Don't leak a reference to the entire map -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS diff --git a/ghcide/src/Development/IDE/Core/WorkerThread.hs b/ghcide/src/Development/IDE/Core/WorkerThread.hs index 6d141c7ef3..1c55d21c99 100644 --- a/ghcide/src/Development/IDE/Core/WorkerThread.hs +++ b/ghcide/src/Development/IDE/Core/WorkerThread.hs @@ -7,18 +7,38 @@ Description : This module provides an API for managing worker threads in the IDE see Note [Serializing runs in separate thread] -} module Development.IDE.Core.WorkerThread - (withWorkerQueue, awaitRunInThread) - where + ( LogWorkerThread (..), + withWorkerQueue, + awaitRunInThread, + TaskQueue, + writeTaskQueue, + withWorkerQueueSimple + ) +where -import Control.Concurrent.Async (AsyncCancelled (AsyncCancelled), - withAsync) +import Control.Concurrent.Async (withAsync) import Control.Concurrent.STM import Control.Concurrent.Strict (newBarrier, signalBarrier, waitBarrier) -import Control.Exception.Safe (Exception (fromException), - SomeException, throwIO, try) -import Control.Monad (forever) +import Control.Exception.Safe (SomeException, finally, throwIO, + try) import Control.Monad.Cont (ContT (ContT)) +import qualified Data.Text as T +import Ide.Logger + +data LogWorkerThread + = LogThreadEnding !T.Text + | LogThreadEnded !T.Text + | LogSingleWorkStarting !T.Text + | LogSingleWorkEnded !T.Text + deriving (Show) + +instance Pretty LogWorkerThread where + pretty = \case + LogThreadEnding t -> "Worker thread ending:" <+> pretty t + LogThreadEnded t -> "Worker thread ended:" <+> pretty t + LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t + LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t {- Note [Serializing runs in separate thread] @@ -30,30 +50,71 @@ Like the db writes, session loading in session loader, shake session restarts. Originally we used various ways to implement this, but it was hard to maintain and error prone. Moreover, we can not stop these threads uniformly when we are shutting down the server. -} +data TaskQueue a = TaskQueue (TQueue a) +newTaskQueueIO :: IO (TaskQueue a) +newTaskQueueIO = TaskQueue <$> newTQueueIO +data ExitOrTask t = Exit | Task t -- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker -- thread which polls the queue for requests and runs the given worker -- function on them. -withWorkerQueue :: (t -> IO a) -> ContT () IO (TQueue t) -withWorkerQueue workerAction = ContT $ \mainAction -> do - q <- newTQueueIO - withAsync (writerThread q) $ \_ -> mainAction q - where - writerThread q = - forever $ do - l <- atomically $ readTQueue q - workerAction l +withWorkerQueueSimple :: Recorder (WithPriority LogWorkerThread) -> T.Text -> ContT () IO (TaskQueue (IO ())) +withWorkerQueueSimple log title = withWorkerQueue log title id +withWorkerQueue :: Recorder (WithPriority LogWorkerThread) -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) +withWorkerQueue log title workerAction = ContT $ \mainAction -> do + q <- newTaskQueueIO + -- Use a TMVar as a stop flag to coordinate graceful shutdown. + -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately, + -- ensuring that no new work is started after shutdown is requested. + -- This mechanism is necessary because some downstream code may swallow async exceptions, + -- making 'cancel' unreliable for stopping the thread in all cases. + -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job), + -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant. + b <- newEmptyTMVarIO + withAsync (writerThread q b) $ \_ -> do + mainAction q + -- if we want to debug the exact location the worker swallows an async exception, we can + -- temporarily comment out the `finally` clause. + `finally` atomically (putTMVar b ()) + logWith log Debug (LogThreadEnding title) + logWith log Debug (LogThreadEnded title) + where + -- writerThread :: TaskQueue t -> TMVar () -> (forall a. IO a -> IO a) -> IO () + writerThread q b = + -- See above: check stop flag before dequeuing, exit if set, otherwise run next job. + do + task <- atomically $ do + task <- tryReadTaskQueue q + isEm <- isEmptyTMVar b + case (isEm, task) of + (False, _) -> return Exit -- stop flag set, exit + (_, Just t) -> return $ Task t -- got a task, run it + (_, Nothing) -> retry -- no task, wait + case task of + Exit -> return () + Task t -> do + logWith log Debug $ LogSingleWorkStarting title + workerAction t + logWith log Debug $ LogSingleWorkEnded title + writerThread q b + -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, -- and then blocks until the result is computed. If the action throws an -- non-async exception, it is rethrown in the calling thread. -awaitRunInThread :: TQueue (IO ()) -> IO result -> IO result -awaitRunInThread q act = do - -- Take an action from TQueue, run it and - -- use barrier to wait for the result - barrier <- newBarrier - atomically $ writeTQueue q $ try act >>= signalBarrier barrier - resultOrException <- waitBarrier barrier - case resultOrException of - Left e -> throwIO (e :: SomeException) - Right r -> return r +awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result +awaitRunInThread (TaskQueue q) act = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + barrier <- newBarrier + atomically $ writeTQueue q (try act >>= signalBarrier barrier) + resultOrException <- waitBarrier barrier + case resultOrException of + Left e -> throwIO (e :: SomeException) + Right r -> return r + +writeTaskQueue :: TaskQueue a -> a -> STM () +writeTaskQueue (TaskQueue q) = writeTQueue q + +tryReadTaskQueue :: TaskQueue a -> STM (Maybe a) +tryReadTaskQueue (TaskQueue q) = tryReadTQueue q diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 918e024a4f..86af5641ad 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -12,6 +12,8 @@ module Development.IDE.LSP.LanguageServer , ThreadQueue , runWithWorkerThreads , Setup (..) + , InitializationContext (..) + , untilMVar' ) where import Control.Concurrent.STM @@ -35,12 +37,16 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Concurrent.Extra (newBarrier, + signalBarrier, + waitBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Service (shutdown) import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing -import Development.IDE.Core.WorkerThread (withWorkerQueue) +import Development.IDE.Core.WorkerThread import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb, WithHieDbShield (..)) @@ -48,6 +54,7 @@ import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) +import System.Timeout (timeout) data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -56,11 +63,26 @@ data Log | LogCancelledRequest !SomeLspId | LogSession Session.Log | LogLspServer LspServerLog - | LogServerShutdownMessage + | LogReactorShutdownRequested Bool + | LogShutDownTimeout Int + | LogServerExitWith (Either () Int) + | LogReactorShutdownConfirmed !T.Text deriving Show instance Pretty Log where pretty = \case + LogReactorShutdownRequested b -> + "Requested reactor shutdown; stop signal posted: " <+> pretty b + LogReactorShutdownConfirmed msg -> + "Reactor shutdown confirmed: " <+> pretty msg + LogServerExitWith (Right 0) -> + "Server exited successfully" + LogServerExitWith (Right code) -> + "Server exited with failure code" <+> pretty code + LogServerExitWith (Left _) -> + "Server forcefully exited due to exception in reactor thread" + LogShutDownTimeout seconds -> + "Shutdown timeout, the server will exit now after waiting for" <+> pretty seconds <+> "seconds" LogRegisteringIdeConfig ideConfig -> -- This log is also used to identify if HLS starts successfully in vscode-haskell, -- don't forget to update the corresponding test in vscode-haskell if the text in @@ -80,7 +102,32 @@ instance Pretty Log where "Cancelled request" <+> viaShow requestId LogSession msg -> pretty msg LogLspServer msg -> pretty msg - LogServerShutdownMessage -> "Received shutdown message" + +-- | Context for initializing the LSP language server. +-- This record encapsulates all the configuration and callback functions +-- needed to set up and run the language server initialization process. +data InitializationContext config = InitializationContext + { ctxRecorder :: Recorder (WithPriority Log) + -- ^ Logger for recording server events and diagnostics + , ctxDefaultRoot :: FilePath + -- ^ Default root directory for the workspace, see Note [Root Directory] + , ctxGetHieDbLoc :: FilePath -> IO FilePath + -- ^ Function to determine the HIE database location for a given root path + , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState + -- ^ Function to create and initialize the IDE state with the given environment + , ctxUntilReactorStopSignal :: IO () -> IO () + -- ^ Lifetime control: MVar to signal reactor shutdown + , ctxconfirmReactorShutdown :: T.Text -> IO () + -- ^ Callback to log/confirm reactor shutdown with a reason + , ctxForceShutdown :: IO () + -- ^ Action to forcefully exit the server when exception occurs + , ctxClearReqId :: SomeLspId -> IO () + -- ^ Function to clear/cancel a request by its ID + , ctxWaitForCancel :: SomeLspId -> IO () + -- ^ Function to wait for a request cancellation by its ID + , ctxClientMsgChan :: Chan ReactorMessage + -- ^ Channel for communicating with the reactor message loop + } data Setup config m a = MkSetup @@ -136,8 +183,8 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh outH serverDefinition - untilMVar clientMsgVar $ - runServer `finally` sequence_ onExit + untilMVar' clientMsgVar runServer `finally` sequence_ onExit + >>= logWith recorder Info . LogServerExitWith setupLSP :: forall config. @@ -155,8 +202,21 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar -- An MVar to control the lifetime of the reactor loop. -- The loop will be stopped and resources freed when it's full - reactorLifetime <- newEmptyMVar - let stopReactorLoop = void $ tryPutMVar reactorLifetime () + reactorStopSignal <- newEmptyMVar + reactorConfirmBarrier <- newBarrier + let + untilReactorStopSignal = untilMVar reactorStopSignal + confirmReactorShutdown reason = do + logWith recorder Debug $ LogReactorShutdownConfirmed reason + signalBarrier reactorConfirmBarrier () + requestReactorShutdown = do + k <- tryPutMVar reactorStopSignal () + logWith recorder Info $ LogReactorShutdownRequested k + let timeOutSeconds = 2 + timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case + Just () -> pure () + -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway. + Nothing -> logWith recorder Warning $ LogShutDownTimeout timeOutSeconds -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () @@ -185,49 +245,63 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler exit - , shutdownHandler recorder stopReactorLoop + , shutdownHandler recorder requestReactorShutdown ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let initParams = InitializationContext + { ctxRecorder = recorder + , ctxDefaultRoot = defaultRoot + , ctxGetHieDbLoc = getHieDbLoc + , ctxGetIdeState = getIdeState + , ctxUntilReactorStopSignal = untilReactorStopSignal + , ctxconfirmReactorShutdown = confirmReactorShutdown + , ctxForceShutdown = exit + , ctxClearReqId = clearReqId + , ctxWaitForCancel = waitForCancel + , ctxClientMsgChan = clientMsgChan + } + + let doInitialize = handleInit initParams let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - - let onExit = [stopReactorLoop, exit] + let onExit = [void $ tryPutMVar reactorStopSignal ()] pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} handleInit - :: Recorder (WithPriority Log) - -> FilePath -- ^ root directory, see Note [Root Directory] - -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) - -> MVar () - -> IO () - -> (SomeLspId -> IO ()) - -> (SomeLspId -> IO ()) - -> Chan ReactorMessage + :: InitializationContext config -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit initParams env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - -- only shift if lsp root is different from the rootDir - -- see Note [Root Directory] + -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] + let + recorder = ctxRecorder initParams + defaultRoot = ctxDefaultRoot initParams + untilReactorStopSignal = ctxUntilReactorStopSignal initParams + lifetimeConfirm = ctxconfirmReactorShutdown initParams root <- case LSP.resRootPath env of - Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot - _ -> pure defaultRoot - dbLoc <- getHieDbLoc root + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot + dbLoc <- ctxGetHieDbLoc initParams root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig - dbMVar <- newEmptyMVar - - - let handleServerException (Left e) = do - logWith recorder Error $ LogReactorThreadException e - exitClientMsg - handleServerException (Right _) = pure () + ideMVar <- newEmptyMVar + + let handleServerExceptionOrShutDown me = do + -- shutdown shake + tryReadMVar ideMVar >>= mapM_ shutdown + case me of + Left e -> do + lifetimeConfirm "due to exception in reactor thread" + logWith recorder Error $ LogReactorThreadException e + ctxForceShutdown initParams + _ -> do + lifetimeConfirm "due to shutdown message" + return () exceptionInHandler e = do logWith recorder Error $ LogReactorMessageActionException e @@ -235,13 +309,13 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO () checkCancelled _id act k = let sid = SomeLspId _id - in flip finally (clearReqId sid) $ + in flip finally (ctxClearReqId initParams sid) $ catch (do -- We could optimize this by first checking if the id -- is in the cancelled set. However, this is unlikely to be a -- bottleneck and the additional check might hide -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel sid) act + cancelOrRes <- race (ctxWaitForCancel initParams sid) act case cancelOrRes of Left () -> do logWith recorder Debug $ LogCancelledRequest sid @@ -250,20 +324,23 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c ) $ \(e :: SomeException) -> do exceptionInHandler e k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> do - putMVar dbMVar (WithHieDbShield withHieDb',threadQueue') - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - logWith recorder Info LogReactorThreadStopped - - (WithHieDbShield withHieDb, threadQueue) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb threadQueue + _ <- flip forkFinally handleServerExceptionOrShutDown $ do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' threadQueue' -> + do + ide <- ctxGetIdeState initParams env root withHieDb' threadQueue' + putMVar ideMVar ide + -- We might be blocked indefinitly at initialization if reactorStop is signaled + -- before we putMVar. + untilReactorStopSignal $ forever $ do + msg <- readChan $ ctxClientMsgChan initParams + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> handle exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + logWith recorder Info LogReactorThreadStopped + + ide <- readMVar ideMVar registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) @@ -273,9 +350,9 @@ handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg c -- see Note [Serializing runs in separate thread] runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () runWithWorkerThreads recorder dbLoc f = evalContT $ do - sessionRestartTQueue <- withWorkerQueue id - sessionLoaderTQueue <- withWorkerQueue id (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue" + sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue" liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. @@ -286,6 +363,9 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () untilMVar mvar io = race_ (readMVar mvar) io +untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b) +untilMVar' mvar io = race (readMVar mvar) io + cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> liftIO $ cancelRequest (SomeLspId (toLspId _id)) @@ -294,18 +374,11 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T toLspId (InR y) = IdString y shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) -shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do - (_, ide) <- ask - liftIO $ logWith recorder Debug LogServerShutdownMessage - -- stop the reactor to free up the hiedb connection - liftIO stopReactor - -- flush out the Shake session to record a Shake profile if applicable - liftIO $ shakeShut ide +shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do + -- stop the reactor to free up the hiedb connection and shut down shake + liftIO requestReactorShutdown resp $ Right Null -exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit - modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 0a5cecaca8..6c59a5ffe5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -857,7 +857,7 @@ mergeListsBy cmp all_lists = merge_lists all_lists -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo -getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext +getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo getCompletionPrefixFromRope pos@(Position l c) ropetext = diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 0ab203fe36..9ec15c0f96 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -29,6 +29,7 @@ module Test.Hls goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir, goldenWithTestConfig, + hlsHelperTestRecorder, def, -- * Running HLS for integration tests runSessionWithServer, @@ -153,6 +154,17 @@ data Log = LogIDEMain IDEMain.Log | LogTestHarness LogTestHarness +data TestRunLog + = TestRunFinished + | TestServerExitTimeoutSeconds Int + | TestServerCancelFinished String + +instance Pretty TestRunLog where + pretty :: TestRunLog -> Logger.Doc ann + pretty TestRunFinished = "Test run finished" + pretty (TestServerExitTimeoutSeconds secs) = "Server does not exit in " <> pretty secs <> "s, canceling the async task..." + pretty (TestServerCancelFinished took) = "Finishing canceling (took " <> pretty took <> "s)" + instance Pretty Log where pretty = \case LogIDEMain log -> pretty log @@ -760,6 +772,7 @@ runSessionWithTestConfig TestConfig{..} session = (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder + testRecorder <- hlsHelperTestRecorder -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") @@ -780,9 +793,10 @@ runSessionWithTestConfig TestConfig{..} session = timeout 3 (wait server) >>= \case Just () -> pure () Nothing -> do - putStrLn "Server does not exit in 3s, canceling the async task..." + logWith testRecorder Info (TestServerExitTimeoutSeconds 3) (t, _) <- duration $ cancel server - putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" + logWith testRecorder Info (TestServerCancelFinished (showDuration t)) + logWith testRecorder Info TestRunFinished pure result where diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index a0d1648fb3..7daae0df51 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -90,7 +90,7 @@ docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Sessio docLspSemanticTokensString doc = do res <- Test.getSemanticTokens doc textContent <- documentContents doc - let vfs = VirtualFile 0 0 (Rope.fromText textContent) + let vfs = VirtualFile 0 0 (Rope.fromText textContent) (Just LanguageKind_Haskell) case res ^? Language.LSP.Protocol.Types._L of Just tokens -> do either (error . show) pure $ recoverLspSemanticTokens vfs tokens diff --git a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs index ada4d70872..e8ac3cac0d 100644 --- a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs +++ b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs @@ -94,7 +94,7 @@ help when a space char is inserted, we probably have to use up-to-date results. {- Here is a brief description of the algorithm of finding relevant bits from HIE AST -1. let 'hsAppNode' = the smallest 'HsApp' AST node which contains the cursor postion +1. let 'hsAppNode' = the smallest 'HsApp' AST node which contains the cursor position See 'extractInfoFromSmallestContainingFunctionApplicationAst' 2. let 'functionNode' = the left-most node of 'hsAppNode' See 'getLeftMostNode' diff --git a/plugins/hls-signature-help-plugin/test/Main.hs b/plugins/hls-signature-help-plugin/test/Main.hs index 4ac665e7d1..f6518552ae 100644 --- a/plugins/hls-signature-help-plugin/test/Main.hs +++ b/plugins/hls-signature-help-plugin/test/Main.hs @@ -11,7 +11,8 @@ import qualified Data.Text as T import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (PosPrefixInfo)) import Ide.Plugin.SignatureHelp (descriptor) import qualified Language.LSP.Protocol.Lens as L -import Test.Hls +import Test.Hls hiding + (getSignatureHelp) import Test.Hls.FileSystem (VirtualFileTree, directCradle, file, mkVirtualFileTree, diff --git a/scripts/eventlog_dump.py b/scripts/eventlog_dump.py new file mode 100644 index 0000000000..9fb6602269 --- /dev/null +++ b/scripts/eventlog_dump.py @@ -0,0 +1,127 @@ +#!/usr/bin/env python3 +""" +Dump a GHC RTS .eventlog to a plain-text file using the ghc-events CLI. +Usage: + scripts/eventlog_dump.py [--out output.txt] [--contains SUBSTR1|SUBSTR2] + +Behavior mirrors scripts/eventlog-dump.fish: tries to find ghc-events in PATH, +~/.cabal/bin, or ~/.local/bin. If not found and `cabal` exists in PATH, it will run +`cabal install ghc-events` and retry. + +Filtering: if --contains is provided it should be a pipe-separated list of +substrings; a line is kept if it contains any of the substrings. + +Exit codes: + 0 : success + >0 : failures from ghc-events or setup errors +""" +from __future__ import annotations + +import argparse +import os +import shutil +import subprocess +import sys +from typing import Iterable, List, Optional + + +def find_ghc_events() -> Optional[str]: + # 1) PATH + path = shutil.which("ghc-events") + if path: + return path + # 2) common user bins + cand = os.path.expanduser("~/.cabal/bin/ghc-events") + if os.path.isfile(cand) and os.access(cand, os.X_OK): + return cand + cand = os.path.expanduser("~/.local/bin/ghc-events") + if os.path.isfile(cand) and os.access(cand, os.X_OK): + return cand + return None + + +def try_install_ghc_events() -> bool: + if shutil.which("cabal") is None: + return False + print("ghc-events not found; attempting to install via 'cabal install ghc-events'...", file=sys.stderr) + rc = subprocess.run(["cabal", "install", "ghc-events"]) # let cabal print its own output + return rc.returncode == 0 + + +def stream_and_filter(cmd: List[str], out_path: str, contains: Optional[Iterable[str]]) -> int: + proc = subprocess.Popen(cmd, stdout=subprocess.PIPE, stderr=subprocess.PIPE, text=True) + assert proc.stdout is not None + with open(out_path, "w", encoding="utf-8", newline="\n") as fout: + for line in proc.stdout: + if contains: + if any(sub in line for sub in contains): + fout.write(line) + else: + fout.write(line) + # wait for process to finish and capture stderr + _, err = proc.communicate() + if proc.returncode != 0: + # write stderr for debugging + sys.stderr.write(err) + return proc.returncode + + +def parse_args(argv: Optional[List[str]] = None) -> argparse.Namespace: + ap = argparse.ArgumentParser(description="Dump GHC eventlog to text with optional substring filtering") + ap.add_argument("eventlog", help=".eventlog file to dump") + ap.add_argument("--out", "-o", default=None, help="Output text file (default: .events.txt)") + ap.add_argument("--contains", "-c", default=None, + help="Pipe-separated substrings to keep (e.g. 'foo|bar'). If omitted, keep all lines.") + return ap.parse_args(argv) + + +def main(argv: Optional[List[str]] = None) -> int: + args = parse_args(argv) + evlog = args.eventlog + if not os.path.isfile(evlog): + print(f"error: file not found: {evlog}", file=sys.stderr) + return 1 + + out = args.out + if out is None: + base = os.path.basename(evlog) + if base.endswith(".eventlog"): + out = base[:-len(".eventlog")] + ".events.txt" + else: + out = base + ".events.txt" + + contains_list: Optional[List[str]] = None + if args.contains: + contains_list = [s for s in args.contains.split("|") if s != ""] + + ghc_events = find_ghc_events() + if ghc_events is None: + if try_install_ghc_events(): + ghc_events = find_ghc_events() + else: + print("error: ghc-events not found; please install it (e.g., 'cabal install ghc-events')", file=sys.stderr) + return 1 + if ghc_events is None: + print("error: ghc-events still not found after installation.", file=sys.stderr) + return 1 + + cmd = [ghc_events, "show", evlog] + print(f"Dumping events from {evlog} to {out} using {ghc_events}...", file=sys.stderr) + rc = stream_and_filter(cmd, out, contains_list) + if rc != 0: + print(f"error: dump failed with exit code {rc}", file=sys.stderr) + return rc + + try: + size = os.path.getsize(out) + except Exception: + size = None + if size is None: + print(f"Wrote {out}.") + else: + print(f"Wrote {out} ({size} bytes).") + return 0 + + +if __name__ == "__main__": + raise SystemExit(main()) diff --git a/scripts/flaky-test-loop.sh b/scripts/flaky-test-loop.sh new file mode 100755 index 0000000000..2e3dfa9906 --- /dev/null +++ b/scripts/flaky-test-loop.sh @@ -0,0 +1,199 @@ +#!/usr/bin/env bash +# Loop running HLS tasty tests until a Broken pipe or test failure is observed. +# Originally ran only the "open close" test; now supports multiple patterns. +# Ensures successful build before running any tests. +# Logs each run to test-logs/-loop-.log, rotating every 100 files per pattern. +# +# Environment you can tweak: +# MAX_ITER : maximum iterations before giving up (default: 1000) +# SLEEP_SECS : seconds to sleep between iterations (default: 0) +# SHOW_EVERY : print progress/iteration header every N iterations (default: 100, 1 = every run, <=0 = disabled) +# LOG_STDERR : set to 1 to enable verbose stderr logging (HLS_TEST_LOG_STDERR & HLS_TEST_HARNESS_STDERR) (default: 1) +# NO_BUILD_ONCE : set to non-empty to skip the initial cabal build step +# +# Test selection: +# TEST_PATTERNS : comma-separated list of entries to run each iteration. +# Each entry can be either a plain tasty pattern, or 'BIN::PATTERN' to select a test binary. +# Examples: +# TEST_PATTERNS='open close' +# TEST_PATTERNS='ghcide-tests::open close,func-test::sends indefinite progress notifications' +# If set and non-empty, this takes precedence over PATTERN_FILE. +# If unset, defaults to 'ghcide-tests::open close' to match prior behavior. +# PATTERN_FILE : path to a file with one entry per line. +# Lines start with optional 'BIN::', then the tasty pattern. '#' comments and blank lines ignored. +# Examples: +# ghcide-tests::open close +# func-test::sends indefinite progress notifications +# Used only if TEST_PATTERNS is empty/unset; otherwise ignored. +# +# Exit codes: +# 1 on success (broken pipe or test failure reproduced) +# 0 on reaching MAX_ITER without reproduction +# 2 on other setup error + +set -euo pipefail + +MAX_ITER="${MAX_ITER:-}" +SLEEP_SECS="${SLEEP_SECS:-0}" +SHOW_EVERY="${SHOW_EVERY:-1}" +LOG_STDERR="${LOG_STDERR:-1}" + +# Allow providing a positional max iteration: ./open-close-loop.sh 50 +if [[ $# -ge 1 && -z "${MAX_ITER}" ]]; then + MAX_ITER="$1" +fi + +# fallback to default if not set +if [[ -z "${MAX_ITER}" ]]; then + MAX_ITER=1000 +fi + +mkdir -p test-logs + +iter=0 +start_ts=$(date -Iseconds) +echo "[loop] Starting at ${start_ts}" >&2 + +# Patterns to detect issues +# - Use case-insensitive extended regex for failures/timeouts in logs +# - Broken pipe: case-insensitive fixed-string search +BROKEN_PIPE_RE='Broken pipe' +TEST_FAILED_RE='tests failed|timeout' +DEBUG_DETECT="${DEBUG_DETECT:-0}" + +# Resolve what to run each iteration as pairs of BIN and PATTERN +items=() # each item is 'BIN::PATTERN' +if [[ -n "${TEST_PATTERNS:-}" ]]; then + IFS=',' read -r -a raw_items <<< "${TEST_PATTERNS}" + for it in "${raw_items[@]}"; do + # trim + it="${it#${it%%[![:space:]]*}}"; it="${it%${it##*[![:space:]]}}" + [[ -z "$it" ]] && continue + if [[ "$it" == *"::"* ]]; then + items+=("$it") + else + items+=("ghcide-tests::${it}") + fi + done +elif [[ -n "${PATTERN_FILE:-}" && -r "${PATTERN_FILE}" ]]; then + while IFS= read -r line; do + # trim whitespace, skip comments and blank lines + trimmed="${line#${line%%[![:space:]]*}}"; trimmed="${trimmed%${trimmed##*[![:space:]]}}" + [[ -z "${trimmed}" || "${trimmed}" =~ ^[[:space:]]*# ]] && continue + if [[ "${trimmed}" == *"::"* ]]; then + items+=("${trimmed}") + else + items+=("ghcide-tests::${trimmed}") + fi + done < "${PATTERN_FILE}" +else + # default to the original single test + items+=("ghcide-tests::open close") +fi + +if [[ ${#items[@]} -eq 0 ]]; then + echo "[loop][error] No test entries provided (via PATTERN_FILE or TEST_PATTERNS)." >&2 + exit 2 +fi + +# Build required test binaries once upfront (unless NO_BUILD_ONCE is set) +if [[ -z "${NO_BUILD_ONCE:-}" ]]; then + # collect unique BIN names + declare -a bins_to_build=() + for it in "${items[@]}"; do + bin="${it%%::*}"; seen=0 + if (( ${#bins_to_build[@]} > 0 )); then + for b in "${bins_to_build[@]}"; do [[ "$b" == "$bin" ]] && seen=1 && break; done + fi + [[ $seen -eq 0 ]] && bins_to_build+=("$bin") + done + if (( ${#bins_to_build[@]} > 0 )); then + echo "[loop] Building test targets once upfront: ${bins_to_build[*]}" >&2 + if ! cabal build "${bins_to_build[@]}" >&2; then + echo "[loop][error] Build failed. Cannot proceed with tests." >&2 + exit 2 + fi + echo "[loop] Build succeeded. Proceeding with tests." >&2 + fi +fi + +# Resolve binary path by name (cache results) +BIN_NAMES=() +BIN_PATHS=() +get_bin_path() { + local name="$1" + local i + for ((i=0; i<${#BIN_NAMES[@]}; i++)); do + if [[ "${BIN_NAMES[i]}" == "$name" ]]; then + echo "${BIN_PATHS[i]}"; return + fi + done + local path="" + path=$(find dist-newstyle -type f -name "$name" -perm -111 2>/dev/null | head -n1 || true) + BIN_NAMES+=("$name"); BIN_PATHS+=("$path") + echo "$path" +} + +while true; do + iter=$((iter+1)) + ts=$(date -Iseconds) + file_num=$((iter % 2)) + + # Run each selected item (BIN::PATTERN) in this iteration + for item in "${items[@]}"; do + bin_name="${item%%::*}" + pattern="${item#*::}" + # sanitize pattern for a log slug + slug=$(printf '%s' "${bin_name}-${pattern}" | tr -cs 'A-Za-z0-9._-' '-' | sed -E 's/^-+|-+$//g') + [[ -z "${slug}" ]] && slug="pattern" + log="test-logs/${slug}-loop-${file_num}.log" + + # Show iteration start at first run and then every SHOW_EVERY runs (if > 0) + if [[ ${iter} -eq 1 || ( ${SHOW_EVERY} -gt 0 && $((iter % SHOW_EVERY)) -eq 0 ) ]]; then + echo "[loop] Iteration ${iter} (${ts}) pattern='${pattern}' -> ${log}" | tee -a "${log}" >&2 + fi + + # We don't fail the loop on non-zero exit (capture output then decide). + set +e + # HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 \ + HLS_TEST_LOG_STDERR="${LOG_STDERR}" \ + HLS_TEST_HARNESS_STDERR="${LOG_STDERR}" \ + TASTY_NUM_THREADS=1 \ + TASTY_PATTERN="${pattern}" \ + "$(get_bin_path "${bin_name}")" +RTS -l -olhlint.eventlog -RTS >"${log}" 2>&1 + set -e + + if grep -aFiq -- "${BROKEN_PIPE_RE}" "${log}"; then + echo "[loop] Broken pipe reproduced in iteration ${iter} for pattern '${pattern}'. Stopping." | tee -a "${log}" >&2 + echo "[loop] Log file: ${log} (abs: $(pwd)/${log})" | tee -a "${log}" >&2 + echo "[loop] --- Tail (last 60 lines) ---" >&2 + tail -n 60 "${log}" >&2 + exit 1 + elif grep -aEq -- "${TEST_FAILED_RE}" "${log}"; then + echo "[loop] Test failure detected in iteration ${iter} for pattern '${pattern}'. Stopping." | tee -a "${log}" >&2 + echo "[loop] Log file: ${log} (abs: $(pwd)/${log})" | tee -a "${log}" >&2 + echo "[loop] --- Tail (last 60 lines) ---" >&2 + tail -n 60 "${log}" >&2 + exit 1 + else + if [[ ${DEBUG_DETECT} -eq 1 ]]; then + echo "[loop][debug] No match for '${BROKEN_PIPE_RE}' or '${TEST_FAILED_RE}' in iteration ${iter} (pattern='${pattern}')." | tee -a "${log}" >&2 + fi + fi + done + + if [[ -n "${MAX_ITER}" && ${iter} -ge ${MAX_ITER} ]]; then + echo "[loop] Reached MAX_ITER=${MAX_ITER} without reproducing issues." >&2 + exit 0 + fi + + # Show progress at the configured cadence + if [[ ${SHOW_EVERY} -gt 0 && $((iter % SHOW_EVERY)) -eq 0 ]]; then + echo "[loop] Progress: Completed ${iter} iterations without detecting issues." >&2 + fi + + if [[ ${SLEEP_SECS} -gt 0 ]]; then + echo "[loop] Sleeping ${SLEEP_SECS}s" >&2 + sleep "${SLEEP_SECS}" + fi +done diff --git a/scripts/flaky-test-patterns.txt b/scripts/flaky-test-patterns.txt new file mode 100644 index 0000000000..4a4b4681d1 --- /dev/null +++ b/scripts/flaky-test-patterns.txt @@ -0,0 +1,20 @@ +# One tasty pattern per line. Lines starting with # are comments. +# Blank lines are ignored. + +open close +# non local variable +# Notification Handlers +# bidirectional module dependency with hs-boot + +# InternalError over InvalidParams +# ghcide restarts shake session on config changes: +# addDependentFile +# Another interesting one you can try: +# func-test::sends indefinite progress notifications +# hls-pragmas-plugin-tests::/inline: RULES/ + +# hls-graph cancel leaks asynchronous exception to the next session +# hls-hlint-plugin-tests::adding hlint flags to plugin configuration removes hlint diagnostics +# hls-explicit-imports-plugin-tests::ExplicitUsualCase inlay hints with client caps +# hls-class-plugin-tests::Creates a placeholder for fmap +# hls-rename-plugin-tests::Rename