packages feed

tricorder 0.1.1.0 → 0.2.0.0

raw patch · 121 files changed

+11205/−10291 lines, 121 filesdep +Cabaldep +tardep +zlibdep ~atelier-corenew-uploader

Dependencies added: Cabal, tar, zlib

Dependency ranges changed: atelier-core

Files

CHANGELOG.md view
@@ -5,6 +5,36 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and this project adheres to the [PVP](https://pvp.haskell.org/). +## [Unreleased]++## [0.2.0.0] - 2026-08-06++### Added++- The TUI can now restart the daemon — press `R` (the `restart_daemon` key+  event, rebindable like the others). It reconnects automatically once the+  fresh daemon is ready.+- Support for eval comments. See [Features of Tricorder - Eval Comments] for+  more information+- `tricorder eval-comments` subcommand.+- `tricorder log --print-path` prints the path to the current repo's Tricorder+  log file.++### Fixed++- No diagnostics are listed in single-package repos.+- Build loops on startup failure.++### Changed++- `tricorder source` now uses a package's sdist tarball from cabal's global+  cache instead of parsing Haddock-HTML, fetching them if necessary. This+  allows Tricorder to show sources for packages without documentation.++### Removed++- Observability and metrics stack.+ ## [0.1.1.0] - 2026-06-26  ### Added@@ -48,3 +78,5 @@ - Configurable via `.tricorder.toml` (targets, debounce, log file, etc.). - File watcher with debouncing; auto-restarts the GHCi session on crash   (fixes ghcid's crash-on-file-removal bug).++[Features of Tricorder - Eval Comments]: ../docs/features-of-tricorder.md#eval-comments
README.md view
@@ -4,16 +4,16 @@  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.+See the [repository README](https://github.com/tweag/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+- [`atelier-prelude`](https://github.com/tweag/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions+- [`atelier-core`](https://github.com/tweag/tricorder/tree/main/atelier-core) — foundational effects and utilities+- [`atelier-db`](https://github.com/tweag/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8)+- [`atelier-testing`](https://github.com/tweag/tricorder/tree/main/atelier-testing) — database-backed test utilities  ## License
− src/Tricorder.hs 
@@ -1,108 +0,0 @@-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 
@@ -1,206 +0,0 @@-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/Build.hs view
@@ -0,0 +1,101 @@+module Tricorder.Build+    ( BuildState (..)+    , BuildId (..)+    , BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , PostBuild (..)+    , Diagnostic (..)+    , Severity (..)+    ) where++import Atelier.Effects.Clock (UTCTime)+import Atelier.Time (Millisecond)+import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import GHC.Generics (Generically (..))++import Tricorder.Daemon.DaemonInfo (DaemonInfo)+import Tricorder.Session.TestTarget (TestTarget)++import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Build.Test qualified as Test+++data BuildState = BuildState+    { daemonInfo :: DaemonInfo+    , phase :: BuildPhase+    , buildId :: BuildId+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically BuildState+++newtype BuildId = BuildId {getBuildId :: Int}+    deriving stock (Eq, Show)+    deriving (FromJSON, Num, ToJSON) via Int+++data BuildPhase+    = Starting+    | Building [TestTarget] BuildProgress+    | Failed Text+    | PostBuilding BuildResult PostBuild+    | Finished BuildResult PostBuild+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically BuildPhase+++data BuildProgress = BuildProgress+    { compiled :: Int+    , total :: Int+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically BuildProgress+++data BuildResult = BuildResult+    { completedAt :: UTCTime+    , duration :: Millisecond+    , moduleCount :: Int+    , diagnostics :: [Diagnostic]+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically BuildResult+++data PostBuild = PostBuild+    { testSuites :: Test.Suites+    , evalComments :: Eval.Phase+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically PostBuild+++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 (FromJSON, ToJSON) via Generically Diagnostic+++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"
+ src/Tricorder/Build/Changes.hs view
@@ -0,0 +1,19 @@+module Tricorder.Build.Changes+    ( ChangeKind (..)+    , CabalChangeDetected (..)+    , SourceChangeDetected (..)+    ) where++import Atelier.Effects.FileWatcher (FileEvent)+++-- | 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)
+ src/Tricorder/Build/EvalComment.hs view
@@ -0,0 +1,218 @@+module Tricorder.Build.EvalComment+    ( Phase (..)+    , phasePending+    , Comments (..)+    , anyRunningComments+    , Evaluation (..)+    , Comment (..)+    , findComments+    , evalCommentP+    , singleLineEvalCommentP+    , multiLineEvalCommentP+    , blockCommentEvalP+    , State (..)+    , JsonOutput (..)+    ) where++import Atelier.Types.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, (.:))+import GHC.Generics (Generically (..))+import Text.Megaparsec+    ( MonadParsec (takeWhile1P, takeWhileP)+    , Parsec+    , SourcePos (..)+    , anySingle+    , eof+    , getSourcePos+    , manyTill+    , parse+    , try+    , unPos+    )+import Text.Megaparsec.Char (char, hspace, space, string)++import Data.Aeson.KeyMap qualified as KM+import Data.Text qualified as T+++data Phase+    = Looking+    | Found Comments+    | NoneFound+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically Phase+++phasePending :: Phase -> Bool+phasePending = \case+    Looking -> True+    NoneFound -> False+    Found comments -> anyRunningComments comments+++data Comments = Comments {getComments :: NonEmpty Evaluation}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically Comments+++anyRunningComments :: Comments -> Bool+anyRunningComments = any ((== Pending) . (.state)) . (.getComments)+++data Evaluation = Evaluation+    { file :: FilePath+    , comment :: Comment+    , state :: State+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically Evaluation+++-- | An eval comment found in a source file: a @-- $> \<expr\>@ annotation.+data Comment = Comment+    { lineNumber :: Int+    , expression :: Text+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically Comment+++-- | Scan source file content for eval comments.+-- Returns one 'Comment' per match, in source order.+findComments :: Text -> [Comment]+findComments content =+    case parse fileP "" content of+        Left _ -> []+        Right comments -> comments+  where+    fileP = catMaybes <$> manyTill lineP eof+    lineP = hspace *> ((Just <$> try evalCommentP) <|> (Nothing <$ skipRestOfLine))+    skipRestOfLine = void $ takeWhileP Nothing (/= '\n') *> optional (char '\n')+++evalCommentP :: Parser Comment+evalCommentP = singleLineEvalCommentP <|> multiLineEvalCommentP <|> blockCommentEvalP+++-- | @-- $> \<expr\>@ on a single line.+singleLineEvalCommentP :: Parser Comment+singleLineEvalCommentP = do+    _ <- string "-- $>"+    space+    SourcePos {sourceLine} <- getSourcePos+    expression <- takeWhile1P (Just "eval comment character") (/= '\n')+    pure+        Comment+            { lineNumber = unPos sourceLine+            , expression+            }+++-- | Multi-line line-comment block:+--+-- @+-- -- $$>+-- -- line one+-- -- line two+-- -- \<$$+-- @+--+-- Each content line must start with @--@ (optionally followed by a space).+-- The leading @-- @ is stripped; relative indentation within the block is+-- preserved.+multiLineEvalCommentP :: Parser Comment+multiLineEvalCommentP = do+    SourcePos {sourceLine} <- getSourcePos+    _ <- string "-- $$>"+    expression <- try multiLineExpr <|> inlineExpr+    pure+        Comment+            { expression+            , lineNumber = unPos sourceLine+            }+  where+    multiLineExpr = do+        _ <- optional (char '\n')+        lineContents <- manyTill commentLineP (try (string "-- <$$"))+        pure $ T.intercalate "\n" lineContents+    inlineExpr = do+        chars <- manyTill anySingle (string "<$$")+        pure $ T.strip (toText chars)+    commentLineP = do+        _ <- string "--"+        _ <- optional (char ' ')+        content <- takeWhileP Nothing (/= '\n')+        _ <- optional (char '\n')+        pure content+++-- | Block-comment eval:+--+-- @+-- {- $$>+-- expr+-- \<$$ -}+-- @+--+-- Content between the markers is stripped of leading\/trailing whitespace.+-- For multi-line expressions use the layout that GHCi expects; do not indent+-- the body relative to the opening @{- $>@ marker.+blockCommentEvalP :: Parser Comment+blockCommentEvalP = do+    SourcePos {sourceLine} <- getSourcePos+    _ <- string "{- $$>"+    _ <- optional (char '\n')+    chars <- manyTill anySingle (string "<$$ -}")+    pure+        Comment+            { expression = T.strip (toText chars)+            , lineNumber = unPos sourceLine+            }+++type Parser = Parsec Void Text+++data State+    = -- | The eval comment has yet to complete evaluation.+      Pending+    | -- | Combined stdout+stderr from GHCi, or an error message.+      Completed Text+    deriving stock (Eq, Generic, Show)+++instance ToJSON State where+    toJSON = \case+        Pending ->+            toJSON+                $ KM.fromList+                    [ ("state", String "pending")+                    ]+        Completed output ->+            toJSON+                $ KM.fromList+                    [ ("state", String "completed")+                    , ("output", String output)+                    ]+++instance FromJSON State where+    parseJSON = withObject "State" \o -> do+        state :: Text <- o .: "state"+        case state of+            "pending" -> pure $ Pending+            "completed" -> do+                output <- o .: "output"+                pure $ Completed output+            _ -> fail "invalid 'state' property"+++data JsonOutput+    = Starting+    | Building+    | Failed Text+    | Evaluating+    | NoEvalCommentsFound+    | Done Comments+    deriving stock (Generic)+    deriving (ToJSON) via QuietSnake JsonOutput
+ src/Tricorder/Build/Test.hs view
@@ -0,0 +1,111 @@+module Tricorder.Build.Test+    ( Suites (..)+    , hasFailedTests+    , suiteRuns+    , anyRunningTests+    , nullSuites+    , Suite (..)+    , isFailedRun+    , Progress (..)+    , Outcome (..)+    , Case (..)+    , caseFailed+    , SuiteCompletion (..)+    , SuiteError (..)+    ) where++import Atelier.Time (Millisecond)+import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generically (..))++import Data.Map.Strict qualified as Map++import Tricorder.Session.TestTarget (TestTarget)+++newtype Suites = Suites {getSuites :: Map TestTarget Suite}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically Suites+    deriving (Monoid, Semigroup) via Map TestTarget Suite+++hasFailedTests :: Suites -> Bool+hasFailedTests = any isFailedRun . suiteRuns+++suiteRuns :: Suites -> [Suite]+suiteRuns = Map.elems . getSuites+++anyRunningTests :: Suites -> Bool+anyRunningTests =+    any+        ( \case+            SuiteRunning _ -> True+            _ -> False+        )+        . toList+        . getSuites+++nullSuites :: Suites -> Bool+nullSuites = Map.null . getSuites+++data Suite+    = SuiteRunning (Maybe Progress)+    | SuiteErrored SuiteError+    | SuiteCompleted SuiteCompletion+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via (Generically Suite)+++isFailedRun :: Suite -> Bool+isFailedRun (SuiteCompleted c) = not c.passed+isFailedRun (SuiteErrored _) = True+isFailedRun (SuiteRunning _) = False+++data Progress = Progress+    { compiled :: Int+    , total :: Int+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically Progress+++data Outcome+    = Passed+    | Failed Text+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via (Generically Outcome)+++data Case = Case+    { description :: Text+    , outcome :: Outcome+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via (Generically Case)+++caseFailed :: Case -> Bool+caseFailed (Case _ (Failed _)) = True+caseFailed _ = False+++newtype SuiteError = SuiteError+    { message :: Text+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via (Generically SuiteError)+++data SuiteCompletion = SuiteCompletion+    { passed :: Bool+    , output :: Text+    , testCases :: [Case]+    , duration :: Maybe Millisecond+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via (Generically SuiteCompletion)
− src/Tricorder/BuildState.hs 
@@ -1,238 +0,0 @@--- | 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 (..), Target, WatchDirs (..))--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 :: [Target]-    , 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.getWatchDirs-            , 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 
@@ -1,675 +0,0 @@-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-    , preserveFailureVisibility-    )-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 (Command (..), Session (..), Target, TestTargets, WatchDirs, getTestTargets, renderTarget)--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 :: Command-    , targets :: [Target]-    , testTargets :: TestTargets-    , watchDirs :: WatchDirs-    }-    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 = " <> coerce 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 <> ": " <> coerce 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 =-                    preserveFailureVisibility loadResult.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 targetNames || any (\d -> d.severity == SError) partialResult.diagnostics = pure (Just [])-    | otherwise = do-        TestRunner.resetAbort-        setNewPhase-            $ EnteringNewPhase bid-            $ Testing partialResult {testRuns = map (`TestRunning` Nothing) targetNames}--        Log.info $ "Running " <> show (length targetNames) <> " test suite(s)"--        let initial = (\t -> (t, TestRunning t Nothing)) <$> targetNames-        runLoop initial targetNames-  where-    -- The runner consumes the @test:@ targets as cabal/ghci arguments, so-    -- render the structured targets to their textual form at this boundary.-    targetNames = map renderTarget testTargets.getTestTargets-    runLoop acc [] = pure (Just (snd <$> acc))-    runLoop acc (target : rest) = do-        Log.info $ "Running tests: " <> target-        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 
@@ -1,199 +0,0 @@-module Tricorder.Builder.Dispatch-    ( BuilderState (..)-    , DiagnosticMap-    , DispatchAction (..)-    , KnownTargetNames (..)-    , dispatch-    , emptyBuilderState-    , fileMatchesAnyTarget-    , filterToWatchDirs-    , mergeDiagnostics-    , preserveFailureVisibility-    ) where--import Atelier.Effects.FileWatcher (FileEvent (..))-import Data.Default (Default (..))-import System.FilePath (isAbsolute, normalise, splitDirectories, takeExtension, (</>))--import Data.List qualified as List-import Data.Map.Strict qualified as Map-import Data.Set qualified as Set--import Tricorder.BuildState (Diagnostic (..), Severity (..))-import Tricorder.Effects.GhciSession (LoadResult (..), LoadedModule (..))-import Tricorder.Effects.GhciSession.GhciParser-    ( isLocationLess-    , pathSuffixesAsModuleName-    , unattributedFailure-    )-import Tricorder.Session (WatchDirs (..))----- | The Builder's per-GHCi-session cache: what it last saw from GHCi plus its--- 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.------ Location-less diagnostics (see 'isLocationLess') are never keyed to a real--- source file, so they would never appear in 'compiledFiles' and would persist--- forever once raised. They describe the current load's outcome, so we clear--- them every cycle and let this cycle's 'diagnostics' re-add them if the--- failure is still present.-mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap-mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} =-    let retained = Map.filterWithKey (\f _ -> not (isLocationLess f)) prev-        cleared = foldr Map.delete retained compiledFiles-        newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics]-    in  Map.union newByFile cleared----- | 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.------ @:show targets@ entries are either dotted module names (e.g.--- @Tricorder.CLI.Main@) or file paths (e.g. @app/Main.hs@). GHCi uses the path--- form when a module name is ambiguous across home units — i.e. every--- executable/test 'Main'. We match both forms.------ The path form matters because a /failed/ executable 'Main' drops out of--- @:show modules@ but survives in @:show targets@ as its path. Without matching--- it, fixing the executable would dispatch a no-op 'Add' instead of a 'Reload',--- leaving the diagnostic stale.-fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool-fileMatchesAnyTarget (KnownTargetNames targets) fp =-    any (`Set.member` targets) (pathSuffixesAsModuleName fp)-        || any (pathTargetMatches fp . toString) (Set.toList targets)----- | Whether a path-shaped @:show targets@ entry refers to the given file,--- compared on directory-segment boundaries (so @app/Main.hs@ matches--- @./tricorder/app/Main.hs@ but @pp/Main.hs@ does not). Module-name targets--- (no @.hs@ extension) are left to the module-name branch above.-pathTargetMatches :: FilePath -> FilePath -> Bool-pathTargetMatches file target =-    takeExtension target == ".hs"-        && splitDirectories (normalise target) `List.isSuffixOf` splitDirectories (normalise file)----- | A GHCi command to issue in response to a source file change.-data DispatchAction-    = Reload-    | 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.------ Location-less diagnostics (see 'isLocationLess') are always kept: they carry--- no path to test against a watch dir, but they represent genuine build-level--- failures (e.g. a home-unit GHC plugin that can't load under--- @--enable-multi-repl@) that must not be dropped, or the build would silently--- read as clean.-filterToWatchDirs :: FilePath -> WatchDirs -> [Diagnostic] -> [Diagnostic]-filterToWatchDirs _ (WatchDirs []) diags = diags-filterToWatchDirs projectRoot (WatchDirs watchDirs) diags =-    filter (\d -> isLocationLess d.file || isUnderAnyWatchDir d.file) diags-  where-    absWatchDirs = map toAbsWd watchDirs-    toAbsWd wd-        | 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----- | Keep a failed build from ever reading as clean after watch-dir filtering.------ 'filterToWatchDirs' drops diagnostics outside the watched directories. If a--- load failed but every error it produced lay outside those dirs (e.g. a--- compile error in a sibling home unit not under @watchDirs@), filtering would--- leave no diagnostics and the broken build would look green. Detecting that an--- error was present /before/ filtering but none survived, we re-attach the--- location-less synthetic failure (which filtering always keeps) so the failure--- still surfaces.------ Takes the pre-filter diagnostics and the post-filter diagnostics; returns the--- post-filter list, with the synthetic failure appended only when needed.-preserveFailureVisibility :: [Diagnostic] -> [Diagnostic] -> [Diagnostic]-preserveFailureVisibility raw filtered-    | any isError raw && not (any isError filtered) = filtered ++ [unattributedFailure]-    | otherwise = filtered-  where-    isError d = d.severity == SError
− src/Tricorder/CLI.hs 
@@ -1,281 +0,0 @@-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/App.hs view
@@ -0,0 +1,141 @@+module Tricorder.CLI.App (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 Atelier.Effects.Process (Process)+import Atelier.Effects.Timeout (Timeout)+import Effectful (IOE)+import Effectful.Concurrent (Concurrent)+import Effectful.Reader.Static (Reader, ask, asks)+import Prelude hiding (force)++import Atelier.Effects.Console qualified as Console+import Data.Text qualified as T++import Tricorder.Build (BuildState (..))+import Tricorder.CLI.Arguments (Command (..), LogMode (..))+import Tricorder.CLI.Daemon+    ( restartDaemon+    , startDaemon+    , stopDaemon+    , waitForDaemon+    )+import Tricorder.CLI.Operations+    ( showEvalComments+    , showLog+    , showSource+    , showStatus+    , showTests+    )+import Tricorder.CLI.UI (viewUi)+import Tricorder.CLI.UI.Brick (Brick)+import Tricorder.CLI.UI.BrickChan (BrickChan)+import Tricorder.Daemon.DaemonInfo (DaemonInfo (..))+import Tricorder.Runtime (LogPath (..), PidFile (..), SocketPath (..))+import Tricorder.Socket.Client (isDaemonRunning, queryStatus)+import Tricorder.Socket.UnixSocket (UnixSocket)++import Tricorder.CLI.UI.Keys qualified as Keys+++run+    :: ( Brick :> es+       , BrickChan :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Console :> es+       , Daemons :> es+       , Delay :> es+       , Exit :> es+       , File :> es+       , FileSystem :> es+       , IOE :> es+       , Process :> 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+                ready <- waitForDaemon+                if ready then+                    Console.putStrLn "Daemon started."+                else+                    Console.putStrLn "Daemon started, but the socket is not responding yet."+        Stop force -> do+            running <- isDaemonRunning+            when running+                $ stopDaemon force >>= \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 logMode -> 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)+            case logMode of+                ShowLog followMode -> showLog logFile followMode+                ShowLogPath -> Console.putTextLn (toText logFile)+        UI -> do+            running <- isDaemonRunning+            unless running do+                startDaemon+                void waitForDaemon+            viewUi+        Source moduleNames -> do+            running <- isDaemonRunning+            unless running $ do+                startDaemon+                void waitForDaemon+            showSource moduleNames+        Restart force ->+            restartDaemon force >>= \case+                Just (Left reasons) -> traverse_ Console.putTextLn reasons+                _ -> pass+        EvalComments opts -> do+            running <- isDaemonRunning+            unless running do+                startDaemon+                void waitForDaemon+            showEvalComments opts
+ src/Tricorder/CLI/Arguments.hs view
@@ -0,0 +1,263 @@+module Tricorder.CLI.Arguments+    ( Command (..)+    , FollowMode (..)+    , LogMode (..)+    , OutputFormat (..)+    , StatusOptions (..)+    , TestOptions (..)+    , EvalCommentsOptions (..)+    , 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+    , flag'+    , fullDesc+    , header+    , help+    , helper+    , hsubparser+    , info+    , infoOption+    , long+    , metavar+    , option+    , progDesc+    , short+    )++import Data.Text qualified as T++import Tricorder.Module (ModuleName (..))+import Tricorder.Socket.Protocol (Force (..))+import Tricorder.SourceLookup (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 LogMode+    = ShowLog FollowMode+    | ShowLogPath+++data StatusOptions = StatusOptions+    { wait :: WaitMode+    , format :: OutputFormat+    , verbosity :: Verbosity+    , expand :: Maybe Int+    }+++data TestOptions = TestOptions+    { failedOnly :: Bool+    , wait :: WaitMode+    }+++data EvalCommentsOptions = EvalCommentsOptions+    { wait :: WaitMode+    , format :: OutputFormat+    }+++data Command+    = Start+    | Stop Force+    | Status StatusOptions+    | Test TestOptions+    | UI+    | Log LogMode+    | Source [SourceQuery]+    | Restart Force+    | EvalComments EvalCommentsOptions+++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 stopParser (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"))+            <> command "restart" (info restartParser (progDesc "Restart the daemon"))+            <> command "eval-comments" (info evalCommentsParser (progDesc "Show eval comments from the latest build"))+        )+++logParser :: Parser Command+logParser =+    Log <$> (pathFlag <|> followFlag)+  where+    pathFlag =+        flag'+            ShowLogPath+            ( long "print-path"+                <> help "Print the path to the log file instead of its contents"+            )+    followFlag =+        ShowLog+            <$> flag+                NoFollow+                Follow+                ( long "follow"+                    <> short 'f'+                    <> help "Keep streaming new log lines as they are written"+                )+++statusParser :: Parser Command+statusParser =+    Status+        <$> ( StatusOptions+                <$> waitParser+                <*> jsonFormatToggleParser+                <*> 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"+                    )+                <*> waitParser+            )+++sourceParser :: Parser Command+sourceParser =+    Source <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function"))+++stopParser :: Parser Command+stopParser =+    Stop <$> forceParser "Ignore waiting queries when stopping the daemon"+++restartParser :: Parser Command+restartParser =+    Restart <$> forceParser "Ignore watiting queries when restarting the daemon"+++forceParser :: String -> Parser Force+forceParser helpText = flag NoForce Force $ long "force" <> help helpText+++evalCommentsParser :: Parser Command+evalCommentsParser =+    EvalComments+        <$> ( EvalCommentsOptions+                <$> waitParser+                <*> jsonFormatToggleParser+            )+++waitParser :: Parser WaitMode+waitParser =+    flag+        ShowCurrent+        WaitForBuild+        ( long "wait"+            <> help "Block until the current build cycle completes"+        )+++jsonFormatToggleParser :: Parser OutputFormat+jsonFormatToggleParser =+    flag+        TextOutput+        JsonOutput+        ( long "json"+            <> help "Output full build state as JSON"+        )+++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/CLI/Daemon.hs view
@@ -0,0 +1,148 @@+module Tricorder.CLI.Daemon+    ( startDaemon+    , stopDaemon+    , restartDaemon+    , waitForDaemon+    ) where++import Atelier.Effects.Delay (Delay)+import Atelier.Effects.File (File)+import Atelier.Effects.Posix.Daemons (Daemons)+import Atelier.Effects.Timeout (Timeout, timeout)+import Atelier.Time (Millisecond, Second)+import Effectful (IOE)+import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet)+import Effectful.Reader.Static (Reader, ask)+import Effectful.Writer.Static.Local (runWriter, tell)+import Prelude hiding (force)++import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Posix.Daemons qualified as Daemons++import Tricorder.Runtime (PidFile, SocketPath (..))+import Tricorder.Socket.Client (isDaemonReady, isDaemonRunning, requestShutdown)+import Tricorder.Socket.Protocol (Force (..))+import Tricorder.Socket.UnixSocket (UnixSocket)++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+       )+    => Force -> Eff es (Either [Text] Text)+stopDaemon force = 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+    timeoutDelay :: Second = case force of+        Force -> 3+        NoForce -> 6+    requestStop sockPath pidFile = do+        timeout1second (requestShutdown force sockPath) >>= \_ -> do+            didStop <- fmap isJust $ timeout timeoutDelay $ 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 :: Second)++    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 ()+++-- | Restart the daemon: stop it (if running) and then start a fresh instance.+-- Returns the outcome of the stop attempt, or 'Nothing' if the daemon was not+-- running. The daemon is started unconditionally afterwards, mirroring the+-- @restart@ subcommand.+restartDaemon+    :: ( Daemons :> es+       , Delay :> es+       , File :> es+       , IOE :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , Timeout :> es+       , UnixSocket :> es+       )+    => Force+    -> Eff es (Maybe (Either [Text] Text))+restartDaemon force = do+    running <- isDaemonRunning+    res <- if running then Just <$> stopDaemon force else pure Nothing+    startDaemon+    pure res+++-- | Poll until the daemon binds to the socket, giving up after roughly+-- ten seconds. Returns 'True' once the socket is accepting connections.+--+-- We poll the socket rather than the PID file for two reasons: the daemon+-- writes its PID /before/ it binds the socket (a client connecting in that+-- window gets a "connection refused" error), and right after forking the PID+-- file may not exist yet — so the PID is not a reliable readiness signal either+-- way.+waitForDaemon+    :: ( Delay :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Eff es Bool+waitForDaemon = do+    SocketPath sockPath <- ask+    go sockPath maxAttempts+  where+    -- 50 attempts × 200ms ≈ 10s+    maxAttempts = 50 :: Int+    go _ 0 = pure False+    go sockPath n = do+        ready <- isDaemonReady sockPath+        if ready then+            pure True+        else do+            Delay.wait (200 :: Millisecond)+            go sockPath (n - 1)
src/Tricorder/CLI/Main.hs view
@@ -10,19 +10,20 @@ import Atelier.Effects.File (runFile) import Atelier.Effects.FileSystem (runFileSystemIO) import Atelier.Effects.Posix.Daemons (runDaemons)+import Atelier.Effects.Process (runProcessIO)+import Atelier.Effects.Timeout (runTimeout) import Effectful (runEff) import Effectful.Concurrent (runConcurrent)-import Effectful.Timeout (runTimeout) -import Tricorder.Arguments (runArguments)+import Tricorder.CLI.Arguments (runArguments)+import Tricorder.CLI.UI.Brick (runBrick)+import Tricorder.CLI.UI.BrickChan (runBrickChan) 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.Socket.UnixSocket (runUnixSocketIO) -import Tricorder qualified-import Tricorder.UI.Keys qualified as Keys+import Tricorder.CLI.App qualified as App+import Tricorder.CLI.UI.Keys qualified as Keys   main :: IO ()@@ -47,7 +48,8 @@         . runLoadedConfig         . runConfig @"keybindings" @Keys.Config         . runDaemons+        . runProcessIO         . runArgumentsIO         . runArguments         . runUnixSocketIO-        $ Tricorder.run+        $ App.run
+ src/Tricorder/CLI/Operations.hs view
@@ -0,0 +1,406 @@+module Tricorder.CLI.Operations+    ( showLog+    , showSource+    , showStatus+    , showTests+    , showEvalComments+    ) 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.Map.Strict qualified as Map+import Data.Text qualified as T++import Tricorder.Build (BuildState (..), Severity (..))+import Tricorder.Build.Test (Suites (..))+import Tricorder.CLI.Arguments+    ( EvalCommentsOptions (..)+    , FollowMode (..)+    , OutputFormat (..)+    , StatusOptions (..)+    , TestOptions (..)+    , Verbosity (..)+    , WaitMode (..)+    )+import Tricorder.CLI.Render+    ( diagnosticLineIndexed+    , formatDuration+    , renderSourceResults+    )+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Session.TestTarget (renderTestTarget)+import Tricorder.Socket.Client (querySource, queryStatus, queryStatusWait)+import Tricorder.Socket.UnixSocket (UnixSocket)+import Tricorder.SourceLookup (SourceQuery)+import Tricorder.TestOutput (stripGhciNoise)++import Tricorder.Build qualified as Build+import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Build.Test qualified as Test+import Tricorder.Build.Test qualified as Tests+++-- | 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+    when (opts.wait == WaitForBuild && opts.format == TextOutput) do+        displayPendingBuildStatus+    result <- awaitBuildStatus opts.wait+    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+        Build.Starting -> Console.putStrLn "Building..."+        Build.Building _ _ -> Console.putStrLn "Building..."+        Build.Failed msg -> reportBuildFailed msg+        Build.PostBuilding _ postBuild ->+            let+                testsRunning = Test.anyRunningTests postBuild.testSuites+                commentsEvaluating = Eval.phasePending postBuild.evalComments+            in+                if+                    | testsRunning && commentsEvaluating ->+                        Console.putStrLn "Testing and evaluating comments..."+                    | testsRunning ->+                        Console.putStrLn "Testing..."+                    | commentsEvaluating ->+                        Console.putStrLn "Evaluating comments..."+                    | otherwise ->+                        Console.putStrLn "Post-procesing..."+        Build.Finished result postBuild -> do+            tz <- currentTimeZone+            case expand of+                Just n ->+                    case result.diagnostics !!? (n - 1) of+                        Nothing ->+                            Console.putTextLn+                                $ "No diagnostic #"+                                    <> show n+                                    <> " (current build has "+                                    <> show (length result.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 ..] result.diagnostics)+                    Console.putTextLn $ buildSummary tz result+                    mapM_ (uncurry (printTestRun verbosity)) $ Map.toList postBuild.testSuites.getSuites+                    when (buildHasErrors result || Test.hasFailedTests postBuild.testSuites) exitFailure++    printTestRun verbosity tgt tr = do+        Console.putTextLn $ case tr of+            Test.SuiteRunning Nothing -> t <> "  running..."+            Test.SuiteRunning (Just p) -> t <> "  running... (" <> show p.compiled <> "/" <> show p.total <> ")"+            Test.SuiteErrored e -> t <> "  error: " <> e.message+            Test.SuiteCompleted c -> t <> "  " <> completionSummary c+        when (verbosity == Verbose) $ case tr of+            Test.SuiteCompleted c ->+                mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (T.lines c.output))+            _ -> pure ()+      where+        t = renderTestTarget tgt++    buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics+    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 :: Test.SuiteCompletion -> 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 (Test.Case _ (Test.Failed _)) = 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+    result <- awaitBuildStatus opts.wait+    case result of+        Left err -> Console.putTextLn $ "Error: " <> err+        Right state ->+            case state.phase of+                Build.Starting -> Console.putStrLn "Daemon starting, no test results yet."+                Build.Building _ _ -> Console.putStrLn "Build in progress, no test results yet."+                Build.PostBuilding _ postBuild -> renderTestRuns postBuild.testSuites.getSuites+                Build.Finished _ postBuild -> renderTestRuns postBuild.testSuites.getSuites+                Build.Failed msg -> reportBuildFailed msg+  where+    renderTestRuns suites+        | Map.null suites = Console.putStrLn "No test results."+        | Map.null filteredSuites = do+            Console.putStrLn "All passed."+            mapM_ (Console.putTextLn . ("  " <>) . renderTestTarget) $ Map.keys suites+        | otherwise = do+            mapM_ (uncurry printTestOutput) $ Map.toList filteredSuites+            when (any Test.isFailedRun filteredSuites) exitFailure+      where+        filteredSuites =+            if opts.failedOnly then+                Map.filter Test.isFailedRun suites+            else+                suites++    printTestOutput tgt tr = case tr of+        Test.SuiteRunning Nothing ->+            Console.putTextLn $ t <> "running..."+        Test.SuiteRunning (Just p) ->+            Console.putTextLn $ t <> "running... (" <> show p.compiled <> "/" <> show p.total <> ")"+        Test.SuiteErrored e ->+            Console.putTextLn $ t <> "error: " <> e.message+        Test.SuiteCompleted c -> do+            Console.putTextLn $ t <> 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 Test.caseFailed c.testCases)+            else+                mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (lines c.output))+      where+        t = renderTestTarget tgt <> "  "++    printFailedCase tc = do+        Console.putTextLn $ "  " <> tc.description+        case tc.outcome of+            Test.Failed details ->+                mapM_ (Console.putTextLn . ("    " <>)) (T.lines details)+            Test.Passed -> 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+++showEvalComments+    :: ( Console :> es+       , Exit :> es+       , File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => EvalCommentsOptions -> Eff es ()+showEvalComments opts = do+    when (opts.wait == WaitForBuild && opts.format == TextOutput) do+        displayPendingBuildStatus+    result <- awaitBuildStatus opts.wait+    case opts.format of+        TextOutput -> displayTextOutput result+        JsonOutput -> displayJsonOutput result+++displayTextOutput+    :: ( Console :> es+       , Exit :> es+       )+    => Either Text BuildState -> Eff es ()+displayTextOutput = \case+    Left err -> do+        Console.putTextLn $ "Error: " <> err+        exitFailure+    Right (BuildState _ phase _) -> case phase of+        Build.Starting -> Console.putStrLn "Starting..."+        Build.Building _ _ -> Console.putStrLn "Building..."+        Build.PostBuilding _ postBuild -> txtEvalComments postBuild+        Build.Finished _ postBuild -> txtEvalComments postBuild+        Build.Failed err -> do+            Console.putTextLn $ "Error: " <> err+            exitFailure+  where+    txtEvalComments postBuild =+        let evalutatingComments = Eval.phasePending postBuild.evalComments+        in  if+                | Tests.anyRunningTests postBuild.testSuites && evalutatingComments ->+                    Console.putStrLn "Testing and evaluating comments..."+                | Tests.anyRunningTests postBuild.testSuites -> Console.putStrLn "Testing..."+                | evalutatingComments -> Console.putStrLn "Evaluating comments..."+                | otherwise -> case postBuild.evalComments of+                    Eval.Looking -> Console.putStrLn "Looking for eval comments..."+                    Eval.NoneFound -> Console.putStrLn "No eval comments found"+                    Eval.Found comments+                        | Eval.anyRunningComments comments -> Console.putStrLn "Evaluating comments..."+                        | otherwise ->+                            Console.putTextLn+                                . T.intercalate "\n\n"+                                . toList+                                $ showEvalRun <$> comments.getComments+    showEvalRun run =+        T.intercalate+            "\n"+            [ showEvalRunInfo run+            , showEvalState run+            ]+    showEvalRunInfo evaluation =+        T.intercalate+            "\n"+            [ toText evaluation.file <> ":" <> show evaluation.comment.lineNumber+            , "Expression:"+            , evaluation.comment.expression+            ]+    showEvalState evaluation =+        case evaluation.state of+            Eval.Pending -> "Pending..."+            Eval.Completed output ->+                T.intercalate+                    "\n"+                    [ "Output:"+                    , output+                    ]+++displayJsonOutput :: (Console :> es, Exit :> es) => Either Text BuildState -> Eff es ()+displayJsonOutput = \case+    Left err -> do+        putJson $ Eval.Failed err+        exitFailure+    Right (BuildState _ phase _) -> case phase of+        Build.Starting -> putJson Eval.Starting+        Build.Building _ _ -> putJson Eval.Building+        Build.Failed msg -> do+            putJson $ Eval.Failed msg+            exitFailure+        Build.PostBuilding _ postBuild -> jsonEvalComments postBuild+        Build.Finished _ postBuild -> jsonEvalComments postBuild+  where+    jsonEvalComments postBuild = case postBuild.evalComments of+        Eval.Looking -> putJson Eval.Evaluating+        Eval.NoneFound -> putJson $ Eval.NoEvalCommentsFound+        Eval.Found comments+            | Eval.anyRunningComments comments -> putJson Eval.Evaluating+            | otherwise -> putJson $ Eval.Done comments+    putJson = Console.putStrLn . toStrict . encode+++displayPendingBuildStatus+    :: ( Console :> es+       , File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Eff es ()+displayPendingBuildStatus = do+    SocketPath sockPath <- ask+    current <- queryStatus sockPath+    case current of+        Right BuildState {phase = Build.Starting} -> Console.putStrLn "Starting..."+        Right BuildState {phase = Build.Building _ _} -> Console.putStrLn "Building..."+        Right BuildState {phase = Build.Finished _ postBuild} ->+            displayPostBuildStatus postBuild+        Right BuildState {phase = Build.PostBuilding _ postBuild} ->+            displayPostBuildStatus postBuild+        Right BuildState {phase = Build.Failed _} -> pure ()+        Left _ -> pure ()+  where+    displayPostBuildStatus postBuild+        | Tests.anyRunningTests postBuild.testSuites && evaluatingComments =+            Console.putStrLn "Testing and evaluating comments..."+        | Tests.anyRunningTests postBuild.testSuites =+            Console.putStrLn "Testing..."+        | evaluatingComments =+            Console.putStrLn "Evaluating comments..."+        | otherwise = pure ()+      where+        evaluatingComments = Eval.phasePending postBuild.evalComments+++awaitBuildStatus+    :: ( File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => WaitMode -> Eff es (Either Text BuildState)+awaitBuildStatus wait = do+    SocketPath sockPath <- ask+    case wait of+        WaitForBuild -> queryStatusWait sockPath+        ShowCurrent -> queryStatus sockPath
src/Tricorder/CLI/Render.hs view
@@ -11,14 +11,10 @@ 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 (..))+import Tricorder.Build (Diagnostic (..), Severity (..))+import Tricorder.Module (ModuleName (..), PackageId (..))+import Tricorder.SourceLookup (ModuleSourceResult (..), SourceQuery (..))   formatDuration :: Millisecond -> Text@@ -56,27 +52,22 @@ renderSourceResults :: (Console :> es) => [ModuleSourceResult] -> Eff es () renderSourceResults results = mapM_ renderOne results   where-    renderOne (SourceFound query src reExports) = do+    renderOne (SourceFound query src) = 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) =+    renderOne (SourceUnavailable query pkgId) =         Console.putTextLn             $ "No source available: "                 <> unModuleName query.moduleName-                <> " (package "-                <> unPackageId pkgId-                <> " was built without documentation; try `cabal get "+                <> " (could not locate or fetch a source tarball for "                 <> unPackageId pkgId-                <> "`)"+                <> ")"     renderOne (FunctionNotFound query) =         Console.putTextLn             $ "tricorder: "@@ -89,6 +80,3 @@         "-- "             <> unModuleName query.moduleName             <> maybe "" ("#" <>) query.function--    renderReExport (ReExportModule m) = "module " <> m-    renderReExport (ReExportName name src) = name <> " (from " <> src <> ")"
+ src/Tricorder/CLI/UI.hs view
@@ -0,0 +1,119 @@+module Tricorder.CLI.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 Atelier.Effects.Process (Process, getExecutablePath, proc, runProcess)+import Brick (App (..), neverShowCursor)+import Brick.BChan (BChan, writeBChanNonBlocking)+import Brick.Keybindings (KeyConfig)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar)+import Effectful.Exception (bracket_, trySync)+import Effectful.Reader.Static (Reader, ask)++import Atelier.Effects.Conc qualified as Conc++import Tricorder.CLI.Daemon (waitForDaemon)+import Tricorder.CLI.UI.Brick (Brick)+import Tricorder.CLI.UI.BrickChan (BrickChan)+import Tricorder.CLI.UI.Event (Event (..), handleEvent)+import Tricorder.CLI.UI.Keys (KeyEvent, dispatcher)+import Tricorder.CLI.UI.State (State (..), Viewports (..))+import Tricorder.CLI.UI.View (mkAttrMap, view)+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Socket.Client (queryWatch)+import Tricorder.Socket.UnixSocket (UnixSocket)++import Tricorder.CLI.UI.Brick qualified as Brick+import Tricorder.CLI.UI.BrickChan qualified as BrickChan+import Tricorder.CLI.UI.Keys qualified as Keys+import Tricorder.CLI.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; @R@+-- restarts the daemon.+viewUi+    :: ( Brick :> es+       , BrickChan :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Console :> es+       , Delay :> es+       , File :> es+       , Process :> es+       , Reader Keys.Config :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Eff es ()+viewUi = do+    SocketPath sockPath <- ask+    chan <- BrickChan.newBChan 10+    restartChan <- BrickChan.newBChan 1+    -- Set while a restart we triggered is in flight, so the watch loop stays+    -- patient and reconnects to the fresh daemon instead of giving up.+    restarting <- newTVarIO False+    initialState <- Model.init+    Conc.scoped do+        _ <-+            Conc.fork do+                queryWatch sockPath (readTVarIO restarting)+                    $ BrickChan.writeBChan chan . NewBuildState+                BrickChan.writeBChan chan $ FailedBuild "Lost contact with the daemon"+        _ <- Conc.fork $ restartWorker restartChan restarting+        keyConfig <- Keys.mkKeyConfig+        let requestRestart = void $ writeBChanNonBlocking restartChan ()+        void+            $ Brick.runBrickApp+                chan+                (watchApp requestRestart keyConfig)+                initialState+++-- | Wait for restart requests from the TUI and service each one by spawning a+-- fresh @tricorder restart@ process.+--+-- The restart must happen out-of-process: starting the daemon double-forks (see+-- "System.Posix.Daemon"), and forking this vty-controlled process knocks the+-- terminal out of the raw mode brick set up, so keystrokes stop being captured.+-- Delegating to a separate process keeps the fork isolated. The brick event+-- handler signals us over @restartChan@ because it cannot run these effects.+restartWorker+    :: ( BrickChan :> es+       , Concurrent :> es+       , Delay :> es+       , Process :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => BChan ()+    -> TVar Bool+    -> Eff es ()+restartWorker restartChan restarting = forever+    $ bracket_+        (BrickChan.readBChan restartChan >> atomically (writeTVar restarting True))+        (atomically $ writeTVar restarting False)+        do+            self <- getExecutablePath+            -- Swallow failures: a restart that errors must not take down the TUI, and+            -- the flag has to be cleared either way.+            _ <- trySync $ runProcess $ proc self ["restart"]+            void waitForDaemon+++watchApp :: IO () -> KeyConfig KeyEvent -> App State Event Viewports+watchApp requestRestart kc =+    App+        { appDraw = view kc+        , appHandleEvent = handleEvent $ dispatcher requestRestart kc+        , appStartEvent = pure ()+        , appAttrMap = mkAttrMap+        , appChooseCursor = neverShowCursor+        }
+ src/Tricorder/CLI/UI/Brick.hs view
@@ -0,0 +1,48 @@+module Tricorder.CLI.UI.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.CLI.UI.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/CLI/UI/BrickChan.hs view
@@ -0,0 +1,34 @@+module Tricorder.CLI.UI.BrickChan+    ( BrickChan+    , BChan+    , newBChan+    , writeBChan+    , readBChan+    , 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.readBChan`+    ReadBChan :: BChan a -> BrickChan m a+++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+    ReadBChan c -> liftIO $ BChan.readBChan c
+ src/Tricorder/CLI/UI/Event.hs view
@@ -0,0 +1,38 @@+module Tricorder.CLI.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.Build (BuildState (..))+import Tricorder.CLI.UI.Keys (KeyEvent)+import Tricorder.CLI.UI.State (Processed (..), State (..), Viewports (..))+import Tricorder.Socket.Client (Restarting (..))+++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/CLI/UI/Keys.hs view
@@ -0,0 +1,264 @@+module Tricorder.CLI.UI.Keys+    ( KeyEvent+    , Config+    , keys+    , dispatcher+    , viewKeybindings+    , mkKeyConfig+    , keybindForRoute+    ) 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.KeyConfig (firstActiveBinding)+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.CLI.UI.Misc (warn)+import Tricorder.CLI.UI.Route (Route)+import Tricorder.CLI.UI.State+    ( Processed (Waiting)+    , State (..)+    , Viewports (..)+    , currentRoute+    , cycleTestFilter+    , navigate+    , viewToViewport+    )++import Tricorder.CLI.UI.Route qualified as Route+++-- | [tag:keybinding_events] The TUI key events. This type is the source of truth+-- for the event names documented in README.md under "Custom Key Bindings", which+-- points back here with a matching @ref@. Whenever you add, remove, or rename a+-- 'KeyEvent', update that list to match — @tagref check@ flags the dangling+-- reference if this tag is renamed or dropped without touching the docs.+data KeyEvent+    = ToggleDaemonInfoView+    | ToggleHelp+    | CycleTestView+    | ToggleEvalComments+    | RestartDaemon+    | ExitView+    | ScrollUp+    | ScrollDown+    | Quit+    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)+        , ("toggle help", ToggleHelp)+        , ("cycle test view", CycleTestView)+        , ("toggle eval comments", ToggleEvalComments)+        , ("restart daemon", RestartDaemon)+        , ("exit view", ExitView)+        , ("scroll up", ScrollUp)+        , ("scroll down", ScrollDown)+        , ("quit", Quit)+        ]+++bindings :: [(KeyEvent, [Binding])]+bindings =+    [ (ToggleDaemonInfoView, [bind 'g'])+    , (ToggleHelp, [bind 'h'])+    , (CycleTestView, [bind 't'])+    , (ToggleEvalComments, [bind 'e'])+    , (RestartDaemon, [bind 'R'])+    , (ExitView, [binding KEsc []])+    , (ScrollUp, [binding KUp []])+    , (ScrollDown, [binding KDown []])+    , (Quit, [bind 'q', ctrl 'c'])+    ]+++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+++-- | Build the key dispatcher. @requestRestart@ is run (in 'IO') when the restart+-- key is pressed; it hands the request off to the worker that owns the daemon+-- control effects, since brick's 'EventM' cannot run them directly.+dispatcher :: IO () -> KeyConfig KeyEvent -> KeyDispatcher KeyEvent (EventM Viewports State)+dispatcher requestRestart 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 currentRoute s == Route.DaemonInfo then+                        navigate Route.Main s+                    else+                        navigate Route.DaemonInfo s+            , onEvent ToggleHelp "Toggle help" do+                modify \s ->+                    if currentRoute s == Route.Help then+                        navigate Route.Main s+                    else+                        navigate Route.Help s+            , onEvent CycleTestView "Cycle test results view" do+                modify \s -> case currentRoute s of+                    Route.Tests ->+                        if s.testFilter == maxBound then+                            navigate Route.Main s {testFilter = minBound}+                        else+                            s {testFilter = cycleTestFilter s.testFilter}+                    _ -> navigate Route.Tests s+            , onEvent ToggleEvalComments "Toggle eval comments view" do+                modify \s ->+                    if currentRoute s == Route.Evals then+                        navigate Route.Main s+                    else+                        navigate Route.Evals s+            , onEvent RestartDaemon "Restart the daemon" do+                liftIO requestRestart+                modify \s -> s {buildState = Waiting}+            , onEvent ExitView "Exit or go back" do+                gets (.route) >>= \case+                    Route.Main -> halt+                    _ -> modify $ navigate Route.Main+            , onEvent ScrollUp "Scroll up" do+                mvp <- gets (viewToViewport . currentRoute)+                case mvp of+                    Just vp -> vScrollBy (viewportScroll vp) (-1)+                    Nothing -> pure ()+            , onEvent ScrollDown "Scroll down" do+                mvp <- gets (viewToViewport . currentRoute)+                case mvp of+                    Just vp ->+                        vScrollBy (viewportScroll vp) 1+                    Nothing -> pure ()+            , onEvent Quit "Exit" do+                halt+            ]+  where+    stringify =+        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 triggers =+    hBox+        [ warn $ txt $ eventName <> ": "+        , txt $ showBindings $ mconcat $ getBindings <$> triggers+        ]+  where+    showBindings = T.intercalate ", " . fmap ppBinding . sort . toList+    getBindings = \case+        ByKey k -> Set.singleton k+        ByEvent e -> Set.fromList $ allActiveBindings kc e+++keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding+keybindForRoute kc = \case+    Route.Main -> Nothing+    Route.DaemonInfo -> firstActiveBinding kc ToggleDaemonInfoView+    Route.Help -> firstActiveBinding kc ToggleHelp+    Route.Tests -> firstActiveBinding kc CycleTestView+    Route.Evals -> firstActiveBinding kc ToggleEvalComments
+ src/Tricorder/CLI/UI/Misc.hs view
@@ -0,0 +1,50 @@+module Tricorder.CLI.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/CLI/UI/Route.hs view
@@ -0,0 +1,22 @@+module Tricorder.CLI.UI.Route+    ( Route (..)+    , name+    ) where+++data Route+    = Main+    | Help+    | DaemonInfo+    | Tests+    | Evals+    deriving stock (Bounded, Enum, Eq)+++name :: Route -> Text+name = \case+    Main -> "Dashboard"+    Help -> "Help"+    DaemonInfo -> "Daemon info"+    Tests -> "Tests"+    Evals -> "Eval comments"
+ src/Tricorder/CLI/UI/State.hs view
@@ -0,0 +1,78 @@+module Tricorder.CLI.UI.State+    ( Viewports (..)+    , State (..)+    , Processed (..)+    , TestFilter (..)+    , init+    , currentRoute+    , viewToViewport+    , cycleTestFilter+    , navigate+    ) where++import Atelier.Effects.Clock (Clock, TimeZone)+import Prelude hiding (init)++import Atelier.Effects.Clock qualified as Clock++import Tricorder.Build (BuildState)+import Tricorder.CLI.UI.Route (Route)++import Tricorder.CLI.UI.Route qualified as Route+++data Viewports+    = MainViewport+    | DiagnosticViewport+    | TestViewport+    | EvalResultsViewport+    deriving stock (Eq, Ord, Show)+++data State = State+    { buildState :: Processed Text BuildState+    , timeZone :: TimeZone+    , route :: Route+    , testFilter :: TestFilter+    }+++data TestFilter = TestFilterAll | TestFilterFailedOnly+    deriving stock (Bounded, Enum, Eq)+++cycleTestFilter :: TestFilter -> TestFilter+cycleTestFilter x = if x == maxBound then minBound else succ x+++data Processed e a+    = Waiting+    | Failure e+    | Success a+++currentRoute :: State -> Route+currentRoute = (.route)+++viewToViewport :: Route -> Maybe Viewports+viewToViewport = \case+    Route.Tests -> Just TestViewport+    Route.Main -> Just DiagnosticViewport+    _ -> Nothing+++navigate :: Route -> State -> State+navigate route s = s {route}+++init :: (Clock :> es) => Eff es State+init = do+    tz <- Clock.currentTimeZone+    pure+        State+            { buildState = Waiting+            , timeZone = tz+            , route = Route.Main+            , testFilter = minBound+            }
+ src/Tricorder/CLI/UI/View.hs view
@@ -0,0 +1,556 @@+module Tricorder.CLI.UI.View (mkAttrMap, view) where++import Atelier.Effects.Clock (TimeZone)+import Atelier.Time (Millisecond, toMicroseconds)+import Brick+    ( AttrMap+    , AttrName+    , VScrollBarOrientation (..)+    , ViewportType (..)+    , Widget+    , attrMap+    , attrName+    , vBox+    , viewport+    )+import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList, ppBinding)+import Brick.Widgets.Core+    ( Padding (..)+    , emptyWidget+    , hBox+    , padLeft+    , txt+    , txtWrap+    , withClickableVScrollBars+    , withDefAttr+    , withVScrollBarHandles+    , withVScrollBars+    )+import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime)+import System.FilePath (isAbsolute)++import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Graphics.Vty.Attributes qualified as Attr+import Graphics.Vty.Attributes.Color qualified as Color++import Tricorder.Build (BuildPhase, BuildResult, BuildState, Diagnostic, Severity (..))+import Tricorder.CLI.UI.Keys (KeyEvent, keybindForRoute, viewKeybindings)+import Tricorder.CLI.UI.Misc (emphasis, err, hBoxSpaced, ok, subtle, vBoxSpaced, warn)+import Tricorder.CLI.UI.Route (Route)+import Tricorder.CLI.UI.State (Processed (..), State (..), TestFilter (..), Viewports (..), currentRoute)+import Tricorder.Daemon.DaemonInfo (DaemonInfo (..))+import Tricorder.Session.Target (Target, renderTarget)+import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+import Tricorder.TestOutput (stripGhciNoise)++import Tricorder.Build qualified as Build+import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Build.Test qualified as Test+import Tricorder.CLI.UI.Keys qualified as Keys+import Tricorder.CLI.UI.Route qualified as Route+import Tricorder.Version qualified as Version+++mkAttrMap :: State -> AttrMap+mkAttrMap =+    const+        ( attrMap+            Attr.defAttr+            [ (attrName "ok", Attr.withForeColor Attr.defAttr Color.green)+            , (attrName "warning", Attr.withForeColor Attr.defAttr Color.yellow)+            , (attrName "error", Attr.withForeColor Attr.defAttr Color.red)+            , (attrName "emphasis", Attr.withStyle Attr.defAttr Attr.bold)+            , (attrName "subtle", Attr.withForeColor Attr.defAttr $ Color.rgbColor @Int 148 148 148)+            ]+        )+++view :: KeyConfig KeyEvent -> State -> [Widget Viewports]+view kc ws =+    [ vBoxSpaced+        1+        [ vBox+            [ viewAppHeader ws+            , viewTabs kc ws+            ]+        , case currentRoute ws of+            Route.Help ->+                viewHelp kc+            Route.DaemonInfo ->+                viewDaemonInfo ws+            Route.Tests ->+                viewTests ws+            Route.Main ->+                viewMain ws+            Route.Evals ->+                viewEvals ws+        ]+    ]+++viewTabs :: KeyConfig KeyEvent -> State -> Widget n+viewTabs kc ws =+    hBoxSpaced 1+        $ intersperse (subtle $ txt "-")+        $ viewRouteTab kc ws <$> universe @Route+++viewRouteTab :: KeyConfig KeyEvent -> State -> Route -> Widget n+viewRouteTab kc ws route =+    style $ txt $ Route.name route <> keyBind+  where+    style = if route == currentRoute ws then id else subtle+    showBinding = (" " <>) . ("[" <>) . (<> "]") . ppBinding+    keyBind = maybe "" showBinding $ keybindForRoute kc route+++viewDaemonInfo :: State -> Widget Viewports+viewDaemonInfo ws =+    withBuildState ws (viewExpandedDaemonInfo . (.daemonInfo))+++viewTests :: State -> Widget Viewports+viewTests ws =+    withBuildState ws (viewTestResultsPanel ws)+++viewEvals :: State -> Widget Viewports+viewEvals ws =+    withBuildState ws $ viewEvalCommentsPanel ws+++viewMain :: State -> Widget Viewports+viewMain ws = withBuildState ws (viewDefaultPanel ws.timeZone)+++viewHelp :: KeyConfig KeyEvent -> Widget n+viewHelp kc = viewKeybindings kc handlers+  where+    -- The dispatcher is built only to enumerate handler descriptions for the help+    -- view, so the restart action is a no-op here.+    handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher (pure ()) kc)+++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+++viewAppHeader :: State -> Widget n+viewAppHeader ws =+    ok+        $ emphasis+        $ txt+        $ "Tricorder"+            <> maybe+                ""+                (" - " <>)+                (viewHeading ws)+++viewHeading :: State -> Maybe Text+viewHeading ws = case currentRoute ws of+    Route.Tests -> case ws.testFilter of+        TestFilterAll -> Just "Tests"+        TestFilterFailedOnly -> Just "Tests - Failed only"+    Route.Help -> Just "Help"+    Route.DaemonInfo -> Just "Daemon info"+    Route.Main -> Nothing+    Route.Evals -> Just "Eval comments"+++viewDefaultPanel :: TimeZone -> BuildState -> Widget Viewports+viewDefaultPanel tz bs = viewBuildPhase tz bs.phase+++viewTestResultsPanel :: State -> BuildState -> Widget Viewports+viewTestResultsPanel ws bs =+    vBoxSpaced+        1+        [ viewBuildPhaseLine ws.timeZone bs.phase+        , viewTestPanel ws.testFilter (phaseTestRuns bs.phase)+        ]+++viewEvalCommentsPanel :: State -> BuildState -> Widget Viewports+viewEvalCommentsPanel ws bs =+    vBoxSpaced+        1+        [ viewBuildPhaseLine ws.timeZone bs.phase+        , case bs.phase of+            Build.Finished _ postBuild -> viewEvalComments postBuild.evalComments+            Build.PostBuilding _ postBuild -> viewEvalComments postBuild.evalComments+            _ -> txt "Waiting for build..."+        ]+++viewEvalComments :: Eval.Phase -> Widget Viewports+viewEvalComments Eval.Looking = txt "Looking for eval comments..."+viewEvalComments Eval.NoneFound = txt "No eval comments detected"+viewEvalComments (Eval.Found (Eval.Comments results)) =+    vScrollViewport EvalResultsViewport+        $ vBoxSpaced 1+        $ toList+        $ viewEvaluation <$> results+++viewEvaluation :: Eval.Evaluation -> Widget n+viewEvaluation evaluation =+    vBox+        $ [ hBoxSpaced+                1+                [ subtle $ txt "File:"+                , txt $ toText evaluation.file <> ":" <> show evaluation.comment.lineNumber+                ]+          , subtle $ txt "Expression:"+          , txt evaluation.comment.expression+          ]+            <> case evaluation.state of+                Eval.Completed output ->+                    [ subtle $ txt "Result:"+                    , vBox $ txt <$> T.lines output+                    ]+                Eval.Pending ->+                    [ subtle $ txt "Running..."+                    ]+++viewExpandedDaemonInfo :: DaemonInfo -> Widget n+viewExpandedDaemonInfo di =+    vBox+        [ viewVersion+        , viewTargets di.targets+        , viewWatchDirs di.watchDirs+        , viewSockPath di.sockPath+        , viewLogFile di.logFile+        ]+++viewVersion :: Widget n+viewVersion =+    hBoxSpaced+        1+        [ emphasis $ txt "Client version:"+        , txt Version.gitHash+        ]+++viewTargets :: [Target] -> Widget n+viewTargets targets =+    hBoxSpaced+        1+        [ emphasis $ txt "Targets:"+        , if null targets then+            txt "(all)"+          else+            txtWrap (T.intercalate " " (map renderTarget targets))+        ]+++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+    Build.Starting ->+        warn $ txt "Starting..."+    Build.Building testTargets phase ->+        vBoxSpaced+            1+            [ warn $ txt $ "Building (" <> show phase.compiled <> "/" <> show phase.total <> ")..."+            , viewPendingTestTargets testTargets+            ]+    Build.PostBuilding result postBuild ->+        vBoxSpaced+            1+            [ viewBuildResult tz result+            , viewTestRuns postBuild.testSuites+            ]+    Build.Finished result postBuild ->+        vBoxSpaced+            1+            [ viewBuildResult tz result+            , viewTestRuns postBuild.testSuites+            ]+    Build.Failed msg ->+        viewBuildFailed msg+++viewPendingTestTargets :: [TestTarget] -> Widget n+viewPendingTestTargets =+    vBox+        . ([txt "Pending test suites:"] <>)+        . fmap (subtle . txt . renderTestTarget)+++viewBuildFailed :: Text -> Widget Viewports+viewBuildFailed msg =+    vBox+        [ err $ txt "Build command failed"+        , vScrollViewport DiagnosticViewport (vBox $ txtWrap <$> T.lines msg)+        ]+++-- | A vertically-scrollable viewport with clickable scrollbars on the right.+vScrollViewport :: (Ord vp, Show vp) => vp -> Widget vp -> Widget vp+vScrollViewport vp =+    withClickableVScrollBars (\_ _ -> vp)+        . withVScrollBarHandles+        . withVScrollBars OnRight+        . viewport vp Vertical+++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 $ vBox $ 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 :: Test.Suites -> Widget n+viewTestRuns suites = vBox $ uncurry viewTestRun <$> Map.toList suites.getSuites+++viewTestRun :: TestTarget -> Test.Suite -> Widget n+viewTestRun tgt run =+    hBox $ [txt $ renderTestTarget tgt, txt "  "] <> status+  where+    status = case run of+        Test.SuiteRunning Nothing ->+            [ warn $ txt "running..."+            ]+        Test.SuiteRunning (Just p) ->+            [ warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"+            ]+        Test.SuiteErrored e ->+            [ err $ txt "error: "+            , txt e.message+            ]+        Test.SuiteCompleted c ->+            [ viewCompletionStatus c+            ]+++viewCompletionStatus :: Test.SuiteCompletion -> 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 Test.caseFailed 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+    Build.Starting ->+        warn $ txt "Starting..."+    Build.Building _ phase ->+        warn $ txt $ "Building (" <> show phase.compiled <> "/" <> show phase.total <> ")..."+    Build.PostBuilding result _ ->+        viewBuildResultLine tz result+    Build.Finished result _ ->+        viewBuildResultLine tz result+    Build.Failed _ ->+        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 -> Test.Suites+phaseTestRuns (Build.PostBuilding _ postBuild) = postBuild.testSuites+phaseTestRuns (Build.Finished _ postBuild) = postBuild.testSuites+phaseTestRuns _ = Test.Suites mempty+++viewTestPanel :: TestFilter -> Test.Suites -> Widget Viewports+viewTestPanel tvf suites+    | Test.nullSuites suites = subtle $ txt "No test results."+    | otherwise = scrollableRuns tvf suites+++scrollableRuns :: TestFilter -> Test.Suites -> Widget Viewports+scrollableRuns tvf suites =+    vScrollViewport TestViewport+        $ vBox+        $ uncurry (viewTestRunDetail tvf) <$> Map.toList suites.getSuites+++viewTestRunDetail :: TestFilter -> TestTarget -> Test.Suite -> Widget n+viewTestRunDetail tvf tgt = \case+    Test.SuiteRunning Nothing ->+        hBox+            [ txt t+            , txt "  "+            , warn $ txt "running..."+            ]+    Test.SuiteRunning (Just p) ->+        hBox+            [ txt t+            , txt "  "+            , warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"+            ]+    Test.SuiteErrored e ->+        hBoxSpaced+            1+            [ txt t+            , err $ txt "error:"+            , txt e.message+            ]+    Test.SuiteCompleted c ->+        vBox+            [ hBox [txt $ t <> "  ", viewCompletionStatus c]+            , viewTestOutput tvf c+            ]+  where+    t = renderTestTarget tgt+++viewTestOutput :: TestFilter -> Test.SuiteCompletion -> Widget n+viewTestOutput TestFilterAll c =+    padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output)+viewTestOutput TestFilterFailedOnly c+    | not (any Test.caseFailed 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 Test.caseFailed c.testCases+++viewFailedCase :: Test.Case -> Widget n+viewFailedCase tc =+    vBox+        [ err $ txt tc.description+        , case tc.outcome of+            Test.Failed details -> padLeft (Pad 2) $ txtWrap details+            Test.Passed -> emptyWidget+        ]
src/Tricorder/Config.hs view
@@ -1,22 +1,17 @@ module Tricorder.Config     ( LoadedConfig (..)     , runLoadedConfig-    , restartOnConfigChange+    , inputLoadedConfig+    , configFileName     ) 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 Atelier.Effects.Input (Input, runInputEff) 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@@ -55,27 +50,11 @@     runReader cfg act  -restartOnConfigChange-    :: ( Conc :> es-       , Concurrent :> es-       , Debounce FilePath :> es-       , FileWatcher :> es+inputLoadedConfig+    :: ( FileSystem :> es        , Reader ProjectRoot :> es        )-    => Eff es a -> Eff es a-restartOnConfigChange act = do+    => Eff (Input LoadedConfig : es) a -> Eff es a+inputLoadedConfig = runInputEff 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+    loadTricorderConfig projectRoot
− src/Tricorder/Daemon.hs 
@@ -1,97 +0,0 @@-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/Builder.hs view
@@ -0,0 +1,191 @@+module Tricorder.Daemon.Builder+    ( Builder (..)+    , NewLoadResult (..)+    , BuildConsideration (..)+    , BuildFailure (..)+    , build+    , consider+    , with+    , compileBuildResults+    ) where++import Atelier.Effects.Clock (Clock, UTCTime)+import Atelier.Effects.FileWatcher (FileEvent)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Publishing.Pub (Pub)+import Atelier.Time (Millisecond, nominalDiffTime)+import Data.Time (diffUTCTime)+import Effectful (Effect, inject)+import Effectful.Dispatch.Dynamic (reinterpretWith_)+import Effectful.Exception (trySync)+import Effectful.Reader.Static (Reader, ask)+import Effectful.State.Static.Shared (State, get, modify)+import Effectful.TH (makeEffect)+import System.FilePath (normalise)++import Atelier.Effects.Clock qualified as Clock+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Publishing.Pub qualified as Pub+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Effectful.State.Static.Shared qualified as State++import Tricorder.Build (BuildId (..), BuildProgress, BuildResult (..), Diagnostic (..))+import Tricorder.Daemon.Dispatch+    ( BuilderState (..)+    , DiagnosticMap+    , DispatchAction (..)+    , KnownTargetNames (..)+    , dispatch+    , emptyBuilderState+    , filterToWatchDirs+    , mergeDiagnostics+    , preserveFailureVisibility+    )+import Tricorder.Daemon.GhciSession (GhciSession, LoadResult (..))+import Tricorder.Daemon.GhciSession.GhciParser (resolveKnownTargets)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command (Command)+import Tricorder.Session.WatchDirs (WatchDirs)++import Tricorder.Daemon.GhciSession qualified as GhciSession+++data Builder :: Effect where+    Consider :: FilePath -> FileEvent -> Builder m BuildConsideration+    Build :: DispatchAction -> Builder m (Either BuildFailure NewLoadResult)+++data BuildConsideration+    = SkipBuilding+    | ShouldBuild DispatchAction+++data BuildFailure+    = ReloadFailed SomeException+    deriving stock (Show)+++data NewLoadResult = NewLoadResult+    { startTime :: UTCTime+    , endTime :: UTCTime+    , loadResult :: LoadResult+    }+    deriving stock (Eq, Show)+++makeEffect ''Builder+++with+    :: ( Clock :> es+       , GhciSession :> es+       , Log :> es+       , Pub BuildProgress :> es+       , Reader ProjectRoot :> es+       )+    => BuildId+    -> Command+    -> WatchDirs+    -> (BuilderState -> NewLoadResult -> Eff (Builder : es) a)+    -> Eff es (Either SomeException a)+with buildId command watchDirs action = do+    root <- ask+    startTime <- Clock.currentTime+    trySync $ GhciSession.withGhciWith Pub.publish command root \initialLoad controls -> do+        endTime <- Clock.currentTime+        let filteredMsgs = filterToWatchDirs root.getProjectRoot watchDirs initialLoad.diagnostics+        Log.info+            $ mconcat+                [ "GHCi started (session #"+                , show buildId.getBuildId+                , "): "+                , show (length filteredMsgs)+                , " diagnostics"+                ]+        let initialLoadResult = NewLoadResult {startTime, endTime, loadResult = initialLoad}+        let initialBuilderState =+                emptyBuilderState+                    { loadedModules = resolveKnownTargets Map.empty initialLoad+                    , knownTargets = KnownTargetNames (Set.fromList initialLoad.targetNames)+                    }+        reinterpretWith_+            (State.evalState initialBuilderState)+            (action initialBuilderState initialLoadResult)+            \case+                Consider fp event -> considerBuild fp event+                Build dispatchAction ->+                    buildSource (GhciSession.transformControls inject controls) dispatchAction+++considerBuild+    :: (State BuilderState :> es)+    => FilePath+    -> FileEvent+    -> Eff es BuildConsideration+considerBuild fp event = do+    builderState <- get+    let known = Map.lookup (normalise fp) builderState.loadedModules+    case dispatch builderState.knownTargets known fp event of+        Nothing ->+            -- File not loaded in GHCi, so we skip building.+            pure SkipBuilding+        Just action -> do+            pure $ ShouldBuild action+++buildSource+    :: (Clock :> es, State BuilderState :> es)+    => GhciSession.Controls (Eff es)+    -> DispatchAction+    -> Eff es (Either BuildFailure NewLoadResult)+buildSource controls action = do+    res <- trySync do+        startTime <- Clock.currentTime+        res <- runAction controls action+        endTime <- Clock.currentTime+        pure (startTime, endTime, res)++    case res of+        Left e -> do+            pure $ Left $ ReloadFailed e+        Right (startTime, endTime, loadResult) -> do+            modify \s ->+                s+                    { loadedModules = resolveKnownTargets s.loadedModules loadResult+                    , knownTargets = KnownTargetNames (Set.fromList loadResult.targetNames)+                    }+            pure $ Right $ NewLoadResult {startTime, endTime, loadResult}+++compileBuildResults+    :: ProjectRoot+    -> WatchDirs+    -> DiagnosticMap+    -> NewLoadResult+    -> (DiagnosticMap, BuildResult)+compileBuildResults (ProjectRoot projectRoot) watchDirs diagnosticMap newLoadResult =+    (merged, buildResult)+  where+    NewLoadResult {startTime, endTime, loadResult} = newLoadResult+    merged = mergeDiagnostics diagnosticMap filteredResult+    filteredResult =+        loadResult+            { GhciSession.diagnostics =+                preserveFailureVisibility loadResult.diagnostics+                    $ filterToWatchDirs projectRoot watchDirs loadResult.diagnostics+            }+    buildResult =+        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 merged+            }+++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
+ src/Tricorder/Daemon/Core.hs view
@@ -0,0 +1,392 @@+module Tricorder.Daemon.Core (main) where++import Atelier.Config (LoadedConfig)+import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Debounce (Debounce)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.FileWatcher (FileEvent, FileWatcher)+import Atelier.Effects.Input (Input)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Publishing (runPubSub_)+import Atelier.Effects.Publishing.Pub (Pub)+import Atelier.Effects.Publishing.Sub (Sub)+import Data.List (isSuffixOf)+import Effectful.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)+import Effectful.Concurrent.STM (Concurrent, atomically, newEmptyTMVar, takeTMVar, writeTMVar)+import Effectful.Reader.Static (Reader)+import Effectful.State.Static.Shared (State)+import Relude.Extra.Tuple (dup)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.FileWatcher qualified as FileWatcher+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Publishing.Pub qualified as Pub+import Atelier.Effects.Publishing.Sub qualified as Sub+import Data.Map.Strict qualified as Map+import Effectful.Reader.Static qualified as Reader+import Effectful.State.Static.Shared qualified as State++import Tricorder.Build (BuildId, BuildPhase, BuildResult, PostBuild (..), Severity (..))+import Tricorder.Build.Changes (CabalChangeDetected (..), SourceChangeDetected (..))+import Tricorder.Daemon.Builder+    ( BuildConsideration (..)+    , BuildFailure+    , Builder+    , NewLoadResult+    , compileBuildResults+    )+import Tricorder.Daemon.Dispatch+    ( BuilderState (..)+    , DispatchAction+    , emptyBuilderState+    )+import Tricorder.Daemon.EvalCommentRunner+    ( EvalCommentRunner+    , findEvalCommentsInModules+    )+import Tricorder.Daemon.GhciSession (GhciSession)+import Tricorder.Daemon.GhciSession.GhciParser+    ( LoadResult+    , LoadedModule (..)+    , resolveKnownTargets+    )+import Tricorder.Daemon.TestRunner (TestRunner)+import Tricorder.Daemon.Watch (WatchedFile)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Session (..), loadSession)+import Tricorder.Session.CabalFile (CabalFile)+import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+import Tricorder.Session.TestTimeout (TestTimeout)+import Tricorder.Waiters (Waiters)++import Tricorder.Build qualified as Build+import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Build.Test qualified as Test+import Tricorder.Config qualified as Config+import Tricorder.Daemon.Builder qualified as Builder+import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner+import Tricorder.Daemon.TestRunner qualified as TestRunner+import Tricorder.Daemon.Watch qualified as Watch+import Tricorder.Waiters qualified as Waiters+++data ReloadSession = ReloadSession+data RestartBuilder = RestartBuilder+data ReloadBuilder = ReloadBuilder FilePath FileEvent+++-- | Top of the build loop. Responsible for handling changes to the Tricorder+-- config, as well as setting up other build-specific effects.+main+    :: ( Chan :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce FilePath :> es+       , EvalCommentRunner :> es+       , FileSystem :> es+       , FileWatcher :> es+       , GhciSession :> es+       , Input LoadedConfig :> es+       , Input [CabalFile] :> es+       , Log :> es+       , Pub BuildPhase :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , TestRunner :> es+       , Waiters :> es+       )+    => Eff es Void+main = runPubSub_ @ReloadSession+    . runPubSub_ @WatchedFile+    . runPubSub_ @CabalChangeDetected+    . runPubSub_ @SourceChangeDetected+    . runPubSub_ @RestartBuilder+    . runPubSub_ @ReloadBuilder+    $ Conc.restartableFork waitForReloadSession do+        root <- Reader.ask+        session <- loadSession+        Conc.fork_ $ watchConfigFile root++        Conc.fork_ $ Watch.files root session+        Conc.fork_ $ Sub.listen_ Watch.publishChange++        Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) -> do+            needsSessionReload <- shouldReloadSession session+            if needsSessionReload then+                Pub.publish ReloadSession+            else+                Pub.publish RestartBuilder+        Conc.fork_ $ Sub.listen_ \(SourceChangeDetected fp event) ->+            Pub.publish $ ReloadBuilder fp event++        State.evalState emptyBuilderState $ withSession session+  where+    waitForReloadSession = Waiters.wait $ Sub.listenOnce_ @ReloadSession+++shouldReloadSession+    :: ( FileSystem :> es+       , Input LoadedConfig :> es+       , Input [CabalFile] :> es+       , Log :> es+       , Reader ProjectRoot :> es+       )+    => Session -> Eff es Bool+shouldReloadSession oldSession = do+    newSession <- loadSession+    pure $ newSession /= oldSession+++watchConfigFile+    :: ( Debounce FilePath :> es+       , FileWatcher :> es+       , Pub ReloadSession :> es+       )+    => ProjectRoot -> Eff es Void+watchConfigFile root = do+    FileWatcher.watchFilePathsDebounced+        [FileWatcher.dirWhere root.getProjectRoot (Config.configFileName `isSuffixOf`)]+        \_ _ -> Pub.publish $ ReloadSession+++-- | For a given session, handles controlling the build process itself,+-- restarting it as necessary.+withSession+    :: ( Clock :> es+       , Conc :> es+       , Concurrent :> es+       , EvalCommentRunner :> es+       , GhciSession :> es+       , Log :> es+       , Pub BuildPhase :> es+       , Reader ProjectRoot :> es+       , State BuildId :> es+       , State BuilderState :> es+       , Sub ReloadBuilder :> es+       , Sub RestartBuilder :> es+       , TestRunner :> es+       , Waiters :> es+       )+    => Session -> Eff es Void+withSession session = do+    Conc.restartableFork (Waiters.wait $ Sub.listenOnce_ @RestartBuilder) do+        buildId <- State.state (\s -> (s, s + 1))+        runSession buildId session+++-- | Starts the initial build with GHCi, and waits for source changes.+runSession+    :: ( Clock :> es+       , Conc :> es+       , Concurrent :> es+       , EvalCommentRunner :> es+       , GhciSession :> es+       , Log.Log :> es+       , Pub BuildPhase :> es+       , Reader ProjectRoot :> es+       , State BuilderState :> es+       , Sub ReloadBuilder :> es+       , TestRunner :> es+       , Waiters :> es+       )+    => BuildId -> Session -> Eff es ()+runSession buildId session = do+    Log.info $ "Starting session " <> show buildId.getBuildId+    Pub.publish Build.Starting+    startupError <- fmap (either id absurd)+        $ Pub.map (Build.Building session.testTargets)+        $ Builder.with buildId session.command session.watchDirs \_ initialLoad -> do+            processPostBuild session $ Right initialLoad+            Log.debug "Waiting for reload"+            newestReloadEvent <- atomically newEmptyTMVar+            cancelSem <- newEmptyMVar+            let requestCancel = tryPutMVar cancelSem ()+                checkCancel = takeMVar cancelSem+            Conc.fork_ $ Sub.listen_ @ReloadBuilder \event -> do+                atomically $ writeTMVar newestReloadEvent event+                Waiters.without do+                    Pub.publish Build.Starting+                    Log.debug "Cancelling current build"+                    requestCancel+            forever do+                event <- atomically $ takeTMVar newestReloadEvent+                Conc.restartableFork checkCancel+                    $ waitForReload session event++    Pub.publish $ Build.Failed $ show startupError+++-- | Handles source changes as they come, determining whether the source change+-- detected warrants a rebuild.+waitForReload+    :: ( Builder :> es+       , Conc :> es+       , EvalCommentRunner :> es+       , Log :> es+       , Pub BuildPhase :> es+       , Reader ProjectRoot :> es+       , State BuilderState :> es+       , TestRunner :> es+       )+    => Session -> ReloadBuilder -> Eff es ()+waitForReload session (ReloadBuilder fp event) = do+    Log.debug $ "Considering " <> toText fp+    consideration <- Builder.consider fp event+    case consideration of+        SkipBuilding -> do+            Log.debug $ "Skipping " <> toText fp+            pure ()+        ShouldBuild action -> do+            Log.debug $ "Should build " <> toText fp+            processSource session action+    Log.info "Reload finished"+++-- | Rebuilds the project on source change.+processSource+    :: ( Builder :> es+       , Conc :> es+       , EvalCommentRunner :> es+       , Log :> es+       , Pub BuildPhase :> es+       , Reader ProjectRoot :> es+       , State BuilderState :> es+       , TestRunner :> es+       )+    => Session+    -> DispatchAction+    -> Eff es ()+processSource session action = do+    res <- Builder.build action+    Log.debug "Finished build"+    processPostBuild session res+++processPostBuild+    :: ( Conc :> es+       , EvalCommentRunner :> es+       , Log :> es+       , Pub BuildPhase :> es+       , Reader ProjectRoot :> es+       , State BuilderState :> es+       , TestRunner :> es+       )+    => Session -> Either BuildFailure NewLoadResult -> Eff es ()+processPostBuild session = \case+    Left buildFailure -> do+        Log.debug "Build failure"+        Pub.publish $ Build.Failed $ show buildFailure+    Right newLoadResult -> do+        Log.debug "Built"+        buildResult <- newLoadResultToBuildResult session newLoadResult+        let initialPostBuild = PostBuild mempty Eval.Looking+        Pub.publish $ Build.PostBuilding buildResult initialPostBuild+        State.evalState initialPostBuild $ Conc.scoped do+            evalCommentsP <-+                Conc.fork+                    $ Pub.consume (updateEvalComments buildResult)+                    $ runEvalComments session newLoadResult.loadResult+            testsP <-+                Conc.fork+                    $ Pub.consume (updateTestSuites buildResult)+                    $ runTests session buildResult+            evalComments <- Conc.await evalCommentsP+            Log.debug "Eval comments finished"+            tests <- Conc.await testsP+            Log.debug "Tests finished"+            Pub.publish $ Build.Finished buildResult $ PostBuild tests evalComments+  where+    updateEvalComments buildResult evalComments = do+        newPostBuild <- State.state \postBuild -> dup $ postBuild {evalComments}+        Pub.publish $ Build.PostBuilding buildResult newPostBuild+    updateTestSuites buildResult testSuites = do+        newPostBuild <- State.state \postBuild -> dup $ postBuild {testSuites}+        Pub.publish $ Build.PostBuilding buildResult newPostBuild+++runEvalComments+    :: ( EvalCommentRunner :> es+       , Pub Eval.Phase :> es+       , State BuilderState :> es+       )+    => Session -> LoadResult -> Eff es Eval.Phase+runEvalComments session loadResult = do+    builderState <- State.get @BuilderState+    evalComments <- findEvalCommentsInModules $ resolveKnownTargets builderState.loadedModules loadResult++    case nonEmpty evalComments of+        Nothing -> pure Eval.NoneFound+        Just nonEmptyComments -> do+            let pendingComments =+                    sconcat $ (\(lm, ecs) -> toPending lm.relPath <$> ecs) <$> nonEmptyComments+            Pub.publish $ Eval.Found $ Eval.Comments pendingComments+            evaluatedComments <- EvalCommentRunner.evaluateComments session.command nonEmptyComments+            pure $ Eval.Found $ Eval.Comments evaluatedComments+  where+    toPending file comment =+        Eval.Evaluation+            { file+            , comment+            , state = Eval.Pending+            }+++runTests+    :: ( Log :> es+       , Pub Test.Suites :> es+       , TestRunner :> es+       )+    => Session -> BuildResult -> Eff es Test.Suites+runTests session buildResult+    | hasTargets session.testTargets && noErrors buildResult.diagnostics =+        runTestsForTargets session.testTimeout session.testTargets+    | otherwise = pure mempty+  where+    hasTargets = not . null+    noErrors = all \d -> d.severity /= SError+++runTestsForTargets+    :: ( Log :> es+       , Pub Test.Suites :> es+       , TestRunner :> es+       )+    => TestTimeout+    -> [TestTarget]+    -> Eff es Test.Suites+runTestsForTargets testTimeout testTargets = do+    Pub.publish $ Test.Suites initial+    Log.info $ "Running " <> show (length testTargets) <> " test suite(s)"+    fmap Test.Suites . State.execState initial $ traverse_ go testTargets+  where+    initial = Map.fromList $ (,Test.SuiteRunning Nothing) <$> testTargets+    go target = do+        Log.info $ "Running tests: " <> renderTestTarget target+        finishedSuite <-+            TestRunner.runTestSuite+                ( \suite -> do+                    updated <- State.state $ dup . Map.insert target suite+                    Pub.publish $ Test.Suites updated+                )+                testTimeout+                target+        updated <- State.state $ dup . Map.insert target finishedSuite+        Pub.publish $ Test.Suites updated+++newLoadResultToBuildResult+    :: (Reader ProjectRoot :> es, State BuilderState :> es)+    => Session -> NewLoadResult -> Eff es BuildResult+newLoadResultToBuildResult session newLoadResult = do+    root <- Reader.ask+    State.state \s ->+        let (newDiagnosticMap, buildResult) =+                compileBuildResults+                    root+                    session.watchDirs+                    s.diagnosticMap+                    newLoadResult+        in  (buildResult, s {diagnosticMap = newDiagnosticMap})
+ src/Tricorder/Daemon/DaemonInfo.hs view
@@ -0,0 +1,57 @@+module Tricorder.Daemon.DaemonInfo+    ( DaemonInfo (..)+    , load+    , runInput+    ) where++import Atelier.Effects.Input (Input, input, runInputEff)+import Data.Aeson (FromJSON (..), ToJSON (..))+import Effectful.Reader.Static (Reader, ask)+import GHC.Generics (Generically (..))+import System.FilePath (makeRelative)++import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..))+import Tricorder.Session (Session (..))+import Tricorder.Session.Target (Target)+import Tricorder.Session.WatchDirs (WatchDirs (..))+++data DaemonInfo = DaemonInfo+    { targets :: [Target]+    , watchDirs :: [FilePath]+    , sockPath :: FilePath+    , logFile :: FilePath+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically DaemonInfo+++load+    :: ( Input Session :> es+       , Reader LogPath :> es+       , Reader ProjectRoot :> es+       , Reader SocketPath :> es+       )+    => Eff es DaemonInfo+load = do+    session <- input+    ProjectRoot projectRoot <- ask+    SocketPath sockPath <- ask+    LogPath logFile <- ask+    pure+        $ DaemonInfo+            { targets = session.targets+            , watchDirs = map (makeRelative projectRoot) session.watchDirs.getWatchDirs+            , sockPath+            , logFile+            }+++runInput+    :: ( Input Session :> es+       , Reader LogPath :> es+       , Reader ProjectRoot :> es+       , Reader SocketPath :> es+       )+    => Eff (Input DaemonInfo : es) a -> Eff es a+runInput = runInputEff load
+ src/Tricorder/Daemon/Dispatch.hs view
@@ -0,0 +1,202 @@+module Tricorder.Daemon.Dispatch+    ( BuilderState (..)+    , DiagnosticMap+    , DispatchAction (..)+    , KnownTargetNames (..)+    , dispatch+    , emptyBuilderState+    , fileMatchesAnyTarget+    , filterToWatchDirs+    , mergeDiagnostics+    , preserveFailureVisibility+    ) where++import Atelier.Effects.FileWatcher (FileEvent (..))+import System.FilePath (isAbsolute, normalise, splitDirectories, takeExtension, (</>))++import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.Build (Diagnostic (..), Severity (..))+import Tricorder.Daemon.GhciSession.GhciParser+    ( LoadResult (..)+    , LoadedModule (..)+    , isLocationLess+    , pathSuffixesAsModuleName+    , unattributedFailure+    )+import Tricorder.Session.WatchDirs (WatchDirs (..))+++-- | 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)+++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.+--+-- Location-less diagnostics (see 'isLocationLess') are never keyed to a real+-- source file, so they would never appear in 'compiledFiles' and would persist+-- forever once raised. They describe the current load's outcome, so we clear+-- them every cycle and let this cycle's 'diagnostics' re-add them if the+-- failure is still present.+mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap+mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} =+    let retained = Map.filterWithKey (\f _ -> not (isLocationLess f)) prev+        cleared = foldr Map.delete retained compiledFiles+        newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics]+    in  Map.union newByFile cleared+++-- | 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.+--+-- @:show targets@ entries are either dotted module names (e.g.+-- @Tricorder.CLI.Main@) or file paths (e.g. @app/Main.hs@). GHCi uses the path+-- form when a module name is ambiguous across home units — i.e. every+-- executable/test 'Main'. We match both forms.+--+-- The path form matters because a /failed/ executable 'Main' drops out of+-- @:show modules@ but survives in @:show targets@ as its path. Without matching+-- it, fixing the executable would dispatch a no-op 'Add' instead of a 'Reload',+-- leaving the diagnostic stale.+fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool+fileMatchesAnyTarget (KnownTargetNames targets) fp =+    any (`Set.member` targets) (pathSuffixesAsModuleName fp)+        || any (pathTargetMatches fp . toString) (Set.toList targets)+++-- | Whether a path-shaped @:show targets@ entry refers to the given file,+-- compared on directory-segment boundaries (so @app/Main.hs@ matches+-- @./tricorder/app/Main.hs@ but @pp/Main.hs@ does not). Module-name targets+-- (no @.hs@ extension) are left to the module-name branch above.+pathTargetMatches :: FilePath -> FilePath -> Bool+pathTargetMatches file target =+    takeExtension target == ".hs"+        && splitDirectories (normalise target) `List.isSuffixOf` splitDirectories (normalise file)+++-- | A GHCi command to issue in response to a source file change.+data DispatchAction+    = Reload+    | 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.+--+-- Location-less diagnostics (see 'isLocationLess') are always kept: they carry+-- no path to test against a watch dir, but they represent genuine build-level+-- failures (e.g. a home-unit GHC plugin that can't load under+-- @--enable-multi-repl@) that must not be dropped, or the build would silently+-- read as clean.+filterToWatchDirs :: FilePath -> WatchDirs -> [Diagnostic] -> [Diagnostic]+filterToWatchDirs _ (WatchDirs []) diags = diags+filterToWatchDirs projectRoot (WatchDirs watchDirs) diags =+    filter (\d -> isLocationLess d.file || isUnderAnyWatchDir d.file) diags+  where+    absWatchDirs = map toAbsWd watchDirs+    toAbsWd wd+        | wd == "." = projectRoot+        | isAbsolute wd = wd+        | otherwise = projectRoot </> wd+    isUnderAnyWatchDir file+        | isCPPMangledFile file = False+        | isAbsolute file =+            any (\wd -> (wd ++ "/") `isPrefixOf` file || wd == file) absWatchDirs+        | otherwise =+            let absFile = projectRoot </> normalizeRelativePath file+            in  any (\wd -> (wd ++ "/") `isPrefixOf` absFile || wd == absFile) absWatchDirs+    isCPPMangledFile = ("In file included from" `isPrefixOf`)+    normalizeRelativePath file+        -- GHCi reports filenames relative to the project root for+        -- single-package repos. E.g. "src/Foo/Bar.hs", instead of+        -- an absolute path or a "./" prefixed path.+        | "./" `isPrefixOf` file = drop 2 file+        | otherwise = file+++-- | Keep a failed build from ever reading as clean after watch-dir filtering.+--+-- 'filterToWatchDirs' drops diagnostics outside the watched directories. If a+-- load failed but every error it produced lay outside those dirs (e.g. a+-- compile error in a sibling home unit not under @watchDirs@), filtering would+-- leave no diagnostics and the broken build would look green. Detecting that an+-- error was present /before/ filtering but none survived, we re-attach the+-- location-less synthetic failure (which filtering always keeps) so the failure+-- still surfaces.+--+-- Takes the pre-filter diagnostics and the post-filter diagnostics; returns the+-- post-filter list, with the synthetic failure appended only when needed.+preserveFailureVisibility :: [Diagnostic] -> [Diagnostic] -> [Diagnostic]+preserveFailureVisibility raw filtered+    | any isError raw && not (any isError filtered) = filtered ++ [unattributedFailure]+    | otherwise = filtered+  where+    isError d = d.severity == SError
+ src/Tricorder/Daemon/EvalCommentRunner.hs view
@@ -0,0 +1,156 @@+module Tricorder.Daemon.EvalCommentRunner+    ( -- * Effect+      EvalCommentRunner (..)+    , evaluateComments+    , findEvalCommentsInModules++      -- * Interpreters+    , run+    ) where++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.File (File)+import Atelier.Effects.FileSystem (FileSystem, readFileBs)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Process (Process)+import Atelier.Effects.Timeout (Timeout)+import Data.Default (def)+import Data.Text.Encoding (decodeUtf8Lenient)+import Data.Traversable (for)+import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic (interpretWith_)+import Effectful.Exception (trySync)+import Effectful.Reader.Static (Reader, ask)+import Effectful.TH (makeEffect)++import Atelier.Effects.Log qualified as Log+import Data.Map.Strict qualified as Map+import Data.Text qualified as T++import Tricorder.Daemon.GhciSession.GhciParser (LoadedModule (..))+import Tricorder.Daemon.GhciSession.GhciProcess (execGhci, withGhciProcess)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command (Command)++import Tricorder.Build.EvalComment qualified as Eval+++data EvalCommentRunner :: Effect where+    -- | Scan all loaded source files for eval comments and evaluate them, each+    -- in a fresh GHCi session started in that file's module context.+    EvaluateComments+        :: Command+        -> NonEmpty (LoadedModule, NonEmpty Eval.Comment)+        -> EvalCommentRunner m (NonEmpty Eval.Evaluation)+    -- | Extract eval comments from provided source files. Returns a map of all+    -- files that have at least 1 eval comment.+    FindEvalCommentsInModules+        :: Map FilePath LoadedModule+        -> EvalCommentRunner m [(LoadedModule, NonEmpty Eval.Comment)]+++makeEffect ''EvalCommentRunner+++-- | Production interpreter: spawns one short-lived @cabal repl@ session per+-- source file that contains at least one eval comment, then runs each+-- eval comment in that module's context.+run+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , FileSystem :> es+       , Log :> es+       , Process :> es+       , Reader ProjectRoot :> es+       , Timeout :> es+       )+    => Eff (EvalCommentRunner : es) a -> Eff es a+run act = do+    interpretWith_ act \case+        FindEvalCommentsInModules loadedModules -> do+            concat <$> for (Map.toList loadedModules) \(absPath, lm) -> do+                fileResult <- trySync $ readFileBs absPath+                pure $ case fileResult of+                    Left _ -> []+                    Right bs ->+                        case Eval.findComments $ decodeUtf8Lenient bs of+                            [] -> []+                            x : xs -> [(lm, x :| xs)]+        EvaluateComments command moduleComments -> do+            fmap sconcat $ for moduleComments \(lm, comments) -> do+                runFileEvals+                    command+                    lm.relPath+                    lm.moduleName+                    comments+++-- ---------------------------------------------------------------------------+-- Internal helpers++-- | Spawn a fresh @cabal repl@ session for one source file and run all of its+-- eval comments in that module's context. Returns an 'Evaluation' for each+-- comment; on session startup failure returns a single error evaluation.+--+-- The process is registered in @currentProcRef@ as soon as @cabal repl@ has+-- it running (before the initial compile drain), so that a concurrent+-- 'InterruptCurrent' can terminate it promptly.+runFileEvals+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Process :> es+       , Reader ProjectRoot :> es+       , Timeout :> es+       )+    => Command+    -> FilePath+    -- ^ Relative path to the source file (stored in results).+    -> Text+    -- ^ Module name (e.g. @"Tricorder.Builder"@), used to load the module+    -- in interpreted mode so that its full local scope is available.+    -> NonEmpty Eval.Comment+    -> Eff es (NonEmpty Eval.Evaluation)+runFileEvals cmd relPath moduleName comments = do+    ProjectRoot projectRoot <- ask+    let noProgress = \_ -> pure ()+        noSetup = \_ -> pure ()+        wrapForGhci expr+            | T.elem '\n' expr = ":{" <> "\n" <> expr <> "\n" <> ":}"+            | otherwise = expr+    sessionResult <- trySync+        $ withGhciProcess def cmd projectRoot noProgress noSetup \ghci _ -> do+            _ <- execGhci ghci (":load *" <> moduleName) noProgress+            for comments \comment -> do+                outputResult <- trySync $ execGhci ghci (wrapForGhci comment.expression) noProgress+                pure+                    Eval.Evaluation+                        { file = relPath+                        , comment+                        , state = Eval.Completed $ case outputResult of+                            Left ex -> "error: " <> toText (displayException ex)+                            Right ls -> T.unlines ls+                        }+    case sessionResult of+        Right results -> pure results+        Left ex -> do+            let errMsg =+                    "EvalRunner: session startup failed for "+                        <> toText relPath+                        <> ": "+                        <> toText (displayException ex)+            Log.warn errMsg+            pure+                $ Eval.Evaluation+                    { file = relPath+                    , comment =+                        Eval.Comment+                            { lineNumber = 0+                            , expression = "<no expression>"+                            }+                    , state = Eval.Completed errMsg+                    }+                    :| []
+ src/Tricorder/Daemon/GhciSession.hs view
@@ -0,0 +1,165 @@+module Tricorder.Daemon.GhciSession+    ( -- * Effect+      GhciSession+    , Controls (..)+    , transformControls+    , withGhciWith+    , withGhci++      -- * Types+    , LoadResult (..)+    , LoadedModule (..)++      -- * Interpreters+    , runGhciSession+    , runGhciSessionScripted+    ) where++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.File (File)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Process (Process)+import Atelier.Effects.Publishing.Pub (Pub)+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 Atelier.Effects.Publishing.Pub qualified as Pub++import Tricorder.Build (BuildProgress (..))+import Tricorder.Daemon.GhciSession.GhciParser+    ( GhciLoading (..)+    , LoadResult (..)+    , LoadedModule (..)+    )+import Tricorder.Daemon.GhciSession.GhciProcess (addGhci, collectGhciResult, interruptGhci, reloadGhci, unaddGhci, withGhciProcess)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command (Command)+++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.+    WithGhciWith+        :: (BuildProgress -> m ())+        -- ^ Action to run when reporting progress+        -> Command+        -> 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+++transformControls :: (forall a. m a -> n a) -> Controls m -> Controls n+transformControls f ctrls =+    Controls+        { reload = f ctrls.reload+        , interrupt = f ctrls.interrupt+        , add = f . ctrls.add+        , unadd = f . ctrls.unadd+        }+++withGhci+    :: (GhciSession :> es, Pub BuildProgress :> es)+    => Command+    -> ProjectRoot+    -> (LoadResult -> Controls (Eff es) -> Eff es a)+    -> Eff es a+withGhci cmd root handler = do+    withGhciWith Pub.publish cmd root handler+++-- | 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+            WithGhciWith _ _ _ 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.Daemon.GhciSession.GhciProcess'+-- and 'Tricorder.Daemon.GhciSession.GhciParser'.+runGhciSession+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Process :> es+       , Timeout :> es+       )+    => Eff (GhciSession : es) a -> Eff es a+runGhciSession = interpret $ \env -> \case+    WithGhciWith onProgress cmd (ProjectRoot dir) handler -> do+        localLift env (ConcUnlift Persistent Unlimited) \liftEff ->+            localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do+                let reportProgress loading =+                        unlift+                            $ onProgress+                            $ BuildProgress+                                { compiled = loading.index+                                , total = loading.total+                                }+                withGhciProcess def cmd dir reportProgress (\_ -> pure ()) \process startupLines -> do+                    initialResult <- collectGhciResult process startupLines dir+                    unlift+                        $ handler initialResult+                        $ transformControls liftEff+                        $ Controls+                            { reload = reloadGhci process dir reportProgress+                            , interrupt = interruptGhci process+                            , add = \fp -> addGhci process fp dir reportProgress+                            , unadd = \mn -> unaddGhci process mn dir reportProgress+                            }
+ src/Tricorder/Daemon/GhciSession/GhciParser.hs view
@@ -0,0 +1,669 @@+module Tricorder.Daemon.GhciSession.GhciParser+    ( GhciLoad (..)+    , GhciLoading (..)+    , GhciMessage (..)+    , GhciSeverity (..)+    , LoadOutcome (..)+    , LoadResult (..)+    , LoadedModule (..)+    , Position (..)+    , collectResult+    , collectResultCustom+    , isLocationLess+    , reloadFailed+    , parseProgressLine+    , parseReload+    , parseShowModules+    , parseShowTargets+    , pathSuffixesAsModuleName+    , resolveKnownTargets+    , stripAnsi+    , extractTitle+    , toAbsolute+    , toRelative+    , unattributedFailure+    ) 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.Build (Diagnostic (..), Severity (..))+++-- | 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)+++-- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@+-- on success or @Failed, …@ on failure.+data LoadOutcome = LoadSucceeded | LoadFailed+    deriving stock (Eq, Show)+++-- | A structured item from GHCi's reload output.+data GhciLoad+    = GLoading GhciLoading+    | GMessage GhciMessage+    | GLoadConfig FilePath+    | GSummary LoadOutcome+    deriving stock (Eq, Show)+++-- | 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: terminal summary line "Ok, ..." / "Failed, ..."+          fmap Just $ do+            (_, stripped) <-+                satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s)+            pure+                $ GSummary+                $ if "Failed, " `T.isPrefixOf` stripped then LoadFailed else LoadSucceeded+        , -- Pattern: "<no location info>: error:"+          fmap Just $ do+            (origLine, _) <- satisfyStripped ("<no location info>: error:" `T.isPrefixOf`)+            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+            }+++-- | Assemble a 'LoadResult' from the raw reload output plus the @:show+-- modules@ / @:show targets@ output.+--+-- This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload+-- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a+-- location-less failure we don't otherwise attribute to a file), a synthetic+-- error diagnostic is appended so the build can never be reported as clean+-- while GHCi considers it failed.+collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult+collectResult projectRoot reloadLines modules targets =+    let loads = parseReload reloadLines+        base = collectResultCustom projectRoot loads modules targets+        hasError = any (\d -> d.severity == SError) base.diagnostics+    in  if reloadFailed loads && not hasError then+            base {diagnostics = base.diagnostics ++ [unattributedFailure]}+        else+            base+++-- | Synthetic diagnostic for a failed load with no located error. Without a+-- source span it cannot point anywhere, but it stops the build reading as+-- clean and tells the user where to look.+unattributedFailure :: Diagnostic+unattributedFailure =+    Diagnostic+        { severity = SError+        , file = "<no location info>"+        , line = 0+        , col = 0+        , endLine = 0+        , endCol = 0+        , title = "GHCi reported a failed load with no located error"+        , text = "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n"+        }+++-- | Whether GHCi's load ended in failure, decided from the 'GSummary' items+-- 'parseReload' produces — the single place that classifies GHCi's terminal+-- @Ok, …@ / @Failed, …@ summary line.+--+-- GHCi emits the real summary last, after all compilation output. Output+-- produced /during/ the load (a Template Haskell splice, top-level IO run while+-- interpreting) can contain an earlier line that looks like a summary, so only+-- the /last/ 'GSummary' reflects the true outcome.+reloadFailed :: [GhciLoad] -> Bool+reloadFailed loads =+    case [outcome | GSummary outcome <- loads] of+        [] -> False+        outcomes -> List.last outcomes == LoadFailed+++-- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully+-- @\<…\>@-bracketed marker such as @\<no location info\>@ or @\<interactive\>@+-- rather than a real source path. These carry no source span but can still+-- represent genuine build-level failures, so callers treat them specially+-- (kept rather than dropped, cleared every cycle rather than retained).+--+-- We require both the opening @\<@ and a closing @\>@ so a real (if exotic)+-- path that merely starts with @\<@, e.g. @\<generated\>/Foo.hs@, is not+-- mistaken for a marker.+isLocationLess :: FilePath -> Bool+isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f+++-- | Path↔module-name map for the next cycle: this round's @:show modules@+-- plus carryover from @prev@ for targets that failed mid-session and so+-- dropped out. Never-compiled targets are absent here (no path↔name+-- 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] -> [Diagnostic]+toDiagnostics rel loads = mapMaybe toMsg loads+  where+    -- Location-less messages (e.g. @<no location info>@, @<interactive>@) carry+    -- no source span. We keep the *errors* — a @<no location info>@ error is a+    -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in+    -- @--enable-multi-repl@) and must not be silently dropped — but discard+    -- location-less warnings, which are just noise without a file to attach to.+    toMsg (GMessage m) | isLocationLess m.file, m.severity /= GError = Nothing+    toMsg (GMessage m) =+        Just+            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/Daemon/GhciSession/GhciProcess.hs view
@@ -0,0 +1,551 @@+module Tricorder.Daemon.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.Log (Log)+import Atelier.Effects.Process+    ( Process+    , RunningProcess+    , createPipe+    , getStderr+    , getStdin+    , getStdout+    , 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 (finally, throwIO, trySync)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.File qualified as File+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Process qualified as Process+import Data.Text qualified as T++import Tricorder.Daemon.GhciSession.GhciParser+    ( GhciLoading (..)+    , LoadResult (..)+    , collectResult+    , parseProgressLine+    , parseShowModules+    , parseShowTargets+    , stripAnsi+    , unattributedFailure+    )+import Tricorder.Session.Command (Command (..))+++-- | 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+++-- | Set up the GHCi protocol on an already-started process and return its+-- handle together with the output captured during startup.+--+-- The spawn and group teardown are owned by 'withGhciProcess'.+setupGhciProcess+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Timeout :> es+       )+    => Config+    -> RunningProcess Handle Handle Handle+    -> (GhciLoading -> Eff es ())+    -- ^ Called as each @[N of M] Compiling …@ line is streamed during the+    -- initial-build drain, so the UI can update the progress bar live+    -- 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])+setupGhciProcess config p onProgress onReady = do+    let inp = getStdin p+        out = getStdout p+        err = getStderr p+    File.hSetBuffering inp LineBuffering+    File.hSetBuffering out LineBuffering+    File.hSetBuffering err LineBuffering++    -- Register the process for interruption before the (possibly slow) banner+    -- wait, so an interrupt during @cabal repl@ startup can terminate it.+    stateVar <- newTVarIO (Idle 0)+    let ghciProcess =+            GhciProcess+                { 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++    -- 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)+++-- | Run a GHCi @cabal repl@ session for the duration of @action@.+--+-- The session runs in its own process group, so the whole group is torn down on+-- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The+-- action receives the process handle and the output captured during startup.+-- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks.+withGhciProcess+    :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es)+    => Config+    -> Command+    -> FilePath+    -> (GhciLoading -> Eff es ())+    -> (GhciProcess -> Eff es ())+    -> (GhciProcess -> [Text] -> Eff es a)+    -> Eff es a+withGhciProcess config cmd dir onProgress onReady action =+    Process.withProcessGroup processConfig \p -> do+        (ghciProcess, initialLines) <- setupGhciProcess config p onProgress onReady+        action ghciProcess initialLines `finally` quitGhci config ghciProcess+  where+    processConfig =+        setStdin createPipe+            $ setStdout createPipe+            $ setStderr createPipe+            $ setWorkingDir dir+            $ shell (toString cmd.getCommand)+++-- | Execute a command in GHCi and return the combined stdout+stderr output+-- 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 a GHCi process and its whole group.+--+-- Stronger than 'interruptGhci': intended for one-shot processes (such as the+-- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is+-- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT+-- handlers that finalise the current run rather than aborting it. Safe to call+-- from another thread while the session is running.+terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es ()+terminateGhciProcess ghciProcess =+    Process.terminateProcessGroup ghciProcess.handle+++-- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it+-- shut down gracefully before the enclosing 'withGhciProcess' tears down the+-- group. Never throws.+quitGhci :: (File :> es, Process :> es, Timeout :> es) => Config -> GhciProcess -> Eff es ()+quitGhci config ghciProcess = do+    void $ trySync $ do+        File.hPutTextLn ghciProcess.stdin ":quit"+        File.hFlush ghciProcess.stdin+    void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle)+++-- ---------------------------------------------------------------------------+-- 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+       , Timeout :> es+       )+    => Second -> Handle -> Handle -> Eff es ()+waitForBannerOrFail delay out err = 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+                throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured)+            Nothing -> do+                captured <- atomically $ readTVar capturedVar+                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, Log :> es)+    => GhciProcess+    -> [Text]+    -> FilePath+    -> Eff es LoadResult+collectGhciResult process lines' projectRoot = do+    let noProgress = \_ -> pure ()+    moduleLines <- execGhci process ":show modules" noProgress+    targetLines <- execGhci process ":show targets" noProgress+    let result =+            collectResult+                projectRoot+                lines'+                (parseShowModules moduleLines)+                (parseShowTargets targetLines)+    -- A failed load with no located error produces only the synthetic+    -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in+    -- that case, so log the raw GHCi output — it's the only way to see what+    -- actually went wrong, and the synthetic diagnostic points here.+    when (any (== unattributedFailure) result.diagnostics)+        $ Log.info+        $ "GHCi reported a failed load with no located error. Full GHCi output:\n"+            <> T.unlines lines'+    pure result+++-- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events+-- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read.+reloadGhci+    :: (Conc :> es, Concurrent :> es, File :> es, Log :> 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, Log :> 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, Log :> 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/Daemon/Main.hs view
@@ -1,21 +1,18 @@ 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.Env (runEnv) 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.Publishing (runPubSub_) import Atelier.Effects.Timeout (runTimeout) import Data.Default (def) import Effectful (runEff)@@ -24,29 +21,31 @@ import Effectful.State.Static.Shared (evalState)  import Atelier.Effects.Cache.Config qualified as CacheConfig+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Input qualified as Input 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.Build (BuildId (..), BuildPhase)+import Tricorder.Config (inputLoadedConfig)+import Tricorder.Daemon.GhciSession (runGhciSession)+import Tricorder.Logging (runLogging)+import Tricorder.Module (ModuleName, PackageId) import Tricorder.Runtime (runLogPath, runProjectRoot, runRuntimeDir, runSocketPath)+import Tricorder.Session (inputSession)+import Tricorder.Session.CabalFile (inputCabalFiles)+import Tricorder.Socket.UnixSocket (runUnixSocketIO)+import Tricorder.SourceLookup (SourceQuery)+import Tricorder.SourceLookup.Cabal (runCabalIO)+import Tricorder.SourceLookup.GhcPkg (runGhcPkgIO) -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.Daemon.Core qualified as Core+import Tricorder.Daemon.DaemonInfo qualified as DaemonInfo+import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner+import Tricorder.Daemon.TestRunner qualified as TestRunner+import Tricorder.Socket.Server qualified as Server import Tricorder.SourceLookup qualified as SourceLookup import Tricorder.Version qualified as Version-import Tricorder.Watcher qualified as Watcher+import Tricorder.Waiters qualified as Waiters   -- | Run the daemon for the given project root.@@ -60,45 +59,37 @@         . 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+        . inputLoadedConfig         . runChan-        . runPubSub @SessionStore.SessionStoreReloaded-        . runSessionStore+        . inputCabalFiles+        . inputSession         . 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+        . DaemonInfo.runInput+        . runCacheTtl @ModuleName @PackageId+        . runCacheTtl @(PackageId, SourceQuery) @SourceLookup.ModuleSourceResult         . runProcessIO-        . runMetricsServerIO-        . runTestRunnerIO+        . runCabalIO+        . runEnv         . runGhcPkgIO         . runUnixSocketIO         . runGhciSession         . evalState (BuildId 1)-        . evalState @Dispatch.BuilderState Dispatch.emptyBuilderState+        . Input.fromState @BuildId+        . runPubSub_ @BuildPhase+        . EvalCommentRunner.run+        . TestRunner.run+        . Waiters.run         $ do             Log.info $ "Starting tricorder " <> Version.gitHash-            runSystem-                [ Observability.component-                , Watcher.component-                , Builder.component-                , SocketServer.component-                ]+            Conc.fork_ Core.main+            Conc.fork_ Server.main+            Conc.awaitAll
+ src/Tricorder/Daemon/TestRunner.hs view
@@ -0,0 +1,203 @@+module Tricorder.Daemon.TestRunner+    ( -- * Effect+      TestRunner (..)+    , runTestSuite++      -- * Interpreters+    , run+    , runScripted++      -- * Parsing utilities+    , GhciOutcome (..)+    , detectOutcome++      -- * Internal helpers (exported for testing)+    , loadingToProgress+    ) 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.Exception (throwIO)+import Data.Default (def)+import Data.Time.Units (Second)+import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (ConcUnlift))+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic (interpretWith, localUnlift, reinterpret_)+import Effectful.Exception (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.Daemon.GhciSession.GhciParser (GhciLoading (..))+import Tricorder.Daemon.GhciSession.GhciProcess+    ( execGhci+    , withGhciProcess+    )+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command (Command (..))+import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+import Tricorder.Session.TestTimeout (TestTimeout (..))+import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput)++import Tricorder.Build.Test qualified as Test+++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+        :: (Test.Suite -> m ())+        -- ^ Handler for test run progress+        -> TestTimeout+        -> TestTarget+        -> TestRunner m Test.Suite+++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'.+run+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Process :> es+       , Reader ProjectRoot :> es+       , Timeout :> es+       )+    => Eff (TestRunner : es) a -> Eff es a+run act = do+    interpretWith act \env -> \case+        RunTestSuite progressHandler testTimeout target ->+            localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do+                let onProgress = unlift . progressHandler . loadingToProgress+                    noProgress _ = pure ()+                    noReady _ = pure ()+                ProjectRoot projectRoot <- ask+                result <- trySync+                    $ withGhciProcess def (Command $ "cabal repl " <> renderTestTarget target) projectRoot onProgress noReady \ghci _ ->+                        case testTimeout of+                            TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress+                            TestTimeout secs ->+                                let duration = fromIntegral secs :: Second+                                in  maybeToRight secs+                                        <$> timeout duration (execGhci ghci ":main" noProgress)+                case result of+                    Left ex ->+                        pure+                            $ Test.SuiteErrored+                            $ Test.SuiteError {message = show ex}+                    Right (Left secs) -> do+                        Log.warn+                            $ mconcat+                                [ "Test suite "+                                , renderTestTarget target+                                , " timed out after "+                                , show secs+                                , "s"+                                ]+                        pure+                            $ Test.SuiteErrored+                            $ Test.SuiteError+                                { 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 ->+                                        Test.SuiteErrored $ Test.SuiteError {message = msg}+                                    outcome ->+                                        Test.SuiteCompleted+                                            $ Test.SuiteCompletion+                                                { 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.+runScripted+    :: forall es a+     . (IOE :> es)+    => [Either SomeException Test.Suite]+    -> Eff (TestRunner : es) a+    -> Eff es a+runScripted results =+    reinterpret_+        (evalState results)+        (\(RunTestSuite _ _ _) -> popResult)+  where+    popResult :: Eff (State [Either SomeException Test.Suite] : es) Test.Suite+    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+++loadingToProgress :: GhciLoading -> Test.Suite+loadingToProgress loading =+    Test.SuiteRunning+        $ Just+        $ Test.Progress {compiled = loading.index, total = loading.total}+++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/Daemon/Watch.hs view
@@ -0,0 +1,105 @@+module Tricorder.Daemon.Watch+    ( WatchedFile (..)+    , files+    , publishChange+    , specs+    , isCabalFile+    ) where++import Atelier.Effects.Debounce (Debounce)+import Atelier.Effects.FileWatcher+    ( FileEvent+    , FileWatcher+    , Watch+    , containing+    , dirExt+    , dirWhere+    , excluding+    )+import Atelier.Effects.Publishing.Pub (Pub)+import System.FilePath (takeExtension, takeFileName)+import Text.Regex.TDFA (ExecOption (..), blankCompOpt, blankExecOpt, match)+import Text.Regex.TDFA.TDFA (patternToRegex)++import Atelier.Effects.FileWatcher qualified as FileWatcher+import Atelier.Effects.Publishing.Pub qualified as Pub++import Tricorder.Build.Changes+    ( CabalChangeDetected (..)+    , ChangeKind (..)+    , SourceChangeDetected (..)+    )+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Session (..))+import Tricorder.Session.WatchDirs (WatchDirs (..))+import Tricorder.Session.WatchExclusionPatterns (Pattern, WatchExclusionPatterns (..))+++data WatchedFile = WatchedFile+    { path :: FilePath+    , event :: FileEvent+    }+++files+    :: ( Debounce FilePath :> es+       , FileWatcher :> es+       , Pub WatchedFile :> es+       )+    => ProjectRoot -> Session -> Eff es Void+files projectRoot session =+    FileWatcher.watchFilePathsDebounced watches \filePath fileEvent ->+        Pub.publish $ WatchedFile filePath fileEvent+  where+    watches = specs projectRoot session.watchExclusionPatterns session.watchDirs+++publishChange+    :: ( Pub CabalChangeDetected :> es+       , Pub SourceChangeDetected :> es+       )+    => WatchedFile -> Eff es ()+publishChange f =+    case changeKindFor f.path of+        CabalChange -> Pub.publish (CabalChangeDetected f.path f.event)+        SourceChange -> Pub.publish (SourceChangeDetected f.path f.event)+++changeKindFor :: FilePath -> ChangeKind+changeKindFor path+    | isCabalFile path = CabalChange+    | otherwise = SourceChange+++specs :: ProjectRoot -> WatchExclusionPatterns -> WatchDirs -> [Watch]+specs projectRoot watchExclusionPatterns watchDirs =+    sourceWatches (coerce watchExclusionPatterns) (coerce watchDirs)+        <> cabalWatches projectRoot+++sourceWatches :: [Pattern] -> [FilePath] -> [Watch]+sourceWatches exclusionPatterns =+    map \d ->+        dirExt d ".hs"+            `excluding` containing "dist-newstyle"+            `excluding` exclusionMatches exclusionPatterns+++exclusionMatches :: [Pattern] -> FilePath -> Bool+exclusionMatches exclusionPatterns fp = any matchPattern exclusionPatterns+  where+    matchPattern p =+        match+            (patternToRegex p blankCompOpt blankExecOpt {captureGroups = False})+            fp+++cabalWatches :: ProjectRoot -> [Watch]+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"]
− src/Tricorder/Effects/Brick.hs 
@@ -1,48 +0,0 @@-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 
@@ -1,42 +0,0 @@-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 
@@ -1,216 +0,0 @@-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 
@@ -1,57 +0,0 @@-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 
@@ -1,135 +0,0 @@-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.Log (Log)-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 (..))-import Tricorder.Session (Command)---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 :: Command -> 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-       , Log :> 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 
@@ -1,671 +0,0 @@-module Tricorder.Effects.GhciSession.GhciParser-    ( GhciLoad (..)-    , GhciLoading (..)-    , GhciMessage (..)-    , GhciSeverity (..)-    , LoadOutcome (..)-    , LoadResult (..)-    , LoadedModule (..)-    , Position (..)-    , collectResult-    , collectResultCustom-    , isLocationLess-    , reloadFailed-    , parseProgressLine-    , parseReload-    , parseShowModules-    , parseShowTargets-    , pathSuffixesAsModuleName-    , resolveKnownTargets-    , stripAnsi-    , extractTitle-    , toAbsolute-    , toRelative-    , unattributedFailure-    ) 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)----- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@--- on success or @Failed, …@ on failure.-data LoadOutcome = LoadSucceeded | LoadFailed-    deriving stock (Eq, Show)----- | A structured item from GHCi's reload output.-data GhciLoad-    = GLoading GhciLoading-    | GMessage GhciMessage-    | GLoadConfig FilePath-    | GSummary LoadOutcome-    deriving stock (Eq, Show)----- | 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: terminal summary line "Ok, ..." / "Failed, ..."-          fmap Just $ do-            (_, stripped) <--                satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s)-            pure-                $ GSummary-                $ if "Failed, " `T.isPrefixOf` stripped then LoadFailed else LoadSucceeded-        , -- Pattern: "<no location info>: error:"-          fmap Just $ do-            (origLine, _) <- satisfyStripped ("<no location info>: error:" `T.isPrefixOf`)-            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-            }----- | Assemble a 'LoadResult' from the raw reload output plus the @:show--- modules@ / @:show targets@ output.------ This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload--- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a--- location-less failure we don't otherwise attribute to a file), a synthetic--- error diagnostic is appended so the build can never be reported as clean--- while GHCi considers it failed.-collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult-collectResult projectRoot reloadLines modules targets =-    let loads = parseReload reloadLines-        base = collectResultCustom projectRoot loads modules targets-        hasError = any (\d -> d.severity == SError) base.diagnostics-    in  if reloadFailed loads && not hasError then-            base {diagnostics = base.diagnostics ++ [unattributedFailure]}-        else-            base----- | Synthetic diagnostic for a failed load with no located error. Without a--- source span it cannot point anywhere, but it stops the build reading as--- clean and tells the user where to look.-unattributedFailure :: Diagnostic-unattributedFailure =-    BuildState.Diagnostic-        { severity = SError-        , file = "<no location info>"-        , line = 0-        , col = 0-        , endLine = 0-        , endCol = 0-        , title = "GHCi reported a failed load with no located error"-        , text = "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n"-        }----- | Whether GHCi's load ended in failure, decided from the 'GSummary' items--- 'parseReload' produces — the single place that classifies GHCi's terminal--- @Ok, …@ / @Failed, …@ summary line.------ GHCi emits the real summary last, after all compilation output. Output--- produced /during/ the load (a Template Haskell splice, top-level IO run while--- interpreting) can contain an earlier line that looks like a summary, so only--- the /last/ 'GSummary' reflects the true outcome.-reloadFailed :: [GhciLoad] -> Bool-reloadFailed loads =-    case [outcome | GSummary outcome <- loads] of-        [] -> False-        outcomes -> List.last outcomes == LoadFailed----- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully--- @\<…\>@-bracketed marker such as @\<no location info\>@ or @\<interactive\>@--- rather than a real source path. These carry no source span but can still--- represent genuine build-level failures, so callers treat them specially--- (kept rather than dropped, cleared every cycle rather than retained).------ We require both the opening @\<@ and a closing @\>@ so a real (if exotic)--- path that merely starts with @\<@, e.g. @\<generated\>/Foo.hs@, is not--- mistaken for a marker.-isLocationLess :: FilePath -> Bool-isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f----- | Path↔module-name map for the next cycle: this round's @:show modules@--- plus carryover from @prev@ for targets that failed mid-session and so--- dropped out. Never-compiled targets are absent here (no path↔name--- 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-    -- Location-less messages (e.g. @<no location info>@, @<interactive>@) carry-    -- no source span. We keep the *errors* — a @<no location info>@ error is a-    -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in-    -- @--enable-multi-repl@) and must not be silently dropped — but discard-    -- location-less warnings, which are just noise without a file to attach to.-    toMsg (GMessage m) | isLocationLess m.file, m.severity /= GError = Nothing-    toMsg (GMessage m) =-        Just-            BuildState.Diagnostic-                { 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 
@@ -1,551 +0,0 @@-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.Log (Log)-import Atelier.Effects.Process-    ( Process-    , RunningProcess-    , createPipe-    , getStderr-    , getStdin-    , getStdout-    , 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 (finally, throwIO, trySync)--import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.File qualified as File-import Atelier.Effects.Log qualified as Log-import Atelier.Effects.Process qualified as Process-import Data.Text qualified as T--import Tricorder.Effects.GhciSession.GhciParser-    ( GhciLoading (..)-    , LoadResult (..)-    , collectResult-    , parseProgressLine-    , parseShowModules-    , parseShowTargets-    , stripAnsi-    , unattributedFailure-    )-import Tricorder.Session (Command (..))----- | 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----- | Set up the GHCi protocol on an already-started process and return its--- handle together with the output captured during startup.------ The spawn and group teardown are owned by 'withGhciProcess'.-setupGhciProcess-    :: ( Conc :> es-       , Concurrent :> es-       , File :> es-       , Timeout :> es-       )-    => Config-    -> RunningProcess Handle Handle Handle-    -> (GhciLoading -> Eff es ())-    -- ^ Called as each @[N of M] Compiling …@ line is streamed during the-    -- initial-build drain, so the UI can update the progress bar live-    -- 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])-setupGhciProcess config p onProgress onReady = do-    let inp = getStdin p-        out = getStdout p-        err = getStderr p-    File.hSetBuffering inp LineBuffering-    File.hSetBuffering out LineBuffering-    File.hSetBuffering err LineBuffering--    -- Register the process for interruption before the (possibly slow) banner-    -- wait, so an interrupt during @cabal repl@ startup can terminate it.-    stateVar <- newTVarIO (Idle 0)-    let ghciProcess =-            GhciProcess-                { 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--    -- 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)----- | Run a GHCi @cabal repl@ session for the duration of @action@.------ The session runs in its own process group, so the whole group is torn down on--- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The--- action receives the process handle and the output captured during startup.--- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks.-withGhciProcess-    :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es)-    => Config-    -> Command-    -> FilePath-    -> (GhciLoading -> Eff es ())-    -> (GhciProcess -> Eff es ())-    -> (GhciProcess -> [Text] -> Eff es a)-    -> Eff es a-withGhciProcess config cmd dir onProgress onReady action =-    Process.withProcessGroup processConfig \p -> do-        (ghciProcess, initialLines) <- setupGhciProcess config p onProgress onReady-        action ghciProcess initialLines `finally` quitGhci config ghciProcess-  where-    processConfig =-        setStdin createPipe-            $ setStdout createPipe-            $ setStderr createPipe-            $ setWorkingDir dir-            $ shell (toString cmd.getCommand)----- | Execute a command in GHCi and return the combined stdout+stderr output--- 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 a GHCi process and its whole group.------ Stronger than 'interruptGhci': intended for one-shot processes (such as the--- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is--- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT--- handlers that finalise the current run rather than aborting it. Safe to call--- from another thread while the session is running.-terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es ()-terminateGhciProcess ghciProcess =-    Process.terminateProcessGroup ghciProcess.handle----- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it--- shut down gracefully before the enclosing 'withGhciProcess' tears down the--- group. Never throws.-quitGhci :: (File :> es, Process :> es, Timeout :> es) => Config -> GhciProcess -> Eff es ()-quitGhci config ghciProcess = do-    void $ trySync $ do-        File.hPutTextLn ghciProcess.stdin ":quit"-        File.hFlush ghciProcess.stdin-    void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle)----- ------------------------------------------------------------------------------ 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-       , Timeout :> es-       )-    => Second -> Handle -> Handle -> Eff es ()-waitForBannerOrFail delay out err = 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-                throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured)-            Nothing -> do-                captured <- atomically $ readTVar capturedVar-                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, Log :> es)-    => GhciProcess-    -> [Text]-    -> FilePath-    -> Eff es LoadResult-collectGhciResult process lines' projectRoot = do-    let noProgress = \_ -> pure ()-    moduleLines <- execGhci process ":show modules" noProgress-    targetLines <- execGhci process ":show targets" noProgress-    let result =-            collectResult-                projectRoot-                lines'-                (parseShowModules moduleLines)-                (parseShowTargets targetLines)-    -- A failed load with no located error produces only the synthetic-    -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in-    -- that case, so log the raw GHCi output — it's the only way to see what-    -- actually went wrong, and the synthetic diagnostic points here.-    when (any (== unattributedFailure) result.diagnostics)-        $ Log.info-        $ "GHCi reported a failed load with no located error. Full GHCi output:\n"-            <> T.unlines lines'-    pure result----- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events--- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read.-reloadGhci-    :: (Conc :> es, Concurrent :> es, File :> es, Log :> 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, Log :> 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, Log :> 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 
@@ -1,18 +0,0 @@-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 
@@ -1,120 +0,0 @@-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 
@@ -1,288 +0,0 @@-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 (Command (..), Session (..), TestTimeout (..))-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 'setupGhciProcess'-                    -- 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 (Command $ "cabal repl " <> target) projectRoot onProgress onReady \ghci _ ->-                        atomically (readTVar abortedRef) >>= \case-                            -- An interrupt may have landed during the-                            -- @cabal repl@ load. The returned value is-                            -- discarded by the run loop once it sees-                            -- 'abortedRef'.-                            True -> pure (Right [])-                            False -> case testTimeout of-                                TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress-                                TestTimeout secs ->-                                    timeout (fromIntegral secs :: Second) (execGhci ghci ":main" noProgress) >>= \case-                                        Nothing -> pure (Left secs)-                                        Just ls -> pure (Right ls)-                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 
@@ -1,154 +0,0 @@-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 
@@ -1,6 +0,0 @@-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 
@@ -1,26 +0,0 @@-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/Logging.hs view
@@ -0,0 +1,18 @@+module Tricorder.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/Module.hs view
@@ -0,0 +1,13 @@+module Tricorder.Module (ModuleName (..), PackageId (..)) 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)
− src/Tricorder/Observability.hs 
@@ -1,71 +0,0 @@-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/Session.hs view
@@ -1,541 +1,97 @@ module Tricorder.Session     ( Session (..)-    , Config (..)-    , Command (..)-    , TestTargets-    , getTestTargets-    , parseTestTargets-    , Target (..)-    , ComponentKind (..)-    , parseTarget-    , renderTarget-    , WatchDirs (..)-    , WatchExclusionPatterns (..)-    , ReplBuildDir (..)-    , TestTimeout (..)-    , Pattern     , loadSession-    , resolveCommand-    , resolveTargets-    , discoverCabalFiles-    , allComponentTargets-    , resolveTestTargets-    , resolveWatchDirs-    , sourceDirsForTarget-    , compareTargets+    , inputSession     ) where  import Atelier.Config (LoadedConfig, extractConfig)-import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Input (Input, input, runInputEff) import Atelier.Effects.Log (Log)-import Atelier.Types.QuietSnake (QuietSnake (..))-import Atelier.Types.WithDefaults (WithDefaults (..))-import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Default (Default (..))-import Data.List (nub)-import Distribution.Compat.Lens (view)-import Distribution.Fields (Field (..), FieldLine (..), Name (..), readFields)-import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)-import Distribution.Types.CondTree (condTreeData)-import Distribution.Types.GenericPackageDescription-    ( GenericPackageDescription-    , condBenchmarks-    , condExecutables-    , condForeignLibs-    , condLibrary-    , condSubLibraries-    , condTestSuites-    , packageDescription-    )-import Distribution.Types.PackageDescription (package)-import Distribution.Types.PackageId (pkgName)-import Distribution.Types.PackageName (unPackageName)-import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName)-import Distribution.Utils.Path (getSymbolicPath)-import Effectful.Exception (throwIO) import Effectful.Reader.Static (Reader, ask)-import System.FilePath (normalise, takeDirectory, takeExtension, (</>))-import System.IO.Error (userError)-import Text.Regex.TDFA.ReadRegex (parseRegex)  import Atelier.Effects.Log qualified as Log-import Data.ByteString.Char8 qualified as BC import Data.Text qualified as T-import Distribution.Types.BuildInfo.Lens qualified as Lens-import Text.Regex.TDFA.Pattern qualified as Regex  import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.CabalFile (CabalFile)+import Tricorder.Session.Command (Command (..), resolveCommand)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.ReplBuildDir (ReplBuildDir (..))+import Tricorder.Session.Target (Target, definesCustomPrelude, resolveTargets)+import Tricorder.Session.TestTarget (TestTarget, resolveTestTargets)+import Tricorder.Session.TestTimeout (TestTimeout (..))+import Tricorder.Session.WatchDirs (WatchDirs (..), resolveWatchDirs)+import Tricorder.Session.WatchExclusionPatterns (WatchExclusionPatterns (..), resolveWatchExclusionPatterns)   data Session = Session     { command :: Command     , targets :: [Target]-    , testTargets :: TestTargets+    , testTargets :: [TestTarget]     , watchDirs :: WatchDirs     , watchExclusionPatterns :: WatchExclusionPatterns     , replBuildDir :: ReplBuildDir     , testTimeout :: TestTimeout     }---type Pattern = (Regex.Pattern, (Regex.GroupIndex, Regex.DoPa))+    deriving stock (Eq)   instance Default Session where     def =         Session-            { command = Command ""-            , targets = []-            , testTargets = projectTestTargets []-            , watchDirs = WatchDirs []-            , watchExclusionPatterns = WatchExclusionPatterns []-            , replBuildDir = ReplBuildDir "/tmp"-            , testTimeout = TestTimeout 10-            }---data Config = Config-    { command :: Maybe Text-    , targets :: [Text]-    , watchDirs :: [FilePath]-    , watchExclusionPatterns :: [Text]-    , testTargets :: Maybe [Text]-    , replBuildDir :: FilePath-    , testTimeout :: Int-    }-    deriving stock (Eq, Generic, Show)-    deriving (FromJSON) via WithDefaults (QuietSnake Config)---instance Default Config where-    def =-        Config-            { command = Nothing+            { command = def             , targets = []-            , watchDirs = []-            , watchExclusionPatterns = []-            , testTargets = Nothing-            , replBuildDir = "dist-newstyle/tricorder"-            , testTimeout = 10+            , testTargets = []+            , watchDirs = def+            , watchExclusionPatterns = def+            , replBuildDir = def+            , testTimeout = def             }  -newtype Command = Command {getCommand :: Text}-    deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via Text----- | The test suites to run after a clean build. Built only by projecting a--- target list onto its @test:@ components via 'projectTestTargets'; the data--- constructor is not exported, so a 'TestTargets' can never hold a non-test--- target [ref:test_targets_invariant].-newtype TestTargets = TestTargets {getTestTargets :: [Target]}-    deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via [Target]----- | [tag:test_targets_invariant] Project a target list onto its test suites —--- the only way to build a 'TestTargets', so the @test:@-only invariant holds by--- construction.-projectTestTargets :: [Target] -> TestTargets-projectTestTargets = TestTargets . filter isTestTarget-  where-    isTestTarget (Qualified Test _) = True-    isTestTarget _ = False----- | Parse raw target strings (e.g. the @test_targets@ config) and project them--- onto their test suites — non-test entries are dropped.-parseTestTargets :: [Text] -> TestTargets-parseTestTargets = projectTestTargets . map parseTarget----- | A cabal build target, parsed from its textual @[kind:]name@ form. Used to--- resolve which source directories belong to a target.-data Target-    = -- | A @kind:name@ reference, e.g. @lib:foo@, @exe:foo@, @test:foo@. An-      -- empty name with 'Lib' (i.e. @lib:@) denotes the package's main library.-      Qualified ComponentKind Text-    | -- | A name with no @kind:@ prefix. Refers either to a package (all of its-      -- components) or to a single component matched by name.-      Bare Text-    | -- | A form we don't recognize: an unknown kind, or extra colons.-      Unrecognized Text-    deriving stock (Eq, Show)----- | The kind of cabal component a 'Qualified' target names. Covers every--- component kind cabal models (matching @Distribution.Types.ComponentName@).-data ComponentKind = Lib | FLib | Exe | Test | Bench-    deriving stock (Bounded, Enum, Eq, Show)----- | [tag:kind_prefix_sole_source] The canonical prefix cabal uses for each--- component kind. Single source of truth shared by 'parseTarget' and--- 'renderTarget' — keep this the only place the prefix strings appear.------ We deliberately model only these canonical prefixes, not cabal's full set of--- aliases (@executable@, @test-suite@, …) or its case-folding. Those would mean--- hand-mirroring an unexported, internally-inconsistent cabal table; instead an--- aliased spelling falls to 'Unrecognized', which is still handed to cabal--- verbatim for the build and still resolves watch dirs by matching its trailing--- component name [ref:alias_name_match].-kindPrefix :: ComponentKind -> Text-kindPrefix = \case-    Lib -> "lib"-    FLib -> "flib"-    Exe -> "exe"-    Test -> "test"-    Bench -> "bench"----- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two--- never drift apart [ref:kind_prefix_sole_source].-parseKind :: Text -> Maybe ComponentKind-parseKind = inverseMap kindPrefix----- | Classify a target's textual form. The grammar is @[kind:]name@ where--- @kind@ is one of @lib@, @flib@, @exe@, @test@, or @bench@; anything else (an--- unknown kind, a cabal alias such as @executable@, or extra colons) is--- 'Unrecognized'.-parseTarget :: Text -> Target-parseTarget target = case T.splitOn ":" target of-    [prefix, name] | Just kind <- parseKind prefix -> Qualified kind name-    [name] -> Bare name-    _ -> Unrecognized target----- | Render a 'Target' back to the textual form cabal understands. Inverse of--- 'parseTarget' (lossless: @parseTarget . renderTarget == id@). Builds prefixes--- via 'kindPrefix' rather than hardcoding them [ref:kind_prefix_sole_source].-renderTarget :: Target -> Text-renderTarget = \case-    Qualified kind name -> kindPrefix kind <> ":" <> name-    Bare name -> name-    Unrecognized raw -> raw---instance ToJSON Target where-    toJSON = toJSON . renderTarget---instance FromJSON Target where-    parseJSON = fmap parseTarget . parseJSON---newtype WatchDirs = WatchDirs {getWatchDirs :: [FilePath]}-    deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via [FilePath]---newtype WatchExclusionPatterns = WatchExclusionPatterns {getWatchExclusionPatterns :: [Pattern]}-    deriving stock (Eq, Generic, Show)---newtype ReplBuildDir = ReplBuildDir {getReplBuildDir :: FilePath}-    deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via FilePath---newtype TestTimeout = TestTimeout {getTestTimeout :: Int}-    deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via Int----- | Resolve the GHCi command, using config if set or autodetecting otherwise.------ The @testTargets@ are the discovered @test:@ components; they are appended to--- the auto-detected @all@ target (see 'detectCommand'). They are ignored when--- the user has pinned an explicit @command@ or explicit @targets@ in config.-resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> TestTargets -> Eff es Command-resolveCommand projectRoot cfg targets testTargets =-    case cfg.command of-        Just cmd -> pure $ Command cmd-        Nothing -> detectCommand targets testTargets cfg.replBuildDir projectRoot----- | Build the autodetected GHCi command.------ Configured @targets@ are spelled out verbatim. Otherwise we use cabal's--- catch-all @all@ plus the discovered @test:@ targets, because--- @cabal repl --enable-multi-repl all@ omits test suites unless the project sets--- @tests: True@ in @cabal.project@ — so test errors would go unnoticed.------ We keep @all@ rather than enumerating every component: @all@ lets cabal order--- the multi-repl units, and GHCi makes the /last/ unit the active one. If that--- unit imports a custom @Prelude@ from a sibling home package, GHCi reports it--- "not loaded" and the session dies — which a naive discovery-order enumeration--- triggers but @all@ avoids. Appending already-included test targets is a no-op--- (cabal deduplicates).-detectCommand :: (FileSystem :> es) => [Target] -> TestTargets -> FilePath -> ProjectRoot -> Eff es Command-detectCommand targets (TestTargets testTargets) replBuildDir (ProjectRoot projectRoot) = do-    hasCabalProject <- doesFileExist (projectRoot </> "cabal.project")-    cabalFiles <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory projectRoot-    hasStack <- doesFileExist (projectRoot </> "stack.yaml")-    let targetStr-            | not (null targets) = unwords (map renderTarget targets)-            | otherwise = unwords ("all" : map renderTarget testTargets)-        buildDirFlag = "--builddir " <> toText replBuildDir <> " "-    pure-        if-            | hasCabalProject || not (null cabalFiles) ->-                Command $ "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr-            | hasStack -> Command $ "stack ghci " <> targetStr-            | otherwise -> Command $ "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 -> [Target] -> Eff es WatchDirs-resolveWatchDirs projectRoot cabalFiles cfg targets =-    case cfg.watchDirs of-        dirs@(_ : _) -> pure $ WatchDirs $ map (coerce projectRoot </>) dirs-        [] -> resolveWatchDirsFromTargets cabalFiles targets---resolveWatchDirsFromTargets :: (FileSystem :> es) => [FilePath] -> [Target] -> Eff es WatchDirs-resolveWatchDirsFromTargets _ [] = pure $ WatchDirs ["."]-resolveWatchDirsFromTargets cabalFiles targets = do-    dirs <- nub . concat <$> traverse watchDirsForCabal cabalFiles-    pure $ WatchDirs $ if null dirs then ["."] else dirs-  where-    -- @hs-source-dirs@ are relative to the package's own directory, so scope-    -- them to the directory holding that package's @.cabal@. In a-    -- 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 -> Target -> [FilePath]-sourceDirsForTarget gpd target =-    map getSymbolicPath $ case target of-        Qualified Lib "" -> mainLibSourceDirs-        Qualified Lib name-            | toString name == mainPkgName -> mainLibSourceDirs-            | otherwise -> subLibSourceDirs name-        Qualified FLib name -> flibSourceDirs name-        Qualified Exe name -> exeSourceDirs name-        Qualified Test name -> testSourceDirs name-        Qualified Bench name -> benchSourceDirs name-        -- A bare target (no @kind:@ prefix) is a package name or a component-        -- name. A package name covers every component; otherwise match a-        -- single component by name across the kinds.-        Bare name-            | toString name == mainPkgName -> allComponentSourceDirs-            | otherwise -> componentSourceDirsByName name-        -- [tag:alias_name_match] A form we couldn't parse into a kind — a cabal-        -- alias (@executable:@) or a case variant (@Lib:@). The kind is-        -- untrustworthy, but cabal component names are unique within a package,-        -- so we match the trailing name across every kind. This recovers precise-        -- watch dirs for aliased spellings; worst case we over-match a-        -- same-named component, never miss one. (The raw string is still handed-        -- to cabal verbatim for the build.)-        Unrecognized raw -> componentSourceDirsByName (T.takeWhileEnd (/= ':') raw)-  where-    mainPkgName = unPackageName . pkgName . package . packageDescription $ gpd--    -- @hs-source-dirs@ of any component, via the @HasBuildInfo@ lens — one-    -- accessor that works uniformly across libraries, foreign libs, exes,-    -- tests, and benchmarks, so we don't repeat a per-kind @buildInfo@ getter.-    componentDirs component = view Lens.hsSourceDirs component--    mainLibSourceDirs = maybe [] (componentDirs . condTreeData) (condLibrary gpd)-    subLibSourceDirs name = dirsForComponent (condSubLibraries gpd) name-    flibSourceDirs name = dirsForComponent (condForeignLibs gpd) name-    exeSourceDirs name = dirsForComponent (condExecutables gpd) name-    testSourceDirs name = dirsForComponent (condTestSuites gpd) name-    benchSourceDirs name = dirsForComponent (condBenchmarks gpd) name--    -- Match a component name across every kind. The main library is keyed by-    -- the package name rather than an unqualified component name, so it joins-    -- in only when @name@ is the package name.-    componentSourceDirsByName name =-        mainLibForName name-            <> subLibSourceDirs name-            <> flibSourceDirs name-            <> exeSourceDirs name-            <> testSourceDirs name-            <> benchSourceDirs name--    mainLibForName name-        | toString name == mainPkgName = mainLibSourceDirs-        | otherwise = []--    allComponentSourceDirs =-        mainLibSourceDirs-            <> concatMap (componentDirs . condTreeData . snd) (condSubLibraries gpd)-            <> concatMap (componentDirs . condTreeData . snd) (condForeignLibs gpd)-            <> concatMap (componentDirs . condTreeData . snd) (condExecutables gpd)-            <> concatMap (componentDirs . condTreeData . snd) (condTestSuites gpd)-            <> concatMap (componentDirs . condTreeData . snd) (condBenchmarks gpd)--    dirsForComponent components name =-        let ucn = mkUnqualComponentName (toString name)-        in  concatMap (componentDirs . condTreeData . snd) $ filter ((== ucn) . fst) components----- | Infer the effective targets to build and watch. This is the boundary where--- raw target strings (from config) are parsed into structured 'Target's: the--- configured targets are parsed as-is, or all components across every--- discovered package are auto-detected when no targets are configured. Either--- way the result is sorted with 'compareTargets' so libraries come last--- [ref:lib_sort_order].-resolveTargets :: (FileSystem :> es) => [FilePath] -> [Text] -> Eff es [Target]-resolveTargets _ targets@(_ : _) = pure $ sortBy compareTargets $ map parseTarget targets-resolveTargets cabalFiles [] =-    sortBy compareTargets . concat <$> traverse targetsFromCabal cabalFiles-  where-    targetsFromCabal path = do-        contents <- readFileBs path-        pure $ maybe [] allComponentTargets (parseGenericPackageDescriptionMaybe contents)----- | [tag:lib_sort_order] When running @cabal repl <package defining custom--- prelude> <other packages...>@, GHCi fails because it attempts to load the--- provided @Prelude@ module before loading the package itself. This is not a--- problem if the package defining the prelude module is not the first component--- listed.------ Because of this GHCi quirk, we sort all packages beginning with @lib:@ last.--- This is based on the assumption that components defining custom preludes--- usually reside in libraries. If we can then place at least one target that--- does not specify a custom prelude a before targets that do, we will prevent--- the user from being hit with this rather obscure error message.-compareTargets :: Target -> Target -> Ordering-compareTargets a b-    | isLib a && not (isLib b) = GT-    | not (isLib a) && isLib b = LT-    | otherwise = compare (renderTarget a) (renderTarget b)-  where-    isLib (Qualified Lib _) = True-    isLib _ = False----- | Locate every package's @.cabal@ file, logging what drove the result. In a--- multi-package project the packages live in subdirectories listed under--- @packages:@ in @cabal.project@; in a single-package project the @.cabal@--- 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 -> [Target]-allComponentTargets gpd =-    mainLibTargets-        ++ subLibTargets-        ++ flibTargets-        ++ exeTargets-        ++ testTargets-        ++ benchTargets-  where-    mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd-    mainLibTargets = maybe [] (const [Qualified Lib mainPkgName]) (condLibrary gpd)-    subLibTargets = map (\(n, _) -> Qualified Lib (componentName n)) (condSubLibraries gpd)-    flibTargets = map (\(n, _) -> Qualified FLib (componentName n)) (condForeignLibs gpd)-    exeTargets = map (\(n, _) -> Qualified Exe (componentName n)) (condExecutables gpd)-    testTargets = map (\(n, _) -> Qualified Test (componentName n)) (condTestSuites gpd)-    benchTargets = map (\(n, _) -> Qualified Bench (componentName n)) (condBenchmarks gpd)-    componentName = toText . unUnqualComponentName----- | Resolve which test suites to run after a clean build. Either source — the--- explicit @test_targets@ config or the build 'targets' — is projected onto its--- @test:@ components (see 'projectTestTargets'), so non-test entries are--- dropped and the result only ever names test suites [ref:test_targets_invariant].-resolveTestTargets :: Config -> [Target] -> TestTargets-resolveTestTargets cfg targets = case cfg.testTargets of-    Just explicit -> parseTestTargets explicit-    Nothing -> projectTestTargets targets---resolveWatchExclusionPatterns :: [Text] -> Eff es WatchExclusionPatterns-resolveWatchExclusionPatterns rawPatterns = do-    either (throwIO . userError . show) (pure . WatchExclusionPatterns)-        $ traverse-            ( parseRegex-                . toString-            )-            rawPatterns-- loadSession     :: ( FileSystem :> es+       , Input LoadedConfig :> es+       , Input [CabalFile] :> es        , Log :> es-       , Reader LoadedConfig :> es        , Reader ProjectRoot :> es        )     => Eff es Session loadSession = do     projectRoot <- ask @ProjectRoot-    loadedCfg <- ask+    loadedCfg <- input+    projectFiles <- input+     let cfgFile = extractConfig @"session" @Config loadedCfg-    cabalFiles <- discoverCabalFiles projectRoot-    effectiveTargets <- resolveTargets cabalFiles cfgFile.targets-    let testTargets = resolveTestTargets cfgFile effectiveTargets+        effectiveTargets = resolveTargets projectFiles cfgFile.targets+        testTargets = resolveTestTargets cfgFile effectiveTargets+        watchDirs = resolveWatchDirs projectRoot projectFiles cfgFile effectiveTargets++    watchExclusionPatterns <-+        case resolveWatchExclusionPatterns cfgFile.watchExclusionPatterns of+            Left err -> do+                Log.err+                    $ T.intercalate+                        "\n"+                        [ "Failed to parse watch exclusion patterns:"+                        , err+                        , "Defaulting to no exclusion patterns."+                        ]+                pure $ WatchExclusionPatterns []+            Right pts -> pure pts++    when (not (null effectiveTargets) && all (definesCustomPrelude projectFiles) effectiveTargets)+        $ Log.warn+            "Every resolved target exposes a custom Prelude module. GHCi may \+            \fail to start because the first target's Prelude will be loaded \+            \before its package is ready. Consider adding a target that does \+            \not define its own Prelude, or set an explicit command in your \+            \tricorder configuration."+     command <- resolveCommand projectRoot cfgFile effectiveTargets testTargets-    watchDirs <- resolveWatchDirs projectRoot cabalFiles cfgFile effectiveTargets-    watchExclusionPatterns <- resolveWatchExclusionPatterns cfgFile.watchExclusionPatterns+     pure         $ Session             { targets = effectiveTargets@@ -546,3 +102,14 @@             , replBuildDir = ReplBuildDir cfgFile.replBuildDir             , testTimeout = TestTimeout cfgFile.testTimeout             }+++inputSession+    :: ( FileSystem :> es+       , Input LoadedConfig :> es+       , Input [CabalFile] :> es+       , Log :> es+       , Reader ProjectRoot :> es+       )+    => Eff (Input Session : es) a -> Eff es a+inputSession = runInputEff loadSession
+ src/Tricorder/Session/CabalFile.hs view
@@ -0,0 +1,108 @@+module Tricorder.Session.CabalFile+    ( CabalFile (..)+    , inputCabalFiles+    , discoverCabalFiles+    ) where++import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs)+import Atelier.Effects.Input (Input, runInputEff)+import Atelier.Effects.Log (Log)+import Data.Traversable (for)+import Distribution.Fields (Field (..), FieldLine (..), Name (..), readFields)+import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)+import Effectful.Reader.Static (Reader, ask)+import System.FilePath (normalise, 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 CabalFile = CabalFile+    { projectFilePath :: FilePath+    , projectPackageDescription :: GenericPackageDescription+    }+    deriving stock (Show)+++inputCabalFiles+    :: ( FileSystem :> es+       , Log :> es+       , Reader ProjectRoot :> es+       )+    => Eff (Input [CabalFile] : es) a -> Eff es a+inputCabalFiles = runInputEff do+    projectRoot <- ask+    projectFilePaths <- discoverCabalFiles projectRoot+    (faileds, packageDescriptions) <-+        partitionEithers <$> for projectFilePaths \p -> do+            contents <- readFileBs p+            case parseGenericPackageDescriptionMaybe contents of+                Nothing -> pure $ Left p+                Just gpd -> pure $ Right $ CabalFile p gpd+    unless (null faileds) do+        Log.warn+            $ "Failed to parse .cabal files for the following packages: "+                <> T.intercalate ", " (toText <$> faileds)+    pure $ packageDescriptions+++-- | 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.debug+            $ "Found cabal.project; discovered "+                <> show (length cabalFiles)+                <> " package cabal file(s): "+                <> listed+    else+        Log.debug $ "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)
+ src/Tricorder/Session/Command.hs view
@@ -0,0 +1,65 @@+module Tricorder.Session.Command+    ( Command (..)+    , resolveCommand+    ) where++import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory)+import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Default (Default (..))+import System.FilePath (takeExtension, (</>))++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Target (Target, renderTarget)+import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+++newtype Command = Command {getCommand :: Text}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Text+++instance Default Command where+    def = Command ""+++-- | Resolve the GHCi command, using config if set or autodetecting otherwise.+--+-- The @testTargets@ are the discovered @test:@ components; they are appended to+-- the auto-detected @all@ target (see 'detectCommand'). They are ignored when+-- the user has pinned an explicit @command@ or explicit @targets@ in config.+resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> [TestTarget] -> Eff es Command+resolveCommand projectRoot cfg targets testTargets =+    case cfg.command of+        Just cmd -> pure $ Command cmd+        Nothing -> detectCommand targets testTargets cfg.replBuildDir projectRoot+++-- | Build the autodetected GHCi command.+--+-- Configured @targets@ are spelled out verbatim. Otherwise we use cabal's+-- catch-all @all@ plus the discovered @test:@ targets, because+-- @cabal repl --enable-multi-repl all@ omits test suites unless the project sets+-- @tests: True@ in @cabal.project@ — so test errors would go unnoticed.+--+-- We keep @all@ rather than enumerating every component: @all@ lets cabal order+-- the multi-repl units, and GHCi makes the /last/ unit the active one. If that+-- unit imports a custom @Prelude@ from a sibling home package, GHCi reports it+-- "not loaded" and the session dies — which a naive discovery-order enumeration+-- triggers but @all@ avoids. Appending already-included test targets is a no-op+-- (cabal deduplicates).+detectCommand :: (FileSystem :> es) => [Target] -> [TestTarget] -> FilePath -> ProjectRoot -> Eff es Command+detectCommand targets testTargets replBuildDir (ProjectRoot projectRoot) = do+    hasCabalProject <- doesFileExist (projectRoot </> "cabal.project")+    cabalFiles <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory projectRoot+    hasStack <- doesFileExist (projectRoot </> "stack.yaml")+    let targetStr+            | not (null targets) = unwords (map renderTarget targets)+            | otherwise = unwords ("all" : map renderTestTarget testTargets)+        buildDirFlag = "--builddir " <> toText replBuildDir <> " "+    pure+        if+            | hasCabalProject || not (null cabalFiles) ->+                Command $ "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr+            | hasStack -> Command $ "stack ghci " <> targetStr+            | otherwise -> Command $ "cabal repl " <> buildDirFlag <> targetStr
+ src/Tricorder/Session/Config.hs view
@@ -0,0 +1,32 @@+module Tricorder.Session.Config (Config (..)) where++import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))+import Data.Aeson (FromJSON (..))+import Data.Default (Default (..))+++data Config = Config+    { command :: Maybe Text+    , targets :: [Text]+    , watchDirs :: [FilePath]+    , watchExclusionPatterns :: [Text]+    , testTargets :: Maybe [Text]+    , 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 = []+            , watchExclusionPatterns = []+            , testTargets = Nothing+            , replBuildDir = "dist-newstyle/tricorder"+            , testTimeout = 10+            }
+ src/Tricorder/Session/ReplBuildDir.hs view
@@ -0,0 +1,13 @@+module Tricorder.Session.ReplBuildDir (ReplBuildDir (..)) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+++newtype ReplBuildDir = ReplBuildDir {getReplBuildDir :: FilePath}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via FilePath+++instance Default ReplBuildDir where+    def = ReplBuildDir "/tmp"
+ src/Tricorder/Session/Target.hs view
@@ -0,0 +1,192 @@+module Tricorder.Session.Target+    ( Target (..)+    , ComponentKind (..)+    , parseTarget+    , renderTarget+    , resolveTargets+    , definesCustomPrelude+    , compareTargets+    , allComponentTargets+    ) where++import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey)+import Distribution.Types.CondTree (condTreeData)+import Distribution.Types.GenericPackageDescription+    ( GenericPackageDescription+    , condBenchmarks+    , condExecutables+    , condForeignLibs+    , condLibrary+    , condSubLibraries+    , condTestSuites+    , packageDescription+    )+import Distribution.Types.Library (exposedModules)+import Distribution.Types.PackageDescription (package)+import Distribution.Types.PackageId (pkgName)+import Distribution.Types.PackageName (unPackageName)+import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName)++import Data.Text qualified as T++import Tricorder.Session.CabalFile (CabalFile (..))+++-- | A cabal build target, parsed from its textual @[kind:]name@ form. Used to+-- resolve which source directories belong to a target.+data Target+    = -- | A @kind:name@ reference, e.g. @lib:foo@, @exe:foo@, @test:foo@. An+      -- empty name with 'Lib' (i.e. @lib:@) denotes the package's main library.+      Qualified ComponentKind Text+    | -- | A name with no @kind:@ prefix. Refers either to a package (all of its+      -- components) or to a single component matched by name.+      Bare Text+    | -- | A form we don't recognize: an unknown kind, or extra colons.+      Unrecognized Text+    deriving stock (Eq, Generic, Ord, Show)+++instance ToJSON Target where+    toJSON = toJSON . renderTarget+++instance FromJSON Target where+    parseJSON = fmap parseTarget . parseJSON+++instance ToJSONKey Target+instance FromJSONKey Target+++-- | The kind of cabal component a 'Qualified' target names. Covers every+-- component kind cabal models (matching @Distribution.Types.ComponentName@).+data ComponentKind = Lib | FLib | Exe | Test | Bench+    deriving stock (Bounded, Enum, Eq, Generic, Ord, Show)+++-- | [tag:kind_prefix_sole_source] The canonical prefix cabal uses for each+-- component kind. Single source of truth shared by 'parseTarget' and+-- 'renderTarget' — keep this the only place the prefix strings appear.+--+-- We deliberately model only these canonical prefixes, not cabal's full set of+-- aliases (@executable@, @test-suite@, …) or its case-folding. Those would mean+-- hand-mirroring an unexported, internally-inconsistent cabal table; instead an+-- aliased spelling falls to 'Unrecognized', which is still handed to cabal+-- verbatim for the build and still resolves watch dirs by matching its trailing+-- component name [ref:alias_name_match].+kindPrefix :: ComponentKind -> Text+kindPrefix = \case+    Lib -> "lib"+    FLib -> "flib"+    Exe -> "exe"+    Test -> "test"+    Bench -> "bench"+++-- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two+-- never drift apart [ref:kind_prefix_sole_source].+parseKind :: Text -> Maybe ComponentKind+parseKind = inverseMap kindPrefix+++-- | Classify a target's textual form. The grammar is @[kind:]name@ where+-- @kind@ is one of @lib@, @flib@, @exe@, @test@, or @bench@; anything else (an+-- unknown kind, a cabal alias such as @executable@, or extra colons) is+-- 'Unrecognized'.+parseTarget :: Text -> Target+parseTarget target = case T.splitOn ":" target of+    [prefix, name] | Just kind <- parseKind prefix -> Qualified kind name+    [name] -> Bare name+    _ -> Unrecognized target+++-- | Render a 'Target' back to the textual form cabal understands. Inverse of+-- 'parseTarget' (lossless: @parseTarget . renderTarget == id@). Builds prefixes+-- via 'kindPrefix' rather than hardcoding them [ref:kind_prefix_sole_source].+renderTarget :: Target -> Text+renderTarget = \case+    Qualified kind name -> kindPrefix kind <> ":" <> name+    Bare name -> name+    Unrecognized raw -> raw+++-- | Infer the effective targets to build and watch. This is the boundary where+-- raw target strings (from config) are parsed into structured 'Target's: the+-- configured targets are parsed as-is, or all components across every+-- discovered package are auto-detected when no targets are configured. Either+-- way the result is sorted with 'compareTargets' so libraries exposing a custom+-- @Prelude@ come last [ref:lib_sort_order].+resolveTargets :: [CabalFile] -> [Text] -> [Target]+resolveTargets cabalFiles targets@(_ : _) =+    sortBy (compareTargets (definesCustomPrelude cabalFiles)) $ parseTarget <$> targets+resolveTargets cabalFiles [] =+    sortBy (compareTargets (definesCustomPrelude cabalFiles))+        $ foldMap (allComponentTargets . (.projectPackageDescription)) cabalFiles+++-- | [tag:lib_sort_order] When running @cabal repl <package defining custom+-- prelude> <other packages...>@, GHCi fails because it attempts to load the+-- provided @Prelude@ module before loading the package itself. This is not a+-- problem if the package defining the prelude module is not the first component+-- listed.+--+-- We check each library target against the discovered cabal files via+-- 'definesCustomPrelude': only those that expose a @Prelude@ module are sorted+-- last. This is more precise than sorting every @lib:@ target last — only the+-- libraries that actually cause the failure are reordered.+compareTargets :: (Target -> Bool) -> Target -> Target -> Ordering+compareTargets definesPrelude a b+    | definesPrelude a && not (definesPrelude b) = GT+    | not (definesPrelude a) && definesPrelude b = LT+    | otherwise = compare (renderTarget a) (renderTarget b)+++-- | Check whether any of the discovered packages' libraries expose a @Prelude@+-- module for the given target. Used to build the predicate passed to+-- 'compareTargets' so that only the libraries that actually cause the GHCi+-- startup failure are sorted last [ref:lib_sort_order].+definesCustomPrelude :: [CabalFile] -> Target -> Bool+definesCustomPrelude cabalFiles target = any check cabalFiles+  where+    check cabalFile = any hasPrelude $ relevantLibs cabalFile.projectPackageDescription+    hasPrelude lib = "Prelude" `elem` exposedModules lib+    relevantLibs gpd =+        let pkgN = unPackageName gpd.packageDescription.package.pkgName+        in  case target of+                Qualified Lib "" ->+                    toList $ condTreeData <$> condLibrary gpd+                Qualified Lib name+                    | toString name == pkgN ->+                        toList $ condTreeData <$> condLibrary gpd+                    | otherwise ->+                        subLibsNamed gpd (toString name)+                Bare name+                    | toString name == pkgN ->+                        toList (condTreeData <$> condLibrary gpd)+                            <> (condTreeData . snd <$> condSubLibraries gpd)+                    | otherwise ->+                        subLibsNamed gpd (toString name)+                _ -> []+    subLibsNamed gpd name =+        map (condTreeData . snd)+            $ filter ((== mkUnqualComponentName name) . fst)+            $ condSubLibraries gpd+++allComponentTargets :: GenericPackageDescription -> [Target]+allComponentTargets gpd =+    mainLibTargets+        ++ subLibTargets+        ++ flibTargets+        ++ exeTargets+        ++ testTargets+        ++ benchTargets+  where+    mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd+    mainLibTargets = maybe [] (const [Qualified Lib mainPkgName]) (condLibrary gpd)+    subLibTargets = map (\(n, _) -> Qualified Lib (componentName n)) (condSubLibraries gpd)+    flibTargets = map (\(n, _) -> Qualified FLib (componentName n)) (condForeignLibs gpd)+    exeTargets = map (\(n, _) -> Qualified Exe (componentName n)) (condExecutables gpd)+    testTargets = map (\(n, _) -> Qualified Test (componentName n)) (condTestSuites gpd)+    benchTargets = map (\(n, _) -> Qualified Bench (componentName n)) (condBenchmarks gpd)+    componentName = toText . unUnqualComponentName
+ src/Tricorder/Session/TestTarget.hs view
@@ -0,0 +1,48 @@+module Tricorder.Session.TestTarget+    ( TestTarget (..)+    , renderTestTarget+    , parseTestTargets+    , resolveTestTargets+    , projectTestTargets+    ) where++import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey)++import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Target (ComponentKind (..), Target (..), parseTarget, renderTarget)+++newtype TestTarget = TestTarget {getTestTarget :: Target}+    deriving stock (Eq, Generic, Ord, Show)+    deriving (FromJSON, ToJSON) via Target+    deriving (FromJSONKey, ToJSONKey) via Target+++renderTestTarget :: TestTarget -> Text+renderTestTarget = renderTarget . getTestTarget+++-- | Parse raw target strings (e.g. the @test_targets@ config) and project them+-- onto their test suites — non-test entries are dropped.+parseTestTargets :: [Text] -> [TestTarget]+parseTestTargets = projectTestTargets . map parseTarget+++-- | [tag:test_targets_invariant] Project a target list onto its test suites —+-- the only way to build a 'TestTargets', so the @test:@-only invariant holds by+-- construction.+projectTestTargets :: [Target] -> [TestTarget]+projectTestTargets = mapMaybe mkTestTarget+  where+    mkTestTarget tgt@(Qualified Test _) = Just $ TestTarget tgt+    mkTestTarget _ = Nothing+++-- | Resolve which test suites to run after a clean build. Either source — the+-- explicit @test_targets@ config or the build 'targets' — is projected onto its+-- @test:@ components (see 'projectTestTargets'), so non-test entries are+-- dropped and the result only ever names test suites [ref:test_targets_invariant].+resolveTestTargets :: Config -> [Target] -> [TestTarget]+resolveTestTargets cfg targets = case cfg.testTargets of+    Just explicit -> parseTestTargets explicit+    Nothing -> projectTestTargets targets
+ src/Tricorder/Session/TestTimeout.hs view
@@ -0,0 +1,13 @@+module Tricorder.Session.TestTimeout (TestTimeout (..)) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+++newtype TestTimeout = TestTimeout {getTestTimeout :: Int}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Int+++instance Default TestTimeout where+    def = TestTimeout 10
+ src/Tricorder/Session/WatchDirs.hs view
@@ -0,0 +1,144 @@+module Tricorder.Session.WatchDirs+    ( WatchDirs (..)+    , resolveWatchDirs+    , sourceDirsForTarget+    ) where++import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Default (Default (..))+import Data.List (nub)+import Distribution.Compat.Lens (view)+import Distribution.Types.CondTree (condTreeData)+import Distribution.Types.GenericPackageDescription+    ( GenericPackageDescription+    , condBenchmarks+    , condExecutables+    , condForeignLibs+    , condLibrary+    , condSubLibraries+    , condTestSuites+    , packageDescription+    )+import Distribution.Types.PackageDescription (package)+import Distribution.Types.PackageId (pkgName)+import Distribution.Types.PackageName (unPackageName)+import Distribution.Types.UnqualComponentName (mkUnqualComponentName)+import Distribution.Utils.Path (getSymbolicPath)+import System.FilePath (takeDirectory, (</>))++import Data.Text qualified as T+import Distribution.Types.BuildInfo.Lens qualified as Lens++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.CabalFile (CabalFile (..))+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Target (ComponentKind (..), Target (..))+++newtype WatchDirs = WatchDirs {getWatchDirs :: [FilePath]}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via [FilePath]+++instance Default WatchDirs where+    def = WatchDirs []+++-- | 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 :: ProjectRoot -> [CabalFile] -> Config -> [Target] -> WatchDirs+resolveWatchDirs projectRoot projectFiles cfg targets =+    case cfg.watchDirs of+        dirs@(_ : _) -> WatchDirs $ map (coerce projectRoot </>) dirs+        [] -> resolveWatchDirsFromTargets projectFiles targets+++resolveWatchDirsFromTargets :: [CabalFile] -> [Target] -> WatchDirs+resolveWatchDirsFromTargets _ [] = WatchDirs ["."]+resolveWatchDirsFromTargets projectFiles targets =+    WatchDirs $ case dirs of+        [] -> ["."]+        _ -> dirs+  where+    dirs = nub . concat $ watchDirsForCabal <$> projectFiles+    -- @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 projectFile =+        let pkgDir = takeDirectory projectFile.projectFilePath+            sourceDirs = sourceDirsForTarget projectFile.projectPackageDescription+        in  (pkgDir </>) <$> concatMap sourceDirs targets+++sourceDirsForTarget :: GenericPackageDescription -> Target -> [FilePath]+sourceDirsForTarget gpd target =+    map getSymbolicPath $ case target of+        Qualified Lib "" -> mainLibSourceDirs+        Qualified Lib name+            | toString name == mainPkgName -> mainLibSourceDirs+            | otherwise -> subLibSourceDirs name+        Qualified FLib name -> flibSourceDirs name+        Qualified Exe name -> exeSourceDirs name+        Qualified Test name -> testSourceDirs name+        Qualified Bench name -> benchSourceDirs name+        -- A bare target (no @kind:@ prefix) is a package name or a component+        -- name. A package name covers every component; otherwise match a+        -- single component by name across the kinds.+        Bare name+            | toString name == mainPkgName -> allComponentSourceDirs+            | otherwise -> componentSourceDirsByName name+        -- [tag:alias_name_match] A form we couldn't parse into a kind — a cabal+        -- alias (@executable:@) or a case variant (@Lib:@). The kind is+        -- untrustworthy, but cabal component names are unique within a package,+        -- so we match the trailing name across every kind. This recovers precise+        -- watch dirs for aliased spellings; worst case we over-match a+        -- same-named component, never miss one. (The raw string is still handed+        -- to cabal verbatim for the build.)+        Unrecognized raw -> componentSourceDirsByName (T.takeWhileEnd (/= ':') raw)+  where+    mainPkgName = unPackageName . pkgName . package . packageDescription $ gpd++    -- @hs-source-dirs@ of any component, via the @HasBuildInfo@ lens — one+    -- accessor that works uniformly across libraries, foreign libs, exes,+    -- tests, and benchmarks, so we don't repeat a per-kind @buildInfo@ getter.+    componentDirs component = view Lens.hsSourceDirs component++    mainLibSourceDirs = maybe [] (componentDirs . condTreeData) (condLibrary gpd)+    subLibSourceDirs name = dirsForComponent (condSubLibraries gpd) name+    flibSourceDirs name = dirsForComponent (condForeignLibs gpd) name+    exeSourceDirs name = dirsForComponent (condExecutables gpd) name+    testSourceDirs name = dirsForComponent (condTestSuites gpd) name+    benchSourceDirs name = dirsForComponent (condBenchmarks gpd) name++    -- Match a component name across every kind. The main library is keyed by+    -- the package name rather than an unqualified component name, so it joins+    -- in only when @name@ is the package name.+    componentSourceDirsByName name =+        mainLibForName name+            <> subLibSourceDirs name+            <> flibSourceDirs name+            <> exeSourceDirs name+            <> testSourceDirs name+            <> benchSourceDirs name++    mainLibForName name+        | toString name == mainPkgName = mainLibSourceDirs+        | otherwise = []++    allComponentSourceDirs =+        mainLibSourceDirs+            <> concatMap (componentDirs . condTreeData . snd) (condSubLibraries gpd)+            <> concatMap (componentDirs . condTreeData . snd) (condForeignLibs gpd)+            <> concatMap (componentDirs . condTreeData . snd) (condExecutables gpd)+            <> concatMap (componentDirs . condTreeData . snd) (condTestSuites gpd)+            <> concatMap (componentDirs . condTreeData . snd) (condBenchmarks gpd)++    dirsForComponent components name =+        let ucn = mkUnqualComponentName (toString name)+        in  concatMap (componentDirs . condTreeData . snd) $ filter ((== ucn) . fst) components
+ src/Tricorder/Session/WatchExclusionPatterns.hs view
@@ -0,0 +1,27 @@+module Tricorder.Session.WatchExclusionPatterns+    ( WatchExclusionPatterns (..)+    , Pattern+    , resolveWatchExclusionPatterns+    ) where++import Data.Default (Default (..))+import Text.Regex.TDFA.ReadRegex (parseRegex)++import Text.Regex.TDFA.Pattern qualified as Regex+++newtype WatchExclusionPatterns = WatchExclusionPatterns {getWatchExclusionPatterns :: [Pattern]}+    deriving stock (Eq, Generic, Show)+++instance Default WatchExclusionPatterns where+    def = WatchExclusionPatterns []+++type Pattern = (Regex.Pattern, (Regex.GroupIndex, Regex.DoPa))+++resolveWatchExclusionPatterns :: [Text] -> Either Text WatchExclusionPatterns+resolveWatchExclusionPatterns rawPatterns = do+    bimap show WatchExclusionPatterns+        $ traverse (parseRegex . toString) rawPatterns
src/Tricorder/Socket/Client.hs view
@@ -7,6 +7,7 @@     , queryDiagnostic     , requestShutdown     , isDaemonRunning+    , isDaemonReady     ) where  import Atelier.Effects.Delay (Delay)@@ -19,18 +20,25 @@ import Effectful.Reader.Static (Reader, ask) import Effectful.State.Static.Shared (evalState, get, modify, put) import System.IO.Error (isEOFError)+import Prelude hiding (force)  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.Build (BuildState, Diagnostic) import Tricorder.Runtime (PidFile)-import Tricorder.Socket.Protocol (ClientMessage (..), DiagnosticQuery (..), Query (..), StatusQuery (..))-import Tricorder.SourceLookup (ModuleSourceResult)+import Tricorder.Socket.Protocol+    ( ClientMessage (..)+    , DiagnosticQuery (..)+    , Force (..)+    , Query (..)+    , StatusQuery (..)+    , Waiters (..)+    )+import Tricorder.Socket.UnixSocket (UnixSocket, withConnection)+import Tricorder.SourceLookup (ModuleSourceResult, SourceQuery)  import Tricorder.Version qualified as Version @@ -60,23 +68,30 @@  -- | Connect and stream build updates, calling the handler after each completed build. -- Retries automatically when the connection is lost or the daemon is restarting.+--+-- A transient drop is tolerated for a few attempts before giving up. While+-- @isRestarting@ reports 'True' (a restart we initiated is in flight) the retry+-- budget is ignored and reconnection continues indefinitely, so the watch+-- survives the gap between stopping the old daemon and the new one binding its+-- socket. queryWatch     :: forall es      . (Delay :> es, File :> es, UnixSocket :> es)     => FilePath+    -> Eff es Bool+    -- ^ Whether a restart is currently in progress.     -> (Either Restarting BuildState -> Eff es ())     -> Eff es ()-queryWatch sockPath handler = evalState retryLimit retryLoop+queryWatch sockPath isRestarting handler = evalState retryLimit retryLoop   where     retryLimit = 3 :: Int     retryLoop = do         retries <- get @Int-        if retries <= 0 then-            pure ()-        else do+        keepGoing <- if retries > 0 then pure True else inject isRestarting+        when keepGoing do             void $ trySync $ withConnection sockPath \h -> sendQuery h Watch >> loop h             Delay.wait (500 :: Millisecond)-            modify $ subtract 1+            when (retries > 0) $ modify $ subtract 1             retryLoop      loop h = do@@ -123,20 +138,38 @@         Right d -> pure $ Right d  -requestShutdown :: (File :> es, UnixSocket :> es) => FilePath -> Eff es (Either Text ())-requestShutdown sockPath = withConnection sockPath \h -> do-    sendQuery h Quit+requestShutdown+    :: (File :> es, UnixSocket :> es)+    => Force -> FilePath -> Eff es (Either Text ())+requestShutdown force sockPath = withConnection sockPath \h -> do+    sendQuery h $ Quit waiters     line <- File.hGetLine h     if eitherDecode (BSL.fromStrict (encodeUtf8 line)) == Right True then         pure $ Right ()     else         pure $ Left "Failed to request shutdown"+  where+    waiters = case force of+        Force -> IgnoreWaiters+        NoForce -> WaitForWaiters   isDaemonRunning :: (Daemons :> es, Reader PidFile :> es) => Eff es Bool isDaemonRunning = do     pidFile <- ask     Daemons.isRunning pidFile+++-- | Check whether the daemon socket is bound and accepting connections.+--+-- The PID file can appear before the daemon has bound its socket, so a+-- running process is not enough to guarantee a client can connect. This opens+-- (and immediately closes) a throwaway connection and reports whether it+-- succeeded.+isDaemonReady :: (UnixSocket :> es) => FilePath -> Eff es Bool+isDaemonReady sockPath =+    either (const False) (const True)+        <$> trySync (withConnection sockPath \_ -> pass)   -- internals
src/Tricorder/Socket/Protocol.hs view
@@ -1,16 +1,21 @@ module Tricorder.Socket.Protocol-    ( Query (..)+    ( Force (..)+    , Query (..)     , StatusQuery (..)     , DiagnosticQuery (..)     , ErrorResponse (..)     , ClientMessage (..)+    , Waiters (..)     ) where  import Data.Aeson (FromJSON, ToJSON) -import Tricorder.GhcPkg.Types (SourceQuery)+import Tricorder.SourceLookup (SourceQuery)  +data Force = Force | NoForce++ data StatusQuery = StatusQuery {awaitDone :: Bool}     deriving stock (Eq, Generic, Show)     deriving anyclass (FromJSON, ToJSON)@@ -26,7 +31,12 @@     | Watch     | Source [SourceQuery]     | DiagnosticAt DiagnosticQuery-    | Quit+    | Quit Waiters+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, ToJSON)+++data Waiters = WaitForWaiters | IgnoreWaiters     deriving stock (Eq, Generic, Show)     deriving anyclass (FromJSON, ToJSON)
src/Tricorder/Socket/Server.hs view
@@ -1,26 +1,37 @@-module Tricorder.Socket.Server (component, SocketRemoved (..)) where+module Tricorder.Socket.Server (main, 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.Env (Env) import Atelier.Effects.Exit (Exit, exitSuccess) import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Input (Input, input) import Atelier.Effects.Log (Log)-import Atelier.Time (Millisecond)+import Atelier.Effects.Publishing.Sub (Sub) import Data.Aeson (ToJSON, decode, encode) import Effectful.Exception (IOException, finally) import Effectful.Reader.Static (Reader, ask)+import Effectful.State.Static.Shared (State) import System.IO (Handle)  import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Publishing.Sub qualified as Sub import Data.ByteString.Lazy qualified as BSL+import Effectful.State.Static.Shared qualified as State -import Tricorder.BuildState (BuildPhase (..), BuildResult (..), BuildState (..), Diagnostic)-import Tricorder.Effects.BuildStore (BuildStore, getState, waitForAnyChange, waitUntilDone)-import Tricorder.Effects.GhcPkg (GhcPkg)-import Tricorder.Effects.UnixSocket+import Tricorder.Build (BuildId, BuildPhase, BuildState (..), Diagnostic)+import Tricorder.Daemon.DaemonInfo (DaemonInfo)+import Tricorder.Module (ModuleName, PackageId)+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Socket.Protocol+    ( ClientMessage (..)+    , DiagnosticQuery (..)+    , ErrorResponse (..)+    , Query (..)+    , StatusQuery (..)+    )+import Tricorder.Socket.UnixSocket     ( UnixSocket     , acceptHandle     , bindSocket@@ -29,58 +40,68 @@     , 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.SourceLookup (ModuleSourceResult, SourceQuery (..), lookupModuleSource)+import Tricorder.SourceLookup.Cabal (Cabal)+import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.Version (VersionMismatch (..), checkVersion)+import Tricorder.Waiters (Waiters) +import Tricorder.Build qualified as Build+import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Build.Test qualified as Test+import Tricorder.Socket.Protocol qualified as Protocol+import Tricorder.Waiters qualified as Waiters + 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+main+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es        , Cache ModuleName PackageId :> es        , Conc :> es-       , Delay :> es+       , Env :> es        , Exit :> es        , FileSystem :> es        , GhcPkg :> es+       , Input BuildId :> es+       , Input DaemonInfo :> es        , Log :> es        , Reader SocketPath :> es+       , Sub BuildPhase :> es        , UnixSocket :> es+       , Waiters :> es        )-    => Component es-component =-    defaultComponent-        { name = "SocketServer"-        , setup = do-            SocketPath sockPath <- ask-            removeSocketFile sockPath-        , triggers = pure [acceptTrigger]-        }+    => Eff es Void+main = State.evalState Build.Starting do+    Conc.fork_ $ Sub.listen_ @BuildPhase State.put +    SocketPath sockPath <- ask+    removeSocketFile sockPath+    acceptTrigger + acceptTrigger-    :: ( BuildStore :> es-       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es        , Cache ModuleName PackageId :> es        , Conc :> es-       , Delay :> es+       , Env :> es        , Exit :> es        , FileSystem :> es        , GhcPkg :> es+       , Input BuildId :> es+       , Input DaemonInfo :> es        , Log :> es        , Reader SocketPath :> es+       , State BuildPhase :> es+       , Sub BuildPhase :> es        , UnixSocket :> es+       , Waiters :> es        )-    => Trigger es+    => Eff es Void acceptTrigger = do     SocketPath sockPath <- ask     sock <- bindSocket sockPath@@ -91,15 +112,21 @@   handleConnection-    :: ( BuildStore :> es-       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es        , Cache ModuleName PackageId :> es-       , Delay :> es+       , Conc :> es+       , Env :> es        , Exit :> es        , FileSystem :> es        , GhcPkg :> es+       , Input BuildId :> es+       , Input DaemonInfo :> es        , Log :> es+       , State BuildPhase :> es+       , Sub BuildPhase :> es        , UnixSocket :> es+       , Waiters :> es        )     => Handle     -> Eff es ()@@ -117,15 +144,21 @@   dispatch-    :: ( BuildStore :> es-       , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es        , Cache ModuleName PackageId :> es-       , Delay :> es+       , Conc :> es+       , Env :> es        , Exit :> es        , FileSystem :> es        , GhcPkg :> es+       , Input BuildId :> es+       , Input DaemonInfo :> es        , Log :> es+       , State BuildPhase :> es+       , Sub BuildPhase :> es        , UnixSocket :> es+       , Waiters :> es        )     => Query     -> Handle@@ -136,88 +169,106 @@     Watch -> watchStream h     Source moduleNames -> respondSource moduleNames h     DiagnosticAt dq -> respondDiagnostic dq.index h-    Quit -> quit h+    Quit waiters -> quit h waiters  -quit :: (Exit :> es, Log :> es, UnixSocket :> es) => Handle -> Eff es ()-quit h = do-    sendJson h True-    Log.info "Shutting down."-    exitSuccess+quit+    :: ( Exit :> es+       , Log :> es+       , UnixSocket :> es+       , Waiters :> es+       )+    => Handle -> Protocol.Waiters -> Eff es ()+quit h = \case+    Protocol.WaitForWaiters -> Waiters.wait doQuit+    Protocol.IgnoreWaiters -> doQuit+  where+    doQuit = do+        sendJson h True+        Log.info "Shutting down."+        exitSuccess  -respondOnce :: (BuildStore :> es, UnixSocket :> es) => Handle -> Eff es ()-respondOnce h = getState >>= sendJson h+respondOnce+    :: ( Input BuildId :> es+       , Input DaemonInfo :> es+       , State BuildPhase :> es+       , UnixSocket :> es+       )+    => Handle -> Eff es ()+respondOnce h = do+    progress <- State.get+    mkBuildState progress >>= 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+respondWhenDone+    :: ( Conc :> es+       , Input BuildId :> es+       , Input DaemonInfo :> es+       , State BuildPhase :> es+       , Sub BuildPhase :> es+       , UnixSocket :> es+       )+    => Handle -> Eff es ()+respondWhenDone h = awaitResult >>= mkBuildState >>= 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+    awaitResult = Conc.scoped do+        progressP <- Conc.fork $ Sub.listenUntil_ \case+            failed@(Build.Failed _) -> Just failed+            finished@(Build.Finished _ _) -> Just finished+            _ -> Nothing+        s <- State.get+        waitOrStart progressP 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'+    waitOrStart p = \case+        finished@(Build.Finished _ _) -> pure finished+        failed@(Build.Failed _) -> pure failed+        _ -> Conc.await p  --- | Stream a JSON object after each state change (loops until handle closes or error).-watchStream :: (BuildStore :> es, UnixSocket :> es) => Handle -> Eff es ()+-- | Stream a JSON object after each state change event.+watchStream+    :: ( Input BuildId :> es+       , Input DaemonInfo :> es+       , State BuildPhase :> es+       , Sub BuildPhase :> 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+    progress0 <- State.get+    mkBuildState progress0 >>= sendJson h+    vacuous $ Sub.listen_ \progress ->+        mkBuildState progress >>= sendJson h  -respondDiagnostic :: (BuildStore :> es, UnixSocket :> es) => Int -> Handle -> Eff es ()+respondDiagnostic :: (State BuildPhase :> 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"+    progress <- State.get+    case progress of+        Build.Finished result postBuild+            | not $ Test.anyRunningTests postBuild.testSuites && Eval.phasePending postBuild.evalComments ->+                case result.diagnostics !!? (idx - 1) of+                    Nothing ->+                        sendJson h+                            $ ErrorResponse+                            $ "No diagnostic #"+                                <> show idx+                                <> " (current build has "+                                <> show (length result.diagnostics)+                                <> ")"+                    Just d -> sendJson h (d :: Diagnostic)+            | otherwise -> sendJson h $ ErrorResponse "Build in progress"+        Build.Failed msg -> sendJson h $ ErrorResponse $ "Build command failed:\n" <> msg+        _ -> 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+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es        , Cache ModuleName PackageId :> es+       , Env :> es        , FileSystem :> es        , GhcPkg :> es        , Log :> es@@ -233,3 +284,10 @@  sendJson :: (ToJSON a, UnixSocket :> es) => Handle -> a -> Eff es () sendJson h val = sendLine h (decodeUtf8 (BSL.toStrict (encode val)))+++mkBuildState :: (Input BuildId :> es, Input DaemonInfo :> es) => BuildPhase -> Eff es BuildState+mkBuildState phase = do+    daemonInfo <- input+    buildId <- input+    pure $ BuildState {daemonInfo, buildId, phase}
+ src/Tricorder/Socket/UnixSocket.hs view
@@ -0,0 +1,154 @@+module Tricorder.Socket.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/SourceLookup.hs view
@@ -1,72 +1,75 @@ module Tricorder.SourceLookup     ( -- * Types-      ModuleName-    , PackageId-    , SourceQuery (..)+      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.Env (Env)+import Atelier.Effects.FileSystem (FileSystem) 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-+import Tricorder.Module (ModuleName (..), PackageId (..))+import Tricorder.SourceLookup.Cabal (Cabal)+import Tricorder.SourceLookup.GhcPkg (GhcPkg)+import Tricorder.SourceLookup.Slice (sliceSymbol)+import Tricorder.SourceLookup.Tarball+    ( TarballOutcome (..)+    , obtainTarball+    , readModuleMember+    ) --- | 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)+import Tricorder.SourceLookup.GhcPkg qualified as GhcPkg   -- | 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]+    = -- | Source was found; contains the module (or single-symbol) source text.+      SourceFound SourceQuery Text     | -- | 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.+    | -- | The package was resolved but no source tarball could be located or+      -- fetched (no index, offline, yanked, or the archive could not be read).+      SourceUnavailable SourceQuery PackageId+    | -- | The module source was found but the requested symbol was not in it.       FunctionNotFound SourceQuery     deriving stock (Eq, Generic, Show)     deriving anyclass (FromJSON, ToJSON)  +-- | A query for module source: optionally scoped to a single top-level symbol.+data SourceQuery = SourceQuery+    { moduleName :: ModuleName+    , function :: Maybe Text+    -- ^ The symbol to slice: 'Nothing' is the whole module; @'Just' name@ is a+    -- single top-level declaration — a value binding, or (by initial casing) a+    -- type, class, or constructor.+    }+    deriving stock (Eq, Generic, Show)+    deriving anyclass (FromJSON, Hashable, ToJSON)++ -- ── Lookup logic ───────────────────────────────────────────────────────────  -- | Resolve and return the source for a single module. ----- Checks both cache levels before issuing any shell-outs.+-- Resolves the module to its project-pinned 'PackageId' via @ghc-pkg@, then+-- serves source from that package's sdist tarball in cabal's global cache,+-- fetching it on demand if absent. A symbol query slices the relevant+-- declaration (with its doc comment) from the module source. Both resolution+-- steps are cached, so the fetch + read cost is paid at most once per+-- (package, query). lookupModuleSource-    :: ( Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es        , Cache ModuleName PackageId :> es+       , Env :> es        , FileSystem :> es        , GhcPkg :> es        , Log :> es@@ -74,223 +77,68 @@     => 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+    mPkg <- resolvePackage query.moduleName+    case mPkg of         Nothing -> pure (SourceNotFound query)         Just p -> do-            mCachedSrc <- cacheLookup @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query)-            case mCachedSrc of-                Just (src, reExports) -> do+            mCached <- cacheLookup @(PackageId, SourceQuery) @ModuleSourceResult (p, query)+            case mCached of+                Just result -> 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+                    pure result+                Nothing -> serveFromTarball query p  --- | 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)))+-- | Resolve a module to its package, consulting the module -> package cache first.+resolvePackage+    :: (Cache ModuleName PackageId :> es, GhcPkg :> es, Log :> es)+    => ModuleName+    -> Eff es (Maybe PackageId)+resolvePackage modName = do+    mCachedPkg <- cacheLookup @ModuleName @PackageId modName+    case mCachedPkg of+        Just p -> do+            Log.debug $ "Source: " <> unModuleName modName <> " → " <> unPackageId p <> " (cached)"+            pure (Just p)+        Nothing -> do+            result <- GhcPkg.findModule modName+            Log.debug $ "Source: find-module " <> unModuleName modName <> " → " <> show result+            whenJust result (cacheInsert @ModuleName @PackageId modName)+            pure result  --- | 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+-- | Locate (or fetch) the package's tarball, read the module member, and slice+-- the requested symbol if any. Caches and returns the result.+serveFromTarball+    :: ( Cabal :> es+       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+       , Env :> es+       , FileSystem :> es+       )+    => SourceQuery+    -> PackageId+    -> Eff es ModuleSourceResult+serveFromTarball query p =+    obtainTarball p >>= \case+        -- A failed `cabal fetch` is transient (offline, stale index), so return+        -- unavailable WITHOUT caching: a later lookup retries once the network or+        -- index recovers, rather than serving the negative for the whole window.+        TarballFetchFailed -> pure (SourceUnavailable query p)+        -- The package is genuinely absent — a deterministic negative, safe to+        -- cache alongside the read/slice outcomes below.+        TarballAbsent -> cacheResult (SourceUnavailable query p)+        TarballAt tarball -> do+            mModuleSrc <- readModuleMember tarball query.moduleName+            cacheResult $ case mModuleSrc of+                Nothing -> SourceUnavailable query p+                Just moduleSrc -> case query.function of+                    Nothing -> SourceFound query moduleSrc+                    Just symbol -> case sliceSymbol symbol moduleSrc of+                        Just slice -> SourceFound query slice+                        Nothing -> FunctionNotFound query   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;" "\""+    -- Cache a deterministic outcome so the fetch + read/slice cost is paid at+    -- most once per (package, query) within the cache window.+    cacheResult result = do+        cacheInsert @(PackageId, SourceQuery) @ModuleSourceResult (p, query) result+        pure result
+ src/Tricorder/SourceLookup/Cabal.hs view
@@ -0,0 +1,99 @@+-- | A narrow effect for the non-interactive @cabal@ subcommands tricorder+-- needs. The interpreter is the /sole/ spawner of the @cabal@ executable, and+-- it only ever runs the specific, pre-validated commands modelled here —+-- callers can neither pass arbitrary arguments nor choose the working+-- directory (fetches are pinned to the project root). Interactive+-- @cabal repl@ sessions are a separate concern, handled by+-- "Tricorder.Daemon.GhciSession.GhciProcess".+module Tricorder.SourceLookup.Cabal+    ( -- * Effect+      Cabal+    , FetchResult (..)+    , fetchSource++      -- * Interpreters+    , runCabalIO+    , runCabalFetchWith+    , CabalScript (..)+    ) where++import Atelier.Effects.Log (Log)+import Atelier.Effects.Process (Process, proc, readProcess, setWorkingDir)+import Effectful (Effect)+import Effectful.Dispatch.Dynamic (interpret)+import Effectful.Exception (trySync)+import Effectful.Reader.Static (Reader, ask)+import Effectful.TH (makeEffect)+import System.Exit (ExitCode (..))++import Atelier.Effects.Log qualified as Log+import Data.Text qualified as T++import Tricorder.Module (PackageId (..))+import Tricorder.Runtime (ProjectRoot (..))+++-- | Whether an on-demand fetch exited cleanly. A clean exit that still leaves+-- no tarball is a /deterministic/ absence (safe to cache); a failed fetch is+-- /transient/ (must not be cached).+data FetchResult = Fetched | FetchFailed+    deriving stock (Eq, Show)+++-- | The non-interactive @cabal@ subcommands tricorder drives. Each runs the+-- user's /own/ @cabal@ executable inside their project — tricorder deliberately+-- does not bring the @Cabal@ library along as a Haskell dependency, so+-- behaviour always matches the user's toolchain and project configuration.+data Cabal :: Effect where+    -- | @cabal fetch --no-dependencies \<pkgId\>@, run in the project root so it+    -- honours the project's configured repositories (CHaP, constraints).+    -- Reports only whether the fetch exited cleanly, so a transient failure+    -- (offline, stale index, yanked) stays distinguishable from a genuine+    -- absence and is not cached.+    FetchSource :: PackageId -> Cabal m FetchResult+++makeEffect ''Cabal+++-- | Production interpreter. The only code path that spawns @cabal@.+runCabalIO+    :: (Log :> es, Process :> es, Reader ProjectRoot :> es)+    => Eff (Cabal : es) a+    -> Eff es a+runCabalIO = interpret \_ -> \case+    FetchSource pkgId -> do+        ProjectRoot projectRoot <- ask+        Log.info $ "Source: cabal fetch " <> unPackageId pkgId+        let cfg =+                setWorkingDir projectRoot+                    $ proc "cabal" ["fetch", "--no-dependencies", toString (unPackageId pkgId)]+        result <- trySync (readProcess cfg)+        case result of+            Right (ExitSuccess, _, _) -> pure Fetched+            Right (ExitFailure _, out, err) -> do+                let details = T.strip (decodeUtf8 (err <> out))+                    suffix = if T.null details then "" else ": " <> details+                Log.warn $ "Source: cabal fetch failed for " <> unPackageId pkgId <> suffix+                pure FetchFailed+            Left e -> do+                Log.warn $ "Source: cabal fetch failed for " <> unPackageId pkgId <> ": " <> show e+                pure FetchFailed+++-- | Test interpreter: every 'fetchSource' yields the result of @onFetch@, which+-- runs in the remaining effects so it can model the fetch's observable side+-- effect — e.g. populating a fake filesystem to mimic a warmed cache.+-- 'cabalVersion' is unsupported. Use this when the unit under test drives+-- @cabal@ solely through 'fetchSource'.+runCabalFetchWith :: Eff es FetchResult -> Eff (Cabal : es) a -> Eff es a+runCabalFetchWith onFetch = interpret \_ -> \case+    FetchSource _ -> onFetch+++-- | Script element for the pure test interpreter.+data CabalScript+    = -- | Return this value for the next 'fetchSource' call.+      NextFetch FetchResult+    | -- | Return this value for the next 'cabalVersion' call.+      NextVersion (Maybe Text)
+ src/Tricorder/SourceLookup/GhcPkg.hs view
@@ -0,0 +1,46 @@+module Tricorder.SourceLookup.GhcPkg+    ( GhcPkg+    , findModule+    , 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.Module (ModuleName (..), PackageId (..))+++data GhcPkg :: Effect where+    FindModule :: ModuleName -> GhcPkg m (Maybe PackageId)+++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+++-- | Script element for the test interpreter.+newtype GhcPkgScript+    = -- | Return this value for the next 'findModule' call.+      NextFindModule (Maybe PackageId)+++-- | 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"
+ src/Tricorder/SourceLookup/Slice.hs view
@@ -0,0 +1,265 @@+-- | A pure, lexical source slicer.+--+-- It is deliberately /lexical/. It reasons about column-0 anchors, leading+-- keywords, and blank-line boundaries; it never builds a real Haskell AST. That+-- keeps it robust to CPP, unknown language extensions, and exotic syntax: a+-- shape it cannot make sense of simply yields 'Nothing', and the caller falls+-- back to the whole module (or reports the symbol as not found). It never+-- throws.+module Tricorder.SourceLookup.Slice+    ( sliceSymbol+    ) where++import Data.Char (isAlphaNum, isSpace, isUpper)++import Data.List qualified as List+import Data.Text qualified as T+++-- | Slice the declaration that introduces @symbol@ from @source@.+--+-- Returns the top-level declaration that introduces the symbol: the declaration+-- head, any type signature directly above it, and the contiguous doc-comment+-- block above that — terminating at the blank line or the next top-level+-- declaration that ends it. 'Nothing' when no introducing declaration is found.+sliceSymbol :: Text -> Text -> Maybe Text+sliceSymbol symbol source+    | T.null symbol = Nothing+    | otherwise =+        let ls = T.lines source+        in  if isTypeSymbol symbol then+                sliceType symbol ls <|> sliceConstructor symbol ls+            else+                sliceValue symbol ls+++-- | Evaluate whether the symbol references a type-level entity.+isTypeSymbol :: Text -> Bool+isTypeSymbol = maybe False (isUpper . fst) . T.uncons+++-- ── Value bindings ─────────────────────────────────────────────────────────++-- | Slice the value binding introducing @name@ (a function, CAF, or operator).+sliceValue :: Text -> [Text] -> Maybe Text+sliceValue name ls =+    (\i -> expandAt (belongsToValue name) i ls) <$> List.findIndex (introducesValue name) ls+++-- | Whether a line introduces the value @name@ at column 0 — its type+-- signature, an equation head, or a bare binding. Operators are matched in+-- their parenthesised @(op)@ form.+introducesValue :: Text -> Text -> Bool+introducesValue name line =+    isCol0 line+        && ( leadingIdent line == name+                || ("(" <> name <> ")") `T.isPrefixOf` line+           )+++-- | Whether a column-0 line below the anchor still belongs to the value binding+-- for @name@: a further equation or signature (same leading identifier or+-- @(name)@ head), or — for an operator — an infix equation whose left-hand side+-- uses it (e.g. @a \<+\> b = …@, which leads with the argument rather than the+-- operator).+belongsToValue :: Text -> Text -> Bool+belongsToValue name line =+    introducesValue name line+        || (isOperatorName name && usesOperatorInHead name line)+++-- | Whether @line@ is an equation whose left-hand side applies operator @name@+-- infix. The head is the text before the first @=@; the operator must appear+-- there as a whitespace-delimited token, so an unrelated binding that merely+-- mentions the operator in its /body/ (@merge x y = x \<+\> y@) is excluded.+usesOperatorInHead :: Text -> Text -> Bool+usesOperatorInHead name line =+    (" " <> name <> " ") `T.isInfixOf` (" " <> T.strip head_ <> " ")+  where+    head_ = fst (T.breakOn "=" line)+++-- | Whether @name@ is an operator (its first character is not identifier-like).+isOperatorName :: Text -> Bool+isOperatorName = maybe False (not . isIdentChar . fst) . T.uncons+++-- ── Type / class declarations ──────────────────────────────────────────────++-- | Slice the type-level declaration head introducing @name@. A type\/class+-- body is entirely indented, so no column-0 line below the head belongs to it.+sliceType :: Text -> [Text] -> Maybe Text+sliceType name ls =+    (\i -> expandAt (const False) i ls) <$> List.findIndex (introducesType name) ls+++-- | Whether a column-0 line is a declaration head for the type-level @name@.+introducesType :: Text -> Text -> Bool+introducesType name line =+    isCol0 line+        && case T.words line of+            ("data" : "family" : n : _) -> tok n == name+            ("type" : "family" : n : _) -> tok n == name+            ("data" : n : _) -> tok n == name+            ("newtype" : n : _) -> tok n == name+            ("type" : n : _) -> tok n == name+            ("class" : ws) -> maybe False ((== name) . tok) (classHead ws)+            _ -> False+  where+    tok = T.takeWhile isIdentChar+++-- | The class name from the words following the @class@ keyword: the first word+-- after the superclass context (the last @=>@), or the very first word when+-- there is no context. So @class Eq a => Ord a where@ yields @Ord@, not the+-- superclass @Eq@.+classHead :: [Text] -> Maybe Text+classHead ws =+    case break (== "=>") (reverse (takeWhile (/= "where") ws)) of+        (afterContext, _ : _) -> viaNonEmpty last afterContext+        (_, []) -> listToMaybe ws+++-- | Slice the @data@ \/ @newtype@ declaration whose body defines @name@ as a+-- constructor, returning that whole declaration block. Used as a fallback for+-- uppercase queries that do not name a type head.+sliceConstructor :: Text -> [Text] -> Maybe Text+sliceConstructor name ls =+    List.find (mentionsConstructor name) (map (\i -> expandAt (const False) i ls) dataHeads)+  where+    dataHeads = List.findIndices isDataNewtypeHead ls+++-- | Whether a column-0 line opens a @data@ or @newtype@ declaration.+isDataNewtypeHead :: Text -> Bool+isDataNewtypeHead line =+    isCol0 line+        && case T.words line of+            ("data" : _) -> True+            ("newtype" : _) -> True+            _ -> False+++-- | Whether a declaration block defines @name@ as a constructor. Lexical and+-- approximate, but it looks only at /constructor positions/ — the leading token+-- of each @|@-separated alternative in an ADT, or the names before @::@ in a+-- GADT — so a mention of @name@ as a field type or inside a doc comment does not+-- count, and we do not return a @data@ block that merely references it.+mentionsConstructor :: Text -> Text -> Bool+mentionsConstructor name block = name `elem` constructorNames block+++-- | The constructor names introduced by a @data@ \/ @newtype@ block, ignoring+-- doc comments. Handles both ADT syntax (@= A x | B y@) and GADT syntax+-- (@A, B :: …@ lines under a @where@ head).+constructorNames :: Text -> [Text]+constructorNames block =+    case filter (not . isCommentLine) (T.lines block) of+        [] -> []+        code@(headLine : rest)+            | "where" `elem` T.words headLine -> concatMap gadtCons rest+            | otherwise -> adtCons (T.unwords code)+  where+    -- ADT: names lead each alternative after the first @=@.+    adtCons decl =+        let rhs = T.drop 1 (T.dropWhile (/= '=') decl)+        in  mapMaybe (leadingCon . T.stripStart) (T.splitOn "|" rhs)+    -- GADT: @Con1, Con2 :: …@ — names before the @::@.+    gadtCons line+        | "::" `T.isInfixOf` line =+            mapMaybe (leadingCon . T.strip) (T.splitOn "," (fst (T.breakOn "::" line)))+        | otherwise = []+    leadingCon t = case leadingIdent t of+        "" -> Nothing+        ident -> Just ident+++-- ── Block expansion ────────────────────────────────────────────────────────++-- | Expand the declaration anchored at line index @i@ into its full slice: the+-- contiguous doc-comment block above @i@, then the declaration from @i@ down to+-- (but not including) the next top-level declaration.+--+-- The block ends at the next top-level (column-0) declaration. Indented lines,+-- blank lines, and CPP directives all continue it — so a blank line inside a+-- @where@ clause or between guards does not truncate the slice — while+-- @sameDecl@ recognises the column-0 lines that also continue it (further+-- equations of a value binding, or an operator's infix body). Trailing blank+-- lines picked up before the boundary are trimmed off.+expandAt :: (Text -> Bool) -> Int -> [Text] -> Text+expandAt sameDecl i ls =+    let (before, rest) = splitAt i ls+        docBlock = docCommentAbove before+        body = case rest of+            [] -> []+            (hd : tl) -> hd : takeWhile continuesBody tl+    in  T.intercalate "\n" (docBlock <> dropTrailingBlanks body)+  where+    continuesBody line =+        isBlank line+            || not (isCol0 line)+            || isCppLine line+            || sameDecl line+    dropTrailingBlanks = reverse . dropWhile isBlank . reverse+++-- | The contiguous doc-comment block immediately above a declaration, in source+-- order. Handles line comments (@--@) and multi-line block comments+-- (@{- … -}@), whose interior and closing lines are not themselves+-- comment-prefixed. Stops at the first non-comment (or blank) line.+docCommentAbove :: [Text] -> [Text]+docCommentAbove before = reverse (takeDoc (reverse before))+  where+    takeDoc [] = []+    takeDoc (l : ls)+        | isCommentLine l = l : takeDoc ls+        | closesBlockComment l =+            let (blockBody, ls') = consumeToBlockOpen ls+            in  (l : blockBody) <> takeDoc ls'+        | otherwise = []+    -- Consume upward (source-reversed) until the line that opens the block.+    consumeToBlockOpen [] = ([], [])+    consumeToBlockOpen (l : ls)+        | opensBlockComment l = ([l], ls)+        | otherwise = let (blockBody, ls') = consumeToBlockOpen ls in (l : blockBody, ls')+    closesBlockComment l = "-}" `T.isSuffixOf` T.stripEnd l && not (opensBlockComment l)+    opensBlockComment l = "{-" `T.isPrefixOf` T.stripStart l+++-- ── Lexical helpers ────────────────────────────────────────────────────────++-- | A line that is empty or only whitespace.+isBlank :: Text -> Bool+isBlank = T.null . T.strip+++-- | A line whose first non-blank content opens a comment (@--@ or @{-@). Used+-- to gather the doc block above a declaration.+isCommentLine :: Text -> Bool+isCommentLine line =+    let s = T.stripStart line+    in  "--" `T.isPrefixOf` s || "{-" `T.isPrefixOf` s+++-- | A CPP directive line (@#if@, @#else@, @#endif@, …). These sit at column 0+-- but are transparent to declaration boundaries, so a slice spans them.+isCppLine :: Text -> Bool+isCppLine = T.isPrefixOf "#" . T.stripStart+++-- | A line whose first character is in column 0 (not indented, not empty).+isCol0 :: Text -> Bool+isCol0 line = case T.uncons line of+    Just (c, _) -> not (isSpace c)+    Nothing -> False+++-- | The leading identifier token of a line, or @""@ when it does not start with+-- one. E.g. @"foo x = 1"@ → @"foo"@, @"foo :: Int"@ → @"foo"@, @"-- doc"@ → @""@.+leadingIdent :: Text -> Text+leadingIdent = T.takeWhile isIdentChar+++-- | Characters that may appear in a Haskell identifier.+isIdentChar :: Char -> Bool+isIdentChar c = isAlphaNum c || c == '_' || c == '\''
+ src/Tricorder/SourceLookup/Tarball.hs view
@@ -0,0 +1,244 @@+-- | Locate, fetch, and read a package's source from its Hackage sdist tarball+-- in cabal's global package cache.+module Tricorder.SourceLookup.Tarball+    ( -- * High-level+      TarballOutcome (..)+    , obtainTarball+    , readModuleMember++      -- * Pure helpers (exposed for testing)+    , splitPackageId+    , tarballPath+    , cabalPackagesDirs+    , matchesModule+    , extractModule+    ) where++import Atelier.Effects.Env (Env, getEnvironment)+import Atelier.Effects.FileSystem+    ( FileSystem+    , doesFileExist+    , doesPathExist+    , listDirectory+    , readFileLbs+    )+import Data.Char (isUpper)+import Effectful.Exception (trySync)+import System.FilePath (splitDirectories, (</>))++import Codec.Archive.Tar qualified as Tar+import Codec.Compression.GZip qualified as GZip+import Data.ByteString.Lazy qualified as BSL+import Data.List qualified as List+import Data.Text qualified as T++import Tricorder.Module (ModuleName (..), PackageId (..))+import Tricorder.SourceLookup.Cabal (Cabal, FetchResult (..), fetchSource)+++-- | The default repository subdirectory under the cabal package cache.+hackageRepo :: FilePath+hackageRepo = "hackage.haskell.org"+++-- ── High-level ─────────────────────────────────────────────────────────────++-- | The result of locating (and, if needed, fetching) a package's tarball.+data TarballOutcome+    = TarballAt FilePath+    | -- | No tarball, though the lookup completed cleanly (absent from every+      -- configured repository, or yanked).+      TarballAbsent+    | -- | The on-demand @cabal fetch@ itself failed (offline, stale index, …).+      TarballFetchFailed+    deriving stock (Eq, Show)+++-- | Locate @pkgId@'s sdist tarball in the cabal cache, fetching it on demand if+-- absent.+--+-- The cache holds one @\<pkg\>-\<ver\>.tar.gz@ per resolved package at a+-- predictable path. On a hit we return that path directly. On a miss we warm+-- the cache with @cabal fetch --no-dependencies@ — the exact version @ghc-pkg@+-- reports — and look again. The outcome distinguishes a genuine absence from a+-- transient fetch failure.+obtainTarball+    :: (Cabal :> es, Env :> es, FileSystem :> es)+    => PackageId+    -> Eff es TarballOutcome+obtainTarball pkgId = do+    found <- findTarball pkgId+    case found of+        Just path -> pure (TarballAt path)+        Nothing -> do+            fetched <- fetchSource pkgId+            refound <- findTarball pkgId+            pure $ case refound of+                Just path -> TarballAt path+                Nothing -> case fetched of+                    Fetched -> TarballAbsent+                    FetchFailed -> TarballFetchFailed+++-- | Read a single module's source from a tarball, in-process. 'Nothing' when+-- the member is absent or the archive cannot be read (any decompression or+-- parse error is caught, never propagated).+readModuleMember :: (FileSystem :> es) => FilePath -> ModuleName -> Eff es (Maybe Text)+readModuleMember tarball modName = do+    raw <- readFileLbs tarball+    -- 'force' drives the lazy gunzip + tar parse to completion inside 'trySync',+    -- so a corrupt archive yields 'Nothing' instead of a deferred exception.+    result <- trySync (pure $! force (extractModule modName raw))+    pure (either (const Nothing) id result)+++-- ── Locate ─────────────────────────────────────────────────────────────────++-- | Search every candidate cabal cache directory (and every repository subdir+-- within it) for @pkgId@'s tarball, preferring @hackage.haskell.org@.+findTarball :: (Env :> es, FileSystem :> es) => PackageId -> Eff es (Maybe FilePath)+findTarball pkgId = do+    env <- getEnvironment+    candidates <- concat <$> traverse basePaths (cabalPackagesDirs env)+    firstExisting candidates+  where+    basePaths base = do+        repos <- listRepos base+        pure [tarballPath base repo pkgId | repo <- repos]+    firstExisting [] = pure Nothing+    firstExisting (p : ps) = do+        exists <- doesFileExist p+        if exists then pure (Just p) else firstExisting ps+++-- | The repository subdirectories under the cache, @hackage.haskell.org@ first.+-- Falls back to just @hackage.haskell.org@ when the cache directory is absent.+listRepos :: (FileSystem :> es) => FilePath -> Eff es [FilePath]+listRepos base = do+    exists <- doesPathExist base+    if not exists then+        pure [hackageRepo]+    else do+        entries <- listDirectory base+        pure (hackageRepo : filter (/= hackageRepo) entries)+++-- | Candidate cabal package-cache directories to search, most-preferred first.+--+-- Honors @CABAL_DIR@; otherwise searches the XDG cache and both the modern+-- @~\/.cache\/cabal@ and the legacy pre-XDG @~\/.cabal@ layouts, since which one+-- cabal uses depends on its version and on whether @~\/.cabal@ already exists.+--+-- Only absolute candidates are produced: when @HOME@ (and the cabal vars) are+-- unset — as in a stripped daemon environment — the result is empty rather than+-- a path resolved relative to the working directory.+cabalPackagesDirs :: [(String, String)] -> [FilePath]+cabalPackagesDirs env =+    case List.lookup "CABAL_DIR" env of+        Just dir | not (null dir) -> [dir </> "packages"]+        _ -> xdgCandidate <> homeCandidates+  where+    xdgCandidate = case List.lookup "XDG_CACHE_HOME" env of+        Just x | not (null x) -> [x </> "cabal" </> "packages"]+        _ -> []+    homeCandidates = case List.lookup "HOME" env of+        Just h+            | not (null h) ->+                [ h </> ".cache" </> "cabal" </> "packages"+                , h </> ".cabal" </> "packages"+                ]+        _ -> []+++-- ── Pure helpers ───────────────────────────────────────────────────────────++-- | Split a 'PackageId' into its package name and version. The version is the+-- final hyphen-delimited component (versions are dot-, not hyphen-separated),+-- so @"list-t-1.0.5.7"@ → @("list-t", "1.0.5.7")@.+splitPackageId :: PackageId -> (Text, Text)+splitPackageId (PackageId pid) =+    case reverse (T.splitOn "-" pid) of+        (ver : nameParts@(_ : _)) -> (T.intercalate "-" (reverse nameParts), ver)+        _ -> (pid, "")+++-- | The cache path of a package's tarball under one repository subdir:+-- @\<base\>\/\<repo\>\/\<pkg\>\/\<ver\>\/\<pkg\>-\<ver\>.tar.gz@.+tarballPath :: FilePath -> FilePath -> PackageId -> FilePath+tarballPath base repo pkgId =+    let (name, ver) = splitPackageId pkgId+    in  base </> repo </> toString name </> toString ver </> toString (name <> "-" <> ver <> ".tar.gz")+++-- | Whether a tarball entry path is the source file for @modName@. Matches the+-- module's dotted-to-slashed path plus a Haskell source extension as a suffix,+-- which resolves @src\/@, @lib\/@, and flat layouts uniformly+-- (@\<pkg\>-\<ver\>\/src\/Data\/Aeson.hs@ etc.) and covers preprocessed sources+-- (@.hsc@, @.lhs@, @.chs@).+--+-- The path component immediately before the match must be a source root (e.g.+-- @src@, the package dir), not another module component — otherwise module+-- @Lens@ would spuriously match the file for @Control.Lens@.+matchesModule :: ModuleName -> FilePath -> Bool+matchesModule modName path = any matchesWithExtension sourceExtensions+  where+    slashed = T.map dotToSlash (unModuleName modName)+    txt = toText path+    matchesWithExtension ext = case T.stripSuffix ("/" <> slashed <> ext) txt of+        Just before -> not (endsWithModuleComponent before)+        Nothing -> False+    endsWithModuleComponent before = case T.uncons (T.takeWhileEnd (/= '/') before) of+        Just (c, _) -> isUpper c+        Nothing -> False+    dotToSlash '.' = '/'+    dotToSlash c = c+++-- | Source-file extensions whose base name equals the final module component.+sourceExtensions :: [Text]+sourceExtensions = [".hs", ".lhs", ".hsc", ".chs"]+++-- | Extract @modName@'s source text from a gzipped tarball. 'Nothing' when no+-- member matches.+extractModule :: ModuleName -> LByteString -> Maybe Text+extractModule modName tarGz =+    decodeUtf8 . BSL.toStrict <$> extractMember (matchesModule modName) tarGz+++-- | The bytes of the best regular-file entry whose path satisfies the+-- predicate: a library path in preference to a same-named copy under a+-- @test@\/@bench@\/@example@ tree, then the shallowest path. This keeps a+-- package's test module from shadowing the library module of the same name.+extractMember :: (FilePath -> Bool) -> LByteString -> Maybe LByteString+extractMember matches tarGz =+    snd <$> viaNonEmpty head (List.sortOn rank candidates)+  where+    entries = Tar.read (GZip.decompress tarGz)+    candidates = Tar.foldEntries step [] (const []) entries+    step entry acc = case Tar.entryContent entry of+        Tar.NormalFile bytes _+            | matches path -> (path, bytes) : acc+          where+            path = Tar.entryPath entry+        _ -> acc+    rank (path, _) = (isNonLibraryPath path, length (splitDirectories path))+++-- | Whether a path lies under a non-library source tree (tests, benchmarks,+-- examples), which we deprioritise when the same module appears more than once.+isNonLibraryPath :: FilePath -> Bool+isNonLibraryPath path = any (`elem` nonLibraryDirs) (splitDirectories path)+  where+    nonLibraryDirs :: [FilePath]+    nonLibraryDirs =+        [ "test"+        , "tests"+        , "bench"+        , "benchmark"+        , "benchmarks"+        , "example"+        , "examples"+        , "spec"+        , "specs"+        ]
src/Tricorder/TestOutput.hs view
@@ -5,7 +5,7 @@  import Data.Text qualified as T -import Tricorder.BuildState (TestCase (..), TestCaseOutcome (..))+import Tricorder.Build.Test qualified as Test   -- | Parse hspec output into individual test case results.@@ -14,18 +14,18 @@ -- 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 :: Text -> [Test.Case] parseHspecOutput = go . T.lines   where     go [] = []     go (l : ls)         | T.isSuffixOf "OK" norm =-            TestCase {description = extractDesc "OK" norm, outcome = TestCasePassed}+            Test.Case {description = extractDesc "OK" norm, outcome = Test.Passed}                 : 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}+            in  Test.Case {description = extractDesc "FAIL" norm, outcome = Test.Failed details}                     : go rest         | otherwise = go ls       where
− src/Tricorder/UI.hs 
@@ -1,72 +0,0 @@-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 (..), neverShowCursor)-import Brick.Keybindings (KeyConfig)-import Effectful.Reader.Static (Reader, ask)--import Atelier.Effects.Conc qualified as Conc--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 (mkAttrMap, 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 = mkAttrMap-        , appChooseCursor = neverShowCursor-        }
− src/Tricorder/UI/Event.hs 
@@ -1,38 +0,0 @@-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 
@@ -1,240 +0,0 @@-module Tricorder.UI.Keys-    ( KeyEvent-    , Config-    , keys-    , dispatcher-    , viewKeybindings-    , mkKeyConfig-    , keybindForRoute-    ) 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.KeyConfig (firstActiveBinding)-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.Route (Route)-import Tricorder.UI.State-    ( State (..)-    , Viewports (..)-    , currentRoute-    , cycleTestFilter-    , navigate-    , viewToViewport-    )--import Tricorder.UI.Route qualified as Route----- When adding a new event here, also list it in the README under "Custom Key Bindings".-data KeyEvent-    = ToggleDaemonInfoView-    | ToggleHelp-    | CycleTestView-    | ExitView-    | ScrollUp-    | ScrollDown-    | Quit-    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)-        , ("toggle help", ToggleHelp)-        , ("cycle test view", CycleTestView)-        , ("exit view", ExitView)-        , ("scroll up", ScrollUp)-        , ("scroll down", ScrollDown)-        , ("quit", Quit)-        ]---bindings :: [(KeyEvent, [Binding])]-bindings =-    [ (ToggleDaemonInfoView, [bind 'g'])-    , (ToggleHelp, [bind 'h'])-    , (CycleTestView, [bind 't'])-    , (ExitView, [binding KEsc []])-    , (ScrollUp, [binding KUp []])-    , (ScrollDown, [binding KDown []])-    , (Quit, [bind 'q', ctrl 'c'])-    ]---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 currentRoute s == Route.DaemonInfo then-                        navigate Route.Main s-                    else-                        navigate Route.DaemonInfo s-            , onEvent ToggleHelp "Toggle help" do-                modify \s ->-                    if currentRoute s == Route.Help then-                        navigate Route.Main s-                    else-                        navigate Route.Help s-            , onEvent CycleTestView "Cycle test results view" do-                modify \s -> case currentRoute s of-                    Route.Tests ->-                        if s.testFilter == maxBound then-                            navigate Route.Main s {testFilter = minBound}-                        else-                            s {testFilter = cycleTestFilter s.testFilter}-                    _ -> navigate Route.Tests s-            , onEvent ExitView "Exit or go back" do-                gets (.route) >>= \case-                    Route.Main -> halt-                    _ -> modify $ navigate Route.Main-            , onEvent ScrollUp "Scroll up" do-                mvp <- gets (viewToViewport . currentRoute)-                case mvp of-                    Just vp -> vScrollBy (viewportScroll vp) (-1)-                    Nothing -> pure ()-            , onEvent ScrollDown "Scroll down" do-                mvp <- gets (viewToViewport . currentRoute)-                case mvp of-                    Just vp ->-                        vScrollBy (viewportScroll vp) 1-                    Nothing -> pure ()-            , onEvent Quit "Exit" do-                halt-            ]-  where-    stringify =-        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 triggers =-    hBox-        [ warn $ txt $ eventName <> ": "-        , txt $ showBindings $ mconcat $ getBindings <$> triggers-        ]-  where-    showBindings = T.intercalate ", " . fmap ppBinding . sort . toList-    getBindings = \case-        ByKey k -> Set.singleton k-        ByEvent e -> Set.fromList $ allActiveBindings kc e---keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding-keybindForRoute kc = \case-    Route.Main -> Nothing-    Route.DaemonInfo -> firstActiveBinding kc ToggleDaemonInfoView-    Route.Help -> firstActiveBinding kc ToggleHelp-    Route.Tests -> firstActiveBinding kc CycleTestView
− src/Tricorder/UI/Misc.hs 
@@ -1,50 +0,0 @@-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/Route.hs 
@@ -1,20 +0,0 @@-module Tricorder.UI.Route-    ( Route (..)-    , name-    ) where---data Route-    = Main-    | Help-    | DaemonInfo-    | Tests-    deriving stock (Bounded, Enum, Eq)---name :: Route -> Text-name = \case-    Main -> "Dashboard"-    Help -> "Help"-    DaemonInfo -> "Daemon info"-    Tests -> "Tests"
− src/Tricorder/UI/State.hs 
@@ -1,77 +0,0 @@-module Tricorder.UI.State-    ( Viewports (..)-    , State (..)-    , Processed (..)-    , TestFilter (..)-    , init-    , currentRoute-    , viewToViewport-    , cycleTestFilter-    , navigate-    ) where--import Atelier.Effects.Clock (Clock, TimeZone)-import Prelude hiding (init)--import Atelier.Effects.Clock qualified as Clock--import Tricorder.BuildState (BuildState (..))-import Tricorder.UI.Route (Route)--import Tricorder.UI.Route qualified as Route---data Viewports-    = MainViewport-    | DiagnosticViewport-    | TestViewport-    deriving stock (Eq, Ord, Show)---data State = State-    { buildState :: Processed Text BuildState-    , timeZone :: TimeZone-    , route :: Route-    , testFilter :: TestFilter-    }---data TestFilter = TestFilterAll | TestFilterFailedOnly-    deriving stock (Bounded, Enum, Eq)---cycleTestFilter :: TestFilter -> TestFilter-cycleTestFilter x = if x == maxBound then minBound else succ x---data Processed e a-    = Waiting-    | Failure e-    | Success a---currentRoute :: State -> Route-currentRoute = (.route)---viewToViewport :: Route -> Maybe Viewports-viewToViewport = \case-    Route.Tests -> Just TestViewport-    Route.Main -> Just DiagnosticViewport-    _ -> Nothing---navigate :: Route -> State -> State-navigate route s = s {route}---init :: (Clock :> es) => Eff es State-init = do-    tz <- Clock.currentTimeZone-    pure-        State-            { buildState = Waiting-            , timeZone = tz-            , route = Route.Main-            , testFilter = minBound-            }
− src/Tricorder/UI/View.hs 
@@ -1,473 +0,0 @@-module Tricorder.UI.View (mkAttrMap, view) where--import Atelier.Effects.Clock (TimeZone)-import Atelier.Time (Millisecond, toMicroseconds)-import Brick-    ( AttrMap-    , AttrName-    , VScrollBarOrientation (..)-    , ViewportType (..)-    , Widget-    , attrMap-    , attrName-    , vBox-    , viewport-    )-import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList, ppBinding)-import Brick.Widgets.Core-    ( Padding (..)-    , emptyWidget-    , hBox-    , 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 Graphics.Vty.Attributes qualified as Attr-import Graphics.Vty.Attributes.Color qualified as Color--import Tricorder.BuildState-    ( BuildPhase (..)-    , BuildProgress (..)-    , BuildResult (..)-    , BuildState (..)-    , DaemonInfo (..)-    , Diagnostic (..)-    , Severity (..)-    , TestCase (..)-    , TestCaseOutcome (..)-    , TestRun (..)-    , TestRunCompletion (..)-    , TestRunError (..)-    )-import Tricorder.Session (Target, renderTarget)-import Tricorder.TestOutput (stripGhciNoise)-import Tricorder.UI.Keys (KeyEvent, keybindForRoute, viewKeybindings)-import Tricorder.UI.Misc (emphasis, err, hBoxSpaced, ok, subtle, vBoxSpaced, warn)-import Tricorder.UI.Route (Route)-import Tricorder.UI.State (Processed (..), State (..), TestFilter (..), Viewports (..), currentRoute)--import Tricorder.UI.Keys qualified as Keys-import Tricorder.UI.Route qualified as Route-import Tricorder.Version qualified as Version---mkAttrMap :: State -> AttrMap-mkAttrMap =-    const-        ( attrMap-            Attr.defAttr-            [ (attrName "ok", Attr.withForeColor Attr.defAttr Color.green)-            , (attrName "warning", Attr.withForeColor Attr.defAttr Color.yellow)-            , (attrName "error", Attr.withForeColor Attr.defAttr Color.red)-            , (attrName "emphasis", Attr.withStyle Attr.defAttr Attr.bold)-            , (attrName "subtle", Attr.withForeColor Attr.defAttr $ Color.rgbColor @Int 148 148 148)-            ]-        )---view :: KeyConfig KeyEvent -> State -> [Widget Viewports]-view kc ws =-    [ vBoxSpaced-        1-        [ vBox-            [ viewAppHeader ws-            , viewTabs kc ws-            ]-        , case currentRoute ws of-            Route.Help ->-                viewHelp kc-            Route.DaemonInfo ->-                viewDaemonInfo ws-            Route.Tests ->-                viewTests ws-            Route.Main ->-                viewMain ws-        ]-    ]---viewTabs :: KeyConfig KeyEvent -> State -> Widget n-viewTabs kc ws =-    hBoxSpaced 1-        $ intersperse (subtle $ txt "-")-        $ viewRouteTab kc ws <$> universe @Route---viewRouteTab :: KeyConfig KeyEvent -> State -> Route -> Widget n-viewRouteTab kc ws route =-    style $ txt $ Route.name route <> keyBind-  where-    style = if route == currentRoute ws then id else subtle-    showBinding = (" " <>) . ("[" <>) . (<> "]") . ppBinding-    keyBind = maybe "" showBinding $ keybindForRoute kc route---viewDaemonInfo :: State -> Widget Viewports-viewDaemonInfo ws =-    withBuildState ws (viewExpandedDaemonInfo . (.daemonInfo))---viewTests :: State -> Widget Viewports-viewTests ws =-    withBuildState ws (viewTestResultsPanel ws)---viewMain :: State -> Widget Viewports-viewMain ws = withBuildState ws (viewDefaultPanel ws.timeZone)---viewHelp :: KeyConfig KeyEvent -> Widget n-viewHelp kc = viewKeybindings kc handlers-  where-    handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher kc)---withBuildState :: State -> (BuildState -> Widget Viewports) -> Widget Viewports-withBuildState ws render =-    case ws.buildState of-        Waiting ->-            txt "Waiting for build..."-        Failure reason ->-            txt $ "Error when contacting daemon: " <> reason-        Success bs ->-            render bs---viewAppHeader :: State -> Widget n-viewAppHeader ws =-    ok-        $ emphasis-        $ txt-        $ "Tricorder"-            <> maybe-                ""-                (" - " <>)-                (viewHeading ws)---viewHeading :: State -> Maybe Text-viewHeading ws = case currentRoute ws of-    Route.Tests -> case ws.testFilter of-        TestFilterAll -> Just "Tests"-        TestFilterFailedOnly -> Just "Tests - Failed only"-    Route.Help -> Just "Help"-    Route.DaemonInfo -> Just "Daemon info"-    Route.Main -> Nothing---viewDefaultPanel :: TimeZone -> BuildState -> Widget Viewports-viewDefaultPanel tz bs = viewBuildPhase tz bs.phase---viewTestResultsPanel :: State -> BuildState -> Widget Viewports-viewTestResultsPanel ws bs =-    vBoxSpaced-        1-        [ viewBuildPhaseLine ws.timeZone bs.phase-        , viewTestPanel ws.testFilter (phaseTestRuns bs.phase)-        ]---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 :: [Target] -> Widget n-viewTargets targets =-    hBoxSpaced-        1-        [ emphasis $ txt "Targets:"-        , if null targets then-            txt "(all)"-          else-            txtWrap (T.intercalate " " (map renderTarget 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 :: TestFilter -> [TestRun] -> Widget Viewports-viewTestPanel _ [] = subtle $ txt "No test results."-viewTestPanel tvf runs = scrollableRuns tvf runs---scrollableRuns :: TestFilter -> [TestRun] -> Widget Viewports-scrollableRuns tvf runs =-    vScrollViewport TestViewport (viewTestRunDetail tvf <$> runs)---viewTestRunDetail :: TestFilter -> TestRun -> Widget n-viewTestRunDetail _ (TestRunning t Nothing) = hBox [txt t, txt "  ", warn $ txt "running..."]-viewTestRunDetail _ (TestRunning t (Just p)) =-    hBox [txt t, txt "  ", warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"]-viewTestRunDetail _ (TestRunErrored e) = hBoxSpaced 1 [txt e.target, err $ txt "error:", txt e.message]-viewTestRunDetail tvf (TestRunCompleted c) =-    vBox-        [ hBox [txt c.target, txt "  ", viewCompletionStatus c]-        , viewTestOutput tvf c-        ]---viewTestOutput :: TestFilter -> TestRunCompletion -> Widget n-viewTestOutput TestFilterAll c =-    padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output)-viewTestOutput TestFilterFailedOnly 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/Waiters.hs view
@@ -0,0 +1,49 @@+module Tricorder.Waiters+    ( Waiters (..)+    , with+    , without+    , wait+    , run+    ) where++import Effectful (Effect)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, retry)+import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift)+import Effectful.Exception (bracket_)+import Effectful.TH (makeEffect)+++data Waiters :: Effect where+    -- | Perform an action, signalling that there is a waiter inhabiting the+    -- action.+    With :: m a -> Waiters m a+    -- | Perform an action only if there are no waiters.+    Without :: m a -> Waiters m ()+    -- | Wait for there to be no waiters, then perform the passed action.+    Wait :: m a -> Waiters m a+++makeEffect ''Waiters+++run :: (Concurrent :> es) => Eff (Waiters : es) a -> Eff es a+run act = do+    waiters <- newTVarIO (0 :: Int)+    interpretWith act \env -> \case+        With m -> localSeqUnlift env \unlift -> do+            bracket_+                (atomically $ modifyTVar' waiters (+ 1))+                (atomically $ modifyTVar' waiters (max 0 . subtract 1))+                $ unlift m+        Without m -> localSeqUnlift env \unlift -> do+            noWaiters <- atomically do+                n <- readTVar waiters+                pure (n <= 0)+            when noWaiters do+                void $ unlift m+        Wait m -> localSeqUnlift env \unlift -> do+            atomically do+                n <- readTVar waiters+                when (n > 0) retry+            unlift m
− src/Tricorder/Watcher.hs 
@@ -1,178 +0,0 @@-module Tricorder.Watcher-    ( component-    , WatchedFile (..)-    , WatcherSession (..)-    , isCabalFile-    , makeWatches-    , 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 Text.Regex.TDFA (ExecOption (..), blankCompOpt, blankExecOpt, match)-import Text.Regex.TDFA.TDFA (patternToRegex)--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 (Pattern, Session (..), WatchDirs (..), WatchExclusionPatterns (..))--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 :: WatchDirs-    , watchExclusionPatterns :: WatchExclusionPatterns-    }-    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 $ \session ->-        WatcherSession-            { watchDirs = session.watchDirs-            , watchExclusionPatterns = session.watchExclusionPatterns-            }---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 = makeWatches projectRoot session-        watchFilePathsDebounced watches \filePath fileEvent -> publish (WatchedFile filePath fileEvent)---makeWatches :: ProjectRoot -> WatcherSession -> [Watch]-makeWatches projectRoot session =-    sourceWatches (coerce session.watchExclusionPatterns) (coerce session.watchDirs)-        <> cabalWatches projectRoot---sourceWatches :: [Pattern] -> [FilePath] -> [Watch]-sourceWatches exclusionPatterns =-    map \d ->-        dirExt d ".hs"-            `excluding` containing "dist-newstyle"-            `excluding` exclusionMatches exclusionPatterns---exclusionMatches :: [Pattern] -> FilePath -> Bool-exclusionMatches exclusionPatterns fp = any matchPattern exclusionPatterns-  where-    matchPattern p =-        match-            (patternToRegex p blankCompOpt blankExecOpt {captureGroups = False})-            fp---cabalWatches :: ProjectRoot -> [Watch]-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/Unit/Tricorder/Build/EvalCommentSpec.hs view
@@ -0,0 +1,177 @@+module Unit.Tricorder.Build.EvalCommentSpec (spec_EvalComment) where++import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy)+import Text.Megaparsec (parse)++import Tricorder.Build.EvalComment qualified as Eval+++spec_EvalComment :: Spec+spec_EvalComment = do+    describe "singleLineEvalCommentP" testSingleLine+    describe "multiLineEvalCommentP" testMultiLine+    describe "blockCommentEvalP" testBlockComment+    describe "findComments" testFindComments+++--------------------------------------------------------------------------------+-- singleLineEvalCommentP+--------------------------------------------------------------------------------++testSingleLine :: Spec+testSingleLine = do+    it "parses a basic expression" do+        parse Eval.singleLineEvalCommentP "" "-- $> 1 + 2"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "1 + 2"}++    it "handles no space between marker and expression" do+        parse Eval.singleLineEvalCommentP "" "-- $>expr"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}++    it "strips leading whitespace from the expression" do+        parse Eval.singleLineEvalCommentP "" "-- $>   expr"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}++    it "captures the full expression including inner spaces" do+        parse Eval.singleLineEvalCommentP "" "-- $> foo bar baz"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "foo bar baz"}++    it "stops at a newline, not consuming it" do+        parse Eval.singleLineEvalCommentP "" "-- $> expr\nnext line"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}++    it "fails when there is no expression after the marker" do+        parse Eval.singleLineEvalCommentP "" "-- $>" `shouldSatisfy` isLeft++    it "fails on the multi-line opening marker" do+        parse Eval.singleLineEvalCommentP "" "-- $$> expr -- <$$" `shouldSatisfy` isLeft++    it "fails on other text between comment start and eval marker" do+        parse Eval.singleLineEvalCommentP "" "-- foo $> 1 + 2" `shouldSatisfy` isLeft++    it "fails on unrelated text" do+        parse Eval.singleLineEvalCommentP "" "hello world" `shouldSatisfy` isLeft+++--------------------------------------------------------------------------------+-- multiLineEvalCommentP+--------------------------------------------------------------------------------++testMultiLine :: Spec+testMultiLine = do+    it "parses a single content line, stripping the -- prefix" do+        parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr\n-- <$$"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}++    it "parses multiple content lines, stripping -- prefixes" do+        parse Eval.multiLineEvalCommentP "" "-- $$>\n-- foo\n-- bar\n-- <$$"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "foo\nbar"}++    it "preserves relative indentation after stripping -- prefix" do+        parse Eval.multiLineEvalCommentP "" "-- $$>\n-- let x = 1\n--     y = 2\n-- in x + y\n-- <$$"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n    y = 2\nin x + y"}++    it "handles -- with no trailing space" do+        parse Eval.multiLineEvalCommentP "" "-- $$>\n--expr\n-- <$$"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}++    it "parse multi-line eval comment in a single line" do+        parse Eval.multiLineEvalCommentP "" "-- $$> expr <$$"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}++    it "fails when the closing marker is absent" do+        parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr" `shouldSatisfy` isLeft++    it "fails on the single-line marker" do+        parse Eval.multiLineEvalCommentP "" "-- $> expr" `shouldSatisfy` isLeft++    it "fails on unrelated text" do+        parse Eval.multiLineEvalCommentP "" "hello world" `shouldSatisfy` isLeft+++--------------------------------------------------------------------------------+-- blockCommentEvalP+--------------------------------------------------------------------------------++testBlockComment :: Spec+testBlockComment = do+    it "parses a single-line expression on its own line" do+        parse Eval.blockCommentEvalP "" "{- $$>\n2 + 2\n<$$ -}"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "2 + 2"}++    it "parses an inline one-liner" do+        parse Eval.blockCommentEvalP "" "{- $$> 2 + 2 <$$ -}"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "2 + 2"}++    it "parses a multi-line expression preserving layout" do+        parse Eval.blockCommentEvalP "" "{- $$>\nlet x = 1\n    y = 2\nin x + y\n<$$ -}"+            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n    y = 2\nin x + y"}++    it "fails when the closing marker is absent" do+        parse Eval.blockCommentEvalP "" "{- $$>\nexpr" `shouldSatisfy` isLeft++    it "fails on the line-comment multi-line eval marker" do+        parse Eval.blockCommentEvalP "" "-- $$> expr" `shouldSatisfy` isLeft++    it "fails on the single-line eval marker" do+        parse Eval.blockCommentEvalP "" "{- $> expr -}" `shouldSatisfy` isLeft++    it "fails on unrelated text" do+        parse Eval.blockCommentEvalP "" "hello world" `shouldSatisfy` isLeft+++--------------------------------------------------------------------------------+-- findComments+--------------------------------------------------------------------------------++testFindComments :: Spec+testFindComments = do+    it "returns empty list for empty text" do+        Eval.findComments "" `shouldMatchList` []++    it "returns empty list when there are no eval comments" do+        Eval.findComments "hello world\nno comments here" `shouldMatchList` []++    it "finds a single single-line eval comment" do+        Eval.findComments "x = 1\n-- $> x\ny = 2"+            `shouldMatchList` [Eval.Comment {lineNumber = 2, expression = "x"}]++    it "finds multiple single-line eval comments in source order" do+        Eval.findComments "-- $> a\n-- $> b"+            `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"}+                              , Eval.Comment {lineNumber = 2, expression = "b"}+                              ]++    it "reports correct line numbers" do+        Eval.findComments "line1\nline2\n-- $> expr\nline4"+            `shouldMatchList` [Eval.Comment {lineNumber = 3, expression = "expr"}]++    it "ignores lines that look like partial markers" do+        Eval.findComments "-- $\n-- $> expr"+            `shouldMatchList` [Eval.Comment {lineNumber = 2, expression = "expr"}]++    it "does not match an eval marker embedded in another comment" do+        Eval.findComments "-- foo -- $> expr" `shouldMatchList` []++    it "does not match an inline eval marker appearing after code" do+        Eval.findComments "x = 1  -- $> x" `shouldMatchList` []++    it "finds a multi-line eval comment, stripping -- prefixes" do+        Eval.findComments "-- $$>\n-- expr\n-- <$$"+            `shouldMatchList` [Eval.Comment {lineNumber = 1, expression = "expr"}]++    it "finds a block comment eval" do+        Eval.findComments "{- $$>\nexpr\n<$$ -}"+            `shouldMatchList` [Eval.Comment {lineNumber = 1, expression = "expr"}]++    it "finds both single-line and multi-line eval comments" do+        Eval.findComments "-- $> a\n-- $$>\n-- b\n-- <$$"+            `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"}+                              , Eval.Comment {lineNumber = 2, expression = "b"}+                              ]++    it "finds both single-line and block comment eval comments" do+        Eval.findComments "-- $> a\n{- $$>\nb\n<$$ -}"+            `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"}+                              , Eval.Comment {lineNumber = 2, expression = "b"}+                              ]
− test/Unit/Tricorder/BuildStateSpec.hs 
@@ -1,81 +0,0 @@-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 
@@ -1,184 +0,0 @@-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 
@@ -1,1204 +0,0 @@-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-    , preserveFailureVisibility-    )-import Tricorder.Effects.GhciSession (Controls (..), LoadResult (..), LoadedModule (..), runGhciSessionScripted)-import Tricorder.Effects.GhciSession.GhciParser (collectResult, extractTitle, resolveKnownTargets)-import Tricorder.Effects.TestRunner (TestRunner (..), runTestRunnerScripted)-import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (Command (..), WatchDirs (..), parseTestTargets)--import Tricorder.BuildState qualified as BuildState-import Tricorder.Builder qualified as Builder-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]--        -- A failed executable 'Main' appears in :show targets only as its-        -- path ("app/Main.hs", since the name 'Main' is ambiguous across home-        -- units), so dispatch must match that path form to Reload, not :add.-        describe "when the file is a path-shaped target that failed on initial load" do-            it "calls controls.reload, not controls.add" do-                phases <--                    runTest-                        Map.empty-                        (KnownTargetNames (Set.singleton "app/Main.hs"))-                        distinctCtrls-                        (SourceChangeDetected "/abs/app/Main.hs" Modified)-                buildResultsFrom phases `shouldMatchList` [resultFor reloadLr]--    describe "Added" do-        describe "when the file is not loaded" $ it "calls controls.add" do-            phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Added)-            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 = 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 (parseTestTargets []) [] expected-        length phases `shouldBe` 1-        phases `shouldMatchList` [EnteringNewPhase (BuildId 1) $ Done expected]--    describe "when there are errors" $ it "should skip testing" do-        let expected' = expected {BuildState.diagnostics = [errMsg]}-        phases <- runTest (parseTestTargets ["test:foo"]) [] expected'-        length phases `shouldBe` 1-        phases `shouldMatchList` [EnteringNewPhase (BuildId 1) $ Done expected']--    it "should emit EnteringNewPhase events for each test target" do-        phases <--            runTest-                (parseTestTargets ["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 = Command ""-                        , targets = []-                        , testTargets = parseTestTargets ["test:foo", "test:bar"]-                        , watchDirs = 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 = Command ""-                    , targets = []-                    , testTargets-                    , watchDirs = 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--    -- GHCi renders a target whose module name is ambiguous across home units-    -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs".-    it "matches a path-shaped target on directory-segment boundaries" do-        fileMatchesAnyTarget-            (KnownTargetNames (Set.singleton "app/Main.hs"))-            "./tricorder/app/Main.hs"-            `shouldBe` True--    it "does not match a path-shaped target on a partial segment" do-        fileMatchesAnyTarget-            (KnownTargetNames (Set.singleton "pp/Main.hs"))-            "./tricorder/app/Main.hs"-            `shouldBe` False--    it "does not match a path-shaped target for a different file" do-        fileMatchesAnyTarget-            (KnownTargetNames (Set.singleton "daemon/Main.hs"))-            "./tricorder/app/Main.hs"-            `shouldBe` False-------------------------------------------------------------------------------------- mergeDiagnostics tests-----------------------------------------------------------------------------------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]--    describe "when the cycle reports none" $ it "clears a stale location-less diagnostic" do-        -- <no location info> is never in compiledFiles, so without special-        -- handling it would persist forever. A cycle with no location-less-        -- diagnostic must evict it.-        let noLoc = errMsg {file = "<no location info>"}-            prev = Map.fromList [(noLoc.file, [noLoc])]-            result =-                LoadResult-                    { moduleCount = 1-                    , compiledFiles = Set.singleton errMsg.file-                    , loadedModules = Map.empty-                    , targetNames = []-                    , diagnostics = []-                    }-        let merged = mergeDiagnostics prev result-        Map.lookup noLoc.file merged `shouldBe` Nothing--    it "refreshes a location-less diagnostic that is still present" do-        let noLoc = errMsg {file = "<no location info>"}-            prev = Map.fromList [(noLoc.file, [noLoc])]-            result =-                LoadResult-                    { moduleCount = 1-                    , compiledFiles = Set.empty-                    , loadedModules = Map.empty-                    , targetNames = []-                    , diagnostics = [noLoc]-                    }-        let merged = mergeDiagnostics prev result-        Map.lookup noLoc.file merged `shouldBe` Just [noLoc]-------------------------------------------------------------------------------------- filterToWatchDirs tests-----------------------------------------------------------------------------------testFilterToWatchDirs :: Spec-testFilterToWatchDirs = do-    let root = "/project"-        watchDirs = 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 (WatchDirs ["."]) [d] `shouldBe` []--    it "passes everything through when watchDirs is empty" do-        let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}-        filterToWatchDirs root (WatchDirs []) [d] `shouldBe` [d]--    it "works with the '.' fallback watch dir (whole project root)" do-        let d = errMsg {file = "./src/Foo.hs"}-            nixD = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}-        filterToWatchDirs root (WatchDirs ["."]) [d, nixD] `shouldBe` [d]--    describe "when diagnostic has no path it" $ it "keeps location-less <no location info> errors" do-        -- A home-unit GHC plugin that can't load under --enable-multi-repl-        -- produces a <no location info> error. It has no path to test against a-        -- watch dir, but must survive or the failed build reads as clean.-        let d = errMsg {file = "<no location info>"}-        filterToWatchDirs root watchDirs [d] `shouldBe` [d]--    it "does not treat a real <-prefixed path as a location-less marker" do-        -- isLocationLess requires a closing '>'. A real (if exotic) path that-        -- merely starts with '<' is an ordinary out-of-watch file and must be-        -- dropped, not kept as a build-level marker.-        let d = errMsg {file = "<generated>/Foo.hs"}-        filterToWatchDirs root watchDirs [d] `shouldBe` []--    describe "when its only error is out of watch dirs" $ it "a failed load does not read as clean" do-        -- collectResult only injects its synthetic failure when no SError is-        -- present. Here GHCi Failed with a single *located* error in a file-        -- outside the watch dirs, so collectResult adds no synthetic — and then-        -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The-        -- Builder pipeline composes preserveFailureVisibility after filtering to-        -- re-attach the failure, so a failed build never survives with zero-        -- diagnostics.-        let reloadOutput =-                [ "/other/Dep.hs:5:1: error: boom"-                , "Failed, 0 modules loaded."-                ]-            result = collectResult root reloadOutput [] []-            filtered = filterToWatchDirs root watchDirs result.diagnostics-        preserveFailureVisibility result.diagnostics filtered-            `shouldSatisfy` (not . null)-------------------------------------------------------------------------------------- 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
@@ -2,10 +2,7 @@  import Test.Hspec -import Tricorder.BuildState-    ( Diagnostic (..)-    , Severity (..)-    )+import Tricorder.Build (Diagnostic (..), Severity (..)) import Tricorder.CLI.Render (diagnosticBlock)
+ test/Unit/Tricorder/Daemon/BuildStateSpec.hs view
@@ -0,0 +1,107 @@+module Unit.Tricorder.Daemon.BuildStateSpec (spec_BuildState) where++import Data.Aeson (eitherDecode, encode)+import Data.Time (UTCTime (..), fromGregorian)+import Test.Hspec++import Tricorder.Build+    ( BuildId (..)+    , BuildResult (..)+    , BuildState (..)+    , Diagnostic (..)+    , PostBuild (..)+    , Severity (..)+    )+import Tricorder.Daemon.DaemonInfo (DaemonInfo (..))++import Tricorder.Build qualified as Build+import Tricorder.Build.EvalComment qualified as Eval+++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 =+                            Build.Failed+                                "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 =+            Build.Finished+                ( BuildResult+                    { completedAt = epoch+                    , duration = 0+                    , moduleCount = 0+                    , diagnostics = msgs+                    }+                )+                $ PostBuild mempty Eval.NoneFound+        , daemonInfo =+            DaemonInfo+                { targets = []+                , watchDirs = []+                , sockPath = ""+                , logFile = ""+                }+        }+  where+    epoch = UTCTime (fromGregorian 1970 1 1) 0
+ test/Unit/Tricorder/Daemon/BuilderSpec.hs view
@@ -0,0 +1,286 @@+module Unit.Tricorder.Daemon.BuilderSpec (spec_Builder) where++import Data.Time (UTCTime (..), addUTCTime, fromGregorian)+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.Build (BuildResult (..), Diagnostic (..), Severity (..))+import Tricorder.Daemon.Builder (NewLoadResult (..), compileBuildResults)+import Tricorder.Daemon.GhciSession.GhciParser+    ( LoadResult (..)+    , LoadedModule (..)+    , extractTitle+    , resolveKnownTargets+    )+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.WatchDirs (WatchDirs (..))+++spec_Builder :: Spec+spec_Builder = do+    describe "extractTitle" testExtractTitle+    describe "compileBuildResults" testCompileBuildResults+    describe "resolveKnownTargets" testResolveKnownTargets+++data StopSignal = StopSignal+    deriving stock (Show)+++testCompileBuildResults :: Spec+testCompileBuildResults = do+    it "uses NewLoadResult's times to calculate duration" do+        let (_, r) =+                compileBuildResults+                    root+                    watchDirs+                    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, _) =+                compileBuildResults root watchDirs (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) =+                compileBuildResults root watchDirs 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]+                    }+        r `shouldBe` expected+  where+    root = ProjectRoot "/"+    watchDirs = WatchDirs ["/src"]+++--------------------------------------------------------------------------------+-- 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 = []+            }+++--------------------------------------------------------------------------------+-- 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
+ test/Unit/Tricorder/Daemon/DispatchSpec.hs view
@@ -0,0 +1,282 @@+module Unit.Tricorder.Daemon.DispatchSpec (spec_Dispatch) where++import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy)++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.Build (Diagnostic (..), Severity (..))+import Tricorder.Daemon.Dispatch+    ( KnownTargetNames (..)+    , fileMatchesAnyTarget+    , filterToWatchDirs+    , mergeDiagnostics+    , preserveFailureVisibility+    )+import Tricorder.Daemon.GhciSession.GhciParser (LoadResult (..), collectResult)+import Tricorder.Session.WatchDirs (WatchDirs (..))+++spec_Dispatch :: Spec+spec_Dispatch = do+    describe "fileMatchesAnyTarget" testFileMatchesAnyTarget+    describe "mergeDiagnostics" testMergeDiagnostics+    describe "filterToWatchDirs" testFilterToWatchDirs+++--------------------------------------------------------------------------------+-- 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++    -- GHCi renders a target whose module name is ambiguous across home units+    -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs".+    it "matches a path-shaped target on directory-segment boundaries" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "app/Main.hs"))+            "./tricorder/app/Main.hs"+            `shouldBe` True++    it "does not match a path-shaped target on a partial segment" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "pp/Main.hs"))+            "./tricorder/app/Main.hs"+            `shouldBe` False++    it "does not match a path-shaped target for a different file" do+        fileMatchesAnyTarget+            (KnownTargetNames (Set.singleton "daemon/Main.hs"))+            "./tricorder/app/Main.hs"+            `shouldBe` False+++--------------------------------------------------------------------------------+-- mergeDiagnostics tests+--------------------------------------------------------------------------------++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]++    describe "when the cycle reports none" $ it "clears a stale location-less diagnostic" do+        -- <no location info> is never in compiledFiles, so without special+        -- handling it would persist forever. A cycle with no location-less+        -- diagnostic must evict it.+        let noLoc = errMsg {file = "<no location info>"}+            prev = Map.fromList [(noLoc.file, [noLoc])]+            result =+                LoadResult+                    { moduleCount = 1+                    , compiledFiles = Set.singleton errMsg.file+                    , loadedModules = Map.empty+                    , targetNames = []+                    , diagnostics = []+                    }+        let merged = mergeDiagnostics prev result+        Map.lookup noLoc.file merged `shouldBe` Nothing++    it "refreshes a location-less diagnostic that is still present" do+        let noLoc = errMsg {file = "<no location info>"}+            prev = Map.fromList [(noLoc.file, [noLoc])]+            result =+                LoadResult+                    { moduleCount = 1+                    , compiledFiles = Set.empty+                    , loadedModules = Map.empty+                    , targetNames = []+                    , diagnostics = [noLoc]+                    }+        let merged = mergeDiagnostics prev result+        Map.lookup noLoc.file merged `shouldBe` Just [noLoc]+++--------------------------------------------------------------------------------+-- filterToWatchDirs tests+--------------------------------------------------------------------------------++testFilterToWatchDirs :: Spec+testFilterToWatchDirs = do+    let root = "/project"+        watchDirs = 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 "keeps diagnostics under \".\" watched directory" do+        let d = errMsg {file = "src/Foo.hs"}+        filterToWatchDirs root (WatchDirs ["."]) [d] `shouldMatchList` [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 (WatchDirs ["."]) [d] `shouldBe` []++    it "passes everything through when watchDirs is empty" do+        let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}+        filterToWatchDirs root (WatchDirs []) [d] `shouldBe` [d]++    it "works with the '.' fallback watch dir (whole project root)" do+        let d = errMsg {file = "./src/Foo.hs"}+            nixD = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}+        filterToWatchDirs root (WatchDirs ["."]) [d, nixD] `shouldBe` [d]++    describe "when diagnostic has no path it" $ it "keeps location-less <no location info> errors" do+        -- A home-unit GHC plugin that can't load under --enable-multi-repl+        -- produces a <no location info> error. It has no path to test against a+        -- watch dir, but must survive or the failed build reads as clean.+        let d = errMsg {file = "<no location info>"}+        filterToWatchDirs root watchDirs [d] `shouldBe` [d]++    it "does not treat a real <-prefixed path as a location-less marker" do+        -- isLocationLess requires a closing '>'. A real (if exotic) path that+        -- merely starts with '<' is an ordinary out-of-watch file and must be+        -- dropped, not kept as a build-level marker.+        let d = errMsg {file = "<generated>/Foo.hs"}+        filterToWatchDirs root watchDirs [d] `shouldBe` []++    describe "when its only error is out of watch dirs" $ it "a failed load does not read as clean" do+        -- collectResult only injects its synthetic failure when no SError is+        -- present. Here GHCi Failed with a single *located* error in a file+        -- outside the watch dirs, so collectResult adds no synthetic — and then+        -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The+        -- Builder pipeline composes preserveFailureVisibility after filtering to+        -- re-attach the failure, so a failed build never survives with zero+        -- diagnostics.+        let reloadOutput =+                [ "/other/Dep.hs:5:1: error: boom"+                , "Failed, 0 modules loaded."+                ]+            result = collectResult root reloadOutput [] []+            filtered = filterToWatchDirs root watchDirs result.diagnostics+        preserveFailureVisibility result.diagnostics filtered+            `shouldSatisfy` (not . null)+++--------------------------------------------------------------------------------+-- 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"+        }
+ test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs view
@@ -0,0 +1,421 @@+module Unit.Tricorder.Daemon.GhciSession.GhciParserSpec (spec_GhciParser) where++import Test.Hspec++import Tricorder.Build (Diagnostic (..), Severity (..))+import Tricorder.Daemon.GhciSession.GhciParser+    ( GhciLoad (..)+    , GhciLoading (..)+    , GhciMessage (..)+    , GhciSeverity (..)+    , LoadOutcome (..)+    , LoadResult (..)+    , Position (..)+    , collectResult+    , collectResultCustom+    , 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++    describe "collectResultCustom" do+        describe "<no location info> plugin load failure" testPluginLoadFailure++    describe "collectResult" do+        describe "failed load with no located error" testUnattributedFailure+++--------------------------------------------------------------------------------+-- parseReload: clean build+--------------------------------------------------------------------------------++testCleanBuild :: Spec+testCleanBuild = do+    it "produces GLoading items for each compiled module" do+        let input =+                [ "[1 of 3] Compiling Tricorder.Build ( src/Tricorder.Build.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.Build", sourceFile = "src/Tricorder.Build.hs"}+                       , GLoading GhciLoading {index = 2, total = 3, moduleName = "Tricorder.Session", sourceFile = "src/Tricorder/Session.hs"}+                       , GLoading GhciLoading {index = 3, total = 3, moduleName = "Main", sourceFile = "app/Main.hs"}+                       , GSummary LoadSucceeded+                       ]++    it "handles padded module index (e.g. [ 1 of 47])" do+        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"}+                       , GSummary LoadSucceeded+                       ]++    describe "when only summary line" $ it "returns the summary outcome" do+        parseReload ["Ok, 0 modules loaded."] `shouldBe` [GSummary LoadSucceeded]+++--------------------------------------------------------------------------------+-- 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, Message, and summary items" 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"}+                       , GSummary LoadFailed+                       ]+++--------------------------------------------------------------------------------+-- 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'"+                                    ]+                                }+                       , GSummary LoadFailed+                       ]++    describe "when all modules are already up to date" $ it "returns the summary outcome" do+        -- GHCi with -fhide-source-paths and nothing to recompile+        parseReload ["Ok, 5 modules loaded."] `shouldBe` [GSummary LoadSucceeded]+++--------------------------------------------------------------------------------+-- 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"}+                       , GSummary LoadSucceeded+                       ]+++--------------------------------------------------------------------------------+-- parseShowModules+--------------------------------------------------------------------------------++testShowModules :: Spec+testShowModules = do+    it "parses typical :show modules output" do+        let input =+                [ "Tricorder.Build     ( src/Tricorder.Build.hs, interpreted )"+                , "Tricorder.Session        ( src/Tricorder/Session.hs, interpreted )"+                , "Main                     ( app/Main.hs, interpreted )"+                ]+        parseShowModules input+            `shouldBe` [ ("Tricorder.Build", "src/Tricorder.Build.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` []+++--------------------------------------------------------------------------------+-- collectResultCustom: <no location info> plugin load failure+--------------------------------------------------------------------------------++-- | Regression test for the \"All good\" bug with home-unit GHC plugins.+--+-- Under @cabal repl --enable-multi-repl@ every unit is interpreted, so a+-- package used as a GHC plugin in the same project is not available as a+-- compiled plugin. The unit that depends on it fails to load, GHCi reports the+-- failure with @\<no location info\>@ (it has no source span), and the load+-- ends with @Failed, N modules loaded@. This output must still surface as an+-- error diagnostic — otherwise the build is silently reported as clean.+testPluginLoadFailure :: Spec+testPluginLoadFailure = do+    -- Shape of the GHCi output from `cabal repl --enable-multi-repl` when an+    -- executable loads a home-unit GHC plugin: the plugin package's modules+    -- compile, then the unit using the plugin fails with a location-less error.+    let reloadOutput =+            [ "[3 of 5] Compiling My.Plugin       ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]"+            , "<no location info>: error:"+            , "    Could not load module \8216My.Plugin\8217."+            , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217."+            , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file."+            , "Use -v to see a list of the files searched for."+            , ""+            , "[5 of 5] Compiling Main            ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]"+            , "Failed, 4 modules loaded."+            ]+        result = collectResultCustom "/project" (parseReload reloadOutput) [] []++    it "surfaces the plugin load failure as an error diagnostic" do+        map (.severity) result.diagnostics `shouldContain` [SError]++    it "carries the plugin error message in the diagnostic title" do+        map (.title) result.diagnostics+            `shouldContain` ["Could not load module \8216My.Plugin\8217."]+++--------------------------------------------------------------------------------+-- collectResult: failed load with no located error+--------------------------------------------------------------------------------++-- 'collectResult' is the safety net: GHCi can end a load with @Failed, …@+-- without emitting any error that carries a source span. The build must never+-- read as clean in that case, so a synthetic error diagnostic is added.+testUnattributedFailure :: Spec+testUnattributedFailure = do+    describe "when the load failed but no error was located" $ it "adds a synthetic error" do+        let reloadOutput =+                [ "[1 of 2] Compiling Lib  ( src/Lib.hs, interpreted )"+                , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )"+                , "Failed, 1 module loaded."+                ]+            result = collectResult "/project" reloadOutput [] []+        map (.severity) result.diagnostics `shouldBe` [SError]++    it "does not duplicate a failure that already produced a located error" do+        let reloadOutput =+                [ "[1 of 1] Compiling Lib ( src/Lib.hs, interpreted )"+                , "src/Lib.hs:5:1: error: Oops"+                , "Failed, 0 modules loaded."+                ]+            result = collectResult "/project" reloadOutput [] []+        -- Only the real, located diagnostic — no synthetic one appended.+        map (.file) result.diagnostics `shouldBe` ["src/Lib.hs"]++    it "adds nothing for a successful load" do+        let reloadOutput =+                [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"+                , "Ok, 1 module loaded."+                ]+            result = collectResult "/project" reloadOutput [] []+        result.diagnostics `shouldBe` []++    describe "when 'Failed,' appears off the summary line" $ it "does not flag a clean build" do+        -- The load outcome lives on GHCi's single summary line+        -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a+        -- Template Haskell splice or top-level IO run while interpreting — can+        -- contain a line that happens to begin with "Failed,". That must not be+        -- mistaken for a failed load: the summary here is "Ok," so no synthetic+        -- error belongs.+        let reloadOutput =+                [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"+                , "Failed, retrying with fallback" -- printed by a TH splice+                , "Ok, 1 module loaded."+                ]+            result = collectResult "/project" reloadOutput [] []+        result.diagnostics `shouldBe` []
+ test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs view
@@ -0,0 +1,422 @@+module Unit.Tricorder.Daemon.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, terminateProcessGroup, withProcessGroup)+import Atelier.Effects.Process.Internal (RunningProcess (..))+import Atelier.Effects.Timeout (runTimeout)+import Atelier.Time (Millisecond)+import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (newTVarIO)+import Control.Exception (IOException, catch)+import Data.Char (isDigit)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Time.Units (Second)+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Exception (trySync)+import System.IO (hGetLine)+import System.Posix.Signals (nullSignal, sigKILL, signalProcess)+import System.Process.Typed+    ( createPipe+    , getStderr+    , getStdin+    , getStdout+    , setCreateGroup+    , setStderr+    , setStdin+    , setStdout+    , 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 Atelier.Effects.Process qualified as AProc+import Data.Text qualified as T+import System.Process qualified as Process+import System.Timeout qualified++import Tricorder.Daemon.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+    describe "withProcessGroup (process group)" testWithProcessGroupCleanup+    describe "terminateProcessGroup (process group)" testTerminateProcessGroup+++-- | 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 = RunningProcess 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 = RunningProcess 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+        -- The banner and error streams are pipes we drive ourselves, so the+        -- timing is deterministic rather than a race against the OS pipe buffer.+        (bannerOut, bannerOutW) <- Process.createPipe+        (errR, errW) <- Process.createPipe+        result <-+            runEff+                . runConcurrent+                . runTimeout+                . runDelay+                . runFile+                . runConc+                $ 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)+        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)+++-- | Regression for orphaned/zombie build subprocesses on restart and shutdown.+--+-- The original leak was on the /graceful/ path: GHCi exits cleanly on @:quit@,+-- so its leader is reaped, yet the build subprocesses sharing its group linger.+-- 'withProcessGroup' must still sweep the whole group even after the leader has+-- gone. We simulate it with a leader that forks a long-lived child sharing its+-- group and exits on stdin input (mirroring @:quit@); after 'withProcessGroup'+-- returns, the child must be gone.+testWithProcessGroupCleanup :: Spec+testWithProcessGroupCleanup =+    it "terminates the whole group on exit, even after the leader has exited" do+        childPidRef <- newIORef (Nothing :: Maybe Int)+        let scenario =+                runEff+                    . runConcurrent+                    . runTimeout+                    . runDelay+                    . runFile+                    . runConc+                    . runProcessIO+                    $ withProcessGroup procConfig \p -> do+                        -- First stdout line is the long-lived child's pid.+                        line <- File.hGetLine (AProc.getStdout p)+                        liftIO $ writeIORef childPidRef (parsePid (T.unpack line))+                        -- Let the leader exit and reap it, so the cleanup runs+                        -- with the leader already gone — the path the bug needed.+                        File.hPutTextLn (AProc.getStdin p) ""+                        File.hFlush (AProc.getStdin p)+                        void $ AProc.waitExitCode p+        -- Hard wall-clock bound: a regression must surface as a failed+        -- assertion, never as a hang that stalls the whole suite.+        outcome <- System.Timeout.timeout (8_000_000) scenario+        case outcome of+            Nothing -> expectationFailure "test timed out (process did not settle)"+            Just () ->+                readIORef childPidRef >>= \case+                    Nothing -> expectationFailure "could not capture the child pid"+                    Just childPid -> do+                        died <- waitForProcessDeath childPid+                        -- Never leak the child if the assertion fails.+                        ignoring (signalProcess sigKILL (fromIntegral childPid))+                        died `shouldBe` True+  where+    procConfig =+        setStdin createPipe+            $ setStdout createPipe+            $ setStderr createPipe+            $ shell "sleep 30 & echo \"$!\"; read _quit"+++-- | 'terminateProcessGroup' must kill the whole group when called mid-flight+-- (the leader still alive) — the explicit early-termination path the test+-- runner uses to abort a one-shot @cabal repl test:…@ from another thread.+testTerminateProcessGroup :: Spec+testTerminateProcessGroup =+    it "kills the whole group, not just the leader, mid-flight" do+        outcome <- System.Timeout.timeout (8_000_000) do+            p <-+                startProcess+                    $ setStdin createPipe+                    $ setStdout createPipe+                    $ setStderr createPipe+                    $ setCreateGroup True+                    $ shell "sleep 30 & echo \"$!\"; read _quit"+            childLine <- hGetLine (getStdout p)+            case parsePid childLine of+                Nothing -> do+                    ignoring (stopProcess p)+                    expectationFailure ("could not parse child pid from: " <> show childLine)+                    pure False+                Just childPid -> do+                    runEff . runProcessIO $ terminateProcessGroup (RunningProcess p)+                    died <- waitForProcessDeath childPid+                    -- Never leak the child if the assertion fails.+                    ignoring (signalProcess sigKILL (fromIntegral childPid))+                    pure died+        outcome `shouldBe` Just True+++-- | Parse a pid printed on its own line (tolerating surrounding whitespace).+parsePid :: String -> Maybe Int+parsePid = readMaybe . takeWhile isDigit . dropWhile (not . isDigit)+++-- | Swallow any exception from a best-effort cleanup action.+ignoring :: IO () -> IO ()+ignoring act = act `catch` \(_ :: SomeException) -> pure ()+++-- | Poll for up to ~3s for the given pid to disappear from the process table.+-- @signalProcess nullSignal@ is a liveness probe: it throws once the process is+-- gone (and reaped by init after being orphaned).+waitForProcessDeath :: Int -> IO Bool+waitForProcessDeath pid = go (60 :: Int)+  where+    go 0 = not <$> alive+    go n = do+        a <- alive+        if not a then pure True else threadDelay 50_000 >> go (n - 1)+    alive =+        (signalProcess nullSignal (fromIntegral pid) >> pure True)+            `catch` \(_ :: IOException) -> pure False+++testDecideInterrupt :: Spec+testDecideInterrupt = do+    -- Regression: an idle GHCi must not be SIGINT'd, since the matching+    -- 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 = RunningProcess 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/Daemon/GhciSessionSpec.hs view
@@ -0,0 +1,134 @@+module Unit.Tricorder.Daemon.GhciSessionSpec (spec_GhciSession) where++import Atelier.Effects.Publishing.Pub (Pub)+import Control.Exception (ErrorCall (..))+import Effectful (IOE, runEff)+import Effectful.Exception (try)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++import Atelier.Effects.Publishing.Pub qualified as Pub+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.Build (BuildProgress, Diagnostic (..), Severity (..))+import Tricorder.Daemon.GhciSession+    ( Controls (..)+    , GhciSession+    , LoadResult (..)+    , runGhciSessionScripted+    , withGhci+    )+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command (Command (..))+++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 (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial+                msgs `shouldBe` [errMsg]++            it "returns empty list when scripted result has no messages" do+                LoadResult {diagnostics = msgs} <-+                    runScripted [simpleResult []]+                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial+                msgs `shouldBe` []++            it "throws when scripted result is Left" do+                result <-+                    runScripted [Left (toException boom)]+                        $ try @ErrorCall+                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial+                result `shouldBe` Left boom++        describe "reloading" do+            it "returns scripted messages" do+                LoadResult {diagnostics = msgs} <-+                    runScripted [simpleResult [warnMsg], simpleResult [errMsg]]+                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload+                msgs `shouldBe` [errMsg]++            it "throws when scripted result is Left" do+                result <-+                    runScripted [Left (toException boom)]+                        $ try @ErrorCall+                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload+                result `shouldBe` Left boom++    describe "sequencing" do+        it "consumes results in order across mixed operations" do+            (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do+                withGhci (Command "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 (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i+                LoadResult {diagnostics = r2} <- withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i+                pure (r1, r2)+            fst result `shouldSatisfy` isLeft+            snd result `shouldBe` []+++--------------------------------------------------------------------------------+-- 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, Pub BuildProgress, IOE] a+    -> IO a+runScripted results = runEff . Pub.runNoOp . runGhciSessionScripted results
+ test/Unit/Tricorder/Daemon/TestRunnerSpec.hs view
@@ -0,0 +1,186 @@+module Unit.Tricorder.Daemon.TestRunnerSpec (spec_TestRunner) where++import Control.Exception (ErrorCall (..))+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Exception (try)+import Test.Hspec++import Tricorder.Daemon.TestRunner+    ( GhciOutcome (..)+    , TestRunner+    , detectOutcome+    , runTestSuite+    )+import Tricorder.Session.Target (Target (..))+import Tricorder.Session.TestTarget (TestTarget (..))+import Tricorder.Session.TestTimeout (TestTimeout (..))++import Tricorder.Build.Test qualified as Test+import Tricorder.Daemon.TestRunner qualified as TestRunner+++spec_TestRunner :: Spec+spec_TestRunner = do+    describe "detectOutcome" testDetectOutcome+    describe "runScripted" testScripted+++--------------------------------------------------------------------------------+-- 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 noProgress testTimeout+                $ mkTestTarget "test:foo"+        result `shouldBe` passingRun++    it "ignores the target name argument" do+        result <-+            runScripted [Right failingRun]+                $ runTestSuite noProgress testTimeout+                $ mkTestTarget "test:anything"+        result `shouldBe` failingRun++    it "throws when scripted result is Left" do+        result <-+            runScripted [Left (toException boom)]+                $ try @ErrorCall+                $ runTestSuite noProgress testTimeout+                $ mkTestTarget "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 noProgress testTimeout $ mkTestTarget "test:foo"+                b <- runTestSuite noProgress testTimeout $ mkTestTarget "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 noProgress testTimeout $ mkTestTarget "test:foo"+                r2 <- runTestSuite noProgress testTimeout $ mkTestTarget "test:bar"+                pure (r1, r2)+            fst result `shouldBe` Left boom+            snd result `shouldBe` passingRun+++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++boom :: ErrorCall+boom = ErrorCall "simulated process crash"+++passingRun :: Test.Suite+passingRun =+    Test.SuiteCompleted+        $ Test.SuiteCompletion+            { passed = True+            , output = "2 examples, 0 failures\n"+            , testCases = []+            , duration = Nothing+            }+++failingRun :: Test.Suite+failingRun =+    Test.SuiteCompleted+        $ Test.SuiteCompletion+            { passed = False+            , output = "1 example, 1 failure\n"+            , testCases = []+            , duration = Nothing+            }+++runScripted :: [Either SomeException Test.Suite] -> Eff '[TestRunner, Concurrent, IOE] a -> IO a+runScripted results = runEff . runConcurrent . TestRunner.runScripted results+++mkTestTarget :: Text -> TestTarget+mkTestTarget = TestTarget . Bare+++testTimeout :: TestTimeout+testTimeout = TestTimeout (-1)+++noProgress :: b -> Eff es ()+noProgress = const $ pure ()
+ test/Unit/Tricorder/Daemon/WatchSpec.hs view
@@ -0,0 +1,150 @@+module Unit.Tricorder.Daemon.WatchSpec (spec_Watch) where++import Atelier.Effects.FileWatcher (FileEvent (..), matchesAny)+import Effectful (runEff)+import Effectful.Writer.Static.Shared (execWriter, runWriter)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)+import Text.Regex.TDFA.ReadRegex (parseRegex)++import Atelier.Effects.Publishing.Pub qualified as Pub++import Tricorder.Build.Changes+    ( CabalChangeDetected (..)+    , SourceChangeDetected (..)+    )+import Tricorder.Daemon.Watch (WatchedFile (..))+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.WatchDirs (WatchDirs (..))+import Tricorder.Session.WatchExclusionPatterns (WatchExclusionPatterns (..))++import Tricorder.Daemon.Watch qualified as Watch+++spec_Watch :: Spec+spec_Watch = do+    describe "publishChange" testPublishChange+    describe "specs" testSpecs+++testPublishChange :: Spec+testPublishChange = do+    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+            . runWriter+            . Pub.toWriter @SourceChangeDetected+            . execWriter+            . Pub.toWriter @CabalChangeDetected+            . Watch.publishChange+            . (`WatchedFile` Modified)+++testSpecs :: Spec+testSpecs = do+    describe "source watches" do+        it "matches .hs files in configured watch dirs" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs ["/proj/src"])+            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True++        it "does not match non-.hs files" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs ["/proj/src"])+            matchesAny watches "/proj/src/Foo.txt" `shouldBe` False++        it "excludes paths containing dist-newstyle" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs ["/proj/src"])+            matchesAny watches "/proj/src/dist-newstyle/Foo.hs" `shouldBe` False++        it "excludes paths matching an exclusion pattern" do+            let pat = parsePattern "vendor"+                watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [pat])+                        (WatchDirs ["/proj/src"])+            matchesAny watches "/proj/src/vendor/Foo.hs" `shouldBe` False+            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True++        it "matches .hs files across multiple watch dirs" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs ["/proj/src", "/proj/test"])+            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True+            matchesAny watches "/proj/test/FooSpec.hs" `shouldBe` True++        -- Second line of defense: 'cabalWatches' registers the whole project+        -- root, and 'deduplicateDirs' collapses the narrow source dirs into it,+        -- so the OS watches the entire repo recursively. 'matchesAny' is what+        -- re-scopes events back to the configured dirs — a .hs file in a sibling+        -- package must not match.+        it "does not match a .hs file in a sibling package outside the watch dirs" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs ["/proj/pkg-a/src"])+            matchesAny watches "/proj/pkg-a/src/Foo.hs" `shouldBe` True+            matchesAny watches "/proj/pkg-b/src/Foo.hs" `shouldBe` False++    describe "cabal watches" do+        it "matches .cabal files under project root" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs [])+            matchesAny watches "/proj/foo.cabal" `shouldBe` True++        it "matches cabal.project under project root" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs [])+            matchesAny watches "/proj/cabal.project" `shouldBe` True++        it "matches package.yaml under project root" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs [])+            matchesAny watches "/proj/package.yaml" `shouldBe` True++        it "does not match non-cabal files" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs [])+            matchesAny watches "/proj/README.md" `shouldBe` False++        it "excludes cabal files under dist-newstyle" do+            let watches =+                    Watch.specs+                        (ProjectRoot "/proj")+                        (WatchExclusionPatterns [])+                        (WatchDirs [])+            matchesAny watches "/proj/dist-newstyle/foo.cabal" `shouldBe` False+  where+    parsePattern p = fromRight (error . toText $ "bad test pattern: " <> p) (parseRegex p)
− test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs 
@@ -1,421 +0,0 @@-module Unit.Tricorder.Effects.GhciSession.GhciParserSpec (spec_GhciParser) where--import Test.Hspec--import Tricorder.BuildState (Diagnostic (..), Severity (..))-import Tricorder.Effects.GhciSession.GhciParser-    ( GhciLoad (..)-    , GhciLoading (..)-    , GhciMessage (..)-    , GhciSeverity (..)-    , LoadOutcome (..)-    , LoadResult (..)-    , Position (..)-    , collectResult-    , collectResultCustom-    , parseReload-    , parseShowModules-    , parseShowTargets-    )---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--    describe "collectResultCustom" do-        describe "<no location info> plugin load failure" testPluginLoadFailure--    describe "collectResult" do-        describe "failed load with no located error" testUnattributedFailure-------------------------------------------------------------------------------------- parseReload: clean build-----------------------------------------------------------------------------------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"}-                       , GSummary LoadSucceeded-                       ]--    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"}-                       , GSummary LoadSucceeded-                       ]--    describe "when only summary line" $ it "returns the summary outcome" do-        parseReload ["Ok, 0 modules loaded."] `shouldBe` [GSummary LoadSucceeded]-------------------------------------------------------------------------------------- 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, Message, and summary items" 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"}-                       , GSummary LoadFailed-                       ]-------------------------------------------------------------------------------------- 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'"-                                    ]-                                }-                       , GSummary LoadFailed-                       ]--    describe "when all modules are already up to date" $ it "returns the summary outcome" do-        -- GHCi with -fhide-source-paths and nothing to recompile-        parseReload ["Ok, 5 modules loaded."] `shouldBe` [GSummary LoadSucceeded]-------------------------------------------------------------------------------------- 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"}-                       , GSummary LoadSucceeded-                       ]-------------------------------------------------------------------------------------- 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` []-------------------------------------------------------------------------------------- collectResultCustom: <no location info> plugin load failure------------------------------------------------------------------------------------- | Regression test for the \"All good\" bug with home-unit GHC plugins.------ Under @cabal repl --enable-multi-repl@ every unit is interpreted, so a--- package used as a GHC plugin in the same project is not available as a--- compiled plugin. The unit that depends on it fails to load, GHCi reports the--- failure with @\<no location info\>@ (it has no source span), and the load--- ends with @Failed, N modules loaded@. This output must still surface as an--- error diagnostic — otherwise the build is silently reported as clean.-testPluginLoadFailure :: Spec-testPluginLoadFailure = do-    -- Shape of the GHCi output from `cabal repl --enable-multi-repl` when an-    -- executable loads a home-unit GHC plugin: the plugin package's modules-    -- compile, then the unit using the plugin fails with a location-less error.-    let reloadOutput =-            [ "[3 of 5] Compiling My.Plugin       ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]"-            , "<no location info>: error:"-            , "    Could not load module \8216My.Plugin\8217."-            , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217."-            , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file."-            , "Use -v to see a list of the files searched for."-            , ""-            , "[5 of 5] Compiling Main            ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]"-            , "Failed, 4 modules loaded."-            ]-        result = collectResultCustom "/project" (parseReload reloadOutput) [] []--    it "surfaces the plugin load failure as an error diagnostic" do-        map (.severity) result.diagnostics `shouldContain` [SError]--    it "carries the plugin error message in the diagnostic title" do-        map (.title) result.diagnostics-            `shouldContain` ["Could not load module \8216My.Plugin\8217."]-------------------------------------------------------------------------------------- collectResult: failed load with no located error------------------------------------------------------------------------------------- 'collectResult' is the safety net: GHCi can end a load with @Failed, …@--- without emitting any error that carries a source span. The build must never--- read as clean in that case, so a synthetic error diagnostic is added.-testUnattributedFailure :: Spec-testUnattributedFailure = do-    describe "when the load failed but no error was located" $ it "adds a synthetic error" do-        let reloadOutput =-                [ "[1 of 2] Compiling Lib  ( src/Lib.hs, interpreted )"-                , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )"-                , "Failed, 1 module loaded."-                ]-            result = collectResult "/project" reloadOutput [] []-        map (.severity) result.diagnostics `shouldBe` [SError]--    it "does not duplicate a failure that already produced a located error" do-        let reloadOutput =-                [ "[1 of 1] Compiling Lib ( src/Lib.hs, interpreted )"-                , "src/Lib.hs:5:1: error: Oops"-                , "Failed, 0 modules loaded."-                ]-            result = collectResult "/project" reloadOutput [] []-        -- Only the real, located diagnostic — no synthetic one appended.-        map (.file) result.diagnostics `shouldBe` ["src/Lib.hs"]--    it "adds nothing for a successful load" do-        let reloadOutput =-                [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"-                , "Ok, 1 module loaded."-                ]-            result = collectResult "/project" reloadOutput [] []-        result.diagnostics `shouldBe` []--    describe "when 'Failed,' appears off the summary line" $ it "does not flag a clean build" do-        -- The load outcome lives on GHCi's single summary line-        -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a-        -- Template Haskell splice or top-level IO run while interpreting — can-        -- contain a line that happens to begin with "Failed,". That must not be-        -- mistaken for a failed load: the summary here is "Ok," so no synthetic-        -- error belongs.-        let reloadOutput =-                [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"-                , "Failed, retrying with fallback" -- printed by a TH splice-                , "Ok, 1 module loaded."-                ]-            result = collectResult "/project" reloadOutput [] []-        result.diagnostics `shouldBe` []
− test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs 
@@ -1,422 +0,0 @@-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, terminateProcessGroup, withProcessGroup)-import Atelier.Effects.Process.Internal (RunningProcess (..))-import Atelier.Effects.Timeout (runTimeout)-import Atelier.Time (Millisecond)-import Control.Concurrent (threadDelay)-import Control.Concurrent.STM (newTVarIO)-import Control.Exception (IOException, catch)-import Data.Char (isDigit)-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.Time.Units (Second)-import Effectful (runEff)-import Effectful.Concurrent (runConcurrent)-import Effectful.Exception (trySync)-import System.IO (hGetLine)-import System.Posix.Signals (nullSignal, sigKILL, signalProcess)-import System.Process.Typed-    ( createPipe-    , getStderr-    , getStdin-    , getStdout-    , setCreateGroup-    , setStderr-    , setStdin-    , setStdout-    , 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 Atelier.Effects.Process qualified as AProc-import Data.Text qualified as T-import System.Process qualified as Process-import System.Timeout qualified--import Tricorder.Effects.GhciSession.GhciProcess-    ( GhciProcess (..)-    , 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-    describe "withProcessGroup (process group)" testWithProcessGroupCleanup-    describe "terminateProcessGroup (process group)" testTerminateProcessGroup----- | 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 = RunningProcess 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 = RunningProcess 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-        -- The banner and error streams are pipes we drive ourselves, so the-        -- timing is deterministic rather than a race against the OS pipe buffer.-        (bannerOut, bannerOutW) <- Process.createPipe-        (errR, errW) <- Process.createPipe-        result <--            runEff-                . runConcurrent-                . runTimeout-                . runDelay-                . runFile-                . runConc-                $ 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)-        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)----- | Regression for orphaned/zombie build subprocesses on restart and shutdown.------ The original leak was on the /graceful/ path: GHCi exits cleanly on @:quit@,--- so its leader is reaped, yet the build subprocesses sharing its group linger.--- 'withProcessGroup' must still sweep the whole group even after the leader has--- gone. We simulate it with a leader that forks a long-lived child sharing its--- group and exits on stdin input (mirroring @:quit@); after 'withProcessGroup'--- returns, the child must be gone.-testWithProcessGroupCleanup :: Spec-testWithProcessGroupCleanup =-    it "terminates the whole group on exit, even after the leader has exited" do-        childPidRef <- newIORef (Nothing :: Maybe Int)-        let scenario =-                runEff-                    . runConcurrent-                    . runTimeout-                    . runDelay-                    . runFile-                    . runConc-                    . runProcessIO-                    $ withProcessGroup procConfig \p -> do-                        -- First stdout line is the long-lived child's pid.-                        line <- File.hGetLine (AProc.getStdout p)-                        liftIO $ writeIORef childPidRef (parsePid (T.unpack line))-                        -- Let the leader exit and reap it, so the cleanup runs-                        -- with the leader already gone — the path the bug needed.-                        File.hPutTextLn (AProc.getStdin p) ""-                        File.hFlush (AProc.getStdin p)-                        void $ AProc.waitExitCode p-        -- Hard wall-clock bound: a regression must surface as a failed-        -- assertion, never as a hang that stalls the whole suite.-        outcome <- System.Timeout.timeout (8_000_000) scenario-        case outcome of-            Nothing -> expectationFailure "test timed out (process did not settle)"-            Just () ->-                readIORef childPidRef >>= \case-                    Nothing -> expectationFailure "could not capture the child pid"-                    Just childPid -> do-                        died <- waitForProcessDeath childPid-                        -- Never leak the child if the assertion fails.-                        ignoring (signalProcess sigKILL (fromIntegral childPid))-                        died `shouldBe` True-  where-    procConfig =-        setStdin createPipe-            $ setStdout createPipe-            $ setStderr createPipe-            $ shell "sleep 30 & echo \"$!\"; read _quit"----- | 'terminateProcessGroup' must kill the whole group when called mid-flight--- (the leader still alive) — the explicit early-termination path the test--- runner uses to abort a one-shot @cabal repl test:…@ from another thread.-testTerminateProcessGroup :: Spec-testTerminateProcessGroup =-    it "kills the whole group, not just the leader, mid-flight" do-        outcome <- System.Timeout.timeout (8_000_000) do-            p <--                startProcess-                    $ setStdin createPipe-                    $ setStdout createPipe-                    $ setStderr createPipe-                    $ setCreateGroup True-                    $ shell "sleep 30 & echo \"$!\"; read _quit"-            childLine <- hGetLine (getStdout p)-            case parsePid childLine of-                Nothing -> do-                    ignoring (stopProcess p)-                    expectationFailure ("could not parse child pid from: " <> show childLine)-                    pure False-                Just childPid -> do-                    runEff . runProcessIO $ terminateProcessGroup (RunningProcess p)-                    died <- waitForProcessDeath childPid-                    -- Never leak the child if the assertion fails.-                    ignoring (signalProcess sigKILL (fromIntegral childPid))-                    pure died-        outcome `shouldBe` Just True----- | Parse a pid printed on its own line (tolerating surrounding whitespace).-parsePid :: String -> Maybe Int-parsePid = readMaybe . takeWhile isDigit . dropWhile (not . isDigit)----- | Swallow any exception from a best-effort cleanup action.-ignoring :: IO () -> IO ()-ignoring act = act `catch` \(_ :: SomeException) -> pure ()----- | Poll for up to ~3s for the given pid to disappear from the process table.--- @signalProcess nullSignal@ is a liveness probe: it throws once the process is--- gone (and reaped by init after being orphaned).-waitForProcessDeath :: Int -> IO Bool-waitForProcessDeath pid = go (60 :: Int)-  where-    go 0 = not <$> alive-    go n = do-        a <- alive-        if not a then pure True else threadDelay 50_000 >> go (n - 1)-    alive =-        (signalProcess nullSignal (fromIntegral pid) >> pure True)-            `catch` \(_ :: IOException) -> pure False---testDecideInterrupt :: Spec-testDecideInterrupt = do-    -- Regression: an idle GHCi must not be SIGINT'd, since the matching-    -- 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 = RunningProcess 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 
@@ -1,123 +0,0 @@-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 (..))-import Tricorder.Session (Command (..))---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 (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial-                msgs `shouldBe` [errMsg]--            it "returns empty list when scripted result has no messages" do-                LoadResult {diagnostics = msgs} <--                    runScripted [simpleResult []]-                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial-                msgs `shouldBe` []--            it "throws when scripted result is Left" do-                result <--                    runScripted [Left (toException boom)]-                        $ try @ErrorCall-                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial-                result `shouldBe` Left boom--        describe "reloading" do-            it "returns scripted messages" do-                LoadResult {diagnostics = msgs} <--                    runScripted [simpleResult [warnMsg], simpleResult [errMsg]]-                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload-                msgs `shouldBe` [errMsg]--            it "throws when scripted result is Left" do-                result <--                    runScripted [Left (toException boom)]-                        $ try @ErrorCall-                        $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload-                result `shouldBe` Left boom--    describe "sequencing" do-        it "consumes results in order across mixed operations" do-            (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do-                withGhci (Command "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 (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i-                LoadResult {diagnostics = r2} <- withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i-                pure (r1, r2)-            fst result `shouldSatisfy` isLeft-            snd result `shouldBe` []-------------------------------------------------------------------------------------- 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 
@@ -1,162 +0,0 @@-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 (Command (..), 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 = Command "session-1"}---session2 :: Session-session2 = def {command = Command "session-2"}---epoch :: UTCTime-epoch = UTCTime (fromGregorian 1970 1 1) 0
− test/Unit/Tricorder/GhcPkgSpec.hs 
@@ -1,49 +0,0 @@-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/Session/CabalFileSpec.hs view
@@ -0,0 +1,43 @@+module Unit.Tricorder.Session.CabalFileSpec (spec_CabalFile) where++import Atelier.Effects.FileSystem (runFileSystemState)+import Atelier.Effects.Log (runLogNoOp)+import Effectful (runPureEff)+import Effectful.State.Static.Shared (evalState)+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Map.Strict qualified as Map++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.CabalFile (discoverCabalFiles)+import Unit.Tricorder.Session.Helpers (cabalFixture, multiPackageFs)+++spec_CabalFile :: Spec+spec_CabalFile = do+    describe "discoverCabalFiles" testDiscoverCabalFiles+++-- | 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
+ test/Unit/Tricorder/Session/CommandSpec.hs view
@@ -0,0 +1,95 @@+module Unit.Tricorder.Session.CommandSpec (spec_Command) where++import Atelier.Effects.FileSystem (runFileSystemState)+import Data.Default (def)+import Effectful (runPureEff)+import Effectful.State.Static.Shared (evalState)+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Map.Strict qualified as Map++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command (Command (..), resolveCommand)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Target (parseTarget)+import Tricorder.Session.TestTarget (parseTestTargets)++import Tricorder.Session.Config qualified as Config+++spec_Command :: Spec+spec_Command = do+    describe "resolveCommand" testResolveCommand+++testResolveCommand :: Spec+testResolveCommand = do+    describe "when config has a command" do+        it "should use specified command" do+            let Command actual =+                    runPureEff+                        . evalState mempty+                        . runFileSystemState+                        $ resolveCommand pr def {command = Just "foo"} [] testTargets+            actual `shouldBe` "foo"++    describe "when config has explicit targets" do+        it "should spell them out verbatim, ignoring discovered test targets" do+            let Command actual =+                    runPureEff+                        . evalState (Map.singleton "/cabal.project" "")+                        . runFileSystemState+                        $ resolveCommand pr cfg (parseTarget <$> ["lib:foo"]) testTargets+            actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"++    describe "when config does not have a command or targets" do+        describe "and there is a cabal.project file" do+            it "should use cabal 'all' plus the discovered test targets" do+                let Command actual =+                        runPureEff+                            . evalState (Map.singleton "/cabal.project" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg [] testTargets+                actual+                    `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"++        describe "and there is at least one *.cabal file" do+            it "should use cabal 'all' plus the discovered test targets" do+                let Command actual =+                        runPureEff+                            . evalState (Map.singleton "/foo.cabal" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg [] testTargets+                actual+                    `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"++        describe "and there is a stack.yaml file" do+            it "should use stack ghci with 'all' plus test targets" do+                let Command actual =+                        runPureEff+                            . evalState (Map.singleton "/stack.yaml" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg [] testTargets+                actual `shouldBe` "stack ghci all test:foo"++        describe "but there are no project files" do+            it "should use default cabal repl with 'all' plus test targets" do+                let Command actual =+                        runPureEff+                            . evalState mempty+                            . runFileSystemState+                            $ resolveCommand pr cfg [] testTargets+                actual `shouldBe` "cabal repl --builddir /replbuild all test:foo"++        describe "and no test targets are discovered" do+            it "should fall back to plain 'all'" do+                let Command actual =+                        runPureEff+                            . evalState (Map.singleton "/cabal.project" "")+                            . runFileSystemState+                            $ resolveCommand pr cfg [] (parseTestTargets [])+                actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all"+  where+    pr = ProjectRoot "/"+    cfg = def {Config.replBuildDir = "/replbuild"}+    testTargets = parseTestTargets ["test:foo"]
+ test/Unit/Tricorder/Session/Helpers.hs view
@@ -0,0 +1,176 @@+module Unit.Tricorder.Session.Helpers+    ( multiCabalFiles+    , singleCabalFile+    , multiPackageFs+    , preludeOnlyLibCabal+    , libWithPreludeCabal+    , libTestCabal+    , gpdFixture+    , cabalFixture+    , gpd+    ) where++import Distribution.PackageDescription (GenericPackageDescription)+import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)++import Data.Map.Strict qualified as Map+import Data.Text qualified as T++import Tricorder.Session.CabalFile (CabalFile (..))+++gpd :: GenericPackageDescription+gpd =+    fromMaybe (error "cabalFixture failed to parse")+        $ parseGenericPackageDescriptionMaybe cabalFixture+++multiCabalFiles :: [CabalFile]+multiCabalFiles =+    uncurry CabalFile+        . second+            ( fromMaybe (error "multiCabalFiles failed to parse")+                . parseGenericPackageDescriptionMaybe+            )+        <$> Map.toList multiPackageCabalFs+++-- | 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")+        ]+        `Map.union` multiPackageCabalFs+++multiPackageCabalFs :: Map FilePath ByteString+multiPackageCabalFs =+    Map.fromList+        [ ("/pkg-a/pkg-a.cabal", libTestCabal "pkg-a")+        , ("/pkg-b/pkg-b.cabal", libTestCabal "pkg-b")+        ]+++-- | A minimal cabal file for @name@ with a single library that exposes+-- @Prelude@ and nothing else. All auto-detected targets define a custom+-- Prelude, which triggers the 'loadSession' warning.+preludeOnlyLibCabal :: Text -> ByteString+preludeOnlyLibCabal name =+    encodeUtf8+        $ T.unlines+            [ "cabal-version: 2.0"+            , "name:          " <> name+            , "version:       0.1.0.0"+            , "build-type:    Simple"+            , ""+            , "library"+            , "  hs-source-dirs: src"+            , "  exposed-modules: Prelude"+            , "  build-depends: base"+            , "  default-language: Haskell2010"+            ]+++-- | A minimal cabal file for @name@ with one library that exposes @Prelude@+-- and one executable. Used to verify that libraries defining a custom Prelude+-- are sorted last by 'resolveTargets'.+libWithPreludeCabal :: Text -> ByteString+libWithPreludeCabal name =+    encodeUtf8+        $ T.unlines+            [ "cabal-version: 2.0"+            , "name:          " <> name+            , "version:       0.1.0.0"+            , "build-type:    Simple"+            , ""+            , "library"+            , "  hs-source-dirs: src"+            , "  exposed-modules: Prelude"+            , "  build-depends: base"+            , "  default-language: Haskell2010"+            , ""+            , "executable " <> name <> "-exe"+            , "  main-is: Main.hs"+            , "  hs-source-dirs: app"+            , "  build-depends: base"+            , "  default-language: Haskell2010"+            ]+++-- | 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"+            ]+++singleCabalFile :: [CabalFile]+singleCabalFile = [CabalFile "/myapp.cabal" gpdFixture]+++gpdFixture :: GenericPackageDescription+gpdFixture = fromMaybe (error "gpdFixture failed to parse") $ parseGenericPackageDescriptionMaybe cabalFixture+++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\+    \foreign-library myapp-flib\n\+    \  type: native-shared\n\+    \  hs-source-dirs: flib\n\+    \  build-depends: base\n\+    \  default-language: Haskell2010\n\+    \\n\+    \executable myapp-exe\n\+    \  main-is: Main.hs\n\+    \  hs-source-dirs: app\n\+    \  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\+    \\n\+    \benchmark myapp-bench\n\+    \  type: exitcode-stdio-1.0\n\+    \  main-is: Bench.hs\n\+    \  hs-source-dirs: bench\n\+    \  build-depends: base\n\+    \  default-language: Haskell2010\n"
+ test/Unit/Tricorder/Session/TargetSpec.hs view
@@ -0,0 +1,233 @@+module Unit.Tricorder.Session.TargetSpec (spec_Target) where++import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)+import Test.Hspec+    ( Spec+    , describe+    , it+    , shouldBe+    , shouldContain+    , shouldMatchList+    )++import Tricorder.Session.CabalFile (CabalFile (..))+import Tricorder.Session.Target+    ( ComponentKind (..)+    , Target (..)+    , allComponentTargets+    , compareTargets+    , definesCustomPrelude+    , parseTarget+    , resolveTargets+    )+import Unit.Tricorder.Session.Helpers+    ( gpd+    , libTestCabal+    , libWithPreludeCabal+    , multiCabalFiles+    , singleCabalFile+    )+++spec_Target :: Spec+spec_Target = do+    describe "resolveTargets" testResolveTargets+    describe "parseTarget" testParseTarget+    describe "compareTargets" testCompareTargets+    describe "allComponentTargets" testAllComponentTargets+    describe "definesCustomPrelude" testDefinesCustomPrelude+++testParseTarget :: Spec+testParseTarget = do+    describe "qualified targets" do+        it "parses lib: as the main library (empty name)" do+            parseTarget "lib:" `shouldBe` Qualified Lib ""++        it "parses a named lib: target" do+            parseTarget "lib:myapp-utils" `shouldBe` Qualified Lib "myapp-utils"++        it "parses an flib: target" do+            parseTarget "flib:myapp-flib" `shouldBe` Qualified FLib "myapp-flib"++        it "parses an exe: target" do+            parseTarget "exe:myapp-exe" `shouldBe` Qualified Exe "myapp-exe"++        it "parses a test: target" do+            parseTarget "test:myapp-test" `shouldBe` Qualified Test "myapp-test"++        it "parses a bench: target" do+            parseTarget "bench:myapp-bench" `shouldBe` Qualified Bench "myapp-bench"++    describe "a name with no kind prefix" do+        it "parses as bare" do+            parseTarget "myapp" `shouldBe` Bare "myapp"++    describe "unrecognized targets" do+        it "rejects an unknown kind" do+            parseTarget "bogus:myapp" `shouldBe` Unrecognized "bogus:myapp"++        it "rejects a form with extra colons" do+            parseTarget "lib:a:b" `shouldBe` Unrecognized "lib:a:b"+++testResolveTargets :: Spec+testResolveTargets = do+    describe "when targets are configured" do+        it "parses and sorts configured targets" do+            let actual = resolveTargets [] ["lib:foo", "test:foo-test"]+            actual `shouldBe` [Qualified Lib "foo", Qualified Test "foo-test"]++    describe "when no targets are configured" do+        it "auto-detects all components from the cabal file" do+            -- cabalFixture exposes no Prelude module, so all components sort+            -- alphabetically by their rendered form.+            let actual = resolveTargets singleCabalFile []+            actual+                `shouldBe` [ Qualified Bench "myapp-bench"+                           , Qualified Exe "myapp-exe"+                           , Qualified FLib "myapp-flib"+                           , Qualified Lib "myapp"+                           , Qualified Lib "myapp-utils"+                           , Qualified Test "myapp-test"+                           ]++        it "surfaces test-suite components so they can be run after a build" do+            let actual = resolveTargets singleCabalFile []+            actual `shouldContain` [Qualified Test "myapp-test"]++        it "returns no targets when there are no cabal files" do+            let actual = resolveTargets [] []+            actual `shouldBe` []++        -- [tag: test_resolve_targest_aggregate]+        it "aggregates components across every package (regression: was 0)" do+            let actual = resolveTargets multiCabalFiles []+            actual+                `shouldMatchList` [ Qualified Test "pkg-a-test"+                                  , Qualified Test "pkg-b-test"+                                  , Qualified Lib "pkg-a"+                                  , Qualified Lib "pkg-b"+                                  ]++        it "sorts a library exposing a custom Prelude last" do+            let cabalFile =+                    CabalFile "/myprelude.cabal"+                        $ fromMaybe (error "libWithPreludeCabal failed to parse")+                        $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude")+            let actual = resolveTargets [cabalFile] []+            actual `shouldBe` [Qualified Exe "myprelude-exe", Qualified Lib "myprelude"]+++testCompareTargets :: Spec+testCompareTargets = do+    -- A predicate that stands in for 'definesCustomPrelude': marks lib: targets+    -- as "defines custom Prelude" so the comparison contract is exercised+    -- independently of cabal-file parsing.+    let defPred (Qualified Lib _) = True+        defPred _ = False++    describe "Ord" do+        describe "only first target matches the predicate" do+            describe "first target's render normally sorts as LT" do+                it "should return GT" do+                    compareTargets defPred (Qualified Lib "a") (Qualified Exe "b") `shouldBe` GT+            describe "both targets have the same render" do+                it "should return GT" do+                    compareTargets defPred (Qualified Lib "a") (Qualified Exe "a") `shouldBe` GT+            describe "first target's render normally sorts as GT" do+                it "should return GT" do+                    compareTargets defPred (Qualified Lib "b") (Qualified Exe "a") `shouldBe` GT++        describe "only second target matches the predicate" do+            describe "first target's render normally sorts as LT" do+                it "should return LT" do+                    compareTargets defPred (Qualified Exe "a") (Qualified Lib "b") `shouldBe` LT+            describe "both targets have the same render" do+                it "should return LT" do+                    compareTargets defPred (Qualified Exe "a") (Qualified Lib "a") `shouldBe` LT+            describe "first target's render normally sorts as GT" do+                it "should return LT" do+                    compareTargets defPred (Qualified Exe "b") (Qualified Lib "a") `shouldBe` LT++        describe "both targets match the predicate" do+            describe "first target's render normally sorts as LT" do+                it "should sort normally" do+                    compareTargets defPred (Qualified Lib "a") (Qualified Lib "b") `shouldBe` LT+            describe "both targets have the same render" do+                it "should sort normally" do+                    compareTargets defPred (Qualified Lib "a") (Qualified Lib "a") `shouldBe` EQ+            describe "first target's render normally sorts as GT" do+                it "should sort normally" do+                    compareTargets defPred (Qualified Lib "b") (Qualified Lib "a") `shouldBe` GT++        describe "neither target matches the predicate" do+            describe "first target's render normally sorts as LT" do+                it "should sort normally" do+                    compareTargets defPred (Qualified Exe "a") (Qualified Exe "b") `shouldBe` LT+            describe "both targets have the same render" do+                it "should sort normally" do+                    compareTargets defPred (Qualified Exe "a") (Qualified Exe "a") `shouldBe` EQ+            describe "first target's render normally sorts as GT" do+                it "should sort normally" do+                    compareTargets defPred (Qualified Exe "b") (Qualified Exe "a") `shouldBe` GT+++testAllComponentTargets :: Spec+testAllComponentTargets = do+    it "returns every component for the fixture" do+        allComponentTargets gpd+            `shouldMatchList` [ Qualified Lib "myapp"+                              , Qualified Lib "myapp-utils"+                              , Qualified FLib "myapp-flib"+                              , Qualified Exe "myapp-exe"+                              , Qualified Test "myapp-test"+                              , Qualified Bench "myapp-bench"+                              ]+    -- This test ensures `allComponentTargets`' part of the aggregate test.+    -- [ref:test_resolve_targest_aggregate]+    it "returns every component for test fixures" do+        let actual =+                allComponentTargets+                    $ fromMaybe (error "failed to parse cabal")+                    $ parseGenericPackageDescriptionMaybe+                    $ libTestCabal "pkg-a"+        actual `shouldMatchList` [Qualified Lib "pkg-a", Qualified Test "pkg-a-test"]+++testDefinesCustomPrelude :: Spec+testDefinesCustomPrelude = do+    let preludeCF =+            CabalFile "/myprelude.cabal"+                $ fromMaybe (error "libWithPreludeCabal failed to parse")+                $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude")++    describe "when the main library exposes Prelude" do+        it "returns True for Qualified Lib \"\" (unnamed main lib)" do+            definesCustomPrelude [preludeCF] (Qualified Lib "") `shouldBe` True++        it "returns True for Qualified Lib matching the package name" do+            definesCustomPrelude [preludeCF] (Qualified Lib "myprelude") `shouldBe` True++        it "returns True for Bare matching the package name" do+            definesCustomPrelude [preludeCF] (Bare "myprelude") `shouldBe` True++    describe "when no library exposes Prelude" do+        it "returns False for a lib target in a normal package" do+            definesCustomPrelude singleCabalFile (Qualified Lib "myapp") `shouldBe` False++        it "returns False for Bare matching the package name" do+            definesCustomPrelude singleCabalFile (Bare "myapp") `shouldBe` False++    describe "for non-library targets" do+        it "returns False for Qualified Exe" do+            definesCustomPrelude [preludeCF] (Qualified Exe "myprelude-exe") `shouldBe` False++        it "returns False for Qualified Test" do+            definesCustomPrelude singleCabalFile (Qualified Test "myapp-test") `shouldBe` False++        it "returns False for Unrecognized" do+            definesCustomPrelude [preludeCF] (Unrecognized "library:myprelude") `shouldBe` False++    it "returns False when the cabal file list is empty" do+        definesCustomPrelude [] (Qualified Lib "anything") `shouldBe` False
+ test/Unit/Tricorder/Session/TestTargetSpec.hs view
@@ -0,0 +1,43 @@+module Unit.Tricorder.Session.TestTargetSpec (spec_TestTarget) where++import Data.Default (def)+import Test.Hspec (Spec, describe, it, shouldBe)++import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Target (parseTarget)+import Tricorder.Session.TestTarget (parseTestTargets, resolveTestTargets)+++spec_TestTarget :: Spec+spec_TestTarget = do+    describe "resolveTestTargets" testResolveTestTargets+++testResolveTestTargets :: Spec+testResolveTestTargets = do+    it "infers test: components from targets when testTargets is absent" do+        let cfg = def :: Config+        resolveTestTargets cfg (mkTargets ["lib:mylib", "test:mylib-test"])+            `shouldBe` parseTestTargets ["test:mylib-test"]++    it "returns empty list when no test: components in targets" do+        let cfg = def :: Config+        resolveTestTargets cfg (mkTargets ["lib:mylib", "exe:myapp"])+            `shouldBe` parseTestTargets []++    it "uses explicit testTargets list when set" do+        let cfg = def {testTargets = Just ["test:b-test"]} :: Config+        resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"])+            `shouldBe` parseTestTargets ["test:b-test"]++    it "returns empty list when testTargets is explicitly empty" do+        let cfg = def {testTargets = Just []} :: Config+        resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test"])+            `shouldBe` parseTestTargets []++    it "infers multiple test: components" do+        let cfg = def :: Config+        resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"])+            `shouldBe` parseTestTargets ["test:a-test", "test:b-test"]+  where+    mkTargets = fmap parseTarget
+ test/Unit/Tricorder/Session/WatchDirsSpec.hs view
@@ -0,0 +1,142 @@+module Unit.Tricorder.Session.WatchDirsSpec (spec_WatchDirs) where++import Data.Default (def)+import Test.Hspec (Spec, context, describe, it, shouldBe)++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Target (ComponentKind (..), Target (..), parseTarget)+import Tricorder.Session.WatchDirs (WatchDirs (..), resolveWatchDirs, sourceDirsForTarget)+import Unit.Tricorder.Session.Helpers (gpd, multiCabalFiles, singleCabalFile)+++spec_WatchDirs :: Spec+spec_WatchDirs = do+    describe "resolveWatchDirs" testResolveWatchDirs+    describe "sourceDirsForTarget" testSourceDirsForTarget+++testResolveWatchDirs :: Spec+testResolveWatchDirs = do+    describe "when watch_dirs is set in config" do+        it "uses config dirs relative to project root" do+            let WatchDirs actual =+                    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 WatchDirs actual = resolveWatchDirs pr [] def []+            actual `shouldBe` ["."]++        it "infers source dirs from resolved targets" do+            let WatchDirs actual =+                    resolveWatchDirs pr singleCabalFile def (mkTargets ["lib:myapp", "test:myapp-test"])+            actual `shouldBe` ["/src", "/test"]++        it "falls back to [\".\"] when there are no cabal files" do+            let WatchDirs actual =+                    resolveWatchDirs pr [] def (mkTargets ["lib:myapp"])+            actual `shouldBe` ["."]++        -- Sharp edge: an unparseable .cabal yields no source dirs, so resolution+        -- falls back to watching the whole project root. This pins the current+        -- behavior; if it ever changes to something narrower, update this test.+        it "falls back to [\".\"] when no cabal files are found or parsed" do+            let WatchDirs actual =+                    resolveWatchDirs pr [] def (mkTargets ["lib:myapp"])+            actual `shouldBe` ["."]++    describe "when the project is a multi-package cabal.project" do+        it "infers per-package source dirs, scoped to each package's directory" do+            let WatchDirs actual =+                    resolveWatchDirs+                        pr+                        multiCabalFiles+                        def+                        (mkTargets ["lib:pkg-a", "test:pkg-a-test", "lib:pkg-b", "test:pkg-b-test"])+            actual+                `shouldBe` ["/pkg-a/src", "/pkg-a/test", "/pkg-b/src", "/pkg-b/test"]++        it "scopes a bare package-name target to that package, ignoring siblings" do+            let WatchDirs actual =+                    resolveWatchDirs pr multiCabalFiles def (mkTargets ["pkg-a"])+            actual `shouldBe` ["/pkg-a/src", "/pkg-a/test"]+  where+    pr = ProjectRoot "/"+++-- | These exercise the 'Target' -> dirs resolution directly with constructed+-- 'Target' values; the string -> 'Target' parsing is covered by 'testParseTarget'.+testSourceDirsForTarget :: Spec+testSourceDirsForTarget = do+    describe "Qualified Lib" do+        context "when the name is empty" do+            it "returns the main library source dirs" do+                sourceDirsForTarget gpd (Qualified Lib "") `shouldBe` ["src"]++        context "when the name matches the package name" do+            it "returns the main library source dirs" do+                sourceDirsForTarget gpd (Qualified Lib "myapp") `shouldBe` ["src"]++        context "when the name matches a sub-library" do+            it "returns the sub-library source dirs" do+                sourceDirsForTarget gpd (Qualified Lib "myapp-utils") `shouldBe` ["utils"]++        context "when the sub-library is unknown" do+            it "returns an empty list" do+                sourceDirsForTarget gpd (Qualified Lib "nonexistent") `shouldBe` []++    describe "Qualified FLib" do+        it "returns the foreign-library source dirs" do+            sourceDirsForTarget gpd (Qualified FLib "myapp-flib") `shouldBe` ["flib"]++    describe "Qualified Exe" do+        it "returns the executable source dirs" do+            sourceDirsForTarget gpd (Qualified Exe "myapp-exe") `shouldBe` ["app"]++    describe "Qualified Test" do+        it "returns the test suite source dirs" do+            sourceDirsForTarget gpd (Qualified Test "myapp-test") `shouldBe` ["test"]++    describe "Qualified Bench" do+        it "returns the benchmark source dirs" do+            sourceDirsForTarget gpd (Qualified Bench "myapp-bench") `shouldBe` ["bench"]++    describe "Bare (package name)" do+        it "returns every component's source dirs" do+            sourceDirsForTarget gpd (Bare "myapp") `shouldBe` ["src", "utils", "flib", "app", "test", "bench"]++    describe "Bare (component name)" do+        context "when it names a sub-library" do+            it "returns the sub-library source dirs" do+                sourceDirsForTarget gpd (Bare "myapp-utils") `shouldBe` ["utils"]++        context "when it names an executable" do+            it "returns the executable source dirs" do+                sourceDirsForTarget gpd (Bare "myapp-exe") `shouldBe` ["app"]++        context "when it names a test suite" do+            it "returns the test suite source dirs" do+                sourceDirsForTarget gpd (Bare "myapp-test") `shouldBe` ["test"]++        context "when it matches no component" do+            it "returns an empty list" do+                sourceDirsForTarget gpd (Bare "unknown") `shouldBe` []++    describe "Unrecognized" do+        it "matches an aliased kind prefix by trailing name" do+            sourceDirsForTarget gpd (Unrecognized "executable:myapp-exe") `shouldBe` ["app"]++        it "matches a case-variant kind prefix by trailing name" do+            sourceDirsForTarget gpd (Unrecognized "Test-Suite:myapp-test") `shouldBe` ["test"]++        it "matches the main library when the trailing name is the package name" do+            sourceDirsForTarget gpd (Unrecognized "library:myapp") `shouldBe` ["src"]++        it "returns an empty list when the trailing name matches no component" do+            sourceDirsForTarget gpd (Unrecognized "bogus:x") `shouldBe` []+++mkTargets :: [Text] -> [Target]+mkTargets = fmap parseTarget
test/Unit/Tricorder/SessionSpec.hs view
@@ -1,569 +1,59 @@ module Unit.Tricorder.SessionSpec (spec_Session) where +import Atelier.Config (LoadedConfig (..)) import Atelier.Effects.FileSystem (runFileSystemState)-import Atelier.Effects.Log (runLogNoOp)-import Data.Default (Default (..))+import Atelier.Effects.Input (runInputConst)+import Atelier.Effects.Log (Message (..), Severity (..), runLogWriter)+import Data.Aeson (Value (Null)) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)-import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import Effectful (runPureEff)+import Effectful.Reader.Static (runReader) import Effectful.State.Static.Shared (evalState)+import Effectful.Writer.Static.Shared (execWriter) import Test.Hspec -import Data.Map.Strict qualified as Map-import Data.Text qualified as T- import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (Command (..), ComponentKind (..), Config (..), Target (..), WatchDirs (..), allComponentTargets, compareTargets, discoverCabalFiles, parseTarget, parseTestTargets, resolveCommand, resolveTargets, resolveTestTargets, resolveWatchDirs, sourceDirsForTarget)+import Tricorder.Session (loadSession)+import Tricorder.Session.CabalFile (CabalFile (..))+import Unit.Tricorder.Session.Helpers (libWithPreludeCabal, preludeOnlyLibCabal)   spec_Session :: Spec spec_Session = do-    describe "resolveCommand" testResolveCommand-    describe "discoverCabalFiles" testDiscoverCabalFiles-    describe "resolveTargets" testResolveTargets-    describe "resolveWatchDirs" testResolveWatchDirs-    describe "resolveTestTargets" testResolveTestTargets-    describe "parseTarget" testParseTarget-    describe "sourceDirsForTarget" testSourceDirsForTarget-    describe "allComponentTargets" testAllComponentTargets-    describe "compareTargets" testCompareTargets---testParseTarget :: Spec-testParseTarget = do-    describe "qualified targets" do-        it "parses lib: as the main library (empty name)" do-            parseTarget "lib:" `shouldBe` Qualified Lib ""--        it "parses a named lib: target" do-            parseTarget "lib:myapp-utils" `shouldBe` Qualified Lib "myapp-utils"--        it "parses an flib: target" do-            parseTarget "flib:myapp-flib" `shouldBe` Qualified FLib "myapp-flib"--        it "parses an exe: target" do-            parseTarget "exe:myapp-exe" `shouldBe` Qualified Exe "myapp-exe"--        it "parses a test: target" do-            parseTarget "test:myapp-test" `shouldBe` Qualified Test "myapp-test"--        it "parses a bench: target" do-            parseTarget "bench:myapp-bench" `shouldBe` Qualified Bench "myapp-bench"--    describe "a name with no kind prefix" do-        it "parses as bare" do-            parseTarget "myapp" `shouldBe` Bare "myapp"--    describe "unrecognized targets" do-        it "rejects an unknown kind" do-            parseTarget "bogus:myapp" `shouldBe` Unrecognized "bogus:myapp"--        it "rejects a form with extra colons" do-            parseTarget "lib:a:b" `shouldBe` Unrecognized "lib:a:b"----- | These exercise the 'Target' -> dirs resolution directly with constructed--- 'Target' values; the string -> 'Target' parsing is covered by 'testParseTarget'.-testSourceDirsForTarget :: Spec-testSourceDirsForTarget = do-    describe "Qualified Lib" do-        context "when the name is empty" do-            it "returns the main library source dirs" do-                sourceDirsForTarget gpd (Qualified Lib "") `shouldBe` ["src"]--        context "when the name matches the package name" do-            it "returns the main library source dirs" do-                sourceDirsForTarget gpd (Qualified Lib "myapp") `shouldBe` ["src"]--        context "when the name matches a sub-library" do-            it "returns the sub-library source dirs" do-                sourceDirsForTarget gpd (Qualified Lib "myapp-utils") `shouldBe` ["utils"]--        context "when the sub-library is unknown" do-            it "returns an empty list" do-                sourceDirsForTarget gpd (Qualified Lib "nonexistent") `shouldBe` []--    describe "Qualified FLib" do-        it "returns the foreign-library source dirs" do-            sourceDirsForTarget gpd (Qualified FLib "myapp-flib") `shouldBe` ["flib"]--    describe "Qualified Exe" do-        it "returns the executable source dirs" do-            sourceDirsForTarget gpd (Qualified Exe "myapp-exe") `shouldBe` ["app"]--    describe "Qualified Test" do-        it "returns the test suite source dirs" do-            sourceDirsForTarget gpd (Qualified Test "myapp-test") `shouldBe` ["test"]--    describe "Qualified Bench" do-        it "returns the benchmark source dirs" do-            sourceDirsForTarget gpd (Qualified Bench "myapp-bench") `shouldBe` ["bench"]--    describe "Bare (package name)" do-        it "returns every component's source dirs" do-            sourceDirsForTarget gpd (Bare "myapp") `shouldBe` ["src", "utils", "flib", "app", "test", "bench"]--    describe "Bare (component name)" do-        context "when it names a sub-library" do-            it "returns the sub-library source dirs" do-                sourceDirsForTarget gpd (Bare "myapp-utils") `shouldBe` ["utils"]--        context "when it names an executable" do-            it "returns the executable source dirs" do-                sourceDirsForTarget gpd (Bare "myapp-exe") `shouldBe` ["app"]--        context "when it names a test suite" do-            it "returns the test suite source dirs" do-                sourceDirsForTarget gpd (Bare "myapp-test") `shouldBe` ["test"]--        context "when it matches no component" do-            it "returns an empty list" do-                sourceDirsForTarget gpd (Bare "unknown") `shouldBe` []--    describe "Unrecognized" do-        it "matches an aliased kind prefix by trailing name" do-            sourceDirsForTarget gpd (Unrecognized "executable:myapp-exe") `shouldBe` ["app"]--        it "matches a case-variant kind prefix by trailing name" do-            sourceDirsForTarget gpd (Unrecognized "Test-Suite:myapp-test") `shouldBe` ["test"]--        it "matches the main library when the trailing name is the package name" do-            sourceDirsForTarget gpd (Unrecognized "library:myapp") `shouldBe` ["src"]--        it "returns an empty list when the trailing name matches no component" do-            sourceDirsForTarget gpd (Unrecognized "bogus:x") `shouldBe` []---testAllComponentTargets :: Spec-testAllComponentTargets = do-    it "includes the main library as a named Qualified Lib" do-        allComponentTargets gpd `shouldContain` [Qualified Lib "myapp"]--    it "includes sub-libraries" do-        allComponentTargets gpd `shouldContain` [Qualified Lib "myapp-utils"]--    it "includes foreign libraries" do-        allComponentTargets gpd `shouldContain` [Qualified FLib "myapp-flib"]--    it "includes executables" do-        allComponentTargets gpd `shouldContain` [Qualified Exe "myapp-exe"]--    it "includes test suites" do-        allComponentTargets gpd `shouldContain` [Qualified Test "myapp-test"]--    it "includes benchmarks" do-        allComponentTargets gpd `shouldContain` [Qualified Bench "myapp-bench"]--    it "returns every component for the fixture" do-        allComponentTargets gpd-            `shouldBe` [ Qualified Lib "myapp"-                       , Qualified Lib "myapp-utils"-                       , Qualified FLib "myapp-flib"-                       , Qualified Exe "myapp-exe"-                       , Qualified Test "myapp-test"-                       , Qualified Bench "myapp-bench"-                       ]----- | Pins the discovery contract: a @cabal.project@ selects per-package--- @.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` [Qualified Test "foo-test", Qualified Lib "foo"]--    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` [ Qualified Bench "myapp-bench"-                           , Qualified Exe "myapp-exe"-                           , Qualified FLib "myapp-flib"-                           , Qualified Test "myapp-test"-                           , Qualified Lib "myapp"-                           , Qualified Lib "myapp-utils"-                           ]--        it "surfaces test-suite components so they can be run after a build" do-            let actual =-                    runPureEff-                        . evalState (Map.singleton "/myapp.cabal" cabalFixture)-                        . runFileSystemState-                        $ resolveTargets ["/myapp.cabal"] []-            actual `shouldContain` [Qualified 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` [Qualified Lib "pkg-a"]-            actual `shouldContain` [Qualified Lib "pkg-b"]-            [t | t@(Qualified Test _) <- actual]-                `shouldBe` [Qualified Test "pkg-a-test", Qualified Test "pkg-b-test"]---testResolveWatchDirs :: Spec-testResolveWatchDirs = do-    describe "when watch_dirs is set in config" do-        it "uses config dirs relative to project root" do-            let WatchDirs 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 WatchDirs actual =-                    runPureEff-                        . evalState mempty-                        . runFileSystemState-                        $ resolveWatchDirs pr [] def []-            actual `shouldBe` ["."]--        it "infers source dirs from resolved targets" do-            let WatchDirs actual =-                    runPureEff-                        . evalState (Map.singleton "/myapp.cabal" cabalFixture)-                        . runFileSystemState-                        $ resolveWatchDirs pr ["/myapp.cabal"] def (mkTargets ["lib:myapp", "test:myapp-test"])-            actual `shouldBe` ["/src", "/test"]--        it "falls back to [\".\"] when there are no cabal files" do-            let WatchDirs actual =-                    runPureEff-                        . evalState mempty-                        . runFileSystemState-                        $ resolveWatchDirs pr [] def (mkTargets ["lib:myapp"])-            actual `shouldBe` ["."]--        -- Sharp edge: an unparseable .cabal yields no source dirs, so resolution-        -- falls back to watching the whole project root. This pins the current-        -- behavior; if it ever changes to something narrower, update this test.-        it "falls back to [\".\"] when the cabal file cannot be parsed" do-            let WatchDirs actual =-                    runPureEff-                        . evalState (Map.singleton "/myapp.cabal" malformedCabal)-                        . runFileSystemState-                        $ resolveWatchDirs pr ["/myapp.cabal"] def (mkTargets ["lib:myapp"])-            actual `shouldBe` ["."]--    describe "when the project is a multi-package cabal.project" do-        it "infers per-package source dirs, scoped to each package's directory" do-            let WatchDirs actual =-                    runPureEff-                        . evalState multiPackageFs-                        . runFileSystemState-                        $ resolveWatchDirs-                            pr-                            ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]-                            def-                            (mkTargets ["lib:pkg-a", "test:pkg-a-test", "lib:pkg-b", "test:pkg-b-test"])-            actual-                `shouldBe` ["/pkg-a/src", "/pkg-a/test", "/pkg-b/src", "/pkg-b/test"]--        it "scopes a bare package-name target to that package, ignoring siblings" do-            let WatchDirs actual =-                    runPureEff-                        . evalState multiPackageFs-                        . runFileSystemState-                        $ resolveWatchDirs-                            pr-                            ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]-                            def-                            (mkTargets ["pkg-a"])-            actual `shouldBe` ["/pkg-a/src", "/pkg-a/test"]-  where-    pr = ProjectRoot "/"---testResolveTestTargets :: Spec-testResolveTestTargets = do-    it "infers test: components from targets when testTargets is absent" do-        let cfg = def :: Config-        resolveTestTargets cfg (mkTargets ["lib:mylib", "test:mylib-test"]) `shouldBe` parseTestTargets ["test:mylib-test"]--    it "returns empty list when no test: components in targets" do-        let cfg = def :: Config-        resolveTestTargets cfg (mkTargets ["lib:mylib", "exe:myapp"]) `shouldBe` parseTestTargets []--    it "uses explicit testTargets list when set" do-        let cfg = def {testTargets = Just ["test:b-test"]} :: Config-        resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) `shouldBe` parseTestTargets ["test:b-test"]--    it "returns empty list when testTargets is explicitly empty" do-        let cfg = def {testTargets = Just []} :: Config-        resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test"]) `shouldBe` parseTestTargets []--    it "infers multiple test: components" do-        let cfg = def :: Config-        resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) `shouldBe` parseTestTargets ["test:a-test", "test:b-test"]+    describe "loadSession" testLoadSession  -testResolveCommand :: Spec-testResolveCommand = do-    describe "when config has a command" do-        it "should use specified command" do-            let Command actual =-                    runPureEff-                        . evalState mempty-                        . runFileSystemState-                        $ resolveCommand pr def {command = Just "foo"} [] testTargets-            actual `shouldBe` "foo"--    describe "when config has explicit targets" do-        it "should spell them out verbatim, ignoring discovered test targets" do-            let Command actual =-                    runPureEff-                        . evalState (Map.singleton "/cabal.project" "")-                        . runFileSystemState-                        $ resolveCommand pr cfg (mkTargets ["lib:foo"]) testTargets-            actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"--    describe "when config does not have a command or targets" do-        describe "and there is a cabal.project file" do-            it "should use cabal 'all' plus the discovered test targets" do-                let Command actual =-                        runPureEff-                            . evalState (Map.singleton "/cabal.project" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual-                    `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"--        describe "and there is at least one *.cabal file" do-            it "should use cabal 'all' plus the discovered test targets" do-                let Command actual =-                        runPureEff-                            . evalState (Map.singleton "/foo.cabal" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual-                    `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"--        describe "and there is a stack.yaml file" do-            it "should use stack ghci with 'all' plus test targets" do-                let Command actual =-                        runPureEff-                            . evalState (Map.singleton "/stack.yaml" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual `shouldBe` "stack ghci all test:foo"+testLoadSession :: Spec+testLoadSession = do+    describe "when every resolved target exposes a custom Prelude module" do+        it "emits a WARN" do+            let msgs = captureSessionLogs [preludeOnlyCF]+            any (\m -> m.severity == WARN) msgs `shouldBe` True -        describe "but there are no project files" do-            it "should use default cabal repl with 'all' plus test targets" do-                let Command actual =-                        runPureEff-                            . evalState mempty-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual `shouldBe` "cabal repl --builddir /replbuild all test:foo"+    describe "when not every resolved target exposes a custom Prelude module" do+        it "does not emit a WARN" do+            -- libWithPreludeCabal has both a lib (custom Prelude) and an exe (no Prelude)+            let msgs = captureSessionLogs [mixedCF]+            any (\m -> m.severity == WARN) msgs `shouldBe` False -        describe "and no test targets are discovered" do-            it "should fall back to plain 'all'" do-                let Command actual =-                        runPureEff-                            . evalState (Map.singleton "/cabal.project" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] (parseTestTargets [])-                actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all"+    it "does not emit a WARN when there are no resolved targets" do+        any (\m -> m.severity == WARN) (captureSessionLogs []) `shouldBe` False   where-    pr = ProjectRoot "/"-    cfg = def {replBuildDir = "/replbuild"}-    testTargets = parseTestTargets ["test:foo"]---testCompareTargets :: Spec-testCompareTargets = do-    describe "Ord" do-        describe "only first target beginnings with 'lib:'" do-            describe "first target's component name normally sorts as LT" do-                it "should return GT" do-                    compareTargets (Qualified Lib "a") (Qualified Exe "b") `shouldBe` GT-            describe "both targets have same component name" do-                it "should return GT" do-                    compareTargets (Qualified Lib "a") (Qualified Exe "a") `shouldBe` GT-            describe "first target's component name normally sorts as GT" do-                it "should return GT" do-                    compareTargets (Qualified Lib "b") (Qualified Exe "a") `shouldBe` GT--        describe "only second target begins with 'lib:'" do-            describe "first target's component name normally sorts as LT" do-                it "should return LT" do-                    compareTargets (Qualified Exe "a") (Qualified Lib "b") `shouldBe` LT-            describe "both targets have same component name" do-                it "should return LT" do-                    compareTargets (Qualified Exe "a") (Qualified Lib "a") `shouldBe` LT-            describe "first target's component name normally sorts as GT" do-                it "should return LT" do-                    compareTargets (Qualified Exe "b") (Qualified Lib "a") `shouldBe` LT--        describe "both targets begin with 'lib:'" do-            describe "first target's component name normally sorts as LT" do-                it "should sort normally" do-                    compareTargets (Qualified Lib "a") (Qualified Lib "b") `shouldBe` LT-            describe "both targets have same component name" do-                it "should sort normally" do-                    compareTargets (Qualified Lib "a") (Qualified Lib "a") `shouldBe` EQ-            describe "first target's component name normally sorts as GT" do-                it "should sort normally" do-                    compareTargets (Qualified Lib "b") (Qualified Lib "a") `shouldBe` GT--        describe "neither target begin with 'lib:'" do-            describe "first target's component name normally sorts as LT" do-                it "should sort normally" do-                    compareTargets (Qualified Exe "a") (Qualified Exe "b") `shouldBe` LT-            describe "both targets have same component name" do-                it "should sort normally" do-                    compareTargets (Qualified Exe "a") (Qualified Exe "a") `shouldBe` EQ-            describe "first target's component name normally sorts as GT" do-                it "should sort normally" do-                    compareTargets (Qualified Exe "b") (Qualified Exe "a") `shouldBe` GT-------------------------------------------------------------------------------------- Helpers-----------------------------------------------------------------------------------gpd :: GenericPackageDescription-gpd =-    fromMaybe (error "cabalFixture failed to parse")-        $ parseGenericPackageDescriptionMaybe cabalFixture----- | Build a target list from textual forms, exactly as config and cabal--- discovery do via 'parseTarget'.-mkTargets :: [Text] -> [Target]-mkTargets = map parseTarget----- | An in-memory project root with a @cabal.project@ listing two packages,--- each in its own subdirectory with a library and a test suite.-multiPackageFs :: Map FilePath ByteString-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"-            ]----- | Not a valid @.cabal@ file: @parseGenericPackageDescriptionMaybe@ returns--- 'Nothing' for it.-malformedCabal :: ByteString-malformedCabal = "this is not a cabal file {{{ <<< @@@\n"---cabalFixture :: ByteString-cabalFixture =-    "cabal-version: 2.0\n\-    \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\-    \foreign-library myapp-flib\n\-    \  type: native-shared\n\-    \  hs-source-dirs: flib\n\-    \  build-depends: base\n\-    \  default-language: Haskell2010\n\-    \\n\-    \executable myapp-exe\n\-    \  main-is: Main.hs\n\-    \  hs-source-dirs: app\n\-    \  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\-    \\n\-    \benchmark myapp-bench\n\-    \  type: exitcode-stdio-1.0\n\-    \  main-is: Bench.hs\n\-    \  hs-source-dirs: bench\n\-    \  build-depends: base\n\-    \  default-language: Haskell2010\n"+    preludeOnlyCF =+        CabalFile "/p.cabal"+            $ fromMaybe (error "preludeOnlyLibCabal failed to parse")+            $ parseGenericPackageDescriptionMaybe (preludeOnlyLibCabal "p")+    mixedCF =+        CabalFile "/mixed.cabal"+            $ fromMaybe (error "libWithPreludeCabal failed to parse")+            $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "mixed")+    captureSessionLogs cabalFiles =+        runPureEff+            . execWriter @[Message]+            . runLogWriter+            . evalState @(Map FilePath ByteString) mempty+            . runFileSystemState+            . runInputConst cabalFiles+            . runReader (ProjectRoot "/")+            . runInputConst (LoadedConfig Null)+            $ loadSession
test/Unit/Tricorder/SocketSpec.hs view
@@ -3,14 +3,16 @@ import Atelier.Effects.File (File, runFile) import Effectful (IOE, runEff) import System.IO (hClose, hGetLine, openFile, writeFile)-import Test.Hspec+import Test.Hspec (Spec, describe, it, shouldBe) -import Tricorder.Effects.UnixSocket+import Tricorder.Socket.Client (isDaemonReady)+import Tricorder.Socket.UnixSocket     ( SocketScript (..)     , UnixSocket     , acceptHandle     , bindSocket     , removeSocketFile+    , runUnixSocketIO     , runUnixSocketScripted     , socketFileExists     )@@ -19,6 +21,7 @@ spec_Socket :: Spec spec_Socket = do     describe "runUnixSocketScripted" testScripted+    describe "isDaemonReady" testReady   --------------------------------------------------------------------------------@@ -55,9 +58,36 @@   --------------------------------------------------------------------------------+-- isDaemonReady (real IO interpreter)+--------------------------------------------------------------------------------++testReady :: Spec+testReady = do+    it "returns False when nothing is listening on the path" do+        -- A connect to a non-existent socket must be caught, not thrown: this is+        -- the race the start/status path hit before the socket was bound.+        result <- runIO' $ isDaemonReady "/tmp/tricorder-isdaemonready-absent.sock"+        result `shouldBe` False++    it "returns True once a socket is bound and listening" do+        let path = "/tmp/tricorder-isdaemonready-bound.sock"+        result <- runIO' do+            removeSocketFile path+            _ <- bindSocket path+            isDaemonReady path+        runIO' $ removeSocketFile path+        result `shouldBe` True+++-------------------------------------------------------------------------------- -- Helpers --------------------------------------------------------------------------------  -- | Run scripted socket operations (no Delay needed). runScripted :: [SocketScript] -> Eff '[UnixSocket, File, IOE] a -> IO a runScripted script = runEff . runFile . runUnixSocketScripted script+++-- | Run socket operations against the real IO interpreter.+runIO' :: Eff '[UnixSocket, File, IOE] a -> IO a+runIO' = runEff . runFile . runUnixSocketIO
+ test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs view
@@ -0,0 +1,30 @@+module Unit.Tricorder.SourceLookup.GhcPkgSpec (spec_GhcPkg) where++import Effectful (runPureEff)+import Test.Hspec++import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), findModule, runGhcPkgScripted)+++spec_GhcPkg :: Spec+spec_GhcPkg = do+    describe "findModule" testFindModule+++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"+++runScripted :: [GhcPkgScript] -> Eff '[GhcPkg] a -> a+runScripted script = runPureEff . runGhcPkgScripted script
+ test/Unit/Tricorder/SourceLookup/SliceSpec.hs view
@@ -0,0 +1,342 @@+module Unit.Tricorder.SourceLookup.SliceSpec (spec_Slice) where++import Test.Hspec++import Data.Text qualified as T++import Tricorder.SourceLookup.Slice (sliceSymbol)+++spec_Slice :: Spec+spec_Slice = describe "sliceSymbol" do+    valueBindings+    typeDeclarations+    constructors+    compactDeclarations+    robustness+    capturePrecision+++-- | Build a source fixture from individual lines.+src :: [Text] -> Text+src = T.unlines+++valueBindings :: Spec+valueBindings = describe "value bindings" do+    it "slices a function with its signature and doc block" do+        let source =+                src+                    [ "-- | The answer to everything."+                    , "answer :: Int"+                    , "answer = 42"+                    , ""+                    , "other :: Bool"+                    , "other = True"+                    ]+        sliceSymbol "answer" source+            `shouldBe` Just "-- | The answer to everything.\nanswer :: Int\nanswer = 42"++    it "slices a binding with no signature" do+        let source = src ["foo = 1", "", "bar = 2"]+        sliceSymbol "foo" source `shouldBe` Just "foo = 1"++    it "captures every equation of a multi-equation binding" do+        let source =+                src+                    [ "isJust :: Maybe a -> Bool"+                    , "isJust (Just _) = True"+                    , "isJust Nothing = False"+                    , ""+                    , "next = ()"+                    ]+        sliceSymbol "isJust" source+            `shouldBe` Just "isJust :: Maybe a -> Bool\nisJust (Just _) = True\nisJust Nothing = False"++    it "keeps a multi-line line-comment doc block" do+        let source =+                src+                    [ "-- | The answer to everything,"+                    , "-- computed once."+                    , "answer :: Int"+                    , "answer = 42"+                    ]+        sliceSymbol "answer" source+            `shouldBe` Just "-- | The answer to everything,\n-- computed once.\nanswer :: Int\nanswer = 42"++    it "slices an operator binding in (op) form" do+        let source =+                src+                    [ "(<+>) :: Int -> Int -> Int"+                    , "a <+> b = a + b"+                    ]+        sliceSymbol "<+>" source+            `shouldBe` Just "(<+>) :: Int -> Int -> Int\na <+> b = a + b"++    it "does not match a different binding with a shared prefix" do+        let source = src ["answer = 1", "", "answerable = 2"]+        sliceSymbol "answerable" source `shouldBe` Just "answerable = 2"+++-- | Real Hackage source frequently packs top-level declarations together with+-- no blank line between them. The slice must stop at the neighbouring+-- declaration, not swallow it.+compactDeclarations :: Spec+compactDeclarations = describe "adjacent declarations without blank lines" do+    it "does not swallow the following binding" do+        sliceSymbol "bar" (src ["foo = 1", "bar = 2", "baz = 3"])+            `shouldBe` Just "bar = 2"++    it "does not swallow the preceding binding and its signature" do+        let source =+                src+                    [ "foo :: Int"+                    , "foo = 1"+                    , "bar :: Int"+                    , "bar = 2"+                    ]+        sliceSymbol "bar" source `shouldBe` Just "bar :: Int\nbar = 2"++    it "keeps the doc block but not a preceding declaration" do+        let source =+                src+                    [ "foo = 1"+                    , "-- | doc for bar"+                    , "bar = 2"+                    ]+        sliceSymbol "bar" source `shouldBe` Just "-- | doc for bar\nbar = 2"++    it "keeps a multi-line doc block but not a preceding declaration" do+        let source =+                src+                    [ "foo = 1"+                    , "-- | doc for bar,"+                    , "-- second line."+                    , "bar = 2"+                    ]+        sliceSymbol "bar" source+            `shouldBe` Just "-- | doc for bar,\n-- second line.\nbar = 2"+++typeDeclarations :: Spec+typeDeclarations = describe "type declarations" do+    it "slices a data declaration with doc and deriving clause" do+        let source =+                src+                    [ "-- | A JSON value."+                    , "data Value = Null | Bool Bool"+                    , "    deriving (Show)"+                    , ""+                    , "instance Eq Value"+                    ]+        sliceSymbol "Value" source+            `shouldBe` Just "-- | A JSON value.\ndata Value = Null | Bool Bool\n    deriving (Show)"++    it "keeps a multi-line block doc comment on a data declaration" do+        let source =+                src+                    [ "{- | A JSON value,"+                    , "   as parsed. -}"+                    , "data Value = Null | Bool Bool"+                    , ""+                    ]+        sliceSymbol "Value" source+            `shouldBe` Just "{- | A JSON value,\n   as parsed. -}\ndata Value = Null | Bool Bool"++    it "slices a newtype" do+        sliceSymbol "Age" (src ["newtype Age = Age Int", ""])+            `shouldBe` Just "newtype Age = Age Int"++    it "slices a type alias" do+        sliceSymbol "Name" (src ["type Name = Text"])+            `shouldBe` Just "type Name = Text"++    it "slices a type family" do+        sliceSymbol "Elem" (src ["type family Elem c"])+            `shouldBe` Just "type family Elem c"++    it "slices a class with its methods" do+        let source =+                src+                    [ "class Eq a => Container a where"+                    , "    empty :: a"+                    , ""+                    , "foo = ()"+                    ]+        sliceSymbol "Container" source+            `shouldBe` Just "class Eq a => Container a where\n    empty :: a"++    it "slices a record declaration including all fields" do+        let source =+                src+                    [ "data Person = Person"+                    , "    { name :: Text"+                    , "    , age :: Int"+                    , "    }"+                    , "    deriving (Show)"+                    , ""+                    ]+        sliceSymbol "Person" source+            `shouldBe` Just+                ( "data Person = Person\n"+                    <> "    { name :: Text\n"+                    <> "    , age :: Int\n"+                    <> "    }\n"+                    <> "    deriving (Show)"+                )++    it "slices a GADT declaration" do+        let source =+                src+                    [ "data Expr a where"+                    , "    Lit :: Int -> Expr Int"+                    , "    Add :: Expr Int -> Expr Int -> Expr Int"+                    , ""+                    ]+        sliceSymbol "Expr" source+            `shouldBe` Just+                ( "data Expr a where\n"+                    <> "    Lit :: Int -> Expr Int\n"+                    <> "    Add :: Expr Int -> Expr Int -> Expr Int"+                )+++constructors :: Spec+constructors = describe "constructor queries" do+    it "returns the enclosing data block for a constructor" do+        let source =+                src+                    [ "-- | Optionality."+                    , "data Maybe a = Nothing | Just a"+                    , ""+                    , "foo = ()"+                    ]+        sliceSymbol "Just" source+            `shouldBe` Just "-- | Optionality.\ndata Maybe a = Nothing | Just a"++    it "keeps a multi-line doc block above the enclosing data block" do+        let source =+                src+                    [ "-- | Optionality,"+                    , "-- the Maybe type."+                    , "data Maybe a = Nothing | Just a"+                    , ""+                    ]+        sliceSymbol "Just" source+            `shouldBe` Just "-- | Optionality,\n-- the Maybe type.\ndata Maybe a = Nothing | Just a"++    it "returns the enclosing GADT block for a GADT constructor" do+        let source =+                src+                    [ "data Expr a where"+                    , "    Lit :: Int -> Expr Int"+                    , "    Add :: Expr Int -> Expr Int -> Expr Int"+                    , ""+                    ]+        sliceSymbol "Lit" source+            `shouldBe` Just+                ( "data Expr a where\n"+                    <> "    Lit :: Int -> Expr Int\n"+                    <> "    Add :: Expr Int -> Expr Int -> Expr Int"+                )+++robustness :: Spec+robustness = describe "robustness" do+    it "returns Nothing for a missing symbol" do+        sliceSymbol "nope" (src ["foo = 1", "bar = 2"]) `shouldBe` Nothing++    it "returns Nothing for an empty query" do+        sliceSymbol "" (src ["foo = 1"]) `shouldBe` Nothing++    it "does not choke on CPP-laden source" do+        let source =+                src+                    [ "#if MIN_VERSION_base(4,18,0)"+                    , "answer :: Int"+                    , "#else"+                    , "answer :: Integer"+                    , "#endif"+                    , "answer = 42"+                    ]+        let result = sliceSymbol "answer" source+        result `shouldSatisfy` isJust+        fmap (T.isInfixOf "answer = 42") result `shouldBe` Just True+++-- | The slice must span exactly the queried declaration: not truncating it+-- early, not swallowing a neighbour, and not anchoring on the wrong entity.+-- These are the over-/under-capture shapes real Hackage source triggers.+capturePrecision :: Spec+capturePrecision = describe "capture precision" do+    it "keeps a where-clause that contains a blank line" do+        let source =+                src+                    [ "foo x = go x"+                    , "  where"+                    , "    go y = y + 1"+                    , ""+                    , "    helper = 2"+                    , ""+                    , "bar = 3"+                    ]+        sliceSymbol "foo" source+            `shouldBe` Just "foo x = go x\n  where\n    go y = y + 1\n\n    helper = 2"++    it "does not swallow a following binding that merely uses the operator" do+        let source =+                src+                    [ "(<+>) :: Int -> Int -> Int"+                    , "a <+> b = a + b"+                    , "merge x y = x <+> y"+                    ]+        sliceSymbol "<+>" source+            `shouldBe` Just "(<+>) :: Int -> Int -> Int\na <+> b = a + b"++    it "does not anchor on a superclass name in a class head" do+        let source =+                src+                    [ "class Eq a => Ord a where"+                    , "    compare :: a -> a -> Ordering"+                    ]+        sliceSymbol "Eq" source `shouldBe` Nothing++    it "slices a class that has a superclass context by its own name" do+        let source =+                src+                    [ "class Eq a => Ord a where"+                    , "    compare :: a -> a -> Ordering"+                    ]+        sliceSymbol "Ord" source+            `shouldBe` Just "class Eq a => Ord a where\n    compare :: a -> a -> Ordering"++    it "picks the data block that actually defines the constructor" do+        let source =+                src+                    [ "-- | Uses Just internally."+                    , "data Wrapper = Wrap Int"+                    , ""+                    , "data Maybe a = Nothing | Just a"+                    ]+        sliceSymbol "Just" source+            `shouldBe` Just "data Maybe a = Nothing | Just a"++    it "does not anchor on a constructor name used as a field type elsewhere" do+        let source =+                src+                    [ "data Holder = Holder Bar"+                    , ""+                    , "data Thing = Bar | Baz"+                    ]+        sliceSymbol "Bar" source `shouldBe` Just "data Thing = Bar | Baz"++    it "keeps a multi-line {- | -} block doc comment" do+        let source =+                src+                    [ "{- | This does X"+                    , "   over multiple lines. -}"+                    , "foo :: Int"+                    , "foo = 1"+                    ]+        sliceSymbol "foo" source+            `shouldBe` Just "{- | This does X\n   over multiple lines. -}\nfoo :: Int\nfoo = 1"
+ test/Unit/Tricorder/SourceLookup/TarballSpec.hs view
@@ -0,0 +1,107 @@+module Unit.Tricorder.SourceLookup.TarballSpec (spec_Tarball) where++import System.FilePath (isAbsolute, (</>))+import Test.Hspec++import Codec.Archive.Tar qualified as Tar+import Codec.Archive.Tar.Entry qualified as Tar+import Codec.Compression.GZip qualified as GZip+import Data.ByteString.Lazy qualified as BSL++import Tricorder.SourceLookup.Tarball+    ( cabalPackagesDirs+    , extractModule+    , matchesModule+    , splitPackageId+    , tarballPath+    )+++spec_Tarball :: Spec+spec_Tarball = do+    describe "splitPackageId" do+        it "splits a simple package id" do+            splitPackageId "aeson-2.2.5.0" `shouldBe` ("aeson", "2.2.5.0")++        it "keeps hyphens inside the package name" do+            splitPackageId "list-t-1.0.5.7" `shouldBe` ("list-t", "1.0.5.7")++    describe "tarballPath" do+        it "derives the cache path for a package id" do+            tarballPath "/c" "hackage.haskell.org" "aeson-2.2.5.0"+                `shouldBe` "/c" </> "hackage.haskell.org/aeson/2.2.5.0/aeson-2.2.5.0.tar.gz"++    describe "cabalPackagesDirs" do+        it "honors CABAL_DIR" do+            cabalPackagesDirs [("CABAL_DIR", "/cd")] `shouldBe` ["/cd/packages"]++        it "includes the legacy ~/.cabal location alongside the XDG one" do+            cabalPackagesDirs [("HOME", "/h")]+                `shouldBe` ["/h/.cache/cabal/packages", "/h/.cabal/packages"]++        it "yields no candidates (never a relative path) when HOME is unset" do+            cabalPackagesDirs [] `shouldBe` []++        it "only ever produces absolute candidates" do+            all isAbsolute (cabalPackagesDirs [("HOME", "/h"), ("XDG_CACHE_HOME", "/x")])+                `shouldBe` True++    describe "matchesModule" do+        it "matches a src/ layout entry" do+            matchesModule "Data.Aeson" "aeson-2.2.5.0/src/Data/Aeson.hs" `shouldBe` True++        it "matches a lib/ layout entry" do+            matchesModule "Data.Aeson" "aeson-2.2.5.0/lib/Data/Aeson.hs" `shouldBe` True++        it "matches a flat layout entry" do+            matchesModule "Data.Aeson" "aeson-2.2.5.0/Data/Aeson.hs" `shouldBe` True++        it "does not match a different module under the same prefix" do+            matchesModule "Data.Aeson" "aeson-2.2.5.0/src/Data/Aeson/Types.hs" `shouldBe` False++        it "does not match a deeper module whose final component coincides" do+            -- Module `Lens` must not resolve to the file for `Control.Lens`.+            matchesModule "Lens" "pkg-1.0/Control/Lens.hs" `shouldBe` False++        it "matches a preprocessed .hsc entry" do+            matchesModule "System.Posix.Files" "unix-2.8.5.0/System/Posix/Files.hsc" `shouldBe` True++        it "matches a literate .lhs entry" do+            matchesModule "Data.Ratio" "base-4.19.0.0/src/Data/Ratio.lhs" `shouldBe` True++    describe "extractModule" do+        it "extracts a member by module name" do+            extractModule "Data.Aeson" fixtureTarball `shouldBe` Just "module Data.Aeson where\n"++        it "returns Nothing when the module is absent" do+            extractModule "Data.Missing" fixtureTarball `shouldBe` Nothing++        it "prefers a library source path over a same-named test path" do+            extractModule "Data.Aeson" dupModuleTarball+                `shouldBe` Just "module Data.Aeson (lib) where\n"+++-- | A gzipped tar with a single source member.+fixtureTarball :: LByteString+fixtureTarball = mkTarball [("aeson-2.2.5.0/src/Data/Aeson.hs", "module Data.Aeson where\n")]+++-- | A gzipped tar in which the same module appears under both a test tree and+-- the library tree, with the test copy listed first.+dupModuleTarball :: LByteString+dupModuleTarball =+    mkTarball+        [ ("aeson-2.2.5.0/tests/Data/Aeson.hs", "module Data.Aeson (test) where\n")+        , ("aeson-2.2.5.0/src/Data/Aeson.hs", "module Data.Aeson (lib) where\n")+        ]+++-- | Build a gzipped tar from @(path, contents)@ pairs, in the given order.+mkTarball :: [(FilePath, Text)] -> LByteString+mkTarball entries =+    GZip.compress (Tar.write [fileEntry path content | (path, content) <- entries])+  where+    fileEntry path content =+        Tar.fileEntry+            (either (error . toText) id (Tar.toTarPath False path))+            (BSL.fromStrict (encodeUtf8 content))
test/Unit/Tricorder/SourceLookupSpec.hs view
@@ -1,139 +1,259 @@ module Unit.Tricorder.SourceLookupSpec (spec_SourceLookup) where  import Atelier.Effects.Cache (Cache, runCacheForever)+import Atelier.Effects.Env (Env, runEnvConst) 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 Effectful.Reader.Static (Reader, runReader)+import Effectful.State.Static.Shared (State, evalState, gets, modify)+import System.FilePath ((</>)) import Test.Hspec +import Codec.Archive.Tar qualified as Tar+import Codec.Archive.Tar.Entry qualified as Tar+import Codec.Compression.GZip qualified as GZip+import Data.ByteString.Lazy qualified as BSL+import Data.IORef qualified as IORef+import Data.List qualified as List import Data.Map.Strict qualified as Map+import Data.Text qualified as T -import Tricorder.Effects.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted)-import Tricorder.GhcPkg.Types (ModuleName, PackageId, SourceQuery (..))-import Tricorder.SourceLookup (ModuleSourceResult (..), ReExport, lookupModuleSource)+import Tricorder.Module (ModuleName, PackageId)+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.SourceLookup+    ( ModuleSourceResult (..)+    , SourceQuery (..)+    , lookupModuleSource+    )+import Tricorder.SourceLookup.Cabal (Cabal, FetchResult (..), runCabalFetchWith)+import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted)   spec_SourceLookup :: Spec-spec_SourceLookup = do-    describe "lookupModuleSource" testLookupModuleSource-+spec_SourceLookup = describe "lookupModuleSource" do+    it "reads the whole module from a cached tarball" do+        result <-+            runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch+                $ lookupModuleSource (wholeModule "Data.Aeson")+        result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource -testLookupModuleSource :: Spec-testLookupModuleSource = do-    it "returns SourceFound when module, haddock-html, and file are present" do+    it "slices a symbol (with its doc block) from a cached tarball" 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" []+            runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch+                $ lookupModuleSource (symbol "Data.Aeson" "encode")+        result+            `shouldBe` SourceFound+                (symbol "Data.Aeson" "encode")+                "-- | Encode a value as JSON.\nencode :: Value -> ByteString\nencode = undefined" -    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 FunctionNotFound for a symbol absent from the module" do+        result <-+            runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch+                $ lookupModuleSource (symbol "Data.Aeson" "nope")+        result `shouldBe` FunctionNotFound (symbol "Data.Aeson" "nope") -    it "returns SourceNotFound when findModule returns Nothing" do+    it "returns SourceNotFound when the module is in no package" do         result <--            runTest-                [NextFindModule Nothing]-                Map.empty-                (lookupModuleSource (wholeModule "Unknown"))-        result `shouldBe` SourceNotFound (wholeModule "Unknown")+            runTest [NextFindModule Nothing] Map.empty noFetch+                $ lookupModuleSource (wholeModule "Data.Unknown")+        result `shouldBe` SourceNotFound (wholeModule "Data.Unknown") -    it "returns SourceNoHaddock when getHaddockHtml returns Nothing" do+    it "fetches on a cache miss, then reads the now-present tarball" 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"+            runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty (fetchProduces tarballPath tarballBytes)+                $ lookupModuleSource (wholeModule "Data.Aeson")+        result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource -    it "returns SourceNoHaddock when the html file does not exist" do+    it "returns SourceUnavailable when the fetch produces no tarball" 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"+            runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty noFetch+                $ lookupModuleSource (wholeModule "Data.Aeson")+        result `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.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")+    it "caches the result so a second lookup needs no further resolution" do+        -- Only one NextFindModule is scripted; the second lookup must be served+        -- entirely from cache (module→package and package→source).+        (r1, r2) <-+            runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch $ do+                r1 <- lookupModuleSource (wholeModule "Data.Aeson")+                r2 <- lookupModuleSource (wholeModule "Data.Aeson")                 pure (r1, r2)-        r1 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" []-        r2 `shouldBe` SourceFound (wholeModule "Bar") "module Bar where" []+        r1 `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource+        r2 `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource +    it "caches an unavailable result and does not re-fetch on a repeat lookup" do+        -- The tarball is absent and every fetch fails, so the first lookup is+        -- SourceUnavailable. A repeat lookup must be served from cache — no+        -- second `cabal fetch` on the (network) request path.+        fetchCount <- IORef.newIORef (0 :: Int)+        let countingFetch = do+                liftIO (IORef.modifyIORef' fetchCount (+ 1))+                noFetch+        (r1, r2) <-+            runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty countingFetch $ do+                r1 <- lookupModuleSource (wholeModule "Data.Aeson")+                r2 <- lookupModuleSource (wholeModule "Data.Aeson")+                pure (r1, r2)+        r1 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0"+        r2 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0"+        fetches <- IORef.readIORef fetchCount+        fetches `shouldBe` 1 +    it "re-fetches after a failed fetch rather than caching the failure" do+        -- A failed `cabal fetch` (offline, stale index) is transient, so the+        -- resulting SourceUnavailable must NOT be cached: a repeat lookup has to+        -- retry the fetch, or a brief network blip pins unavailability for the+        -- whole cache window.+        fetchCount <- IORef.newIORef (0 :: Int)+        let failingFetch = do+                liftIO (IORef.modifyIORef' fetchCount (+ 1))+                pure FetchFailed+        (r1, r2) <-+            runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty failingFetch $ do+                r1 <- lookupModuleSource (wholeModule "Data.Aeson")+                r2 <- lookupModuleSource (wholeModule "Data.Aeson")+                pure (r1, r2)+        r1 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0"+        r2 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0"+        fetches <- IORef.readIORef fetchCount+        fetches `shouldBe` 2++    it "finds a tarball in the legacy ~/.cabal cache location" do+        result <-+            runTest [NextFindModule (Just "aeson-2.2.5.0")] withLegacyTarball noFetch+                $ lookupModuleSource (wholeModule "Data.Aeson")+        result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource++ -------------------------------------------------------------------------------- -- Fixtures -------------------------------------------------------------------------------- -sampleHtml :: LByteString-sampleHtml = "<html><body><pre id=\"src\"><span>module</span> Foo <span>where</span></pre></body></html>"+-- | Source of the fixture module, carried verbatim in the fixture tarball.+moduleSource :: Text+moduleSource =+    T.unlines+        [ "module Data.Aeson where"+        , ""+        , "-- | Encode a value as JSON."+        , "encode :: Value -> ByteString"+        , "encode = undefined"+        ]  -barHtml :: LByteString-barHtml = "<html><body><pre id=\"src\"><span>module</span> Bar <span>where</span></pre></body></html>"+-- | The cabal cache path the fixture package resolves to under @HOME=\/h@.+tarballPath :: FilePath+tarballPath =+    "/h/.cache/cabal/packages" </> "hackage.haskell.org/aeson/2.2.5.0/aeson-2.2.5.0.tar.gz"  --- | Helper: a whole-module query (no function filter).+-- | A gzipped tar holding the fixture module under a @src\/@ layout.+tarballBytes :: LByteString+tarballBytes = mkTarball "aeson-2.2.5.0/src/Data/Aeson.hs" moduleSource+++-- | A filesystem in which the fixture tarball is already cached.+withTarball :: Map FilePath LByteString+withTarball = Map.singleton tarballPath tarballBytes+++-- | The legacy (pre-XDG) cabal cache path under @HOME=\/h@.+legacyTarballPath :: FilePath+legacyTarballPath =+    "/h/.cabal/packages" </> "hackage.haskell.org/aeson/2.2.5.0/aeson-2.2.5.0.tar.gz"+++-- | A filesystem in which the fixture tarball lives only in the legacy cache.+withLegacyTarball :: Map FilePath LByteString+withLegacyTarball = Map.singleton legacyTarballPath tarballBytes+++mkTarball :: FilePath -> Text -> LByteString+mkTarball entryPath content =+    GZip.compress (Tar.write [Tar.fileEntry tarPath (BSL.fromStrict (encodeUtf8 content))])+  where+    tarPath = either (error . toText) id (Tar.toTarPath False entryPath)++ wholeModule :: ModuleName -> SourceQuery wholeModule m = SourceQuery {moduleName = m, function = Nothing}  +symbol :: ModuleName -> Text -> SourceQuery+symbol m s = SourceQuery {moduleName = m, function = Just s}++ ----------------------------------------------------------------------------------- Helpers+-- Harness -------------------------------------------------------------------------------- -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"+-- | The action a faked @cabal fetch@ runs: 'noFetch' leaves the filesystem+-- untouched (a clean fetch that produces no tarball); 'fetchProduces' inserts a+-- file. A failed fetch is modelled by returning 'FetchFailed' directly.+noFetch :: Eff es FetchResult+noFetch = pure Fetched  +fetchProduces+    :: (State (Map FilePath LByteString) :> es)+    => FilePath -> LByteString -> Eff es FetchResult+fetchProduces path bytes = do+    modify (Map.insert path bytes)+    pure Fetched++ runTest     :: [GhcPkgScript]     -> Map FilePath LByteString-    -> Eff '[Cache ModuleName PackageId, Cache (PackageId, SourceQuery) (Text, [ReExport]), FileSystem, GhcPkg, Log, Concurrent, IOE] a+    -> Eff '[FileSystem, State (Map FilePath LByteString), Log, Concurrent, IOE] FetchResult+    -> Eff+        '[ Cache ModuleName PackageId+         , Cache (PackageId, SourceQuery) ModuleSourceResult+         , GhcPkg+         , Env+         , Reader ProjectRoot+         , Cabal+         , FileSystem+         , State (Map FilePath LByteString)+         , Log+         , Concurrent+         , IOE+         ]+        a     -> IO a-runTest pkgScript files action =+runTest pkgScript initialFs onFetch action =     runEff         . runConcurrent         . runLogNoOp+        . evalState initialFs+        . runFileSystemFake+        . runCabalFetchWith onFetch+        . runReader (ProjectRoot "/proj")+        . runEnvConst [("HOME", "/h")]         . runGhcPkgScripted pkgScript-        . runFileSystemScripted files-        . runCacheForever @(PackageId, SourceQuery) @(Text, [ReExport])+        . runCacheForever @(PackageId, SourceQuery) @ModuleSourceResult         . runCacheForever @ModuleName @PackageId         $ action+++-- | A 'FileSystem' backed by an in-memory map, with directory semantics good+-- enough for the cabal-cache layout: 'doesPathExist' treats a key as living+-- under any of its path prefixes, and 'listDirectory' returns immediate child+-- names (so a repo subdir like @hackage.haskell.org@ is discoverable).+runFileSystemFake+    :: (State (Map FilePath LByteString) :> es)+    => Eff (FileSystem : es) a -> Eff es a+runFileSystemFake = interpret_ \case+    DoesFileExist p -> gets (Map.member p)+    DoesPathExist p -> gets (any (isUnder p) . Map.keys)+    ListDirectory p -> gets (ordNub . mapMaybe (childName p) . Map.keys)+    ReadFileLbsFrom p _ -> gets (fromMaybe "" . Map.lookup p)+    _ -> error "runFileSystemFake: unexpected operation"+  where+    isUnder p k = p == k || (p <> "/") `List.isPrefixOf` k+    childName p k = case List.stripPrefix (p <> "/") k of+        Just rest | not (null rest) -> Just (takeWhile (/= '/') rest)+        _ -> Nothing
− test/Unit/Tricorder/SourceSpec.hs 
@@ -1,161 +0,0 @@-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
@@ -2,10 +2,11 @@  import Test.Hspec -import Tricorder.BuildState (TestCase (..), TestCaseOutcome (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput, stripGhciNoise) +import Tricorder.Build.Test qualified as Test + spec_TestOutput :: Spec spec_TestOutput = do     describe "parseHspecOutput" do@@ -15,12 +16,12 @@         it "parses a passing test" do             let output = "  foo\n    bar baz:                                      OK\n"             parseHspecOutput output-                `shouldBe` [TestCase {description = "bar baz:", outcome = TestCasePassed}]+                `shouldBe` [Test.Case {description = "bar baz:", outcome = Test.Passed}]          it "parses a failing test" do             let output = "  foo\n    bar baz:                                      FAIL\n"             parseHspecOutput output-                `shouldBe` [TestCase {description = "bar baz:", outcome = TestCaseFailed ""}]+                `shouldBe` [Test.Case {description = "bar baz:", outcome = Test.Failed ""}]          it "captures failure details" do             let output =@@ -29,11 +30,11 @@                         <> "       but got: 2\n"                         <> "    another test:                                       OK\n"             parseHspecOutput output-                `shouldBe` [ TestCase+                `shouldBe` [ Test.Case                                 { description = "a test:"-                                , outcome = TestCaseFailed "expected: 1\nbut got: 2"+                                , outcome = Test.Failed "expected: 1\nbut got: 2"                                 }-                           , TestCase {description = "another test:", outcome = TestCasePassed}+                           , Test.Case {description = "another test:", outcome = Test.Passed}                            ]          it "stops collecting details when indentation returns to test level" do@@ -44,7 +45,7 @@             let cases = parseHspecOutput output             length cases `shouldBe` 2             case cases of-                (c : _) -> c.outcome `shouldBe` TestCaseFailed "detail line"+                (c : _) -> c.outcome `shouldBe` Test.Failed "detail line"                 [] -> expectationFailure "expected at least one test case"          it "skips group header lines" do@@ -53,7 +54,7 @@                         <> "    someFunction\n"                         <> "      does the thing:                                  OK\n"             parseHspecOutput output-                `shouldBe` [TestCase {description = "does the thing:", outcome = TestCasePassed}]+                `shouldBe` [Test.Case {description = "does the thing:", outcome = Test.Passed}]          it "parses mixed passing and failing tests" do             let output =@@ -63,30 +64,30 @@                         <> "      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}+                `shouldBe` [ Test.Case {description = "passes:", outcome = Test.Passed}+                           , Test.Case {description = "fails:", outcome = Test.Failed "reason"}+                           , Test.Case {description = "also passes:", outcome = Test.Passed}                            ]          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}]+                `shouldBe` [Test.Case {description = "slow test:", outcome = Test.Passed}]          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}]+                `shouldBe` [Test.Case {description = "fast property:", outcome = Test.Passed}]          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 ""}]+                `shouldBe` [Test.Case {description = "slow fail:", outcome = Test.Failed ""}]          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}]+                `shouldBe` [Test.Case {description = "test (corner case):", outcome = Test.Passed}]      describe "parseHspecDuration" do         it "returns Nothing for empty output" do
− test/Unit/Tricorder/TestRunnerSpec.hs 
@@ -1,319 +0,0 @@-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/WaitersSpec.hs view
@@ -0,0 +1,140 @@+module Unit.Tricorder.WaitersSpec (spec_Waiters) where++import Atelier.Effects.Conc (Conc, runConc)+import Effectful (IOE, runEff)+import Effectful.Concurrent (Concurrent, runConcurrent)+import Effectful.Exception (catch, throwIO)+import Effectful.State.Static.Shared (State, get, modify, runState)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldThrow)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Types.Semaphore qualified as Sem++import Tricorder.Waiters (Waiters)++import Tricorder.Waiters qualified as Waiters+++-- | Test exception type, used to prove that a waiter's slot is released+-- even when its action throws.+data TestException = TestException Text+    deriving stock (Eq, Show)+    deriving anyclass (Exception)+++runWaitersTest+    :: Eff [Waiters, State [Text], Conc, Concurrent, IOE] a+    -> IO (a, [Text])+runWaitersTest =+    runEff+        . runConcurrent+        . runConc+        . runState @[Text] []+        . Waiters.run+++logEvent :: (State [Text] :> es) => Text -> Eff es ()+logEvent name = modify (<> [name])+++spec_Waiters :: Spec+spec_Waiters = do+    describe "Waiters.without" do+        describe "with waiters" $ it "skips the action" do+            (_, events) <- runWaitersTest do+                proceed <- Sem.new+                started <- Sem.new+                waiter <- Conc.fork $ Waiters.with do+                    void $ Sem.set started+                    Sem.wait proceed+                    logEvent "waiter"+                Sem.wait started+                -- Called directly (not forked): Without never blocks, so+                -- forking it here would race its no-waiters check against+                -- the `Sem.set proceed` below, making the test flaky.+                Waiters.without (logEvent "without")+                void $ Sem.set proceed+                Conc.await waiter+            events `shouldBe` ["waiter"]+        it "runs its action immediately when there are no active waiters" do+            (_, events) <- runWaitersTest $ Waiters.without (logEvent "ran")+            events `shouldBe` ["ran"]++    describe "Waiters.with" do+        it "runs its action" do+            (_, events) <- runWaitersTest $ Waiters.with (logEvent "ran")+            events `shouldBe` ["ran"]++        it "lets a subsequent Waiters.wait proceed once it has completed" do+            (_, events) <- runWaitersTest do+                Waiters.with (logEvent "waiter")+                Waiters.wait (logEvent "quiesced")+            events `shouldBe` ["waiter", "quiesced"]++        it "blocks a concurrent Waiters.wait until its action finishes" do+            (_, events) <- runWaitersTest do+                started <- Sem.new+                proceed <- Sem.new+                waiter <- Conc.fork $ Waiters.with do+                    _ <- Sem.set started+                    Sem.wait proceed+                    logEvent "waiter-end"+                Sem.wait started+                quiescent <- Conc.fork $ Waiters.wait (logEvent "quiesced")+                _ <- Sem.set proceed+                Conc.await waiter+                Conc.await quiescent+            -- Blocking is guaranteed by the STM retry on the waiter count,+            -- not by scheduling luck, so this order holds on every run.+            events `shouldBe` ["waiter-end", "quiesced"]++        it "blocks wait until every concurrent waiter finishes" do+            (afterFirst, events) <- runWaitersTest do+                started1 <- Sem.new+                proceed1 <- Sem.new+                waiter1 <- Conc.fork $ Waiters.with do+                    _ <- Sem.set started1+                    Sem.wait proceed1+                    logEvent "waiter1-end"+                Sem.wait started1++                quiescent <- Conc.fork $ Waiters.wait (logEvent "quiesced")++                started2 <- Sem.new+                proceed2 <- Sem.new+                waiter2 <- Conc.fork $ Waiters.with do+                    _ <- Sem.set started2+                    Sem.wait proceed2+                    logEvent "waiter2-end"+                Sem.wait started2++                _ <- Sem.set proceed1+                Conc.await waiter1+                -- waiter2 is still active here, so the waiter count cannot+                -- have reached zero yet: quiescent is still blocked, not+                -- just "hasn't been scheduled".+                afterFirst <- get+                _ <- Sem.set proceed2+                Conc.await waiter2+                -- No snapshot is taken here: once waiter2's slot is released,+                -- quiescent's STM retry can wake and log concurrently with+                -- this thread, so there is no deterministic in-between state+                -- to observe. Only the final, fully-awaited state is safe to+                -- assert on.+                Conc.await quiescent+                pure afterFirst+            afterFirst `shouldMatchList` ["waiter1-end"]+            events `shouldMatchList` ["waiter1-end", "waiter2-end", "quiesced"]++    describe "exception safety" do+        it "propagates an exception raised by the waiter's action" do+            let action = runWaitersTest $ Waiters.with (throwIO $ TestException "boom")+            action `shouldThrow` \(TestException msg) -> msg == "boom"++        it "releases the waiter slot even when the action throws" do+            (_, events) <- runWaitersTest do+                _ <-+                    Waiters.with (throwIO $ TestException "boom")+                        `catch` \(_ :: TestException) -> pure ()+                Waiters.without (logEvent "quiesced")+            events `shouldBe` ["quiesced"]
− test/Unit/Tricorder/WatcherSpec.hs 
@@ -1,135 +0,0 @@-module Unit.Tricorder.WatcherSpec (spec_Watcher) where--import Atelier.Effects.Delay (runDelay)-import Atelier.Effects.FileWatcher (FileEvent (..), matchesAny)-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 Text.Regex.TDFA.ReadRegex (parseRegex)--import Tricorder.BuildState-    ( CabalChangeDetected (..)-    , ChangeKind (..)-    , DaemonInfo (..)-    , SourceChangeDetected (..)-    )-import Tricorder.Effects.BuildStore (BuildStore (..))-import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (WatchDirs (..), WatchExclusionPatterns (WatchExclusionPatterns))-import Tricorder.Watcher (WatchedFile (..), WatcherSession (..), makeWatches, markWatchedFiles)---spec_Watcher :: Spec-spec_Watcher = do-    describe "markWatchedFiles" testMarkWatchedFiles-    describe "makeWatches" testMakeWatches---testMarkWatchedFiles :: Spec-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"---testMakeWatches :: Spec-testMakeWatches = do-    describe "source watches" do-        it "matches .hs files in configured watch dirs" do-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True--        it "does not match non-.hs files" do-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])-            matchesAny watches "/proj/src/Foo.txt" `shouldBe` False--        it "excludes paths containing dist-newstyle" do-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])-            matchesAny watches "/proj/src/dist-newstyle/Foo.hs" `shouldBe` False--        it "excludes paths matching an exclusion pattern" do-            let pat = parsePattern "vendor"-                watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [pat])-            matchesAny watches "/proj/src/vendor/Foo.hs" `shouldBe` False-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True--        it "matches .hs files across multiple watch dirs" do-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src", "/proj/test"] [])-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True-            matchesAny watches "/proj/test/FooSpec.hs" `shouldBe` True--        -- Second line of defense: 'cabalWatches' registers the whole project-        -- root, and 'deduplicateDirs' collapses the narrow source dirs into it,-        -- so the OS watches the entire repo recursively. 'matchesAny' is what-        -- re-scopes events back to the configured dirs — a .hs file in a sibling-        -- package must not match.-        it "does not match a .hs file in a sibling package outside the watch dirs" do-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/pkg-a/src"] [])-            matchesAny watches "/proj/pkg-a/src/Foo.hs" `shouldBe` True-            matchesAny watches "/proj/pkg-b/src/Foo.hs" `shouldBe` False--    describe "cabal watches" do-        it "matches .cabal files under project root" do-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession-            matchesAny watches "/proj/foo.cabal" `shouldBe` True--        it "matches cabal.project under project root" do-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession-            matchesAny watches "/proj/cabal.project" `shouldBe` True--        it "matches package.yaml under project root" do-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession-            matchesAny watches "/proj/package.yaml" `shouldBe` True--        it "does not match non-cabal files" do-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession-            matchesAny watches "/proj/README.md" `shouldBe` False--        it "excludes cabal files under dist-newstyle" do-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession-            matchesAny watches "/proj/dist-newstyle/foo.cabal" `shouldBe` False-  where-    parsePattern p = fromRight (error . toText $ "bad test pattern: " <> p) (parseRegex p)-    emptyWatcherSession = watcherSession [] []-    watcherSession dirs patterns = WatcherSession (WatchDirs dirs) (WatchExclusionPatterns patterns)---emptyDaemonInfo :: DaemonInfo-emptyDaemonInfo =-    DaemonInfo-        { targets = []-        , watchDirs = []-        , sockPath = ""-        , logFile = ""-        , metricsPort = Nothing-        }
tricorder.cabal view
@@ -5,12 +5,12 @@ -- see: https://github.com/sol/hpack  name:           tricorder-version:        0.1.1.0+version:        0.2.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+homepage:       https://github.com/tweag/tricorder#readme+bug-reports:    https://github.com/tweag/tricorder/issues author:         Christian Georgii maintainer:     christian.georgii@tweag.io license:        MIT@@ -22,51 +22,66 @@  source-repository head   type: git-  location: https://github.com/atelier-hub/tricorder+  location: https://github.com/tweag/tricorder  library tricorder-internal   exposed-modules:-      Tricorder-      Tricorder.Arguments-      Tricorder.Builder-      Tricorder.Builder.Dispatch-      Tricorder.BuildState-      Tricorder.CLI+      Tricorder.Build+      Tricorder.Build.Changes+      Tricorder.Build.EvalComment+      Tricorder.Build.Test+      Tricorder.CLI.App+      Tricorder.CLI.Arguments+      Tricorder.CLI.Daemon       Tricorder.CLI.Main+      Tricorder.CLI.Operations       Tricorder.CLI.Render+      Tricorder.CLI.UI+      Tricorder.CLI.UI.Brick+      Tricorder.CLI.UI.BrickChan+      Tricorder.CLI.UI.Event+      Tricorder.CLI.UI.Keys+      Tricorder.CLI.UI.Misc+      Tricorder.CLI.UI.Route+      Tricorder.CLI.UI.State+      Tricorder.CLI.UI.View       Tricorder.Config-      Tricorder.Daemon+      Tricorder.Daemon.Builder+      Tricorder.Daemon.Core+      Tricorder.Daemon.DaemonInfo+      Tricorder.Daemon.Dispatch+      Tricorder.Daemon.EvalCommentRunner+      Tricorder.Daemon.GhciSession+      Tricorder.Daemon.GhciSession.GhciParser+      Tricorder.Daemon.GhciSession.GhciProcess       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.Daemon.TestRunner+      Tricorder.Daemon.Watch+      Tricorder.Logging+      Tricorder.Module       Tricorder.Runtime       Tricorder.Session+      Tricorder.Session.CabalFile+      Tricorder.Session.Command+      Tricorder.Session.Config+      Tricorder.Session.ReplBuildDir+      Tricorder.Session.Target+      Tricorder.Session.TestTarget+      Tricorder.Session.TestTimeout+      Tricorder.Session.WatchDirs+      Tricorder.Session.WatchExclusionPatterns       Tricorder.Socket.Client       Tricorder.Socket.Protocol       Tricorder.Socket.Server+      Tricorder.Socket.UnixSocket       Tricorder.SourceLookup+      Tricorder.SourceLookup.Cabal+      Tricorder.SourceLookup.GhcPkg+      Tricorder.SourceLookup.Slice+      Tricorder.SourceLookup.Tarball       Tricorder.TestOutput-      Tricorder.UI-      Tricorder.UI.Event-      Tricorder.UI.Keys-      Tricorder.UI.Misc-      Tricorder.UI.Route-      Tricorder.UI.State-      Tricorder.UI.View       Tricorder.Version-      Tricorder.Watcher+      Tricorder.Waiters   other-modules:       Paths_tricorder   autogen-modules:@@ -92,10 +107,11 @@       TypeFamilies   ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded   build-depends:-      Cabal-syntax >=3.12 && <3.17+      Cabal >=3.12 && <3.17+    , Cabal-syntax >=3.12 && <3.17     , aeson ==2.2.*     , ansi-terminal ==1.1.*-    , atelier-core ==0.2.*+    , atelier-core ==0.3.*     , atelier-prelude ==0.1.*     , base >=4.18 && <4.23     , brick ==2.10.*@@ -118,6 +134,7 @@     , regex-tdfa >=1.3.2.5 && <1.4     , relude ==1.2.*     , stm ==2.5.*+    , tar >=0.6 && <0.8     , template-haskell >=2.20 && <2.25     , text ==2.1.*     , time >=1.12 && <1.16@@ -125,6 +142,7 @@     , vty ==6.5.*     , vty-crossplatform ==0.5.*     , yaml ==0.11.*+    , zlib ==0.7.*   mixins:       base hiding (Prelude)   default-language: GHC2021@@ -211,22 +229,30 @@   type: exitcode-stdio-1.0   main-is: Driver.hs   other-modules:-      Unit.Tricorder.BuilderSpec-      Unit.Tricorder.BuildStateSpec-      Unit.Tricorder.BuildStoreSpec+      Unit.Tricorder.Build.EvalCommentSpec       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.Daemon.BuilderSpec+      Unit.Tricorder.Daemon.BuildStateSpec+      Unit.Tricorder.Daemon.DispatchSpec+      Unit.Tricorder.Daemon.GhciSession.GhciParserSpec+      Unit.Tricorder.Daemon.GhciSession.GhciProcessSpec+      Unit.Tricorder.Daemon.GhciSessionSpec+      Unit.Tricorder.Daemon.TestRunnerSpec+      Unit.Tricorder.Daemon.WatchSpec+      Unit.Tricorder.Session.CabalFileSpec+      Unit.Tricorder.Session.CommandSpec+      Unit.Tricorder.Session.Helpers+      Unit.Tricorder.Session.TargetSpec+      Unit.Tricorder.Session.TestTargetSpec+      Unit.Tricorder.Session.WatchDirsSpec       Unit.Tricorder.SessionSpec       Unit.Tricorder.SocketSpec+      Unit.Tricorder.SourceLookup.GhcPkgSpec+      Unit.Tricorder.SourceLookup.SliceSpec+      Unit.Tricorder.SourceLookup.TarballSpec       Unit.Tricorder.SourceLookupSpec-      Unit.Tricorder.SourceSpec       Unit.Tricorder.TestOutputSpec-      Unit.Tricorder.TestRunnerSpec-      Unit.Tricorder.WatcherSpec+      Unit.Tricorder.WaitersSpec       Paths_tricorder   autogen-modules:       Paths_tricorder@@ -255,18 +281,22 @@   build-depends:       Cabal-syntax >=3.12 && <3.17     , aeson ==2.2.*-    , atelier-core ==0.2.*+    , atelier-core ==0.3.*     , atelier-prelude ==0.1.*     , base >=4.18 && <4.23+    , bytestring >=0.11 && <0.13     , containers >=0.6 && <0.9     , data-default ==0.8.*     , effectful ==2.6.*     , effectful-core ==2.6.*     , effectful-plugin >=2.0 && <2.2+    , filepath >=1.4 && <1.6     , hspec ==2.11.*+    , megaparsec ==9.7.*     , process ==1.6.*     , regex-tdfa >=1.3.2.5 && <1.4     , stm ==2.5.*+    , tar >=0.6 && <0.8     , tasty ==1.5.*     , tasty-discover ==5.2.*     , tasty-hspec ==1.2.*@@ -277,6 +307,7 @@     , typed-process ==0.2.*     , unagi-chan ==0.4.*     , unix ==2.8.*+    , zlib ==0.7.*   mixins:       base hiding (Prelude)   default-language: GHC2021