packages feed

tricorder (empty) → 0.1.0.0

raw patch · 62 files changed

+10759/−0 lines, 62 filesdep +Cabal-syntaxdep +aesondep +ansi-terminal

Dependencies added: Cabal-syntax, aeson, ansi-terminal, atelier-core, atelier-prelude, base, brick, bytestring, casing, containers, data-default, directory, effectful, effectful-core, effectful-plugin, effectful-th, filepath, hashable, hspec, megaparsec, mtl, network, optparse-applicative, process, relude, stm, tasty, tasty-discover, tasty-hspec, template-haskell, text, time, time-units, tricorder, typed-process, unagi-chan, vty, vty-crossplatform, yaml

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 Christian Georgii++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,20 @@+# tricorder++`tricorder` empowers developers and LLM coding agents working with Haskell by surfacing the right information at each stage: build status, diagnostics, test results, and documentation.++Like `ghcid` and `ghciwatch`, it rebuilds continuously on every change and reports diagnostics — but it runs builds in a background daemon so multiple clients (an interactive TUI, a `tricorder status` CLI, a Claude Code skill) can query a single shared build state without triggering redundant rebuilds. It discovers components across multi-package `cabal.project` workspaces automatically and ships context-friendly output for agentic use.++See the [repository README](https://github.com/atelier-hub/tricorder#readme) for installation (Nix, Home Manager, NixOS), Claude Code plugin setup, configuration, and custom key bindings.++## Built on atelier++`tricorder` is built on the **atelier** toolkit, also developed in this repository:++- [`atelier-prelude`](https://github.com/atelier-hub/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions+- [`atelier-core`](https://github.com/atelier-hub/tricorder/tree/main/atelier-core) — foundational effects and utilities+- [`atelier-db`](https://github.com/atelier-hub/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8)+- [`atelier-testing`](https://github.com/atelier-hub/tricorder/tree/main/atelier-testing) — database-backed test utilities++## License++MIT — see [LICENSE](LICENSE).
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Tricorder.CLI.Main qualified as CLI+++main :: IO ()+main = CLI.main
+ daemon/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Tricorder.Daemon.Main qualified as Daemon+++main :: IO ()+main = Daemon.main
+ src/Tricorder.hs view
@@ -0,0 +1,108 @@+module Tricorder (run) where++import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Console (Console)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Exit (Exit)+import Atelier.Effects.File (File)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Posix.Daemons (Daemons)+import Effectful (IOE)+import Effectful.Reader.Static (Reader, ask, asks)+import Effectful.Timeout (Timeout)++import Atelier.Effects.Console qualified as Console+import Data.Text qualified as T++import Tricorder.Arguments (Command (..))+import Tricorder.BuildState (BuildState (..), DaemonInfo (..))+import Tricorder.CLI (showLog, showSource, showStatus, showTests)+import Tricorder.Daemon (startDaemon, stopDaemon, waitForDaemon)+import Tricorder.Effects.Brick (Brick)+import Tricorder.Effects.BrickChan (BrickChan)+import Tricorder.Effects.UnixSocket (UnixSocket)+import Tricorder.Runtime (LogPath (..), PidFile (..), SocketPath (..))+import Tricorder.Socket.Client (isDaemonRunning, queryStatus)+import Tricorder.UI (viewUi)++import Tricorder.UI.Keys qualified as Keys+++run+    :: ( Brick :> es+       , BrickChan :> es+       , Clock :> es+       , Conc :> es+       , Console :> es+       , Daemons :> es+       , Delay :> es+       , Exit :> es+       , File :> es+       , FileSystem :> es+       , IOE :> es+       , Reader Command :> es+       , Reader Keys.Config :> es+       , Reader LogPath :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , Timeout :> es+       , UnixSocket :> es+       )+    => Eff es ()+run =+    ask >>= \case+        Start -> do+            running <- isDaemonRunning+            if running then+                Console.putStrLn "Daemon already running."+            else do+                startDaemon+                Console.putStrLn "Daemon started."+        Stop -> do+            running <- isDaemonRunning+            when running+                $ stopDaemon >>= \case+                    Left reasons ->+                        Console.putTextLn+                            $ T.intercalate "\n"+                            $ "Was unable to stop the daemon:" : reasons+                    Right result -> do+                        Console.putTextLn result+        Status opts -> do+            running <- isDaemonRunning+            if not running then+                Console.putStrLn "Stopped."+            else+                showStatus opts+        Test opts -> do+            running <- isDaemonRunning+            if not running then+                Console.putStrLn "Stopped."+            else+                showTests opts+        Log followMode -> do+            running <- isDaemonRunning+            logFile <-+                if running then do+                    SocketPath sp <- ask+                    result <- queryStatus sp+                    LogPath fallback <- ask+                    pure $ case result of+                        Right state -> state.daemonInfo.logFile+                        Left _ -> fallback+                else+                    asks @LogPath (.getLogPath)+            showLog logFile followMode+        UI -> do+            running <- isDaemonRunning+            unless running do+                startDaemon+                waitForDaemon+            viewUi+        Source moduleNames -> do+            running <- isDaemonRunning+            unless running $ do+                startDaemon+                waitForDaemon+            showSource moduleNames
+ src/Tricorder/Arguments.hs view
@@ -0,0 +1,206 @@+module Tricorder.Arguments+    ( Command (..)+    , FollowMode (..)+    , OutputFormat (..)+    , StatusOptions (..)+    , TestOptions (..)+    , Verbosity (..)+    , WaitMode (..)+    , parseArguments+    , runArguments+    ) where++import Atelier.Effects.Arguments (Arguments, execParser)+import Effectful.Reader.Static (Reader, runReader)+import Options.Applicative+    ( Parser+    , ParserInfo+    , ReadM+    , argument+    , auto+    , command+    , eitherReader+    , flag+    , fullDesc+    , header+    , help+    , helper+    , hsubparser+    , info+    , infoOption+    , long+    , metavar+    , option+    , progDesc+    , short+    )++import Data.Text qualified as T++import Tricorder.GhcPkg.Types (ModuleName (..), SourceQuery (..))++import Tricorder.Version qualified as Version+++data WaitMode+    = ShowCurrent+    | WaitForBuild+    deriving stock (Eq)+++data OutputFormat+    = TextOutput+    | JsonOutput+    deriving stock (Eq)+++data Verbosity+    = Concise+    | Verbose+    deriving stock (Eq)+++data FollowMode+    = NoFollow+    | Follow+    deriving stock (Eq)+++data StatusOptions = StatusOptions+    { wait :: WaitMode+    , format :: OutputFormat+    , verbosity :: Verbosity+    , expand :: Maybe Int+    }+++data TestOptions = TestOptions+    { failedOnly :: Bool+    , wait :: WaitMode+    }+++data Command+    = Start+    | Stop+    | Status StatusOptions+    | Test TestOptions+    | UI+    | Log FollowMode+    | Source [SourceQuery]+++runArguments :: (Arguments :> es) => Eff (Reader Command : es) a -> Eff es a+runArguments eff = do+    args <- parseArguments+    runReader args eff+++parseArguments :: (Arguments :> es) => Eff es Command+parseArguments = execParser opts+++opts :: ParserInfo Command+opts =+    info (commandParser <**> versionOption <**> helper)+        $ fullDesc+            <> progDesc "tricorder — daemon-based GHCi build status"+            <> header "tricorder — robust GHCi daemon with structured querying"+++versionOption :: Parser (a -> a)+versionOption = infoOption (toString Version.gitHash) (long "version" <> help "Show version and exit")+++commandParser :: Parser Command+commandParser =+    hsubparser+        ( command "start" (info (pure Start) (progDesc "Start the daemon (no-op if already running)"))+            <> command "stop" (info (pure Stop) (progDesc "Stop the daemon"))+            <> command "status" (info statusParser (progDesc "Print build diagnostics (--json for machine-readable output)"))+            <> command "test-results" (info testParser (progDesc "Show output from the latest test run"))+            <> command "ui" (info (pure UI) (progDesc "Auto-refreshing terminal display"))+            <> command "log" (info logParser (progDesc "Show daemon log output"))+            <> command "source" (info sourceParser (progDesc "Print the Haskell source of one or more installed modules"))+        )+++logParser :: Parser Command+logParser =+    Log+        <$> flag+            NoFollow+            Follow+            ( long "follow"+                <> short 'f'+                <> help "Keep streaming new log lines as they are written"+            )+++statusParser :: Parser Command+statusParser =+    Status+        <$> ( StatusOptions+                <$> flag+                    ShowCurrent+                    WaitForBuild+                    ( long "wait"+                        <> help "Block until the current build cycle completes"+                    )+                <*> flag+                    TextOutput+                    JsonOutput+                    ( long "json"+                        <> help "Output full build state as JSON"+                    )+                <*> flag+                    Concise+                    Verbose+                    ( long "verbose"+                        <> short 'v'+                        <> help "Print full GHC message body under each diagnostic"+                    )+                <*> optional+                    ( option+                        auto+                        ( long "expand"+                            <> metavar "N"+                            <> help "Print full GHC message body for diagnostic #N"+                        )+                    )+            )+++testParser :: Parser Command+testParser =+    Test+        <$> ( TestOptions+                <$> flag+                    False+                    True+                    ( long "failed"+                        <> help "Only show output from failed test suites"+                    )+                <*> flag+                    ShowCurrent+                    WaitForBuild+                    ( long "wait"+                        <> help "Block until the current build cycle completes"+                    )+            )+++sourceParser :: Parser Command+sourceParser =+    Source <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function"))+++queryReader :: ReadM SourceQuery+queryReader = eitherReader $ \s ->+    let t = toText s+        (m, rest) = T.break (== '#') t+    in  Right+            $ SourceQuery+                { moduleName = ModuleName m+                , function = if T.null rest then Nothing else Just (T.tail rest)+                }
+ src/Tricorder/BuildState.hs view
@@ -0,0 +1,238 @@+-- | Shared wire-protocol vocabulary for the build system.+--+-- Every type here is serialised (most via 'FromJSON' / 'ToJSON') and crosses+-- module boundaries between the daemon, the socket layer, the CLI, the UI,+-- and external clients. Components' /internal/ caches and bookkeeping (e.g.+-- the Builder's per-cycle module map and diagnostic accumulator) do not+-- belong here — they live next to the component that owns them.+module Tricorder.BuildState+    ( BuildId (..)+    , BuildState (..)+    , BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , TestRun (..)+    , TestRunError (..)+    , TestRunCompletion (..)+    , TestCase (..)+    , TestCaseOutcome (..)+    , DaemonInfo (..)+    , loadDaemonInfo+    , runDaemonInfo+    , Diagnostic (..)+    , Severity (..)+    , ChangeKind (..)+    , initialBuildState+    , stateLabel+    , CabalChangeDetected (..)+    , SourceChangeDetected (..)+    ) where++import Atelier.Effects.FileWatcher (FileEvent)+import Atelier.Effects.Input (Input, runInputEff)+import Atelier.Time (Millisecond)+import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import Data.Time (UTCTime)+import Effectful.Reader.Static (Reader, ask)+import System.FilePath (makeRelative)++import Tricorder.Effects.SessionStore (SessionStore)+import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..))+import Tricorder.Session (Session (..))++import Tricorder.Effects.SessionStore qualified as SessionStore+import Tricorder.Observability qualified as Observability+++newtype BuildId = BuildId Int+    deriving stock (Eq, Show)+    deriving newtype (FromJSON, ToJSON)+    deriving (Num) via Int+++data DaemonInfo = DaemonInfo+    { targets :: [Text]+    , watchDirs :: [FilePath]+    , sockPath :: FilePath+    , logFile :: FilePath+    , metricsPort :: Maybe Int+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++loadDaemonInfo+    :: ( Reader LogPath :> es+       , Reader Observability.Config :> es+       , Reader ProjectRoot :> es+       , Reader SocketPath :> es+       , SessionStore :> es+       )+    => Eff es DaemonInfo+loadDaemonInfo = do+    session <- SessionStore.get+    obsCfg <- ask @Observability.Config+    ProjectRoot projectRoot <- ask+    SocketPath sockPath <- ask+    LogPath logFile <- ask+    pure+        $ DaemonInfo+            { targets = session.targets+            , watchDirs = map (makeRelative projectRoot) session.watchDirs+            , sockPath+            , logFile+            , metricsPort = if obsCfg.metrics.enabled then Just obsCfg.metrics.port else Nothing+            }+++runDaemonInfo+    :: ( Reader LogPath :> es+       , Reader Observability.Config :> es+       , Reader ProjectRoot :> es+       , Reader SocketPath :> es+       , SessionStore :> es+       )+    => Eff (Input DaemonInfo : es) a -> Eff es a+runDaemonInfo = runInputEff loadDaemonInfo+++data TestCaseOutcome+    = TestCasePassed+    | TestCaseFailed Text+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data TestCase = TestCase+    { description :: Text+    , outcome :: TestCaseOutcome+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data TestRunError = TestRunError+    { target :: Text+    , message :: Text+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data TestRunCompletion = TestRunCompletion+    { target :: Text+    , passed :: Bool+    , output :: Text+    , testCases :: [TestCase]+    , duration :: Maybe Millisecond+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data TestRun+    = TestRunning Text (Maybe BuildProgress)+    | TestRunErrored TestRunError+    | TestRunCompleted TestRunCompletion+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data BuildResult = BuildResult+    { completedAt :: UTCTime+    , duration :: Millisecond+    , moduleCount :: Int+    , diagnostics :: [Diagnostic]+    , testRuns :: [TestRun]+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data BuildProgress = BuildProgress+    { compiled :: Int+    , total :: Int+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data BuildPhase+    = Building (Maybe BuildProgress)+    | Restarting+    | Testing BuildResult+    | Done BuildResult+    | BuildFailed Text+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data BuildState = BuildState+    { buildId :: BuildId+    , phase :: BuildPhase+    , daemonInfo :: DaemonInfo+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data Diagnostic = Diagnostic+    { severity :: Severity+    , file :: FilePath+    , line :: Int+    , col :: Int+    , endLine :: Int+    , endCol :: Int+    , title :: Text+    , text :: Text+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data Severity = SError | SWarning+    deriving stock (Eq, Ord, Show)+++instance FromJSON Severity where+    parseJSON = withText "Severity" \case+        "error" -> pure SError+        "warning" -> pure SWarning+        other -> fail $ "unknown severity: " <> toString other+++instance ToJSON Severity where+    toJSON SError = "error"+    toJSON SWarning = "warning"+++stateLabel :: BuildPhase -> Text+stateLabel (Building _) = "building"+stateLabel Restarting = "restarting"+stateLabel (Testing _) = "testing"+stateLabel (Done result)+    | any (\m -> m.severity == SError) result.diagnostics = "error"+    | any (\m -> m.severity == SWarning) result.diagnostics = "warning"+    | otherwise = "ok"+stateLabel (BuildFailed _) = "error"+++-- | Classifies what kind of file change triggered a dirty signal.+-- 'CabalChange' takes priority over 'SourceChange': if both fire before the+-- next build starts, the session will be fully restarted rather than reloaded.+data ChangeKind = SourceChange | CabalChange deriving stock (Eq, Ord, Show)+++data CabalChangeDetected = CabalChangeDetected FilePath FileEvent+    deriving stock (Eq, Show)+data SourceChangeDetected = SourceChangeDetected FilePath FileEvent+    deriving stock (Eq, Show)+++initialBuildState :: DaemonInfo -> BuildState+initialBuildState di =+    BuildState+        { buildId = BuildId 0+        , phase = Building Nothing+        , daemonInfo = di+        }
+ src/Tricorder/Builder.hs view
@@ -0,0 +1,670 @@+module Tricorder.Builder+    ( component+    , BuildConfig (..)++      -- * Internals exposed for testing+    , NewLoadResult (..)+    , EnteringNewPhase (..)+    , compileLoadResultsIntoBuildResults+    , requestTestRunsForNewBuildResults+    , buildWithGhciOnChange+    , interruptCurrent+    , onRestart+    , reloadOnSourceChange+    , setNewPhase+    , restartOnCabalChange+    ) where++import Atelier.Component (Component (..), defaultComponent)+import Atelier.Effects.Clock (Clock, UTCTime)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Debounce (Debounce, debounced)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Publishing (Sub)+import Atelier.Time (Millisecond, nominalDiffTime)+import Control.Concurrent.STM (check, readTVar, retry, writeTVar)+import Data.Default (Default (..))+import Data.Time (diffUTCTime)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, newTVar)+import Effectful.Exception (finally, trySync)+import Effectful.Reader.Static (Reader, ask)+import Effectful.State.Static.Shared (State, get, modify, put, state)+import System.FilePath (normalise)++import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Publishing qualified as Sub+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.BuildState+    ( BuildId (..)+    , BuildPhase (..)+    , BuildResult (..)+    , CabalChangeDetected (..)+    , Diagnostic (..)+    , Severity (..)+    , SourceChangeDetected (..)+    , TestRun (..)+    )+import Tricorder.Builder.Dispatch+    ( BuilderState (..)+    , DispatchAction (..)+    , KnownTargetNames (..)+    , dispatch+    , emptyBuilderState+    , filterToWatchDirs+    , mergeDiagnostics+    )+import Tricorder.Effects.BuildStore (BuildStore)+import Tricorder.Effects.GhciSession (GhciSession, LoadResult (..))+import Tricorder.Effects.GhciSession.GhciParser (resolveKnownTargets)+import Tricorder.Effects.GhciSession.GhciProcess (GhciProcessError (..))+import Tricorder.Effects.SessionStore (SessionStore)+import Tricorder.Effects.TestRunner (TestRunner)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Session (..))++import Tricorder.Effects.BuildStore qualified as BuildStore+import Tricorder.Effects.GhciSession qualified as GhciSession+import Tricorder.Effects.SessionStore qualified as SessionStore+import Tricorder.Effects.TestRunner qualified as TestRunner+++-- | Builder component.+-- Starts a GHCi session, performs an initial load, then listens for changes+-- from the watcher.+component+    :: ( BuildStore :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce Text :> es+       , GhciSession :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , SessionStore :> es+       , State BuildId :> es+       , State BuilderState :> es+       , Sub CabalChangeDetected :> es+       , Sub SourceChangeDetected :> es+       , TestRunner :> es+       )+    => Component es+component =+    defaultComponent+        { name = "Builder"+        , listeners = pure [runBuilder defaultGhciSessionHooks]+        }+++-- | A subset of 'Session' with just the properties that 'Builder' cares about.+data BuildConfig = BuildConfig+    { command :: Text+    , targets :: [Text]+    , testTargets :: [Text]+    , watchDirs :: [FilePath]+    }+    deriving stock (Eq)+++instance Default BuildConfig where+    def =+        BuildConfig+            { command = session.command+            , targets = session.targets+            , testTargets = session.testTargets+            , watchDirs = session.watchDirs+            }+      where+        session = def @Session+++--------------------------------------------------------------------------------+-- Level 1 — Builder lifecycle: supervise the tricorder session+--------------------------------------------------------------------------------++-- | Level 1 — supervise the /tricorder session/ (the project config). For the+-- current config, run successive GHCi sessions; whenever a @.cabal@ file+-- changes, reload the config and restart everything.+--+-- Cabal-change events flip a TVar; 'restartOnCabalChange' consumes the flag,+-- runs @preRestart@ (transition to 'Restarting', reload the config),+-- then exits the inner scope which cancels the in-flight GHCi session. The next+-- iteration reloads the config via 'loadBuildConfig' and forks a fresh+-- 'runGhciSessions'.+runBuilder+    :: ( BuildStore :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce Text :> es+       , GhciSession :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , SessionStore :> es+       , State BuildId :> es+       , State BuilderState :> es+       , Sub CabalChangeDetected :> es+       , Sub SourceChangeDetected :> es+       , TestRunner :> es+       )+    => GhciSessionHooks es+    -> Eff es Void+runBuilder hooks =+    restartOnCabalChange preRestart loadBuildConfig session+  where+    -- The tricorder session's restart hook: the outer loop reloading *its own*+    -- config. This is not a GHCi-session concern, so it lives here rather than+    -- in 'GhciSessionHooks'.+    preRestart = do+        -- Flip the UI to 'Restarting' immediately so the user sees the change+        -- has been picked up before scope teardown (which kills cabal repl and+        -- waits for graceful exit).+        enterPhase Restarting+        -- Pick up cabal/package.yaml edits before the next iteration.+        SessionStore.rawReload++    session config = runGhciSessions hooks config `finally` onRestart+++-- | Read the current tricorder 'Session' and project the parts the Builder+-- cares about. Runs at the start of each restart iteration.+loadBuildConfig+    :: ( Log :> es+       , SessionStore :> es+       )+    => Eff es BuildConfig+loadBuildConfig = do+    session <- SessionStore.get+    let config =+            BuildConfig+                { command = session.command+                , targets = session.targets+                , testTargets = session.testTargets+                , watchDirs = session.watchDirs+                }+    Log.info $ "Builder.component: resolved command = " <> config.command+    pure config+++onRestart+    :: ( BuildStore :> es+       , Log :> es+       , State BuildId :> es+       )+    => Eff es ()+onRestart = do+    Log.info "Restarting builder..."+    buildId <- get+    modify @BuildId (+ 1)+    setNewPhase $ EnteringNewPhase buildId $ Building Nothing+++--------------------------------------------------------------------------------+-- Level 2 — GHCi-session lifecycle+--------------------------------------------------------------------------------++-- | The lifecycle hooks for one /GHCi session/. Each field is one moment in a+-- GHCi session's life; the coordinators below (@runGhciSessions@ /+-- @watchSourceChanges@) own the /when/, these own the /what/.+--+-- These are deliberately GHCi-session hooks only. Reloading the /tricorder+-- session/ (the project config) on a @.cabal@ change belongs to the outer loop+-- and lives inline in 'runBuilder' — keeping it out of here is what stops a+-- \"child restarting its parent\". Tests supply their own record to observe a+-- single hook in isolation.+data GhciSessionHooks es = GhciSessionHooks+    { onStart :: Eff es ()+    -- ^ A fresh GHCi session is about to launch: reset accumulated state.+    , onInitialLoad :: BuildConfig -> NewLoadResult -> Eff es ()+    -- ^ The initial load finished: run the post-load pipeline.+    , onSourceChange :: BuildConfig -> GhciSession.Controls (Eff es) -> SourceChangeDetected -> Eff es ()+    -- ^ A debounced source change arrived: run one build/test cycle.+    , onStartupFail :: SomeException -> Eff es ()+    -- ^ GHCi failed to start: surface 'BuildFailed' and wait to retry.+    }+++-- | The default GHCi-session hooks.+defaultGhciSessionHooks+    :: ( BuildStore :> es+       , Clock :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , State BuilderState :> es+       , Sub SourceChangeDetected :> es+       , TestRunner :> es+       )+    => GhciSessionHooks es+defaultGhciSessionHooks =+    GhciSessionHooks+        { onStart = put emptyBuilderState+        , onInitialLoad = afterLoad+        , onSourceChange = reloadOnSourceChange+        , onStartupFail = recoverFromStartupFailure+        }+++-- | Level 2 — run successive /GHCi sessions/ for one tricorder session, each+-- retried on startup failure. Reads top-to-bottom as a GHCi session's phases:+--+--   1. 'onStart' — reset accumulated state.+--   2. launch GHCi; on its initial load, 'onInitialLoad' runs the pipeline.+--   3. 'watchSourceChanges' — the inner loop, until the session is torn down.+--   4. 'onStartupFail' — if the launch itself threw, recover and retry.+runGhciSessions+    :: ( BuildStore :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce Text :> es+       , GhciSession :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , State BuilderState :> es+       , Sub SourceChangeDetected :> es+       , TestRunner :> es+       )+    => GhciSessionHooks es+    -> BuildConfig+    -> Eff es Void+runGhciSessions hooks config = forever do+    hooks.onStart+    root@(ProjectRoot rootPath) <- ask+    BuildId n <- get+    Log.info $ "Starting GHCi session #" <> show n <> ": " <> config.command++    startTime <- Clock.currentTime+    result <- trySync $ GhciSession.withGhci config.command root \initialLoad controls -> do+        endTime <- Clock.currentTime+        let filteredMsgs = filterToWatchDirs rootPath config.watchDirs initialLoad.diagnostics+        Log.info+            $ mconcat+                ["GHCi started (session #", show n, "): ", show (length filteredMsgs), " diagnostics"]+        hooks.onInitialLoad config NewLoadResult {startTime, endTime, loadResult = initialLoad}+        modify \s ->+            s+                { loadedModules = resolveKnownTargets Map.empty initialLoad+                , knownTargets = KnownTargetNames (Set.fromList initialLoad.targetNames)+                }+        watchSourceChanges hooks config controls+    case result of+        Right _ -> pure ()+        Left ex -> hooks.onStartupFail ex+++-- | The GHCi-session loop with the default 'defaultGhciSessionHooks'. Kept as a+-- named entry point for tests; 'runBuilder' wraps this with the tricorder+-- session's cabal-restart handling.+buildWithGhciOnChange+    :: ( BuildStore :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce Text :> es+       , GhciSession :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , State BuilderState :> es+       , Sub SourceChangeDetected :> es+       , TestRunner :> es+       )+    => BuildConfig+    -> Eff es Void+buildWithGhciOnChange = runGhciSessions defaultGhciSessionHooks+++-- | Default 'onStartupFail': surface 'BuildFailed', then wait for a source+-- change to retry the launch.+--+-- A cabal change is handled out-of-band by 'runBuilder' cancelling this scope.+-- Without the wait, a startup failure was a dead end: the user could fix the+-- offending source file and nothing would happen, because no+-- 'SourceChangeDetected' listener is active on this path.+recoverFromStartupFailure+    :: ( BuildStore :> es+       , Log :> es+       , State BuildId :> es+       , Sub SourceChangeDetected :> es+       )+    => SomeException -> Eff es ()+recoverFromStartupFailure ex = do+    Log.err $ "GHCi session failed to start: " <> show ex+    enterPhase $ BuildFailed $ renderStartupError ex+    Log.info "Build command failed; waiting for a source change to retry"+    void $ Sub.listenOnce_ @SourceChangeDetected+++--------------------------------------------------------------------------------+-- Level 3 — Source-change loop and build/test cycle+--------------------------------------------------------------------------------++-- | Level 3 — the inner loop. Wait for source changes and drive one build/test+-- cycle ('onSourceChange') per change.+--+-- Coalesce debounced source-change events through a single-slot register: the+-- debounced listener writes the latest event into the slot, and a single worker+-- fork drains it. Events that arrive while the worker is processing the previous+-- one simply overwrite the slot, so a burst of N touches collapses into exactly+-- one trailing cycle (carrying the most recent event) rather than queueing N+-- back-to-back cycles. This matters whenever 'interruptCurrent' can't drop the+-- in-flight cycle promptly — e.g. when a 'status --wait' caller has registered+-- as a waiter, gating 'interruptCurrent' to a no-op.+watchSourceChanges+    :: ( BuildStore :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce Text :> es+       , Log :> es+       , State BuildId :> es+       , Sub SourceChangeDetected :> es+       , TestRunner :> es+       )+    => GhciSessionHooks es+    -> BuildConfig+    -> GhciSession.Controls (Eff es)+    -> Eff es Void+watchSourceChanges hooks config controls = Conc.scoped do+    BuildId n <- get+    Log.debug $ "Builder: waiting for dirty flag (build #" <> show n <> ")"+    forever $ Conc.scoped do+        pending <- atomically (newTVar @(Maybe SourceChangeDetected) Nothing)+        Conc.fork_ $ Sub.listen_ \ev ->+            debounced 200 "source_change_reloader"+                $ atomically (writeTVar pending (Just ev))+        Conc.fork_ $ Sub.listen_ \_ -> interruptCurrent controls+        Conc.fork_ $ forever do+            ev <- atomically do+                readTVar pending >>= \case+                    Nothing -> retry+                    Just e -> writeTVar pending Nothing >> pure e+            hooks.onSourceChange config controls ev+        Conc.awaitAll+++-- 'controls.interrupt' is a safe no-op when GHCi is idle, and 'GhciSession'+-- serialises subsequent reloads through its own STM state.+interruptCurrent+    :: ( BuildStore :> es+       , Log :> es+       , TestRunner :> es+       )+    => GhciSession.Controls (Eff es) -> Eff es ()+interruptCurrent controls = do+    hasWaiters <- BuildStore.hasWaiters+    unless hasWaiters do+        Log.info "Change detected with no waiters. Interrupting current build/tests."+        controls.interrupt+        TestRunner.interruptCurrent+++reloadOnSourceChange+    :: ( BuildStore :> es+       , Clock :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , State BuilderState :> es+       , TestRunner :> es+       )+    => BuildConfig+    -> GhciSession.Controls (Eff es)+    -> SourceChangeDetected+    -> Eff es ()+reloadOnSourceChange config controls (SourceChangeDetected fp event) = do+    Log.debug $ "Builder: source change detected " <> show event <> " " <> toText fp+    builderState <- get @BuilderState+    let known = Map.lookup (normalise fp) builderState.loadedModules+    case dispatch builderState.knownTargets known fp event of+        Nothing ->+            Log.debug+                $ "Builder: no-op for "+                    <> show event+                    <> " of file not loaded in GHCi: "+                    <> toText fp+        Just action -> do+            enterPhase $ Building Nothing++            res <- trySync do+                startTime <- Clock.currentTime+                res <- runAction controls action+                endTime <- Clock.currentTime+                pure (startTime, endTime, res)++            case res of+                Left e -> do+                    now <- Clock.currentTime+                    Log.err $ show now <> " Reload errored: " <> show e+                    -- Resolve the UI instead of stranding it in 'Building': a+                    -- reload that errors (rather than producing a result) must+                    -- not leave the daemon stuck until the next source change+                    -- happens to arrive and succeed.+                    enterPhase $ BuildFailed $ "Reload failed: " <> toText (displayException e)+                Right (startTime, endTime, loadResult) -> do+                    modify \s ->+                        s+                            { loadedModules = resolveKnownTargets s.loadedModules loadResult+                            , knownTargets = KnownTargetNames (Set.fromList loadResult.targetNames)+                            }+                    afterLoad config NewLoadResult {startTime, endTime, loadResult}+++runAction :: GhciSession.Controls (Eff es) -> DispatchAction -> Eff es LoadResult+runAction controls = \case+    Reload -> controls.reload+    Add fp -> controls.add fp+    Unadd mn -> controls.unadd mn+++-- | Run the post-load pipeline synchronously: compile diagnostics into a+-- 'BuildResult', then (optionally) run tests and transition through the+-- corresponding phases.+afterLoad+    :: ( BuildStore :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , State BuilderState :> es+       , TestRunner :> es+       )+    => BuildConfig -> NewLoadResult -> Eff es ()+afterLoad config newLoadResult = do+    buildResult <- compileLoadResultsIntoBuildResults config newLoadResult+    requestTestRunsForNewBuildResults config buildResult+++compileLoadResultsIntoBuildResults+    :: ( Reader ProjectRoot :> es+       , State BuilderState :> es+       )+    => BuildConfig+    -> NewLoadResult+    -> Eff es BuildResult+compileLoadResultsIntoBuildResults session newLoadResult = do+    ProjectRoot projectRoot <- ask+    let filteredResult =+            loadResult+                { GhciSession.diagnostics =+                    filterToWatchDirs projectRoot watchDirs loadResult.diagnostics+                }++    newAccumulated <- state \s ->+        let merged = mergeDiagnostics s.diagnosticMap filteredResult+        in  (merged, s {diagnosticMap = merged})++    pure+        BuildResult+            { completedAt = endTime+            , duration = nominalDiffTime (diffUTCTime endTime startTime) :: Millisecond+            , moduleCount = loadResult.moduleCount+            , diagnostics = sortOn (\d -> (d.severity, d.file, d.line, d.col)) $ concat (Map.elems newAccumulated)+            , testRuns = []+            }+  where+    BuildConfig {watchDirs} = session+    NewLoadResult {startTime, endTime, loadResult} = newLoadResult+++requestTestRunsForNewBuildResults+    :: ( BuildStore :> es+       , Log :> es+       , State BuildId :> es+       , TestRunner :> es+       )+    => BuildConfig+    -> BuildResult+    -> Eff es ()+requestTestRunsForNewBuildResults config partialResult = do+    buildId <- get+    runTestsIfClean config buildId partialResult >>= \case+        Nothing -> Log.info "Test run aborted by source change; skipping Done transition."+        Just testRuns ->+            setNewPhase $ EnteringNewPhase buildId $ Done partialResult {testRuns}+++-- Run all configured test suites if the build has no errors.+-- Transitions to 'Testing' phase while suites are running.+--+-- Returns 'Nothing' if the run was aborted mid-flight by a source change+-- (the caller should not transition to a Done phase in that case). Returns+-- 'Just' with the collected results otherwise.+runTestsIfClean+    :: ( BuildStore :> es+       , Log :> es+       , TestRunner :> es+       )+    => BuildConfig+    -> BuildId+    -> BuildResult+    -> Eff es (Maybe [TestRun])+runTestsIfClean (BuildConfig {testTargets}) bid partialResult+    | null testTargets || any (\d -> d.severity == SError) partialResult.diagnostics = pure (Just [])+    | otherwise = do+        TestRunner.resetAbort+        setNewPhase+            $ EnteringNewPhase bid+            $ Testing partialResult {testRuns = map (`TestRunning` Nothing) testTargets}++        Log.info $ "Running " <> show (length testTargets) <> " test suite(s)"++        let initial = (\t -> (t, TestRunning t Nothing)) <$> testTargets+        runLoop initial testTargets+  where+    runLoop acc [] = pure (Just (snd <$> acc))+    runLoop acc (target : rest) = do+        Log.info $ "Running tests: " <> target+        result <- TestRunner.runTestSuite target+        aborted <- TestRunner.isAborted+        if aborted then+            pure Nothing+        else do+            let acc' = insert target result acc+            setNewPhase+                $ EnteringNewPhase bid+                $ Testing partialResult {testRuns = snd <$> acc'}+            runLoop acc' rest++    insert _ _ [] = []+    insert k v ((k', v') : xs)+        | k == k' = (k, v) : xs+        | otherwise = (k', v') : insert k v xs+++--------------------------------------------------------------------------------+-- Restart machinery+--------------------------------------------------------------------------------++-- | Run @action@ in a loop that restarts whenever a 'CabalChangeDetected'+-- event arrives. At most one iteration of @action@ runs at any moment: cabal+-- events arriving during a restart collapse into a single next iteration.+--+-- A TVar flag funnels the events: the cabal listener writes 'True' to it; a+-- single coordinator drains it via 'restartableForkWith', runs @preRestart@,+-- and exits the inner scope. Scope teardown cancels the current @action@+-- (including the 'cabal repl' subprocess via its bracket) and waits for it to+-- finish before the next iteration starts — so we never have two builders+-- racing for the same dist-newstyle directory.+restartOnCabalChange+    :: ( Conc :> es+       , Concurrent :> es+       , Log :> es+       , Sub CabalChangeDetected :> es+       )+    => Eff es ()+    -- ^ Pre-restart hook: runs in the coordinator thread after the flag has+    -- been drained but before the inner scope is torn down. Use this to set+    -- the UI to 'Restarting' and reload the session.+    -> Eff es r+    -- ^ Setup: runs at the start of each iteration, before @action@ is forked.+    -> (r -> Eff es Void)+    -- ^ Inner action. Must never return.+    -> Eff es Void+restartOnCabalChange preRestart setup action = do+    needsRestart <- atomically (newTVar False)+    Conc.scoped do+        Conc.fork_ $ Conc.restartableForkWith (signal needsRestart) setup action+        Sub.listen_ @CabalChangeDetected $ \(CabalChangeDetected path event) -> do+            Log.info $ "Cabal file changed (" <> show event <> " " <> toText path <> "); queued restart"+            atomically (writeTVar needsRestart True)+  where+    signal needsRestart = do+        atomically do+            check =<< readTVar needsRestart+            writeTVar needsRestart False+        preRestart+++--------------------------------------------------------------------------------+-- Phase-transition helpers+--------------------------------------------------------------------------------++setNewPhase+    :: (BuildStore :> es)+    => EnteringNewPhase -> Eff es ()+setNewPhase (EnteringNewPhase bid phase) =+    BuildStore.setPhase bid phase+++-- | Transition the /current/ build into @phase@.+enterPhase+    :: ( BuildStore :> es+       , State BuildId :> es+       )+    => BuildPhase -> Eff es ()+enterPhase phase = do+    buildId <- get+    setNewPhase $ EnteringNewPhase buildId phase+++renderStartupError :: SomeException -> Text+renderStartupError ex = case fromException ex of+    Just (StartupFailed msg) -> msg+    Just StartupTimeout -> "Build command did not produce a GHCi banner before timing out."+    Just (UnexpectedExit cmd lastLine) ->+        "Build command exited unexpectedly: "+            <> cmd+            <> maybe "" (\l -> "\n" <> l) lastLine+    Nothing -> toText (displayException ex)+++--------------------------------------------------------------------------------+-- Supporting types+--------------------------------------------------------------------------------++data NewLoadResult = NewLoadResult+    { startTime :: UTCTime+    , endTime :: UTCTime+    , loadResult :: LoadResult+    }+    deriving stock (Eq, Show)+++-- | A pending phase transition. Carried by 'setNewPhase' into the 'BuildStore'.+data EnteringNewPhase = EnteringNewPhase BuildId BuildPhase+    deriving stock (Eq, Show)
+ src/Tricorder/Builder/Dispatch.hs view
@@ -0,0 +1,138 @@+module Tricorder.Builder.Dispatch+    ( BuilderState (..)+    , DiagnosticMap+    , DispatchAction (..)+    , KnownTargetNames (..)+    , dispatch+    , emptyBuilderState+    , fileMatchesAnyTarget+    , filterToWatchDirs+    , mergeDiagnostics+    ) where++import Atelier.Effects.FileWatcher (FileEvent (..))+import Data.Default (Default (..))+import System.FilePath (isAbsolute, (</>))++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.BuildState (Diagnostic (..))+import Tricorder.Effects.GhciSession (LoadResult (..), LoadedModule (..))+import Tricorder.Effects.GhciSession.GhciParser (pathSuffixesAsModuleName)+++-- | The Builder's per-GHCi-session cache: what it last saw from GHCi plus its+-- accumulated diagnostics. Reset on every GHCi restart in+-- @buildWithGhciOnChange@; 'BuildId' is intentionally /not/ here because it+-- counts across restarts.+data BuilderState = BuilderState+    { loadedModules :: Map FilePath LoadedModule+    , knownTargets :: KnownTargetNames+    , diagnosticMap :: DiagnosticMap+    }+    deriving stock (Eq, Show)+++instance Default BuilderState where+    def = emptyBuilderState+++emptyBuilderState :: BuilderState+emptyBuilderState =+    BuilderState+        { loadedModules = mempty+        , knownTargets = KnownTargetNames mempty+        , diagnosticMap = mempty+        }+++type DiagnosticMap = Map FilePath [Diagnostic]+++-- | Merge a new 'LoadResult' into the accumulated per-file diagnostic map.+--+-- Files in 'compiledFiles' have their previous diagnostics cleared and replaced+-- 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.+mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap+mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} =+    let cleared = foldr Map.delete prev compiledFiles+        newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics]+    in  Map.union newByFile cleared+++-- | GHCi's current target set, as raw entries from @:show targets@+-- (typically dotted module names under @cabal repl --enable-multi-repl@).+-- Survives every compile failure mode, so the dispatcher can recognise a+-- target even when it's absent from the path-keyed module map.+newtype KnownTargetNames = KnownTargetNames {unKnownTargetNames :: Set Text}+    deriving stock (Eq, Show)+++-- | Whether a file path corresponds to one of GHCi's targets.+fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool+fileMatchesAnyTarget (KnownTargetNames targets) fp =+    any (`Set.member` targets) (pathSuffixesAsModuleName fp)+++-- | A GHCi command to issue in response to a source file change.+data DispatchAction+    = Reload+    | Add FilePath+    | Unadd Text+    deriving stock (Eq, Show)+++-- | Decide what GHCi action a source-file change requires.+--+-- The path-keyed module map misses targets that failed on first load,+-- so we fall back to 'KnownTargetNames' for those — otherwise we would+-- issue @:add@ (a no-op for an already-tracked cabal target), leaving+-- stale diagnostics in place.+dispatch+    :: KnownTargetNames+    -> Maybe LoadedModule+    -> FilePath+    -> FileEvent+    -> Maybe DispatchAction+dispatch knownTargets known fp event = case known of+    Just lm -> Just $ case event of+        Added -> Reload+        Modified -> Reload+        Removed -> Unadd lm.moduleName+    Nothing+        | fileMatchesAnyTarget knownTargets fp -> case event of+            Added -> Just Reload+            Modified -> Just Reload+            Removed -> Nothing+        | otherwise -> case event of+            Added -> Just (Add fp)+            Modified -> Just (Add fp)+            Removed -> Nothing+++-- | Keep only diagnostics whose file is under one of the watched directories.+--+-- Diagnostics from outside the project (e.g. @.h@ files in the Nix store) and+-- 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+  where+    absWatchDirs = map toAbsWd watchDirs+    toAbsWd wd+        | wd == "." = projectRoot+        | isAbsolute wd = wd+        | otherwise = projectRoot </> wd+    isUnderAnyWatchDir file+        | not (isAbsolute file) && not ("./" `isPrefixOf` file) = False+        | isAbsolute file =+            any (\wd -> (wd ++ "/") `isPrefixOf` file || wd == file) absWatchDirs+        | otherwise =+            let absFile = projectRoot </> drop 2 file+            in  any (\wd -> (wd ++ "/") `isPrefixOf` absFile || wd == absFile) absWatchDirs
+ src/Tricorder/CLI.hs view
@@ -0,0 +1,281 @@+module Tricorder.CLI+    ( showLog+    , showSource+    , showStatus+    , showTests+    ) where++import Atelier.Effects.Clock (Clock, currentTimeZone)+import Atelier.Effects.Console (Console)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Exit (Exit, exitFailure)+import Atelier.Effects.File (File)+import Atelier.Effects.FileSystem (FileSystem, doesFileExist, followFile, readFileLbs)+import Data.Aeson (encode)+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Time.LocalTime (utcToLocalTime)+import Effectful.Reader.Static (Reader, ask)++import Atelier.Effects.Console qualified as Console+import Data.ByteString.Lazy qualified as BSL+import Data.Text qualified as T++import Tricorder.Arguments+    ( FollowMode (..)+    , OutputFormat (..)+    , StatusOptions (..)+    , TestOptions (..)+    , Verbosity (..)+    , WaitMode (..)+    )+import Tricorder.BuildState+    ( BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , BuildState (..)+    , Diagnostic (..)+    , Severity (..)+    , TestCase (..)+    , TestCaseOutcome (..)+    , TestRun (..)+    , TestRunCompletion (..)+    , TestRunError (..)+    )+import Tricorder.CLI.Render+    ( diagnosticLineIndexed+    , formatDuration+    , renderSourceResults+    )+import Tricorder.Effects.UnixSocket (UnixSocket)+import Tricorder.GhcPkg.Types (SourceQuery)+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Socket.Client+    ( querySource+    , queryStatus+    , queryStatusWait+    )+import Tricorder.TestOutput (stripGhciNoise)+++-- | Print a build-command failure message and exit non-zero.+reportBuildFailed :: (Console :> es, Exit :> es) => Text -> Eff es a+reportBuildFailed msg = do+    Console.putTextLn "Build command failed:"+    Console.putTextLn msg+    exitFailure+++showStatus+    :: ( Clock :> es+       , Console :> es+       , Exit :> es+       , File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => StatusOptions -> Eff es ()+showStatus opts = do+    SocketPath sockPath <- ask+    when (opts.wait == WaitForBuild && opts.format == TextOutput) $ do+        current <- queryStatus sockPath+        case current of+            Right BuildState {phase = Building _} -> Console.putStrLn "Building..."+            Right BuildState {phase = Restarting} -> Console.putStrLn "Restarting..."+            Right BuildState {phase = Testing _} -> Console.putStrLn "Testing..."+            _ -> pure ()+    result <-+        case opts.wait of+            WaitForBuild -> queryStatusWait sockPath+            ShowCurrent -> queryStatus sockPath+    case result of+        Left err -> Console.putTextLn $ "Error: " <> err+        Right state ->+            case opts.format of+                JsonOutput -> do+                    Console.putStr $ BSL.toStrict $ encode state+                    Console.putStrLn ""+                TextOutput ->+                    renderText opts.verbosity opts.expand state+  where+    renderText verbosity expand state = case state.phase of+        Building _ -> Console.putStrLn "Building..."+        Restarting -> Console.putStrLn "Restarting..."+        Testing _ -> Console.putStrLn "Testing..."+        BuildFailed msg -> reportBuildFailed msg+        Done r -> do+            tz <- currentTimeZone+            case expand of+                Just n ->+                    case r.diagnostics !!? (n - 1) of+                        Nothing ->+                            Console.putTextLn+                                $ "No diagnostic #"+                                    <> show n+                                    <> " (current build has "+                                    <> show (length r.diagnostics)+                                    <> ")"+                        Just d -> do+                            Console.putTextLn $ diagnosticLineIndexed n d+                            Console.putText d.text+                Nothing -> do+                    let printDiag (i, d) = case verbosity of+                            Verbose -> do+                                Console.putTextLn $ diagnosticLineIndexed i d+                                Console.putText d.text+                            Concise ->+                                Console.putTextLn $ diagnosticLineIndexed i d+                    mapM_ printDiag (zip [1 ..] r.diagnostics)+                    Console.putTextLn $ buildSummary tz r+                    mapM_ (printTestRun verbosity) r.testRuns+                    when (buildHasErrors r || testsFailed r) exitFailure++    printTestRun verbosity tr = do+        Console.putTextLn $ case tr of+            TestRunning t Nothing -> t <> "  running..."+            TestRunning t (Just p) -> t <> "  running... (" <> show p.compiled <> "/" <> show p.total <> ")"+            TestRunErrored e -> e.target <> "  error: " <> e.message+            TestRunCompleted c -> c.target <> "  " <> completionSummary c+        when (verbosity == Verbose) $ case tr of+            TestRunCompleted c ->+                mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (T.lines c.output))+            _ -> pure ()++    buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics+    testsFailed r = any isFailedRun r.testRuns+      where+        isFailedRun (TestRunCompleted c) = not c.passed+        isFailedRun (TestRunErrored _) = True+        isFailedRun (TestRunning _ _) = False++    buildSummary tz r =+        let errs = length $ filter ((== SError) . (.severity)) r.diagnostics+            warns = length $ filter ((== SWarning) . (.severity)) r.diagnostics+            ts = toText $ "— " <> formatTime defaultTimeLocale "%H:%M:%S" (utcToLocalTime tz r.completedAt)+            stats = toText $ "(" <> show r.moduleCount <> " modules, " <> formatDuration r.duration <> ")"+        in  if null r.diagnostics then+                "All good. " <> stats <> " " <> ts+            else+                show errs <> " error(s), " <> show warns <> " warning(s) " <> stats <> " " <> ts+++completionSummary :: TestRunCompletion -> Text+completionSummary c = statusText <> maybe "" (\d -> " (" <> formatDuration d <> ")") c.duration+  where+    statusText+        | null c.testCases = if c.passed then "passed" else "failed"+        | otherwise =+            let total = length c.testCases+                failedCount = length $ filter isFailedCase c.testCases+            in  if failedCount == 0 then+                    "passed (" <> show total <> ")"+                else+                    show failedCount <> "/" <> show total <> " failed"+    isFailedCase (TestCase _ (TestCaseFailed _)) = True+    isFailedCase _ = False+++showLog+    :: ( Console :> es+       , Delay :> es+       , FileSystem :> es+       )+    => FilePath -> FollowMode -> Eff es ()+showLog path followMode = do+    exists <- doesFileExist path+    if not exists then+        Console.putTextLn $ "Log file does not exist yet: " <> toText path+    else case followMode of+        Follow -> followFile path Console.putStr+        NoFollow -> readFileLbs path >>= Console.putStr . BSL.toStrict+++showTests+    :: ( Console :> es+       , Exit :> es+       , File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => TestOptions -> Eff es ()+showTests opts = do+    SocketPath sockPath <- ask+    result <-+        case opts.wait of+            WaitForBuild -> queryStatusWait sockPath+            ShowCurrent -> queryStatus sockPath+    case result of+        Left err -> Console.putTextLn $ "Error: " <> err+        Right state ->+            case state.phase of+                Building _ -> Console.putStrLn "Build in progress, no test results yet."+                Restarting -> Console.putStrLn "Daemon restarting, no test results yet."+                Testing r -> renderTestRuns r.testRuns+                Done r -> renderTestRuns r.testRuns+                BuildFailed msg -> reportBuildFailed msg+  where+    renderTestRuns [] = Console.putStrLn "No test results."+    renderTestRuns testRuns+        | null runs = do+            Console.putStrLn "All passed."+            mapM_ (Console.putTextLn . ("  " <>) . testRunTarget) testRuns+        | otherwise = do+            mapM_ printTestOutput runs+            when (any isFailed runs) exitFailure+      where+        runs =+            if opts.failedOnly then+                filter isFailed testRuns+            else+                testRuns++    isFailed (TestRunCompleted c) = not c.passed+    isFailed (TestRunErrored _) = True+    isFailed (TestRunning _ _) = False++    testRunTarget (TestRunning t _) = t+    testRunTarget (TestRunErrored e) = e.target+    testRunTarget (TestRunCompleted c) = c.target++    printTestOutput tr = case tr of+        TestRunning t Nothing ->+            Console.putTextLn $ t <> "  running..."+        TestRunning t (Just p) ->+            Console.putTextLn $ t <> "  running... (" <> show p.compiled <> "/" <> show p.total <> ")"+        TestRunErrored e ->+            Console.putTextLn $ e.target <> "  error: " <> e.message+        TestRunCompleted c -> do+            Console.putTextLn $ c.target <> "  " <> completionSummary c+            if opts.failedOnly then+                if null c.testCases then do+                    Console.putTextLn "  (unrecognised test runner format — showing full output)"+                    mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (lines c.output))+                else+                    mapM_ printFailedCase (filter isCaseFailed c.testCases)+            else+                mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (lines c.output))++    isCaseFailed (TestCase _ (TestCaseFailed _)) = True+    isCaseFailed _ = False++    printFailedCase tc = do+        Console.putTextLn $ "  " <> tc.description+        case tc.outcome of+            TestCaseFailed details ->+                mapM_ (Console.putTextLn . ("    " <>)) (T.lines details)+            TestCasePassed -> pure ()+++showSource+    :: ( Console :> es+       , File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => [SourceQuery]+    -> Eff es ()+showSource queries = do+    SocketPath sockPath <- ask+    result <- querySource sockPath queries+    case result of+        Left err -> Console.putTextLn $ "Error: " <> err+        Right results -> renderSourceResults results
+ src/Tricorder/CLI/Main.hs view
@@ -0,0 +1,53 @@+module Tricorder.CLI.Main (main) where++import Atelier.Config (runConfig)+import Atelier.Effects.Arguments (runArgumentsIO)+import Atelier.Effects.Clock (runClock)+import Atelier.Effects.Conc (runConc)+import Atelier.Effects.Console (runConsole)+import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.Exit (runExit)+import Atelier.Effects.File (runFile)+import Atelier.Effects.FileSystem (runFileSystemIO)+import Atelier.Effects.Posix.Daemons (runDaemons)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Timeout (runTimeout)++import Tricorder.Arguments (runArguments)+import Tricorder.Config (runLoadedConfig)+import Tricorder.Effects.Brick (runBrick)+import Tricorder.Effects.BrickChan (runBrickChan)+import Tricorder.Effects.UnixSocket (runUnixSocketIO)+import Tricorder.Runtime (runLogPath, runPidFile, runProjectRoot, runRuntimeDir, runSocketPath)++import Tricorder qualified+import Tricorder.UI.Keys qualified as Keys+++main :: IO ()+main =+    runEff+        . runTimeout+        . runConcurrent+        . runConc+        . runBrickChan+        . runBrick+        . runConsole+        . runExit+        . runClock+        . runDelay+        . runFile+        . runFileSystemIO+        . runProjectRoot+        . runRuntimeDir+        . runPidFile+        . runSocketPath+        . runLogPath+        . runLoadedConfig+        . runConfig @"keybindings" @Keys.Config+        . runDaemons+        . runArgumentsIO+        . runArguments+        . runUnixSocketIO+        $ Tricorder.run
+ src/Tricorder/CLI/Render.hs view
@@ -0,0 +1,94 @@+module Tricorder.CLI.Render+    ( -- * Plain-text formatting+      diagnosticLine+    , diagnosticLineIndexed+    , diagnosticBlock+    , formatDuration+    , renderSourceResults+    ) where++import Atelier.Effects.Console (Console)+import Atelier.Time (Millisecond, toMicroseconds)++import Atelier.Effects.Console qualified as Console+import Data.Text qualified as T++import Tricorder.BuildState+    ( Diagnostic (..)+    , Severity (..)+    )+import Tricorder.GhcPkg.Types (ModuleName (..), PackageId (..))+import Tricorder.SourceLookup (ModuleSourceResult (..), ReExport (..), SourceQuery (..))+++formatDuration :: Millisecond -> Text+formatDuration d =+    let ms = toMicroseconds d `div` 1000+    in  if ms < 1000 then+            show ms <> "ms"+        else+            show (ms `div` 1000) <> "." <> show ((ms `mod` 1000) `div` 100) <> "s"+++-- | Single-line diagnostic for plain-text / shell output.+--+-- Format: @E src\/Foo\/Bar.hs:42 \`something\` not in scope@+diagnosticLine :: Diagnostic -> Text+diagnosticLine d =+    prefix d.severity <> " " <> toText d.file <> ":" <> show d.line <> " " <> d.title+  where+    prefix SError = "E"+    prefix SWarning = "W"+++-- | Like 'diagnosticLine' but prefixed with a 1-based index.+--+-- Format: @[N] E src\/Foo\/Bar.hs:42 \`something\` not in scope@+diagnosticLineIndexed :: Int -> Diagnostic -> Text+diagnosticLineIndexed n d = "[" <> show n <> "] " <> diagnosticLine d+++-- | One-liner followed by the full GHC message body (verbose mode).+diagnosticBlock :: Diagnostic -> Text+diagnosticBlock d = diagnosticLine d <> "\n" <> d.text+++renderSourceResults :: (Console :> es) => [ModuleSourceResult] -> Eff es ()+renderSourceResults results = mapM_ renderOne results+  where+    renderOne (SourceFound query src reExports) = do+        when (length results > 1) $ Console.putTextLn $ header query+        Console.putText src+        unless (null reExports || isJust query.function)+            $ Console.putTextLn+            $ "\n-- Re-exports: " <> T.intercalate ", " (map renderReExport reExports)+        when (length results > 1) $ Console.putStrLn ""+    renderOne (SourceNotFound query) =+        Console.putTextLn+            $ "Not found: "+                <> unModuleName query.moduleName+                <> " (module not in any installed package)"+    renderOne (SourceNoHaddock query pkgId) =+        Console.putTextLn+            $ "No source available: "+                <> unModuleName query.moduleName+                <> " (package "+                <> unPackageId pkgId+                <> " was built without documentation; try `cabal get "+                <> unPackageId pkgId+                <> "`)"+    renderOne (FunctionNotFound query) =+        Console.putTextLn+            $ "tricorder: "+                <> unModuleName query.moduleName+                <> "#"+                <> fromMaybe "" query.function+                <> ": function not found in module source"++    header query =+        "-- "+            <> unModuleName query.moduleName+            <> maybe "" ("#" <>) query.function++    renderReExport (ReExportModule m) = "module " <> m+    renderReExport (ReExportName name src) = name <> " (from " <> src <> ")"
+ src/Tricorder/Config.hs view
@@ -0,0 +1,81 @@+module Tricorder.Config+    ( LoadedConfig (..)+    , runLoadedConfig+    , restartOnConfigChange+    ) where++import Atelier.Config (LoadedConfig (..))+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Debounce (Debounce)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.FileWatcher (FileWatcher)+import Data.List (isSuffixOf)+import Effectful.Concurrent.MVar (Concurrent, newEmptyMVar, putMVar, takeMVar)+import Effectful.Reader.Static (Reader, ask, runReader)+import System.FilePath ((</>))++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.FileSystem qualified as FileSystem+import Atelier.Effects.FileWatcher qualified as FileWatcher+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.Yaml qualified as Yaml++import Tricorder.Runtime (ProjectRoot (..))+++-- | Load config from .tricorder.yaml in the project root.+-- Falls back to empty config (all defaults) if the file is absent or cannot be parsed.+loadTricorderConfig :: (FileSystem :> es) => FilePath -> Eff es LoadedConfig+loadTricorderConfig projectRoot = do+    exists <- FileSystem.doesFileExist yamlPath+    if not exists then+        pure $ LoadedConfig (Aeson.Object KM.empty)+    else do+        bs <- FileSystem.readFileBs yamlPath+        pure . LoadedConfig $ case Yaml.decodeEither' @Aeson.Value bs of+            Left _ -> Aeson.Object KM.empty+            Right v -> v+  where+    yamlPath = projectRoot </> configFileName+++configFileName :: FilePath+configFileName = ".tricorder.yaml"+++runLoadedConfig+    :: ( FileSystem :> es+       , Reader ProjectRoot :> es+       )+    => Eff (Reader LoadedConfig : es) a -> Eff es a+runLoadedConfig act = do+    ProjectRoot projectRoot <- ask+    cfg <- loadTricorderConfig projectRoot+    runReader cfg act+++restartOnConfigChange+    :: ( Conc :> es+       , Concurrent :> es+       , Debounce FilePath :> es+       , FileWatcher :> es+       , Reader ProjectRoot :> es+       )+    => Eff es a -> Eff es a+restartOnConfigChange act = do+    ProjectRoot projectRoot <- ask+    ref <- newEmptyMVar+    var <- Conc.scoped do+        void $ Conc.fork do+            res <- act+            putMVar ref $ Just res++        Conc.fork_ $ FileWatcher.watchFilePathsDebounced+            [FileWatcher.dirWhere projectRoot (configFileName `isSuffixOf`)]+            \_ _ -> putMVar ref Nothing++        takeMVar ref+    case var of+        Nothing -> restartOnConfigChange act+        Just x -> pure x
+ src/Tricorder/Daemon.hs view
@@ -0,0 +1,97 @@+module Tricorder.Daemon+    ( startDaemon+    , stopDaemon+    , waitForDaemon+    ) where++import Atelier.Effects.Delay (Delay)+import Atelier.Effects.File (File)+import Atelier.Effects.Posix.Daemons (Daemons)+import Atelier.Time (Millisecond)+import Effectful (IOE)+import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet)+import Effectful.Reader.Static (Reader, ask)+import Effectful.Timeout (Timeout, timeout)+import Effectful.Writer.Static.Local (runWriter, tell)++import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Posix.Daemons qualified as Daemons++import Tricorder.Effects.UnixSocket (UnixSocket)+import Tricorder.Runtime (PidFile, SocketPath (..))+import Tricorder.Socket.Client (isDaemonRunning, requestShutdown)++import Tricorder.Daemon.Main qualified as Daemon.Main+++startDaemon+    :: ( Daemons :> es+       , IOE :> es+       , Reader PidFile :> es+       )+    => Eff es ()+startDaemon = do+    pidFile <- ask+    Daemons.daemonize pidFile $ liftIO Daemon.Main.main+++-- | Attempts to stop the daemon in progressively more forceful ways.+-- 1. First attempts to make the daemon stop using the API.+-- 2. Then attempts to stop the daemon by sending `SIGKILL` to its process.+stopDaemon+    :: ( Daemons :> es+       , Delay :> es+       , File :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , Timeout :> es+       , UnixSocket :> es+       )+    => Eff es (Either [Text] Text)+stopDaemon = do+    SocketPath sockPath <- ask+    pidFile <- ask+    res <-+        runWriter @[Text]+            $ fmap rightToMaybe+            $ runNonDet OnEmptyKeep+            $ requestStop sockPath pidFile+                <|> sendKill pidFile+    case res of+        (Just r, _) -> pure $ Right r+        (Nothing, es) -> pure $ Left es+  where+    requestStop sockPath pidFile = do+        timeout1second (requestShutdown sockPath) >>= \_ -> do+            didStop <- fmap isJust $ timeout 3_000_000 $ waitForStop pidFile+            if didStop then+                pure "Daemon stopped."+            else do+                tell ["Daemon did not stop as requested."]+                emptyEff++    sendKill pidFile = do+        timeout1second (Daemons.forceKillAndWait pidFile) >>= \case+            Nothing -> pure "Daemon stopped with SIGKILL."+            Just ex -> do+                tell ["Daemon did not respond to SIGKILL: " <> show ex]+                emptyEff++    timeout1second = fmap (join . fmap rightToMaybe) . timeout 1_000_000++    waitForStop :: forall es'. (Daemons :> es', Delay :> es') => PidFile -> Eff es' ()+    waitForStop pidFile = fix \rec -> do+        running <- Daemons.isRunning pidFile+        if running then do+            Delay.wait (500 :: Millisecond)+            rec+        else+            pure ()+++-- | Poll until the daemon socket becomes connectable.+waitForDaemon :: (Daemons :> es, Delay :> es, Reader PidFile :> es, UnixSocket :> es) => Eff es ()+waitForDaemon = do+    Delay.wait (200 :: Millisecond)+    running <- isDaemonRunning+    unless running waitForDaemon
+ src/Tricorder/Daemon/Main.hs view
@@ -0,0 +1,104 @@+module Tricorder.Daemon.Main (main) where++import Atelier.Component (runSystem)+import Atelier.Config (runConfig)+import Atelier.Effects.Cache (runCacheTtl)+import Atelier.Effects.Chan (runChan)+import Atelier.Effects.Clock (runClock)+import Atelier.Effects.Conc (runConc)+import Atelier.Effects.Debounce (runDebounce)+import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.Exit (runExit)+import Atelier.Effects.File (runFile)+import Atelier.Effects.FileSystem (runFileSystemIO)+import Atelier.Effects.FileWatcher (runFileWatcherIO)+import Atelier.Effects.Monitoring.Metrics.Server (runMetricsServerIO)+import Atelier.Effects.Monitoring.Tracing (TracingConfig, runTracingFromConfig)+import Atelier.Effects.Process (runProcessIO)+import Atelier.Effects.Publishing (runPubSub)+import Atelier.Effects.Timeout (runTimeout)+import Data.Default (def)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Reader.Static (runReader)+import Effectful.State.Static.Shared (evalState)++import Atelier.Effects.Cache.Config qualified as CacheConfig+import Atelier.Effects.Log qualified as Log++import Tricorder.BuildState (BuildId (..), runDaemonInfo)+import Tricorder.Config (restartOnConfigChange, runLoadedConfig)+import Tricorder.Effects.BuildStore (runBuildStore)+import Tricorder.Effects.GhcPkg (runGhcPkgIO)+import Tricorder.Effects.GhciSession (runGhciSession)+import Tricorder.Effects.Logging (runLogging)+import Tricorder.Effects.SessionStore (runSessionStore)+import Tricorder.Effects.TestRunner (runTestRunnerIO)+import Tricorder.Effects.UnixSocket (runUnixSocketIO)+import Tricorder.Runtime (runLogPath, runProjectRoot, runRuntimeDir, runSocketPath)++import Tricorder.BuildState qualified as BuildState+import Tricorder.Builder qualified as Builder+import Tricorder.Builder.Dispatch qualified as Dispatch+import Tricorder.Effects.SessionStore qualified as SessionStore+import Tricorder.GhcPkg.Types qualified as GhcPkg+import Tricorder.Observability qualified as Observability+import Tricorder.Socket.Server qualified as SocketServer+import Tricorder.SourceLookup qualified as SourceLookup+import Tricorder.Version qualified as Version+import Tricorder.Watcher qualified as Watcher+++-- | Run the daemon for the given project root.+-- Blocks forever; all work happens inside the component system.+main :: IO ()+main =+    runEff+        . runConcurrent+        . runConc+        . runClock+        . runDelay+        . runTimeout+        . runDebounce @FilePath+        . runDebounce @Text+        . runFileWatcherIO+        . runFileSystemIO+        . runProjectRoot+        . restartOnConfigChange+        . runExit+        . runFile+        . runRuntimeDir+        . runSocketPath+        . runLogPath+        . runLogging+        . runLoadedConfig+        . runConfig @"observability" @Observability.Config+        . runConfig @"observability.tracing" @TracingConfig+        . runTracingFromConfig+        . runChan+        . runPubSub @SessionStore.SessionStoreReloaded+        . runSessionStore+        . runReader @CacheConfig.Config def+        . runPubSub @Watcher.WatchedFile+        . runPubSub @BuildState.CabalChangeDetected+        . runPubSub @BuildState.SourceChangeDetected+        . runDaemonInfo+        . runCacheTtl @GhcPkg.ModuleName @GhcPkg.PackageId+        . runCacheTtl @(GhcPkg.PackageId, GhcPkg.SourceQuery) @(Text, [SourceLookup.ReExport])+        . runBuildStore+        . runProcessIO+        . runMetricsServerIO+        . runTestRunnerIO+        . runGhcPkgIO+        . runUnixSocketIO+        . runGhciSession+        . evalState (BuildId 1)+        . evalState @Dispatch.BuilderState Dispatch.emptyBuilderState+        $ do+            Log.info $ "Starting tricorder " <> Version.gitHash+            runSystem+                [ Observability.component+                , Watcher.component+                , Builder.component+                , SocketServer.component+                ]
+ src/Tricorder/Effects/Brick.hs view
@@ -0,0 +1,48 @@+module Tricorder.Effects.Brick+    ( -- * Brick+      Brick+    , runBrickApp+    , runBrick+    ) where++import Brick.Main (App, customMain)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)+import Graphics.Vty (Mode (Mouse), outputIface, setMode)+import Graphics.Vty.Config (userConfig)+import Graphics.Vty.CrossPlatform (mkVty)++import Tricorder.Effects.BrickChan (BChan)+++data Brick :: Effect where+    RunBrickApp+        :: (Ord resource)+        => BChan event+        -- ^ Channel for publishing events for the app from outside the app+        -> App state event resource+        -- ^ App to run+        -> state+        -- ^ Initial state+        -> Brick m state+++makeEffect ''Brick+++runBrick :: (IOE :> es) => Eff (Brick : es) a -> Eff es a+runBrick = interpret_ \case+    RunBrickApp chan app initialState -> liftIO do+        let buildVty = do+                cfg <- userConfig+                vty <- mkVty cfg+                setMode (outputIface vty) Mouse True+                pure vty+        initialVty <- liftIO buildVty+        customMain+            initialVty+            buildVty+            (Just chan)+            app+            initialState
+ src/Tricorder/Effects/BrickChan.hs view
@@ -0,0 +1,42 @@+module Tricorder.Effects.BrickChan+    ( BrickChan+    , BChan+    , newBChan+    , writeBChan+    , writeBChanNonBlocking+    , readBChan+    , readBChan2+    , runBrickChan+    ) where++import Brick.BChan (BChan)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.TH (makeEffect)++import Brick.BChan qualified as BChan+++data BrickChan :: Effect where+    -- | Lifted `Brick.BChan.newBChan`+    NewBChan :: Int -> BrickChan m (BChan a)+    -- | Lifted `Brick.BChan.writeBChan`+    WriteBChan :: BChan a -> a -> BrickChan m ()+    -- | Lifted `Brick.BChan.writeBChanNonBlocking`+    WriteBChanNonBlocking :: BChan a -> a -> BrickChan m Bool+    -- | Lifted `Brick.BChan.readBChan`+    ReadBChan :: BChan a -> BrickChan m a+    -- | Lifted `Brick.BChan.readBChan2`+    ReadBChan2 :: BChan a -> BChan b -> BrickChan m (Either a b)+++makeEffect ''BrickChan+++runBrickChan :: (IOE :> es) => Eff (BrickChan : es) a -> Eff es a+runBrickChan = interpret_ \case+    NewBChan n -> liftIO $ BChan.newBChan n+    WriteBChan c x -> liftIO $ BChan.writeBChan c x+    WriteBChanNonBlocking c x -> liftIO $ BChan.writeBChanNonBlocking c x+    ReadBChan c -> liftIO $ BChan.readBChan c+    ReadBChan2 c1 c2 -> liftIO $ BChan.readBChan2 c1 c2
+ src/Tricorder/Effects/BuildStore.hs view
@@ -0,0 +1,216 @@+module Tricorder.Effects.BuildStore+    ( -- * Effect+      BuildStore (..)+    , getState+    , modifyPhase+    , waitUntilDone+    , waitForNext+    , waitForAnyChange+    , setPhase+    , markDirty+    , waitDirty+    , hasWaiters++      -- * Interpreters+    , runBuildStoreScripted+    , runBuildStore+    ) where++import Atelier.Effects.Input (Input, input)+import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (TChan, TVar, atomically, dupTChan, modifyTVar, newBroadcastTChan, newTVar, readTChan, readTVar, retry, writeTChan, writeTVar)+import Effectful.Dispatch.Dynamic (interpretWith_, reinterpret)+import Effectful.Exception (bracket_)+import Effectful.State.Static.Shared (State, evalState, get, put)+import Effectful.TH (makeEffect)++import Tricorder.BuildState+    ( BuildId+    , BuildPhase (..)+    , BuildState (..)+    , ChangeKind (..)+    , DaemonInfo (..)+    , initialBuildState+    )+++data BuildStore :: Effect where+    -- | Read the current build state without blocking.+    GetState :: BuildStore m BuildState+    -- | Atomically update the phase of the current build, keeping its+    -- 'BuildId'. The function sees the live state, so a progress update can+    -- inspect the current phase and leave it untouched if it has moved on.+    ModifyPhase :: (BuildState -> BuildPhase) -> BuildStore m ()+    -- | Block until the current build cycle completes (phase transitions to Done).+    WaitUntilDone :: BuildStore m BuildState+    -- | Block until a completed build with a different 'BuildId' is available.+    WaitForNext :: BuildId -> BuildStore m BuildState+    -- | Block until the build state changes from the given state (any field).+    WaitForAnyChange :: BuildState -> BuildStore m BuildState+    -- | Update the build id and phase without touching other fields (e.g. daemonInfo).+    SetPhase :: BuildId -> BuildPhase -> BuildStore m ()+    -- | Signal that files have changed and a rebuild is needed.+    -- 'CabalChange' upgrades a pending 'SourceChange' but never downgrades.+    MarkDirty :: ChangeKind -> BuildStore m ()+    -- | Block until dirty, atomically clear the flag, and return the change kind.+    WaitDirty :: BuildStore m ChangeKind+    -- | Return True if any callers are currently blocked in 'waitUntilDone'.+    HasWaiters :: BuildStore m Bool+++makeEffect ''BuildStore+++-- | Mutable state shared between the production interpreters and writers+-- (e.g. 'GhciSession'). Internal to this module.+data BuildStateRef = BuildStateRef+    { stateRef :: TVar BuildState+    , dirtyRef :: TVar (Maybe ChangeKind)+    , waitersRef :: TVar Int+    , transitions :: TChan BuildState+    -- ^ Broadcast channel of every phase transition. Writers (setPhase /+    -- modifyPhase) atomically update 'stateRef' AND broadcast on this chan in+    -- the same STM transaction; waiters 'dupTChan' it on entry and consume+    -- every transition. A transient 'Done' followed immediately by+    -- 'Building (N+1)' is therefore observable as two messages on the+    -- channel — the waiter can't be woken on the 'Done' and then miss it+    -- because the 'Building' overwrote 'stateRef' before the waiter re-ran.+    }+++-- | Allocate the shared STM state, seeding the build state from @di@. The+-- record's field types pin the otherwise-polymorphic 'newTVar' and+-- 'newBroadcastTChan' results.+newBuildStateRef :: (Concurrent :> es) => DaemonInfo -> Eff es BuildStateRef+newBuildStateRef di =+    atomically+        $ BuildStateRef+            <$> newTVar (initialBuildState di)+            <*> newTVar Nothing+            <*> newTVar 0+            <*> newBroadcastTChan+++isBuilding :: BuildState -> Bool+isBuilding s = case s.phase of+    Building _ -> True+    Restarting -> True+    Testing _ -> True+    Done _ -> False+    BuildFailed _ -> False+++-- | Block until the build state satisfies @predicate@, then return it.+--+-- Subscribes to 'transitions' before reading the current state, so every+-- subsequent state change is observable as a discrete message even if the+-- TVar value is overwritten before the waiter is rescheduled. This is what+-- prevents a transient 'Done' from being missed when 'Building (N+1)'+-- follows it within the scheduler's wake-up latency.+waitForState+    :: (Concurrent :> es)+    => TVar BuildState+    -> TChan BuildState+    -> (BuildState -> Bool)+    -> Eff es BuildState+waitForState ref transitions predicate = do+    myChan <- atomically (dupTChan transitions)+    -- Snapshot AFTER subscribing so we don't race past a transition: any+    -- state change that happens between subscribing and reading 'ref' also+    -- lands on 'myChan', so the loop will pick it up.+    s0 <- atomically (readTVar ref)+    if predicate s0 then pure s0 else drainUntilMatch myChan+  where+    drainUntilMatch ch = do+        s <- atomically (readTChan ch)+        if predicate s then pure s else drainUntilMatch ch+++-- | Atomically take the dirty marker, blocking until one is set.+takeDirty :: (Concurrent :> es) => TVar (Maybe ChangeKind) -> Eff es ChangeKind+takeDirty dirtyRef = atomically do+    readTVar dirtyRef >>= \case+        Just ck -> writeTVar dirtyRef Nothing >> pure ck+        Nothing -> retry+++-- | Scripted interpreter for testing.+--+-- Advances through a pre-loaded list of 'BuildState' values for blocking+-- operations. Useful for testing components that read build state without+-- needing a real 'TVar' or concurrency.+--+-- * 'getState' peeks at the head of the list without consuming it.+-- * 'modifyPhase' rewrites the head's phase in place.+-- * 'waitUntilDone' pops states until it finds one where @phase /= Building@.+-- * 'waitForNext' pops states until it finds a Done state with a different 'BuildId'.+runBuildStoreScripted :: [BuildState] -> Eff (BuildStore : es) a -> Eff es a+runBuildStoreScripted states = reinterpret (evalState states) $ \_ -> \case+    GetState ->+        get >>= \case+            [] -> error "BuildStoreScripted: getState called on empty state list"+            s : _ -> pure s+    ModifyPhase f ->+        get >>= \case+            [] -> pure ()+            s : rest -> put (s {phase = f s} : rest)+    WaitUntilDone -> advance (not . isBuilding)+    WaitForNext bid -> advance \s -> not (isBuilding s) && s.buildId /= bid+    WaitForAnyChange prev -> advance (/= prev)+    SetPhase bid phase -> do+        get >>= \case+            [] -> pure ()+            s : rest -> put (s {buildId = bid, phase = phase} : rest)+    MarkDirty _ -> pure ()+    WaitDirty -> pure SourceChange+    HasWaiters -> pure False+  where+    advance :: (BuildState -> Bool) -> Eff (State [BuildState] : es) BuildState+    advance predicate =+        get >>= \case+            [] -> error "BuildStoreScripted: no matching state in list"+            s : rest+                | predicate s -> put rest >> pure s+                | otherwise -> put rest >> advance predicate+++-- | Production interpreter backed by a 'TVar', sharing its STM state with+-- writers (e.g. 'GhciSession'). Seeds the state with 'initialBuildState' for+-- the current 'DaemonInfo' and refreshes it on every phase change.+--+-- Blocking operations use STM @retry@ rather than polling, so a transient+-- 'Done' state cannot be missed by a poll cycle landing on the surrounding+-- 'Building' phases. 'atomically' is interruptible, so async exceptions+-- (e.g. Ki's @ScopeClosing@) propagate during daemon shutdown.+runBuildStore+    :: ( Concurrent :> es+       , Input DaemonInfo :> es+       )+    => Eff (BuildStore : es) a -> Eff es a+runBuildStore eff = do+    di <- input+    refs <- newBuildStateRef di+    interpretWith_ eff \case+        GetState -> atomically (readTVar refs.stateRef)+        ModifyPhase f -> do+            daemonInfo <- input+            atomically do+                modifyTVar refs.stateRef \bs -> bs {phase = f bs, daemonInfo}+                readTVar refs.stateRef >>= writeTChan refs.transitions+        WaitUntilDone ->+            bracket_+                (atomically (modifyTVar refs.waitersRef (+ 1)))+                (atomically (modifyTVar refs.waitersRef (subtract 1)))+                (waitForState refs.stateRef refs.transitions (not . isBuilding))+        WaitForNext bid ->+            waitForState refs.stateRef refs.transitions \s -> not (isBuilding s) && s.buildId /= bid+        WaitForAnyChange prev -> waitForState refs.stateRef refs.transitions (/= prev)+        SetPhase bid phase -> do+            daemonInfo <- input+            atomically do+                modifyTVar refs.stateRef \bs -> bs {buildId = bid, phase = phase, daemonInfo}+                readTVar refs.stateRef >>= writeTChan refs.transitions+        MarkDirty ck -> atomically (modifyTVar refs.dirtyRef (max (Just ck)))+        WaitDirty -> takeDirty refs.dirtyRef+        HasWaiters -> fmap (> 0) $ atomically (readTVar refs.waitersRef)
+ src/Tricorder/Effects/GhcPkg.hs view
@@ -0,0 +1,57 @@+module Tricorder.Effects.GhcPkg+    ( GhcPkg+    , findModule+    , getHaddockHtml+    , runGhcPkgIO+    , runGhcPkgScripted+    , GhcPkgScript (..)+    ) where++import Atelier.Effects.Process (Process, readProcessSafe)+import Effectful (Effect)+import Effectful.Dispatch.Dynamic (interpret, reinterpret)+import Effectful.State.Static.Shared (evalState, get, put)+import Effectful.TH (makeEffect)++import Data.Text qualified as T++import Tricorder.GhcPkg.Types (ModuleName (..), PackageId (..))+++data GhcPkg :: Effect where+    FindModule :: ModuleName -> GhcPkg m (Maybe PackageId)+    GetHaddockHtml :: PackageId -> GhcPkg m (Maybe FilePath)+++makeEffect ''GhcPkg+++runGhcPkgIO :: (Process :> es) => Eff (GhcPkg : es) a -> Eff es a+runGhcPkgIO = interpret \_ -> \case+    FindModule modName -> do+        out <- readProcessSafe "ghc-pkg" ["find-module", "--simple-output", toString (unModuleName modName)]+        pure $ out >>= fmap PackageId . listToMaybe . filter (not . T.null) . map T.strip . T.lines+    GetHaddockHtml pkgId -> do+        out <- readProcessSafe "ghc-pkg" ["field", toString (unPackageId pkgId), "haddock-html", "--simple-output"]+        pure $ out >>= listToMaybe . map toString . T.words+++-- | Script element for the test interpreter.+data GhcPkgScript+    = -- | Return this value for the next 'findModule' call.+      NextFindModule (Maybe PackageId)+    | -- | Return this value for the next 'getHaddockHtml' call.+      NextGetHaddockHtml (Maybe FilePath)+++-- | Scripted interpreter for testing. Does not require 'IOE'.+runGhcPkgScripted :: [GhcPkgScript] -> Eff (GhcPkg : es) a -> Eff es a+runGhcPkgScripted script = reinterpret (evalState script) \_ -> \case+    FindModule _ ->+        get >>= \case+            NextFindModule result : rest -> put rest >> pure result+            _ -> error "GhcPkgScripted: expected NextFindModule but queue was empty or mismatched"+    GetHaddockHtml _ ->+        get >>= \case+            NextGetHaddockHtml result : rest -> put rest >> pure result+            _ -> error "GhcPkgScripted: expected NextGetHaddockHtml but queue was empty or mismatched"
+ src/Tricorder/Effects/GhciSession.hs view
@@ -0,0 +1,132 @@+module Tricorder.Effects.GhciSession+    ( -- * Effect+      GhciSession+    , Controls (..)+    , withGhci++      -- * Types+    , LoadResult (..)+    , LoadedModule (..)++      -- * Interpreters+    , runGhciSession+    , runGhciSessionScripted+    ) where++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.File (File)+import Atelier.Effects.Process (Process)+import Atelier.Effects.Timeout (Timeout)+import Data.Default (def)+import Effectful+    ( Effect+    , Limit (..)+    , Persistence (..)+    , UnliftStrategy (..)+    )+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic+    ( interpret+    , localLift+    , localSeqLift+    , localSeqUnlift+    , localUnlift+    , reinterpret+    )+import Effectful.Exception (throwIO)+import Effectful.State.Static.Shared (State, evalState, state)+import Effectful.TH (makeEffect)++import Tricorder.BuildState (BuildPhase (..), BuildProgress (..))+import Tricorder.Effects.BuildStore (BuildStore, modifyPhase)+import Tricorder.Effects.GhciSession.GhciParser+    ( GhciLoading (..)+    , LoadResult (..)+    , LoadedModule (..)+    )+import Tricorder.Effects.GhciSession.GhciProcess (addGhci, collectGhciResult, interruptGhci, reloadGhci, unaddGhci, withGhciProcess)+import Tricorder.Runtime (ProjectRoot (..))+++data GhciSession :: Effect where+    -- | Start a new GHCi session and run the handler with that session active.+    -- 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+++data Controls m = Controls+    { reload :: m LoadResult+    , interrupt :: m ()+    , add :: FilePath -> m LoadResult+    , unadd :: Text -> m LoadResult+    }+++makeEffect ''GhciSession+++-- | Scripted interpreter for testing.+--+-- Each call to 'startGhci' or 'reloadGhci' pops the next result from the+-- pre-loaded list. 'Left' results are re-thrown as exceptions, simulating+-- GHCi crashes. 'stopGhci' is always a no-op.+runGhciSessionScripted :: forall es a. [Either SomeException LoadResult] -> Eff (GhciSession : es) a -> Eff es a+runGhciSessionScripted results = reinterpret (evalState results) $ \env ->+    let popResult :: Eff (State [Either SomeException LoadResult] : es) LoadResult+        popResult = do+            x <- state \case+                x : xs -> (x, xs)+                [] -> error "GhciSessionScripted: no more results in queue"+            case x of+                Left ex -> throwIO ex+                Right r -> pure r+    in  \case+            WithGhci _ _ handler -> do+                initial <- popResult+                localSeqLift env \liftEff ->+                    localSeqUnlift env \unlift ->+                        unlift+                            $ handler+                                initial+                                Controls+                                    { reload = liftEff popResult+                                    , interrupt = pure ()+                                    , add = \_ -> liftEff popResult+                                    , unadd = \_ -> liftEff popResult+                                    }+++-- | GHCi session manager backed by 'Tricorder.Effects.GhciSession.GhciProcess'+-- and 'Tricorder.Effects.GhciSession.GhciParser'.+runGhciSession+    :: ( BuildStore :> es+       , Conc :> es+       , Concurrent :> es+       , File :> es+       , Process :> es+       , Timeout :> es+       )+    => Eff (GhciSession : es) a -> Eff es a+runGhciSession = interpret $ \env -> \case+    WithGhci cmd (ProjectRoot dir) handler -> do+        let onProgress loading =+                modifyPhase \_ ->+                    Building+                        $ Just+                        $ BuildProgress {compiled = loading.index, total = loading.total}+        withGhciProcess def cmd dir onProgress (\_ -> pure ()) \process startupLines ->+            localLift env (ConcUnlift Persistent Unlimited) \liftEff ->+                localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do+                    let doReload = liftEff $ reloadGhci process dir onProgress+                    initialResult <- unlift $ liftEff $ collectGhciResult process startupLines dir+                    unlift+                        $ handler+                            initialResult+                            Controls+                                { reload = doReload+                                , interrupt = liftEff (interruptGhci process)+                                , add = \fp -> liftEff $ addGhci process fp dir onProgress+                                , unadd = \mn -> liftEff $ unaddGhci process mn dir onProgress+                                }
+ src/Tricorder/Effects/GhciSession/GhciParser.hs view
@@ -0,0 +1,586 @@+module Tricorder.Effects.GhciSession.GhciParser+    ( GhciLoad (..)+    , GhciLoading (..)+    , GhciMessage (..)+    , GhciSeverity (..)+    , LoadResult (..)+    , LoadedModule (..)+    , Position (..)+    , collectResultCustom+    , parseProgressLine+    , parseReload+    , parseShowModules+    , parseShowTargets+    , pathSuffixesAsModuleName+    , resolveKnownTargets+    , stripAnsi+    , extractTitle+    , toAbsolute+    , toRelative+    ) where++import Data.Char (isAlpha, isDigit, isSpace, toLower)+import System.FilePath (dropExtension, isAbsolute, makeRelative, normalise, splitDirectories, (</>))+import Text.Megaparsec+import Text.Megaparsec.Char (char, string)+import Prelude hiding (many)++import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T+import Text.Megaparsec.Char.Lexer qualified as L++import Tricorder.BuildState (Diagnostic, Severity (..))++import Tricorder.BuildState qualified as BuildState+++-- | Severity of a GHCi diagnostic message.+data GhciSeverity = GWarning | GError+    deriving stock (Eq, Ord, Show)+++-- | Payload for a @[N of M] Compiling Mod ( file, ... )@ line.+data GhciLoading = GhciLoading+    { index :: Int+    -- ^ N (this module's index in the compilation sequence)+    , total :: Int+    -- ^ M (total modules to compile)+    , moduleName :: Text+    , sourceFile :: FilePath+    }+    deriving stock (Eq, Show)+++-- | A source position (1-based line and column). @(0, 0)@ when unavailable.+data Position = Position+    { line :: Int+    , col :: Int+    }+    deriving stock (Eq, Show)+++-- | Payload for a compiler diagnostic (error or warning).+data GhciMessage = GhciMessage+    { severity :: GhciSeverity+    , file :: FilePath+    , startPos :: Position+    , endPos :: Position+    -- ^ equals 'startPos' when no span+    , messageLines :: [Text]+    -- ^ raw lines (with any ANSI), header first+    }+    deriving stock (Eq, Show)+++-- | A structured item from GHCi's reload output.+data GhciLoad+    = GLoading GhciLoading+    | GMessage GhciMessage+    | GLoadConfig FilePath+    deriving stock (Eq, Show)+++-- | A module currently loaded in the GHCi session.+data LoadedModule = LoadedModule+    { relPath :: FilePath+    -- ^ Path relative to the project root (e.g. @"./src/Foo.hs"@).+    , moduleName :: Text+    }+    deriving stock (Eq, Show)+++-- | The result of a GHCi load or reload operation.+data LoadResult = LoadResult+    { moduleCount :: Int+    , compiledFiles :: Set FilePath+    -- ^ Files compiled in this cycle (derived from 'GLoading' items).+    -- Used by the session layer to decide which files' previous diagnostics to replace vs. retain.+    , loadedModules :: Map FilePath LoadedModule+    -- ^ Map from canonical absolute path to module metadata, derived from @:show modules@ output.+    -- Lists only modules that compiled successfully this cycle — GHCi drops+    -- failed-compile modules from @:show modules@.+    , targetNames :: [Text]+    -- ^ Raw entries from @:show targets@ — typically dotted module names+    -- in @cabal repl --enable-multi-repl@. Unlike 'loadedModules' this+    -- survives failed compiles, so the Builder feeds it into+    -- @KnownTargetNames@ for the dispatcher's fallback lookup.+    , diagnostics :: [Diagnostic]+    }+    deriving stock (Eq, Show)+++-- ---------------------------------------------------------------------------+-- LineStream: a Stream instance for [Text] where Token = Text+-- ---------------------------------------------------------------------------++-- | Wrapper so we can define Stream / VisualStream / TraversableStream for+--   a list of 'Text' lines without orphan-instance conflicts.+newtype LineStream = LineStream [Text]+++instance Stream LineStream where+    type Token LineStream = Text+    type Tokens LineStream = [Text]+    tokenToChunk Proxy = pure+    tokensToChunk Proxy = id+    chunkToTokens Proxy = id+    chunkLength Proxy = length+    chunkEmpty Proxy = null+    take1_ (LineStream []) = Nothing+    take1_ (LineStream (t : ts)) = Just (t, LineStream ts)+    takeN_ n (LineStream s)+        | n <= 0 = Just ([], LineStream s)+        | null s = Nothing+        | otherwise = let (a, b) = splitAt n s in Just (a, LineStream b)+    takeWhile_ p (LineStream s) =+        let (a, b) = span p s in (a, LineStream b)+++-- ---------------------------------------------------------------------------+-- Parser type aliases+-- ---------------------------------------------------------------------------++-- | Parser over a stream of 'Text' lines.+type LineParser = Parsec Void LineStream+++-- | Parser over a single 'Text' value.+type TextParser = Parsec Void Text+++-- ---------------------------------------------------------------------------+-- Text-level sub-parsers (helpers for diagnostic header parsing)+-- ---------------------------------------------------------------------------++-- | Run a 'TextParser' on a 'Text' value, returning 'Nothing' on failure.+runTP :: TextParser a -> Text -> Maybe a+runTP p t = case parse p "" t of+    Right x -> Just x+    Left _ -> Nothing+++-- | Parse a GHCi position in one of the formats:+--   @(L1,C1)-(L2,C2):@, @L:C:@, or @L:C-C2:@.+-- Consumes the trailing colon.+positionP :: TextParser (Position, Position)+positionP = parenForm <|> simpleForm+  where+    parenForm = do+        _ <- char '('+        l1 <- L.decimal+        _ <- char ','+        c1 <- L.decimal+        _ <- char ')'+        _ <- char '-'+        _ <- char '('+        _ <- optional (char '(') -- some GHCi versions emit "(L1,C1)-((L2,C2):"+        l2 <- L.decimal+        _ <- char ','+        c2 <- L.decimal+        _ <- char ')'+        _ <- char ':'+        pure (Position l1 c1, Position l2 c2)+    simpleForm = do+        l <- L.decimal+        _ <- char ':'+        c <- L.decimal+        choice+            [ do+                _ <- char ':'+                pure (Position l c, Position l c)+            , do+                _ <- char '-'+                c2 <- L.decimal+                _ <- char ':'+                pure (Position l c, Position l c2)+            ]+++-- | Parse the full diagnostic header:+--   @file:pos:@ or @drive:path:pos:@ for Windows.+-- Returns @(file, startPos, endPos, textAfterColon)@.+diagHeaderP :: TextParser (Text, Position, Position, Text)+diagHeaderP = do+    a <- takeWhile1P Nothing (/= ':')+    _ <- char ':'+    filePart <-+        if T.length a == 1 && isAlpha (T.head a) then do+            pathRest <- takeWhile1P Nothing (/= ':')+            _ <- char ':'+            pure (a <> ":" <> pathRest)+        else+            pure a+    (sp, ep) <- positionP+    afterPos <- getInput+    pure (filePart, sp, ep, afterPos)+++-- ---------------------------------------------------------------------------+-- Line-level helpers+-- ---------------------------------------------------------------------------++-- | Check if a line is a continuation of a diagnostic message body.+isMessageBody :: Text -> Bool+isMessageBody line =+    " " `T.isPrefixOf` line+        || "\t" `T.isPrefixOf` line+        || case T.break (== '|') line of+            (prefix, rest)+                | not (T.null rest) ->+                    T.all (\c -> isSpace c || isDigit c) prefix+            _ -> False+++-- | Consume a line whose stripped form satisfies the predicate.+-- Returns @(originalLine, strippedLine)@.+satisfyStripped :: (Text -> Bool) -> LineParser (Text, Text)+satisfyStripped p = token testLine mempty+  where+    testLine line =+        let stripped = stripAnsi line+        in  if p stripped then Just (line, stripped) else Nothing+++-- ---------------------------------------------------------------------------+-- parseReload+-- ---------------------------------------------------------------------------++-- | Parse the output of @:reload@ from GHCi into structured items.+parseReload :: [Text] -> [GhciLoad]+parseReload ls =+    case parse (catMaybes <$> many reloadItem <* eof) "" (LineStream ls) of+        Right items -> items+        Left _ -> []+++-- | Parse one item (or skip one line) from the reload output.+reloadItem :: LineParser (Maybe GhciLoad)+reloadItem =+    choice+        [ -- Pattern: "Loaded GHCi configuration from <path>"+          fmap Just $ do+            (_, stripped) <- satisfyStripped ("Loaded GHCi configuration from " `T.isPrefixOf`)+            let file = toString $ T.drop (T.length "Loaded GHCi configuration from ") stripped+            pure (GLoadConfig file)+        , -- Pattern: "[N of M] Compiling ..."+          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: "<no location info>: error:"+          fmap Just $ do+            (origLine, _) <- satisfyStripped ("<no location info>: error:" `T.isPrefixOf`)+            body <- many (satisfy isMessageBody)+            pure+                $ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "<no location info>"+                        , startPos = Position 0 0+                        , endPos = Position 0 0+                        , messageLines = origLine : body+                        }+        , -- Pattern: diagnostic "file:pos:severity: ..."+          do+            (origLine, stripped) <-+                satisfyStripped+                    ( \s ->+                        not (T.null s)+                            && not (" " `T.isPrefixOf` s)+                            && not ("\t" `T.isPrefixOf` s)+                    )+            case runTP diagHeaderP stripped of+                Nothing -> pure Nothing+                Just (fileT, sp, ep, afterPos) ->+                    let lower = T.toLower (T.stripStart afterPos)+                    in  case parseSeverity lower of+                            Nothing -> pure Nothing+                            Just sev -> do+                                body <- many (satisfy isMessageBody)+                                pure+                                    $ Just+                                    $ GMessage+                                        GhciMessage+                                            { severity = sev+                                            , file = toString fileT+                                            , startPos = sp+                                            , endPos = ep+                                            , messageLines = origLine : body+                                            }+        , -- Fallback: skip any other line+          fmap (const Nothing) anySingle+        ]+++-- | Parse a single line as a "[N of M] Compiling …" progress event.+--+-- Returns 'Nothing' for any line that is not a loading line. Used to stream+-- progress updates as GHCi emits them, rather than parsing the whole reload+-- output after the fact.+parseProgressLine :: Text -> Maybe GhciLoading+parseProgressLine line =+    let stripped = stripAnsi line+    in  if "[" `T.isPrefixOf` stripped then case runTP loadingLineP stripped of+            Just (GLoading l) -> Just l+            _ -> Nothing+        else+            Nothing+++-- | Parse a "[N of M] Compiling Mod ( file, ... )" loading line.+loadingLineP :: TextParser GhciLoad+loadingLineP = do+    _ <- char '['+    _ <- takeWhileP Nothing (== ' ')+    n <- L.decimal+    _ <- string " of "+    m <- L.decimal+    _ <- takeWhileP Nothing (== ' ')+    _ <- char ']'+    _ <- takeWhile1P Nothing (== ' ')+    _ <- string "Compiling"+    _ <- takeWhile1P Nothing (== ' ')+    modName <- takeWhile1P Nothing (not . isSpace)+    _ <- takeWhileP Nothing (/= '(')+    _ <- char '('+    _ <- takeWhileP Nothing (== ' ')+    filePath <- takeWhile1P Nothing (\c -> c /= ',' && c /= ')')+    pure+        $ GLoading+            GhciLoading+                { index = n+                , total = m+                , moduleName = modName+                , sourceFile = toString (T.stripEnd filePath)+                }+++-- | Determine severity from the text after the position (lowercased, stripped).+parseSeverity :: Text -> Maybe GhciSeverity+parseSeverity lower+    | "warning:" `T.isPrefixOf` lower = Just GWarning+    | "error:" `T.isPrefixOf` lower = Just GError+    | otherwise = Nothing+++-- ---------------------------------------------------------------------------+-- parseShowModules+-- ---------------------------------------------------------------------------++-- | Parse the output of @:show modules@ into (module name, file path) pairs.+parseShowModules :: [Text] -> [(Text, FilePath)]+parseShowModules ls =+    case parse (catMaybes <$> many showModuleLine <* eof) "" (LineStream ls) of+        Right items -> items+        Left _ -> []+++-- | Parse or skip one line of @:show modules@ output.+showModuleLine :: LineParser (Maybe (Text, FilePath))+showModuleLine = do+    line <- anySingle+    pure $ runTP showModuleLineP (stripAnsi line)+++showModuleLineP :: TextParser (Text, FilePath)+showModuleLineP = do+    modName <- takeWhile1P Nothing (not . isSpace)+    _ <- takeWhileP Nothing (/= '(')+    _ <- char '('+    _ <- char ' '+    filePath <- takeWhile1P Nothing (\c -> c /= ',' && c /= ')')+    pure (modName, toString (T.stripEnd filePath))+++-- ---------------------------------------------------------------------------+-- parseShowTargets+-- ---------------------------------------------------------------------------++-- | Parse the output of @:show targets@.+--+-- Each line names one target. In @cabal repl --enable-multi-repl@ these are+-- dotted module names (e.g. @"Foo.Bar"@); in plain @ghci@ sessions they can+-- also be file paths. A leading @*@ marks the active interactive target and+-- is stripped. Blank lines are skipped.+parseShowTargets :: [Text] -> [Text]+parseShowTargets = mapMaybe parseLine+  where+    parseLine raw =+        let cleaned = T.strip (T.dropWhile (== '*') (T.strip (stripAnsi raw)))+        in  if T.null cleaned then Nothing else Just cleaned+++-- ---------------------------------------------------------------------------+-- Pure utilities (unchanged)+-- ---------------------------------------------------------------------------++-- | Make an absolute path relative to the given base directory, prefixed with @"./"@.+-- Paths already relative, or absolute paths outside @base@, are returned unchanged.+toRelative :: FilePath -> FilePath -> FilePath+toRelative base path+    | not (isAbsolute path) = path+    | otherwise = case splitDirectories (makeRelative base path) of+        (".." : _) -> path+        rel -> "." </> List.foldr1 (</>) rel+++-- | Make a relative path absolute by prepending the given base directory.+-- Paths already absolute are returned unchanged.+toAbsolute :: FilePath -> FilePath -> FilePath+toAbsolute base path+    | isAbsolute path = path+    | otherwise = base </> path+++-- | Candidate dotted module names for a file path.+--+-- We can't convert dotted target names to paths without cabal's+-- source-dirs, so callers check the other direction: any uppercase-segment+-- suffix of the path (with @/@ → @.@, extension dropped) is a candidate.+-- E.g. @./tricorder/src/Tricorder/Version.hs@ yields candidates+-- @"Tricorder.Version"@ and @"Version"@.+pathSuffixesAsModuleName :: FilePath -> [Text]+pathSuffixesAsModuleName fp =+    let segments = filter (not . null) (splitDirectories (dropExtension (normalise fp)))+        upperSegments = dropWhile (not . startsUpper) segments+        suffixes = takeWhile (not . null) (iterate (drop 1) upperSegments)+    in  [T.intercalate "." (map toText s) | s <- suffixes]+  where+    startsUpper (c : _) = c >= 'A' && c <= 'Z'+    startsUpper _ = False+++-- | Strip ANSI escape sequences of the form @ESC [ \<params\> \<letter\>@.+stripAnsi :: Text -> Text+stripAnsi t = case T.uncons t of+    Nothing -> t+    Just ('\ESC', rest) -> case T.uncons rest of+        Just ('[', rest') ->+            let afterParams = T.dropWhile (not . isAlpha) rest'+            in  stripAnsi (T.drop 1 afterParams)+        _ -> T.cons '\ESC' (stripAnsi rest)+    Just (c, rest) -> T.cons c (stripAnsi rest)+++-- | Assemble a 'LoadResult' from a project root, parsed reload items, the+-- @:show modules@ output, and the @:show targets@ output.+collectResultCustom :: FilePath -> [GhciLoad] -> [(Text, FilePath)] -> [Text] -> LoadResult+collectResultCustom projectRoot loads modules targets =+    let rel = toRelative projectRoot+        abs' = toAbsolute projectRoot+        compiledFiles = case [l.sourceFile | GLoading l <- loads] of+            [] -> Set.fromList (map (rel . snd) modules)+            fs -> Set.fromList (map rel fs)+        mkEntry (mn, fp) =+            ( normalise (abs' fp)+            , LoadedModule {relPath = rel fp, moduleName = mn}+            )+    in  LoadResult+            { moduleCount = length modules+            , compiledFiles+            , loadedModules = Map.fromList (map mkEntry modules)+            , targetNames = targets+            , diagnostics = toDiagnostics rel loads+            }+++-- | 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+-- mapping); the dispatcher recognises those via 'KnownTargetNames'.+resolveKnownTargets+    :: Map FilePath LoadedModule+    -- ^ Previous known-targets map (carryover source).+    -> LoadResult+    -> Map FilePath LoadedModule+resolveKnownTargets prev lr =+    let primary = lr.loadedModules+        primaryNames = Set.fromList [lm.moduleName | lm <- Map.elems primary]+        prevByName = Map.fromList [(lm.moduleName, (path, lm)) | (path, lm) <- Map.toList prev]+        carryover =+            Map.fromList+                [ (path, lm)+                | name <- lr.targetNames+                , not (Set.member name primaryNames)+                , Just (path, lm) <- [Map.lookup name prevByName]+                ]+    in  Map.union primary carryover+++toDiagnostics :: (FilePath -> FilePath) -> [GhciLoad] -> [BuildState.Diagnostic]+toDiagnostics rel loads = mapMaybe toMsg loads+  where+    toMsg (GMessage m) | '<' : _ <- m.file = Nothing+    toMsg (GMessage m) =+        Just+            BuildState.Diagnostic+                { severity = case m.severity of+                    GWarning -> SWarning+                    GError -> SError+                , file = rel m.file+                , line = m.startPos.line+                , col = m.startPos.col+                , endLine = m.endPos.line+                , endCol = m.endPos.col+                , title = extractTitle (map toString m.messageLines)+                , text = unlines (map toText m.messageLines)+                }+    toMsg _ = Nothing+++-- | Extract a short human-readable title from GHCi message lines.+--+-- The header line (@"file:line:col: severity: rest"@) is the first element.+-- The human-readable text is either:+--+--   * Inline, after @"error:"@ \/ @"warning:"@ in the header (old GHC style), or+--   * On subsequent indented lines (new GHC style, when header ends with a+--     diagnostic code such as @[GHC-83865]@ or @[-Wmissing-deriving-strategies]@).+--+-- Source-display lines (@"39 | ..."@, @"   | ^^^^"@) are skipped when+-- scanning body lines for content.+extractTitle :: [String] -> Text+extractTitle [] = ""+extractTitle (header : body) =+    fromMaybe (firstBodyLine body) (inlineFromHeader (toString (stripAnsi (toText header))))+  where+    inlineFromHeader :: String -> Maybe Text+    inlineFromHeader h =+        let lower = map toLower h+        in  case headerAfter "error:" lower h <|> headerAfter "warning:" lower h of+                Nothing -> Nothing+                Just rest ->+                    let content = stripDiagCodes (dropWhile isSpace rest)+                    in  if null content then Nothing else Just (toText content)++    headerAfter :: String -> String -> String -> Maybe String+    headerAfter needle haystack original =+        fmap (\i -> drop (i + length needle) original)+            $ List.findIndex (needle `List.isPrefixOf`) (List.tails haystack)++    stripDiagCodes :: String -> String+    stripDiagCodes s = case dropWhile isSpace s of+        '[' : rest ->+            let after = dropWhile isSpace (drop 1 (dropWhile (/= ']') rest))+            in  stripDiagCodes after+        other -> other++    firstBodyLine :: [String] -> Text+    firstBodyLine xs =+        case [ t+             | x <- xs+             , let t = dropWhile isSpace (toString (stripAnsi (toText x)))+             , not (null t)+             , not (isSourceLine t)+             ] of+            (t : _) -> toText t+            [] -> ""++    isSourceLine :: String -> Bool+    isSourceLine s = case dropWhile (\c -> isDigit c || c == ' ') s of+        ('|' : _) -> True+        _ -> not (null s) && all (\c -> c `elem` ("^~_ " :: String)) s
+ src/Tricorder/Effects/GhciSession/GhciProcess.hs view
@@ -0,0 +1,568 @@+module Tricorder.Effects.GhciSession.GhciProcess+    ( Config (..)+    , GhciProcess (..)+    , GhciProcessError (..)+    , SessionState (..)+    , InterruptDecision (..)+    , decideInterrupt+    , waitForBannerOrFail+    , withGhciProcess+    , execGhci+    , interruptGhci+    , terminateGhciProcess+    , collectGhciResult+    , reloadGhci+    , addGhci+    , unaddGhci+    ) where++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.File (BufferMode (..), File, Handle)+import Atelier.Effects.Process+    ( Process+    , RunningProcess+    , createPipe+    , getStderr+    , getStdin+    , getStdout+    , setCreateGroup+    , setStderr+    , setStdin+    , setStdout+    , setWorkingDir+    , shell+    )+import Atelier.Effects.Timeout (Timeout, timeout)+import Control.Concurrent.STM (TVar, modifyTVar', readTVar, retry, writeTVar)+import Data.Default (Default (..))+import Data.Time.Units (Second)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, newTVarIO)+import Effectful.Exception (bracket, finally, throwIO, trySync)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.File qualified as File+import Atelier.Effects.Process qualified as Process+import Data.Text qualified as T++import Tricorder.Effects.GhciSession.GhciParser+    ( GhciLoading (..)+    , LoadResult (..)+    , collectResultCustom+    , parseProgressLine+    , parseReload+    , parseShowModules+    , parseShowTargets+    , stripAnsi+    )+++-- | Configuration for GHCi process management.+data Config = Config+    { startupTimeout :: Second+    -- ^ How long to wait for the GHCi version banner on startup.+    , shutdownTimeout :: Second+    -- ^ How long to wait for the process to exit gracefully before force-killing.+    , extraSetupCommands :: [Text]+    -- ^ Additional GHCi commands to send after the fixed setup block.+    -- Use this to inject session-wide options such as @:set -XOverloadedStrings@.+    }+++instance Default Config where+    def =+        Config+            { startupTimeout = 60+            , shutdownTimeout = 5+            , extraSetupCommands = []+            }+++data SessionState = Idle Int | Busy Int+    deriving stock (Eq, Show)+++-- | The outcome of consulting the 'SessionState' when an interrupt arrives.+--+-- 'NoOpIdle' means the GHCi session is at the prompt — sending SIGINT and a+-- sync marker would dirty the buffers and desync the next 'execGhci'.+-- 'SendInterruptFor n' means a command was in flight (state 'Busy n') and+-- the caller should SIGINT the process group and re-write @markerFor n@ (that+-- command's own marker) to unblock the in-progress 'drainUntil'.+data InterruptDecision+    = NoOpIdle+    | SendInterruptFor Int+    deriving stock (Eq, Show)+++-- | Pure state machine for 'interruptGhci'. Returns the new 'SessionState'+-- to install along with the 'InterruptDecision' the caller should act on.+decideInterrupt :: SessionState -> (SessionState, InterruptDecision)+decideInterrupt s@(Idle _) = (s, NoOpIdle)+decideInterrupt (Busy n) = (Idle (n + 1), SendInterruptFor n)+++-- | A handle to a running GHCi subprocess.+data GhciProcess = GhciProcess+    { stdin :: Handle+    , stdout :: Handle+    , stderr :: Handle+    , handle :: RunningProcess Handle Handle Handle+    , stateVar :: TVar SessionState+    }+++-- | Errors that can occur during GHCi process management.+data GhciProcessError+    = StartupTimeout+    | UnexpectedExit Text (Maybe Text)+    | -- | The build command exited (or printed nothing parseable) before GHCi+      -- produced its version banner. The 'Text' is the captured stderr+stdout+      -- output so callers can surface a useful error (e.g. cabal's dependency+      -- resolution failure).+      StartupFailed Text+    deriving stock (Eq, Show)+++instance Exception GhciProcessError+++-- | Start a GHCi subprocess running the given command in the given directory.+--+-- 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+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Process :> es+       , Timeout :> es+       )+    => Config+    -> Text+    -> FilePath+    -> (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+    -- instead of replaying everything once compilation finishes.+    -> (GhciProcess -> Eff es ())+    -- ^ @onReady@. Called once the 'GhciProcess' is constructed but before the+    -- banner wait and initial-build drain — so callers can register the process+    -- 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)+    let inp = getStdin p+        out = getStdout p+        err = getStderr p+    File.hSetBuffering inp LineBuffering+    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.+    stateVar <- newTVarIO (Idle 0)+    let ghciProcess =+            GhciProcess+                { stdin = inp+                , stdout = out+                , stderr = err+                , handle = p+                , stateVar = stateVar+                }+    onReady ghciProcess++    -- Send a blank line to kick GHCi into producing output+    File.hPutTextLn inp ""+    File.hFlush inp++    -- 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++    -- Send fixed setup commands (protocol requirements)+    File.hPutTextLn inp ":set prompt \"\""+    File.hPutTextLn inp ":set prompt-cont \"\""+    File.hPutTextLn inp ":set +c"+    -- Send any caller-supplied extra setup commands+    for_ config.extraSetupCommands \c ->+        File.hPutTextLn inp c+    File.hFlush inp++    -- Sync: drain until marker 1 seen, then set counter to 2.+    -- Capture lines from both streams — the stderr output contains the initial+    -- compilation progress and any startup diagnostics. The line hook fires+    -- 'onProgress' for each "[N of M] Compiling …" line as it arrives, so the+    -- UI can update the progress bar live during the initial build.+    let marker1 = markerFor 1+        hook = progressLineHook onProgress+    sendSyncCommand inp marker1+    initialLines <- Conc.scoped do+        stdoutThread <- Conc.fork $ drainUntil out marker1 hook+        stderrThread <- Conc.fork $ drainUntil err marker1 hook+        stdoutLines <- Conc.await stdoutThread+        stderrLines <- Conc.await stderrThread+        pure (stdoutLines ++ stderrLines)+    atomically $ writeTVar stateVar (Idle 2)++    pure (ghciProcess, initialLines)+++-- | Bracket helper: start a GHCi process, run an action, then stop it.+--+-- 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.+withGhciProcess+    :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es)+    => Config+    -> Text+    -> 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)+++-- | Execute a command in GHCi and return the combined stdout+stderr output+-- lines. The @onProgress@ callback fires for each @[N of M] Compiling …@ line+-- as it arrives, so reload/add/unadd progress is streamed live to the UI.+-- Pass @\\_ -> pure ()@ for commands that do not trigger compilation.+execGhci+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       )+    => GhciProcess -> Text -> (GhciLoading -> Eff es ()) -> Eff es [Text]+execGhci ghciProcess command onProgress = do+    n <- atomically do+        readTVar ghciProcess.stateVar >>= \case+            Idle n -> writeTVar ghciProcess.stateVar (Busy n) $> n+            Busy _ -> retry+    doExec n `finally` atomically (writeTVar ghciProcess.stateVar (Idle (n + 1)))+  where+    doExec n = do+        let marker = markerFor n+            hook = progressLineHook onProgress+        File.hPutTextLn ghciProcess.stdin command+        File.hFlush ghciProcess.stdin+        sendSyncCommand ghciProcess.stdin marker+        -- Scoped so that an exception from one drain (e.g. 'UnexpectedExit'+        -- when the underlying process is terminated mid-command) is+        -- contained here, re-raised by 'await', and caught by the caller's+        -- 'trySync'. Without 'scoped', Ki propagates the exception to the+        -- \*ambient* scope — typically the builder's listener scope — which+        -- tears down the whole builder loop instead of just failing this+        -- one command.+        (stdoutLines, stderrLines) <- Conc.scoped do+            stdoutThread <- Conc.fork $ drainUntil ghciProcess.stdout marker hook+            stderrThread <- Conc.fork $ drainUntil ghciProcess.stderr marker hook+            (,) <$> Conc.await stdoutThread <*> Conc.await stderrThread+        pure (stdoutLines ++ stderrLines)+++-- | Interrupt the currently running GHCi command (if any).+--+-- If a command is in progress (state 'Busy n'), sends SIGINT to the GHCi+-- process group and re-writes /that command's own/ sync marker (@markerFor n@)+-- so the in-progress 'drainUntil', which is waiting for exactly that marker,+-- unblocks. The next command runs as @n + 1@ and waits for @markerFor (n + 1)@,+-- so any duplicate @markerFor n@ left in the buffers is skipped by 'drainUntil'+-- rather than mistaken for the next command's marker.+--+-- When GHCi is 'Idle' this is a true no-op: sending SIGINT and a sync marker to+-- an idle GHCi leaves leftover marker output in the buffers.+interruptGhci :: (Concurrent :> es, File :> es, Process :> es) => GhciProcess -> Eff es ()+interruptGhci ghciProcess = do+    decision <- atomically do+        s <- readTVar ghciProcess.stateVar+        let (s', d) = decideInterrupt s+        writeTVar ghciProcess.stateVar s'+        pure d+    case decision of+        NoOpIdle -> pure ()+        SendInterruptFor n -> do+            Process.interruptProcessGroup ghciProcess.handle+            sendSyncCommand ghciProcess.stdin (markerFor n)+++-- | Forcefully terminate the GHCi process, closing its 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.+-- After this, any 'execGhci' drain raises 'UnexpectedExit' on the now-closed+-- handles.+terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es ()+terminateGhciProcess ghciProcess = Process.stopProcess 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+    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+++-- ---------------------------------------------------------------------------+-- Internal helpers++-- | Build the finish marker for counter value @n@.+markerFor :: Int -> Text+markerFor n = markerPrefix <> show n <> "~#"+++-- | The prefix shared by all finish markers.+markerPrefix :: Text+markerPrefix = "#~TRI-FINISH-"+++-- | Write the synchronisation Haskell statements to GHCi stdin.+--+-- After each user command, these cause GHCi to emit the finish marker on both+-- stdout and stderr, so 'drainUntil' knows when to stop.+--+-- The marker is emitted as two standalone, fully-qualified statements — one per+-- stream — using only 'System.IO.hPutStrLn'. This is deliberate: a+-- SIGINT-interrupted ':reload' empties GHCi's interactive scope, dropping the+-- implicit @import Prelude@, so bare names like @putStrLn@ (and even the @>>@+-- operator) fall out of scope. A marker built from those would /error/ instead+-- of printing — its marker would never appear and 'drainUntil' would block+-- forever waiting for it (the "stuck Building…" stall). Fully-qualified+-- 'System.IO.hPutStrLn' resolves via GHCi's implicit qualified imports even+-- with an emptied scope, so the marker survives an interrupt.+sendSyncCommand :: (File :> es) => Handle -> Text -> Eff es ()+sendSyncCommand h marker = do+    -- Use show to produce a valid Haskell string literal for the marker text.+    let markerLit = toText (show @String (toString marker)) -- e.g. "\"#~TRI-FINISH-3~#\""+    File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stdout " <> markerLit)+    File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stderr " <> markerLit)+    File.hFlush h+++-- | Read lines from a handle until /this command's/ finish marker is seen (or+-- EOF).+--+-- Stops only on a line containing the exact @marker@ it was given. A line+-- carrying a /different/ finish marker — a stale leftover from a prior command+-- that was interrupted mid-flight — is skipped rather than matched, so it can+-- never make a later drain return prematurely (the "0 modules"/hang desync).+-- Each ordinary line is passed to @onLine@ as it arrives, so callers can stream+-- progress without waiting for the full drain to complete. Returns accumulated+-- non-marker lines in order. Throws 'UnexpectedExit' on EOF before the marker.+drainUntil :: (File :> es) => Handle -> Text -> (Text -> Eff es ()) -> Eff es [Text]+drainUntil h marker onLine = go []+  where+    go acc = do+        result <- trySync $ File.hGetLine h+        case result of+            Left _ ->+                throwIO $ UnexpectedExit marker (listToMaybe (reverse acc))+            Right line+                | marker `T.isInfixOf` line -> pure (reverse acc)+                -- A stale marker from an interrupted command: drop it, keep going.+                | markerPrefix `T.isInfixOf` line -> go acc+                | otherwise -> do+                    onLine line+                    go (line : acc)+++-- | Convert a 'GhciLoading' progress callback into a per-line hook suitable+-- for 'drainUntil'. Non-progress lines are ignored.+progressLineHook :: (GhciLoading -> Eff es ()) -> Text -> Eff es ()+progressLineHook onProgress line = traverse_ onProgress (parseProgressLine line)+++-- | Wait up to the given number of seconds for a GHCi version banner on+-- stdout, capturing stderr (and any non-banner stdout lines) in case the+-- build command fails before printing a banner.+--+-- Throws 'StartupFailed' with the captured output if stdout EOFs (the build+-- command exited) or 'StartupTimeout' if the banner never arrives.+waitForBannerOrFail+    :: ( 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+    capturedVar <- newTVarIO ([] :: [Text])+    let captureLine line = atomically $ modifyTVar' capturedVar (line :)+        drainStderr = drainUntilEof err captureLine+        watchStdout = waitForBannerStdout out captureLine++    Conc.scoped do+        stderrThread <- Conc.fork drainStderr+        result <- timeout delay $ trySync watchStdout+        case result of+            Just (Right ()) -> pure ()+            Just (Left ex) -> do+                -- stdout EOF before the banner: the build command exited. Wait+                -- for the stderr drain to reach EOF too (bounded, in case the+                -- pipe lingers) so we surface its *complete* output — e.g.+                -- cabal's dependency-resolution error — rather than whatever+                -- 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)+++waitForBannerStdout :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()+waitForBannerStdout h captureLine = go+  where+    isVersionLine :: Text -> Bool+    isVersionLine line =+        let stripped = stripAnsi line+        in  "GHCi, version " `T.isInfixOf` stripped+                || "GHCJSi, version " `T.isInfixOf` stripped+                || "Clashi, version " `T.isInfixOf` stripped++    go = do+        result <- trySync $ File.hGetLine h+        case result of+            Left ex -> throwIO ex+            Right line ->+                if isVersionLine line then+                    pure ()+                else do+                    captureLine line+                    go+++drainUntilEof :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()+drainUntilEof h onLine = go+  where+    go = do+        result <- trySync $ File.hGetLine h+        case result of+            Left _ -> pure ()+            Right line -> onLine line >> go+++-- | Render the captured (reverse-order) output lines into an error message,+-- stripping ANSI escapes and dropping blank lines. Returns 'Nothing' when+-- nothing useful remains, so callers can fall back to a generic message.+renderCapturedLines :: [Text] -> Maybe Text+renderCapturedLines capturedRev =+    let cleaned = filter (not . T.null . T.strip) (map stripAnsi (reverse capturedRev))+    in  if null cleaned then Nothing else Just (T.intercalate "\n" cleaned)+++-- | Fallback message when the build command exited before the banner without+-- printing anything we could capture.+startupExitedMessage :: SomeException -> Text+startupExitedMessage ex =+    "Build command exited before GHCi started: " <> toText (displayException ex)+++-- | Parse already-drained GHCi output lines into a 'LoadResult', fetching the+-- current module list via @:show modules@.+--+-- 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)+    => GhciProcess+    -> [Text]+    -> FilePath+    -> Eff es LoadResult+collectGhciResult process lines' projectRoot = do+    let loads = parseReload lines'+        noProgress = \_ -> pure ()+    moduleLines <- execGhci process ":show modules" noProgress+    targetLines <- execGhci process ":show targets" noProgress+    pure+        $ collectResultCustom+            projectRoot+            loads+            (parseShowModules moduleLines)+            (parseShowTargets targetLines)+++-- | 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)+    => GhciProcess+    -> FilePath+    -> (GhciLoading -> Eff es ())+    -> Eff es LoadResult+reloadGhci process projectRoot onProgress = do+    reloadLines <- execGhci process ":reload" onProgress+    collectGhciResult process reloadLines projectRoot+++-- | 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)+    => GhciProcess+    -> FilePath -- the file to :add+    -> FilePath -- projectRoot+    -> (GhciLoading -> Eff es ())+    -> Eff es LoadResult+addGhci process filePath projectRoot onProgress = do+    addLines <- execGhci process (":add " <> T.pack filePath) onProgress+    collectGhciResult process addLines projectRoot+++-- | Execute @:unadd@ for the given module and return the assembled+-- 'LoadResult'. Progress events fire live via @onProgress@ as compilation+-- proceeds.+unaddGhci+    :: (Conc :> es, Concurrent :> es, File :> es)+    => GhciProcess+    -> Text -- the module name to :unadd+    -> FilePath -- projectRoot+    -> (GhciLoading -> Eff es ())+    -> Eff es LoadResult+unaddGhci process moduleName projectRoot onProgress = do+    unaddLines <- execGhci process (":unadd " <> moduleName) onProgress+    collectGhciResult process unaddLines projectRoot
+ src/Tricorder/Effects/Logging.hs view
@@ -0,0 +1,18 @@+module Tricorder.Effects.Logging (runLogging) where++import Atelier.Effects.File (BufferMode (..), File)+import Atelier.Effects.Log (Log, Severity (..), runLogToHandle)+import Effectful (IOE)+import Effectful.Reader.Static (Reader, asks)++import Atelier.Effects.File qualified as File++import Tricorder.Runtime (LogPath (..))+++runLogging :: (File :> es, IOE :> es, Reader LogPath :> es) => Eff (Log : es) a -> Eff es a+runLogging act = do+    path <- asks @LogPath (.getLogPath)+    File.withFile path AppendMode \h -> do+        File.hSetBuffering h LineBuffering+        runLogToHandle h INFO act
+ src/Tricorder/Effects/SessionStore.hs view
@@ -0,0 +1,120 @@+module Tricorder.Effects.SessionStore+    ( SessionStore (..)+    , SessionStoreReloaded (..)+    , get+    , rawReload+    , withSession+    , withSubSession+    , ActiveSession (..)+    , Reloader (..)+    , runSessionStore+    , runSessionStoreConst+    ) where++import Atelier.Config (LoadedConfig)+import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Publishing (Pub, Sub, publish)+import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic (interpret_, reinterpretWith_)+import Effectful.Reader.Static (Reader)+import Effectful.TH (makeEffect)+import Relude.Extra.Tuple (dup)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Iterator qualified as Iter+import Atelier.Effects.Publishing qualified as Sub+import Effectful.State.Static.Shared qualified as State++import Tricorder.Runtime (ProjectRoot)+import Tricorder.Session (Session, loadSession)+++data SessionStore :: Effect where+    Get :: SessionStore m Session+    RawReload :: SessionStore m ()+++makeEffect ''SessionStore+++data ActiveSession es = ActiveSession+    { session :: Session+    , reloader :: Reloader es+    }+++newtype Reloader es = Reloader {reload :: Eff es ()}+++-- | Operate on the most recent 'Session' stored. Whenever the session is+-- reloaded, the passed action is cancelled, and started again with the new+-- 'Session'.+withSession+    :: ( Conc :> es+       , SessionStore :> es+       , Sub SessionStoreReloaded :> es+       )+    => (ActiveSession es -> Eff es a)+    -> Eff es Void+withSession act =+    Conc.restartableForkWith (void $ Sub.listenOnce_ @SessionStoreReloaded) get \session ->+        act ActiveSession {session, reloader = Reloader rawReload}+++-- | Tracks the parts of 'Session' that the caller cares about, and restarts+-- the passed function whenever those parts change based on the 'subSession's+-- 'Eq' instance.+withSubSession+    :: forall subSession es a+     . ( Chan :> es+       , Conc :> es+       , Concurrent :> es+       , Eq subSession+       , SessionStore :> es+       , Sub SessionStoreReloaded :> es+       )+    => (Session -> subSession)+    -> Session+    -> (Reloader es -> subSession -> Eff es a)+    -> Eff es Void+withSubSession mkSubSession initialSession action =+    Iter.fromEvents @SessionStoreReloaded \iter ->+        let initialSubSession = mkSubSession initialSession+            subIter =+                Iter.changes+                    initialSubSession+                    (fmap (\(SessionStoreReloaded s) -> mkSubSession s) iter)+        in  Conc.restartableForkLoop+                initialSubSession+                (Iter.next subIter)+                \cfg -> action (Reloader rawReload) cfg+++data SessionStoreReloaded = SessionStoreReloaded Session+++runSessionStore+    :: ( FileSystem :> es+       , Log :> es+       , Pub SessionStoreReloaded :> es+       , Reader LoadedConfig :> es+       , Reader ProjectRoot :> es+       )+    => Eff (SessionStore : es) a -> Eff es a+runSessionStore act = do+    initialSession <- loadSession+    reinterpretWith_ (State.evalState initialSession) act \case+        Get -> State.get+        RawReload -> do+            session <- State.stateM (\_ -> dup <$> loadSession)+            publish $ SessionStoreReloaded session+++runSessionStoreConst :: Session -> Eff (SessionStore : es) a -> Eff es a+runSessionStoreConst session = interpret_ \case+    Get -> pure session+    RawReload -> pure ()
+ src/Tricorder/Effects/TestRunner.hs view
@@ -0,0 +1,288 @@+module Tricorder.Effects.TestRunner+    ( -- * Effect+      TestRunner (..)+    , runTestSuite+    , interruptCurrent+    , resetAbort+    , isAborted++      -- * Interpreters+    , runTestRunnerIO+    , runTestRunnerScripted++      -- * Parsing utilities+    , GhciOutcome (..)+    , detectOutcome++      -- * Internal helpers (exported for testing)+    , abortGatedProgress+    , reportTestProgress+    ) where++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, timeout)+import Control.Concurrent.STM (TVar, readTVar, writeTVar)+import Control.Exception (throwIO)+import Data.Default (def)+import Data.Time.Units (Second)+import Effectful (Effect, IOE)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, newTVarIO)+import Effectful.Dispatch.Dynamic (interpretWith_, reinterpret)+import Effectful.Exception (bracket_, trySync)+import Effectful.Reader.Static (Reader, ask)+import Effectful.State.Static.Shared (State, evalState, get, put)+import Effectful.TH (makeEffect)++import Atelier.Effects.Log qualified as Log+import Data.List qualified as List+import Data.Text qualified as T++import Tricorder.BuildState+    ( BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , BuildState (..)+    , TestRun (..)+    , TestRunCompletion (..)+    , TestRunError (..)+    )+import Tricorder.Effects.BuildStore (BuildStore, modifyPhase)+import Tricorder.Effects.GhciSession.GhciParser (GhciLoading (..))+import Tricorder.Effects.GhciSession.GhciProcess (GhciProcess, execGhci, terminateGhciProcess, withGhciProcess)+import Tricorder.Effects.SessionStore (SessionStore)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Session (..))+import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput)++import Tricorder.Effects.SessionStore qualified as SessionStore+++data TestRunner :: Effect where+    -- | Run a single test suite in a short-lived @cabal repl@ process and+    -- return the captured output and detected outcome.+    RunTestSuite :: Text -> TestRunner m TestRun+    -- | Interrupt the test currently in flight (if any) and latch an abort+    -- flag so that subsequent 'RunTestSuite' calls short-circuit until+    -- 'ResetAbort' is called.+    InterruptCurrent :: TestRunner m ()+    -- | Clear the abort flag. Call this at the start of a new test run.+    ResetAbort :: TestRunner m ()+    -- | Read the abort flag without clearing it.+    IsAborted :: TestRunner m Bool+++makeEffect ''TestRunner+++-- | Production interpreter that spawns a short-lived @cabal repl test:\<name\>@+-- process for each suite, feeds @:main\\n:quit\\n@ to stdin, captures combined+-- stdout+stderr, and detects the outcome via 'detectOutcome'.+runTestRunnerIO+    :: ( BuildStore :> es+       , Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Process :> es+       , Reader ProjectRoot :> es+       , SessionStore :> es+       , Timeout :> es+       )+    => Eff (TestRunner : es) a -> Eff es a+runTestRunnerIO act = do+    ProjectRoot projectRoot <- ask+    currentProcRef <- newTVarIO (Nothing :: Maybe GhciProcess)+    abortedRef <- newTVarIO False+    interpretWith_ act \case+        InterruptCurrent -> do+            -- Terminate (not just SIGINT) the test process: hspec/tasty+            -- install their own SIGINT handlers that finalise the current+            -- run rather than aborting it. Each test runs in its own+            -- short-lived @cabal repl@ process, so killing it outright is+            -- safe and gets a prompt abort. 'execGhci' then raises+            -- 'UnexpectedExit', 'trySync' catches it, and the run loop+            -- short-circuits on @abortedRef@.+            mProc <- atomically do+                writeTVar abortedRef True+                readTVar currentProcRef+            for_ mProc terminateGhciProcess+        ResetAbort -> atomically (writeTVar abortedRef False)+        IsAborted -> atomically (readTVar abortedRef)+        RunTestSuite target -> do+            alreadyAborted <- atomically (readTVar abortedRef)+            if alreadyAborted then+                pure $ TestRunErrored $ TestRunError {target, message = "Test run aborted"}+            else do+                Session {testTimeout} <- SessionStore.get+                let onProgress = abortGatedProgress abortedRef target+                    noProgress = \_ -> pure ()+                    -- Register the process as soon as 'startGhciProcess'+                    -- constructs it — before the initial @cabal repl@+                    -- compile drain runs. Without this, an interrupt that+                    -- arrives during that drain would find+                    -- 'currentProcRef' empty and have nothing to kill, so+                    -- the new build's cycle would have to wait several+                    -- seconds for the doomed @cabal repl@ to finish+                    -- compiling its test code before the cycle lock was+                    -- released.+                    onReady ghci = atomically (writeTVar currentProcRef (Just ghci))+                -- Outer bracket: always clear 'currentProcRef' on exit,+                -- whether 'withGhciProcess' completed normally or threw.+                result <- trySync+                    $ bracket_+                        (pure ())+                        (atomically (writeTVar currentProcRef Nothing))+                    $ withGhciProcess def ("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+                            -- discarded by the run loop once it sees+                            -- 'abortedRef'.+                            True -> pure (Right [])+                            False -> case testTimeout of+                                secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress+                                secs ->+                                    timeout (fromIntegral secs :: Second) (execGhci ghci ":main" noProgress) >>= \case+                                        Nothing -> pure (Left secs)+                                        Just ls -> pure (Right ls)+                case result of+                    Left ex ->+                        pure $ TestRunErrored $ TestRunError {target, message = show ex}+                    Right (Left secs) -> do+                        Log.warn $ "Test suite " <> target <> " timed out after " <> show secs <> "s"+                        pure $ TestRunErrored $ TestRunError {target, message = "Test suite timed out after " <> show secs <> "s"}+                    Right (Right mainLines) ->+                        pure+                            $ let output = T.unlines mainLines+                              in  case detectOutcome output of+                                    GhciCrashed msg ->+                                        TestRunErrored $ TestRunError {target, message = msg}+                                    outcome ->+                                        TestRunCompleted+                                            $ TestRunCompletion+                                                { target+                                                , passed = outcome == GhciPassed+                                                , output+                                                , testCases = parseHspecOutput output+                                                , duration = parseHspecDuration output+                                                }+++-- | Scripted interpreter for testing.+--+-- Each call to 'runTestSuite' pops the next result from the pre-loaded list.+-- 'Left' results are re-thrown as exceptions, simulating process failures.+runTestRunnerScripted+    :: forall es a+     . (Concurrent :> es, IOE :> es)+    => [Either SomeException TestRun]+    -> Eff (TestRunner : es) a+    -> Eff es a+runTestRunnerScripted results act = do+    -- Mirror the IO interpreter's abort semantics so tests that drive+    -- 'runTestsIfClean' through an interrupt can actually observe the+    -- short-circuit via 'isAborted'. A hard-coded 'pure False' would+    -- silently mask any regression in that flow.+    abortedRef <- newTVarIO False+    reinterpret+        (evalState results)+        ( \_ -> \case+            RunTestSuite _ -> popResult+            InterruptCurrent -> atomically (writeTVar abortedRef True)+            ResetAbort -> atomically (writeTVar abortedRef False)+            IsAborted -> atomically (readTVar abortedRef)+        )+        act+  where+    popResult :: Eff (State [Either SomeException TestRun] : es) TestRun+    popResult =+        get >>= \case+            [] -> error "TestRunnerScripted: no more results in queue"+            Left ex : rest -> put rest >> liftIO (throwIO ex)+            Right r : rest -> put rest >> pure r+++-- | Progress callback used while a test suite is running. Reads the test+-- runner's abort flag before applying the update so that pipe-buffered+-- '[N of M] Compiling' lines emitted by a dying test process — after the+-- user has already touched a file — do not push the counter forward.+abortGatedProgress+    :: (BuildStore :> es, Concurrent :> es)+    => TVar Bool -> Text -> GhciLoading -> Eff es ()+abortGatedProgress abortedRef target loading = do+    aborted <- atomically (readTVar abortedRef)+    unless aborted $ reportTestProgress target loading+++-- | Patch live compile progress for a test suite into the current 'Testing'+-- phase of the build state.+--+-- A test suite's @cabal repl@ session typically recompiles a slice of the+-- project before running @:main@. Mirroring the main-build progress bar, we+-- update the matching 'TestRunning' entry as each @[N of M] Compiling …@+-- line arrives so the UI shows @running... (N/M)@ live.+--+-- The update is best-effort: if the phase has moved on (e.g. a source change+-- triggered 'Restarting' or 'Building'), the progress event is dropped rather+-- than reverting the phase.+reportTestProgress+    :: (BuildStore :> es) => Text -> GhciLoading -> Eff es ()+reportTestProgress target loading =+    modifyPhase \state -> case state.phase of+        Testing partialResult ->+            let progress = BuildProgress {compiled = loading.index, total = loading.total}+                updateRun (TestRunning t _) | t == target = TestRunning t (Just progress)+                updateRun r = r+                newRuns = map updateRun partialResult.testRuns+            in  Testing partialResult {testRuns = newRuns}+        other -> other+++data GhciOutcome+    = GhciPassed+    | GhciFailed+    | GhciCrashed Text+    deriving stock (Eq, Show)+++-- | Detect the test outcome from raw GHCi output.+--+-- All major test frameworks (@hspec@, @tasty@, @HUnit@) call+-- 'System.Exit.exitWith' on completion. GHCi surfaces this as a line+-- matching @*** Exception: ExitSuccess@ (pass) or+-- @*** Exception: ExitFailure N@ (fail). Any other @*** Exception:@ line+-- means the runner crashed.+--+-- When no exception line is present, the absence is ambiguous: either the+-- test ran and printed nothing exit-related, or @:main@ never ran at all+-- (e.g. the test target failed to compile, so @main@ is not in scope).+-- A line containing @": error:"@ in the captured output is treated as the+-- latter — a GHC compile/load error that prevented the suite from running.+detectOutcome :: Text -> GhciOutcome+detectOutcome output =+    case List.find ("*** Exception: " `T.isPrefixOf`) outputLines of+        Just line ->+            case T.stripPrefix "*** Exception: " line of+                Nothing -> GhciPassed+                Just rest ->+                    let r = T.strip rest+                    in  if r == "ExitSuccess" then+                            GhciPassed+                        else+                            if "ExitFailure" `T.isPrefixOf` r then+                                GhciFailed+                            else+                                GhciCrashed r+        Nothing -> case List.find isCompileErrorLine outputLines of+            Just errLine -> GhciCrashed (T.strip errLine)+            Nothing -> GhciPassed+  where+    outputLines = T.lines output+    -- GHC compile/load errors are formatted as+    -- @<file-or-loc>:L:C: error: …@ (with at least one space after the colon).+    -- The substring @": error:"@ is the canonical marker for these.+    isCompileErrorLine line = ": error:" `T.isInfixOf` line
+ src/Tricorder/Effects/UnixSocket.hs view
@@ -0,0 +1,154 @@+module Tricorder.Effects.UnixSocket+    ( -- * Effect+      UnixSocket+    , bindSocket+    , acceptHandle+    , withConnection+    , readLine+    , sendLine+    , closeHandle+    , removeSocketFile+    , socketFileExists++      -- * Interpreters+    , runUnixSocketIO+    , runUnixSocketScripted+    , SocketScript (..)+    ) where++import Atelier.Effects.File (BufferMode (..), File, Handle)+import Atelier.Exception (trySyncIO)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, reinterpret)+import Effectful.Exception (finally)+import Effectful.State.Static.Shared (evalState, get, put)+import Effectful.TH (makeEffect)+import Network.Socket+    ( Family (..)+    , SockAddr (..)+    , Socket+    , SocketType (..)+    , accept+    , bind+    , defaultProtocol+    , listen+    , socket+    , socketToHandle+    )+import System.Directory (doesPathExist, removeFile)+import System.IO (hSetEncoding, utf8)++import Atelier.Effects.File qualified as File+import Network.Socket qualified as Net+++data UnixSocket :: Effect where+    -- | Create, bind, and listen on a Unix socket at the given path.+    BindSocket :: FilePath -> UnixSocket m Socket+    -- | Accept the next incoming connection and return a line-buffered 'Handle'.+    AcceptHandle :: Socket -> UnixSocket m Handle+    -- | Connect to a Unix socket and run the callback with the resulting handle.+    -- The handle is closed when the callback returns.+    WithConnection :: FilePath -> (Handle -> m a) -> UnixSocket m a+    -- | Read a line from a connected handle.+    ReadLine :: Handle -> UnixSocket m Text+    -- | Write a line to a connected handle and flush.+    SendLine :: Handle -> Text -> UnixSocket m ()+    -- | Close a connected handle.+    CloseHandle :: Handle -> UnixSocket m ()+    -- | Remove the socket file, ignoring errors (e.g. file not found).+    RemoveSocketFile :: FilePath -> UnixSocket m ()+    -- | Check whether the socket file exists.+    SocketFileExists :: FilePath -> UnixSocket m Bool+++makeEffect ''UnixSocket+++-- | Production interpreter backed by real Unix sockets.+--+-- Socket creation and encoding setup require raw IO (no @File@ equivalent),+-- but the handle-level reads, writes, buffering and closing go through the+-- 'File' effect.+runUnixSocketIO :: (File :> es, IOE :> es) => Eff (UnixSocket : es) a -> Eff es a+runUnixSocketIO eff = interpretWith eff \env -> \case+    BindSocket path -> liftIO do+        sock <- socket AF_UNIX Stream defaultProtocol+        bind sock (SockAddrUnix path)+        listen sock 5+        pure sock+    AcceptHandle sock -> do+        h <- liftIO do+            (conn, _) <- accept sock+            h <- socketToHandle conn ReadWriteMode+            hSetEncoding h utf8+            pure h+        File.hSetBuffering h LineBuffering+        pure h+    WithConnection sockPath callback ->+        localSeqUnlift env \unlift -> do+            h <- liftIO do+                sock <- socket AF_UNIX Stream defaultProtocol+                Net.connect sock (SockAddrUnix sockPath)+                h <- socketToHandle sock ReadWriteMode+                hSetEncoding h utf8+                pure h+            File.hSetBuffering h LineBuffering+            unlift (callback h) `finally` File.hClose h+    ReadLine h -> File.hGetLine h+    SendLine h line -> File.hPutTextLn h line >> File.hFlush h+    CloseHandle h -> File.hClose h+    RemoveSocketFile path ->+        liftIO $ void $ trySyncIO $ removeFile path+    SocketFileExists path ->+        liftIO $ doesPathExist path+++-- | Script element for the test interpreter.+data SocketScript+    = -- | Return this 'Handle' for the next 'acceptHandle' call.+      NextAccept Handle+    | -- | Return this 'Bool' for the next 'socketFileExists' call.+      NextFileCheck Bool+    | -- | Use this 'Handle' for the next 'withConnection' call.+      NextConnect Handle+    | -- | Return this text for the next 'readLine' call.+      NextReadLine Text+++-- | Scripted interpreter for testing.+--+-- 'bindSocket' creates a real (unbound) socket so that the returned 'Socket'+-- is a valid value, but does not actually bind to the filesystem.+-- 'acceptHandle' pops the next 'NextAccept' entry from the queue and sets+-- line buffering on it. 'removeSocketFile' is always a no-op.+-- 'socketFileExists' pops the next 'NextFileCheck' entry.+-- 'withConnection' pops the next 'NextConnect' entry and passes it to the callback.+runUnixSocketScripted :: (File :> es, IOE :> es) => [SocketScript] -> Eff (UnixSocket : es) a -> Eff es a+runUnixSocketScripted script = reinterpret (evalState script) \env -> \case+    BindSocket _ ->+        liftIO $ Net.socket AF_UNIX Stream defaultProtocol+    AcceptHandle _ ->+        get >>= \case+            NextAccept h : rest -> do+                put rest+                File.hSetBuffering h LineBuffering+                pure h+            _ -> error "UnixSocketScripted: expected NextAccept but queue was empty or mismatched"+    WithConnection _ callback ->+        get >>= \case+            NextConnect h : rest -> do+                put rest+                localSeqUnlift env \unlift -> unlift (callback h)+            _ -> error "UnixSocketScripted: expected NextConnect but queue was empty or mismatched"+    ReadLine _ ->+        get >>= \case+            NextReadLine line : rest -> put rest >> pure line+            _ -> error "UnixSocketScripted: expected NextReadLine but queue was empty or mismatched"+    SendLine _ _ -> pure ()+    CloseHandle _ -> pure ()+    RemoveSocketFile _ -> pure ()+    SocketFileExists _ ->+        get >>= \case+            NextFileCheck b : rest -> put rest >> pure b+            _ -> error "UnixSocketScripted: expected NextFileCheck but queue was empty or mismatched"
+ src/Tricorder/Events/FileChanged.hs view
@@ -0,0 +1,6 @@+module Tricorder.Events.FileChanged (FileChanged (..)) where+++-- | A relevant source file was modified on disk.+newtype FileChanged = FileChanged {path :: FilePath}+    deriving stock (Eq, Show)
+ src/Tricorder/GhcPkg/Types.hs view
@@ -0,0 +1,26 @@+module Tricorder.GhcPkg.Types+    ( ModuleName (..)+    , PackageId (..)+    , SourceQuery (..)+    ) where++import Data.Aeson (FromJSON, ToJSON)+++-- | A dotted Haskell module name, e.g. @"Data.Map.Strict"@.+newtype ModuleName = ModuleName {unModuleName :: Text}+    deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON)+++-- | A @ghc-pkg@ package identifier, e.g. @"containers-0.6.8"@.+newtype PackageId = PackageId {unPackageId :: Text}+    deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON)+++-- | A query for module source: optionally scoped to a single top-level binding.+data SourceQuery = SourceQuery+    { moduleName :: ModuleName+    , function :: Maybe Text -- Nothing = whole module, Just fn = single binding+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, Hashable, ToJSON)
+ src/Tricorder/Observability.hs view
@@ -0,0 +1,71 @@+module Tricorder.Observability+    ( Config (..)+    , MetricsConfig (..)+    , component+    ) where++import Atelier.Component (Component (..), Trigger, defaultComponent)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Monitoring.Metrics.Server (MetricsServer)+import Atelier.Effects.Monitoring.Tracing (TracingConfig)+import Atelier.Time (Millisecond)+import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+import Effectful.Exception (trySync)+import Effectful.Reader.Static (Reader, ask)++import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Monitoring.Metrics.Server qualified as MetricsServer+++data MetricsConfig = MetricsConfig+    { enabled :: Bool+    , port :: Int+    }+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake MetricsConfig+    deriving (FromJSON) via WithDefaults (QuietSnake MetricsConfig)+++instance Default MetricsConfig where+    def = MetricsConfig {enabled = False, port = 9091}+++data Config = Config+    { metrics :: MetricsConfig+    , tracing :: TracingConfig+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON) via QuietSnake Config+++instance Default Config where+    def = Config {metrics = def, tracing = def}+++component :: (Delay :> es, Log :> es, MetricsServer :> es, Reader Config :> es) => Component es+component =+    defaultComponent+        { name = "Observability"+        , triggers = do+            cfg <- ask @Config+            pure+                $ if cfg.metrics.enabled then+                    [metricsServerTrigger cfg.metrics.port]+                else+                    []+        }+++metricsServerTrigger :: (Delay :> es, Log :> es, MetricsServer :> es) => Int -> Trigger es+metricsServerTrigger port = do+    result <- trySync $ MetricsServer.runMetricsServer port+    case result of+        Right () -> pure ()+        Left e ->+            Log.warn $ "Metrics server on port " <> show port <> " failed to start: " <> show e+    forever $ Delay.wait (3_600_000 :: Millisecond)
+ src/Tricorder/Runtime.hs view
@@ -0,0 +1,95 @@+module Tricorder.Runtime+    ( PidFile (..)+    , runPidFile+    , ProjectRoot (..)+    , runProjectRoot+    , RuntimeDir (..)+    , runRuntimeDir+    , runRuntimeDirItem+    , SocketPath (..)+    , runSocketPath+    , LogPath (..)+    , runLogPath+    ) where++import Atelier.Effects.FileSystem+    ( FileSystem+    , canonicalizePath+    , createDirectoryIfMissing+    , getCurrentDirectory+    , getXdgRuntimeDir+    )+import Atelier.Effects.Posix.Daemons (PidFile (..))+import Effectful.Reader.Static (Reader, ask, runReader)+import Numeric (showHex)+import System.FilePath ((</>))+++newtype SocketPath = SocketPath {getSocketPath :: FilePath}+++runSocketPath+    :: (Reader RuntimeDir :> es)+    => Eff (Reader SocketPath : es) a+    -> Eff es a+runSocketPath = runRuntimeDirItem "socket.sock" SocketPath+++newtype RuntimeDir = RuntimeDir {getRuntimeDir :: FilePath}+++runRuntimeDir+    :: ( FileSystem :> es+       , Reader ProjectRoot :> es+       )+    => Eff (Reader RuntimeDir : es) a -> Eff es a+runRuntimeDir act = do+    ProjectRoot projectRoot <- ask+    runtimeDir <- getXdgRuntimeDir+    canonProjectRoot <- canonicalizePath projectRoot+    let projectDirHash = hashPath canonProjectRoot+        dir = runtimeDir </> "tricorder" </> projectDirHash+    createDirectoryIfMissing True dir+    runReader (RuntimeDir dir) act+++runRuntimeDirItem+    :: (Reader RuntimeDir :> es)+    => FilePath+    -- ^ Path segment to append to runtime dir.+    -> (FilePath -> a)+    -- ^ Constructor for the resulting type.+    -> Eff (Reader a : es) b+    -> Eff es b+runRuntimeDirItem path mk act = do+    RuntimeDir runtimeDir <- ask+    runReader (mk $ runtimeDir </> path) act+++newtype ProjectRoot = ProjectRoot {getProjectRoot :: FilePath}+++runProjectRoot+    :: (FileSystem :> es, HasCallStack)+    => Eff (Reader ProjectRoot : es) a -> Eff es a+runProjectRoot act = do+    projectRoot <- getCurrentDirectory+    runReader (ProjectRoot projectRoot) act+++runPidFile :: (Reader RuntimeDir :> es) => Eff (Reader PidFile : es) a -> Eff es a+runPidFile = runRuntimeDirItem "daemon.pid" PidFile+++newtype LogPath = LogPath {getLogPath :: FilePath}+++runLogPath :: (Reader RuntimeDir :> es) => Eff (Reader LogPath : es) a -> Eff es a+runLogPath = runRuntimeDirItem "daemon.log" LogPath+++-- | Polynomial hash of a file path, returned as a hex string.+hashPath :: FilePath -> String+hashPath path =+    let n = foldl' (\acc c -> acc * 31 + toInteger (ord c)) (0 :: Integer) path+    in  showHex (abs n `mod` (16 ^ (16 :: Integer))) ""
+ src/Tricorder/Session.hs view
@@ -0,0 +1,302 @@+module Tricorder.Session+    ( Session (..)+    , Config (..)+    , loadSession+    , resolveCommand+    , resolveTargets+    , discoverCabalFiles+    , allComponentTargets+    , resolveTestTargets+    , resolveWatchDirs+    , sourceDirsForTarget+    ) where++import Atelier.Config (LoadedConfig, extractConfig)+import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs)+import Atelier.Effects.Log (Log)+import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))+import Data.Aeson (FromJSON)+import Data.Default (Default (..))+import Data.List (nub)+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+    , condExecutables+    , 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.Reader.Static (Reader, ask)+import System.FilePath (normalise, takeDirectory, takeExtension, (</>))++import Atelier.Effects.Log qualified as Log+import Data.ByteString.Char8 qualified as BC+import Data.Text qualified as T++import Tricorder.Runtime (ProjectRoot (..))+++data Session = Session+    { command :: Text+    , targets :: [Text]+    , testTargets :: [Text]+    , watchDirs :: [FilePath]+    , outputFile :: Maybe FilePath+    , replBuildDir :: FilePath+    , testTimeout :: Int+    }+++instance Default Session where+    def =+        Session+            { command = ""+            , targets = []+            , testTargets = []+            , watchDirs = []+            , outputFile = Nothing+            , replBuildDir = "/tmp"+            , testTimeout = 10+            }+++data Config = Config+    { command :: Maybe Text+    , targets :: [Text]+    , watchDirs :: [FilePath]+    , testTargets :: Maybe [Text]+    , outputFile :: Maybe FilePath+    , replBuildDir :: FilePath+    , testTimeout :: Int+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON) via WithDefaults (QuietSnake Config)+++instance Default Config where+    def =+        Config+            { command = Nothing+            , targets = []+            , watchDirs = []+            , testTargets = Nothing+            , outputFile = Just "build.json"+            , replBuildDir = "dist-newstyle/tricorder"+            , testTimeout = 10+            }+++-- | Resolve the GHCi command, using config if set or autodetecting otherwise.+resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> Eff es Text+resolveCommand projectRoot cfg =+    case cfg.command of+        Just cmd -> pure cmd+        Nothing -> detectCommand cfg.targets cfg.replBuildDir projectRoot+++detectCommand :: (FileSystem :> es) => [Text] -> FilePath -> ProjectRoot -> Eff es Text+detectCommand targets 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+        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+++-- | Resolve the directories to watch.+--+-- Priority:+-- 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 projectRoot cabalFiles cfg targets =+    case cfg.watchDirs of+        dirs@(_ : _) -> pure $ map (coerce projectRoot </>) dirs+        [] -> resolveWatchDirsFromTargets cabalFiles targets+++resolveWatchDirsFromTargets :: (FileSystem :> es) => [FilePath] -> [Text] -> Eff es [FilePath]+resolveWatchDirsFromTargets _ [] = pure ["."]+resolveWatchDirsFromTargets cabalFiles targets = do+    dirs <- nub . concat <$> traverse watchDirsForCabal cabalFiles+    pure $ 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+    -- single-package project that directory is the project root; in a+    -- multi-package project it's the per-package subdirectory. Targets that+    -- don't belong to this package yield no dirs.+    watchDirsForCabal cabalFile = do+        contents <- readFileBs cabalFile+        let pkgDir = takeDirectory cabalFile+        pure $ case parseGenericPackageDescriptionMaybe contents of+            Nothing -> []+            Just gpd -> map (pkgDir </>) (concatMap (sourceDirsForTarget gpd) targets)+++sourceDirsForTarget :: GenericPackageDescription -> Text -> [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)+        _ -> []+  where+    libDirs = hsSourceDirs . libBuildInfo+    testDirs = hsSourceDirs . testBuildInfo+    exeDirs = hsSourceDirs . buildInfo+++-- | 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+resolveTargets cabalFiles [] =+    concat <$> traverse targetsFromCabal cabalFiles+  where+    targetsFromCabal path = do+        contents <- readFileBs path+        pure $ maybe [] allComponentTargets (parseGenericPackageDescriptionMaybe contents)+++-- | 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@+-- file(s) sit in the root. Called once per session load; the result is shared+-- by target and watch-dir resolution.+discoverCabalFiles :: (FileSystem :> es, Log :> es) => ProjectRoot -> Eff es [FilePath]+discoverCabalFiles (ProjectRoot projectRoot) = do+    hasProject <- doesFileExist projectFile+    cabalFiles <-+        if hasProject then do+            contents <- readFileBs projectFile+            concat <$> traverse cabalFilesForEntry (projectPackageEntries contents)+        else+            cabalFilesIn projectRoot+    let listed+            | null cabalFiles = "none"+            | otherwise = T.intercalate ", " (map toText cabalFiles)+    if hasProject then+        Log.info+            $ "Found cabal.project; discovered "+                <> show (length cabalFiles)+                <> " package cabal file(s): "+                <> listed+    else+        Log.info $ "No cabal.project; using cabal file(s) in project root: " <> listed+    pure cabalFiles+  where+    projectFile = projectRoot </> "cabal.project"++    -- A @packages:@ entry is either a direct path to a @.cabal@ file or a+    -- directory to search for one.+    cabalFilesForEntry entry+        | takeExtension entry == ".cabal" = pure [projectRoot </> entry]+        | otherwise = cabalFilesIn (normalise (projectRoot </> entry))+++-- | List the @.cabal@ files directly inside a directory.+cabalFilesIn :: (FileSystem :> es) => FilePath -> Eff es [FilePath]+cabalFilesIn dir = do+    entries <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory dir+    pure $ map (dir </>) entries+++-- | Extract the directory/file entries from the @packages:@ field of a+-- @cabal.project@. Glob entries (containing @*@) are not expanded and are+-- skipped.+projectPackageEntries :: ByteString -> [FilePath]+projectPackageEntries contents =+    case readFields contents of+        Left _ -> []+        Right fields -> filter (notElem '*') (concatMap fromField fields)+  where+    fromField (Field (Name _ name) fieldLines)+        | name == "packages" = concatMap fromLine fieldLines+    fromField _ = []+    fromLine (FieldLine _ bs) = map BC.unpack (BC.words bs)+++allComponentTargets :: GenericPackageDescription -> [Text]+allComponentTargets gpd =+    mainLibTargets+        ++ subLibTargets+        ++ exeTargets+        ++ testTargets+  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)+++-- | 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]+resolveTestTargets cfg targets = case cfg.testTargets of+    Just explicit -> explicit+    Nothing -> filter ("test:" `T.isPrefixOf`) targets+++loadSession+    :: ( FileSystem :> es+       , Log :> es+       , Reader LoadedConfig :> es+       , Reader ProjectRoot :> es+       )+    => Eff es Session+loadSession = do+    projectRoot <- ask @ProjectRoot+    loadedCfg <- ask+    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+    pure+        $ Session+            { targets = effectiveTargets+            , command+            , watchDirs+            , testTargets+            , outputFile = cfgFile.outputFile+            , replBuildDir = cfgFile.replBuildDir+            , testTimeout = cfgFile.testTimeout+            }
+ src/Tricorder/Socket/Client.hs view
@@ -0,0 +1,153 @@+module Tricorder.Socket.Client+    ( queryStatus+    , queryStatusWait+    , queryWatch+    , Restarting (..)+    , querySource+    , queryDiagnostic+    , requestShutdown+    , isDaemonRunning+    ) where++import Atelier.Effects.Delay (Delay)+import Atelier.Effects.File (File, Handle)+import Atelier.Effects.Posix.Daemons (Daemons)+import Atelier.Time (Millisecond)+import Data.Aeson (decode, eitherDecode, encode)+import Effectful (inject)+import Effectful.Exception (catchJust, trySync)+import Effectful.Reader.Static (Reader, ask)+import Effectful.State.Static.Shared (evalState, get, modify, put)+import System.IO.Error (isEOFError)++import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.File qualified as File+import Atelier.Effects.Posix.Daemons qualified as Daemons+import Data.ByteString.Lazy qualified as BSL++import Tricorder.BuildState (BuildState, Diagnostic)+import Tricorder.Effects.UnixSocket (UnixSocket, withConnection)+import Tricorder.GhcPkg.Types (SourceQuery)+import Tricorder.Runtime (PidFile)+import Tricorder.Socket.Protocol (ClientMessage (..), DiagnosticQuery (..), Query (..), StatusQuery (..))+import Tricorder.SourceLookup (ModuleSourceResult)++import Tricorder.Version qualified as Version+++-- | Query the current build status (non-blocking).+queryStatus+    :: (File :> es, UnixSocket :> es)+    => FilePath+    -> Eff es (Either Text BuildState)+queryStatus sockPath = withConnection sockPath \h -> do+    sendQuery h (Status (StatusQuery {awaitDone = False}))+    receiveState h+++-- | Query the build status, blocking until the current build cycle completes.+queryStatusWait+    :: (File :> es, UnixSocket :> es)+    => FilePath+    -> Eff es (Either Text BuildState)+queryStatusWait sockPath = withConnection sockPath \h -> do+    sendQuery h (Status (StatusQuery {awaitDone = True}))+    receiveState h+++data Restarting = Restarting+++-- | Connect and stream build updates, calling the handler after each completed build.+-- Retries automatically when the connection is lost or the daemon is restarting.+queryWatch+    :: forall es+     . (Delay :> es, File :> es, UnixSocket :> es)+    => FilePath+    -> (Either Restarting BuildState -> Eff es ())+    -> Eff es ()+queryWatch sockPath handler = evalState retryLimit retryLoop+  where+    retryLimit = 3 :: Int+    retryLoop = do+        retries <- get @Int+        if retries <= 0 then+            pure ()+        else do+            void $ trySync $ withConnection sockPath \h -> sendQuery h Watch >> loop h+            Delay.wait (500 :: Millisecond)+            modify $ subtract 1+            retryLoop++    loop h = do+        mLine <-+            catchJust+                (\e -> if isEOFError e then Just e else Nothing)+                (Just <$> File.hGetLine h)+                (\_ -> pure Nothing)+        case mLine of+            Nothing -> inject $ handler (Left Restarting)+            Just line ->+                case decode (BSL.fromStrict (encodeUtf8 (toText line))) of+                    Nothing -> pure ()+                    Just state -> do+                        put retryLimit+                        inject (handler (Right state)) >> loop h+++-- | Look up the source for one or more modules via the daemon.+querySource+    :: (File :> es, UnixSocket :> es)+    => FilePath+    -> [SourceQuery]+    -> Eff es (Either Text [ModuleSourceResult])+querySource sockPath queries = withConnection sockPath \h -> do+    sendQuery h (Source queries)+    line <- File.hGetLine h+    case eitherDecode (BSL.fromStrict (encodeUtf8 (toText line))) of+        Left err -> pure $ Left (toText err)+        Right results -> pure $ Right results+++-- | Fetch the full body of a single diagnostic by 1-based index.+queryDiagnostic+    :: (File :> es, UnixSocket :> es)+    => FilePath+    -> Int+    -> Eff es (Either Text Diagnostic)+queryDiagnostic sockPath idx = withConnection sockPath \h -> do+    sendQuery h (DiagnosticAt (DiagnosticQuery {index = idx}))+    line <- File.hGetLine h+    case eitherDecode (BSL.fromStrict (encodeUtf8 (toText line))) of+        Left err -> pure $ Left (toText err)+        Right d -> pure $ Right d+++requestShutdown :: (File :> es, UnixSocket :> es) => FilePath -> Eff es (Either Text ())+requestShutdown sockPath = withConnection sockPath \h -> do+    sendQuery h Quit+    line <- File.hGetLine h+    if eitherDecode (BSL.fromStrict (encodeUtf8 line)) == Right True then+        pure $ Right ()+    else+        pure $ Left "Failed to request shutdown"+++isDaemonRunning :: (Daemons :> es, Reader PidFile :> es) => Eff es Bool+isDaemonRunning = do+    pidFile <- ask+    Daemons.isRunning pidFile+++-- internals++sendQuery :: (File :> es) => Handle -> Query -> Eff es ()+sendQuery h q = File.hPutLBsLn h $ encode ClientMessage {clientVersion = Version.gitHash, payload = q}+++receiveState :: (File :> es) => Handle -> Eff es (Either Text BuildState)+receiveState h = do+    line <- File.hGetLine h+    case eitherDecode (BSL.fromStrict (encodeUtf8 (toText line))) of+        Left err -> pure $ Left (toText err)+        Right state -> pure $ Right state
+ src/Tricorder/Socket/Protocol.hs view
@@ -0,0 +1,44 @@+module Tricorder.Socket.Protocol+    ( Query (..)+    , StatusQuery (..)+    , DiagnosticQuery (..)+    , ErrorResponse (..)+    , ClientMessage (..)+    ) where++import Data.Aeson (FromJSON, ToJSON)++import Tricorder.GhcPkg.Types (SourceQuery)+++data StatusQuery = StatusQuery {awaitDone :: Bool}+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++newtype DiagnosticQuery = DiagnosticQuery {index :: Int}+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data Query+    = Status StatusQuery+    | Watch+    | Source [SourceQuery]+    | DiagnosticAt DiagnosticQuery+    | Quit+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++newtype ErrorResponse = ErrorResponse {message :: Text}+    deriving stock (Eq, Generic, Show)+    deriving anyclass (ToJSON)+++data ClientMessage = ClientMessage+    { clientVersion :: Text+    , payload :: Query+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)
+ src/Tricorder/Socket/Server.hs view
@@ -0,0 +1,235 @@+module Tricorder.Socket.Server (component, SocketRemoved (..)) where++import Atelier.Component (Component (..), Trigger, defaultComponent)+import Atelier.Effects.Cache (Cache)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay, wait)+import Atelier.Effects.Exit (Exit, exitSuccess)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Log (Log)+import Atelier.Time (Millisecond)+import Data.Aeson (ToJSON, decode, encode)+import Effectful.Exception (IOException, finally)+import Effectful.Reader.Static (Reader, ask)+import System.IO (Handle)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Log qualified as Log+import Data.ByteString.Lazy qualified as BSL++import Tricorder.BuildState (BuildPhase (..), BuildResult (..), BuildState (..), Diagnostic)+import Tricorder.Effects.BuildStore (BuildStore, getState, waitForAnyChange, waitUntilDone)+import Tricorder.Effects.GhcPkg (GhcPkg)+import Tricorder.Effects.UnixSocket+    ( UnixSocket+    , acceptHandle+    , bindSocket+    , closeHandle+    , readLine+    , removeSocketFile+    , sendLine+    )+import Tricorder.GhcPkg.Types (SourceQuery (..))+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Socket.Protocol (ClientMessage (..), DiagnosticQuery (..), ErrorResponse (..), Query (..), StatusQuery (..))+import Tricorder.SourceLookup (ModuleName, PackageId, ReExport, lookupModuleSource)+import Tricorder.Version (VersionMismatch (..), checkVersion)+++data SocketRemoved = SocketRemoved+    deriving stock (Eq, Show)+    deriving anyclass (Exception)+++-- | SocketServer component.+-- Listens on a Unix socket and responds to status/watch/source queries.+component+    :: ( BuildStore :> es+       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+       , Cache ModuleName PackageId :> es+       , Conc :> es+       , Delay :> es+       , Exit :> es+       , FileSystem :> es+       , GhcPkg :> es+       , Log :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Component es+component =+    defaultComponent+        { name = "SocketServer"+        , setup = do+            SocketPath sockPath <- ask+            removeSocketFile sockPath+        , triggers = pure [acceptTrigger]+        }+++acceptTrigger+    :: ( BuildStore :> es+       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+       , Cache ModuleName PackageId :> es+       , Conc :> es+       , Delay :> es+       , Exit :> es+       , FileSystem :> es+       , GhcPkg :> es+       , Log :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Trigger es+acceptTrigger = do+    SocketPath sockPath <- ask+    sock <- bindSocket sockPath+    forever do+        h <- acceptHandle sock+        void $ Conc.forkTry @IOException do+            handleConnection h `finally` closeHandle h+++handleConnection+    :: ( BuildStore :> es+       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+       , Cache ModuleName PackageId :> es+       , Delay :> es+       , Exit :> es+       , FileSystem :> es+       , GhcPkg :> es+       , Log :> es+       , UnixSocket :> es+       )+    => Handle+    -> Eff es ()+handleConnection h = do+    line <- readLine h+    case decode (BSL.fromStrict (encodeUtf8 line)) of+        Nothing -> sendJson h (ErrorResponse "invalid request")+        Just ClientMessage {clientVersion, payload} -> do+            let result = checkVersion clientVersion+            case result of+                Left VersionMismatch {expected, received} -> do+                    Log.warn $ "Version mismatch: server=" <> expected <> " client=" <> received+                    dispatch payload h+                Right () -> dispatch payload h+++dispatch+    :: ( BuildStore :> es+       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+       , Cache ModuleName PackageId :> es+       , Delay :> es+       , Exit :> es+       , FileSystem :> es+       , GhcPkg :> es+       , Log :> es+       , UnixSocket :> es+       )+    => Query+    -> Handle+    -> Eff es ()+dispatch query h = case query of+    Status (StatusQuery False) -> respondOnce h+    Status (StatusQuery True) -> respondWhenDone h+    Watch -> watchStream h+    Source moduleNames -> respondSource moduleNames h+    DiagnosticAt dq -> respondDiagnostic dq.index h+    Quit -> quit h+++quit :: (Exit :> es, Log :> es, UnixSocket :> es) => Handle -> Eff es ()+quit h = do+    sendJson h True+    Log.info "Shutting down."+    exitSuccess+++respondOnce :: (BuildStore :> es, UnixSocket :> es) => Handle -> Eff es ()+respondOnce h = getState >>= sendJson h+++-- | Wait for a completed build, then respond.+--+-- If the build is already done when this is called, we may be racing the file+-- watcher's debounce: a file was just changed but the reload hasn't been+-- dispatched yet (default debounce is 100ms). Poll for up to 250ms to let+-- any in-flight debounce fire before falling back to the current result.+respondWhenDone :: (BuildStore :> es, Delay :> es, UnixSocket :> es) => Handle -> Eff es ()+respondWhenDone h = awaitResult >>= sendJson h+  where+    awaitResult = do+        s <- getState+        case s.phase of+            Building _ -> waitUntilDone+            Restarting -> waitUntilDone+            Testing _ -> waitUntilDone+            Done _ -> awaitBuildStart (5 :: Int) s+            BuildFailed _ -> pure s++    -- Poll up to n × 50ms for a build to start, then wait for it to finish.+    awaitBuildStart 0 s = pure s+    awaitBuildStart n _ = do+        wait (50 :: Millisecond)+        s' <- getState+        case s'.phase of+            Building _ -> waitUntilDone+            Restarting -> waitUntilDone+            Testing _ -> waitUntilDone+            Done _ -> awaitBuildStart (n - 1) s'+            BuildFailed _ -> pure s'+++-- | Stream a JSON object after each state change (loops until handle closes or error).+watchStream :: (BuildStore :> es, UnixSocket :> es) => Handle -> Eff es ()+watchStream h = do+    state0 <- getState+    sendJson h state0+    loop state0+  where+    loop prev = do+        newState <- waitForAnyChange prev+        sendJson h newState+        loop newState+++respondDiagnostic :: (BuildStore :> es, UnixSocket :> es) => Int -> Handle -> Eff es ()+respondDiagnostic idx h = do+    state <- getState+    case state.phase of+        Done r -> case r.diagnostics !!? (idx - 1) of+            Nothing ->+                sendJson h+                    $ ErrorResponse+                    $ "No diagnostic #"+                        <> show idx+                        <> " (current build has "+                        <> show (length r.diagnostics)+                        <> ")"+            Just d -> sendJson h (d :: Diagnostic)+        BuildFailed msg -> sendJson h $ ErrorResponse $ "Build command failed:\n" <> msg+        Building _ -> sendJson h $ ErrorResponse "Build in progress"+        Restarting -> sendJson h $ ErrorResponse "Build in progress"+        Testing _ -> sendJson h $ ErrorResponse "Build in progress"+++-- | Look up source for each requested module and send the results as a JSON array.+respondSource+    :: ( Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+       , Cache ModuleName PackageId :> es+       , FileSystem :> es+       , GhcPkg :> es+       , Log :> es+       , UnixSocket :> es+       )+    => [SourceQuery]+    -> Handle+    -> Eff es ()+respondSource queries h = do+    results <- mapM lookupModuleSource queries+    sendJson h results+++sendJson :: (ToJSON a, UnixSocket :> es) => Handle -> a -> Eff es ()+sendJson h val = sendLine h (decodeUtf8 (BSL.toStrict (encode val)))
+ src/Tricorder/SourceLookup.hs view
@@ -0,0 +1,296 @@+module Tricorder.SourceLookup+    ( -- * Types+      ModuleName+    , PackageId+    , SourceQuery (..)+    , ModuleSourceResult (..)+    , ReExport (..)++      -- * Lookup+    , lookupModuleSource++      -- * HTML extraction+    , extractSource+    , extractFunctionSource+    , extractReExports+    , stripAnnotations+    , stripTags+    , unescapeEntities+    ) where++import Atelier.Effects.Cache (Cache, cacheInsert, cacheLookup)+import Atelier.Effects.FileSystem (FileSystem, doesFileExist, readFileLbs)+import Atelier.Effects.Log (Log)+import Data.Aeson (FromJSON, ToJSON)+import Data.List (findIndex)+import System.FilePath ((</>))++import Atelier.Effects.Log qualified as Log+import Data.ByteString.Lazy qualified as BSL+import Data.Text qualified as T++import Tricorder.Effects.GhcPkg (GhcPkg)+import Tricorder.GhcPkg.Types (ModuleName (..), PackageId (..), SourceQuery (..))++import Tricorder.Effects.GhcPkg qualified as GhcPkg+++-- | A re-exported name or module from a module's export list.+data ReExport+    = -- | Whole-module re-export: @module GHC.Enum@+      ReExportModule Text+    | -- | Single name re-export: (name, source-module)+      ReExportName Text Text+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++-- | The result of a source lookup for a single module.+data ModuleSourceResult+    = -- | Source was found; contains the stripped Haskell source text and re-exports.+      SourceFound SourceQuery Text [ReExport]+    | -- | The module is not provided by any installed package.+      SourceNotFound SourceQuery+    | -- | The package was found but has no haddock-html field (built without docs).+      SourceNoHaddock SourceQuery PackageId+    | -- | The module was found but the requested function was not in the source.+      FunctionNotFound SourceQuery+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++-- ── Lookup logic ───────────────────────────────────────────────────────────++-- | Resolve and return the source for a single module.+--+-- Checks both cache levels before issuing any shell-outs.+lookupModuleSource+    :: ( Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+       , Cache ModuleName PackageId :> es+       , FileSystem :> es+       , GhcPkg :> es+       , Log :> es+       )+    => SourceQuery+    -> Eff es ModuleSourceResult+lookupModuleSource query = do+    mCachedPkg <- cacheLookup @ModuleName @PackageId query.moduleName+    pkgId <- case mCachedPkg of+        Just p -> do+            Log.debug $ "Source: " <> unModuleName query.moduleName <> " → " <> unPackageId p <> " (cached)"+            pure (Just p)+        Nothing -> do+            result <- GhcPkg.findModule query.moduleName+            Log.debug $ "Source: find-module " <> unModuleName query.moduleName <> " → " <> show result+            case result of+                Nothing -> pure Nothing+                Just p -> do+                    cacheInsert @ModuleName @PackageId query.moduleName p+                    pure (Just p)+    case pkgId of+        Nothing -> pure (SourceNotFound query)+        Just p -> do+            mCachedSrc <- cacheLookup @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query)+            case mCachedSrc of+                Just (src, reExports) -> do+                    Log.debug $ "Source: " <> unModuleName query.moduleName <> " source hit (cached)"+                    pure (SourceFound query src reExports)+                Nothing -> do+                    mHtmlRoot <- GhcPkg.getHaddockHtml p+                    Log.debug $ "Source: haddock-html for " <> unPackageId p <> " → " <> show mHtmlRoot+                    case mHtmlRoot of+                        Nothing -> pure (SourceNoHaddock query p)+                        Just htmlRoot -> do+                            -- Haddock generates hyperlinked source in one of two layouts:+                            --   dotted:  src/Data.Map.Strict.html   (newer Haddock / haskell.nix)+                            --   slashed: src/Data/Map/Strict.html   (older Haddock / cabal local)+                            let htmlPathDotted = htmlRoot </> "src" </> toString (unModuleName query.moduleName) <> ".html"+                                htmlPathSlashed = htmlRoot </> "src" </> toString (T.map dotToSlash (unModuleName query.moduleName)) <> ".html"+                            Log.debug $ "Source: reading " <> toText htmlPathDotted+                            mHtml <-+                                readHaddockHtml htmlPathDotted >>= \case+                                    Just html -> pure (Just html)+                                    Nothing -> readHaddockHtml htmlPathSlashed+                            case mHtml of+                                Nothing -> do+                                    Log.debug $ "Source: file not found: " <> toText htmlPathDotted+                                    pure (SourceNoHaddock query p)+                                Just html -> do+                                    let reExports = extractReExports query.moduleName html+                                    case query.function of+                                        Nothing -> do+                                            let src = extractSource html+                                            cacheInsert @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query) (src, reExports)+                                            pure (SourceFound query src reExports)+                                        Just fn ->+                                            case extractFunctionSource fn html of+                                                Just src -> do+                                                    cacheInsert @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query) (src, reExports)+                                                    pure (SourceFound query src reExports)+                                                Nothing ->+                                                    pure (FunctionNotFound query)+  where+    dotToSlash '.' = '/'+    dotToSlash c = c+++-- ── HTML extraction ────────────────────────────────────────────────────────++-- | Read the raw Haddock hyperlinked-source HTML file.+readHaddockHtml :: (FileSystem :> es) => FilePath -> Eff es (Maybe Text)+readHaddockHtml htmlPath = do+    exists <- doesFileExist htmlPath+    if not exists then+        pure Nothing+    else+        Just . decodeUtf8 . BSL.toStrict <$> readFileLbs htmlPath+++-- | Extract the raw Haskell source from Haddock hyperlinked-source HTML.+-- Line spans are split and their numeric prefixes stripped before annotation+-- removal so that 'stripAnnotations' sees well-formed per-line chunks.+extractSource :: Text -> Text+extractSource html =+    let (_, after) = T.breakOn "<pre" html+    in  if T.null after then+            unescapeEntities (stripTags (stripAnnotations html))+        else+            let afterOpen = T.drop 1 $ T.dropWhile (/= '>') after+                content = fst $ T.breakOn "</pre>" afterOpen+                lineChunks = T.splitOn "<span id=\"line-" content+                -- hd is pre-span preamble (no N"> prefix); only tail chunks need stripping.+                stripped = case lineChunks of+                    [] -> ""+                    (hd : tl) -> T.concat (hd : map stripLineNumPrefix tl)+            in  unescapeEntities (stripTags (stripAnnotations stripped))+++-- | Strip the @N"\>@ prefix from a chunk produced by splitting on @\<span id=\"line-@.+stripLineNumPrefix :: Text -> Text+stripLineNumPrefix chunk = T.drop 1 $ T.dropWhile (/= '>') chunk+++-- | Extract the source of a single top-level binding from Haddock source HTML.+-- Finds the span with id matching the function name, then expands to the+-- surrounding blank-line-delimited block (type sig + docstring above, body below).+extractFunctionSource :: Text -> Text -> Maybe Text+extractFunctionSource funcName html =+    let (_, after) = T.breakOn "<pre" html+        afterOpen = T.drop 1 $ T.dropWhile (/= '>') after+        content = fst $ T.breakOn "</pre>" afterOpen+        lineChunks = T.splitOn "<span id=\"line-" content+        target = "id=\"" <> funcName <> "\""+    in  case findIndex (T.isInfixOf target) lineChunks of+            Nothing -> Nothing+            Just i ->+                let (pre, rest) = splitAt i lineChunks+                in  case rest of+                        [] -> Nothing+                        (defLine : post) ->+                            let before = reverse $ takeWhile (not . isBlankChunk) $ reverse pre+                                after' = takeWhile (not . isBlankChunk) post+                                selected = before <> [defLine] <> after'+                            in  Just $ unescapeEntities $ stripTags $ stripAnnotations $ T.concat (map stripLineNumPrefix selected)+  where+    isBlankChunk chunk =+        T.null (T.strip (stripTags (stripLineNumPrefix chunk)))+++-- | Extract re-exported names\/modules from Haddock source HTML.+extractReExports :: ModuleName -> Text -> [ReExport]+extractReExports modName html =+    let afterMod = snd $ T.breakOn "<span class=\"hs-keyword\">module</span>" html+        exportRgn = fst $ T.breakOn "<span class=\"hs-keyword\">where</span>" afterMod+    in  go exportRgn+  where+    modFile = unModuleName modName <> ".html"++    go :: Text -> [ReExport]+    go region+        | T.null region = []+        | otherwise =+            let (before, rest) = T.breakOn "<a href=\"" region+            in  if T.null rest then+                    []+                else+                    let afterHref = T.drop (T.length "<a href=\"") rest+                        (href, rest2) = T.breakOn "\"" afterHref+                        afterClose = T.drop 1 rest2+                        isModRe = T.isInfixOf "<span class=\"hs-keyword\">module</span>" before+                        (_, rest3) = T.breakOn ">" afterClose+                        innerHtml = fst $ T.breakOn "</a>" (T.drop 1 rest3)+                        name = T.strip $ stripTags innerHtml+                        entry+                            | T.null name = Nothing+                            | isLocal href = Nothing+                            | isModRe = Just (ReExportModule name)+                            | otherwise = Just (reExportName href name)+                        rest' = T.drop (T.length "</a>") $ snd $ T.breakOn "</a>" rest+                    in  maybeToList entry <> go rest'++    isLocal :: Text -> Bool+    isLocal href =+        let modPart = T.dropEnd 5 modFile+            sf = T.map (\c -> if c == '.' then '/' else c) modPart <> ".html"+            hrefBase = fst $ T.breakOn "#" href -- strip fragment before comparing+        in  modFile `T.isSuffixOf` hrefBase || sf `T.isSuffixOf` hrefBase++    reExportName :: Text -> Text -> ReExport+    reExportName href name = ReExportName name (deriveModuleName href)+      where+        deriveModuleName h =+            let allParts = T.splitOn "/" h+                fileName = fromMaybe h $ viaNonEmpty last $ filter (not . T.null) allParts+                fileOnly = fst $ T.breakOn "#" fileName+                dotted' = fst $ T.breakOn ".html" fileOnly+            in  if T.isInfixOf "." dotted' then+                    dotted'+                else+                    let revParts = reverse allParts+                        modDirs = takeWhile isModComponent (drop 1 revParts)+                        prefix = T.intercalate "." (reverse modDirs)+                    in  if T.null prefix then dotted' else prefix <> "." <> dotted'++        isModComponent t =+            not (T.null t) && not (T.isPrefixOf "." t) && isUpper (T.head t)+          where+            isUpper c = c >= 'A' && c <= 'Z'+++-- | Remove @\<span class=\"annottext\"\>...\<\/span\>@ blocks including their content.+-- Haddock embeds elaborated GHC types as hover tooltips; they must be excised+-- before 'stripTags' so they don't pollute the plain-text source output.+stripAnnotations :: Text -> Text+stripAnnotations t+    | T.null t = t+    | otherwise =+        let marker = "<span class=\"annottext\">"+            (before, rest) = T.breakOn marker t+        in  if T.null rest then+                before+            else+                let afterOpen = T.drop (T.length marker) rest+                    afterClose = T.drop (T.length "</span>") $ snd $ T.breakOn "</span>" afterOpen+                in  before <> stripAnnotations afterClose+++-- | Remove all @\<...\>@ sequences from text.+stripTags :: Text -> Text+stripTags t+    | T.null t = t+    | otherwise =+        let (before, rest) = T.breakOn "<" t+        in  if T.null rest then+                before+            else+                before <> stripTags (T.drop 1 (T.dropWhile (/= '>') rest))+++-- | Unescape the HTML entities produced by Haddock.+unescapeEntities :: Text -> Text+unescapeEntities =+    T.replace "&lt;" "<"+        . T.replace "&gt;" ">"+        . T.replace "&amp;" "&"+        . T.replace "&#39;" "'"+        . T.replace "&quot;" "\""
+ src/Tricorder/TestOutput.hs view
@@ -0,0 +1,88 @@+module Tricorder.TestOutput (parseHspecOutput, parseHspecDuration, stripGhciNoise) where++import Atelier.Time (Millisecond, fromMicroseconds)+import Data.Char (isDigit)++import Data.Text qualified as T++import Tricorder.BuildState (TestCase (..), TestCaseOutcome (..))+++-- | Parse hspec output into individual test case results.+--+-- Recognises lines ending with @OK@ or @FAIL@ (right-aligned, space-padded),+-- with or without a trailing timing annotation like @(0.05s)@ or @(120ms)@.+-- For failing tests, collects the indented detail lines that follow as the+-- failure message.+parseHspecOutput :: Text -> [TestCase]+parseHspecOutput = go . T.lines+  where+    go [] = []+    go (l : ls)+        | T.isSuffixOf "OK" norm =+            TestCase {description = extractDesc "OK" norm, outcome = TestCasePassed}+                : go ls+        | T.isSuffixOf "FAIL" norm =+            let (detailLines, rest) = span (\dl -> indentOf dl > indentOf l) ls+                details = T.intercalate "\n" $ filter (not . T.null) $ map T.strip detailLines+            in  TestCase {description = extractDesc "FAIL" norm, outcome = TestCaseFailed details}+                    : go rest+        | otherwise = go ls+      where+        norm = stripTimingAnnotation (T.stripEnd l)++    extractDesc suffix l =+        T.strip $ T.dropEnd (T.length suffix) $ T.stripEnd l++    indentOf = T.length . T.takeWhile (== ' ')+++-- | Strip a trailing hspec timing annotation of the form @" (0.05s)"@ or @" (120ms)"@.+--+-- Scans from the end of the line: strips the closing @)@, walks backwards+-- through digits, @.@, @s@, @m@, @μ@, then requires @(@ followed by a space.+-- Returns the input unchanged if the suffix does not match this pattern.+stripTimingAnnotation :: Text -> Text+stripTimingAnnotation t+    | T.null t || T.last t /= ')' = t+    | otherwise =+        let withoutClose = T.init t+            (timePart, rest) = T.span (\c -> isDigit c || c `elem` (".smμ" :: [Char])) (T.reverse withoutClose)+        in  if T.null timePart then+                t+            else case T.uncons rest of+                Just ('(', afterParen) ->+                    case T.uncons afterParen of+                        Just (' ', desc) -> T.stripEnd (T.reverse desc)+                        _ -> t+                _ -> t+++-- | Extract the test suite duration from hspec summary output.+-- Matches non-indented summary lines ending with @"(Xs)"@,+-- e.g. @"All 160 tests passed (0.33s)"@ or @"1 out of 177 tests failed (0.06s)"@.+parseHspecDuration :: Text -> Maybe Millisecond+parseHspecDuration output =+    listToMaybe $ mapMaybe extractMs (T.lines output)+  where+    extractMs line = do+        guard $ not (T.isPrefixOf " " line)+        guard $ T.isSuffixOf "s)" line+        let numStr = T.takeWhileEnd (/= '(') (T.dropEnd 2 line)+        secs <- readMaybe (T.unpack numStr) :: Maybe Double+        pure $ fromMicroseconds (round (secs * 1_000_000))+++-- | Strip GHCi/cabal startup and shutdown noise from captured output lines.+stripGhciNoise :: [Text] -> [Text]+stripGhciNoise ls =+    case dropWhile (not . T.isPrefixOf "ghci> ") ls of+        [] -> ls+        _ : afterPrompt -> reverse $ dropWhile isGhciNoiseLine $ reverse afterPrompt+++isGhciNoiseLine :: Text -> Bool+isGhciNoiseLine l =+    T.isPrefixOf "ghci>" l+        || l == "Leaving GHCi."+        || T.isPrefixOf "*** Exception: " l
+ src/Tricorder/UI.hs view
@@ -0,0 +1,89 @@+module Tricorder.UI+    ( viewUi+    ) where++import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Console (Console)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.File (File)+import Brick+    ( App (..)+    , attrMap+    , attrName+    , 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)+import Tricorder.Effects.UnixSocket (UnixSocket)+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Socket.Client (queryWatch)+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.Effects.Brick qualified as Brick+import Tricorder.Effects.BrickChan qualified as BrickChan+import Tricorder.UI.Keys qualified as Keys+import Tricorder.UI.State qualified as Model+++-- | Connect to the daemon and render a live-updating build status display using+-- a brick TUI. Quits on @q@ or @Esc@; arrow keys scroll the viewport.+viewUi+    :: ( Brick :> es+       , BrickChan :> es+       , Clock :> es+       , Conc :> es+       , Console :> es+       , Delay :> es+       , File :> es+       , Reader Keys.Config :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Eff es ()+viewUi = do+    SocketPath sockPath <- ask+    chan <- BrickChan.newBChan 10+    initialState <- Model.init+    Conc.scoped do+        _ <-+            Conc.fork do+                queryWatch sockPath $ BrickChan.writeBChan chan . NewBuildState+                BrickChan.writeBChan chan $ FailedBuild "Lost contact with the daemon"+        keyConfig <- Keys.mkKeyConfig+        void+            $ Brick.runBrickApp+                chan+                (watchApp keyConfig)+                initialState+++watchApp :: KeyConfig KeyEvent -> App State Event Viewports+watchApp kc =+    App+        { 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)+                    ]+                )+        , appChooseCursor = neverShowCursor+        }
+ src/Tricorder/UI/Event.hs view
@@ -0,0 +1,38 @@+module Tricorder.UI.Event+    ( Event (..)+    , handleEvent+    ) where++import Brick (BrickEvent (..), EventM, vScrollBy, viewportScroll)+import Brick.Keybindings (KeyDispatcher, handleKey)+import Control.Monad.State (modify)++import Graphics.Vty qualified as Vty++import Tricorder.BuildState (BuildState (..))+import Tricorder.Socket.Client (Restarting (..))+import Tricorder.UI.Keys (KeyEvent)+import Tricorder.UI.State (Processed (..), State (..), Viewports (..))+++data Event+    = NewBuildState (Either Restarting BuildState)+    | FailedBuild Text+++handleEvent :: KeyDispatcher KeyEvent (EventM Viewports State) -> BrickEvent Viewports Event -> EventM Viewports State ()+handleEvent _ (AppEvent ev) = handleAppEvent ev+handleEvent d (VtyEvent (Vty.EvKey key modifiers)) = void $ handleKey d key modifiers+handleEvent _ (MouseDown vp Vty.BScrollUp _ _) = vScrollBy (viewportScroll vp) (-1)+handleEvent _ (MouseDown vp Vty.BScrollDown _ _) = vScrollBy (viewportScroll vp) 1+handleEvent _ _ = pure ()+++handleAppEvent :: Event -> EventM Viewports State ()+handleAppEvent = \case+    NewBuildState (Left Restarting) ->+        modify \s -> s {buildState = Waiting}+    NewBuildState (Right bs) ->+        modify \s -> s {buildState = Success bs}+    FailedBuild reason ->+        modify \s -> s {buildState = Failure reason}
+ src/Tricorder/UI/Keys.hs view
@@ -0,0 +1,230 @@+module Tricorder.UI.Keys+    ( KeyEvent+    , Config+    , keys+    , dispatcher+    , viewKeybindings+    , mkKeyConfig+    ) where++import Atelier.Effects.Console (Console)+import Brick+    ( EventM+    , Widget+    , halt+    , txt+    , vBox+    , vScrollBy+    , viewportScroll+    )+import Brick.Keybindings+    ( Binding+    , BindingState+    , EventTrigger (..)+    , Handler (..)+    , KeyConfig+    , KeyDispatcher+    , KeyEventHandler (..)+    , KeyEvents+    , KeyHandler (..)+    , ToBinding (..)+    , allActiveBindings+    , binding+    , ctrl+    , keyDispatcher+    , keyEvents+    , newKeyConfig+    , onEvent+    , parseBindingList+    )+import Brick.Keybindings.Pretty (ppBinding)+import Brick.Widgets.Core (hBox)+import Control.Monad.State (gets, modify)+import Data.Aeson (FromJSON (..))+import Data.Default (Default (..))+import Effectful.Exception (throwIO)+import Effectful.Reader.Static (Reader, ask)+import Graphics.Vty (Key (..))+import System.IO.Error (userError)+import Text.Casing (quietSnake)++import Atelier.Effects.Console qualified as Console+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T++import Tricorder.UI.Misc (warn)+import Tricorder.UI.State+    ( ActiveView (..)+    , State (..)+    , Viewports (..)+    , currentView+    , cycleTestView+    , popView+    , pushView+    )+++-- When adding a new event here, also list it in the README under "Custom Key Bindings".+data KeyEvent+    = ToggleDaemonInfoView+    | Quit+    | ExitView+    | ScrollUp+    | ScrollDown+    | ToggleHelp+    | CycleTestView+    deriving stock (Bounded, Enum, Eq, Ord, Show)+++keyEventToText :: KeyEvent -> Text+keyEventToText = toText . quietSnake . show+++keyEventTextMap :: Map Text KeyEvent+keyEventTextMap = Map.fromList $ (\e -> (keyEventToText e, e)) <$> universe+++textToKeyEvent :: Text -> Maybe KeyEvent+textToKeyEvent = (`Map.lookup` keyEventTextMap)+++keys :: KeyEvents KeyEvent+keys =+    keyEvents+        [ ("toggle daemon info", ToggleDaemonInfoView)+        , ("quit", Quit)+        , ("exit view", ExitView)+        , ("scroll up", ScrollUp)+        , ("scroll down", ScrollDown)+        , ("toggle help", ToggleHelp)+        , ("cycle test view", CycleTestView)+        ]+++bindings :: [(KeyEvent, [Binding])]+bindings =+    [ (ToggleDaemonInfoView, [bind 'g'])+    , (Quit, [bind 'q', ctrl 'c'])+    , (ExitView, [binding KEsc []])+    , (ScrollUp, [binding KUp []])+    , (ScrollDown, [binding KDown []])+    , (ToggleHelp, [bind 'h'])+    , (CycleTestView, [bind 't'])+    ]+++mkKeyConfig :: (Console :> es, Reader Config :> es) => Eff es (KeyConfig KeyEvent)+mkKeyConfig = do+    customBindings <- parseCustomBindings+    pure $ newKeyConfig keys bindings customBindings+++newtype Config = Config (Map Text Text)+    deriving stock (Generic)+    deriving newtype (FromJSON)+++instance Default Config where+    def = Config mempty+++parseCustomBindings+    :: ( Console :> es+       , Reader Config :> es+       )+    => Eff es [(KeyEvent, BindingState)]+parseCustomBindings = do+    Config cfg <- ask+    let (errors, customBindings) = partitionEithers $ uncurry parseEntry <$> Map.toList cfg+    unless (null errors) do+        Console.putTextLn "Error(s) encountered when attempting to parse key bindings:"+        traverse_ (Console.putTextLn . toText) errors+        throwIO $ userError "Malformed keybindings"+    pure customBindings+++parseEntry :: Text -> Text -> Either Text (KeyEvent, BindingState)+parseEntry ev binds =+    (,) <$> parsedEvent <*> parsedBinds+  where+    parsedEvent = parseKeyEvent ev+    parsedBinds = first toText $ parseBindingList binds+++parseKeyEvent :: Text -> Either Text KeyEvent+parseKeyEvent ev = maybeToRight ("Unrecognized key event: " <> ev) $ textToKeyEvent ev+++dispatcher :: KeyConfig KeyEvent -> KeyDispatcher KeyEvent (EventM Viewports State)+dispatcher cfg =+    -- TODO: Handle this error more gracefully.+    either (error . ("Invalid key dispatcher config: " <>) . stringify) id+        $ keyDispatcher+            cfg+            [ onEvent ToggleDaemonInfoView "Toggle daemon info view" do+                modify \s ->+                    if currentView s == Just ViewDaemonInfo then+                        popView 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+            , onEvent ToggleHelp "Toggle help" do+                modify \s ->+                    if currentView s == Just ViewHelp then+                        popView s+                    else+                        pushView ViewHelp s+            , onEvent CycleTestView "Cycle test results view" do+                modify \s -> case currentView s of+                    Just (ViewTestResults tv) ->+                        if tv == maxBound then+                            popView s+                        else+                            pushView (ViewTestResults (cycleTestView tv)) (popView s)+                    _ -> pushView (ViewTestResults minBound) s+            ]+  where+    stringify =+        show . fmap (second $ fmap $ handlerDescription . kehHandler . khHandler)+++viewKeybindings :: (Ord k, Show k) => KeyConfig k -> [KeyEventHandler k m] -> Widget n+viewKeybindings kc =+    vBox+        . fmap (uncurry (viewEventAndTriggers kc))+        . Map.toList+        . foldr groupByEventName Map.empty+  where+    groupByEventName ev = Map.insertWith (<>) ev.kehHandler.handlerDescription [ev.kehEventTrigger]+++viewEventAndTriggers :: (Ord k, Show k) => KeyConfig k -> Text -> [EventTrigger k] -> Widget n+viewEventAndTriggers kc eventName trigger =+    hBox+        [ warn $ txt $ eventName <> ": "+        , txt $ showBindings $ mconcat $ getBindings <$> trigger+        ]+  where+    showBindings = T.intercalate ", " . fmap ppBinding . sort . toList+    getBindings = \case+        ByKey k -> Set.singleton k+        ByEvent e -> Set.fromList $ allActiveBindings kc e
+ src/Tricorder/UI/Misc.hs view
@@ -0,0 +1,50 @@+module Tricorder.UI.Misc+    ( err+    , warn+    , ok+    , emphasis+    , subtle+    , hBoxSpaced+    , vBoxSpaced+    ) where++import Brick+    ( Padding (..)+    , Widget+    , attrName+    , hBox+    , padLeft+    , padTop+    , vBox+    , withDefAttr+    )+++err :: Widget n -> Widget n+err = withDefAttr $ attrName "error"+++warn :: Widget n -> Widget n+warn = withDefAttr $ attrName "warning"+++ok :: Widget n -> Widget n+ok = withDefAttr $ attrName "ok"+++emphasis :: Widget n -> Widget n+emphasis = withDefAttr $ attrName "emphasis"+++subtle :: Widget n -> Widget n+subtle = withDefAttr $ attrName "subtle"+++hBoxSpaced :: Int -> [Widget n] -> Widget n+hBoxSpaced _ [] = hBox []+hBoxSpaced pad (x : xs) = hBox $ x : (padLeft (Pad pad) <$> xs)+++vBoxSpaced :: Int -> [Widget n] -> Widget n+vBoxSpaced _ [] = vBox []+vBoxSpaced pad (x : xs) = vBox $ x : (padTop (Pad pad) <$> xs)
+ src/Tricorder/UI/State.hs view
@@ -0,0 +1,77 @@+module Tricorder.UI.State+    ( Viewports (..)+    , State (..)+    , Processed (..)+    , init+    , ActiveView (..)+    , TestView (..)+    , currentView+    , pushView+    , popView+    , cycleTestView+    ) where++import Atelier.Effects.Clock (Clock, TimeZone)+import Prelude hiding (init)++import Atelier.Effects.Clock qualified as Clock++import Tricorder.BuildState (BuildState (..))+++data Viewports+    = MainViewport+    | DiagnosticViewport+    | TestViewport+    deriving stock (Eq, Ord, Show)+++data State = State+    { buildState :: Processed Text BuildState+    , timeZone :: TimeZone+    , viewStack :: [ActiveView]+    }+++data Processed e a+    = Waiting+    | Failure e+    | Success a+++data ActiveView+    = ViewHelp+    | ViewDaemonInfo+    | ViewTestResults TestView+    deriving stock (Eq)+++data TestView = TestViewFailOnly | TestViewFull+    deriving stock (Bounded, Enum, Eq)+++currentView :: State -> Maybe ActiveView+currentView = viaNonEmpty head . (.viewStack)+++pushView :: ActiveView -> State -> State+pushView v s = s {viewStack = v : s.viewStack}+++popView :: State -> State+popView s = s {viewStack = drop 1 s.viewStack}+++cycleTestView :: TestView -> TestView+cycleTestView v = if v == maxBound then minBound else succ v+++init :: (Clock :> es) => Eff es State+init = do+    tz <- Clock.currentTimeZone+    pure+        State+            { buildState = Waiting+            , timeZone = tz+            , viewStack = []+            }
+ src/Tricorder/UI/View.hs view
@@ -0,0 +1,415 @@+module Tricorder.UI.View (view) where++import Atelier.Effects.Clock (TimeZone)+import Atelier.Time (Millisecond, toMicroseconds)+import Brick+    ( AttrName+    , VScrollBarOrientation (..)+    , ViewportType (..)+    , Widget+    , attrName+    , vBox+    , viewport+    )+import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList)+import Brick.Widgets.Core+    ( Padding (..)+    , emptyWidget+    , hBox+    , padBottom+    , padLeft+    , txt+    , txtWrap+    , withClickableVScrollBars+    , withDefAttr+    , withVScrollBarHandles+    , withVScrollBars+    )+import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime)+import System.FilePath (isAbsolute)++import Data.Text qualified as T++import Tricorder.BuildState+    ( BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , BuildState (..)+    , DaemonInfo (..)+    , Diagnostic (..)+    , Severity (..)+    , TestCase (..)+    , TestCaseOutcome (..)+    , TestRun (..)+    , TestRunCompletion (..)+    , TestRunError (..)+    )+import Tricorder.TestOutput (stripGhciNoise)+import Tricorder.UI.Keys (KeyEvent, 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.Keys qualified as Keys+import Tricorder.Version qualified as Version+++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)+    ]+++withBuildState :: State -> (BuildState -> Widget Viewports) -> Widget Viewports+withBuildState ws render =+    case ws.buildState of+        Waiting ->+            txt "Waiting for build..."+        Failure reason ->+            txt $ "Error when contacting daemon: " <> reason+        Success bs ->+            render bs+++withHint :: Widget n -> Widget n+withHint content = vBox [padBottom Max content, viewHint]+++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)+++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 =+    vBoxSpaced+        1+        [ viewBuildPhaseLine tz bs.phase+        , viewTestPanel tv (phaseTestRuns bs.phase)+        ]+++viewHint :: Widget n+viewHint = subtle $ txt "Press 'h' for help"+++viewExpandedDaemonInfo :: DaemonInfo -> Widget n+viewExpandedDaemonInfo di =+    vBox+        [ viewVersion+        , viewTargets di.targets+        , viewWatchDirs di.watchDirs+        , viewSockPath di.sockPath+        , viewLogFile di.logFile+        , viewMetrics di.metricsPort+        ]+++viewVersion :: Widget n+viewVersion =+    hBoxSpaced+        1+        [ emphasis $ txt "Client version:"+        , txt Version.gitHash+        ]+++viewTargets :: [Text] -> Widget n+viewTargets targets =+    hBoxSpaced+        1+        [ emphasis $ txt "Targets:"+        , if null targets then+            txt "(all)"+          else+            txtWrap (T.intercalate " " targets)+        ]+++viewMetrics :: Maybe Int -> Widget n+viewMetrics Nothing =+    hBoxSpaced+        1+        [ emphasis $ txt "Metrics:"+        , warn $ txt "disabled"+        ]+viewMetrics (Just port) =+    hBoxSpaced+        1+        [ emphasis $ txt "Metrics:"+        , ok $ txt $ "http://localhost:" <> show port <> "/metrics"+        ]+++viewLogFile :: FilePath -> Widget n+viewLogFile p = hBoxSpaced 1 [emphasis $ txt "Log:", txt $ toText p]+++viewSockPath :: FilePath -> Widget n+viewSockPath sockPath =+    hBoxSpaced 1 [emphasis $ txt "Socket:", txt $ toText sockPath]+++viewWatchDirs :: [FilePath] -> Widget n+viewWatchDirs watchDirs =+    vBox+        [ emphasis $ txt "Watching:"+        , padLeft (Pad 2)+            $ vBox+            $ viewWatchDir <$> watchDirs+        ]+++viewWatchDir :: FilePath -> Widget n+viewWatchDir dir = hBox [txt "- ", txt $ toText displayDir]+  where+    displayDir+        | isAbsolute dir = dir+        | dir == "." = "./"+        | otherwise = "./" <> dir+++viewBuildPhase :: TimeZone -> BuildPhase -> Widget Viewports+viewBuildPhase tz = \case+    Building Nothing -> warn $ txt "Building..."+    Building (Just p) -> warn $ txt $ "Building (" <> show p.compiled <> "/" <> show p.total <> ")..."+    Restarting -> warn $ txt "Restarting..."+    Testing result -> vBoxSpaced 1 [viewBuildResult tz result, viewTestRuns result.testRuns]+    Done result -> vBoxSpaced 1 [viewBuildResult tz result, viewTestRuns result.testRuns]+    BuildFailed msg -> viewBuildFailed msg+++viewBuildFailed :: Text -> Widget Viewports+viewBuildFailed msg =+    vBox+        [ err $ txt "Build command failed"+        , vScrollViewport DiagnosticViewport (txtWrap <$> T.lines msg)+        ]+++-- | A vertically-scrollable viewport with clickable scrollbars on the right.+vScrollViewport :: Viewports -> [Widget Viewports] -> Widget Viewports+vScrollViewport vp children =+    withClickableVScrollBars (\_ _ -> vp)+        $ withVScrollBarHandles+        $ withVScrollBars OnRight+        $ viewport vp Vertical+        $ vBox children+++viewBuildResult :: TimeZone -> BuildResult -> Widget Viewports+viewBuildResult tz result+    | null result.diagnostics =+        hBoxSpaced+            1+            [ ok $ txt "All good."+            , viewBuildSummary result.moduleCount result.duration+            , viewTimestamp tz result.completedAt+            ]+    | otherwise =+        let msgs = result.diagnostics+            errCount = length $ filter (\m -> m.severity == SError) msgs+            warnCount = length $ filter (\m -> m.severity == SWarning) msgs+            header =+                if errCount > 0 then+                    err $ txt $ show errCount <> " error(s), " <> show warnCount <> " warning(s)"+                else+                    warn $ txt $ show warnCount <> " warning(s)"+        in  vBoxSpaced+                1+                [ hBoxSpaced+                    1+                    [ header+                    , viewDuration result.duration+                    , viewTimestamp tz result.completedAt+                    ]+                , vScrollViewport DiagnosticViewport (viewDiagnostic <$> msgs)+                ]+++viewDiagnostic :: Diagnostic -> Widget n+viewDiagnostic m =+    vBox+        [ hBoxSpaced+            1+            [ severityLabel+            , txt $ toText loc+            ]+        , txtWrap m.text+        ]+  where+    loc = m.file <> ":" <> show m.line <> ":" <> show m.col+    severityLabel = withDefAttr (severityToAttrName m.severity) $ txt $ case m.severity of+        SError -> "error:"+        SWarning -> "warning:"+++severityToAttrName :: Severity -> AttrName+severityToAttrName SError = attrName "error"+severityToAttrName SWarning = attrName "warning"+++viewDuration :: Millisecond -> Widget n+viewDuration d = txt $ "(" <> formatDuration d <> ")"+++viewTestRuns :: [TestRun] -> Widget n+viewTestRuns [] = emptyWidget+viewTestRuns runs = vBox $ viewTestRun <$> runs+++viewTestRun :: TestRun -> Widget n+viewTestRun (TestRunning t Nothing) = hBox [txt t, txt "  ", warn $ txt "running..."]+viewTestRun (TestRunning t (Just p)) =+    hBox [txt t, txt "  ", warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"]+viewTestRun (TestRunErrored e) = hBox [txt e.target, txt "  ", err $ txt "error: ", txt e.message]+viewTestRun (TestRunCompleted c) = hBox [txt c.target, txt "  ", viewCompletionStatus c]+++viewCompletionStatus :: TestRunCompletion -> Widget n+viewCompletionStatus c = case c.duration of+    Nothing -> statusWidget+    Just d -> hBoxSpaced 1 [statusWidget, subtle $ viewDuration d]+  where+    statusWidget+        | null c.testCases = if c.passed then ok (txt "passed") else err (txt "failed")+        | otherwise =+            let total = length c.testCases+                failed = length $ filter isCaseFailed c.testCases+            in  if failed == 0 then+                    ok $ txt $ "passed (" <> show total <> ")"+                else+                    err $ txt $ show failed <> "/" <> show total <> " failed"+++viewTimestamp :: TimeZone -> UTCTime -> Widget n+viewTimestamp tz t = txt $ "— " <> toText (formatTime defaultTimeLocale "%H:%M:%S" $ utcToLocalTime tz t)+++viewBuildSummary :: Int -> Millisecond -> Widget n+viewBuildSummary moduleCount duration =+    txt $ "(" <> show moduleCount <> " modules, " <> formatDuration duration <> ")"+++formatDuration :: Millisecond -> Text+formatDuration d =+    let ms = toMicroseconds d `div` 1000+    in  if ms < 1000 then+            show ms <> "ms"+        else+            show (ms `div` 1000) <> "." <> show ((ms `mod` 1000) `div` 100) <> "s"+++-- | Single-line build status with no scrollable diagnostics list, used as a+-- compact header when a secondary panel (test results, daemon info) is open.+viewBuildPhaseLine :: TimeZone -> BuildPhase -> Widget n+viewBuildPhaseLine tz = \case+    Building Nothing -> warn $ txt "Building..."+    Building (Just p) -> warn $ txt $ "Building (" <> show p.compiled <> "/" <> show p.total <> ")..."+    Restarting -> warn $ txt "Restarting..."+    Testing result -> viewBuildResultLine tz result+    Done result -> viewBuildResultLine tz result+    BuildFailed _ -> err $ txt "Build command failed"+++viewBuildResultLine :: TimeZone -> BuildResult -> Widget n+viewBuildResultLine tz result+    | null result.diagnostics =+        hBoxSpaced+            1+            [ ok $ txt "All good."+            , viewBuildSummary result.moduleCount result.duration+            , viewTimestamp tz result.completedAt+            ]+    | otherwise =+        let errCount = length $ filter (\m -> m.severity == SError) result.diagnostics+            warnCount = length $ filter (\m -> m.severity == SWarning) result.diagnostics+            header =+                if errCount > 0 then+                    err $ txt $ show errCount <> " error(s), " <> show warnCount <> " warning(s)"+                else+                    warn $ txt $ show warnCount <> " warning(s)"+        in  hBoxSpaced 1 [header, viewDuration result.duration, viewTimestamp tz result.completedAt]+++phaseTestRuns :: BuildPhase -> [TestRun]+phaseTestRuns (Testing r) = r.testRuns+phaseTestRuns (Done r) = r.testRuns+phaseTestRuns _ = []+++viewTestPanel :: TestView -> [TestRun] -> Widget Viewports+viewTestPanel _ [] = subtle $ txt "No test results."+viewTestPanel tv runs = scrollableRuns tv runs+++scrollableRuns :: TestView -> [TestRun] -> Widget Viewports+scrollableRuns tv runs =+    vScrollViewport TestViewport (viewTestRunDetail tv <$> runs)+++viewTestRunDetail :: TestView -> 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) =+    vBox+        [ hBox [txt c.target, txt "  ", viewCompletionStatus c]+        , viewTestOutput tv c+        ]+++viewTestOutput :: TestView -> TestRunCompletion -> Widget n+viewTestOutput TestViewFull c =+    padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output)+viewTestOutput TestViewFailOnly c+    | not (any isCaseFailed c.testCases) && c.passed = emptyWidget+    | null c.testCases =+        padLeft (Pad 2)+            $ vBox+                [ subtle $ txt "(unrecognised test runner — showing full output)"+                , vBox $ txt <$> stripGhciNoise (T.lines c.output)+                ]+    | otherwise =+        padLeft (Pad 2) $ vBox $ viewFailedCase <$> filter isCaseFailed c.testCases+++isCaseFailed :: TestCase -> Bool+isCaseFailed (TestCase _ (TestCaseFailed _)) = True+isCaseFailed _ = False+++viewFailedCase :: TestCase -> Widget n+viewFailedCase tc =+    vBox+        [ err $ txt tc.description+        , case tc.outcome of+            TestCaseFailed details -> padLeft (Pad 2) $ txtWrap details+            TestCasePassed -> emptyWidget+        ]
+ src/Tricorder/Version.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fforce-recomp #-}++-- | Build-time version information.+--+-- The git hash is spliced in at compile time via Template Haskell, so it+-- carries zero runtime overhead and requires no file I/O at startup.+--+-- The @-fforce-recomp@ pragma ensures GHC re-evaluates the TH splice on every+-- build invocation. Without it, GHC may skip recompilation when no source+-- files have changed (e.g. after a @git commit@), leaving the old hash baked+-- in until something else triggers a rebuild.+module Tricorder.Version (gitHash, VersionMismatch (..), checkVersion) where++import Language.Haskell.TH (litE, runIO, stringL)+import System.Environment (lookupEnv)+import System.IO.Error (tryIOError)+import System.Process (readProcess)+++-- | Short git hash of the commit this binary was built from.+--+-- Resolution order at compile time:+--+-- 1. @TRICORDER_VERSION@ environment variable — useful for non-git VCS+--    (e.g. Jujutsu workspaces without a colocated @.git@) and for CI+--    pipelines that inject the version externally.+-- 2. @git rev-parse --short HEAD@ — the common case for git checkouts.+-- 3. @"unknown"@ — fallback when @git@ is unavailable.+gitHash :: Text+gitHash =+    toText+        ( $( do+                hash <- runIO $ do+                    override <- lookupEnv "TRICORDER_VERSION"+                    case override of+                        Just v -> pure v+                        Nothing ->+                            either (const "unknown") (filter (/= '\n'))+                                <$> tryIOError (readProcess "git" ["rev-parse", "--short", "HEAD"] "")+                litE (stringL hash)+           )+            :: String+        )+++data VersionMismatch = VersionMismatch+    { expected :: Text+    , received :: Text+    }+    deriving stock (Show)+++checkVersion :: Text -> Either VersionMismatch ()+checkVersion clientVersion+    | clientVersion == gitHash = Right ()+    | otherwise = Left VersionMismatch {expected = gitHash, received = clientVersion}
+ src/Tricorder/Watcher.hs view
@@ -0,0 +1,150 @@+module Tricorder.Watcher+    ( component+    , WatchedFile (..)+    , isCabalFile+    , markWatchedFiles+    ) where++import Atelier.Component (Component (..), defaultComponent)+import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Debounce (Debounce)+import Atelier.Effects.FileWatcher+    ( FileEvent+    , FileWatcher+    , Watch+    , containing+    , dirExt+    , dirWhere+    , excluding+    , watchFilePathsDebounced+    )+import Atelier.Effects.Publishing (Pub, Sub, publish)+import Effectful.Concurrent (Concurrent)+import Effectful.Reader.Static (Reader, ask)+import System.FilePath (takeExtension, takeFileName)++import Atelier.Effects.Publishing qualified as Sub++import Tricorder.BuildState+    ( CabalChangeDetected (..)+    , ChangeKind (..)+    , SourceChangeDetected (..)+    )+import Tricorder.Effects.BuildStore (BuildStore)+import Tricorder.Effects.SessionStore (SessionStore, SessionStoreReloaded)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Session (..))++import Tricorder.Effects.BuildStore qualified as BuildStore+import Tricorder.Effects.SessionStore qualified as SessionStore+++-- | Watcher component.+-- Watches source files and cabal-related files for changes, setting the dirty+-- flag in 'BuildStore'. 'GhciSession' polls this flag and triggers a rebuild+-- or session restart accordingly.+component+    :: ( BuildStore :> es+       , Chan :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce FilePath :> es+       , FileWatcher :> es+       , Pub CabalChangeDetected :> es+       , Pub SourceChangeDetected :> es+       , Pub WatchedFile :> es+       , Reader ProjectRoot :> es+       , SessionStore :> es+       , Sub SessionStoreReloaded :> es+       , Sub WatchedFile :> es+       )+    => Component es+component =+    defaultComponent+        { name = "Watcher"+        , triggers = pure [watchFiles]+        , listeners = pure [Sub.listen_ markWatchedFiles]+        }+++markWatchedFiles+    :: ( BuildStore :> es+       , Pub CabalChangeDetected :> es+       , Pub SourceChangeDetected :> es+       )+    => WatchedFile -> Eff es ()+markWatchedFiles f = do+    BuildStore.markDirty change+    case change of+        CabalChange -> publish (CabalChangeDetected f.path f.event)+        SourceChange -> publish (SourceChangeDetected f.path f.event)+  where+    change = changeKindFor f.path+++data WatchedFile = WatchedFile+    { path :: FilePath+    , event :: FileEvent+    }+++data WatcherSession = WatcherSession+    { watchDirs :: [FilePath]+    }+    deriving stock (Eq)+++withWatcherSession+    :: ( Chan :> es+       , Conc :> es+       , Concurrent :> es+       , SessionStore :> es+       , Sub SessionStoreReloaded :> es+       )+    => Session+    -> (SessionStore.Reloader es -> WatcherSession -> Eff es Void)+    -> Eff es Void+withWatcherSession =+    SessionStore.withSubSession $ WatcherSession . (.watchDirs)+++watchFiles+    :: ( Chan :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce FilePath :> es+       , FileWatcher :> es+       , Pub WatchedFile :> es+       , Reader ProjectRoot :> es+       , SessionStore :> es+       , Sub SessionStoreReloaded :> es+       )+    => Eff es Void+watchFiles = do+    initialSession <- SessionStore.get+    withWatcherSession initialSession $ \_ session -> do+        projectRoot <- ask+        let watches = sourceWatches session.watchDirs <> cabalWatches projectRoot+        watchFilePathsDebounced watches \filePath fileEvent -> publish (WatchedFile filePath fileEvent)+++sourceWatches :: [FilePath] -> [Watch]+sourceWatches = map (\d -> dirExt d ".hs" `excluding` containing "dist-newstyle")+++cabalWatches :: ProjectRoot -> [Watch]+cabalWatches (ProjectRoot projectRoot) =+    [dirWhere projectRoot isCabalFile `excluding` containing "dist-newstyle"]+++isCabalFile :: FilePath -> Bool+isCabalFile f =+    takeExtension f == ".cabal"+        || takeFileName f `elem` ["cabal.project", "package.yaml"]+++changeKindFor :: FilePath -> ChangeKind+changeKindFor path+    | isCabalFile path = CabalChange+    | otherwise = SourceChange
+ test/Driver.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+
+ test/Unit/Tricorder/BuildStateSpec.hs view
@@ -0,0 +1,81 @@+module Unit.Tricorder.BuildStateSpec (spec_BuildState) where++import Data.Aeson (eitherDecode, encode)+import Data.Time (UTCTime (..), fromGregorian)+import Test.Hspec++import Tricorder.BuildState (BuildId (..), BuildPhase (..), BuildResult (..), BuildState (..), DaemonInfo (..), Diagnostic (..), Severity (..))+++spec_BuildState :: Spec+spec_BuildState = do+    describe "JSON round-trip" do+        it "survives Unicode smart quotes in message text" do+            let msg =+                    Diagnostic+                        { severity = SWarning+                        , file = "<interactive>"+                        , line = 2+                        , col = 8+                        , endLine = 2+                        , endCol = 8+                        , title = "Found \8216qualified\8217 in prepositive position"+                        , text = "Found \8216qualified\8217 in prepositive position\n    Suggested fixes:\n      \8226 Place \8216qualified\8217 after the module name."+                        }+                bs = mkBuildState [msg]+            eitherDecode (encode bs) `shouldBe` Right bs++        it "survives control characters in message text" do+            let msg =+                    Diagnostic+                        { severity = SWarning+                        , file = "<interactive>"+                        , line = 1+                        , col = 1+                        , endLine = 1+                        , endCol = 1+                        , title = "text with \CAN control \EM chars and \ESC[1m ANSI \ESC[0m codes"+                        , text = "text with \CAN control \EM chars and \ESC[1m ANSI \ESC[0m codes"+                        }+                bs = mkBuildState [msg]+            eitherDecode (encode bs) `shouldBe` Right bs++        it "survives curly double quotes in message text" do+            let msg =+                    Diagnostic+                        { severity = SWarning+                        , file = "<interactive>"+                        , line = 1+                        , col = 1+                        , endLine = 1+                        , endCol = 1+                        , title = "\8220Place qualified after the module name.\8221"+                        , text = "\8220Place qualified after the module name.\8221"+                        }+                bs = mkBuildState [msg]+            eitherDecode (encode bs) `shouldBe` Right bs++        -- Guards the wire format for the BuildFailed phase: the captured+        -- cabal/build error (multi-line, Unicode) must round-trip intact so+        -- the CLI/UI clients can render it.+        it "survives a BuildFailed phase with a multi-line message" do+            let bs =+                    mkBuildState [] :: BuildState+                failed =+                    bs+                        { phase =+                            BuildFailed+                                "cabal: Could not resolve dependencies:\n[__0] trying: \8216base\8217\nrejecting: ..."+                        }+            eitherDecode (encode failed) `shouldBe` Right failed+++mkBuildState :: [Diagnostic] -> BuildState+mkBuildState msgs =+    BuildState+        { buildId = BuildId 1+        , phase = Done (BuildResult {completedAt = epoch, duration = 0, moduleCount = 0, diagnostics = msgs, testRuns = []})+        , daemonInfo = DaemonInfo {targets = [], watchDirs = [], sockPath = "", logFile = "", metricsPort = Nothing}+        }+  where+    epoch = UTCTime (fromGregorian 1970 1 1) 0
+ test/Unit/Tricorder/BuildStoreSpec.hs view
@@ -0,0 +1,184 @@+module Unit.Tricorder.BuildStoreSpec (spec_BuildStore) where++import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.Delay (Delay, runDelay)+import Atelier.Effects.Input (Input, runInputConst)+import Control.Concurrent (threadDelay)+import Data.Time (UTCTime (..), fromGregorian)+import Effectful (IOE, runEff, runPureEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Test.Hspec++import Atelier.Effects.Conc qualified as Conc++import Tricorder.BuildState (BuildId (..), BuildPhase (..), BuildResult (..), BuildState (..), DaemonInfo (..))+import Tricorder.Effects.BuildStore+    ( BuildStore+    , getState+    , runBuildStore+    , runBuildStoreScripted+    , setPhase+    , waitForNext+    , waitUntilDone+    )+++spec_BuildStore :: Spec+spec_BuildStore = do+    describe "runBuildStoreScripted" testScripted+    describe "runBuildStoreSTM" testSTM+++--------------------------------------------------------------------------------+-- Scripted interpreter tests (pure, no IO)+--------------------------------------------------------------------------------++testScripted :: Spec+testScripted = do+    describe "getState" do+        it "returns the head of the state list" do+            let result = runScripted [buildingAt 0, doneAt 1] getState+            result.buildId `shouldBe` BuildId 0++        it "does not consume the state" do+            let result = runScripted [doneAt 1] do+                    _ <- getState+                    getState+            result.buildId `shouldBe` BuildId 1++    describe "waitUntilDone" do+        it "returns immediately when head is already Done" do+            let result = runScripted [doneAt 1, doneAt 2] waitUntilDone+            result.buildId `shouldBe` BuildId 1++        it "skips Building states and returns the first Done" do+            let result = runScripted [buildingAt 0, buildingAt 0, doneAt 1] waitUntilDone+            result.buildId `shouldBe` BuildId 1++        it "consumes states up to and including the matched Done" do+            let result = runScripted [buildingAt 0, doneAt 1, doneAt 2] do+                    _ <- waitUntilDone+                    waitUntilDone+            result.buildId `shouldBe` BuildId 2++    describe "waitForNext" do+        it "skips states with the same buildId" do+            let result = runScripted [doneAt 1, doneAt 2] (waitForNext (BuildId 1))+            result.buildId `shouldBe` BuildId 2++        it "skips Building states regardless of buildId" do+            let result = runScripted [buildingAt 2, doneAt 2] (waitForNext (BuildId 1))+            result.buildId `shouldBe` BuildId 2++        it "skips Building and same-id Done before returning next Done" do+            let states = [buildingAt 1, doneAt 1, buildingAt 2, doneAt 2]+            let result = runScripted states (waitForNext (BuildId 1))+            result.buildId `shouldBe` BuildId 2+++--------------------------------------------------------------------------------+-- STM interpreter tests (concurrent)+--------------------------------------------------------------------------------++testSTM :: Spec+testSTM = do+    describe "getState" do+        it "returns the initial Building state" do+            result <- runStm getState+            result `shouldBe` buildingAt 0++    describe "setPhase / getState" do+        it "reflects a written state" do+            result <- runStm do+                setPhase (BuildId 1) donePhase+                getState+            result `shouldBe` doneAt 1++    describe "waitUntilDone" do+        it "returns immediately when state is already Done" do+            result <- runStm do+                setPhase (BuildId 1) donePhase+                waitUntilDone+            result.buildId `shouldBe` BuildId 1++        it "blocks until a Done phase is set from another thread" do+            result <- runStmConc do+                void $ Conc.fork do+                    liftIO (threadDelay 10_000)+                    setPhase (BuildId 1) donePhase+                waitUntilDone+            result.buildId `shouldBe` BuildId 1++    describe "waitForNext" do+        it "blocks until a Done state with a different buildId appears" do+            result <- runStmConc do+                setPhase (BuildId 1) donePhase+                void $ Conc.fork do+                    liftIO (threadDelay 10_000)+                    setPhase (BuildId 2) donePhase+                waitForNext (BuildId 1)+            result.buildId `shouldBe` BuildId 2++    -- Regression for the bug behind the user's "status --wait waits until+    -- the LAST cycle finishes" report: a polling-based 'waitUntilDone'+    -- could miss a transient 'Done' state if the next 'Building' phase+    -- overwrote the TVar within the poll interval, and an STM-retry+    -- version still races against the scheduler's wake-up latency. The+    -- broadcast 'TChan' of transitions makes every phase change a+    -- discrete message that can't be overwritten — so even if+    -- 'setPhase Done >> setPhase Building' happens back-to-back, the+    -- waiter observes the Done.+    describe "atomic transition capture" do+        it "observes a transient Done even if Building immediately follows" do+            result <- runStmConc do+                setPhase (BuildId 1) (Building Nothing)+                -- The publisher thread fires Done and then immediately+                -- overwrites it with Building (N+1), the exact pattern the+                -- coalescing worker produces between two queued cycles.+                void $ Conc.fork do+                    liftIO (threadDelay 5_000)+                    setPhase (BuildId 1) donePhase+                    setPhase (BuildId 2) (Building Nothing)+                waitUntilDone+            -- The waiter must report Done(1), NOT skip past it and report+            -- the later Done(2) (or block forever).+            result.buildId `shouldBe` BuildId 1+            case result.phase of+                Done _ -> pure ()+                p -> expectationFailure $ "expected Done phase, got: " <> show p+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++emptyDaemonInfo :: DaemonInfo+emptyDaemonInfo = DaemonInfo {targets = [], watchDirs = [], sockPath = "", logFile = "", metricsPort = Nothing}+++buildingAt :: Int -> BuildState+buildingAt n = BuildState (BuildId n) (Building Nothing) emptyDaemonInfo+++donePhase :: BuildPhase+donePhase = Done (BuildResult {completedAt = epoch, duration = 0, moduleCount = 0, diagnostics = [], testRuns = []})+++doneAt :: Int -> BuildState+doneAt n = BuildState (BuildId n) donePhase emptyDaemonInfo+++epoch :: UTCTime+epoch = UTCTime (fromGregorian 1970 1 1) 0+++runScripted :: [BuildState] -> Eff '[BuildStore] a -> a+runScripted states = runPureEff . runBuildStoreScripted states+++runStm :: Eff '[BuildStore, Input DaemonInfo, Delay, Concurrent, IOE] a -> IO a+runStm = runEff . runConcurrent . runDelay . runInputConst emptyDaemonInfo . runBuildStore+++runStmConc :: Eff '[Conc, BuildStore, Input DaemonInfo, Delay, Concurrent, IOE] a -> IO a+runStmConc = runEff . runConcurrent . runDelay . runInputConst emptyDaemonInfo . runBuildStore . runConc
+ test/Unit/Tricorder/BuilderSpec.hs view
@@ -0,0 +1,1102 @@+module Unit.Tricorder.BuilderSpec (spec_Builder) where++import Atelier.Effects.Chan (runChan)+import Atelier.Effects.Clock (runClockConst)+import Atelier.Effects.Conc (runConc)+import Atelier.Effects.Debounce (debounced, runDebounce, runDebounceNoOp)+import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.FileWatcher (FileEvent (..))+import Atelier.Effects.Input (runInputConst)+import Atelier.Effects.Log (runLogNoOp)+import Atelier.Effects.Monitoring.Tracing (runTracingNoOp)+import Atelier.Effects.Publishing (listen_, publish, runPubSub)+import Atelier.Time (Millisecond)+import Control.Concurrent.STM (modifyTVar', newTVarIO, readTVar, retry, writeTVar)+import Control.Exception (ErrorCall (..))+import Data.Default (def)+import Data.Time (UTCTime (..), addUTCTime, fromGregorian)+import Effectful (runEff, runPureEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Concurrent.STM (atomically)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (runErrorNoCallStack, throwError)+import Effectful.Exception (throwIO)+import Effectful.Reader.Static (runReader)+import Effectful.State.Static.Shared (evalState, runState)+import Effectful.Writer.Static.Shared (Writer, execWriter, tell)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Control.Concurrent.STM qualified as STM+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.BuildState+    ( BuildId (..)+    , BuildPhase (..)+    , BuildResult (..)+    , BuildState (..)+    , CabalChangeDetected (..)+    , DaemonInfo (..)+    , Diagnostic (..)+    , Severity (..)+    , SourceChangeDetected (..)+    , TestRun (..)+    , TestRunCompletion (..)+    )+import Tricorder.Builder+    ( BuildConfig (..)+    , EnteringNewPhase (..)+    , NewLoadResult (..)+    , compileLoadResultsIntoBuildResults+    , onRestart+    , reloadOnSourceChange+    , requestTestRunsForNewBuildResults+    , setNewPhase+    )+import Tricorder.Builder.Dispatch+    ( BuilderState (..)+    , KnownTargetNames (..)+    , emptyBuilderState+    , fileMatchesAnyTarget+    , filterToWatchDirs+    , mergeDiagnostics+    )+import Tricorder.Effects.GhciSession (Controls (..), LoadResult (..), LoadedModule (..), runGhciSessionScripted)+import Tricorder.Effects.GhciSession.GhciParser (extractTitle, resolveKnownTargets)+import Tricorder.Effects.TestRunner (TestRunner (..), runTestRunnerScripted)+import Tricorder.Runtime (ProjectRoot (..))++import Tricorder.BuildState qualified as BuildState+import Tricorder.Builder qualified as Builder+import Tricorder.Effects.BuildStore qualified as BuildStore+++spec_Builder :: Spec+spec_Builder = do+    describe "mergeDiagnostics" testMergeDiagnostics+    describe "filterToWatchDirs" testFilterToWatchDirs+    describe "extractTitle" testExtractTitle+    describe "compileLoadResultsIntoBuildResults" testCompileLoadResultsIntoBuildResults+    describe "requestTestRunsForNewBuildResults" testRequestTestRunsForNewBuildResults+    describe "setNewPhase" testSetNewPhase+    describe "onRestart" testOnRestart+    describe "restartOnCabalChange" testRestartOnCabalChange+    describe "buildWithGhciOnChange (startup-failure recovery)" testBuildWithGhciRecovery+    describe "reloadOnSourceChange" testReloadOnSourceChange+    describe "watchSourceChanges (event coalescing)" testEventCoalescing+    describe "interruptCurrent" testInterruptCurrent+    describe "resolveKnownTargets" testResolveKnownTargets+    describe "fileMatchesAnyTarget" testFileMatchesAnyTarget+++testOnRestart :: Spec+testOnRestart = do+    it "transitions BuildStore to the Building phase" do+        (st, _) <- runTest+        st.phase `shouldBe` Building Nothing++    it "should increment the build ID" do+        (_, buildId) <- runTest+        buildId `shouldBe` BuildId 2+  where+    runTest =+        runEff+            . runConcurrent+            . runDelay+            . runLogNoOp+            . runInputConst emptyDaemonInfo+            . BuildStore.runBuildStore+            . runState (BuildId 1)+            $ do+                onRestart+                BuildStore.getState+++testRestartOnCabalChange :: Spec+testRestartOnCabalChange = do+    it "restarts the supervised action when CabalChangeDetected is published" do+        countVar <- newTVarIO @Int 0++        runTest do+            Conc.scoped do+                _ <-+                    Conc.fork+                        $ Builder.restartOnCabalChange+                            (pure ())+                            (pure ())+                            ( \_ -> do+                                atomically (modifyTVar' countVar (+ 1))+                                -- Block forever; we want to verify the action is+                                -- cancelled and re-entered, not that it returns.+                                forever (Delay.wait (10 :: Millisecond))+                            )+                Delay.wait (20 :: Millisecond) -- let the first iteration land+                publish (CabalChangeDetected "foo.cabal" Modified)+                Delay.wait (50 :: Millisecond) -- let the restart land+        finalCount <- STM.atomically (readTVar countVar)+        finalCount `shouldBe` 2+  where+    runTest =+        runEff+            . runConcurrent+            . runTracingNoOp+            . runClockConst epoch+            . runChan+            . runDelay+            . runLogNoOp+            . runPubSub @CabalChangeDetected+            . runConc+++-- | Regression for the startup-failure dead-end: when the build command+-- fails to start, 'buildWithGhciOnChange' must surface 'BuildFailed' and then+-- stay able to retry once a source file changes. The original code parked on+-- 'atomically retry' after 'BuildFailed', so it could only ever recover via a+-- *cabal* change (runBuilder cancelling its scope) — a source edit that+-- fixed the underlying problem was ignored and the daemon stayed stuck.+testBuildWithGhciRecovery :: Spec+testBuildWithGhciRecovery = do+    it "retries the build on a source change after a startup failure" do+        phases <-+            runTest+                -- First launch throws (startup failure); the retry succeeds.+                [ Left (toException (ErrorCall "ghci failed to start"))+                , Right successLoad+                ]+                do+                    Conc.scoped do+                        Conc.fork_ (Builder.buildWithGhciOnChange (def @BuildConfig))+                        Delay.wait (40 :: Millisecond) -- let the first launch fail + subscribe+                        publish (SourceChangeDetected "/abs/path/Foo.hs" Modified)+                        Delay.wait (60 :: Millisecond) -- let the retry land+                        -- The failed launch reports BuildFailed exactly once.+        length [() | EnteringNewPhase _ (BuildFailed _) <- phases] `shouldBe` 1+        -- The source change drove a second, successful launch to completion.+        -- With the bug the builder is parked, so no Done is ever emitted.+        length [() | EnteringNewPhase _ (Done _) <- phases] `shouldSatisfy` (>= 1)+  where+    successLoad =+        LoadResult+            { moduleCount = 1+            , compiledFiles = Set.empty+            , loadedModules = Map.empty+            , targetNames = []+            , diagnostics = []+            }++    runTest script body =+        runEff+            . runConcurrent+            . runTracingNoOp+            . runClockConst epoch+            . runChan+            . runDelay+            . runReader (ProjectRoot "/")+            . evalState (BuildId 1)+            . evalState emptyBuilderState+            . runLogNoOp+            . execWriter @[EnteringNewPhase]+            . runBuildStoreCapture+            . runTestRunnerScripted []+            . runGhciSessionScripted script+            . runPubSub @SourceChangeDetected+            . runConc+            . runDebounceNoOp+            $ body+++--------------------------------------------------------------------------------+-- Effect stack for integration tests+--------------------------------------------------------------------------------++data StopSignal = StopSignal+    deriving stock (Show)+++testReloadOnSourceChange :: Spec+testReloadOnSourceChange = do+    describe "Modified" do+        describe "when the file is loaded in GHCi" do+            it "transitions through Building then Done" do+                phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Modified)+                phases `shouldBe` flow reloadLr++            it "calls controls.reload" do+                phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Modified)+                buildResultsFrom phases `shouldMatchList` [resultFor reloadLr]++        describe "when the file is not loaded in GHCi" do+            it "calls controls.add (the editor just wrote a new file)" do+                phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/New.hs" Modified)+                buildResultsFrom phases `shouldMatchList` [resultFor addLr]++        -- Regression test for stale-diagnostics bug: cold-start with a+        -- pre-existing error then fix it. Foo is in :show targets but+        -- not :show modules, so dispatch must consult KnownTargetNames to+        -- avoid issuing a no-op :add.+        describe "when the file is a known target that failed on initial load" do+            it "calls controls.reload, not controls.add" do+                phases <-+                    runTest+                        Map.empty+                        (KnownTargetNames (Set.singleton "Foo"))+                        distinctCtrls+                        (SourceChangeDetected "/abs/src/Foo.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)+            buildResultsFrom phases `shouldMatchList` [resultFor addLr]++        describe "when the file is already loaded" $ it "calls controls.reload (re-add is a reload)" do+            phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Added)+            buildResultsFrom phases `shouldMatchList` [resultFor reloadLr]++    describe "Removed" do+        describe "when the file is loaded" $ it "calls controls.unadd" do+            phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Removed)+            buildResultsFrom phases `shouldMatchList` [resultFor unaddLr]++        describe "when the file is not loaded" $ it "is a no-op" do+            phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/Unknown.hs" Removed)+            phases `shouldBe` []++    describe "when the reload throws (e.g. interrupted mid-flight)" do+        it "resolves to BuildFailed instead of stranding the UI in Building" do+            phases <- runTest knownFoo noTargets throwingCtrls (SourceChangeDetected "/abs/path/Foo.hs" Modified)+            -- Regression: a reload that errors must resolve the build, not+            -- leave 'Building' as the terminal phase (the daemon would be+            -- stuck until the next change happened to succeed).+            viaNonEmpty last [p | EnteringNewPhase _ p <- phases]+                `shouldSatisfy` \case+                    Just (BuildFailed _) -> True+                    _ -> False+  where+    runTest initialModuleMap initialTargets ctrls event =+        runEff+            . runConcurrent+            . runClockConst epoch+            . runReader (ProjectRoot "/")+            . evalState (BuildId 1)+            . evalState+                emptyBuilderState+                    { loadedModules = initialModuleMap+                    , knownTargets = initialTargets+                    }+            . runLogNoOp+            . execWriter @[EnteringNewPhase]+            . runBuildStoreCapture+            . runTestRunnerScripted []+            $ reloadOnSourceChange (def @BuildConfig) ctrls event++    flow lr =+        [ EnteringNewPhase (BuildId 1) (Building Nothing)+        , EnteringNewPhase (BuildId 1) (Done (resultFor lr))+        ]++    buildResultsFrom phases = [r | EnteringNewPhase _ (Done r) <- phases]++    resultFor lr =+        BuildResult+            { completedAt = epoch+            , duration = 0+            , moduleCount = lr.moduleCount+            , diagnostics = []+            , testRuns = []+            }++    noTargets = KnownTargetNames Set.empty++    distinctCtrls =+        Controls+            { reload = pure reloadLr+            , interrupt = pure ()+            , add = \_ -> pure addLr+            , unadd = \_ -> pure unaddLr+            }++    -- A reload that throws, as if SIGINT'd by a second rapid source change.+    throwingCtrls = distinctCtrls {reload = throwIO (ErrorCall "reload interrupted")}++    knownFoo =+        Map.fromList+            [+                ( "/abs/path/Foo.hs"+                , LoadedModule {relPath = "./src/Foo.hs", moduleName = "MyModule"}+                )+            ]++    -- Distinct LoadResults so tests can identify which control was invoked.+    mkLr :: Int -> LoadResult+    mkLr n =+        LoadResult+            { moduleCount = n+            , compiledFiles = Set.singleton errMsg.file+            , loadedModules = Map.empty+            , targetNames = []+            , diagnostics = []+            }+    reloadLr = mkLr 10+    addLr = mkLr 20+    unaddLr = mkLr 30+++testSetNewPhase :: Spec+testSetNewPhase = do+    it "should set build phase" do+        state <- runEff+            . runConcurrent+            . runDelay+            . runInputConst emptyDaemonInfo+            . BuildStore.runBuildStore+            $ do+                setNewPhase $ EnteringNewPhase (BuildId 1) (Building Nothing)+                BuildStore.getState+        state+            `shouldBe` BuildState+                { buildId = BuildId 1+                , phase = Building Nothing+                , daemonInfo = emptyDaemonInfo+                }+++testCompileLoadResultsIntoBuildResults :: Spec+testCompileLoadResultsIntoBuildResults = do+    it "uses NewLoadResult's times to calculate duration" do+        let (_, r) =+                runTest+                    mempty+                    NewLoadResult+                        { startTime = addUTCTime 10 epoch+                        , endTime = addUTCTime 20 epoch+                        , loadResult =+                            LoadResult+                                { moduleCount = 2+                                , compiledFiles = Set.singleton errMsg.file+                                , loadedModules = Map.empty+                                , targetNames = []+                                , diagnostics = []+                                }+                        }+        r.duration `shouldBe` 10_000+    it "merges with existing results" do+        let (m, _) =+                runTest (Map.fromList [(errMsg.file, [errMsg])])+                    $ NewLoadResult+                        { startTime = epoch+                        , endTime = epoch+                        , loadResult =+                            LoadResult+                                { moduleCount = 2+                                , compiledFiles = Set.singleton warnMsg.file+                                , loadedModules = Map.empty+                                , targetNames = []+                                , diagnostics = [warnMsg]+                                }+                        }+        m+            `shouldBe` fromList+                [ (warnMsg.file, [warnMsg])+                , (errMsg.file, [errMsg])+                ]++    it "returns a BuildResult" do+        let (_, r) =+                runTest mempty+                    $ NewLoadResult+                        { startTime = epoch+                        , endTime = addUTCTime 10 epoch+                        , loadResult =+                            LoadResult+                                { moduleCount = 2+                                , compiledFiles = Set.singleton warnMsg.file+                                , loadedModules = Map.empty+                                , targetNames = []+                                , diagnostics = [warnMsg]+                                }+                        }+            expected =+                BuildResult+                    { completedAt = addUTCTime 10 epoch+                    , duration = 10_000+                    , moduleCount = 2+                    , diagnostics = [warnMsg]+                    , testRuns = []+                    }+        r `shouldBe` expected+  where+    runTest acc nlr =+        let (buildResult, builderState) =+                runPureEff+                    . runReader (ProjectRoot "/")+                    . runState (emptyBuilderState {diagnosticMap = acc})+                    $ compileLoadResultsIntoBuildResults (def {Builder.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+        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'+        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"]+                [ Right $ mkTestRun "test:foo"+                , Right $ mkTestRun "test:bar"+                ]+                expected+        length phases `shouldBe` 4+        let expectedPhases =+                [ mkTesting . buildWithTests+                    $ [ TestRunning "test:foo" Nothing+                      , TestRunning "test:bar" Nothing+                      ]+                , mkTesting . buildWithTests+                    $ [ mkTestRun "test:foo"+                      , TestRunning "test:bar" Nothing+                      ]+                , mkTesting . buildWithTests+                    $ [ mkTestRun "test:foo"+                      , mkTestRun "test:bar"+                      ]+                , mkDone . buildWithTests+                    $ [ mkTestRun "test:foo"+                      , mkTestRun "test:bar"+                      ]+                ]+        phases `shouldMatchList` expectedPhases++    -- Regression for the abort handling in 'runTestsIfClean': when an+    -- interrupt arrives mid-run loop, 'isAborted' becomes True and the loop+    -- returns 'Nothing'. The caller MUST then skip the 'Done' transition —+    -- otherwise the BuildStore briefly publishes a Done with a partial+    -- testRuns list, and a 'status --wait' caller reads that stale result+    -- before the new cycle starts.+    it "does not transition to Done when the run is aborted mid-flight" do+        phases <-+            runEff+                . runConcurrent+                . runLogNoOp+                . evalState (BuildId 1)+                . execWriter @[EnteringNewPhase]+                . runBuildStoreCapture+                . runTestRunnerAbortAfterFirst (mkTestRun "test:foo")+                $ requestTestRunsForNewBuildResults+                    BuildConfig+                        { command = ""+                        , targets = []+                        , testTargets = ["test:foo", "test:bar"]+                        , watchDirs = []+                        }+                    expected+        -- The critical assertion: no Done phase, because the run was+        -- aborted before completing the second suite. A Done here would+        -- briefly publish a half-finished testRuns list that a+        -- 'status --wait' caller could observe.+        length [() | EnteringNewPhase _ (Done _) <- phases] `shouldBe` 0+        -- Sanity: only the initial Testing transition was published; the+        -- run loop short-circuited after the first 'isAborted' check, so+        -- the post-foo Testing update never fired.+        length phases `shouldBe` 1+  where+    runTest testTargets script partial =+        runEff+            . runConcurrent+            . runLogNoOp+            . evalState (BuildId 1)+            . execWriter @[EnteringNewPhase]+            . runBuildStoreCapture+            . runTestRunnerScripted script+            $ requestTestRunsForNewBuildResults+                BuildConfig {command = "", targets = [], testTargets, watchDirs = []}+                partial++    mkPhase = EnteringNewPhase (BuildId 1)+    mkTesting = mkPhase . Testing+    mkDone = mkPhase . Done+    buildWithTests testRuns = expected {testRuns}++    expected =+        BuildResult+            { completedAt = addUTCTime 10 epoch+            , duration = 10_000+            , moduleCount = 2+            , diagnostics = [warnMsg]+            , testRuns = []+            }++    mkTestRun target =+        TestRunCompleted+            $ TestRunCompletion+                { target+                , passed = True+                , output = ""+                , testCases = []+                , duration = Nothing+                }+++--------------------------------------------------------------------------------+-- resolveKnownTargets tests+--------------------------------------------------------------------------------++testResolveKnownTargets :: Spec+testResolveKnownTargets = do+    it "uses :show modules as the primary source for path↔name mapping" do+        let result =+                emptyLr+                    { loadedModules =+                        Map.fromList+                            [+                                ( "/abs/src/Foo.hs"+                                , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"}+                                )+                            ]+                    , targetNames = ["Foo"]+                    }+        resolveKnownTargets Map.empty result+            `shouldBe` Map.fromList+                [+                    ( "/abs/src/Foo.hs"+                    , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"}+                    )+                ]++    -- Regression test for the stale-results bug. After a failed compile, the+    -- module disappears from :show modules but stays in :show targets. The+    -- prior state's entry must be carried over so the dispatcher continues to+    -- see the file as "known" and issues :reload (not :add) when the user+    -- fixes the error.+    it "carries over prior state for targets that are no longer in :show modules" do+        let prev =+                Map.fromList+                    [+                        ( "/abs/src/Foo.hs"+                        , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"}+                        )+                    ]+            result =+                emptyLr+                    { loadedModules = Map.empty -- Foo failed to compile+                    , targetNames = ["Foo"] -- but is still a target+                    }+        resolveKnownTargets prev result `shouldBe` prev++    it "drops targets that are no longer in :show targets" do+        let prev =+                Map.fromList+                    [+                        ( "/abs/src/Foo.hs"+                        , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"}+                        )+                    ]+            result = emptyLr {loadedModules = Map.empty, targetNames = []}+        resolveKnownTargets prev result `shouldBe` Map.empty++    -- Dropped from the path-keyed map because we have no path↔name entry;+    -- the dispatcher still handles them via 'KnownTargetNames'.+    it "drops targets that have neither a current :show modules entry nor prior state" do+        let result = emptyLr {loadedModules = Map.empty, targetNames = ["BrandNew"]}+        resolveKnownTargets Map.empty result `shouldBe` Map.empty+  where+    emptyLr =+        LoadResult+            { moduleCount = 0+            , compiledFiles = Set.empty+            , loadedModules = Map.empty+            , targetNames = []+            , diagnostics = []+            }+++--------------------------------------------------------------------------------+-- fileMatchesAnyTarget tests+--------------------------------------------------------------------------------++testFileMatchesAnyTarget :: Spec+testFileMatchesAnyTarget = do+    it "matches when the path's uppercase-suffix equals a target" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "Tricorder.Version"))+            "./tricorder/src/Tricorder/Version.hs"+            `shouldBe` True++    it "matches a single-segment module" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "Main"))+            "./app/Main.hs"+            `shouldBe` True++    it "does not match when no uppercase-suffix equals a target" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "Other.Module"))+            "./tricorder/src/Tricorder/Version.hs"+            `shouldBe` False++    it "does not match a lowercase-prefix even if textually contained" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "src.Tricorder.Version"))+            "./tricorder/src/Tricorder/Version.hs"+            `shouldBe` False++    it "handles .lhs extension" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "Foo.Bar"))+            "./src/Foo/Bar.lhs"+            `shouldBe` True+++--------------------------------------------------------------------------------+-- mergeDiagnostics tests+--------------------------------------------------------------------------------++testMergeDiagnostics :: Spec+testMergeDiagnostics = do+    it "retains diagnostics from files not in compiledFiles" do+        -- Foo has an error, Bar has a warning.+        -- Only Foo is recompiled (and fixed). Bar is unchanged, so Bar's+        -- warning must survive.+        let prev = Map.fromList [(errMsg.file, [errMsg]), (warnMsg.file, [warnMsg])]+            result =+                LoadResult+                    { moduleCount = 2+                    , compiledFiles = Set.singleton errMsg.file+                    , loadedModules = Map.empty+                    , targetNames = []+                    , diagnostics = []+                    }+        let merged = mergeDiagnostics prev result+        Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg]++    it "clears diagnostics when a recompiled file now has no issues" do+        let prev = Map.fromList [(errMsg.file, [errMsg])]+            result =+                LoadResult+                    { moduleCount = 1+                    , compiledFiles = Set.singleton errMsg.file+                    , loadedModules = Map.empty+                    , targetNames = []+                    , diagnostics = []+                    }+        let merged = mergeDiagnostics prev result+        Map.lookup errMsg.file merged `shouldBe` Nothing++    it "replaces diagnostics for recompiled files" do+        let newErr = errMsg {title = "new error", text = "new error\n"}+            prev = Map.fromList [(errMsg.file, [errMsg])]+            result =+                LoadResult+                    { moduleCount = 1+                    , compiledFiles = Set.singleton errMsg.file+                    , loadedModules = Map.empty+                    , targetNames = []+                    , diagnostics = [newErr]+                    }+        let merged = mergeDiagnostics prev result+        Map.lookup errMsg.file merged `shouldBe` Just [newErr]++    it "accumulates diagnostics for newly seen files" do+        let result =+                LoadResult+                    { moduleCount = 1+                    , compiledFiles = Set.singleton warnMsg.file+                    , loadedModules = Map.empty+                    , targetNames = []+                    , diagnostics = [warnMsg]+                    }+        let merged = mergeDiagnostics Map.empty result+        Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg]+++--------------------------------------------------------------------------------+-- filterToWatchDirs tests+--------------------------------------------------------------------------------++testFilterToWatchDirs :: Spec+testFilterToWatchDirs = do+    let root = "/project"+        watchDirs = ["/project/src"]++    it "keeps diagnostics under a watched directory" do+        -- ./src/Foo.hs is what toRelative produces for an absolute project file+        let d = errMsg {file = "./src/Foo.hs"}+        filterToWatchDirs root watchDirs [d] `shouldBe` [d]++    it "drops diagnostics from outside the project (e.g. Nix store .h files)" do+        let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}+        filterToWatchDirs root watchDirs [d] `shouldBe` []++    it "drops diagnostics with mangled CPP filenames" do+        -- The ghcid parser produces "In file included from <path>" as the file+        -- field for GCC-style CPP include-chain messages.+        let d = errMsg {file = "In file included from src/Foo.hs"}+        filterToWatchDirs root watchDirs [d] `shouldBe` []++    it "drops mangled CPP filenames when watchDirs is [\".\"] (project root)" do+        -- With watchDirs=["."], the watch dir resolves to projectRoot itself.+        -- 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` []++    it "passes everything through when watchDirs is empty" do+        let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}+        filterToWatchDirs root [] [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]+++--------------------------------------------------------------------------------+-- extractTitle tests+--------------------------------------------------------------------------------++testExtractTitle :: Spec+testExtractTitle = do+    it "returns empty string for empty message" do+        extractTitle [] `shouldBe` ""++    -- New GHC style: header ends with [GHC-XXXXX], content on body lines.+    -- Captured from GHC 9.10.2 with -Weverything.+    it "extracts first body line for error with [GHC-XXXXX] code" do+        extractTitle+            [ "src/Tricorder/Config.hs:39:20: error: [GHC-83865]"+            , "    \8226 Couldn't match expected type 'Int' with actual type 'Bool'"+            , "    \8226 In the expression: True"+            , "      In an equation for '_deliberateError': _deliberateError = True"+            , "   |"+            , "39 | _deliberateError = True"+            , "   |                    ^^^^"+            ]+            `shouldBe` "\8226 Couldn't match expected type 'Int' with actual type 'Bool'"++    it "extracts first body line for warning with [GHC-XXXXX] [-Wfoo] codes" do+        extractTitle+            [ "src/Tricorder/Config.hs:38:26: warning: [GHC-55631] [-Wmissing-deriving-strategies]"+            , "    No deriving strategy specified. Did you want stock, newtype, or anyclass?"+            , "   |"+            , "38 | data TestWarn = TestWarn deriving (Eq)"+            , "   |                          ^^^^^^^^^^^^^"+            ]+            `shouldBe` "No deriving strategy specified. Did you want stock, newtype, or anyclass?"++    -- Old GHC style: message text is inline on the header line.+    it "extracts inline content for old-style single-line error" do+        extractTitle ["GHCi.hs:70:1: error: Parse error: naked expression at top level"]+            `shouldBe` "Parse error: naked expression at top level"++    it "extracts inline content for old-style Warning (capital W)" do+        extractTitle ["GHCi.hs:81:1: Warning: Defined but not used: \8216foo\8217"]+            `shouldBe` "Defined but not used: \8216foo\8217"++    -- Multi-line without any inline message: position-only or "Warning:" header.+    it "extracts first body line when header has position only" do+        extractTitle+            [ "GHCi.hs:72:13:"+            , "    No instance for (Num ([String] -> [String]))"+            , "      arising from the literal '1'"+            ]+            `shouldBe` "No instance for (Num ([String] -> [String]))"++    it "extracts first body line when header ends with 'Warning:'" do+        extractTitle+            [ "/src/TrieSpec.hs:(192,7)-(193,76): Warning:"+            , "    A do-notation statement discarded a result of type '[()]'"+            ]+            `shouldBe` "A do-notation statement discarded a result of type '[()]'"++    -- Source display lines (pipe/caret) must be skipped.+    it "skips source display lines when scanning body" do+        extractTitle+            [ "file.hs:1:1: error: [GHC-12345]"+            , "   |"+            , "1 | foo bar"+            , "   |     ^^^"+            , "    actual content here"+            ]+            `shouldBe` "actual content here"++    -- ANSI-escaped header (colour output): strip escapes before searching.+    it "handles ANSI-escaped headers" do+        extractTitle+            [ "\ESC[;1msrc/Types.hs:11:1: \ESC[35mwarning:\ESC[0m \ESC[35m[-Wunused-imports]\ESC[0m"+            , "    The import of 'Data.Data' is redundant"+            ]+            `shouldBe` "The import of 'Data.Data' is redundant"+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++errMsg :: Diagnostic+errMsg =+    Diagnostic+        { severity = SError+        , file = "./src/Foo.hs"+        , line = 1+        , col = 1+        , endLine = 1+        , endCol = 5+        , title = "Variable not in scope: foo"+        , text = "Variable not in scope: foo"+        }+++warnMsg :: Diagnostic+warnMsg =+    Diagnostic+        { severity = SWarning+        , file = "./src/Bar.hs"+        , line = 10+        , col = 3+        , endLine = 10+        , endCol = 8+        , title = "Unused import"+        , text = "Unused import"+        }+++epoch :: UTCTime+epoch = UTCTime (fromGregorian 1970 1 1) 0+++emptyDaemonInfo :: DaemonInfo+emptyDaemonInfo =+    DaemonInfo+        { targets = []+        , watchDirs = []+        , sockPath = ""+        , logFile = ""+        , metricsPort = Nothing+        }+++--------------------------------------------------------------------------------+-- Event coalescing (watchSourceChanges)+--+-- Regression for the parallel-cycles bug. When source-change events arrive+-- more than 200ms apart, debounce fires each callback separately. While one+-- cycle is in flight, the rest must collapse into AT MOST ONE trailing cycle+-- rather than queueing N back-to-back cycles — otherwise a 'status --wait'+-- caller wouldn't see "Done" until the last queued cycle finished. This+-- mirrors the single-slot register + single-worker pattern that+-- 'watchSourceChanges' uses to coalesce a burst into one trailing reload.+--------------------------------------------------------------------------------++testEventCoalescing :: Spec+testEventCoalescing = do+    -- Whenever 'interruptCurrent' cannot drop the in-flight cycle promptly+    -- (e.g. a 'status --wait' caller has registered as a waiter, gating+    -- 'interruptCurrent' to a no-op), additional source-change events would+    -- previously each queue their own follow-up cycle.+    -- N touches spaced wider than the 200ms debounce window therefore+    -- produced N back-to-back cycles after the in-flight one finished — and+    -- a 'status --wait' caller wouldn't see "Done" until the last queued+    -- cycle completed.+    --+    -- Desired behaviour: while a cycle is in flight, additional source+    -- changes coalesce into AT MOST ONE trailing cycle, regardless of how+    -- many events arrived. This mirrors the single-slot register ++    -- single-worker pattern that 'watchSourceChanges' uses.+    it "coalesces source-change events into one follow-up cycle while busy" do+        cycleRunsRef <- newTVarIO (0 :: Int)+        releaseFirst <- STM.newEmptyTMVarIO @()+        isFirstRef <- newTVarIO True+        let onEvent _ = do+                atomically (modifyTVar' cycleRunsRef (+ 1))+                -- The first invocation blocks until released, simulating+                -- the in-flight cycle. Subsequent invocations return+                -- immediately.+                wasFirst <- atomically (STM.swapTVar isFirstRef False)+                when wasFirst $ atomically (STM.takeTMVar releaseFirst)+        result <-+            runEff+                . runConcurrent+                . runTracingNoOp+                . runClockConst epoch+                . runChan+                . runDelay+                . runPubSub @SourceChangeDetected+                . runErrorNoCallStack @StopSignal+                . runConc+                . runDebounce @Text+                $ do+                    pending <- atomically (STM.newTVar @(Maybe SourceChangeDetected) Nothing)+                    Conc.scoped do+                        -- Listener: debounce + write the latest event into+                        -- the single-slot register.+                        Conc.fork_+                            $ listen_ \(ev :: SourceChangeDetected) ->+                                debounced+                                    (200 :: Millisecond)+                                    ("source_change_reloader" :: Text)+                                    (atomically (writeTVar pending (Just ev)))+                        -- Worker: drain the register, run the action.+                        -- Bursts of events that arrive while 'onEvent' is in+                        -- flight overwrite the slot, so the worker sees only+                        -- the most recent one.+                        Conc.fork_ $ forever do+                            ev <- atomically do+                                readTVar pending >>= \case+                                    Nothing -> retry+                                    Just e -> writeTVar pending Nothing >> pure e+                            onEvent ev+                        -- Let the listener's 'dupChan' subscribe before we+                        -- start publishing — otherwise the first event is+                        -- dropped because no subscriber sees it.+                        Delay.wait (50 :: Millisecond)+                        -- Four events spaced wider than 200ms so the+                        -- debounce window does NOT collapse them by itself.+                        -- The first becomes the in-flight cycle; the rest+                        -- must collapse into ONE trailing invocation.+                        publish (SourceChangeDetected "/x" Modified)+                        Delay.wait (250 :: Millisecond)+                        publish (SourceChangeDetected "/y" Modified)+                        Delay.wait (250 :: Millisecond)+                        publish (SourceChangeDetected "/z" Modified)+                        Delay.wait (250 :: Millisecond)+                        publish (SourceChangeDetected "/w" Modified)+                        -- Let the last debounce window expire so the latest+                        -- event lands in the slot.+                        Delay.wait (300 :: Millisecond)+                        -- Release the in-flight cycle; the slot drains and+                        -- the trailing cycle runs.+                        atomically (STM.putTMVar releaseFirst ())+                        Delay.wait (300 :: Millisecond)+                        throwError StopSignal+        case result of+            Left StopSignal -> pure ()+            Right () -> pure ()+        runs <- STM.atomically (readTVar cycleRunsRef)+        -- 1 in-flight + 1 coalesced trailing = 2.+        runs `shouldBe` 2+++-- | Pins down the abort path on every source change: when no 'status --wait'+-- caller is holding the build, 'interruptCurrent' must drive both+-- 'controls.interrupt' (which terminates the in-flight GHCi command) and+-- 'TestRunner.interruptCurrent' (which terminates the in-flight test+-- process). When a waiter IS present, both are suppressed so the waiter+-- gets the result it's blocked on rather than a half-cancelled cycle.+testInterruptCurrent :: Spec+testInterruptCurrent = do+    it "drives controls.interrupt and TestRunner.interruptCurrent when no waiter" do+        (ctrls, testRun) <- runInterruptCurrent False+        ctrls `shouldBe` 1+        testRun `shouldBe` 1++    it "suppresses both interrupts when a waiter is present" do+        (ctrls, testRun) <- runInterruptCurrent True+        ctrls `shouldBe` 0+        testRun `shouldBe` 0+  where+    runInterruptCurrent waiterPresent = do+        ctrlsCalled <- newTVarIO (0 :: Int)+        trCalled <- newTVarIO (0 :: Int)+        -- Wrap the unused fields in 'pure' so the 'error' is the Eff+        -- \*action*, not the field value — Controls uses StrictData, which+        -- would otherwise force the bottoms when the record is constructed.+        let mockCtrls =+                Controls+                    { reload = pure (error "interruptCurrent must not call reload")+                    , interrupt = atomically (modifyTVar' ctrlsCalled (+ 1))+                    , add = \_ -> pure (error "interruptCurrent must not call add")+                    , unadd = \_ -> pure (error "interruptCurrent must not call unadd")+                    }+        runEff+            . runConcurrent+            . runLogNoOp+            . runHasWaitersConst waiterPresent+            . runTestRunnerInterruptCounter trCalled+            $ Builder.interruptCurrent mockCtrls+        (,)+            <$> STM.atomically (readTVar ctrlsCalled)+            <*> STM.atomically (readTVar trCalled)++    -- 'interruptCurrent' only calls 'hasWaiters' on the BuildStore — every+    -- other op is unreachable from this code path, so we trap them.+    runHasWaitersConst+        :: Bool+        -> Eff (BuildStore.BuildStore : es) a+        -> Eff es a+    runHasWaitersConst hasWaiters = interpret_ \case+        BuildStore.HasWaiters -> pure hasWaiters+        BuildStore.SetPhase _ _ -> error "interruptCurrent must not setPhase"+        BuildStore.MarkDirty _ -> error "interruptCurrent must not markDirty"+        BuildStore.GetState -> error "interruptCurrent must not getState"+        BuildStore.ModifyPhase _ -> error "interruptCurrent must not modifyPhase"+        BuildStore.WaitUntilDone -> error "interruptCurrent must not waitUntilDone"+        BuildStore.WaitForNext _ -> error "interruptCurrent must not waitForNext"+        BuildStore.WaitForAnyChange _ -> error "interruptCurrent must not waitForAnyChange"+        BuildStore.WaitDirty -> error "interruptCurrent must not waitDirty"++    -- Counts 'InterruptCurrent' invocations; the other ops are unreachable+    -- from 'Builder.interruptCurrent'.+    runTestRunnerInterruptCounter+        :: (Concurrent :> es)+        => STM.TVar Int+        -> Eff (TestRunner : es) a+        -> Eff es a+    runTestRunnerInterruptCounter counter = interpret_ \case+        InterruptCurrent -> atomically (modifyTVar' counter (+ 1))+        RunTestSuite _ -> error "Builder.interruptCurrent must not runTestSuite"+        ResetAbort -> error "Builder.interruptCurrent must not resetAbort"+        IsAborted -> error "Builder.interruptCurrent must not isAborted"+++-- | A 'TestRunner' interpreter that returns the same result for every+-- 'RunTestSuite' call, but latches 'IsAborted' to True after the first one+-- — simulating an external interrupt that arrives between two test suites.+runTestRunnerAbortAfterFirst+    :: (Concurrent :> es)+    => TestRun -> Eff (TestRunner : es) a -> Eff es a+runTestRunnerAbortAfterFirst result act = do+    callCountRef <- atomically (STM.newTVar (0 :: Int))+    abortedRef <- atomically (STM.newTVar False)+    interpret_+        ( \case+            RunTestSuite _ -> do+                n <- atomically do+                    modifyTVar' callCountRef (+ 1)+                    readTVar callCountRef+                when (n == 1) $ atomically (writeTVar abortedRef True)+                pure result+            InterruptCurrent -> atomically (writeTVar abortedRef True)+            ResetAbort -> atomically (writeTVar abortedRef False)+            IsAborted -> atomically (readTVar abortedRef)+        )+        act+++-- | A 'BuildStore' interpreter that records every 'setPhase' call into a+-- 'Writer'. Only the operations used by the Builder pipeline tests are+-- implemented; the rest error.+runBuildStoreCapture+    :: (Writer [EnteringNewPhase] :> es)+    => Eff (BuildStore.BuildStore : es) a -> Eff es a+runBuildStoreCapture = interpret_ \case+    BuildStore.SetPhase bid phase -> tell [EnteringNewPhase bid phase]+    BuildStore.HasWaiters -> pure False+    BuildStore.MarkDirty _ -> pure ()+    BuildStore.GetState -> error "runBuildStoreCapture: GetState unsupported"+    BuildStore.ModifyPhase _ -> error "runBuildStoreCapture: ModifyPhase unsupported"+    BuildStore.WaitUntilDone -> error "runBuildStoreCapture: WaitUntilDone unsupported"+    BuildStore.WaitForNext _ -> error "runBuildStoreCapture: WaitForNext unsupported"+    BuildStore.WaitForAnyChange _ -> error "runBuildStoreCapture: WaitForAnyChange unsupported"+    BuildStore.WaitDirty -> error "runBuildStoreCapture: WaitDirty unsupported"
+ test/Unit/Tricorder/CLI/RenderSpec.hs view
@@ -0,0 +1,76 @@+module Unit.Tricorder.CLI.RenderSpec (spec_Render) where++import Test.Hspec++import Tricorder.BuildState+    ( Diagnostic (..)+    , Severity (..)+    )+import Tricorder.CLI.Render (diagnosticBlock)+++spec_Render :: Spec+spec_Render = do+    describe "diagnosticBlock" do+        it "includes the one-liner prefix for an error" do+            diagnosticBlock errMsg `shouldContainT` "E Foo.hs:10 type mismatch"++        it "includes the full text body after the first line" do+            diagnosticBlock errMsg `shouldContainT` "\ntype mismatch"++        it "uses 'W' prefix for warnings" do+            diagnosticBlock warnMsg `shouldContainT` "W Bar.hs:3 unused import"++        it "contains both title and text when they differ" do+            let d = mixedMsg+            diagnosticBlock d `shouldContainT` "short title"+            diagnosticBlock d `shouldContainT` "full body of the message"+  where+    shouldContainT :: Text -> Text -> Expectation+    shouldContainT a b = toString a `shouldContain` toString b+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++errMsg :: Diagnostic+errMsg =+    Diagnostic+        { severity = SError+        , file = "Foo.hs"+        , line = 10+        , col = 1+        , endLine = 10+        , endCol = 5+        , title = "type mismatch"+        , text = "type mismatch"+        }+++warnMsg :: Diagnostic+warnMsg =+    Diagnostic+        { severity = SWarning+        , file = "Bar.hs"+        , line = 3+        , col = 1+        , endLine = 3+        , endCol = 10+        , title = "unused import"+        , text = "unused import"+        }+++mixedMsg :: Diagnostic+mixedMsg =+    Diagnostic+        { severity = SError+        , file = "Baz.hs"+        , line = 5+        , col = 1+        , endLine = 5+        , endCol = 20+        , title = "short title"+        , text = "full body of the message"+        }
+ test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs view
@@ -0,0 +1,313 @@+module Unit.Tricorder.Effects.GhciSession.GhciParserSpec (spec_GhciParser) where++import Test.Hspec++import Tricorder.Effects.GhciSession.GhciParser+    ( GhciLoad (..)+    , GhciLoading (..)+    , GhciMessage (..)+    , GhciSeverity (..)+    , Position (..)+    , parseReload+    , parseShowModules+    , parseShowTargets+    )+++spec_GhciParser :: Spec+spec_GhciParser = do+    describe "parseReload" do+        describe "clean build" testCleanBuild+        describe "with errors and warnings" testErrors+        describe "with -fhide-source-paths (no Loading items)" testHideSourcePaths+        describe "with <no location info> errors" testNoLocationInfo+        describe "with Loaded GHCi configuration" testLoadedConfig++    describe "parseShowModules" do+        describe "typical output" testShowModules+        describe "empty / blank input" testShowModulesEmpty++    describe "parseShowTargets" testShowTargets+++--------------------------------------------------------------------------------+-- parseReload: clean build+--------------------------------------------------------------------------------++testCleanBuild :: Spec+testCleanBuild = do+    it "produces GLoading items for each compiled module" do+        let input =+                [ "[1 of 3] Compiling Tricorder.BuildState ( src/Tricorder/BuildState.hs, interpreted )"+                , "[2 of 3] Compiling Tricorder.Session    ( src/Tricorder/Session.hs, interpreted )"+                , "[3 of 3] Compiling Main                 ( app/Main.hs, interpreted )"+                , "Ok, 3 modules loaded."+                ]+        parseReload input+            `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"}+                       ]++    it "handles padded module index (e.g. [ 1 of 47])" do+        let input =+                [ "[ 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"}]++    describe "when only summary line" $ it "returns empty list" do+        parseReload ["Ok, 0 modules loaded."] `shouldBe` []+++--------------------------------------------------------------------------------+-- parseReload: errors and warnings+--------------------------------------------------------------------------------++testErrors :: Spec+testErrors = do+    it "parses a single-line error" do+        let input = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]+        parseReload input+            `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Foo.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]}]++    it "parses a warning with continuation lines" do+        let input =+                [ "src/Bar.hs:20:3: warning: [-Wunused-imports]"+                , "    Redundant import: Data.List"+                , "    Perhaps you want to remove it."+                ]+        parseReload input+            `shouldBe` [ GMessage+                            GhciMessage+                                { severity = GWarning+                                , file = "src/Bar.hs"+                                , startPos = Position 20 3+                                , endPos = Position 20 3+                                , messageLines =+                                    [ "src/Bar.hs:20:3: warning: [-Wunused-imports]"+                                    , "    Redundant import: Data.List"+                                    , "    Perhaps you want to remove it."+                                    ]+                                }+                       ]++    it "parses a span position (L:C-C2:)" do+        let input = ["src/Baz.hs:5:1-10: error: Parse error"]+        parseReload input+            `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Baz.hs", startPos = Position 5 1, endPos = Position 5 10, messageLines = ["src/Baz.hs:5:1-10: error: Parse error"]}]++    it "parses a span position ((L1,C1)-(L2,C2):)" do+        let input = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]+        parseReload input+            `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Qux.hs", startPos = Position 3 1, endPos = Position 5 20, messageLines = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]}]++    it "parses a span position with double-paren end ((L1,C1)-((L2,C2):)" do+        let input = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]+        parseReload input+            `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Qux.hs", startPos = Position 3 1, endPos = Position 5 20, messageLines = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]}]++    it "parses source-display continuation lines (pipe format)" do+        let input =+                [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                , "   |"+                , "10 | foo bar"+                , "   | ^^^"+                , "    Suggested fix: import Foo"+                ]+        parseReload input+            `shouldBe` [ GMessage+                            GhciMessage+                                { severity = GError+                                , file = "src/Foo.hs"+                                , startPos = Position 10 5+                                , endPos = Position 10 5+                                , messageLines =+                                    [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                                    , "   |"+                                    , "10 | foo bar"+                                    , "   | ^^^"+                                    , "    Suggested fix: import Foo"+                                    ]+                                }+                       ]++    it "strips ANSI codes from header for matching but stores original in glMessage" do+        let ansiHeader = "\ESC[1msrc/Foo.hs:10:5:\ESC[0m \ESC[91merror:\ESC[0m Variable not in scope: foo"+        parseReload [ansiHeader]+            `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Foo.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = [ansiHeader]}]++    it "parses a Windows drive-letter path in a diagnostic" do+        let input = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]+        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+        let input =+                [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )"+                , "src/Lib.hs:5:1: error: Oops"+                , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )"+                , "Failed, 1 module loaded."+                ]+        parseReload input+            `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"}+                       ]+++--------------------------------------------------------------------------------+-- parseReload: -fhide-source-paths output+--------------------------------------------------------------------------------++testHideSourcePaths :: Spec+testHideSourcePaths = do+    describe "when source paths are hidden" $ it "produces no GLoading items" do+        let input =+                [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                , "    Perhaps you meant: 'bar'"+                , "Failed, one module failed to load."+                ]+        parseReload input+            `shouldBe` [ GMessage+                            GhciMessage+                                { severity = GError+                                , file = "src/Foo.hs"+                                , startPos = Position 10 5+                                , endPos = Position 10 5+                                , messageLines =+                                    [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                                    , "    Perhaps you meant: 'bar'"+                                    ]+                                }+                       ]++    describe "when all modules are already up to date" $ it "returns empty list" do+        -- GHCi with -fhide-source-paths and nothing to recompile+        parseReload ["Ok, 5 modules loaded."] `shouldBe` []+++--------------------------------------------------------------------------------+-- parseReload: <no location info> errors+--------------------------------------------------------------------------------++testNoLocationInfo :: Spec+testNoLocationInfo = do+    it "handles <no location info>: error: with continuation" do+        let input =+                [ "<no location info>: error:"+                , "    Module `Tricorder.Missing' is not loaded."+                ]+        parseReload input+            `shouldBe` [ GMessage+                            GhciMessage+                                { severity = GError+                                , file = "<no location info>"+                                , startPos = Position 0 0+                                , endPos = Position 0 0+                                , messageLines =+                                    [ "<no location info>: error:"+                                    , "    Module `Tricorder.Missing' is not loaded."+                                    ]+                                }+                       ]++    it "handles <no location info>: error: with no continuation" do+        parseReload ["<no location info>: error: some error"]+            `shouldBe` [GMessage GhciMessage {severity = GError, file = "<no location info>", startPos = Position 0 0, endPos = Position 0 0, messageLines = ["<no location info>: error: some error"]}]+++--------------------------------------------------------------------------------+-- parseReload: Loaded GHCi configuration+--------------------------------------------------------------------------------++testLoadedConfig :: Spec+testLoadedConfig = do+    it "parses a GHCi configuration line" do+        parseReload ["Loaded GHCi configuration from /home/user/project/.ghci"]+            `shouldBe` [GLoadConfig "/home/user/project/.ghci"]++    it "parses a Windows-style GHCi configuration path" do+        parseReload ["Loaded GHCi configuration from C:\\Users\\user\\project\\.ghci"]+            `shouldBe` [GLoadConfig "C:\\Users\\user\\project\\.ghci"]++    it "handles config line mixed with other output" do+        let input =+                [ "Loaded GHCi configuration from .ghci"+                , "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"+                , "Ok, 1 module loaded."+                ]+        parseReload input+            `shouldBe` [ GLoadConfig ".ghci"+                       , GLoading GhciLoading {index = 1, total = 1, moduleName = "Main", sourceFile = "app/Main.hs"}+                       ]+++--------------------------------------------------------------------------------+-- parseShowModules+--------------------------------------------------------------------------------++testShowModules :: Spec+testShowModules = do+    it "parses typical :show modules output" do+        let input =+                [ "Tricorder.BuildState     ( src/Tricorder/BuildState.hs, interpreted )"+                , "Tricorder.Session        ( src/Tricorder/Session.hs, interpreted )"+                , "Main                     ( app/Main.hs, interpreted )"+                ]+        parseShowModules input+            `shouldBe` [ ("Tricorder.BuildState", "src/Tricorder/BuildState.hs")+                       , ("Tricorder.Session", "src/Tricorder/Session.hs")+                       , ("Main", "app/Main.hs")+                       ]++    it "parses absolute paths" do+        parseShowModules ["Lib ( /home/user/project/src/Lib.hs, interpreted )"]+            `shouldBe` [("Lib", "/home/user/project/src/Lib.hs")]++    it "strips ANSI codes before parsing" do+        parseShowModules ["\ESC[1mMain\ESC[0m                     ( app/Main.hs, interpreted )"]+            `shouldBe` [("Main", "app/Main.hs")]+++testShowModulesEmpty :: Spec+testShowModulesEmpty = do+    it "returns empty list for empty input" do+        parseShowModules [] `shouldBe` []++    it "returns empty list for blank lines" do+        parseShowModules ["", "   ", "\t"] `shouldBe` []++    it "skips lines without '( '" do+        parseShowModules ["just some random text"] `shouldBe` []+++--------------------------------------------------------------------------------+-- parseShowTargets+--------------------------------------------------------------------------------++testShowTargets :: Spec+testShowTargets = do+    it "parses module names emitted by cabal repl --enable-multi-repl" do+        parseShowTargets+            [ "Atelier.Effects.Cache"+            , "Atelier.Effects.Chan"+            , "Paths_tricorder"+            ]+            `shouldBe` ["Atelier.Effects.Cache", "Atelier.Effects.Chan", "Paths_tricorder"]++    it "parses file-path targets emitted by plain ghci" do+        parseShowTargets ["src/Foo.hs", "test/Bar.hs"]+            `shouldBe` ["src/Foo.hs", "test/Bar.hs"]++    it "strips the leading '*' marker for the active interactive target" do+        parseShowTargets ["*Main", "Foo.Bar"] `shouldBe` ["Main", "Foo.Bar"]++    it "strips ANSI escape sequences" do+        parseShowTargets ["\ESC[1mFoo.Bar\ESC[0m"] `shouldBe` ["Foo.Bar"]++    it "skips blank and whitespace-only lines" do+        parseShowTargets ["", "   ", "\t", "Real.Target"] `shouldBe` ["Real.Target"]++    it "returns empty list for empty input" do+        parseShowTargets [] `shouldBe` []
+ test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs view
@@ -0,0 +1,319 @@+module Unit.Tricorder.Effects.GhciSession.GhciProcessSpec (spec_GhciProcess) where++import Atelier.Effects.Conc (runConc)+import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.File (runFile)+import Atelier.Effects.Process (runProcessIO)+import Atelier.Effects.Timeout (runTimeout)+import Atelier.Time (Millisecond)+import Control.Concurrent.STM (newTVarIO)+import Control.Exception (catch)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Time.Units (Second)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Exception (trySync)+import System.Process.Typed+    ( createPipe+    , getStderr+    , getStdin+    , getStdout+    , setStderr+    , setStdin+    , setStdout+    , shell+    , startProcess+    , stopProcess+    , waitExitCode+    )+import Test.Hspec++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.File qualified as File+import Data.Text qualified as T+import System.Process qualified as Process++import Tricorder.Effects.GhciSession.GhciProcess+    ( GhciProcess (..)+    , GhciProcessError (..)+    , InterruptDecision (..)+    , SessionState (..)+    , decideInterrupt+    , execGhci+    , waitForBannerOrFail+    )+++spec_GhciProcess :: Spec+spec_GhciProcess = do+    describe "decideInterrupt" testDecideInterrupt+    describe "execGhci" testExecGhciScope+    describe "execGhci (stale marker desync)" testExecGhciStaleMarker+    describe "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent+    describe "waitForBannerOrFail" testWaitForBannerOrFail+++-- | Regression for the touch-during-reload desync. Interrupting a *Busy* GHCi+-- (a reload in flight) leaves a stale sync marker in the stdout/stderr buffers+-- ahead of the next command's real output. Because 'drainUntil' used to stop on+-- ANY marker-prefix line, the next 'execGhci' matched that stale marker and+-- returned *before its command ran* — surfacing as @All good. (0 modules)@ (or,+-- on the other timing, a hang). 'execGhci' must skip markers that aren't its+-- own and stop only on the marker it is waiting for.+testExecGhciStaleMarker :: Spec+testExecGhciStaleMarker =+    it "skips a stale leftover marker and returns the command's real output" do+        (stdinR, stdinW) <- Process.createPipe+        (stdoutR, stdoutW) <- Process.createPipe+        (stderrR, stderrW) <- Process.createPipe+        -- A dummy process handle to fill the record; 'execGhci' never uses it.+        p <-+            startProcess+                $ setStdin createPipe+                $ setStdout createPipe+                $ setStderr createPipe+                $ shell "true"+        _ <- waitExitCode p+        stateVar <- newTVarIO (Idle 9)+        let gp =+                GhciProcess+                    { stdin = stdinW+                    , stdout = stdoutR+                    , stderr = stderrR+                    , handle = p+                    , stateVar+                    }+            -- Mirrors 'markerFor': "#~TRI-FINISH-<n>~#".+            marker n = "#~TRI-FINISH-" <> show (n :: Int) <> "~#" :: Text+        result <-+            runEff+                . runConcurrent+                . runTimeout+                . runDelay+                . runFile+                . runConc+                $ do+                    -- A stale 'marker 5' (left by a prior interrupted reload)+                    -- precedes the fresh command's real output + its 'marker 9'+                    -- (state is 'Idle 9', so 'execGhci' waits for marker 9).+                    for_ [marker 5, "out-line", marker 9] (File.hPutTextLn stdoutW)+                    for_ [marker 5, "err-line", marker 9] (File.hPutTextLn stderrW)+                    File.hClose stdoutW+                    File.hClose stderrW+                    -- Keep the stdin read-end alive across the write inside+                    -- 'execGhci' (otherwise it is GC-finalised → broken pipe).+                    r <- execGhci gp "reload" (\_ -> pure ())+                    File.hClose stdinR+                    pure r+        _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())+        result `shouldBe` ["out-line", "err-line"]+++-- | Root-cause regression for the "stuck Building…" stall. A SIGINT-interrupted+-- ':reload' empties GHCi's interactive scope — it drops the implicit+-- @import Prelude@ (verified against ghci 9.10). A sync marker built from bare+-- Prelude names then fails to run instead of printing: @putStrLn@ is no longer+-- in scope, and neither is the @>>@ operator. The marker never appears, so+-- 'drainUntil' blocks until the watchdog fires. The marker must therefore use+-- only fully-qualified 'System.IO.hPutStrLn' statements (which survive the+-- emptied scope), one per stream, with no bare names or operators.+--+-- We assert on exactly what 'execGhci' writes to GHCi's stdin.+testSyncMarkerScopeIndependent :: Spec+testSyncMarkerScopeIndependent =+    it "writes the finish marker using only fully-qualified names (no bare putStrLn / >>)" do+        (stdinR, stdinW) <- Process.createPipe+        (stdoutR, stdoutW) <- Process.createPipe+        (stderrR, stderrW) <- Process.createPipe+        p <-+            startProcess+                $ setStdin createPipe+                $ setStdout createPipe+                $ setStderr createPipe+                $ shell "true"+        _ <- waitExitCode p+        stateVar <- newTVarIO (Idle 9)+        let gp =+                GhciProcess+                    { stdin = stdinW+                    , stdout = stdoutR+                    , stderr = stderrR+                    , handle = p+                    , stateVar+                    }+            marker = "#~TRI-FINISH-9~#" :: Text+        written <-+            runEff+                . runConcurrent+                . runTimeout+                . runDelay+                . runFile+                . runConc+                $ do+                    -- Pre-seed the marker on both streams so the drain returns+                    -- immediately; we only care about what was written to stdin.+                    File.hPutTextLn stdoutW marker+                    File.hPutTextLn stderrW marker+                    File.hClose stdoutW+                    File.hClose stderrW+                    _ <- execGhci gp ":reload" (\_ -> pure ())+                    File.hClose stdinW+                    let readAll acc =+                            trySync (File.hGetLine stdinR) >>= \case+                                Left (_ :: SomeException) -> pure (reverse acc)+                                Right l -> readAll (l : acc)+                    readAll []+        _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())+        let blob = T.intercalate "\n" written+        (" >> " `T.isInfixOf` blob) `shouldBe` False+        ("System.IO.hPutStrLn System.IO.stdout" `T.isInfixOf` blob) `shouldBe` True+        ("System.IO.hPutStrLn System.IO.stderr" `T.isInfixOf` blob) `shouldBe` True+++-- | Regression: when the build command exits before printing a GHCi banner,+-- 'waitForBannerOrFail' must surface the *complete* stderr output in the+-- 'StartupFailed' error. The original implementation snapshotted the captured+-- lines as soon as the process exited (it waited on 'waitExitCode'), racing+-- the concurrent stderr drain — so a burst of error lines still buffered in+-- the pipe was truncated, and the real cabal/build failure was lost.+testWaitForBannerOrFail :: Spec+testWaitForBannerOrFail =+    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+        (bannerOut, bannerOutW) <- Process.createPipe+        (errR, errW) <- Process.createPipe+        result <-+            runEff+                . runConcurrent+                . runTimeout+                . 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"+                    -- failure branch.+                    File.hClose bannerOutW+                    -- Producer: pause long enough that a snapshot-at-exit reads+                    -- an empty buffer, THEN stream the whole error log and+                    -- close so the drain sees EOF. A correct implementation+                    -- awaits that drain before reading the captured lines.+                    _ <- Conc.fork do+                        Delay.wait (30 :: Millisecond)+                        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 ())+        case result of+            Right () -> expectationFailure "expected waitForBannerOrFail to throw a startup error"+            Left ex -> case fromException ex of+                Just (StartupFailed msg) ->+                    (lastLine `T.isInfixOf` msg) `shouldBe` True+                other ->+                    expectationFailure ("expected StartupFailed, got: " <> show other)+++testDecideInterrupt :: Spec+testDecideInterrupt = do+    -- Regression: an idle GHCi must not be SIGINT'd, since the matching+    -- sync-marker write would leave a stale marker line in stdout/stderr+    -- that the next 'execGhci' drain would match instead of the fresh one,+    -- desyncing the protocol and reporting "0 modules" or hanging.+    it "is a no-op when the session is Idle" do+        decideInterrupt (Idle 7) `shouldBe` (Idle 7, NoOpIdle)++    it "preserves the counter for any Idle state" do+        decideInterrupt (Idle 0) `shouldBe` (Idle 0, NoOpIdle)+        decideInterrupt (Idle 42) `shouldBe` (Idle 42, NoOpIdle)++    it "advances to Idle (n+1) and emits SendInterruptFor n when Busy" do+        decideInterrupt (Busy 7) `shouldBe` (Idle 8, SendInterruptFor 7)++    it "advances correctly from Busy 0" do+        decideInterrupt (Busy 0) `shouldBe` (Idle 1, SendInterruptFor 0)+++-- | Pins down the 'Conc.scoped' fix in 'execGhci': when the drain forks+-- raise 'UnexpectedExit' (because the underlying process exited and EOF'd+-- the pipes), the exception must be CONTAINED inside 'execGhci' and+-- surfaced via the caller's 'trySync' — not propagated to the ambient+-- 'Conc.scoped' that called 'execGhci'.+--+-- Without the inner 'Conc.scoped' in 'execGhci', Ki propagates an+-- exception from a forked thread to its owning scope. If 'execGhci' forks+-- its drains directly into the ambient scope (the original bug), the+-- ambient scope is torn down — siblings die, the whole builder cycle+-- unwinds, and the daemon ends up in the "Restarting builder..." state+-- the user observed.+testExecGhciScope :: Spec+testExecGhciScope =+    -- Spawn a real subprocess that exits immediately ('true'). Its+    -- stdout/stderr pipes EOF as soon as the child exits, which makes+    -- 'drainUntil' inside 'execGhci' throw 'UnexpectedExit' — exactly the+    -- mid-command termination path the fix exists to handle.+    it "contains drain exceptions inside its own scope so siblings survive" do+        p <-+            startProcess+                $ setStdin createPipe+                $ setStdout createPipe+                $ setStderr createPipe+                $ shell "true"+        -- Wait for the child to actually exit so the pipes are EOF before+        -- 'execGhci' starts draining (otherwise the drain blocks).+        _ <- waitExitCode p+        stateVar <- newTVarIO (Idle 0)+        let gp =+                GhciProcess+                    { stdin = getStdin p+                    , stdout = getStdout p+                    , stderr = getStderr p+                    , handle = p+                    , stateVar+                    }+        siblingDoneRef <- newIORef False+        result <-+            runEff+                . runConcurrent+                . runTimeout+                . runDelay+                . runFile+                . runConc+                $ Conc.scoped do+                    -- A sibling fork in the SAME ambient scope. If the bug+                    -- regresses, the drain exception will tear this scope+                    -- down and the sibling will be cancelled before it can+                    -- flip the ref.+                    sibling <- Conc.fork do+                        Delay.wait (50 :: Millisecond)+                        liftIO (writeIORef siblingDoneRef True)+                    -- Drive 'execGhci' on a dead process; the drains should+                    -- raise 'UnexpectedExit', which 'trySync' must catch+                    -- here rather than letting Ki tear down the scope.+                    execResult <- trySync (execGhci gp "cmd" (\_ -> pure ()))+                    -- Wait for the sibling to run.+                    Conc.await sibling+                    pure execResult+        -- stopProcess flushes the buffered command+marker to a pipe whose+        -- read end is already closed, which raises ResourceVanished. The+        -- subprocess has long since exited; just swallow the cleanup error.+        _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())+        siblingDone <- readIORef siblingDoneRef+        siblingDone `shouldBe` True+        case result of+            Left _ -> pure ()+            Right _ -> expectationFailure "expected execGhci to raise UnexpectedExit"
+ test/Unit/Tricorder/Effects/GhciSessionSpec.hs view
@@ -0,0 +1,122 @@+module Unit.Tricorder.Effects.GhciSessionSpec (spec_GhciSession) where++import Control.Exception (ErrorCall (..))+import Effectful (IOE, runEff)+import Effectful.Exception (try)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.BuildState (Diagnostic (..), Severity (..))+import Tricorder.Effects.GhciSession (Controls (..), GhciSession, LoadResult (..), runGhciSessionScripted, withGhci)+import Tricorder.Runtime (ProjectRoot (..))+++spec_GhciSession :: Spec+spec_GhciSession = do+    describe "runGhciSessionScripted" testScripted+++--------------------------------------------------------------------------------+-- Scripted interpreter tests+--------------------------------------------------------------------------------++testScripted :: Spec+testScripted = do+    describe "withGhci" do+        describe "initial load" do+            it "returns scripted messages" do+                LoadResult {diagnostics = msgs} <-+                    runScripted [simpleResult [errMsg]]+                        $ withGhci "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+                msgs `shouldBe` []++            it "throws when scripted result is Left" do+                result <-+                    runScripted [Left (toException boom)]+                        $ try @ErrorCall+                        $ withGhci "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+                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+                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+                    LoadResult {diagnostics = b} <- controls.reload+                    pure (a, b)+            a `shouldBe` [errMsg]+            b `shouldBe` [warnMsg]++        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+                pure (r1, r2)+            fst result `shouldSatisfy` isLeft+            snd result `shouldBe` []+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++boom :: ErrorCall+boom = ErrorCall "simulated GHCi crash"+++errMsg :: Diagnostic+errMsg =+    Diagnostic+        { severity = SError+        , file = "src/Foo.hs"+        , line = 1+        , col = 1+        , endLine = 1+        , endCol = 5+        , title = "Variable not in scope: foo"+        , text = "Variable not in scope: foo"+        }+++warnMsg :: Diagnostic+warnMsg =+    Diagnostic+        { severity = SWarning+        , file = "src/Bar.hs"+        , line = 10+        , col = 3+        , endLine = 10+        , endCol = 8+        , title = "Unused import"+        , text = "Unused import"+        }+++-- | Convenience constructor: a scripted result with no compiled-file info.+simpleResult :: [Diagnostic] -> Either SomeException LoadResult+simpleResult msgs = Right LoadResult {moduleCount = 0, compiledFiles = Set.empty, loadedModules = Map.empty, targetNames = [], diagnostics = msgs}+++runScripted :: [Either SomeException LoadResult] -> Eff '[GhciSession, IOE] a -> IO a+runScripted results = runEff . runGhciSessionScripted results
+ test/Unit/Tricorder/Effects/SessionStoreSpec.hs view
@@ -0,0 +1,162 @@+module Unit.Tricorder.Effects.SessionStoreSpec (spec_SessionStore) where++import Atelier.Effects.Chan (Chan, runChan)+import Atelier.Effects.Clock (Clock, runClockConst)+import Atelier.Effects.Conc (Conc, runConc)+import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp)+import Atelier.Effects.Publishing (Pub, Sub, publish, runPubSub)+import Control.Concurrent (threadDelay)+import Data.Default (def)+import Data.IORef (IORef)+import Data.Time (UTCTime (..), fromGregorian)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, runErrorNoCallStack, throwError)+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.IORef qualified as IORef++import Tricorder.Effects.SessionStore+    ( ActiveSession (..)+    , SessionStore (..)+    , SessionStoreReloaded (..)+    , runSessionStoreConst+    , withSession+    )+import Tricorder.Session (Session (..))++import Tricorder.Effects.SessionStore qualified as SessionStore+++spec_SessionStore :: Spec+spec_SessionStore = do+    describe "withSession" testWithSession+++testWithSession :: Spec+testWithSession = do+    it "calls the action with the current session" do+        cmdRef <- IORef.newIORef Nothing+        _ <- runFixed session1 do+            withSession \active -> do+                liftIO $ IORef.writeIORef cmdRef (Just active.session.command)+                throwError StopSignal+        result <- IORef.readIORef cmdRef+        result `shouldBe` Just session1.command++    it "provides a reloader that calls rawReload" do+        reloadedRef <- IORef.newIORef False+        _ <- runFlagged reloadedRef do+            withSession \active -> do+                active.reloader.reload+                throwError StopSignal+        reloaded <- IORef.readIORef reloadedRef+        reloaded `shouldBe` True++    it "restarts with the new session when reloaded" do+        sessionsRef <- IORef.newIORef []+        sessionRef <- IORef.newIORef session1+        callCount <- IORef.newIORef (0 :: Int)+        _ <- runMutable sessionRef do+            withSession \active -> do+                liftIO $ IORef.modifyIORef' sessionsRef (active.session.command :)+                n <- liftIO $ IORef.atomicModifyIORef' callCount (\x -> (x + 1, x + 1))+                if n == 1 then do+                    -- Give withSession time to call listenOnce_ before we publish.+                    liftIO $ threadDelay 1_000+                    liftIO $ IORef.writeIORef sessionRef session2+                    publish (SessionStoreReloaded session2)+                else+                    throwError StopSignal+        sessions <- reverse <$> IORef.readIORef sessionsRef+        sessions `shouldBe` [session1.command, session2.command]+++--------------------------------------------------------------------------------+-- Effect stack+--------------------------------------------------------------------------------++data StopSignal = StopSignal+    deriving stock (Show)+++type TestEs =+    '[ Conc+     , Error StopSignal+     , Pub SessionStoreReloaded+     , Sub SessionStoreReloaded+     , SessionStore+     , Chan+     , Clock+     , Tracing+     , Concurrent+     , IOE+     ]+++runFixed :: Session -> Eff TestEs a -> IO (Either StopSignal a)+runFixed session =+    runEff+        . runConcurrent+        . runTracingNoOp+        . runClockConst epoch+        . runChan+        . runSessionStoreConst session+        . runPubSub @SessionStoreReloaded+        . runErrorNoCallStack @StopSignal+        . runConc+++runFlagged :: IORef Bool -> Eff TestEs a -> IO (Either StopSignal a)+runFlagged flag =+    runEff+        . runConcurrent+        . runTracingNoOp+        . runClockConst epoch+        . runChan+        . runSessionStoreFlagged flag+        . runPubSub @SessionStoreReloaded+        . runErrorNoCallStack @StopSignal+        . runConc+++runMutable :: IORef Session -> Eff TestEs a -> IO (Either StopSignal a)+runMutable ref =+    runEff+        . runConcurrent+        . runTracingNoOp+        . runClockConst epoch+        . runChan+        . runSessionStoreMutable ref+        . runPubSub @SessionStoreReloaded+        . runErrorNoCallStack @StopSignal+        . runConc+++runSessionStoreFlagged :: (IOE :> es) => IORef Bool -> Eff (SessionStore : es) a -> Eff es a+runSessionStoreFlagged flag = interpret_ \case+    Get -> pure session1+    RawReload -> liftIO $ IORef.writeIORef flag True+++runSessionStoreMutable :: (IOE :> es) => IORef Session -> Eff (SessionStore : es) a -> Eff es a+runSessionStoreMutable ref = interpret_ \case+    Get -> liftIO $ IORef.readIORef ref+    RawReload -> pure ()+++--------------------------------------------------------------------------------+-- Fixtures+--------------------------------------------------------------------------------++session1 :: Session+session1 = def {command = "session-1"}+++session2 :: Session+session2 = def {command = "session-2"}+++epoch :: UTCTime+epoch = UTCTime (fromGregorian 1970 1 1) 0
+ test/Unit/Tricorder/GhcPkgSpec.hs view
@@ -0,0 +1,49 @@+module Unit.Tricorder.GhcPkgSpec (spec_GhcPkg) where++import Effectful (runPureEff)+import Test.Hspec++import Tricorder.Effects.GhcPkg (GhcPkg, GhcPkgScript (..), findModule, getHaddockHtml, runGhcPkgScripted)+++spec_GhcPkg :: Spec+spec_GhcPkg = do+    describe "findModule" testFindModule+    describe "getHaddockHtml" testGetHaddockHtml+++testFindModule :: Spec+testFindModule = do+    it "returns Just pkgId when module is known" do+        let result = runScripted [NextFindModule (Just "base-4.18")] $ findModule "Prelude"+        result `shouldBe` Just "base-4.18"++    it "returns Nothing for an unknown module" do+        let result = runScripted [NextFindModule Nothing] $ findModule "No.Such.Module"+        result `shouldBe` Nothing++    it "returns the first scripted result" do+        let result = runScripted [NextFindModule (Just "pkg-1.0"), NextFindModule (Just "pkg-2.0")] $ findModule "Foo"+        result `shouldBe` Just "pkg-1.0"+++testGetHaddockHtml :: Spec+testGetHaddockHtml = do+    it "returns Just path when haddock-html is set" do+        let result = runScripted [NextGetHaddockHtml (Just "/nix/store/abc/share/doc/html")] $ getHaddockHtml "base-4.18"+        result `shouldBe` Just "/nix/store/abc/share/doc/html"++    it "returns Nothing when haddock-html is not set" do+        let result = runScripted [NextGetHaddockHtml Nothing] $ getHaddockHtml "base-4.18"+        result `shouldBe` Nothing++    it "returns the first scripted result" do+        let result =+                runScripted+                    [NextGetHaddockHtml (Just "/path/one"), NextGetHaddockHtml (Just "/path/two")]+                    $ getHaddockHtml "pkg-1.0"+        result `shouldBe` Just "/path/one"+++runScripted :: [GhcPkgScript] -> Eff '[GhcPkg] a -> a+runScripted script = runPureEff . runGhcPkgScripted script
+ test/Unit/Tricorder/SessionSpec.hs view
@@ -0,0 +1,365 @@+module Unit.Tricorder.SessionSpec (spec_Session) where++import Atelier.Effects.FileSystem (runFileSystemState)+import Atelier.Effects.Log (runLogNoOp)+import Data.Default (Default (..))+import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)+import Effectful (runPureEff)+import Effectful.State.Static.Shared (evalState)+import Test.Hspec++import Data.Map.Strict qualified as Map+import Data.Text qualified as T++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session+    ( Config (..)+    , allComponentTargets+    , discoverCabalFiles+    , resolveCommand+    , resolveTargets+    , resolveTestTargets+    , resolveWatchDirs+    , sourceDirsForTarget+    )+++spec_Session :: Spec+spec_Session = do+    describe "resolveCommand" testResolveCommand+    describe "discoverCabalFiles" testDiscoverCabalFiles+    describe "resolveTargets" testResolveTargets+    describe "resolveWatchDirs" testResolveWatchDirs+    describe "resolveTestTargets" testResolveTestTargets+    describe "sourceDirsForTarget" testSourceDirsForTarget+    describe "allComponentTargets" testAllComponentTargets+++testSourceDirsForTarget :: Spec+testSourceDirsForTarget = do+    describe "lib:" do+        it "returns main library source dirs" do+            sourceDirsForTarget gpd "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"]++    describe "lib:<sub-library>" do+        it "returns sub-library source dirs" do+            sourceDirsForTarget gpd "lib:myapp-utils" `shouldBe` ["utils"]++        it "returns empty list for unknown sub-library" do+            sourceDirsForTarget gpd "lib:nonexistent" `shouldBe` []++    describe "exe:<name>" do+        it "returns executable source dirs" do+            sourceDirsForTarget gpd "exe:myapp-exe" `shouldBe` ["app"]++    describe "test:<name>" do+        it "returns test suite source dirs" do+            sourceDirsForTarget gpd "test:myapp-test" `shouldBe` ["test"]++    describe "unknown target" do+        it "returns empty list" do+            sourceDirsForTarget gpd "unknown" `shouldBe` []+++testAllComponentTargets :: Spec+testAllComponentTargets = do+    it "includes the main library as lib:<package-name>" do+        allComponentTargets gpd `shouldContain` ["lib:myapp"]++    it "includes sub-libraries" do+        allComponentTargets gpd `shouldContain` ["lib:myapp-utils"]++    it "includes executables" do+        allComponentTargets gpd `shouldContain` ["exe:myapp-exe"]++    it "includes test suites" do+        allComponentTargets gpd `shouldContain` ["test:myapp-test"]++    it "returns all four components for the fixture" do+        allComponentTargets gpd+            `shouldBe` ["lib:myapp", "lib:myapp-utils", "exe:myapp-exe", "test:myapp-test"]+++-- | Pins the discovery contract: a @cabal.project@ selects per-package+-- @.cabal@ files from its @packages:@ stanza; otherwise the @.cabal@ files in+-- the project root are used.+testDiscoverCabalFiles :: Spec+testDiscoverCabalFiles = do+    describe "when there is no cabal.project" do+        it "finds the .cabal files in the project root" do+            let actual =+                    runDiscovery (Map.singleton "/myapp.cabal" cabalFixture)+                        $ discoverCabalFiles pr+            actual `shouldBe` ["/myapp.cabal"]++        it "returns no files when the root has no cabal file" do+            let actual = runDiscovery mempty $ discoverCabalFiles pr+            actual `shouldBe` []++    describe "when there is a multi-package cabal.project" do+        it "resolves each listed package to its .cabal (regression: was root-only)" do+            let actual = runDiscovery multiPackageFs $ discoverCabalFiles pr+            actual `shouldBe` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+  where+    pr = ProjectRoot "/"+    runDiscovery fs = runPureEff . evalState fs . runFileSystemState . runLogNoOp+++testResolveTargets :: Spec+testResolveTargets = do+    describe "when targets are configured" do+        it "returns configured targets as-is without reading any cabal file" do+            -- The cabal file is absent from the mock FS, so any attempt to read+            -- it would error; passing the test proves the early return.+            let actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveTargets ["/myapp.cabal"] ["lib:foo", "test:foo-test"]+            actual `shouldBe` ["lib:foo", "test:foo-test"]++    describe "when no targets are configured" do+        it "auto-detects all components from the cabal file" do+            let actual =+                    runPureEff+                        . evalState (Map.singleton "/myapp.cabal" cabalFixture)+                        . runFileSystemState+                        $ resolveTargets ["/myapp.cabal"] []+            actual+                `shouldBe` ["lib:myapp", "lib:myapp-utils", "exe:myapp-exe", "test:myapp-test"]++        it "surfaces test-suite components so they can be run after a build" do+            let actual =+                    runPureEff+                        . evalState (Map.singleton "/myapp.cabal" cabalFixture)+                        . runFileSystemState+                        $ resolveTargets ["/myapp.cabal"] []+            actual `shouldContain` ["test:myapp-test"]++        it "returns no targets when there are no cabal files" do+            let actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveTargets [] []+            actual `shouldBe` []++        it "aggregates components across every package (regression: was 0)" do+            let actual =+                    runPureEff+                        . 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"]+++testResolveWatchDirs :: Spec+testResolveWatchDirs = do+    describe "when watch_dirs is set in config" do+        it "uses config dirs relative to project root" do+            let actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveWatchDirs pr [] def {watchDirs = ["src", "test"]} []+            actual `shouldBe` ["/src", "/test"]++    describe "when watch_dirs is not set" do+        it "falls back to [\".\"] when targets list is empty" do+            let actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveWatchDirs pr [] def []+            actual `shouldBe` ["."]++        it "infers source dirs from resolved targets" do+            let actual =+                    runPureEff+                        . evalState (Map.singleton "/myapp.cabal" cabalFixture)+                        . runFileSystemState+                        $ resolveWatchDirs pr ["/myapp.cabal"] def ["lib:myapp", "test:myapp-test"]+            actual `shouldBe` ["/src", "/test"]++        it "falls back to [\".\"] when there are no cabal files" do+            let actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveWatchDirs pr [] def ["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 =+                    runPureEff+                        . evalState multiPackageFs+                        . runFileSystemState+                        $ resolveWatchDirs+                            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"]+            actual+                `shouldBe` ["/pkg-a/src", "/pkg-a/test", "/pkg-b/src", "/pkg-b/test"]+  where+    pr = ProjectRoot "/"+++testResolveTestTargets :: Spec+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"]++    it "returns empty list when no test: components in targets" do+        let cfg = def :: Config+        resolveTestTargets cfg ["lib:mylib", "exe:myapp"] `shouldBe` []++    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"]++    it "returns empty list when testTargets is explicitly empty" do+        let cfg = def {testTargets = Just []} :: Config+        resolveTestTargets cfg ["lib:a", "test:a-test"] `shouldBe` []++    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"]+++testResolveCommand :: Spec+testResolveCommand = do+    describe "when config has a command" do+        it "should use specified command" do+            let actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveCommand pr def {command = Just "foo"}+            actual `shouldBe` "foo"++    describe "when config does not have a command" do+        describe "and there is a cabal.project file" do+            it "should use cabal with --enable-multi-repl" do+                let actual =+                        runPureEff+                            . evalState (Map.singleton "/cabal.project" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg+                actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"++        describe "and there is at least one *.cabal file" do+            it "should use cabal with --enable-multi-repl" do+                let actual =+                        runPureEff+                            . evalState (Map.singleton "/foo.cabal" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg+                actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"+        describe "and there is a stack.yaml file" do+            it "should use stack ghci" do+                let actual =+                        runPureEff+                            . evalState (Map.singleton "/stack.yaml" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg+                actual `shouldBe` "stack ghci lib:foo"++        describe "but there are no project files" do+            it "should use default cabal repl" do+                let actual =+                        runPureEff+                            . evalState mempty+                            . runFileSystemState+                            $ resolveCommand pr cfg+                actual `shouldBe` "cabal repl --builddir /replbuild lib:foo"+  where+    pr = ProjectRoot "/"+    cfg = def {replBuildDir = "/replbuild", targets = ["lib:foo"]}+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++gpd :: GenericPackageDescription+gpd =+    fromMaybe (error "cabalFixture failed to parse")+        $ parseGenericPackageDescriptionMaybe cabalFixture+++-- | 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+multiPackageFs =+    Map.fromList+        [ ("/cabal.project", "packages:\n  pkg-a\n  pkg-b\n\ntests: True\n")+        , ("/pkg-a/pkg-a.cabal", libTestCabal "pkg-a")+        , ("/pkg-b/pkg-b.cabal", libTestCabal "pkg-b")+        ]+++-- | A minimal cabal file for @name@ with one library and one test suite+-- (@<name>-test@).+libTestCabal :: Text -> ByteString+libTestCabal name =+    encodeUtf8+        $ T.unlines+            [ "cabal-version: 2.0"+            , "name:          " <> name+            , "version:       0.1.0.0"+            , "build-type:    Simple"+            , ""+            , "library"+            , "  hs-source-dirs: src"+            , "  build-depends: base"+            , "  default-language: Haskell2010"+            , ""+            , "test-suite " <> name <> "-test"+            , "  type: exitcode-stdio-1.0"+            , "  main-is: Test.hs"+            , "  hs-source-dirs: test"+            , "  build-depends: base"+            , "  default-language: Haskell2010"+            ]+++cabalFixture :: ByteString+cabalFixture =+    "cabal-version: 2.0\n\+    \name:          myapp\n\+    \version:       0.1.0.0\n\+    \build-type:    Simple\n\+    \\n\+    \library\n\+    \  hs-source-dirs: src\n\+    \  build-depends: base\n\+    \  default-language: Haskell2010\n\+    \\n\+    \library myapp-utils\n\+    \  hs-source-dirs: utils\n\+    \  build-depends: base\n\+    \  default-language: Haskell2010\n\+    \\n\+    \executable myapp-exe\n\+    \  main-is: Main.hs\n\+    \  hs-source-dirs: app\n\+    \  build-depends: base\n\+    \  default-language: Haskell2010\n\+    \\n\+    \test-suite myapp-test\n\+    \  type: exitcode-stdio-1.0\n\+    \  main-is: Test.hs\n\+    \  hs-source-dirs: test\n\+    \  build-depends: base\n\+    \  default-language: Haskell2010\n"
+ test/Unit/Tricorder/SocketSpec.hs view
@@ -0,0 +1,63 @@+module Unit.Tricorder.SocketSpec (spec_Socket) where++import Atelier.Effects.File (File, runFile)+import Effectful (IOE, runEff)+import System.IO (hClose, hGetLine, openFile, writeFile)+import Test.Hspec++import Tricorder.Effects.UnixSocket+    ( SocketScript (..)+    , UnixSocket+    , acceptHandle+    , bindSocket+    , removeSocketFile+    , runUnixSocketScripted+    , socketFileExists+    )+++spec_Socket :: Spec+spec_Socket = do+    describe "runUnixSocketScripted" testScripted+++--------------------------------------------------------------------------------+-- Scripted interpreter tests+--------------------------------------------------------------------------------++testScripted :: Spec+testScripted = do+    describe "socketFileExists" do+        it "returns True when scripted" do+            result <- runScripted [NextFileCheck True] $ socketFileExists "/"+            result `shouldBe` True++        it "returns False when scripted" do+            result <- runScripted [NextFileCheck False] $ socketFileExists "/"+            result `shouldBe` False++    describe "removeSocketFile" do+        it "is always a no-op" do+            -- No NextFileCheck/NextAccept needed; just returns ()+            runScripted [] $ removeSocketFile "/nonexistent/path"++    describe "acceptHandle" do+        it "returns the scripted handle, readable from a file" do+            let tmpPath = "/tmp/tricorder-socket-accept-test.txt"+            writeFile tmpPath "hello from test\n"+            h <- liftIO $ openFile tmpPath ReadMode+            line <- runScripted [NextAccept h] $ do+                sock <- bindSocket "/"+                h' <- acceptHandle sock+                liftIO $ hGetLine h'+            liftIO $ hClose h+            line `shouldBe` "hello from test"+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++-- | Run scripted socket operations (no Delay needed).+runScripted :: [SocketScript] -> Eff '[UnixSocket, File, IOE] a -> IO a+runScripted script = runEff . runFile . runUnixSocketScripted script
+ test/Unit/Tricorder/SourceLookupSpec.hs view
@@ -0,0 +1,139 @@+module Unit.Tricorder.SourceLookupSpec (spec_SourceLookup) where++import Atelier.Effects.Cache (Cache, runCacheForever)+import Atelier.Effects.FileSystem (FileSystem (..))+import Atelier.Effects.Log (Log, runLogNoOp)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Dispatch.Dynamic (interpret_)+import Test.Hspec++import Data.Map.Strict qualified as Map++import Tricorder.Effects.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted)+import Tricorder.GhcPkg.Types (ModuleName, PackageId, SourceQuery (..))+import Tricorder.SourceLookup (ModuleSourceResult (..), ReExport, lookupModuleSource)+++spec_SourceLookup :: Spec+spec_SourceLookup = do+    describe "lookupModuleSource" testLookupModuleSource+++testLookupModuleSource :: Spec+testLookupModuleSource = do+    it "returns SourceFound when module, haddock-html, and file are present" do+        result <-+            runTest+                [ NextFindModule (Just "pkg-1.0")+                , NextGetHaddockHtml (Just "/haddock/pkg")+                ]+                (Map.singleton "/haddock/pkg/src/Foo.html" sampleHtml)+                (lookupModuleSource (wholeModule "Foo"))+        result `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" []++    it "returns SourceFound on second call without re-querying GhcPkg (cache hit)" do+        -- Only one NextFindModule and one NextGetHaddockHtml in the script.+        -- The second call must come entirely from cache (no script pop).+        (r1, r2) <- runTest+            [ NextFindModule (Just "pkg-1.0")+            , NextGetHaddockHtml (Just "/haddock/pkg")+            ]+            (Map.singleton "/haddock/pkg/src/Foo.html" sampleHtml)+            $ do+                r1 <- lookupModuleSource (wholeModule "Foo")+                r2 <- lookupModuleSource (wholeModule "Foo")+                pure (r1, r2)+        r1 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" []+        r2 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" []++    it "returns SourceNotFound when findModule returns Nothing" do+        result <-+            runTest+                [NextFindModule Nothing]+                Map.empty+                (lookupModuleSource (wholeModule "Unknown"))+        result `shouldBe` SourceNotFound (wholeModule "Unknown")++    it "returns SourceNoHaddock when getHaddockHtml returns Nothing" do+        result <-+            runTest+                [ NextFindModule (Just "no-docs-1.0")+                , NextGetHaddockHtml Nothing+                ]+                Map.empty+                (lookupModuleSource (wholeModule "Foo"))+        result `shouldBe` SourceNoHaddock (wholeModule "Foo") "no-docs-1.0"++    it "returns SourceNoHaddock when the html file does not exist" do+        result <-+            runTest+                [ NextFindModule (Just "pkg-1.0")+                , NextGetHaddockHtml (Just "/haddock/pkg")+                ]+                Map.empty+                (lookupModuleSource (wholeModule "Foo"))+        result `shouldBe` SourceNoHaddock (wholeModule "Foo") "pkg-1.0"++    it "handles two different module names independently" do+        (r1, r2) <- runTest+            [ NextFindModule (Just "pkg-a-1.0")+            , NextGetHaddockHtml (Just "/haddock/pkg-a")+            , NextFindModule (Just "pkg-b-1.0")+            , NextGetHaddockHtml (Just "/haddock/pkg-b")+            ]+            ( Map.fromList+                [ ("/haddock/pkg-a/src/Foo.html", sampleHtml)+                , ("/haddock/pkg-b/src/Bar.html", barHtml)+                ]+            )+            $ do+                r1 <- lookupModuleSource (wholeModule "Foo")+                r2 <- lookupModuleSource (wholeModule "Bar")+                pure (r1, r2)+        r1 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" []+        r2 `shouldBe` SourceFound (wholeModule "Bar") "module Bar where" []+++--------------------------------------------------------------------------------+-- Fixtures+--------------------------------------------------------------------------------++sampleHtml :: LByteString+sampleHtml = "<html><body><pre id=\"src\"><span>module</span> Foo <span>where</span></pre></body></html>"+++barHtml :: LByteString+barHtml = "<html><body><pre id=\"src\"><span>module</span> Bar <span>where</span></pre></body></html>"+++-- | Helper: a whole-module query (no function filter).+wholeModule :: ModuleName -> SourceQuery+wholeModule m = SourceQuery {moduleName = m, function = Nothing}+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++runFileSystemScripted :: Map FilePath LByteString -> Eff (FileSystem : es) a -> Eff es a+runFileSystemScripted files = interpret_ \case+    DoesFileExist path -> pure $ Map.member path files+    ReadFileLbsFrom path _ -> pure $ fromMaybe "" (Map.lookup path files)+    _ -> error "FileSystemScripted: unexpected operation"+++runTest+    :: [GhcPkgScript]+    -> Map FilePath LByteString+    -> Eff '[Cache ModuleName PackageId, Cache (PackageId, SourceQuery) (Text, [ReExport]), FileSystem, GhcPkg, Log, Concurrent, IOE] a+    -> IO a+runTest pkgScript files action =+    runEff+        . runConcurrent+        . runLogNoOp+        . runGhcPkgScripted pkgScript+        . runFileSystemScripted files+        . runCacheForever @(PackageId, SourceQuery) @(Text, [ReExport])+        . runCacheForever @ModuleName @PackageId+        $ action
+ test/Unit/Tricorder/SourceSpec.hs view
@@ -0,0 +1,161 @@+module Unit.Tricorder.SourceSpec (spec_Source) where++import Test.Hspec++import Tricorder.SourceLookup (extractFunctionSource, extractSource, stripAnnotations, stripTags, unescapeEntities)+++spec_Source :: Spec+spec_Source = do+    describe "extractSource" testExtractSource+    describe "extractFunctionSource" testExtractFunctionSource+    describe "stripAnnotations" testStripAnnotations+    describe "stripTags" testStripTags+    describe "unescapeEntities" testUnescapeEntities+++testExtractSource :: Spec+testExtractSource = do+    it "returns content between <pre id=\"src\"> and </pre>, stripped and unescaped" do+        let html = "<html><body><pre id=\"src\"><span>module</span> Foo <span>where</span></pre></body></html>"+        extractSource html `shouldBe` "module Foo where"++    it "strips tags inside the pre block" do+        let html = "<pre id=\"src\"><a href=\"x\">foo</a> <b>bar</b></pre>"+        extractSource html `shouldBe` "foo bar"++    it "unescapes entities inside the pre block" do+        let html = "<pre id=\"src\">&lt;Type&gt; &amp; &quot;val&quot;</pre>"+        extractSource html `shouldBe` "<Type> & \"val\""++    it "falls back to stripping the whole file when no <pre> block is present" do+        let html = "<html><body><p>hello &amp; world</p></body></html>"+        extractSource html `shouldBe` "hello & world"++    -- Regression: some Haddock versions emit <pre> with no id attribute.+    -- extractSource must still strip annottext spans in that case.+    it "strips annottext spans from a <pre> block without an id attribute" do+        let html =+                "<html><body><pre>"+                    <> "<span id=\"line-1\"></span>"+                    <> "<span class=\"annot\"><span class=\"annottext\">foo :: Int\n</span>"+                    <> "<span class=\"hs-identifier hs-var\">foo</span></span>"+                    <> " = "+                    <> "<span class=\"annot\"><span class=\"annottext\">Int\n</span>"+                    <> "<span class=\"hs-number\">42</span></span>\n"+                    <> "</pre></body></html>"+        extractSource html `shouldBe` "foo = 42\n"+++testExtractFunctionSource :: Spec+testExtractFunctionSource = do+    it "extracts the type signature and body of a named function" do+        extractFunctionSource "bar" sampleHtml+            `shouldBe` Just "bar :: Int\nbar = 42\n"++    it "stops at blank lines and does not include adjacent functions" do+        let result = toString $ fromMaybe "" (extractFunctionSource "bar" sampleHtml)+        result `shouldNotContain` "other"++    it "does not leak line-number prefixes (N\"> regression)" do+        -- Before the fix, output contained fragments like '45">{-' from the+        -- raw line-span remainder after splitting on <span id="line-".+        let result = toString $ fromMaybe "" (extractFunctionSource "bar" sampleHtml)+        result `shouldNotContain` "\">"++    it "returns Nothing for an unknown function name" do+        extractFunctionSource "unknown" sampleHtml `shouldBe` Nothing++    -- Regression: some Haddock versions emit <pre> with no id attribute.+    it "works when <pre> has no id attribute" do+        let noIdHtml =+                "<pre>"+                    <> "<span id=\"line-1\"></span>bar :: Int\n"+                    <> "<span id=\"line-2\"></span><span id=\"bar\">bar</span> = 42\n"+                    <> "</pre>"+        extractFunctionSource "bar" noIdHtml `shouldBe` Just "bar :: Int\nbar = 42\n"+  where+    -- Minimal Haddock-style source HTML with two functions separated by a blank line.+    sampleHtml =+        "<pre id=\"src\">"+            <> "<span id=\"line-1\"></span>other :: Bool\n"+            <> "<span id=\"line-2\"></span><span id=\"other\">other</span> = True\n"+            <> "<span id=\"line-3\"></span>\n"+            <> "<span id=\"line-4\"></span>bar :: Int\n"+            <> "<span id=\"line-5\"></span><span id=\"bar\">bar</span> = 42\n"+            <> "<span id=\"line-6\"></span>\n"+            <> "</pre>"+++testStripAnnotations :: Spec+testStripAnnotations = do+    it "removes an annottext span and its content" do+        stripAnnotations "<span class=\"annottext\">foo :: Int\n</span>bar"+            `shouldBe` "bar"++    it "removes multiple annottext spans" do+        stripAnnotations "a<span class=\"annottext\">X</span>b<span class=\"annottext\">Y</span>c"+            `shouldBe` "abc"++    it "leaves other spans untouched" do+        stripAnnotations "<span class=\"hs-keyword\">module</span>"+            `shouldBe` "<span class=\"hs-keyword\">module</span>"++    it "handles text with no annotations unchanged" do+        stripAnnotations "plain text" `shouldBe` "plain text"++    -- Regression: Haddock emits elaborated types inside annottext that were+    -- leaking into output, e.g. 'universe :: forall a. ...' appearing as a+    -- second type signature, and 'forall a. Bounded a => a' appearing inside+    -- the body of expressions like '[minBound .. maxBound]'.+    it "strips elaborated type annotations from a realistic Haddock snippet" do+        let snippet =+                "<span class=\"annot\">"+                    <> "<span class=\"annottext\">universe :: forall a. (Bounded a, Enum a) =&gt; [a]\n</span>"+                    <> "<a href=\"Relude.Enum.html#universe\">"+                    <> "<span class=\"hs-identifier hs-var\">universe</span>"+                    <> "</a></span>"+                    <> " = [minBound .. maxBound]"+        stripAnnotations snippet+            `shouldBe` "<span class=\"annot\"><a href=\"Relude.Enum.html#universe\"><span class=\"hs-identifier hs-var\">universe</span></a></span> = [minBound .. maxBound]"+++testStripTags :: Spec+testStripTags = do+    it "removes a single tag" do+        stripTags "<span>hello</span>" `shouldBe` "hello"++    it "removes nested and adjacent tags" do+        stripTags "<a><b>inner</b></a><em>after</em>" `shouldBe` "innerafter"++    it "leaves plain text untouched" do+        stripTags "plain text" `shouldBe` "plain text"++    it "handles a tag at the very end with no trailing >" do+        -- A truncated tag with no closing '>' — everything after '<' is consumed+        stripTags "text<unclosed" `shouldBe` "text"+++testUnescapeEntities :: Spec+testUnescapeEntities = do+    it "replaces &lt;" do+        unescapeEntities "&lt;" `shouldBe` "<"++    it "replaces &gt;" do+        unescapeEntities "&gt;" `shouldBe` ">"++    it "replaces &amp;" do+        unescapeEntities "&amp;" `shouldBe` "&"++    it "replaces &#39;" do+        unescapeEntities "&#39;" `shouldBe` "'"++    it "replaces &quot;" do+        unescapeEntities "&quot;" `shouldBe` "\""++    it "replaces all five entities in one string" do+        unescapeEntities "&lt;a&gt; &amp; &#39;b&#39; &quot;c&quot;"+            `shouldBe` "<a> & 'b' \"c\""++    it "leaves unrecognised entities alone" do+        unescapeEntities "&nbsp;&mdash;" `shouldBe` "&nbsp;&mdash;"
+ test/Unit/Tricorder/TestOutputSpec.hs view
@@ -0,0 +1,187 @@+module Unit.Tricorder.TestOutputSpec (spec_TestOutput) where++import Test.Hspec++import Tricorder.BuildState (TestCase (..), TestCaseOutcome (..))+import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput, stripGhciNoise)+++spec_TestOutput :: Spec+spec_TestOutput = do+    describe "parseHspecOutput" do+        it "returns empty list for empty output" do+            parseHspecOutput "" `shouldBe` []++        it "parses a passing test" do+            let output = "  foo\n    bar baz:                                      OK\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "bar baz:", outcome = TestCasePassed}]++        it "parses a failing test" do+            let output = "  foo\n    bar baz:                                      FAIL\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "bar baz:", outcome = TestCaseFailed ""}]++        it "captures failure details" do+            let output =+                    "    a test:                                            FAIL\n"+                        <> "      expected: 1\n"+                        <> "       but got: 2\n"+                        <> "    another test:                                       OK\n"+            parseHspecOutput output+                `shouldBe` [ TestCase+                                { description = "a test:"+                                , outcome = TestCaseFailed "expected: 1\nbut got: 2"+                                }+                           , TestCase {description = "another test:", outcome = TestCasePassed}+                           ]++        it "stops collecting details when indentation returns to test level" do+            let output =+                    "    failing:                                           FAIL\n"+                        <> "      detail line\n"+                        <> "    passing:                                          OK\n"+            let cases = parseHspecOutput output+            length cases `shouldBe` 2+            case cases of+                (c : _) -> c.outcome `shouldBe` TestCaseFailed "detail line"+                [] -> expectationFailure "expected at least one test case"++        it "skips group header lines" do+            let output =+                    "  MyModule\n"+                        <> "    someFunction\n"+                        <> "      does the thing:                                  OK\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "does the thing:", outcome = TestCasePassed}]++        it "parses mixed passing and failing tests" do+            let output =+                    "  Suite\n"+                        <> "    passes:                                            OK\n"+                        <> "    fails:                                             FAIL\n"+                        <> "      reason\n"+                        <> "    also passes:                                       OK\n"+            parseHspecOutput output+                `shouldBe` [ TestCase {description = "passes:", outcome = TestCasePassed}+                           , TestCase {description = "fails:", outcome = TestCaseFailed "reason"}+                           , TestCase {description = "also passes:", outcome = TestCasePassed}+                           ]++        it "parses a passing test with a timing annotation" do+            let output = "  slow test:                                          OK (0.05s)\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "slow test:", outcome = TestCasePassed}]++        it "parses a passing test with a millisecond annotation" do+            let output = "  fast property:                                      OK (12ms)\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "fast property:", outcome = TestCasePassed}]++        it "parses a failing test with a timing annotation" do+            let output = "  slow fail:                                          FAIL (0.03s)\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "slow fail:", outcome = TestCaseFailed ""}]++        it "does not strip a non-timing parenthetical in the description" do+            let output = "  test (corner case):                                 OK\n"+            parseHspecOutput output+                `shouldBe` [TestCase {description = "test (corner case):", outcome = TestCasePassed}]++    describe "parseHspecDuration" do+        it "returns Nothing for empty output" do+            parseHspecDuration "" `shouldBe` Nothing++        it "returns Nothing when no timing line is present" do+            parseHspecDuration "2 examples, 0 failures\n" `shouldBe` Nothing++        it "parses duration from passing summary line" do+            parseHspecDuration "All 177 tests passed (0.05s)\n"+                `shouldBe` Just 50++        it "parses duration from failing summary line" do+            parseHspecDuration "1 out of 177 tests failed (0.06s)\n"+                `shouldBe` Just 60++        it "does not match indented individual test timing lines" do+            parseHspecDuration "      entry is evicted after cleanup thread fires past TTL:  OK (0.05s)\n"+                `shouldBe` Nothing++        it "parses duration embedded in full hspec output" do+            let output =+                    "  Suite\n"+                        <> "    passes:                                          OK\n"+                        <> "    slow test:                                       OK (0.05s)\n"+                        <> "\n"+                        <> "All 2 tests passed (0.5s)\n"+            parseHspecDuration output `shouldBe` Just 500++    describe "stripGhciNoise" do+        it "passes through empty list" do+            stripGhciNoise [] `shouldBe` []++        it "passes through output with no ghci prompt" do+            let ls = ["line one", "line two", "line three"]+            stripGhciNoise ls `shouldBe` ls++        it "strips cabal build preamble" do+            let ls =+                    [ "Resolving dependencies..."+                    , "Build profile: -w ghc-9.6.3 -O1"+                    , "ghci> :reload"+                    , "  test one:                                          OK"+                    , "  test two:                                          OK"+                    ]+            stripGhciNoise ls+                `shouldBe` [ "  test one:                                          OK"+                           , "  test two:                                          OK"+                           ]++        it "strips trailing ghci prompt" do+            let ls =+                    [ "ghci> :reload"+                    , "  a test:                                            OK"+                    , "ghci> "+                    ]+            stripGhciNoise ls `shouldBe` ["  a test:                                            OK"]++        it "strips trailing \"Leaving GHCi.\" line" do+            let ls =+                    [ "ghci> :reload"+                    , "  a test:                                            OK"+                    , "Leaving GHCi."+                    ]+            stripGhciNoise ls `shouldBe` ["  a test:                                            OK"]++        it "strips trailing \"*** Exception: ...\" lines" do+            let ls =+                    [ "ghci> :reload"+                    , "  a test:                                            OK"+                    , "*** Exception: ExitSuccess"+                    ]+            stripGhciNoise ls `shouldBe` ["  a test:                                            OK"]++        it "full round-trip strips build noise, keeps test output" do+            let ls =+                    [ "Resolving dependencies..."+                    , "Build profile: -w ghc-9.6.3 -O1"+                    , "Preprocessing test suite 'spec' for tricorder-0.1.0.0..."+                    , "ghci> :reload"+                    , "  Suite"+                    , "    passes:                                          OK"+                    , "    fails:                                           FAIL"+                    , "      some detail"+                    , ""+                    , "Finished in 0.0001 seconds"+                    , "ghci> "+                    , "Leaving GHCi."+                    , "*** Exception: ExitFailure 1"+                    ]+            stripGhciNoise ls+                `shouldBe` [ "  Suite"+                           , "    passes:                                          OK"+                           , "    fails:                                           FAIL"+                           , "      some detail"+                           , ""+                           , "Finished in 0.0001 seconds"+                           ]
+ test/Unit/Tricorder/TestRunnerSpec.hs view
@@ -0,0 +1,319 @@+module Unit.Tricorder.TestRunnerSpec (spec_TestRunner) where++import Atelier.Effects.Clock (runClockConst)+import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.Input (runInputConst)+import Atelier.Effects.Log (runLogNoOp)+import Control.Concurrent.STM (newTVarIO, writeTVar)+import Control.Exception (ErrorCall (..))+import Data.Time (UTCTime (..), fromGregorian)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Concurrent.STM (atomically)+import Effectful.Exception (try)+import Effectful.Reader.Static (runReader)+import Effectful.State.Static.Shared (evalState)+import Test.Hspec++import Tricorder.BuildState+    ( BuildId (..)+    , BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , BuildState (..)+    , DaemonInfo (..)+    , TestRun (..)+    , TestRunCompletion (..)+    )+import Tricorder.Effects.BuildStore (getState)+import Tricorder.Effects.GhciSession.GhciParser (GhciLoading (..))+import Tricorder.Effects.TestRunner+    ( GhciOutcome (..)+    , TestRunner+    , abortGatedProgress+    , detectOutcome+    , interruptCurrent+    , isAborted+    , resetAbort+    , runTestRunnerScripted+    , runTestSuite+    )+import Tricorder.Runtime (ProjectRoot (..))++import Tricorder.Effects.BuildStore qualified as BuildStore+++spec_TestRunner :: Spec+spec_TestRunner = do+    describe "detectOutcome" testDetectOutcome+    describe "runTestRunnerScripted" testScripted+    describe "abortGatedProgress" testAbortGatedProgress+++--------------------------------------------------------------------------------+-- detectOutcome tests+--------------------------------------------------------------------------------++testDetectOutcome :: Spec+testDetectOutcome = do+    describe "no exception line" do+        it "treats empty output as pass" do+            detectOutcome "" `shouldBe` GhciPassed++        it "treats output with no exception as pass" do+            detectOutcome "2 examples, 0 failures\n" `shouldBe` GhciPassed++        it "does not match 'ExitSuccess' without the exception prefix" do+            detectOutcome "ExitSuccess\n" `shouldBe` GhciPassed++    describe "ExitSuccess" do+        it "detects ExitSuccess as pass" do+            detectOutcome "*** Exception: ExitSuccess\n" `shouldBe` GhciPassed++        it "detects ExitSuccess anywhere in output" do+            detectOutcome "All tests passed\n*** Exception: ExitSuccess\n"+                `shouldBe` GhciPassed++    describe "ExitFailure" do+        it "detects ExitFailure 1 as fail" do+            detectOutcome "1 failure\n*** Exception: ExitFailure 1\n"+                `shouldBe` GhciFailed++        it "detects ExitFailure with any exit code as fail" do+            detectOutcome "*** Exception: ExitFailure 42\n" `shouldBe` GhciFailed++        it "detects ExitFailure anywhere in output" do+            detectOutcome "Some output\n*** Exception: ExitFailure 1\nMore output\n"+                `shouldBe` GhciFailed++    describe "other exception" do+        it "classifies unknown exception as error with message" do+            detectOutcome "*** Exception: SomeException \"oops\"\n"+                `shouldBe` GhciCrashed "SomeException \"oops\""++        it "trims trailing whitespace from the error message" do+            detectOutcome "*** Exception: Crashed  \n"+                `shouldBe` GhciCrashed "Crashed"++    describe "compile failure (no exception line, but GHC errors present)" do+        it "flags ':main not in scope' as crashed" do+            detectOutcome "<interactive>:1:1: error: [GHC-76037] Not in scope: 'main'\n"+                `shouldBe` GhciCrashed+                    "<interactive>:1:1: error: [GHC-76037] Not in scope: 'main'"++        it "flags a source-file compile error as crashed" do+            detectOutcome "src/Foo.hs:42:5: error: Variable not in scope: foo\n"+                `shouldBe` GhciCrashed "src/Foo.hs:42:5: error: Variable not in scope: foo"++        it "reports the first error line when multiple are present" do+            detectOutcome+                "src/Foo.hs:42:5: error: Variable not in scope: foo\nsrc/Bar.hs:10:1: error: Parse error\n"+                `shouldBe` GhciCrashed "src/Foo.hs:42:5: error: Variable not in scope: foo"++        it "prefers exit exception over compile-error heuristic when both appear" do+            -- A real failing run could plausibly mention 'error:' in its+            -- captured output (e.g. logged messages); the ExitFailure line+            -- still wins.+            detectOutcome "log: error: something happened\n*** Exception: ExitFailure 1\n"+                `shouldBe` GhciFailed+++--------------------------------------------------------------------------------+-- Scripted interpreter tests+--------------------------------------------------------------------------------++testScripted :: Spec+testScripted = do+    it "returns scripted TestRun" do+        result <- runScripted [Right passingRun] $ runTestSuite "test:foo"+        result `shouldBe` passingRun++    it "ignores the target name argument" do+        result <- runScripted [Right failingRun] $ runTestSuite "test:anything"+        result `shouldBe` failingRun++    it "throws when scripted result is Left" do+        result <-+            runScripted [Left (toException boom)]+                $ try @ErrorCall+                $ runTestSuite "test:foo"+        result `shouldBe` Left boom++    describe "sequencing" do+        it "consumes results in order across multiple calls" do+            (a, b) <- runScripted [Right passingRun, Right failingRun] do+                a <- runTestSuite "test:foo"+                b <- runTestSuite "test:bar"+                pure (a, b)+            a `shouldBe` passingRun+            b `shouldBe` failingRun++        it "recover scenario: error then success" do+            result <- runScripted [Left (toException boom), Right passingRun] do+                r1 <- try @ErrorCall $ runTestSuite "test:foo"+                r2 <- runTestSuite "test:bar"+                pure (r1, r2)+            fst result `shouldBe` Left boom+            snd result `shouldBe` passingRun++    describe "abort flag" do+        -- The scripted interpreter must mirror 'runTestRunnerIO': any test+        -- that exercises the 'runTestsIfClean' abort short-circuit through+        -- the scripted runner relies on 'isAborted' reflecting prior calls+        -- to 'interruptCurrent'/'resetAbort'. Hard-coding 'pure False' here+        -- silently masks regressions in that flow.+        it "defaults to not aborted" do+            aborted <- runScripted [] isAborted+            aborted `shouldBe` False++        it "interruptCurrent sets the flag" do+            aborted <- runScripted [] do+                interruptCurrent+                isAborted+            aborted `shouldBe` True++        it "resetAbort clears the flag" do+            aborted <- runScripted [] do+                interruptCurrent+                resetAbort+                isAborted+            aborted `shouldBe` False+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++boom :: ErrorCall+boom = ErrorCall "simulated process crash"+++passingRun :: TestRun+passingRun =+    TestRunCompleted+        $ TestRunCompletion+            { target = "test:foo"+            , passed = True+            , output = "2 examples, 0 failures\n"+            , testCases = []+            , duration = Nothing+            }+++failingRun :: TestRun+failingRun =+    TestRunCompleted+        $ TestRunCompletion+            { target = "test:bar"+            , passed = False+            , output = "1 example, 1 failure\n"+            , testCases = []+            , duration = Nothing+            }+++runScripted :: [Either SomeException TestRun] -> Eff '[TestRunner, Concurrent, IOE] a -> IO a+runScripted results = runEff . runConcurrent . runTestRunnerScripted results+++--------------------------------------------------------------------------------+-- abortGatedProgress tests+--+-- Regression for the "module counter glitches after interrupt" bug: after+-- the test runner sets 'abortedRef' = True and terminates a test process,+-- the dying process can still push pipe-buffered '[N of M] Compiling …'+-- lines through the drain, and each one used to call 'reportTestProgress'+-- and tick the UI counter forward. 'abortGatedProgress' must drop those+-- updates instead.+--------------------------------------------------------------------------------++testAbortGatedProgress :: Spec+testAbortGatedProgress = do+    it "applies the progress update when abortedRef is False" do+        finalRuns <- runProgress False progress42 startingRuns+        finalRuns `shouldBe` [TestRunning "test:foo" (Just expected42)]++    it "drops the progress update when abortedRef is True" do+        finalRuns <- runProgress True progress42 startingRuns+        finalRuns `shouldBe` startingRuns++    it "drops every update applied while abortedRef stays True" do+        abortedRef <- newTVarIO True+        let loadings = [mkLoading i 10 | i <- [1 .. 5]]+        finalRuns <- runStore do+            BuildStore.setPhase (BuildId 1) (Testing (partialResultWith startingRuns))+            for_ loadings (abortGatedProgress abortedRef "test:foo")+            phaseTestRuns <$> getState+        finalRuns `shouldBe` startingRuns++    it "flips behaviour mid-run if abortedRef is set between updates" do+        abortedRef <- newTVarIO False+        finalRuns <- runStore do+            BuildStore.setPhase (BuildId 1) (Testing (partialResultWith startingRuns))+            -- This one applies.+            abortGatedProgress abortedRef "test:foo" (mkLoading 3 10)+            -- Simulate the interrupt firing.+            atomically (writeTVar abortedRef True)+            -- These should now be dropped.+            abortGatedProgress abortedRef "test:foo" (mkLoading 8 10)+            abortGatedProgress abortedRef "test:foo" (mkLoading 9 10)+            phaseTestRuns <$> getState+        finalRuns+            `shouldBe` [TestRunning "test:foo" (Just BuildProgress {compiled = 3, total = 10})]+  where+    startingRuns = [TestRunning "test:foo" Nothing]+    progress42 = mkLoading 4 10+    expected42 = BuildProgress {compiled = 4, total = 10}++    runProgress aborted loading runs = do+        abortedRef <- newTVarIO aborted+        runStore do+            BuildStore.setPhase (BuildId 1) (Testing (partialResultWith runs))+            abortGatedProgress abortedRef "test:foo" loading+            phaseTestRuns <$> getState++    runStore =+        runEff+            . runConcurrent+            . runDelay+            . runClockConst epoch+            . runReader (ProjectRoot "/")+            . evalState (BuildId 1)+            . runLogNoOp+            . runInputConst emptyDaemonInfo+            . BuildStore.runBuildStore++    mkLoading i tot =+        GhciLoading+            { index = i+            , total = tot+            , moduleName = "Mod"+            , sourceFile = "Mod.hs"+            }++    partialResultWith runs =+        BuildResult+            { completedAt = epoch+            , duration = 0+            , moduleCount = 0+            , diagnostics = []+            , testRuns = runs+            }++    phaseTestRuns :: BuildState -> [TestRun]+    phaseTestRuns s = case s.phase of+        Testing r -> r.testRuns+        _ -> []++    epoch :: UTCTime+    epoch = UTCTime (fromGregorian 2024 1 1) 0++    emptyDaemonInfo :: DaemonInfo+    emptyDaemonInfo =+        DaemonInfo+            { targets = []+            , watchDirs = []+            , sockPath = ""+            , logFile = ""+            , metricsPort = Nothing+            }
+ test/Unit/Tricorder/WatcherSpec.hs view
@@ -0,0 +1,69 @@+module Unit.Tricorder.WatcherSpec (spec_Watcher) where++import Atelier.Effects.Delay (runDelay)+import Atelier.Effects.FileWatcher (FileEvent (..))+import Atelier.Effects.Publishing (runPubWriter)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Dispatch.Dynamic (reinterpret_)+import Effectful.Reader.Static (runReader)+import Effectful.State.Static.Shared (execState, put)+import Effectful.Writer.Static.Shared (runWriter)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)++import Tricorder.BuildState+    ( CabalChangeDetected (..)+    , ChangeKind (..)+    , DaemonInfo (..)+    , SourceChangeDetected (..)+    )+import Tricorder.Effects.BuildStore (BuildStore (..))+import Tricorder.Watcher (WatchedFile (..), markWatchedFiles)+++spec_Watcher :: Spec+spec_Watcher = do+    describe "markWatchedFiles" testMarkWatchedFiles+++testMarkWatchedFiles :: Spec+testMarkWatchedFiles = do+    it "should mark build store as dirty" do+        ((state, _), _) <- runTest "foo"+        state `shouldBe` Just SourceChange++    describe "with non-cabal file change" $ it "should publish SourceChangeDetected" do+        (_, sourceChanges) <- runTest "foo"+        sourceChanges `shouldMatchList` [SourceChangeDetected "foo" Modified]++    describe "with cabal file change" $ it "should publish CabalChangeDetected" do+        ((_, cabalChanges), _) <- runTest "foo.cabal"+        cabalChanges `shouldMatchList` [CabalChangeDetected "foo.cabal" Modified]+  where+    runTest =+        runEff+            . runConcurrent+            . runDelay+            . runReader emptyDaemonInfo+            . runWriter+            . runPubWriter @SourceChangeDetected+            . runWriter+            . runPubWriter @CabalChangeDetected+            . mockBuildStore+            . markWatchedFiles+            . (`WatchedFile` Modified)+    mockBuildStore :: Eff (BuildStore : es) a -> Eff es (Maybe ChangeKind)+    mockBuildStore = reinterpret_ (execState Nothing) \case+        MarkDirty ck -> put $ Just ck+        _ -> error "Not implemented"+++emptyDaemonInfo :: DaemonInfo+emptyDaemonInfo =+    DaemonInfo+        { targets = []+        , watchDirs = []+        , sockPath = ""+        , logFile = ""+        , metricsPort = Nothing+        }
+ tricorder.cabal view
@@ -0,0 +1,271 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.38.2.+--+-- see: https://github.com/sol/hpack++name:           tricorder+version:        0.1.0.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+homepage:       https://github.com/atelier-hub/tricorder#readme+bug-reports:    https://github.com/atelier-hub/tricorder/issues+author:         Christian Georgii+maintainer:     christian.georgii@tweag.io+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md++source-repository head+  type: git+  location: https://github.com/atelier-hub/tricorder++library tricorder-internal+  exposed-modules:+      Tricorder+      Tricorder.Arguments+      Tricorder.Builder+      Tricorder.Builder.Dispatch+      Tricorder.BuildState+      Tricorder.CLI+      Tricorder.CLI.Main+      Tricorder.CLI.Render+      Tricorder.Config+      Tricorder.Daemon+      Tricorder.Daemon.Main+      Tricorder.Effects.Brick+      Tricorder.Effects.BrickChan+      Tricorder.Effects.BuildStore+      Tricorder.Effects.GhciSession+      Tricorder.Effects.GhciSession.GhciParser+      Tricorder.Effects.GhciSession.GhciProcess+      Tricorder.Effects.GhcPkg+      Tricorder.Effects.Logging+      Tricorder.Effects.SessionStore+      Tricorder.Effects.TestRunner+      Tricorder.Effects.UnixSocket+      Tricorder.Events.FileChanged+      Tricorder.GhcPkg.Types+      Tricorder.Observability+      Tricorder.Runtime+      Tricorder.Session+      Tricorder.Socket.Client+      Tricorder.Socket.Protocol+      Tricorder.Socket.Server+      Tricorder.SourceLookup+      Tricorder.TestOutput+      Tricorder.UI+      Tricorder.UI.Event+      Tricorder.UI.Keys+      Tricorder.UI.Misc+      Tricorder.UI.State+      Tricorder.UI.View+      Tricorder.Version+      Tricorder.Watcher+  other-modules:+      Paths_tricorder+  autogen-modules:+      Paths_tricorder+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      GADTs+      LambdaCase+      MultiWayIf+      OverloadedLabels+      OverloadedRecordDot+      OverloadedStrings+      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+  build-depends:+      Cabal-syntax ==3.12.*+    , aeson ==2.2.*+    , ansi-terminal ==1.1.*+    , atelier-core ==0.1.*+    , atelier-prelude ==0.1.*+    , base ==4.20.*+    , brick ==2.10.*+    , bytestring ==0.12.*+    , casing ==0.1.*+    , containers ==0.7.*+    , data-default ==0.8.*+    , directory ==1.3.*+    , effectful ==2.6.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , effectful-th ==1.0.*+    , filepath ==1.5.*+    , hashable ==1.5.*+    , megaparsec ==9.7.*+    , mtl ==2.3.*+    , network ==3.2.*+    , optparse-applicative ==0.19.*+    , process ==1.6.*+    , relude ==1.2.*+    , stm ==2.5.*+    , template-haskell ==2.22.*+    , text ==2.1.*+    , time ==1.12.*+    , time-units ==1.0.*+    , vty ==6.5.*+    , vty-crossplatform ==0.5.*+    , yaml ==0.11.*+  mixins:+      base hiding (Prelude)+  default-language: GHC2021++executable tricorder-daemon+  main-is: Main.hs+  other-modules:+      Paths_tricorder+  autogen-modules:+      Paths_tricorder+  hs-source-dirs:+      daemon+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      GADTs+      LambdaCase+      MultiWayIf+      OverloadedLabels+      OverloadedRecordDot+      OverloadedStrings+      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"+  build-depends:+      atelier-prelude ==0.1.*+    , base ==4.20.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , tricorder-internal+  mixins:+      base hiding (Prelude)+  default-language: GHC2021++executable tricorder-exe+  main-is: Main.hs+  other-modules:+      Paths_tricorder+  autogen-modules:+      Paths_tricorder+  hs-source-dirs:+      app+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      GADTs+      LambdaCase+      MultiWayIf+      OverloadedLabels+      OverloadedRecordDot+      OverloadedStrings+      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"+  build-depends:+      atelier-prelude ==0.1.*+    , base ==4.20.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , tricorder-internal+  mixins:+      base hiding (Prelude)+  default-language: GHC2021++test-suite tricorder-test+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+      Unit.Tricorder.BuilderSpec+      Unit.Tricorder.BuildStateSpec+      Unit.Tricorder.BuildStoreSpec+      Unit.Tricorder.CLI.RenderSpec+      Unit.Tricorder.Effects.GhciSession.GhciParserSpec+      Unit.Tricorder.Effects.GhciSession.GhciProcessSpec+      Unit.Tricorder.Effects.GhciSessionSpec+      Unit.Tricorder.Effects.SessionStoreSpec+      Unit.Tricorder.GhcPkgSpec+      Unit.Tricorder.SessionSpec+      Unit.Tricorder.SocketSpec+      Unit.Tricorder.SourceLookupSpec+      Unit.Tricorder.SourceSpec+      Unit.Tricorder.TestOutputSpec+      Unit.Tricorder.TestRunnerSpec+      Unit.Tricorder.WatcherSpec+      Paths_tricorder+  autogen-modules:+      Paths_tricorder+  hs-source-dirs:+      test+  default-extensions:+      BlockArguments+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      DuplicateRecordFields+      FlexibleContexts+      GADTs+      LambdaCase+      MultiWayIf+      OverloadedLabels+      OverloadedRecordDot+      OverloadedStrings+      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+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      Cabal-syntax ==3.12.*+    , aeson ==2.2.*+    , atelier-core ==0.1.*+    , atelier-prelude ==0.1.*+    , base ==4.20.*+    , containers ==0.7.*+    , data-default ==0.8.*+    , effectful ==2.6.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , hspec ==2.11.*+    , process ==1.6.*+    , stm ==2.5.*+    , tasty ==1.5.*+    , tasty-discover ==5.2.*+    , tasty-hspec ==1.2.*+    , text ==2.1.*+    , time ==1.12.*+    , time-units ==1.0.*+    , tricorder-internal+    , typed-process ==0.2.*+    , unagi-chan ==0.4.*+  mixins:+      base hiding (Prelude)+  default-language: GHC2021