tricorder 0.1.0.1 → 0.1.1.0
raw patch · 23 files changed
+1637/−508 lines, 23 filesdep +regex-tdfadep +unixdep ~Cabal-syntaxdep ~atelier-coredep ~base
Dependencies added: regex-tdfa, unix
Dependency ranges changed: Cabal-syntax, atelier-core, base, bytestring, containers, effectful-plugin, filepath, template-haskell, time
Files
- CHANGELOG.md +50/−0
- src/Tricorder/BuildState.hs +3/−3
- src/Tricorder/Builder.hs +18/−13
- src/Tricorder/Builder/Dispatch.hs +69/−8
- src/Tricorder/Effects/GhciSession.hs +4/−1
- src/Tricorder/Effects/GhciSession/GhciParser.hs +89/−4
- src/Tricorder/Effects/GhciSession/GhciProcess.hs +67/−84
- src/Tricorder/Effects/TestRunner.hs +5/−5
- src/Tricorder/Session.hs +325/−79
- src/Tricorder/UI.hs +3/−20
- src/Tricorder/UI/Keys.hs +58/−48
- src/Tricorder/UI/Route.hs +20/−0
- src/Tricorder/UI/State.hs +29/−29
- src/Tricorder/UI/View.hs +113/−55
- src/Tricorder/Watcher.hs +34/−6
- test/Unit/Tricorder/BuilderSpec.hs +115/−13
- test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs +114/−6
- test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs +122/−19
- test/Unit/Tricorder/Effects/GhciSessionSpec.hs +9/−8
- test/Unit/Tricorder/Effects/SessionStoreSpec.hs +3/−3
- test/Unit/Tricorder/SessionSpec.hs +281/−77
- test/Unit/Tricorder/WatcherSpec.hs +68/−2
- tricorder.cabal +38/−25
+ CHANGELOG.md view
@@ -0,0 +1,50 @@+# Changelog++All notable changes to `tricorder` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to the [PVP](https://pvp.haskell.org/).++## [0.1.1.0] - 2026-06-26++### Added++- Configurable `watch_exclusion_patterns` to exclude paths from the file+ watcher.+- The TUI now presents its different views as tabs.++### Fixed++- Terminate the whole cabal process group on shutdown, so children that trap+ `SIGINT` are no longer left running.+- Correct watch-directory scoping for bare package-name targets in a+ multi-package project.+- Building no longer fails for packages that use a custom prelude.+- Use the correct set of targets when constructing the build command.+- Surface location-less GHCi load failures (e.g. plugin errors) without+ reporting false positives.+- Clear stale diagnostics for failed executable and test `Main` modules.++## [0.1.0.1] - 2026-06-06++### Fixed++- Renamed the installed executable from `tricorder-exe` to `tricorder` so+ `cabal install tricorder` provides a binary matching the package name.++## [0.1.0.0] - 2026-06-05++### Added++- Initial release: daemon-based GHCi build monitor communicating over a Unix+ socket.+- Commands: `start`, `stop`, `status [--wait]`, `watch`.+- `status` outputs structured JSON with build phase, module count, duration,+ and messages; each message includes `severity`, `file`, `line`/`col`,+ `title` (first line), and `text` (full body).+- Auto-detects cabal/stack projects and builds the+ `cabal repl --enable-multi-repl` command.+- Parses `.cabal` files to resolve `hs-source-dirs` for targeted file watching.+- Configurable via `.tricorder.toml` (targets, debounce, log file, etc.).+- File watcher with debouncing; auto-restarts the GHCi session on crash+ (fixes ghcid's crash-on-file-removal bug).
src/Tricorder/BuildState.hs view
@@ -38,7 +38,7 @@ import Tricorder.Effects.SessionStore (SessionStore) import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..))-import Tricorder.Session (Session (..))+import Tricorder.Session (Session (..), Target, WatchDirs (..)) import Tricorder.Effects.SessionStore qualified as SessionStore import Tricorder.Observability qualified as Observability@@ -51,7 +51,7 @@ data DaemonInfo = DaemonInfo- { targets :: [Text]+ { targets :: [Target] , watchDirs :: [FilePath] , sockPath :: FilePath , logFile :: FilePath@@ -78,7 +78,7 @@ pure $ DaemonInfo { targets = session.targets- , watchDirs = map (makeRelative projectRoot) session.watchDirs+ , watchDirs = map (makeRelative projectRoot) session.watchDirs.getWatchDirs , sockPath , logFile , metricsPort = if obsCfg.metrics.enabled then Just obsCfg.metrics.port else Nothing
src/Tricorder/Builder.hs view
@@ -57,6 +57,7 @@ , emptyBuilderState , filterToWatchDirs , mergeDiagnostics+ , preserveFailureVisibility ) import Tricorder.Effects.BuildStore (BuildStore) import Tricorder.Effects.GhciSession (GhciSession, LoadResult (..))@@ -65,7 +66,7 @@ import Tricorder.Effects.SessionStore (SessionStore) import Tricorder.Effects.TestRunner (TestRunner) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (Session (..))+import Tricorder.Session (Command (..), Session (..), Target, TestTargets, WatchDirs, getTestTargets, renderTarget) import Tricorder.Effects.BuildStore qualified as BuildStore import Tricorder.Effects.GhciSession qualified as GhciSession@@ -102,10 +103,10 @@ -- | A subset of 'Session' with just the properties that 'Builder' cares about. data BuildConfig = BuildConfig- { command :: Text- , targets :: [Text]- , testTargets :: [Text]- , watchDirs :: [FilePath]+ { command :: Command+ , targets :: [Target]+ , testTargets :: TestTargets+ , watchDirs :: WatchDirs } deriving stock (Eq) @@ -186,7 +187,7 @@ , testTargets = session.testTargets , watchDirs = session.watchDirs }- Log.info $ "Builder.component: resolved command = " <> config.command+ Log.info $ "Builder.component: resolved command = " <> coerce config.command pure config @@ -277,7 +278,7 @@ hooks.onStart root@(ProjectRoot rootPath) <- ask BuildId n <- get- Log.info $ "Starting GHCi session #" <> show n <> ": " <> config.command+ Log.info $ "Starting GHCi session #" <> show n <> ": " <> coerce config.command startTime <- Clock.currentTime result <- trySync $ GhciSession.withGhci config.command root \initialLoad controls -> do@@ -491,7 +492,8 @@ let filteredResult = loadResult { GhciSession.diagnostics =- filterToWatchDirs projectRoot watchDirs loadResult.diagnostics+ preserveFailureVisibility loadResult.diagnostics+ $ filterToWatchDirs projectRoot watchDirs loadResult.diagnostics } newAccumulated <- state \s ->@@ -544,18 +546,21 @@ -> BuildResult -> Eff es (Maybe [TestRun]) runTestsIfClean (BuildConfig {testTargets}) bid partialResult- | null testTargets || any (\d -> d.severity == SError) partialResult.diagnostics = pure (Just [])+ | null targetNames || any (\d -> d.severity == SError) partialResult.diagnostics = pure (Just []) | otherwise = do TestRunner.resetAbort setNewPhase $ EnteringNewPhase bid- $ Testing partialResult {testRuns = map (`TestRunning` Nothing) testTargets}+ $ Testing partialResult {testRuns = map (`TestRunning` Nothing) targetNames} - Log.info $ "Running " <> show (length testTargets) <> " test suite(s)"+ Log.info $ "Running " <> show (length targetNames) <> " test suite(s)" - let initial = (\t -> (t, TestRunning t Nothing)) <$> testTargets- runLoop initial testTargets+ let initial = (\t -> (t, TestRunning t Nothing)) <$> targetNames+ runLoop initial targetNames where+ -- The runner consumes the @test:@ targets as cabal/ghci arguments, so+ -- render the structured targets to their textual form at this boundary.+ targetNames = map renderTarget testTargets.getTestTargets runLoop acc [] = pure (Just (snd <$> acc)) runLoop acc (target : rest) = do Log.info $ "Running tests: " <> target
src/Tricorder/Builder/Dispatch.hs view
@@ -8,18 +8,25 @@ , fileMatchesAnyTarget , filterToWatchDirs , mergeDiagnostics+ , preserveFailureVisibility ) where import Atelier.Effects.FileWatcher (FileEvent (..)) import Data.Default (Default (..))-import System.FilePath (isAbsolute, (</>))+import System.FilePath (isAbsolute, normalise, splitDirectories, takeExtension, (</>)) +import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Set qualified as Set -import Tricorder.BuildState (Diagnostic (..))+import Tricorder.BuildState (Diagnostic (..), Severity (..)) import Tricorder.Effects.GhciSession (LoadResult (..), LoadedModule (..))-import Tricorder.Effects.GhciSession.GhciParser (pathSuffixesAsModuleName)+import Tricorder.Effects.GhciSession.GhciParser+ ( isLocationLess+ , pathSuffixesAsModuleName+ , unattributedFailure+ )+import Tricorder.Session (WatchDirs (..)) -- | The Builder's per-GHCi-session cache: what it last saw from GHCi plus its@@ -56,9 +63,16 @@ -- by any new diagnostics produced for them in this cycle. Files absent from -- 'compiledFiles' were skipped by incremental compilation and retain their -- previous diagnostics unchanged.+--+-- Location-less diagnostics (see 'isLocationLess') are never keyed to a real+-- source file, so they would never appear in 'compiledFiles' and would persist+-- forever once raised. They describe the current load's outcome, so we clear+-- them every cycle and let this cycle's 'diagnostics' re-add them if the+-- failure is still present. mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} =- let cleared = foldr Map.delete prev compiledFiles+ let retained = Map.filterWithKey (\f _ -> not (isLocationLess f)) prev+ cleared = foldr Map.delete retained compiledFiles newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics] in Map.union newByFile cleared @@ -72,11 +86,32 @@ -- | Whether a file path corresponds to one of GHCi's targets.+--+-- @:show targets@ entries are either dotted module names (e.g.+-- @Tricorder.CLI.Main@) or file paths (e.g. @app/Main.hs@). GHCi uses the path+-- form when a module name is ambiguous across home units — i.e. every+-- executable/test 'Main'. We match both forms.+--+-- The path form matters because a /failed/ executable 'Main' drops out of+-- @:show modules@ but survives in @:show targets@ as its path. Without matching+-- it, fixing the executable would dispatch a no-op 'Add' instead of a 'Reload',+-- leaving the diagnostic stale. fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool fileMatchesAnyTarget (KnownTargetNames targets) fp = any (`Set.member` targets) (pathSuffixesAsModuleName fp)+ || any (pathTargetMatches fp . toString) (Set.toList targets) +-- | Whether a path-shaped @:show targets@ entry refers to the given file,+-- compared on directory-segment boundaries (so @app/Main.hs@ matches+-- @./tricorder/app/Main.hs@ but @pp/Main.hs@ does not). Module-name targets+-- (no @.hs@ extension) are left to the module-name branch above.+pathTargetMatches :: FilePath -> FilePath -> Bool+pathTargetMatches file target =+ takeExtension target == ".hs"+ && splitDirectories (normalise target) `List.isSuffixOf` splitDirectories (normalise file)++ -- | A GHCi command to issue in response to a source file change. data DispatchAction = Reload@@ -119,10 +154,16 @@ -- those with mangled filenames produced by the C preprocessor (e.g. -- @"In file included from ..."@) are dropped here, before they can enter the -- accumulation map where they would be impossible to evict.-filterToWatchDirs :: FilePath -> [FilePath] -> [Diagnostic] -> [Diagnostic]-filterToWatchDirs _ [] diags = diags-filterToWatchDirs projectRoot watchDirs diags =- filter (isUnderAnyWatchDir . (.file)) diags+--+-- Location-less diagnostics (see 'isLocationLess') are always kept: they carry+-- no path to test against a watch dir, but they represent genuine build-level+-- failures (e.g. a home-unit GHC plugin that can't load under+-- @--enable-multi-repl@) that must not be dropped, or the build would silently+-- read as clean.+filterToWatchDirs :: FilePath -> WatchDirs -> [Diagnostic] -> [Diagnostic]+filterToWatchDirs _ (WatchDirs []) diags = diags+filterToWatchDirs projectRoot (WatchDirs watchDirs) diags =+ filter (\d -> isLocationLess d.file || isUnderAnyWatchDir d.file) diags where absWatchDirs = map toAbsWd watchDirs toAbsWd wd@@ -136,3 +177,23 @@ | otherwise = let absFile = projectRoot </> drop 2 file in any (\wd -> (wd ++ "/") `isPrefixOf` absFile || wd == absFile) absWatchDirs+++-- | Keep a failed build from ever reading as clean after watch-dir filtering.+--+-- 'filterToWatchDirs' drops diagnostics outside the watched directories. If a+-- load failed but every error it produced lay outside those dirs (e.g. a+-- compile error in a sibling home unit not under @watchDirs@), filtering would+-- leave no diagnostics and the broken build would look green. Detecting that an+-- error was present /before/ filtering but none survived, we re-attach the+-- location-less synthetic failure (which filtering always keeps) so the failure+-- still surfaces.+--+-- Takes the pre-filter diagnostics and the post-filter diagnostics; returns the+-- post-filter list, with the synthetic failure appended only when needed.+preserveFailureVisibility :: [Diagnostic] -> [Diagnostic] -> [Diagnostic]+preserveFailureVisibility raw filtered+ | any isError raw && not (any isError filtered) = filtered ++ [unattributedFailure]+ | otherwise = filtered+ where+ isError d = d.severity == SError
src/Tricorder/Effects/GhciSession.hs view
@@ -15,6 +15,7 @@ import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (File)+import Atelier.Effects.Log (Log) import Atelier.Effects.Process (Process) import Atelier.Effects.Timeout (Timeout) import Data.Default (def)@@ -46,6 +47,7 @@ ) import Tricorder.Effects.GhciSession.GhciProcess (addGhci, collectGhciResult, interruptGhci, reloadGhci, unaddGhci, withGhciProcess) import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Command) data GhciSession :: Effect where@@ -53,7 +55,7 @@ -- The handler is also provided an action to reload the GHCi session, -- returning new messages with module counts. The GHCi session is closed -- when the handler returns.- WithGhci :: Text -> ProjectRoot -> (LoadResult -> Controls m -> m a) -> GhciSession m a+ WithGhci :: Command -> ProjectRoot -> (LoadResult -> Controls m -> m a) -> GhciSession m a data Controls m = Controls@@ -105,6 +107,7 @@ , Conc :> es , Concurrent :> es , File :> es+ , Log :> es , Process :> es , Timeout :> es )
src/Tricorder/Effects/GhciSession/GhciParser.hs view
@@ -3,10 +3,14 @@ , GhciLoading (..) , GhciMessage (..) , GhciSeverity (..)+ , LoadOutcome (..) , LoadResult (..) , LoadedModule (..) , Position (..)+ , collectResult , collectResultCustom+ , isLocationLess+ , reloadFailed , parseProgressLine , parseReload , parseShowModules@@ -17,6 +21,7 @@ , extractTitle , toAbsolute , toRelative+ , unattributedFailure ) where import Data.Char (isAlpha, isDigit, isSpace, toLower)@@ -74,11 +79,18 @@ deriving stock (Eq, Show) +-- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@+-- on success or @Failed, …@ on failure.+data LoadOutcome = LoadSucceeded | LoadFailed+ deriving stock (Eq, Show)++ -- | A structured item from GHCi's reload output. data GhciLoad = GLoading GhciLoading | GMessage GhciMessage | GLoadConfig FilePath+ | GSummary LoadOutcome deriving stock (Eq, Show) @@ -268,9 +280,13 @@ do (_, stripped) <- satisfyStripped ("[" `T.isPrefixOf`) pure (runTP loadingLineP stripped)- , -- Pattern: summary lines "Ok, ..." / "Failed, ..." — discard- fmap (const Nothing)- $ satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s)+ , -- Pattern: terminal summary line "Ok, ..." / "Failed, ..."+ fmap Just $ do+ (_, stripped) <-+ satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s)+ pure+ $ GSummary+ $ if "Failed, " `T.isPrefixOf` stripped then LoadFailed else LoadSucceeded , -- Pattern: "<no location info>: error:" fmap Just $ do (origLine, _) <- satisfyStripped ("<no location info>: error:" `T.isPrefixOf`)@@ -488,6 +504,70 @@ } +-- | Assemble a 'LoadResult' from the raw reload output plus the @:show+-- modules@ / @:show targets@ output.+--+-- This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload+-- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a+-- location-less failure we don't otherwise attribute to a file), a synthetic+-- error diagnostic is appended so the build can never be reported as clean+-- while GHCi considers it failed.+collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult+collectResult projectRoot reloadLines modules targets =+ let loads = parseReload reloadLines+ base = collectResultCustom projectRoot loads modules targets+ hasError = any (\d -> d.severity == SError) base.diagnostics+ in if reloadFailed loads && not hasError then+ base {diagnostics = base.diagnostics ++ [unattributedFailure]}+ else+ base+++-- | Synthetic diagnostic for a failed load with no located error. Without a+-- source span it cannot point anywhere, but it stops the build reading as+-- clean and tells the user where to look.+unattributedFailure :: Diagnostic+unattributedFailure =+ BuildState.Diagnostic+ { severity = SError+ , file = "<no location info>"+ , line = 0+ , col = 0+ , endLine = 0+ , endCol = 0+ , title = "GHCi reported a failed load with no located error"+ , text = "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n"+ }+++-- | Whether GHCi's load ended in failure, decided from the 'GSummary' items+-- 'parseReload' produces — the single place that classifies GHCi's terminal+-- @Ok, …@ / @Failed, …@ summary line.+--+-- GHCi emits the real summary last, after all compilation output. Output+-- produced /during/ the load (a Template Haskell splice, top-level IO run while+-- interpreting) can contain an earlier line that looks like a summary, so only+-- the /last/ 'GSummary' reflects the true outcome.+reloadFailed :: [GhciLoad] -> Bool+reloadFailed loads =+ case [outcome | GSummary outcome <- loads] of+ [] -> False+ outcomes -> List.last outcomes == LoadFailed+++-- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully+-- @\<…\>@-bracketed marker such as @\<no location info\>@ or @\<interactive\>@+-- rather than a real source path. These carry no source span but can still+-- represent genuine build-level failures, so callers treat them specially+-- (kept rather than dropped, cleared every cycle rather than retained).+--+-- We require both the opening @\<@ and a closing @\>@ so a real (if exotic)+-- path that merely starts with @\<@, e.g. @\<generated\>/Foo.hs@, is not+-- mistaken for a marker.+isLocationLess :: FilePath -> Bool+isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f++ -- | Path↔module-name map for the next cycle: this round's @:show modules@ -- plus carryover from @prev@ for targets that failed mid-session and so -- dropped out. Never-compiled targets are absent here (no path↔name@@ -514,7 +594,12 @@ toDiagnostics :: (FilePath -> FilePath) -> [GhciLoad] -> [BuildState.Diagnostic] toDiagnostics rel loads = mapMaybe toMsg loads where- toMsg (GMessage m) | '<' : _ <- m.file = Nothing+ -- Location-less messages (e.g. @<no location info>@, @<interactive>@) carry+ -- no source span. We keep the *errors* — a @<no location info>@ error is a+ -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in+ -- @--enable-multi-repl@) and must not be silently dropped — but discard+ -- location-less warnings, which are just noise without a file to attach to.+ toMsg (GMessage m) | isLocationLess m.file, m.severity /= GError = Nothing toMsg (GMessage m) = Just BuildState.Diagnostic
src/Tricorder/Effects/GhciSession/GhciProcess.hs view
@@ -18,6 +18,7 @@ import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (BufferMode (..), File, Handle)+import Atelier.Effects.Log (Log) import Atelier.Effects.Process ( Process , RunningProcess@@ -25,7 +26,6 @@ , getStderr , getStdin , getStdout- , setCreateGroup , setStderr , setStdin , setStdout@@ -38,23 +38,25 @@ import Data.Time.Units (Second) import Effectful.Concurrent (Concurrent) import Effectful.Concurrent.STM (atomically, newTVarIO)-import Effectful.Exception (bracket, finally, throwIO, trySync)+import Effectful.Exception (finally, throwIO, trySync) import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.File qualified as File+import Atelier.Effects.Log qualified as Log import Atelier.Effects.Process qualified as Process import Data.Text qualified as T import Tricorder.Effects.GhciSession.GhciParser ( GhciLoading (..) , LoadResult (..)- , collectResultCustom+ , collectResult , parseProgressLine- , parseReload , parseShowModules , parseShowTargets , stripAnsi+ , unattributedFailure )+import Tricorder.Session (Command (..)) -- | Configuration for GHCi process management.@@ -127,21 +129,18 @@ instance Exception GhciProcessError --- | Start a GHCi subprocess running the given command in the given directory.+-- | Set up the GHCi protocol on an already-started process and return its+-- handle together with the output captured during startup. ----- Waits up to 'startupTimeout' seconds for GHCi to print its version banner,--- then performs initial setup (setting prompts and synchronising) and sends--- any 'extraSetupCommands' from the config.-startGhciProcess+-- The spawn and group teardown are owned by 'withGhciProcess'.+setupGhciProcess :: ( Conc :> es , Concurrent :> es , File :> es- , Process :> es , Timeout :> es ) => Config- -> Text- -> FilePath+ -> RunningProcess Handle Handle Handle -> (GhciLoading -> Eff es ()) -- ^ Called as each @[N of M] Compiling …@ line is streamed during the -- initial-build drain, so the UI can update the progress bar live@@ -152,15 +151,7 @@ -- for interruption while the slow @cabal repl@ startup (dependency build -- and recompilation) is still in progress. -> Eff es (GhciProcess, [Text])-startGhciProcess config cmd dir onProgress onReady = do- p <-- Process.startProcess- $ setStdin createPipe- $ setStdout createPipe- $ setStderr createPipe- $ setCreateGroup True- $ setWorkingDir dir- $ shell (toString cmd)+setupGhciProcess config p onProgress onReady = do let inp = getStdin p out = getStdout p err = getStderr p@@ -168,11 +159,8 @@ File.hSetBuffering out LineBuffering File.hSetBuffering err LineBuffering - -- Create the state var and the process handle up front, then register the- -- process for interruption *before* the (possibly slow) banner wait. For- -- @cabal repl@, dependency building happens before GHCi prints its banner,- -- so registering here lets an interrupt terminate the process during that- -- window rather than having to wait for the whole startup to complete.+ -- Register the process for interruption before the (possibly slow) banner+ -- wait, so an interrupt during @cabal repl@ startup can terminate it. stateVar <- newTVarIO (Idle 0) let ghciProcess = GhciProcess@@ -191,7 +179,7 @@ -- Wait for the version banner. We concurrently capture stderr so that if -- the build command exits before printing a banner (e.g. cabal's -- dependency resolution fails) we can surface its error output.- waitForBannerOrFail config.startupTimeout out err p+ waitForBannerOrFail config.startupTimeout out err -- Send fixed setup commands (protocol requirements) File.hPutTextLn inp ":set prompt \"\""@@ -221,31 +209,32 @@ pure (ghciProcess, initialLines) --- | Bracket helper: start a GHCi process, run an action, then stop it.+-- | Run a GHCi @cabal repl@ session for the duration of @action@. ----- The action receives both the process handle and the output lines captured--- during the startup sync (stdout ++ stderr). These lines contain the initial--- compilation progress and any startup diagnostics. The @onProgress@ callback--- fires for each @[N of M] Compiling …@ line as GHCi emits it during the--- initial build, so the UI can update its progress bar in real time. The--- @onReady@ callback (see 'startGhciProcess') fires once the underlying--- process exists but before the banner wait and initial-load drain — useful--- for registering the process for early termination while @cabal repl@ startup--- (dependency build and initial compilation) is still in flight.+-- The session runs in its own process group, so the whole group is torn down on+-- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The+-- action receives the process handle and the output captured during startup.+-- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks. withGhciProcess :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es) => Config- -> Text+ -> Command -> FilePath -> (GhciLoading -> Eff es ()) -> (GhciProcess -> Eff es ()) -> (GhciProcess -> [Text] -> Eff es a) -> Eff es a withGhciProcess config cmd dir onProgress onReady action =- bracket- (startGhciProcess config cmd dir onProgress onReady)- (stopGhciProcess config . fst)- (uncurry action)+ Process.withProcessGroup processConfig \p -> do+ (ghciProcess, initialLines) <- setupGhciProcess config p onProgress onReady+ action ghciProcess initialLines `finally` quitGhci config ghciProcess+ where+ processConfig =+ setStdin createPipe+ $ setStdout createPipe+ $ setStderr createPipe+ $ setWorkingDir dir+ $ shell (toString cmd.getCommand) -- | Execute a command in GHCi and return the combined stdout+stderr output@@ -310,38 +299,27 @@ sendSyncCommand ghciProcess.stdin (markerFor n) --- | Forcefully terminate the GHCi process, closing its handles.+-- | Forcefully terminate a GHCi process and its whole group. ----- Stronger than 'interruptGhci': intended for one-shot processes (such as--- the per-suite @cabal repl test:…@ used by the test runner) where SIGINT--- is insufficient — test frameworks like @hspec@ and @tasty@ install--- SIGINT handlers that finalise the current run rather than aborting it.--- After this, any 'execGhci' drain raises 'UnexpectedExit' on the now-closed--- handles.+-- Stronger than 'interruptGhci': intended for one-shot processes (such as the+-- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is+-- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT+-- handlers that finalise the current run rather than aborting it. Safe to call+-- from another thread while the session is running. terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es ()-terminateGhciProcess ghciProcess = Process.stopProcess ghciProcess.handle+terminateGhciProcess ghciProcess =+ Process.terminateProcessGroup ghciProcess.handle --- | Stop the GHCi process gracefully, falling back to forced termination.------ Never throws — all errors are swallowed.-stopGhciProcess- :: (File :> es, Process :> es, Timeout :> es)- => Config -> GhciProcess -> Eff es ()-stopGhciProcess config ghciProcess = do- -- Try to write :quit+-- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it+-- shut down gracefully before the enclosing 'withGhciProcess' tears down the+-- group. Never throws.+quitGhci :: (File :> es, Process :> es, Timeout :> es) => Config -> GhciProcess -> Eff es ()+quitGhci config ghciProcess = do void $ trySync $ do File.hPutTextLn ghciProcess.stdin ":quit" File.hFlush ghciProcess.stdin-- -- Wait up to shutdownTimeout seconds for the process to exit, then force-kill- result <- timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle)- when (not (isJust result))- $ Process.stopProcess ghciProcess.handle-- -- Close all handles, ignoring errors- for_ [ghciProcess.stdin, ghciProcess.stdout, ghciProcess.stderr] \h ->- void $ trySync $ File.hClose h+ void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle) -- ---------------------------------------------------------------------------@@ -423,11 +401,10 @@ :: ( Conc :> es , Concurrent :> es , File :> es- , Process :> es , Timeout :> es )- => Second -> Handle -> Handle -> RunningProcess Handle Handle Handle -> Eff es ()-waitForBannerOrFail delay out err p = do+ => Second -> Handle -> Handle -> Eff es ()+waitForBannerOrFail delay out err = do capturedVar <- newTVarIO ([] :: [Text]) let captureLine line = atomically $ modifyTVar' capturedVar (line :) drainStderr = drainUntilEof err captureLine@@ -446,11 +423,9 @@ -- the drain happened to have read so far. _ <- timeout (1 :: Second) (Conc.await stderrThread) captured <- atomically $ readTVar capturedVar- Process.stopProcess p throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured) Nothing -> do captured <- atomically $ readTVar capturedVar- Process.stopProcess p throwIO $ maybe StartupTimeout StartupFailed (renderCapturedLines captured) @@ -508,28 +483,36 @@ -- Progress is emitted live by 'drainUntil' as lines arrive, so no replay -- callback is needed here — this function only assembles the final result. collectGhciResult- :: (Conc :> es, Concurrent :> es, File :> es)+ :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) => GhciProcess -> [Text] -> FilePath -> Eff es LoadResult collectGhciResult process lines' projectRoot = do- let loads = parseReload lines'- noProgress = \_ -> pure ()+ let noProgress = \_ -> pure () moduleLines <- execGhci process ":show modules" noProgress targetLines <- execGhci process ":show targets" noProgress- pure- $ collectResultCustom- projectRoot- loads- (parseShowModules moduleLines)- (parseShowTargets targetLines)+ let result =+ collectResult+ projectRoot+ lines'+ (parseShowModules moduleLines)+ (parseShowTargets targetLines)+ -- A failed load with no located error produces only the synthetic+ -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in+ -- that case, so log the raw GHCi output — it's the only way to see what+ -- actually went wrong, and the synthetic diagnostic points here.+ when (any (== unattributedFailure) result.diagnostics)+ $ Log.info+ $ "GHCi reported a failed load with no located error. Full GHCi output:\n"+ <> T.unlines lines'+ pure result -- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events -- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read. reloadGhci- :: (Conc :> es, Concurrent :> es, File :> es)+ :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) => GhciProcess -> FilePath -> (GhciLoading -> Eff es ())@@ -542,7 +525,7 @@ -- | Execute @:add@ for the given file and return the assembled 'LoadResult'. -- Progress events fire live via @onProgress@ as compilation proceeds. addGhci- :: (Conc :> es, Concurrent :> es, File :> es)+ :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) => GhciProcess -> FilePath -- the file to :add -> FilePath -- projectRoot@@ -557,7 +540,7 @@ -- 'LoadResult'. Progress events fire live via @onProgress@ as compilation -- proceeds. unaddGhci- :: (Conc :> es, Concurrent :> es, File :> es)+ :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) => GhciProcess -> Text -- the module name to :unadd -> FilePath -- projectRoot
src/Tricorder/Effects/TestRunner.hs view
@@ -55,7 +55,7 @@ import Tricorder.Effects.GhciSession.GhciProcess (GhciProcess, execGhci, terminateGhciProcess, withGhciProcess) import Tricorder.Effects.SessionStore (SessionStore) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (Session (..))+import Tricorder.Session (Command (..), Session (..), TestTimeout (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) import Tricorder.Effects.SessionStore qualified as SessionStore@@ -120,7 +120,7 @@ Session {testTimeout} <- SessionStore.get let onProgress = abortGatedProgress abortedRef target noProgress = \_ -> pure ()- -- Register the process as soon as 'startGhciProcess'+ -- Register the process as soon as 'setupGhciProcess' -- constructs it — before the initial @cabal repl@ -- compile drain runs. Without this, an interrupt that -- arrives during that drain would find@@ -136,7 +136,7 @@ $ bracket_ (pure ()) (atomically (writeTVar currentProcRef Nothing))- $ withGhciProcess def ("cabal repl " <> target) projectRoot onProgress onReady \ghci _ ->+ $ withGhciProcess def (Command $ "cabal repl " <> target) projectRoot onProgress onReady \ghci _ -> atomically (readTVar abortedRef) >>= \case -- An interrupt may have landed during the -- @cabal repl@ load. The returned value is@@ -144,8 +144,8 @@ -- 'abortedRef'. True -> pure (Right []) False -> case testTimeout of- secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress- secs ->+ TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress+ TestTimeout secs -> timeout (fromIntegral secs :: Second) (execGhci ghci ":main" noProgress) >>= \case Nothing -> pure (Left secs) Just ls -> pure (Right ls)
src/Tricorder/Session.hs view
@@ -1,6 +1,19 @@ module Tricorder.Session ( Session (..) , Config (..)+ , Command (..)+ , TestTargets+ , getTestTargets+ , parseTestTargets+ , Target (..)+ , ComponentKind (..)+ , parseTarget+ , renderTarget+ , WatchDirs (..)+ , WatchExclusionPatterns (..)+ , ReplBuildDir (..)+ , TestTimeout (..)+ , Pattern , loadSession , resolveCommand , resolveTargets@@ -9,6 +22,7 @@ , resolveTestTargets , resolveWatchDirs , sourceDirsForTarget+ , compareTargets ) where import Atelier.Config (LoadedConfig, extractConfig)@@ -16,60 +30,67 @@ import Atelier.Effects.Log (Log) import Atelier.Types.QuietSnake (QuietSnake (..)) import Atelier.Types.WithDefaults (WithDefaults (..))-import Data.Aeson (FromJSON)+import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Default (Default (..)) import Data.List (nub)+import Distribution.Compat.Lens (view) import Distribution.Fields (Field (..), FieldLine (..), Name (..), readFields) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)-import Distribution.Types.BuildInfo (hsSourceDirs) import Distribution.Types.CondTree (condTreeData)-import Distribution.Types.Executable (buildInfo) import Distribution.Types.GenericPackageDescription ( GenericPackageDescription+ , condBenchmarks , condExecutables+ , condForeignLibs , condLibrary , condSubLibraries , condTestSuites , packageDescription )-import Distribution.Types.Library (libBuildInfo) import Distribution.Types.PackageDescription (package) import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName)-import Distribution.Types.TestSuite (testBuildInfo) import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName) import Distribution.Utils.Path (getSymbolicPath)+import Effectful.Exception (throwIO) import Effectful.Reader.Static (Reader, ask) import System.FilePath (normalise, takeDirectory, takeExtension, (</>))+import System.IO.Error (userError)+import Text.Regex.TDFA.ReadRegex (parseRegex) import Atelier.Effects.Log qualified as Log import Data.ByteString.Char8 qualified as BC import Data.Text qualified as T+import Distribution.Types.BuildInfo.Lens qualified as Lens+import Text.Regex.TDFA.Pattern qualified as Regex import Tricorder.Runtime (ProjectRoot (..)) data Session = Session- { command :: Text- , targets :: [Text]- , testTargets :: [Text]- , watchDirs :: [FilePath]- , outputFile :: Maybe FilePath- , replBuildDir :: FilePath- , testTimeout :: Int+ { command :: Command+ , targets :: [Target]+ , testTargets :: TestTargets+ , watchDirs :: WatchDirs+ , watchExclusionPatterns :: WatchExclusionPatterns+ , replBuildDir :: ReplBuildDir+ , testTimeout :: TestTimeout } +type Pattern = (Regex.Pattern, (Regex.GroupIndex, Regex.DoPa))++ instance Default Session where def = Session- { command = ""+ { command = Command "" , targets = []- , testTargets = []- , watchDirs = []- , outputFile = Nothing- , replBuildDir = "/tmp"- , testTimeout = 10+ , testTargets = projectTestTargets []+ , watchDirs = WatchDirs []+ , watchExclusionPatterns = WatchExclusionPatterns []+ , replBuildDir = ReplBuildDir "/tmp"+ , testTimeout = TestTimeout 10 } @@ -77,8 +98,8 @@ { command :: Maybe Text , targets :: [Text] , watchDirs :: [FilePath]+ , watchExclusionPatterns :: [Text] , testTargets :: Maybe [Text]- , outputFile :: Maybe FilePath , replBuildDir :: FilePath , testTimeout :: Int }@@ -92,34 +113,176 @@ { command = Nothing , targets = [] , watchDirs = []+ , watchExclusionPatterns = [] , testTargets = Nothing- , outputFile = Just "build.json" , replBuildDir = "dist-newstyle/tricorder" , testTimeout = 10 } +newtype Command = Command {getCommand :: Text}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via Text+++-- | The test suites to run after a clean build. Built only by projecting a+-- target list onto its @test:@ components via 'projectTestTargets'; the data+-- constructor is not exported, so a 'TestTargets' can never hold a non-test+-- target [ref:test_targets_invariant].+newtype TestTargets = TestTargets {getTestTargets :: [Target]}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via [Target]+++-- | [tag:test_targets_invariant] Project a target list onto its test suites —+-- the only way to build a 'TestTargets', so the @test:@-only invariant holds by+-- construction.+projectTestTargets :: [Target] -> TestTargets+projectTestTargets = TestTargets . filter isTestTarget+ where+ isTestTarget (Qualified Test _) = True+ isTestTarget _ = False+++-- | Parse raw target strings (e.g. the @test_targets@ config) and project them+-- onto their test suites — non-test entries are dropped.+parseTestTargets :: [Text] -> TestTargets+parseTestTargets = projectTestTargets . map parseTarget+++-- | A cabal build target, parsed from its textual @[kind:]name@ form. Used to+-- resolve which source directories belong to a target.+data Target+ = -- | A @kind:name@ reference, e.g. @lib:foo@, @exe:foo@, @test:foo@. An+ -- empty name with 'Lib' (i.e. @lib:@) denotes the package's main library.+ Qualified ComponentKind Text+ | -- | A name with no @kind:@ prefix. Refers either to a package (all of its+ -- components) or to a single component matched by name.+ Bare Text+ | -- | A form we don't recognize: an unknown kind, or extra colons.+ Unrecognized Text+ deriving stock (Eq, Show)+++-- | The kind of cabal component a 'Qualified' target names. Covers every+-- component kind cabal models (matching @Distribution.Types.ComponentName@).+data ComponentKind = Lib | FLib | Exe | Test | Bench+ deriving stock (Bounded, Enum, Eq, Show)+++-- | [tag:kind_prefix_sole_source] The canonical prefix cabal uses for each+-- component kind. Single source of truth shared by 'parseTarget' and+-- 'renderTarget' — keep this the only place the prefix strings appear.+--+-- We deliberately model only these canonical prefixes, not cabal's full set of+-- aliases (@executable@, @test-suite@, …) or its case-folding. Those would mean+-- hand-mirroring an unexported, internally-inconsistent cabal table; instead an+-- aliased spelling falls to 'Unrecognized', which is still handed to cabal+-- verbatim for the build and still resolves watch dirs by matching its trailing+-- component name [ref:alias_name_match].+kindPrefix :: ComponentKind -> Text+kindPrefix = \case+ Lib -> "lib"+ FLib -> "flib"+ Exe -> "exe"+ Test -> "test"+ Bench -> "bench"+++-- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two+-- never drift apart [ref:kind_prefix_sole_source].+parseKind :: Text -> Maybe ComponentKind+parseKind = inverseMap kindPrefix+++-- | Classify a target's textual form. The grammar is @[kind:]name@ where+-- @kind@ is one of @lib@, @flib@, @exe@, @test@, or @bench@; anything else (an+-- unknown kind, a cabal alias such as @executable@, or extra colons) is+-- 'Unrecognized'.+parseTarget :: Text -> Target+parseTarget target = case T.splitOn ":" target of+ [prefix, name] | Just kind <- parseKind prefix -> Qualified kind name+ [name] -> Bare name+ _ -> Unrecognized target+++-- | Render a 'Target' back to the textual form cabal understands. Inverse of+-- 'parseTarget' (lossless: @parseTarget . renderTarget == id@). Builds prefixes+-- via 'kindPrefix' rather than hardcoding them [ref:kind_prefix_sole_source].+renderTarget :: Target -> Text+renderTarget = \case+ Qualified kind name -> kindPrefix kind <> ":" <> name+ Bare name -> name+ Unrecognized raw -> raw+++instance ToJSON Target where+ toJSON = toJSON . renderTarget+++instance FromJSON Target where+ parseJSON = fmap parseTarget . parseJSON+++newtype WatchDirs = WatchDirs {getWatchDirs :: [FilePath]}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via [FilePath]+++newtype WatchExclusionPatterns = WatchExclusionPatterns {getWatchExclusionPatterns :: [Pattern]}+ deriving stock (Eq, Generic, Show)+++newtype ReplBuildDir = ReplBuildDir {getReplBuildDir :: FilePath}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via FilePath+++newtype TestTimeout = TestTimeout {getTestTimeout :: Int}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via Int++ -- | Resolve the GHCi command, using config if set or autodetecting otherwise.-resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> Eff es Text-resolveCommand projectRoot cfg =+--+-- The @testTargets@ are the discovered @test:@ components; they are appended to+-- the auto-detected @all@ target (see 'detectCommand'). They are ignored when+-- the user has pinned an explicit @command@ or explicit @targets@ in config.+resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> TestTargets -> Eff es Command+resolveCommand projectRoot cfg targets testTargets = case cfg.command of- Just cmd -> pure cmd- Nothing -> detectCommand cfg.targets cfg.replBuildDir projectRoot+ Just cmd -> pure $ Command cmd+ Nothing -> detectCommand targets testTargets cfg.replBuildDir projectRoot -detectCommand :: (FileSystem :> es) => [Text] -> FilePath -> ProjectRoot -> Eff es Text-detectCommand targets replBuildDir (ProjectRoot projectRoot) = do+-- | Build the autodetected GHCi command.+--+-- Configured @targets@ are spelled out verbatim. Otherwise we use cabal's+-- catch-all @all@ plus the discovered @test:@ targets, because+-- @cabal repl --enable-multi-repl all@ omits test suites unless the project sets+-- @tests: True@ in @cabal.project@ — so test errors would go unnoticed.+--+-- We keep @all@ rather than enumerating every component: @all@ lets cabal order+-- the multi-repl units, and GHCi makes the /last/ unit the active one. If that+-- unit imports a custom @Prelude@ from a sibling home package, GHCi reports it+-- "not loaded" and the session dies — which a naive discovery-order enumeration+-- triggers but @all@ avoids. Appending already-included test targets is a no-op+-- (cabal deduplicates).+detectCommand :: (FileSystem :> es) => [Target] -> TestTargets -> FilePath -> ProjectRoot -> Eff es Command+detectCommand targets (TestTargets testTargets) replBuildDir (ProjectRoot projectRoot) = do hasCabalProject <- doesFileExist (projectRoot </> "cabal.project") cabalFiles <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory projectRoot hasStack <- doesFileExist (projectRoot </> "stack.yaml")- let targetStr = if null targets then "all" else unwords targets+ let targetStr+ | not (null targets) = unwords (map renderTarget targets)+ | otherwise = unwords ("all" : map renderTarget testTargets) buildDirFlag = "--builddir " <> toText replBuildDir <> " " pure if | hasCabalProject || not (null cabalFiles) ->- "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr- | hasStack -> "stack ghci " <> targetStr- | otherwise -> "cabal repl " <> buildDirFlag <> targetStr+ Command $ "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr+ | hasStack -> Command $ "stack ghci " <> targetStr+ | otherwise -> Command $ "cabal repl " <> buildDirFlag <> targetStr -- | Resolve the directories to watch.@@ -128,18 +291,18 @@ -- 1. @watch_dirs@ from config, if non-empty (used as-is relative to project root) -- 2. @hs-source-dirs@ inferred from cabal targets, if targets are set -- 3. Falls back to @["."]@ (project root) if neither is available-resolveWatchDirs :: (FileSystem :> es) => ProjectRoot -> [FilePath] -> Config -> [Text] -> Eff es [FilePath]+resolveWatchDirs :: (FileSystem :> es) => ProjectRoot -> [FilePath] -> Config -> [Target] -> Eff es WatchDirs resolveWatchDirs projectRoot cabalFiles cfg targets = case cfg.watchDirs of- dirs@(_ : _) -> pure $ map (coerce projectRoot </>) dirs+ dirs@(_ : _) -> pure $ WatchDirs $ map (coerce projectRoot </>) dirs [] -> resolveWatchDirsFromTargets cabalFiles targets -resolveWatchDirsFromTargets :: (FileSystem :> es) => [FilePath] -> [Text] -> Eff es [FilePath]-resolveWatchDirsFromTargets _ [] = pure ["."]+resolveWatchDirsFromTargets :: (FileSystem :> es) => [FilePath] -> [Target] -> Eff es WatchDirs+resolveWatchDirsFromTargets _ [] = pure $ WatchDirs ["."] resolveWatchDirsFromTargets cabalFiles targets = do dirs <- nub . concat <$> traverse watchDirsForCabal cabalFiles- pure $ if null dirs then ["."] else dirs+ pure $ WatchDirs $ if null dirs then ["."] else dirs where -- @hs-source-dirs@ are relative to the package's own directory, so scope -- them to the directory holding that package's @.cabal@. In a@@ -154,44 +317,111 @@ Just gpd -> map (pkgDir </>) (concatMap (sourceDirsForTarget gpd) targets) -sourceDirsForTarget :: GenericPackageDescription -> Text -> [FilePath]+sourceDirsForTarget :: GenericPackageDescription -> Target -> [FilePath] sourceDirsForTarget gpd target =- map getSymbolicPath $ case T.splitOn ":" target of- ["lib", ""] ->- maybe [] (libDirs . condTreeData) (condLibrary gpd)- ["lib", name] ->- let ucn = mkUnqualComponentName (toString name)- mainLibName = unPackageName . pkgName . package . packageDescription $ gpd- in if toString name == mainLibName then- maybe [] (libDirs . condTreeData) (condLibrary gpd)- else- concatMap (libDirs . condTreeData . snd) $ filter ((== ucn) . fst) (condSubLibraries gpd)- ["test", name] ->- let ucn = mkUnqualComponentName (toString name)- in concatMap (testDirs . condTreeData . snd) $ filter ((== ucn) . fst) (condTestSuites gpd)- ["exe", name] ->- let ucn = mkUnqualComponentName (toString name)- in concatMap (exeDirs . condTreeData . snd) $ filter ((== ucn) . fst) (condExecutables gpd)- _ -> []+ map getSymbolicPath $ case target of+ Qualified Lib "" -> mainLibSourceDirs+ Qualified Lib name+ | toString name == mainPkgName -> mainLibSourceDirs+ | otherwise -> subLibSourceDirs name+ Qualified FLib name -> flibSourceDirs name+ Qualified Exe name -> exeSourceDirs name+ Qualified Test name -> testSourceDirs name+ Qualified Bench name -> benchSourceDirs name+ -- A bare target (no @kind:@ prefix) is a package name or a component+ -- name. A package name covers every component; otherwise match a+ -- single component by name across the kinds.+ Bare name+ | toString name == mainPkgName -> allComponentSourceDirs+ | otherwise -> componentSourceDirsByName name+ -- [tag:alias_name_match] A form we couldn't parse into a kind — a cabal+ -- alias (@executable:@) or a case variant (@Lib:@). The kind is+ -- untrustworthy, but cabal component names are unique within a package,+ -- so we match the trailing name across every kind. This recovers precise+ -- watch dirs for aliased spellings; worst case we over-match a+ -- same-named component, never miss one. (The raw string is still handed+ -- to cabal verbatim for the build.)+ Unrecognized raw -> componentSourceDirsByName (T.takeWhileEnd (/= ':') raw) where- libDirs = hsSourceDirs . libBuildInfo- testDirs = hsSourceDirs . testBuildInfo- exeDirs = hsSourceDirs . buildInfo+ mainPkgName = unPackageName . pkgName . package . packageDescription $ gpd + -- @hs-source-dirs@ of any component, via the @HasBuildInfo@ lens — one+ -- accessor that works uniformly across libraries, foreign libs, exes,+ -- tests, and benchmarks, so we don't repeat a per-kind @buildInfo@ getter.+ componentDirs component = view Lens.hsSourceDirs component --- | Infer the effective targets to build and watch.--- Returns the configured targets as-is, or auto-detects all components across--- every discovered package when no targets are configured.-resolveTargets :: (FileSystem :> es) => [FilePath] -> [Text] -> Eff es [Text]-resolveTargets _ targets@(_ : _) = pure targets+ mainLibSourceDirs = maybe [] (componentDirs . condTreeData) (condLibrary gpd)+ subLibSourceDirs name = dirsForComponent (condSubLibraries gpd) name+ flibSourceDirs name = dirsForComponent (condForeignLibs gpd) name+ exeSourceDirs name = dirsForComponent (condExecutables gpd) name+ testSourceDirs name = dirsForComponent (condTestSuites gpd) name+ benchSourceDirs name = dirsForComponent (condBenchmarks gpd) name++ -- Match a component name across every kind. The main library is keyed by+ -- the package name rather than an unqualified component name, so it joins+ -- in only when @name@ is the package name.+ componentSourceDirsByName name =+ mainLibForName name+ <> subLibSourceDirs name+ <> flibSourceDirs name+ <> exeSourceDirs name+ <> testSourceDirs name+ <> benchSourceDirs name++ mainLibForName name+ | toString name == mainPkgName = mainLibSourceDirs+ | otherwise = []++ allComponentSourceDirs =+ mainLibSourceDirs+ <> concatMap (componentDirs . condTreeData . snd) (condSubLibraries gpd)+ <> concatMap (componentDirs . condTreeData . snd) (condForeignLibs gpd)+ <> concatMap (componentDirs . condTreeData . snd) (condExecutables gpd)+ <> concatMap (componentDirs . condTreeData . snd) (condTestSuites gpd)+ <> concatMap (componentDirs . condTreeData . snd) (condBenchmarks gpd)++ dirsForComponent components name =+ let ucn = mkUnqualComponentName (toString name)+ in concatMap (componentDirs . condTreeData . snd) $ filter ((== ucn) . fst) components+++-- | Infer the effective targets to build and watch. This is the boundary where+-- raw target strings (from config) are parsed into structured 'Target's: the+-- configured targets are parsed as-is, or all components across every+-- discovered package are auto-detected when no targets are configured. Either+-- way the result is sorted with 'compareTargets' so libraries come last+-- [ref:lib_sort_order].+resolveTargets :: (FileSystem :> es) => [FilePath] -> [Text] -> Eff es [Target]+resolveTargets _ targets@(_ : _) = pure $ sortBy compareTargets $ map parseTarget targets resolveTargets cabalFiles [] =- concat <$> traverse targetsFromCabal cabalFiles+ sortBy compareTargets . concat <$> traverse targetsFromCabal cabalFiles where targetsFromCabal path = do contents <- readFileBs path pure $ maybe [] allComponentTargets (parseGenericPackageDescriptionMaybe contents) +-- | [tag:lib_sort_order] When running @cabal repl <package defining custom+-- prelude> <other packages...>@, GHCi fails because it attempts to load the+-- provided @Prelude@ module before loading the package itself. This is not a+-- problem if the package defining the prelude module is not the first component+-- listed.+--+-- Because of this GHCi quirk, we sort all packages beginning with @lib:@ last.+-- This is based on the assumption that components defining custom preludes+-- usually reside in libraries. If we can then place at least one target that+-- does not specify a custom prelude a before targets that do, we will prevent+-- the user from being hit with this rather obscure error message.+compareTargets :: Target -> Target -> Ordering+compareTargets a b+ | isLib a && not (isLib b) = GT+ | not (isLib a) && isLib b = LT+ | otherwise = compare (renderTarget a) (renderTarget b)+ where+ isLib (Qualified Lib _) = True+ isLib _ = False++ -- | Locate every package's @.cabal@ file, logging what drove the result. In a -- multi-package project the packages live in subdirectories listed under -- @packages:@ in @cabal.project@; in a single-package project the @.cabal@@@ -250,30 +480,45 @@ fromLine (FieldLine _ bs) = map BC.unpack (BC.words bs) -allComponentTargets :: GenericPackageDescription -> [Text]+allComponentTargets :: GenericPackageDescription -> [Target] allComponentTargets gpd = mainLibTargets ++ subLibTargets+ ++ flibTargets ++ exeTargets ++ testTargets+ ++ benchTargets where mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd- mainLibTargets = maybe [] (const ["lib:" <> mainPkgName]) (condLibrary gpd)- subLibTargets = map (\(n, _) -> "lib:" <> toText (unUnqualComponentName n)) (condSubLibraries gpd)- exeTargets = map (\(n, _) -> "exe:" <> toText (unUnqualComponentName n)) (condExecutables gpd)- testTargets = map (\(n, _) -> "test:" <> toText (unUnqualComponentName n)) (condTestSuites gpd)+ mainLibTargets = maybe [] (const [Qualified Lib mainPkgName]) (condLibrary gpd)+ subLibTargets = map (\(n, _) -> Qualified Lib (componentName n)) (condSubLibraries gpd)+ flibTargets = map (\(n, _) -> Qualified FLib (componentName n)) (condForeignLibs gpd)+ exeTargets = map (\(n, _) -> Qualified Exe (componentName n)) (condExecutables gpd)+ testTargets = map (\(n, _) -> Qualified Test (componentName n)) (condTestSuites gpd)+ benchTargets = map (\(n, _) -> Qualified Bench (componentName n)) (condBenchmarks gpd)+ componentName = toText . unUnqualComponentName --- | Resolve which test suites to run after a clean build.------ When 'testTargets' is set in config, those suites are used directly.--- Otherwise, all @test:@ components in 'targets' are inferred.-resolveTestTargets :: Config -> [Text] -> [Text]+-- | Resolve which test suites to run after a clean build. Either source — the+-- explicit @test_targets@ config or the build 'targets' — is projected onto its+-- @test:@ components (see 'projectTestTargets'), so non-test entries are+-- dropped and the result only ever names test suites [ref:test_targets_invariant].+resolveTestTargets :: Config -> [Target] -> TestTargets resolveTestTargets cfg targets = case cfg.testTargets of- Just explicit -> explicit- Nothing -> filter ("test:" `T.isPrefixOf`) targets+ Just explicit -> parseTestTargets explicit+ Nothing -> projectTestTargets targets +resolveWatchExclusionPatterns :: [Text] -> Eff es WatchExclusionPatterns+resolveWatchExclusionPatterns rawPatterns = do+ either (throwIO . userError . show) (pure . WatchExclusionPatterns)+ $ traverse+ ( parseRegex+ . toString+ )+ rawPatterns++ loadSession :: ( FileSystem :> es , Log :> es@@ -287,16 +532,17 @@ let cfgFile = extractConfig @"session" @Config loadedCfg cabalFiles <- discoverCabalFiles projectRoot effectiveTargets <- resolveTargets cabalFiles cfgFile.targets- command <- resolveCommand projectRoot cfgFile- watchDirs <- resolveWatchDirs projectRoot cabalFiles cfgFile effectiveTargets let testTargets = resolveTestTargets cfgFile effectiveTargets+ command <- resolveCommand projectRoot cfgFile effectiveTargets testTargets+ watchDirs <- resolveWatchDirs projectRoot cabalFiles cfgFile effectiveTargets+ watchExclusionPatterns <- resolveWatchExclusionPatterns cfgFile.watchExclusionPatterns pure $ Session { targets = effectiveTargets , command , watchDirs+ , watchExclusionPatterns , testTargets- , outputFile = cfgFile.outputFile- , replBuildDir = cfgFile.replBuildDir- , testTimeout = cfgFile.testTimeout+ , replBuildDir = ReplBuildDir cfgFile.replBuildDir+ , testTimeout = TestTimeout cfgFile.testTimeout }
src/Tricorder/UI.hs view
@@ -7,18 +7,11 @@ import Atelier.Effects.Console (Console) import Atelier.Effects.Delay (Delay) import Atelier.Effects.File (File)-import Brick- ( App (..)- , attrMap- , attrName- , neverShowCursor- )+import Brick (App (..), neverShowCursor) import Brick.Keybindings (KeyConfig) import Effectful.Reader.Static (Reader, ask) import Atelier.Effects.Conc qualified as Conc-import Graphics.Vty.Attributes qualified as Attr-import Graphics.Vty.Attributes.Color qualified as Color import Tricorder.Effects.Brick (Brick) import Tricorder.Effects.BrickChan (BrickChan)@@ -28,7 +21,7 @@ import Tricorder.UI.Event (Event (..), handleEvent) import Tricorder.UI.Keys (KeyEvent, dispatcher) import Tricorder.UI.State (State (..), Viewports (..))-import Tricorder.UI.View (view)+import Tricorder.UI.View (mkAttrMap, view) import Tricorder.Effects.Brick qualified as Brick import Tricorder.Effects.BrickChan qualified as BrickChan@@ -74,16 +67,6 @@ { appDraw = view kc , appHandleEvent = handleEvent $ dispatcher kc , appStartEvent = pure ()- , appAttrMap =- const- ( attrMap- Attr.defAttr- [ (attrName "ok", Attr.withForeColor Attr.defAttr Color.green)- , (attrName "warning", Attr.withForeColor Attr.defAttr Color.yellow)- , (attrName "error", Attr.withForeColor Attr.defAttr Color.red)- , (attrName "emphasis", Attr.withStyle Attr.defAttr Attr.bold)- , (attrName "subtle", Attr.withForeColor Attr.defAttr $ Color.rgbColor @Int 148 148 148)- ]- )+ , appAttrMap = mkAttrMap , appChooseCursor = neverShowCursor }
src/Tricorder/UI/Keys.hs view
@@ -5,6 +5,7 @@ , dispatcher , viewKeybindings , mkKeyConfig+ , keybindForRoute ) where import Atelier.Effects.Console (Console)@@ -37,6 +38,7 @@ , onEvent , parseBindingList )+import Brick.Keybindings.KeyConfig (firstActiveBinding) import Brick.Keybindings.Pretty (ppBinding) import Brick.Widgets.Core (hBox) import Control.Monad.State (gets, modify)@@ -54,26 +56,28 @@ import Data.Text qualified as T import Tricorder.UI.Misc (warn)+import Tricorder.UI.Route (Route) import Tricorder.UI.State- ( ActiveView (..)- , State (..)+ ( State (..) , Viewports (..)- , currentView- , cycleTestView- , popView- , pushView+ , currentRoute+ , cycleTestFilter+ , navigate+ , viewToViewport ) +import Tricorder.UI.Route qualified as Route + -- When adding a new event here, also list it in the README under "Custom Key Bindings". data KeyEvent = ToggleDaemonInfoView- | Quit+ | ToggleHelp+ | CycleTestView | ExitView | ScrollUp | ScrollDown- | ToggleHelp- | CycleTestView+ | Quit deriving stock (Bounded, Enum, Eq, Ord, Show) @@ -93,24 +97,24 @@ keys = keyEvents [ ("toggle daemon info", ToggleDaemonInfoView)- , ("quit", Quit)+ , ("toggle help", ToggleHelp)+ , ("cycle test view", CycleTestView) , ("exit view", ExitView) , ("scroll up", ScrollUp) , ("scroll down", ScrollDown)- , ("toggle help", ToggleHelp)- , ("cycle test view", CycleTestView)+ , ("quit", Quit) ] bindings :: [(KeyEvent, [Binding])] bindings = [ (ToggleDaemonInfoView, [bind 'g'])- , (Quit, [bind 'q', ctrl 'c'])+ , (ToggleHelp, [bind 'h'])+ , (CycleTestView, [bind 't']) , (ExitView, [binding KEsc []]) , (ScrollUp, [binding KUp []]) , (ScrollDown, [binding KDown []])- , (ToggleHelp, [bind 'h'])- , (CycleTestView, [bind 't'])+ , (Quit, [bind 'q', ctrl 'c']) ] @@ -164,43 +168,41 @@ cfg [ onEvent ToggleDaemonInfoView "Toggle daemon info view" do modify \s ->- if currentView s == Just ViewDaemonInfo then- popView s+ if currentRoute s == Route.DaemonInfo then+ navigate Route.Main s else- pushView ViewDaemonInfo s- , onEvent Quit "Exit" do- halt- , onEvent ExitView "Exit or go back" do- stack <- gets (.viewStack)- if null stack then halt else modify popView- , onEvent ScrollUp "Scroll up" do- av <- gets currentView- unless (av == Just ViewHelp) do- let vp = case av of- Just (ViewTestResults _) -> TestViewport- _ -> DiagnosticViewport- vScrollBy (viewportScroll vp) (-1)- , onEvent ScrollDown "Scroll down" do- av <- gets currentView- unless (av == Just ViewHelp) do- let vp = case av of- Just (ViewTestResults _) -> TestViewport- _ -> DiagnosticViewport- vScrollBy (viewportScroll vp) 1+ navigate Route.DaemonInfo s , onEvent ToggleHelp "Toggle help" do modify \s ->- if currentView s == Just ViewHelp then- popView s+ if currentRoute s == Route.Help then+ navigate Route.Main s else- pushView ViewHelp s+ navigate Route.Help s , onEvent CycleTestView "Cycle test results view" do- modify \s -> case currentView s of- Just (ViewTestResults tv) ->- if tv == maxBound then- popView s+ modify \s -> case currentRoute s of+ Route.Tests ->+ if s.testFilter == maxBound then+ navigate Route.Main s {testFilter = minBound} else- pushView (ViewTestResults (cycleTestView tv)) (popView s)- _ -> pushView (ViewTestResults minBound) s+ s {testFilter = cycleTestFilter s.testFilter}+ _ -> navigate Route.Tests s+ , onEvent ExitView "Exit or go back" do+ gets (.route) >>= \case+ Route.Main -> halt+ _ -> modify $ navigate Route.Main+ , onEvent ScrollUp "Scroll up" do+ mvp <- gets (viewToViewport . currentRoute)+ case mvp of+ Just vp -> vScrollBy (viewportScroll vp) (-1)+ Nothing -> pure ()+ , onEvent ScrollDown "Scroll down" do+ mvp <- gets (viewToViewport . currentRoute)+ case mvp of+ Just vp ->+ vScrollBy (viewportScroll vp) 1+ Nothing -> pure ()+ , onEvent Quit "Exit" do+ halt ] where stringify =@@ -218,13 +220,21 @@ viewEventAndTriggers :: (Ord k, Show k) => KeyConfig k -> Text -> [EventTrigger k] -> Widget n-viewEventAndTriggers kc eventName trigger =+viewEventAndTriggers kc eventName triggers = hBox [ warn $ txt $ eventName <> ": "- , txt $ showBindings $ mconcat $ getBindings <$> trigger+ , txt $ showBindings $ mconcat $ getBindings <$> triggers ] where showBindings = T.intercalate ", " . fmap ppBinding . sort . toList getBindings = \case ByKey k -> Set.singleton k ByEvent e -> Set.fromList $ allActiveBindings kc e+++keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding+keybindForRoute kc = \case+ Route.Main -> Nothing+ Route.DaemonInfo -> firstActiveBinding kc ToggleDaemonInfoView+ Route.Help -> firstActiveBinding kc ToggleHelp+ Route.Tests -> firstActiveBinding kc CycleTestView
+ src/Tricorder/UI/Route.hs view
@@ -0,0 +1,20 @@+module Tricorder.UI.Route+ ( Route (..)+ , name+ ) where+++data Route+ = Main+ | Help+ | DaemonInfo+ | Tests+ deriving stock (Bounded, Enum, Eq)+++name :: Route -> Text+name = \case+ Main -> "Dashboard"+ Help -> "Help"+ DaemonInfo -> "Daemon info"+ Tests -> "Tests"
src/Tricorder/UI/State.hs view
@@ -2,13 +2,12 @@ ( Viewports (..) , State (..) , Processed (..)+ , TestFilter (..) , init- , ActiveView (..)- , TestView (..)- , currentView- , pushView- , popView- , cycleTestView+ , currentRoute+ , viewToViewport+ , cycleTestFilter+ , navigate ) where import Atelier.Effects.Clock (Clock, TimeZone)@@ -17,8 +16,11 @@ import Atelier.Effects.Clock qualified as Clock import Tricorder.BuildState (BuildState (..))+import Tricorder.UI.Route (Route) +import Tricorder.UI.Route qualified as Route + data Viewports = MainViewport | DiagnosticViewport@@ -29,41 +31,38 @@ data State = State { buildState :: Processed Text BuildState , timeZone :: TimeZone- , viewStack :: [ActiveView]+ , route :: Route+ , testFilter :: TestFilter } -data Processed e a- = Waiting- | Failure e- | Success a---data ActiveView- = ViewHelp- | ViewDaemonInfo- | ViewTestResults TestView- deriving stock (Eq)+data TestFilter = TestFilterAll | TestFilterFailedOnly+ deriving stock (Bounded, Enum, Eq) -data TestView = TestViewFailOnly | TestViewFull- deriving stock (Bounded, Enum, Eq)+cycleTestFilter :: TestFilter -> TestFilter+cycleTestFilter x = if x == maxBound then minBound else succ x -currentView :: State -> Maybe ActiveView-currentView = viaNonEmpty head . (.viewStack)+data Processed e a+ = Waiting+ | Failure e+ | Success a -pushView :: ActiveView -> State -> State-pushView v s = s {viewStack = v : s.viewStack}+currentRoute :: State -> Route+currentRoute = (.route) -popView :: State -> State-popView s = s {viewStack = drop 1 s.viewStack}+viewToViewport :: Route -> Maybe Viewports+viewToViewport = \case+ Route.Tests -> Just TestViewport+ Route.Main -> Just DiagnosticViewport+ _ -> Nothing -cycleTestView :: TestView -> TestView-cycleTestView v = if v == maxBound then minBound else succ v+navigate :: Route -> State -> State+navigate route s = s {route} init :: (Clock :> es) => Eff es State@@ -73,5 +72,6 @@ State { buildState = Waiting , timeZone = tz- , viewStack = []+ , route = Route.Main+ , testFilter = minBound }
src/Tricorder/UI/View.hs view
@@ -1,22 +1,23 @@-module Tricorder.UI.View (view) where+module Tricorder.UI.View (mkAttrMap, view) where import Atelier.Effects.Clock (TimeZone) import Atelier.Time (Millisecond, toMicroseconds) import Brick- ( AttrName+ ( AttrMap+ , AttrName , VScrollBarOrientation (..) , ViewportType (..) , Widget+ , attrMap , attrName , vBox , viewport )-import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList)+import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList, ppBinding) import Brick.Widgets.Core ( Padding (..) , emptyWidget , hBox- , padBottom , padLeft , txt , txtWrap@@ -29,6 +30,8 @@ import System.FilePath (isAbsolute) import Data.Text qualified as T+import Graphics.Vty.Attributes qualified as Attr+import Graphics.Vty.Attributes.Color qualified as Color import Tricorder.BuildState ( BuildPhase (..)@@ -44,29 +47,89 @@ , TestRunCompletion (..) , TestRunError (..) )+import Tricorder.Session (Target, renderTarget) import Tricorder.TestOutput (stripGhciNoise)-import Tricorder.UI.Keys (KeyEvent, viewKeybindings)+import Tricorder.UI.Keys (KeyEvent, keybindForRoute, viewKeybindings) import Tricorder.UI.Misc (emphasis, err, hBoxSpaced, ok, subtle, vBoxSpaced, warn)-import Tricorder.UI.State (ActiveView (..), Processed (..), State (..), TestView (..), Viewports (..), currentView)+import Tricorder.UI.Route (Route)+import Tricorder.UI.State (Processed (..), State (..), TestFilter (..), Viewports (..), currentRoute) import Tricorder.UI.Keys qualified as Keys+import Tricorder.UI.Route qualified as Route import Tricorder.Version qualified as Version +mkAttrMap :: State -> AttrMap+mkAttrMap =+ const+ ( attrMap+ Attr.defAttr+ [ (attrName "ok", Attr.withForeColor Attr.defAttr Color.green)+ , (attrName "warning", Attr.withForeColor Attr.defAttr Color.yellow)+ , (attrName "error", Attr.withForeColor Attr.defAttr Color.red)+ , (attrName "emphasis", Attr.withStyle Attr.defAttr Attr.bold)+ , (attrName "subtle", Attr.withForeColor Attr.defAttr $ Color.rgbColor @Int 148 148 148)+ ]+ )++ view :: KeyConfig KeyEvent -> State -> [Widget Viewports] view kc ws =- [ case currentView ws of- Just ViewHelp ->- viewHelp kc- Just ViewDaemonInfo ->- withHint $ withBuildState ws (viewDaemonInfoPanel ws.timeZone)- Just (ViewTestResults tv) ->- withHint $ withBuildState ws (viewTestResultsPanel ws.timeZone tv)- Nothing ->- withHint $ withBuildState ws (viewDefaultPanel ws.timeZone)+ [ vBoxSpaced+ 1+ [ vBox+ [ viewAppHeader ws+ , viewTabs kc ws+ ]+ , case currentRoute ws of+ Route.Help ->+ viewHelp kc+ Route.DaemonInfo ->+ viewDaemonInfo ws+ Route.Tests ->+ viewTests ws+ Route.Main ->+ viewMain ws+ ] ] +viewTabs :: KeyConfig KeyEvent -> State -> Widget n+viewTabs kc ws =+ hBoxSpaced 1+ $ intersperse (subtle $ txt "-")+ $ viewRouteTab kc ws <$> universe @Route+++viewRouteTab :: KeyConfig KeyEvent -> State -> Route -> Widget n+viewRouteTab kc ws route =+ style $ txt $ Route.name route <> keyBind+ where+ style = if route == currentRoute ws then id else subtle+ showBinding = (" " <>) . ("[" <>) . (<> "]") . ppBinding+ keyBind = maybe "" showBinding $ keybindForRoute kc route+++viewDaemonInfo :: State -> Widget Viewports+viewDaemonInfo ws =+ withBuildState ws (viewExpandedDaemonInfo . (.daemonInfo))+++viewTests :: State -> Widget Viewports+viewTests ws =+ withBuildState ws (viewTestResultsPanel ws)+++viewMain :: State -> Widget Viewports+viewMain ws = withBuildState ws (viewDefaultPanel ws.timeZone)+++viewHelp :: KeyConfig KeyEvent -> Widget n+viewHelp kc = viewKeybindings kc handlers+ where+ handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher kc)++ withBuildState :: State -> (BuildState -> Widget Viewports) -> Widget Viewports withBuildState ws render = case ws.buildState of@@ -78,46 +141,41 @@ render bs -withHint :: Widget n -> Widget n-withHint content = vBox [padBottom Max content, viewHint]+viewAppHeader :: State -> Widget n+viewAppHeader ws =+ ok+ $ emphasis+ $ txt+ $ "Tricorder"+ <> maybe+ ""+ (" - " <>)+ (viewHeading ws) -viewHelp :: KeyConfig KeyEvent -> Widget n-viewHelp kc =- vBox- [ padBottom Max $ vBoxSpaced 1 [ok $ txt "Keymap:", viewKeybindings kc handlers]- , subtle $ txt "Press 'h' to go back"- ]- where- handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher kc)+viewHeading :: State -> Maybe Text+viewHeading ws = case currentRoute ws of+ Route.Tests -> case ws.testFilter of+ TestFilterAll -> Just "Tests"+ TestFilterFailedOnly -> Just "Tests - Failed only"+ Route.Help -> Just "Help"+ Route.DaemonInfo -> Just "Daemon info"+ Route.Main -> Nothing viewDefaultPanel :: TimeZone -> BuildState -> Widget Viewports viewDefaultPanel tz bs = viewBuildPhase tz bs.phase -viewDaemonInfoPanel :: TimeZone -> BuildState -> Widget Viewports-viewDaemonInfoPanel tz bs =- vBoxSpaced- 1- [ viewBuildPhaseLine tz bs.phase- , viewExpandedDaemonInfo bs.daemonInfo- ]---viewTestResultsPanel :: TimeZone -> TestView -> BuildState -> Widget Viewports-viewTestResultsPanel tz tv bs =+viewTestResultsPanel :: State -> BuildState -> Widget Viewports+viewTestResultsPanel ws bs = vBoxSpaced 1- [ viewBuildPhaseLine tz bs.phase- , viewTestPanel tv (phaseTestRuns bs.phase)+ [ viewBuildPhaseLine ws.timeZone bs.phase+ , viewTestPanel ws.testFilter (phaseTestRuns bs.phase) ] -viewHint :: Widget n-viewHint = subtle $ txt "Press 'h' for help"-- viewExpandedDaemonInfo :: DaemonInfo -> Widget n viewExpandedDaemonInfo di = vBox@@ -139,7 +197,7 @@ ] -viewTargets :: [Text] -> Widget n+viewTargets :: [Target] -> Widget n viewTargets targets = hBoxSpaced 1@@ -147,7 +205,7 @@ , if null targets then txt "(all)" else- txtWrap (T.intercalate " " targets)+ txtWrap (T.intercalate " " (map renderTarget targets)) ] @@ -363,32 +421,32 @@ phaseTestRuns _ = [] -viewTestPanel :: TestView -> [TestRun] -> Widget Viewports+viewTestPanel :: TestFilter -> [TestRun] -> Widget Viewports viewTestPanel _ [] = subtle $ txt "No test results."-viewTestPanel tv runs = scrollableRuns tv runs+viewTestPanel tvf runs = scrollableRuns tvf runs -scrollableRuns :: TestView -> [TestRun] -> Widget Viewports-scrollableRuns tv runs =- vScrollViewport TestViewport (viewTestRunDetail tv <$> runs)+scrollableRuns :: TestFilter -> [TestRun] -> Widget Viewports+scrollableRuns tvf runs =+ vScrollViewport TestViewport (viewTestRunDetail tvf <$> runs) -viewTestRunDetail :: TestView -> TestRun -> Widget n+viewTestRunDetail :: TestFilter -> TestRun -> Widget n viewTestRunDetail _ (TestRunning t Nothing) = hBox [txt t, txt " ", warn $ txt "running..."] viewTestRunDetail _ (TestRunning t (Just p)) = hBox [txt t, txt " ", warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"] viewTestRunDetail _ (TestRunErrored e) = hBoxSpaced 1 [txt e.target, err $ txt "error:", txt e.message]-viewTestRunDetail tv (TestRunCompleted c) =+viewTestRunDetail tvf (TestRunCompleted c) = vBox [ hBox [txt c.target, txt " ", viewCompletionStatus c]- , viewTestOutput tv c+ , viewTestOutput tvf c ] -viewTestOutput :: TestView -> TestRunCompletion -> Widget n-viewTestOutput TestViewFull c =+viewTestOutput :: TestFilter -> TestRunCompletion -> Widget n+viewTestOutput TestFilterAll c = padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output)-viewTestOutput TestViewFailOnly c+viewTestOutput TestFilterFailedOnly c | not (any isCaseFailed c.testCases) && c.passed = emptyWidget | null c.testCases = padLeft (Pad 2)
src/Tricorder/Watcher.hs view
@@ -1,7 +1,9 @@ module Tricorder.Watcher ( component , WatchedFile (..)+ , WatcherSession (..) , isCabalFile+ , makeWatches , markWatchedFiles ) where @@ -23,6 +25,8 @@ import Effectful.Concurrent (Concurrent) import Effectful.Reader.Static (Reader, ask) import System.FilePath (takeExtension, takeFileName)+import Text.Regex.TDFA (ExecOption (..), blankCompOpt, blankExecOpt, match)+import Text.Regex.TDFA.TDFA (patternToRegex) import Atelier.Effects.Publishing qualified as Sub @@ -34,7 +38,7 @@ import Tricorder.Effects.BuildStore (BuildStore) import Tricorder.Effects.SessionStore (SessionStore, SessionStoreReloaded) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (Session (..))+import Tricorder.Session (Pattern, Session (..), WatchDirs (..), WatchExclusionPatterns (..)) import Tricorder.Effects.BuildStore qualified as BuildStore import Tricorder.Effects.SessionStore qualified as SessionStore@@ -90,7 +94,8 @@ data WatcherSession = WatcherSession- { watchDirs :: [FilePath]+ { watchDirs :: WatchDirs+ , watchExclusionPatterns :: WatchExclusionPatterns } deriving stock (Eq) @@ -106,7 +111,11 @@ -> (SessionStore.Reloader es -> WatcherSession -> Eff es Void) -> Eff es Void withWatcherSession =- SessionStore.withSubSession $ WatcherSession . (.watchDirs)+ SessionStore.withSubSession $ \session ->+ WatcherSession+ { watchDirs = session.watchDirs+ , watchExclusionPatterns = session.watchExclusionPatterns+ } watchFiles@@ -125,12 +134,31 @@ initialSession <- SessionStore.get withWatcherSession initialSession $ \_ session -> do projectRoot <- ask- let watches = sourceWatches session.watchDirs <> cabalWatches projectRoot+ let watches = makeWatches projectRoot session watchFilePathsDebounced watches \filePath fileEvent -> publish (WatchedFile filePath fileEvent) -sourceWatches :: [FilePath] -> [Watch]-sourceWatches = map (\d -> dirExt d ".hs" `excluding` containing "dist-newstyle")+makeWatches :: ProjectRoot -> WatcherSession -> [Watch]+makeWatches projectRoot session =+ sourceWatches (coerce session.watchExclusionPatterns) (coerce session.watchDirs)+ <> cabalWatches projectRoot+++sourceWatches :: [Pattern] -> [FilePath] -> [Watch]+sourceWatches exclusionPatterns =+ map \d ->+ dirExt d ".hs"+ `excluding` containing "dist-newstyle"+ `excluding` exclusionMatches exclusionPatterns+++exclusionMatches :: [Pattern] -> FilePath -> Bool+exclusionMatches exclusionPatterns fp = any matchPattern exclusionPatterns+ where+ matchPattern p =+ match+ (patternToRegex p blankCompOpt blankExecOpt {captureGroups = False})+ fp cabalWatches :: ProjectRoot -> [Watch]
test/Unit/Tricorder/BuilderSpec.hs view
@@ -62,11 +62,13 @@ , fileMatchesAnyTarget , filterToWatchDirs , mergeDiagnostics+ , preserveFailureVisibility ) import Tricorder.Effects.GhciSession (Controls (..), LoadResult (..), LoadedModule (..), runGhciSessionScripted)-import Tricorder.Effects.GhciSession.GhciParser (extractTitle, resolveKnownTargets)+import Tricorder.Effects.GhciSession.GhciParser (collectResult, extractTitle, resolveKnownTargets) import Tricorder.Effects.TestRunner (TestRunner (..), runTestRunnerScripted) import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Command (..), WatchDirs (..), parseTestTargets) import Tricorder.BuildState qualified as BuildState import Tricorder.Builder qualified as Builder@@ -246,6 +248,19 @@ (SourceChangeDetected "/abs/src/Foo.hs" Modified) buildResultsFrom phases `shouldMatchList` [resultFor reloadLr] + -- A failed executable 'Main' appears in :show targets only as its+ -- path ("app/Main.hs", since the name 'Main' is ambiguous across home+ -- units), so dispatch must match that path form to Reload, not :add.+ describe "when the file is a path-shaped target that failed on initial load" do+ it "calls controls.reload, not controls.add" do+ phases <-+ runTest+ Map.empty+ (KnownTargetNames (Set.singleton "app/Main.hs"))+ distinctCtrls+ (SourceChangeDetected "/abs/app/Main.hs" Modified)+ buildResultsFrom phases `shouldMatchList` [resultFor reloadLr]+ describe "Added" do describe "when the file is not loaded" $ it "calls controls.add" do phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Added)@@ -433,27 +448,27 @@ runPureEff . runReader (ProjectRoot "/") . runState (emptyBuilderState {diagnosticMap = acc})- $ compileLoadResultsIntoBuildResults (def {Builder.watchDirs = ["/src"]}) nlr+ $ compileLoadResultsIntoBuildResults (def {Builder.watchDirs = WatchDirs ["/src"]}) nlr in (builderState.diagnosticMap, buildResult) testRequestTestRunsForNewBuildResults :: Spec testRequestTestRunsForNewBuildResults = do describe "when there are no test targets" $ it "should skip testing" do- phases <- runTest [] [] expected+ phases <- runTest (parseTestTargets []) [] expected length phases `shouldBe` 1 phases `shouldMatchList` [EnteringNewPhase (BuildId 1) $ Done expected] describe "when there are errors" $ it "should skip testing" do let expected' = expected {BuildState.diagnostics = [errMsg]}- phases <- runTest ["test:foo"] [] expected'+ phases <- runTest (parseTestTargets ["test:foo"]) [] expected' length phases `shouldBe` 1 phases `shouldMatchList` [EnteringNewPhase (BuildId 1) $ Done expected'] it "should emit EnteringNewPhase events for each test target" do phases <- runTest- ["test:foo", "test:bar"]+ (parseTestTargets ["test:foo", "test:bar"]) [ Right $ mkTestRun "test:foo" , Right $ mkTestRun "test:bar" ]@@ -496,10 +511,10 @@ . runTestRunnerAbortAfterFirst (mkTestRun "test:foo") $ requestTestRunsForNewBuildResults BuildConfig- { command = ""+ { command = Command "" , targets = []- , testTargets = ["test:foo", "test:bar"]- , watchDirs = []+ , testTargets = parseTestTargets ["test:foo", "test:bar"]+ , watchDirs = WatchDirs [] } expected -- The critical assertion: no Done phase, because the run was@@ -521,7 +536,12 @@ . runBuildStoreCapture . runTestRunnerScripted script $ requestTestRunsForNewBuildResults- BuildConfig {command = "", targets = [], testTargets, watchDirs = []}+ BuildConfig+ { command = Command ""+ , targets = []+ , testTargets+ , watchDirs = WatchDirs []+ } partial mkPhase = EnteringNewPhase (BuildId 1)@@ -658,7 +678,27 @@ "./src/Foo/Bar.lhs" `shouldBe` True + -- GHCi renders a target whose module name is ambiguous across home units+ -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs".+ it "matches a path-shaped target on directory-segment boundaries" do+ fileMatchesAnyTarget+ (KnownTargetNames (Set.singleton "app/Main.hs"))+ "./tricorder/app/Main.hs"+ `shouldBe` True + it "does not match a path-shaped target on a partial segment" do+ fileMatchesAnyTarget+ (KnownTargetNames (Set.singleton "pp/Main.hs"))+ "./tricorder/app/Main.hs"+ `shouldBe` False++ it "does not match a path-shaped target for a different file" do+ fileMatchesAnyTarget+ (KnownTargetNames (Set.singleton "daemon/Main.hs"))+ "./tricorder/app/Main.hs"+ `shouldBe` False++ -------------------------------------------------------------------------------- -- mergeDiagnostics tests --------------------------------------------------------------------------------@@ -720,7 +760,38 @@ let merged = mergeDiagnostics Map.empty result Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg] + describe "when the cycle reports none" $ it "clears a stale location-less diagnostic" do+ -- <no location info> is never in compiledFiles, so without special+ -- handling it would persist forever. A cycle with no location-less+ -- diagnostic must evict it.+ let noLoc = errMsg {file = "<no location info>"}+ prev = Map.fromList [(noLoc.file, [noLoc])]+ result =+ LoadResult+ { moduleCount = 1+ , compiledFiles = Set.singleton errMsg.file+ , loadedModules = Map.empty+ , targetNames = []+ , diagnostics = []+ }+ let merged = mergeDiagnostics prev result+ Map.lookup noLoc.file merged `shouldBe` Nothing + it "refreshes a location-less diagnostic that is still present" do+ let noLoc = errMsg {file = "<no location info>"}+ prev = Map.fromList [(noLoc.file, [noLoc])]+ result =+ LoadResult+ { moduleCount = 1+ , compiledFiles = Set.empty+ , loadedModules = Map.empty+ , targetNames = []+ , diagnostics = [noLoc]+ }+ let merged = mergeDiagnostics prev result+ Map.lookup noLoc.file merged `shouldBe` Just [noLoc]++ -------------------------------------------------------------------------------- -- filterToWatchDirs tests --------------------------------------------------------------------------------@@ -728,7 +799,7 @@ testFilterToWatchDirs :: Spec testFilterToWatchDirs = do let root = "/project"- watchDirs = ["/project/src"]+ watchDirs = WatchDirs ["/project/src"] it "keeps diagnostics under a watched directory" do -- ./src/Foo.hs is what toRelative produces for an absolute project file@@ -750,16 +821,47 @@ -- A mangled path joined onto projectRoot would incorrectly start with -- projectRoot+"/", so this case requires an explicit guard. let d = errMsg {file = "In file included from src/Foo.hs"}- filterToWatchDirs root ["."] [d] `shouldBe` []+ filterToWatchDirs root (WatchDirs ["."]) [d] `shouldBe` [] it "passes everything through when watchDirs is empty" do let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}- filterToWatchDirs root [] [d] `shouldBe` [d]+ filterToWatchDirs root (WatchDirs []) [d] `shouldBe` [d] it "works with the '.' fallback watch dir (whole project root)" do let d = errMsg {file = "./src/Foo.hs"} nixD = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}- filterToWatchDirs root ["."] [d, nixD] `shouldBe` [d]+ filterToWatchDirs root (WatchDirs ["."]) [d, nixD] `shouldBe` [d]++ describe "when diagnostic has no path it" $ it "keeps location-less <no location info> errors" do+ -- A home-unit GHC plugin that can't load under --enable-multi-repl+ -- produces a <no location info> error. It has no path to test against a+ -- watch dir, but must survive or the failed build reads as clean.+ let d = errMsg {file = "<no location info>"}+ filterToWatchDirs root watchDirs [d] `shouldBe` [d]++ it "does not treat a real <-prefixed path as a location-less marker" do+ -- isLocationLess requires a closing '>'. A real (if exotic) path that+ -- merely starts with '<' is an ordinary out-of-watch file and must be+ -- dropped, not kept as a build-level marker.+ let d = errMsg {file = "<generated>/Foo.hs"}+ filterToWatchDirs root watchDirs [d] `shouldBe` []++ describe "when its only error is out of watch dirs" $ it "a failed load does not read as clean" do+ -- collectResult only injects its synthetic failure when no SError is+ -- present. Here GHCi Failed with a single *located* error in a file+ -- outside the watch dirs, so collectResult adds no synthetic — and then+ -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The+ -- Builder pipeline composes preserveFailureVisibility after filtering to+ -- re-attach the failure, so a failed build never survives with zero+ -- diagnostics.+ let reloadOutput =+ [ "/other/Dep.hs:5:1: error: boom"+ , "Failed, 0 modules loaded."+ ]+ result = collectResult root reloadOutput [] []+ filtered = filterToWatchDirs root watchDirs result.diagnostics+ preserveFailureVisibility result.diagnostics filtered+ `shouldSatisfy` (not . null) --------------------------------------------------------------------------------
test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs view
@@ -2,12 +2,17 @@ import Test.Hspec +import Tricorder.BuildState (Diagnostic (..), Severity (..)) import Tricorder.Effects.GhciSession.GhciParser ( GhciLoad (..) , GhciLoading (..) , GhciMessage (..) , GhciSeverity (..)+ , LoadOutcome (..)+ , LoadResult (..) , Position (..)+ , collectResult+ , collectResultCustom , parseReload , parseShowModules , parseShowTargets@@ -29,7 +34,13 @@ describe "parseShowTargets" testShowTargets + describe "collectResultCustom" do+ describe "<no location info> plugin load failure" testPluginLoadFailure + describe "collectResult" do+ describe "failed load with no located error" testUnattributedFailure++ -------------------------------------------------------------------------------- -- parseReload: clean build --------------------------------------------------------------------------------@@ -47,6 +58,7 @@ `shouldBe` [ GLoading GhciLoading {index = 1, total = 3, moduleName = "Tricorder.BuildState", sourceFile = "src/Tricorder/BuildState.hs"} , GLoading GhciLoading {index = 2, total = 3, moduleName = "Tricorder.Session", sourceFile = "src/Tricorder/Session.hs"} , GLoading GhciLoading {index = 3, total = 3, moduleName = "Main", sourceFile = "app/Main.hs"}+ , GSummary LoadSucceeded ] it "handles padded module index (e.g. [ 1 of 47])" do@@ -54,10 +66,13 @@ [ "[ 1 of 47] Compiling Main ( app/Main.hs, interpreted )" , "Ok, 1 module loaded." ]- parseReload input `shouldBe` [GLoading GhciLoading {index = 1, total = 47, moduleName = "Main", sourceFile = "app/Main.hs"}]+ parseReload input+ `shouldBe` [ GLoading GhciLoading {index = 1, total = 47, moduleName = "Main", sourceFile = "app/Main.hs"}+ , GSummary LoadSucceeded+ ] - describe "when only summary line" $ it "returns empty list" do- parseReload ["Ok, 0 modules loaded."] `shouldBe` []+ describe "when only summary line" $ it "returns the summary outcome" do+ parseReload ["Ok, 0 modules loaded."] `shouldBe` [GSummary LoadSucceeded] --------------------------------------------------------------------------------@@ -142,7 +157,7 @@ parseReload input `shouldBe` [GMessage GhciMessage {severity = GError, file = "C:\\path\\file.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]}] - it "parses mixed Loading and Message items, discarding summary" do+ it "parses mixed Loading, Message, and summary items" do let input = [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )" , "src/Lib.hs:5:1: error: Oops"@@ -153,6 +168,7 @@ `shouldBe` [ GLoading GhciLoading {index = 1, total = 2, moduleName = "Lib", sourceFile = "src/Lib.hs"} , GMessage GhciMessage {severity = GError, file = "src/Lib.hs", startPos = Position 5 1, endPos = Position 5 1, messageLines = ["src/Lib.hs:5:1: error: Oops"]} , GLoading GhciLoading {index = 2, total = 2, moduleName = "Main", sourceFile = "app/Main.hs"}+ , GSummary LoadFailed ] @@ -180,11 +196,12 @@ , " Perhaps you meant: 'bar'" ] }+ , GSummary LoadFailed ] - describe "when all modules are already up to date" $ it "returns empty list" do+ describe "when all modules are already up to date" $ it "returns the summary outcome" do -- GHCi with -fhide-source-paths and nothing to recompile- parseReload ["Ok, 5 modules loaded."] `shouldBe` []+ parseReload ["Ok, 5 modules loaded."] `shouldBe` [GSummary LoadSucceeded] --------------------------------------------------------------------------------@@ -240,6 +257,7 @@ parseReload input `shouldBe` [ GLoadConfig ".ghci" , GLoading GhciLoading {index = 1, total = 1, moduleName = "Main", sourceFile = "app/Main.hs"}+ , GSummary LoadSucceeded ] @@ -311,3 +329,93 @@ it "returns empty list for empty input" do parseShowTargets [] `shouldBe` []+++--------------------------------------------------------------------------------+-- collectResultCustom: <no location info> plugin load failure+--------------------------------------------------------------------------------++-- | Regression test for the \"All good\" bug with home-unit GHC plugins.+--+-- Under @cabal repl --enable-multi-repl@ every unit is interpreted, so a+-- package used as a GHC plugin in the same project is not available as a+-- compiled plugin. The unit that depends on it fails to load, GHCi reports the+-- failure with @\<no location info\>@ (it has no source span), and the load+-- ends with @Failed, N modules loaded@. This output must still surface as an+-- error diagnostic — otherwise the build is silently reported as clean.+testPluginLoadFailure :: Spec+testPluginLoadFailure = do+ -- Shape of the GHCi output from `cabal repl --enable-multi-repl` when an+ -- executable loads a home-unit GHC plugin: the plugin package's modules+ -- compile, then the unit using the plugin fails with a location-less error.+ let reloadOutput =+ [ "[3 of 5] Compiling My.Plugin ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]"+ , "<no location info>: error:"+ , " Could not load module \8216My.Plugin\8217."+ , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217."+ , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file."+ , "Use -v to see a list of the files searched for."+ , ""+ , "[5 of 5] Compiling Main ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]"+ , "Failed, 4 modules loaded."+ ]+ result = collectResultCustom "/project" (parseReload reloadOutput) [] []++ it "surfaces the plugin load failure as an error diagnostic" do+ map (.severity) result.diagnostics `shouldContain` [SError]++ it "carries the plugin error message in the diagnostic title" do+ map (.title) result.diagnostics+ `shouldContain` ["Could not load module \8216My.Plugin\8217."]+++--------------------------------------------------------------------------------+-- collectResult: failed load with no located error+--------------------------------------------------------------------------------++-- 'collectResult' is the safety net: GHCi can end a load with @Failed, …@+-- without emitting any error that carries a source span. The build must never+-- read as clean in that case, so a synthetic error diagnostic is added.+testUnattributedFailure :: Spec+testUnattributedFailure = do+ describe "when the load failed but no error was located" $ it "adds a synthetic error" do+ let reloadOutput =+ [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )"+ , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )"+ , "Failed, 1 module loaded."+ ]+ result = collectResult "/project" reloadOutput [] []+ map (.severity) result.diagnostics `shouldBe` [SError]++ it "does not duplicate a failure that already produced a located error" do+ let reloadOutput =+ [ "[1 of 1] Compiling Lib ( src/Lib.hs, interpreted )"+ , "src/Lib.hs:5:1: error: Oops"+ , "Failed, 0 modules loaded."+ ]+ result = collectResult "/project" reloadOutput [] []+ -- Only the real, located diagnostic — no synthetic one appended.+ map (.file) result.diagnostics `shouldBe` ["src/Lib.hs"]++ it "adds nothing for a successful load" do+ let reloadOutput =+ [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"+ , "Ok, 1 module loaded."+ ]+ result = collectResult "/project" reloadOutput [] []+ result.diagnostics `shouldBe` []++ describe "when 'Failed,' appears off the summary line" $ it "does not flag a clean build" do+ -- The load outcome lives on GHCi's single summary line+ -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a+ -- Template Haskell splice or top-level IO run while interpreting — can+ -- contain a line that happens to begin with "Failed,". That must not be+ -- mistaken for a failed load: the summary here is "Ok," so no synthetic+ -- error belongs.+ let reloadOutput =+ [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"+ , "Failed, retrying with fallback" -- printed by a TH splice+ , "Ok, 1 module loaded."+ ]+ result = collectResult "/project" reloadOutput [] []+ result.diagnostics `shouldBe` []
test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs view
@@ -3,21 +3,27 @@ import Atelier.Effects.Conc (runConc) import Atelier.Effects.Delay (runDelay) import Atelier.Effects.File (runFile)-import Atelier.Effects.Process (runProcessIO)+import Atelier.Effects.Process (runProcessIO, terminateProcessGroup, withProcessGroup)+import Atelier.Effects.Process.Internal (RunningProcess (..)) import Atelier.Effects.Timeout (runTimeout) import Atelier.Time (Millisecond)+import Control.Concurrent (threadDelay) import Control.Concurrent.STM (newTVarIO)-import Control.Exception (catch)+import Control.Exception (IOException, catch)+import Data.Char (isDigit) import Data.IORef (newIORef, readIORef, writeIORef) import Data.Time.Units (Second) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.Exception (trySync)+import System.IO (hGetLine)+import System.Posix.Signals (nullSignal, sigKILL, signalProcess) import System.Process.Typed ( createPipe , getStderr , getStdin , getStdout+ , setCreateGroup , setStderr , setStdin , setStdout@@ -31,8 +37,10 @@ import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Delay qualified as Delay import Atelier.Effects.File qualified as File+import Atelier.Effects.Process qualified as AProc import Data.Text qualified as T import System.Process qualified as Process+import System.Timeout qualified import Tricorder.Effects.GhciSession.GhciProcess ( GhciProcess (..)@@ -52,6 +60,8 @@ describe "execGhci (stale marker desync)" testExecGhciStaleMarker describe "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent describe "waitForBannerOrFail" testWaitForBannerOrFail+ describe "withProcessGroup (process group)" testWithProcessGroupCleanup+ describe "terminateProcessGroup (process group)" testTerminateProcessGroup -- | Regression for the touch-during-reload desync. Interrupting a *Busy* GHCi@@ -81,7 +91,7 @@ { stdin = stdinW , stdout = stdoutR , stderr = stderrR- , handle = p+ , handle = RunningProcess p , stateVar } -- Mirrors 'markerFor': "#~TRI-FINISH-<n>~#".@@ -139,7 +149,7 @@ { stdin = stdinW , stdout = stdoutR , stderr = stderrR- , handle = p+ , handle = RunningProcess p , stateVar } marker = "#~TRI-FINISH-9~#" :: Text@@ -182,17 +192,8 @@ it "captures the full stderr output when the command exits before the banner" do let lineCount = 200 :: Int lastLine = "err line " <> show lineCount- -- 'true' exits immediately. We only need it for the 'Process' handle- -- that 'waitForBannerOrFail' stops on the failure path; the banner and- -- error streams are pipes we drive ourselves, so the timing is- -- deterministic rather than a race against the OS pipe buffer.- p <-- startProcess- $ setStdin createPipe- $ setStdout createPipe- $ setStderr createPipe- $ shell "true"- _ <- waitExitCode p+ -- The banner and error streams are pipes we drive ourselves, so the+ -- timing is deterministic rather than a race against the OS pipe buffer. (bannerOut, bannerOutW) <- Process.createPipe (errR, errW) <- Process.createPipe result <-@@ -202,7 +203,6 @@ . runDelay . runFile . runConc- . runProcessIO $ do -- No banner will ever arrive: close the write end so the -- wait sees EOF at once and takes the "command exited"@@ -217,8 +217,7 @@ for_ [1 .. lineCount] \i -> File.hPutTextLn errW ("err line " <> show i :: Text) File.hClose errW- trySync (waitForBannerOrFail (5 :: Second) bannerOut errR p)- _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())+ trySync (waitForBannerOrFail (5 :: Second) bannerOut errR) case result of Right () -> expectationFailure "expected waitForBannerOrFail to throw a startup error" Left ex -> case fromException ex of@@ -228,6 +227,110 @@ expectationFailure ("expected StartupFailed, got: " <> show other) +-- | Regression for orphaned/zombie build subprocesses on restart and shutdown.+--+-- The original leak was on the /graceful/ path: GHCi exits cleanly on @:quit@,+-- so its leader is reaped, yet the build subprocesses sharing its group linger.+-- 'withProcessGroup' must still sweep the whole group even after the leader has+-- gone. We simulate it with a leader that forks a long-lived child sharing its+-- group and exits on stdin input (mirroring @:quit@); after 'withProcessGroup'+-- returns, the child must be gone.+testWithProcessGroupCleanup :: Spec+testWithProcessGroupCleanup =+ it "terminates the whole group on exit, even after the leader has exited" do+ childPidRef <- newIORef (Nothing :: Maybe Int)+ let scenario =+ runEff+ . runConcurrent+ . runTimeout+ . runDelay+ . runFile+ . runConc+ . runProcessIO+ $ withProcessGroup procConfig \p -> do+ -- First stdout line is the long-lived child's pid.+ line <- File.hGetLine (AProc.getStdout p)+ liftIO $ writeIORef childPidRef (parsePid (T.unpack line))+ -- Let the leader exit and reap it, so the cleanup runs+ -- with the leader already gone — the path the bug needed.+ File.hPutTextLn (AProc.getStdin p) ""+ File.hFlush (AProc.getStdin p)+ void $ AProc.waitExitCode p+ -- Hard wall-clock bound: a regression must surface as a failed+ -- assertion, never as a hang that stalls the whole suite.+ outcome <- System.Timeout.timeout (8_000_000) scenario+ case outcome of+ Nothing -> expectationFailure "test timed out (process did not settle)"+ Just () ->+ readIORef childPidRef >>= \case+ Nothing -> expectationFailure "could not capture the child pid"+ Just childPid -> do+ died <- waitForProcessDeath childPid+ -- Never leak the child if the assertion fails.+ ignoring (signalProcess sigKILL (fromIntegral childPid))+ died `shouldBe` True+ where+ procConfig =+ setStdin createPipe+ $ setStdout createPipe+ $ setStderr createPipe+ $ shell "sleep 30 & echo \"$!\"; read _quit"+++-- | 'terminateProcessGroup' must kill the whole group when called mid-flight+-- (the leader still alive) — the explicit early-termination path the test+-- runner uses to abort a one-shot @cabal repl test:…@ from another thread.+testTerminateProcessGroup :: Spec+testTerminateProcessGroup =+ it "kills the whole group, not just the leader, mid-flight" do+ outcome <- System.Timeout.timeout (8_000_000) do+ p <-+ startProcess+ $ setStdin createPipe+ $ setStdout createPipe+ $ setStderr createPipe+ $ setCreateGroup True+ $ shell "sleep 30 & echo \"$!\"; read _quit"+ childLine <- hGetLine (getStdout p)+ case parsePid childLine of+ Nothing -> do+ ignoring (stopProcess p)+ expectationFailure ("could not parse child pid from: " <> show childLine)+ pure False+ Just childPid -> do+ runEff . runProcessIO $ terminateProcessGroup (RunningProcess p)+ died <- waitForProcessDeath childPid+ -- Never leak the child if the assertion fails.+ ignoring (signalProcess sigKILL (fromIntegral childPid))+ pure died+ outcome `shouldBe` Just True+++-- | Parse a pid printed on its own line (tolerating surrounding whitespace).+parsePid :: String -> Maybe Int+parsePid = readMaybe . takeWhile isDigit . dropWhile (not . isDigit)+++-- | Swallow any exception from a best-effort cleanup action.+ignoring :: IO () -> IO ()+ignoring act = act `catch` \(_ :: SomeException) -> pure ()+++-- | Poll for up to ~3s for the given pid to disappear from the process table.+-- @signalProcess nullSignal@ is a liveness probe: it throws once the process is+-- gone (and reaped by init after being orphaned).+waitForProcessDeath :: Int -> IO Bool+waitForProcessDeath pid = go (60 :: Int)+ where+ go 0 = not <$> alive+ go n = do+ a <- alive+ if not a then pure True else threadDelay 50_000 >> go (n - 1)+ alive =+ (signalProcess nullSignal (fromIntegral pid) >> pure True)+ `catch` \(_ :: IOException) -> pure False++ testDecideInterrupt :: Spec testDecideInterrupt = do -- Regression: an idle GHCi must not be SIGINT'd, since the matching@@ -282,7 +385,7 @@ { stdin = getStdin p , stdout = getStdout p , stderr = getStderr p- , handle = p+ , handle = RunningProcess p , stateVar } siblingDoneRef <- newIORef False
test/Unit/Tricorder/Effects/GhciSessionSpec.hs view
@@ -11,6 +11,7 @@ import Tricorder.BuildState (Diagnostic (..), Severity (..)) import Tricorder.Effects.GhciSession (Controls (..), GhciSession, LoadResult (..), runGhciSessionScripted, withGhci) import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Command (..)) spec_GhciSession :: Spec@@ -29,40 +30,40 @@ it "returns scripted messages" do LoadResult {diagnostics = msgs} <- runScripted [simpleResult [errMsg]]- $ withGhci "cabal repl" (ProjectRoot "/") \initial _ -> pure initial+ $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial msgs `shouldBe` [errMsg] it "returns empty list when scripted result has no messages" do LoadResult {diagnostics = msgs} <- runScripted [simpleResult []]- $ withGhci "cabal repl" (ProjectRoot "/") \initial _ -> pure initial+ $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial msgs `shouldBe` [] it "throws when scripted result is Left" do result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ withGhci "cabal repl" (ProjectRoot "/") \initial _ -> pure initial+ $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial result `shouldBe` Left boom describe "reloading" do it "returns scripted messages" do LoadResult {diagnostics = msgs} <- runScripted [simpleResult [warnMsg], simpleResult [errMsg]]- $ withGhci "cabal repl" (ProjectRoot "/") \_ controls -> controls.reload+ $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload msgs `shouldBe` [errMsg] it "throws when scripted result is Left" do result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ withGhci "cabal repl" (ProjectRoot "/") \_ controls -> controls.reload+ $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload result `shouldBe` Left boom describe "sequencing" do it "consumes results in order across mixed operations" do (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do- withGhci "cabal repl" (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do+ withGhci (Command "cabal repl") (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do LoadResult {diagnostics = b} <- controls.reload pure (a, b) a `shouldBe` [errMsg]@@ -70,8 +71,8 @@ it "recover scenario: error then success" do result <- runScripted [Left (toException boom), simpleResult []] do- r1 <- try @ErrorCall $ withGhci "cabal repl" (ProjectRoot "/") \i _ -> pure i- LoadResult {diagnostics = r2} <- withGhci "cabal repl" (ProjectRoot "/") \i _ -> pure i+ r1 <- try @ErrorCall $ withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i+ LoadResult {diagnostics = r2} <- withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i pure (r1, r2) fst result `shouldSatisfy` isLeft snd result `shouldBe` []
test/Unit/Tricorder/Effects/SessionStoreSpec.hs view
@@ -24,7 +24,7 @@ , runSessionStoreConst , withSession )-import Tricorder.Session (Session (..))+import Tricorder.Session (Command (..), Session (..)) import Tricorder.Effects.SessionStore qualified as SessionStore @@ -151,11 +151,11 @@ -------------------------------------------------------------------------------- session1 :: Session-session1 = def {command = "session-1"}+session1 = def {command = Command "session-1"} session2 :: Session-session2 = def {command = "session-2"}+session2 = def {command = Command "session-2"} epoch :: UTCTime
test/Unit/Tricorder/SessionSpec.hs view
@@ -13,16 +13,7 @@ import Data.Text qualified as T import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session- ( Config (..)- , allComponentTargets- , discoverCabalFiles- , resolveCommand- , resolveTargets- , resolveTestTargets- , resolveWatchDirs- , sourceDirsForTarget- )+import Tricorder.Session (Command (..), ComponentKind (..), Config (..), Target (..), WatchDirs (..), allComponentTargets, compareTargets, discoverCabalFiles, parseTarget, parseTestTargets, resolveCommand, resolveTargets, resolveTestTargets, resolveWatchDirs, sourceDirsForTarget) spec_Session :: Spec@@ -32,57 +23,146 @@ describe "resolveTargets" testResolveTargets describe "resolveWatchDirs" testResolveWatchDirs describe "resolveTestTargets" testResolveTestTargets+ describe "parseTarget" testParseTarget describe "sourceDirsForTarget" testSourceDirsForTarget describe "allComponentTargets" testAllComponentTargets+ describe "compareTargets" testCompareTargets +testParseTarget :: Spec+testParseTarget = do+ describe "qualified targets" do+ it "parses lib: as the main library (empty name)" do+ parseTarget "lib:" `shouldBe` Qualified Lib ""++ it "parses a named lib: target" do+ parseTarget "lib:myapp-utils" `shouldBe` Qualified Lib "myapp-utils"++ it "parses an flib: target" do+ parseTarget "flib:myapp-flib" `shouldBe` Qualified FLib "myapp-flib"++ it "parses an exe: target" do+ parseTarget "exe:myapp-exe" `shouldBe` Qualified Exe "myapp-exe"++ it "parses a test: target" do+ parseTarget "test:myapp-test" `shouldBe` Qualified Test "myapp-test"++ it "parses a bench: target" do+ parseTarget "bench:myapp-bench" `shouldBe` Qualified Bench "myapp-bench"++ describe "a name with no kind prefix" do+ it "parses as bare" do+ parseTarget "myapp" `shouldBe` Bare "myapp"++ describe "unrecognized targets" do+ it "rejects an unknown kind" do+ parseTarget "bogus:myapp" `shouldBe` Unrecognized "bogus:myapp"++ it "rejects a form with extra colons" do+ parseTarget "lib:a:b" `shouldBe` Unrecognized "lib:a:b"+++-- | These exercise the 'Target' -> dirs resolution directly with constructed+-- 'Target' values; the string -> 'Target' parsing is covered by 'testParseTarget'. testSourceDirsForTarget :: Spec testSourceDirsForTarget = do- describe "lib:" do- it "returns main library source dirs" do- sourceDirsForTarget gpd "lib:" `shouldBe` ["src"]+ describe "Qualified Lib" do+ context "when the name is empty" do+ it "returns the main library source dirs" do+ sourceDirsForTarget gpd (Qualified Lib "") `shouldBe` ["src"] - describe "lib:<package-name>" do- it "returns main library source dirs when name matches package name" do- sourceDirsForTarget gpd "lib:myapp" `shouldBe` ["src"]+ context "when the name matches the package name" do+ it "returns the main library source dirs" do+ sourceDirsForTarget gpd (Qualified Lib "myapp") `shouldBe` ["src"] - describe "lib:<sub-library>" do- it "returns sub-library source dirs" do- sourceDirsForTarget gpd "lib:myapp-utils" `shouldBe` ["utils"]+ context "when the name matches a sub-library" do+ it "returns the sub-library source dirs" do+ sourceDirsForTarget gpd (Qualified Lib "myapp-utils") `shouldBe` ["utils"] - it "returns empty list for unknown sub-library" do- sourceDirsForTarget gpd "lib:nonexistent" `shouldBe` []+ context "when the sub-library is unknown" do+ it "returns an empty list" do+ sourceDirsForTarget gpd (Qualified Lib "nonexistent") `shouldBe` [] - describe "exe:<name>" do- it "returns executable source dirs" do- sourceDirsForTarget gpd "exe:myapp-exe" `shouldBe` ["app"]+ describe "Qualified FLib" do+ it "returns the foreign-library source dirs" do+ sourceDirsForTarget gpd (Qualified FLib "myapp-flib") `shouldBe` ["flib"] - describe "test:<name>" do- it "returns test suite source dirs" do- sourceDirsForTarget gpd "test:myapp-test" `shouldBe` ["test"]+ describe "Qualified Exe" do+ it "returns the executable source dirs" do+ sourceDirsForTarget gpd (Qualified Exe "myapp-exe") `shouldBe` ["app"] - describe "unknown target" do- it "returns empty list" do- sourceDirsForTarget gpd "unknown" `shouldBe` []+ describe "Qualified Test" do+ it "returns the test suite source dirs" do+ sourceDirsForTarget gpd (Qualified Test "myapp-test") `shouldBe` ["test"] + describe "Qualified Bench" do+ it "returns the benchmark source dirs" do+ sourceDirsForTarget gpd (Qualified Bench "myapp-bench") `shouldBe` ["bench"] + describe "Bare (package name)" do+ it "returns every component's source dirs" do+ sourceDirsForTarget gpd (Bare "myapp") `shouldBe` ["src", "utils", "flib", "app", "test", "bench"]++ describe "Bare (component name)" do+ context "when it names a sub-library" do+ it "returns the sub-library source dirs" do+ sourceDirsForTarget gpd (Bare "myapp-utils") `shouldBe` ["utils"]++ context "when it names an executable" do+ it "returns the executable source dirs" do+ sourceDirsForTarget gpd (Bare "myapp-exe") `shouldBe` ["app"]++ context "when it names a test suite" do+ it "returns the test suite source dirs" do+ sourceDirsForTarget gpd (Bare "myapp-test") `shouldBe` ["test"]++ context "when it matches no component" do+ it "returns an empty list" do+ sourceDirsForTarget gpd (Bare "unknown") `shouldBe` []++ describe "Unrecognized" do+ it "matches an aliased kind prefix by trailing name" do+ sourceDirsForTarget gpd (Unrecognized "executable:myapp-exe") `shouldBe` ["app"]++ it "matches a case-variant kind prefix by trailing name" do+ sourceDirsForTarget gpd (Unrecognized "Test-Suite:myapp-test") `shouldBe` ["test"]++ it "matches the main library when the trailing name is the package name" do+ sourceDirsForTarget gpd (Unrecognized "library:myapp") `shouldBe` ["src"]++ it "returns an empty list when the trailing name matches no component" do+ sourceDirsForTarget gpd (Unrecognized "bogus:x") `shouldBe` []++ testAllComponentTargets :: Spec testAllComponentTargets = do- it "includes the main library as lib:<package-name>" do- allComponentTargets gpd `shouldContain` ["lib:myapp"]+ it "includes the main library as a named Qualified Lib" do+ allComponentTargets gpd `shouldContain` [Qualified Lib "myapp"] it "includes sub-libraries" do- allComponentTargets gpd `shouldContain` ["lib:myapp-utils"]+ allComponentTargets gpd `shouldContain` [Qualified Lib "myapp-utils"] + it "includes foreign libraries" do+ allComponentTargets gpd `shouldContain` [Qualified FLib "myapp-flib"]+ it "includes executables" do- allComponentTargets gpd `shouldContain` ["exe:myapp-exe"]+ allComponentTargets gpd `shouldContain` [Qualified Exe "myapp-exe"] it "includes test suites" do- allComponentTargets gpd `shouldContain` ["test:myapp-test"]+ allComponentTargets gpd `shouldContain` [Qualified Test "myapp-test"] - it "returns all four components for the fixture" do+ it "includes benchmarks" do+ allComponentTargets gpd `shouldContain` [Qualified Bench "myapp-bench"]++ it "returns every component for the fixture" do allComponentTargets gpd- `shouldBe` ["lib:myapp", "lib:myapp-utils", "exe:myapp-exe", "test:myapp-test"]+ `shouldBe` [ Qualified Lib "myapp"+ , Qualified Lib "myapp-utils"+ , Qualified FLib "myapp-flib"+ , Qualified Exe "myapp-exe"+ , Qualified Test "myapp-test"+ , Qualified Bench "myapp-bench"+ ] -- | Pins the discovery contract: a @cabal.project@ selects per-package@@ -121,7 +201,7 @@ . evalState mempty . runFileSystemState $ resolveTargets ["/myapp.cabal"] ["lib:foo", "test:foo-test"]- actual `shouldBe` ["lib:foo", "test:foo-test"]+ actual `shouldBe` [Qualified Test "foo-test", Qualified Lib "foo"] describe "when no targets are configured" do it "auto-detects all components from the cabal file" do@@ -131,7 +211,13 @@ . runFileSystemState $ resolveTargets ["/myapp.cabal"] [] actual- `shouldBe` ["lib:myapp", "lib:myapp-utils", "exe:myapp-exe", "test:myapp-test"]+ `shouldBe` [ Qualified Bench "myapp-bench"+ , Qualified Exe "myapp-exe"+ , Qualified FLib "myapp-flib"+ , Qualified Test "myapp-test"+ , Qualified Lib "myapp"+ , Qualified Lib "myapp-utils"+ ] it "surfaces test-suite components so they can be run after a build" do let actual =@@ -139,7 +225,7 @@ . evalState (Map.singleton "/myapp.cabal" cabalFixture) . runFileSystemState $ resolveTargets ["/myapp.cabal"] []- actual `shouldContain` ["test:myapp-test"]+ actual `shouldContain` [Qualified Test "myapp-test"] it "returns no targets when there are no cabal files" do let actual =@@ -155,17 +241,17 @@ . evalState multiPackageFs . runFileSystemState $ resolveTargets ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] []- actual `shouldContain` ["lib:pkg-a"]- actual `shouldContain` ["lib:pkg-b"]- filter ("test:" `T.isPrefixOf`) actual- `shouldBe` ["test:pkg-a-test", "test:pkg-b-test"]+ actual `shouldContain` [Qualified Lib "pkg-a"]+ actual `shouldContain` [Qualified Lib "pkg-b"]+ [t | t@(Qualified Test _) <- actual]+ `shouldBe` [Qualified Test "pkg-a-test", Qualified Test "pkg-b-test"] testResolveWatchDirs :: Spec testResolveWatchDirs = do describe "when watch_dirs is set in config" do it "uses config dirs relative to project root" do- let actual =+ let WatchDirs actual = runPureEff . evalState mempty . runFileSystemState@@ -174,7 +260,7 @@ describe "when watch_dirs is not set" do it "falls back to [\".\"] when targets list is empty" do- let actual =+ let WatchDirs actual = runPureEff . evalState mempty . runFileSystemState@@ -182,24 +268,35 @@ actual `shouldBe` ["."] it "infers source dirs from resolved targets" do- let actual =+ let WatchDirs actual = runPureEff . evalState (Map.singleton "/myapp.cabal" cabalFixture) . runFileSystemState- $ resolveWatchDirs pr ["/myapp.cabal"] def ["lib:myapp", "test:myapp-test"]+ $ resolveWatchDirs pr ["/myapp.cabal"] def (mkTargets ["lib:myapp", "test:myapp-test"]) actual `shouldBe` ["/src", "/test"] it "falls back to [\".\"] when there are no cabal files" do- let actual =+ let WatchDirs actual = runPureEff . evalState mempty . runFileSystemState- $ resolveWatchDirs pr [] def ["lib:myapp"]+ $ resolveWatchDirs pr [] def (mkTargets ["lib:myapp"]) actual `shouldBe` ["."] + -- Sharp edge: an unparseable .cabal yields no source dirs, so resolution+ -- falls back to watching the whole project root. This pins the current+ -- behavior; if it ever changes to something narrower, update this test.+ it "falls back to [\".\"] when the cabal file cannot be parsed" do+ let WatchDirs actual =+ runPureEff+ . evalState (Map.singleton "/myapp.cabal" malformedCabal)+ . runFileSystemState+ $ resolveWatchDirs pr ["/myapp.cabal"] def (mkTargets ["lib:myapp"])+ actual `shouldBe` ["."]+ describe "when the project is a multi-package cabal.project" do it "infers per-package source dirs, scoped to each package's directory" do- let actual =+ let WatchDirs actual = runPureEff . evalState multiPackageFs . runFileSystemState@@ -207,9 +304,21 @@ pr ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] def- ["lib:pkg-a", "test:pkg-a-test", "lib:pkg-b", "test:pkg-b-test"]+ (mkTargets ["lib:pkg-a", "test:pkg-a-test", "lib:pkg-b", "test:pkg-b-test"]) actual `shouldBe` ["/pkg-a/src", "/pkg-a/test", "/pkg-b/src", "/pkg-b/test"]++ it "scopes a bare package-name target to that package, ignoring siblings" do+ let WatchDirs actual =+ runPureEff+ . evalState multiPackageFs+ . runFileSystemState+ $ resolveWatchDirs+ pr+ ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+ def+ (mkTargets ["pkg-a"])+ actual `shouldBe` ["/pkg-a/src", "/pkg-a/test"] where pr = ProjectRoot "/" @@ -218,76 +327,146 @@ testResolveTestTargets = do it "infers test: components from targets when testTargets is absent" do let cfg = def :: Config- resolveTestTargets cfg ["lib:mylib", "test:mylib-test"] `shouldBe` ["test:mylib-test"]+ resolveTestTargets cfg (mkTargets ["lib:mylib", "test:mylib-test"]) `shouldBe` parseTestTargets ["test:mylib-test"] it "returns empty list when no test: components in targets" do let cfg = def :: Config- resolveTestTargets cfg ["lib:mylib", "exe:myapp"] `shouldBe` []+ resolveTestTargets cfg (mkTargets ["lib:mylib", "exe:myapp"]) `shouldBe` parseTestTargets [] it "uses explicit testTargets list when set" do let cfg = def {testTargets = Just ["test:b-test"]} :: Config- resolveTestTargets cfg ["lib:a", "test:a-test", "test:b-test"] `shouldBe` ["test:b-test"]+ resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) `shouldBe` parseTestTargets ["test:b-test"] it "returns empty list when testTargets is explicitly empty" do let cfg = def {testTargets = Just []} :: Config- resolveTestTargets cfg ["lib:a", "test:a-test"] `shouldBe` []+ resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test"]) `shouldBe` parseTestTargets [] it "infers multiple test: components" do let cfg = def :: Config- resolveTestTargets cfg ["lib:a", "test:a-test", "test:b-test"] `shouldBe` ["test:a-test", "test:b-test"]+ resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) `shouldBe` parseTestTargets ["test:a-test", "test:b-test"] testResolveCommand :: Spec testResolveCommand = do describe "when config has a command" do it "should use specified command" do- let actual =+ let Command actual = runPureEff . evalState mempty . runFileSystemState- $ resolveCommand pr def {command = Just "foo"}+ $ resolveCommand pr def {command = Just "foo"} [] testTargets actual `shouldBe` "foo" - describe "when config does not have a command" do+ describe "when config has explicit targets" do+ it "should spell them out verbatim, ignoring discovered test targets" do+ let Command actual =+ runPureEff+ . evalState (Map.singleton "/cabal.project" "")+ . runFileSystemState+ $ resolveCommand pr cfg (mkTargets ["lib:foo"]) testTargets+ actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"++ describe "when config does not have a command or targets" do describe "and there is a cabal.project file" do- it "should use cabal with --enable-multi-repl" do- let actual =+ it "should use cabal 'all' plus the discovered test targets" do+ let Command actual = runPureEff . evalState (Map.singleton "/cabal.project" "") . runFileSystemState- $ resolveCommand pr cfg- actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"+ $ resolveCommand pr cfg [] testTargets+ actual+ `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo" describe "and there is at least one *.cabal file" do- it "should use cabal with --enable-multi-repl" do- let actual =+ it "should use cabal 'all' plus the discovered test targets" do+ let Command actual = runPureEff . evalState (Map.singleton "/foo.cabal" "") . runFileSystemState- $ resolveCommand pr cfg- actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"+ $ resolveCommand pr cfg [] testTargets+ actual+ `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"+ describe "and there is a stack.yaml file" do- it "should use stack ghci" do- let actual =+ it "should use stack ghci with 'all' plus test targets" do+ let Command actual = runPureEff . evalState (Map.singleton "/stack.yaml" "") . runFileSystemState- $ resolveCommand pr cfg- actual `shouldBe` "stack ghci lib:foo"+ $ resolveCommand pr cfg [] testTargets+ actual `shouldBe` "stack ghci all test:foo" describe "but there are no project files" do- it "should use default cabal repl" do- let actual =+ it "should use default cabal repl with 'all' plus test targets" do+ let Command actual = runPureEff . evalState mempty . runFileSystemState- $ resolveCommand pr cfg- actual `shouldBe` "cabal repl --builddir /replbuild lib:foo"+ $ resolveCommand pr cfg [] testTargets+ actual `shouldBe` "cabal repl --builddir /replbuild all test:foo"++ describe "and no test targets are discovered" do+ it "should fall back to plain 'all'" do+ let Command actual =+ runPureEff+ . evalState (Map.singleton "/cabal.project" "")+ . runFileSystemState+ $ resolveCommand pr cfg [] (parseTestTargets [])+ actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all" where pr = ProjectRoot "/"- cfg = def {replBuildDir = "/replbuild", targets = ["lib:foo"]}+ cfg = def {replBuildDir = "/replbuild"}+ testTargets = parseTestTargets ["test:foo"] +testCompareTargets :: Spec+testCompareTargets = do+ describe "Ord" do+ describe "only first target beginnings with 'lib:'" do+ describe "first target's component name normally sorts as LT" do+ it "should return GT" do+ compareTargets (Qualified Lib "a") (Qualified Exe "b") `shouldBe` GT+ describe "both targets have same component name" do+ it "should return GT" do+ compareTargets (Qualified Lib "a") (Qualified Exe "a") `shouldBe` GT+ describe "first target's component name normally sorts as GT" do+ it "should return GT" do+ compareTargets (Qualified Lib "b") (Qualified Exe "a") `shouldBe` GT++ describe "only second target begins with 'lib:'" do+ describe "first target's component name normally sorts as LT" do+ it "should return LT" do+ compareTargets (Qualified Exe "a") (Qualified Lib "b") `shouldBe` LT+ describe "both targets have same component name" do+ it "should return LT" do+ compareTargets (Qualified Exe "a") (Qualified Lib "a") `shouldBe` LT+ describe "first target's component name normally sorts as GT" do+ it "should return LT" do+ compareTargets (Qualified Exe "b") (Qualified Lib "a") `shouldBe` LT++ describe "both targets begin with 'lib:'" do+ describe "first target's component name normally sorts as LT" do+ it "should sort normally" do+ compareTargets (Qualified Lib "a") (Qualified Lib "b") `shouldBe` LT+ describe "both targets have same component name" do+ it "should sort normally" do+ compareTargets (Qualified Lib "a") (Qualified Lib "a") `shouldBe` EQ+ describe "first target's component name normally sorts as GT" do+ it "should sort normally" do+ compareTargets (Qualified Lib "b") (Qualified Lib "a") `shouldBe` GT++ describe "neither target begin with 'lib:'" do+ describe "first target's component name normally sorts as LT" do+ it "should sort normally" do+ compareTargets (Qualified Exe "a") (Qualified Exe "b") `shouldBe` LT+ describe "both targets have same component name" do+ it "should sort normally" do+ compareTargets (Qualified Exe "a") (Qualified Exe "a") `shouldBe` EQ+ describe "first target's component name normally sorts as GT" do+ it "should sort normally" do+ compareTargets (Qualified Exe "b") (Qualified Exe "a") `shouldBe` GT++ -------------------------------------------------------------------------------- -- Helpers --------------------------------------------------------------------------------@@ -298,6 +477,12 @@ $ parseGenericPackageDescriptionMaybe cabalFixture +-- | Build a target list from textual forms, exactly as config and cabal+-- discovery do via 'parseTarget'.+mkTargets :: [Text] -> [Target]+mkTargets = map parseTarget++ -- | An in-memory project root with a @cabal.project@ listing two packages, -- each in its own subdirectory with a library and a test suite. multiPackageFs :: Map FilePath ByteString@@ -334,6 +519,12 @@ ] +-- | Not a valid @.cabal@ file: @parseGenericPackageDescriptionMaybe@ returns+-- 'Nothing' for it.+malformedCabal :: ByteString+malformedCabal = "this is not a cabal file {{{ <<< @@@\n"++ cabalFixture :: ByteString cabalFixture = "cabal-version: 2.0\n\@@ -351,6 +542,12 @@ \ build-depends: base\n\ \ default-language: Haskell2010\n\ \\n\+ \foreign-library myapp-flib\n\+ \ type: native-shared\n\+ \ hs-source-dirs: flib\n\+ \ build-depends: base\n\+ \ default-language: Haskell2010\n\+ \\n\ \executable myapp-exe\n\ \ main-is: Main.hs\n\ \ hs-source-dirs: app\n\@@ -361,5 +558,12 @@ \ type: exitcode-stdio-1.0\n\ \ main-is: Test.hs\n\ \ hs-source-dirs: test\n\+ \ build-depends: base\n\+ \ default-language: Haskell2010\n\+ \\n\+ \benchmark myapp-bench\n\+ \ type: exitcode-stdio-1.0\n\+ \ main-is: Bench.hs\n\+ \ hs-source-dirs: bench\n\ \ build-depends: base\n\ \ default-language: Haskell2010\n"
test/Unit/Tricorder/WatcherSpec.hs view
@@ -1,7 +1,7 @@ module Unit.Tricorder.WatcherSpec (spec_Watcher) where import Atelier.Effects.Delay (runDelay)-import Atelier.Effects.FileWatcher (FileEvent (..))+import Atelier.Effects.FileWatcher (FileEvent (..), matchesAny) import Atelier.Effects.Publishing (runPubWriter) import Effectful (runEff) import Effectful.Concurrent (runConcurrent)@@ -10,6 +10,7 @@ import Effectful.State.Static.Shared (execState, put) import Effectful.Writer.Static.Shared (runWriter) import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)+import Text.Regex.TDFA.ReadRegex (parseRegex) import Tricorder.BuildState ( CabalChangeDetected (..)@@ -18,12 +19,15 @@ , SourceChangeDetected (..) ) import Tricorder.Effects.BuildStore (BuildStore (..))-import Tricorder.Watcher (WatchedFile (..), markWatchedFiles)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (WatchDirs (..), WatchExclusionPatterns (WatchExclusionPatterns))+import Tricorder.Watcher (WatchedFile (..), WatcherSession (..), makeWatches, markWatchedFiles) spec_Watcher :: Spec spec_Watcher = do describe "markWatchedFiles" testMarkWatchedFiles+ describe "makeWatches" testMakeWatches testMarkWatchedFiles :: Spec@@ -56,6 +60,68 @@ mockBuildStore = reinterpret_ (execState Nothing) \case MarkDirty ck -> put $ Just ck _ -> error "Not implemented"+++testMakeWatches :: Spec+testMakeWatches = do+ describe "source watches" do+ it "matches .hs files in configured watch dirs" do+ let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])+ matchesAny watches "/proj/src/Foo.hs" `shouldBe` True++ it "does not match non-.hs files" do+ let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])+ matchesAny watches "/proj/src/Foo.txt" `shouldBe` False++ it "excludes paths containing dist-newstyle" do+ let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])+ matchesAny watches "/proj/src/dist-newstyle/Foo.hs" `shouldBe` False++ it "excludes paths matching an exclusion pattern" do+ let pat = parsePattern "vendor"+ watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [pat])+ matchesAny watches "/proj/src/vendor/Foo.hs" `shouldBe` False+ matchesAny watches "/proj/src/Foo.hs" `shouldBe` True++ it "matches .hs files across multiple watch dirs" do+ let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src", "/proj/test"] [])+ matchesAny watches "/proj/src/Foo.hs" `shouldBe` True+ matchesAny watches "/proj/test/FooSpec.hs" `shouldBe` True++ -- Second line of defense: 'cabalWatches' registers the whole project+ -- root, and 'deduplicateDirs' collapses the narrow source dirs into it,+ -- so the OS watches the entire repo recursively. 'matchesAny' is what+ -- re-scopes events back to the configured dirs — a .hs file in a sibling+ -- package must not match.+ it "does not match a .hs file in a sibling package outside the watch dirs" do+ let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/pkg-a/src"] [])+ matchesAny watches "/proj/pkg-a/src/Foo.hs" `shouldBe` True+ matchesAny watches "/proj/pkg-b/src/Foo.hs" `shouldBe` False++ describe "cabal watches" do+ it "matches .cabal files under project root" do+ let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession+ matchesAny watches "/proj/foo.cabal" `shouldBe` True++ it "matches cabal.project under project root" do+ let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession+ matchesAny watches "/proj/cabal.project" `shouldBe` True++ it "matches package.yaml under project root" do+ let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession+ matchesAny watches "/proj/package.yaml" `shouldBe` True++ it "does not match non-cabal files" do+ let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession+ matchesAny watches "/proj/README.md" `shouldBe` False++ it "excludes cabal files under dist-newstyle" do+ let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession+ matchesAny watches "/proj/dist-newstyle/foo.cabal" `shouldBe` False+ where+ parsePattern p = fromRight (error . toText $ "bad test pattern: " <> p) (parseRegex p)+ emptyWatcherSession = watcherSession [] []+ watcherSession dirs patterns = WatcherSession (WatchDirs dirs) (WatchExclusionPatterns patterns) emptyDaemonInfo :: DaemonInfo
tricorder.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.38.2.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: tricorder-version: 0.1.0.1+version: 0.1.1.0 synopsis: Continuous Haskell build status, diagnostics, and tests via a shared daemon description: tricorder rebuilds your Haskell project continuously and surfaces build status, diagnostics, test results, and documentation - for developers and LLM coding agents. Like ghcid and ghciwatch it reloads on every change, but builds run in a background daemon so multiple clients (an interactive TUI, a status CLI, an agent skill) share a single build state without triggering redundant rebuilds. It discovers components across multi-package cabal.project workspaces automatically and ships context-friendly output for agentic use via the CLI. category: Development@@ -18,6 +18,7 @@ build-type: Simple extra-doc-files: README.md+ CHANGELOG.md source-repository head type: git@@ -61,6 +62,7 @@ Tricorder.UI.Event Tricorder.UI.Keys Tricorder.UI.Misc+ Tricorder.UI.Route Tricorder.UI.State Tricorder.UI.View Tricorder.Version@@ -88,36 +90,37 @@ StrictData TemplateHaskell TypeFamilies- ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -fplugin=Effectful.Plugin -threaded+ ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded build-depends:- Cabal-syntax ==3.12.*+ Cabal-syntax >=3.12 && <3.17 , aeson ==2.2.* , ansi-terminal ==1.1.*- , atelier-core ==0.1.*+ , atelier-core ==0.2.* , atelier-prelude ==0.1.*- , base ==4.20.*+ , base >=4.18 && <4.23 , brick ==2.10.*- , bytestring ==0.12.*+ , bytestring >=0.11 && <0.13 , casing ==0.1.*- , containers ==0.7.*+ , containers >=0.6 && <0.9 , data-default ==0.8.* , directory ==1.3.* , effectful ==2.6.* , effectful-core ==2.6.*- , effectful-plugin ==2.0.*+ , effectful-plugin >=2.0 && <2.2 , effectful-th ==1.0.*- , filepath ==1.5.*+ , filepath >=1.4 && <1.6 , hashable ==1.5.* , megaparsec ==9.7.* , mtl ==2.3.* , network ==3.2.* , optparse-applicative ==0.19.* , process ==1.6.*+ , regex-tdfa >=1.3.2.5 && <1.4 , relude ==1.2.* , stm ==2.5.*- , template-haskell ==2.22.*+ , template-haskell >=2.20 && <2.25 , text ==2.1.*- , time ==1.12.*+ , time >=1.12 && <1.16 , time-units ==1.0.* , vty ==6.5.* , vty-crossplatform ==0.5.*@@ -125,6 +128,8 @@ mixins: base hiding (Prelude) default-language: GHC2021+ if impl(GHC >= 9.8)+ ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations executable tricorder main-is: Main.hs@@ -151,16 +156,18 @@ StrictData TemplateHaskell TypeFamilies- ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T"+ ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T" build-depends: atelier-prelude ==0.1.*- , base ==4.20.*+ , base >=4.18 && <4.23 , effectful-core ==2.6.*- , effectful-plugin ==2.0.*+ , effectful-plugin >=2.0 && <2.2 , tricorder-internal mixins: base hiding (Prelude) default-language: GHC2021+ if impl(GHC >= 9.8)+ ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations executable tricorder-daemon main-is: Main.hs@@ -187,16 +194,18 @@ StrictData TemplateHaskell TypeFamilies- ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T"+ ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T" build-depends: atelier-prelude ==0.1.*- , base ==4.20.*+ , base >=4.18 && <4.23 , effectful-core ==2.6.*- , effectful-plugin ==2.0.*+ , effectful-plugin >=2.0 && <2.2 , tricorder-internal mixins: base hiding (Prelude) default-language: GHC2021+ if impl(GHC >= 9.8)+ ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations test-suite tricorder-test type: exitcode-stdio-1.0@@ -240,32 +249,36 @@ StrictData TemplateHaskell TypeFamilies- ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -fplugin=Effectful.Plugin -threaded -Wno-prepositive-qualified-module+ ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded -Wno-prepositive-qualified-module build-tool-depends: tasty-discover:tasty-discover build-depends:- Cabal-syntax ==3.12.*+ Cabal-syntax >=3.12 && <3.17 , aeson ==2.2.*- , atelier-core ==0.1.*+ , atelier-core ==0.2.* , atelier-prelude ==0.1.*- , base ==4.20.*- , containers ==0.7.*+ , base >=4.18 && <4.23+ , containers >=0.6 && <0.9 , data-default ==0.8.* , effectful ==2.6.* , effectful-core ==2.6.*- , effectful-plugin ==2.0.*+ , effectful-plugin >=2.0 && <2.2 , hspec ==2.11.* , process ==1.6.*+ , regex-tdfa >=1.3.2.5 && <1.4 , stm ==2.5.* , tasty ==1.5.* , tasty-discover ==5.2.* , tasty-hspec ==1.2.* , text ==2.1.*- , time ==1.12.*+ , time >=1.12 && <1.16 , time-units ==1.0.* , tricorder-internal , typed-process ==0.2.* , unagi-chan ==0.4.*+ , unix ==2.8.* mixins: base hiding (Prelude) default-language: GHC2021+ if impl(GHC >= 9.8)+ ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations