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