diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,36 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and this project adheres to the [PVP](https://pvp.haskell.org/). +## [Unreleased] + +## [0.2.0.0] - 2026-08-06 + +### Added + +- The TUI can now restart the daemon — press `R` (the `restart_daemon` key + event, rebindable like the others). It reconnects automatically once the + fresh daemon is ready. +- Support for eval comments. See [Features of Tricorder - Eval Comments] for + more information +- `tricorder eval-comments` subcommand. +- `tricorder log --print-path` prints the path to the current repo's Tricorder + log file. + +### Fixed + +- No diagnostics are listed in single-package repos. +- Build loops on startup failure. + +### Changed + +- `tricorder source` now uses a package's sdist tarball from cabal's global + cache instead of parsing Haddock-HTML, fetching them if necessary. This + allows Tricorder to show sources for packages without documentation. + +### Removed + +- Observability and metrics stack. + ## [0.1.1.0] - 2026-06-26 ### Added @@ -48,3 +78,5 @@ - Configurable via `.tricorder.toml` (targets, debounce, log file, etc.). - File watcher with debouncing; auto-restarts the GHCi session on crash (fixes ghcid's crash-on-file-removal bug). + +[Features of Tricorder - Eval Comments]: ../docs/features-of-tricorder.md#eval-comments diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,16 +4,16 @@ Like `ghcid` and `ghciwatch`, it rebuilds continuously on every change and reports diagnostics — but it runs builds in a background daemon so multiple clients (an interactive TUI, a `tricorder status` CLI, a Claude Code skill) can query a single shared build state without triggering redundant rebuilds. It discovers components across multi-package `cabal.project` workspaces automatically and ships context-friendly output for agentic use. -See the [repository README](https://github.com/atelier-hub/tricorder#readme) for installation (Nix, Home Manager, NixOS), Claude Code plugin setup, configuration, and custom key bindings. +See the [repository README](https://github.com/tweag/tricorder#readme) for installation (Nix, Home Manager, NixOS), Claude Code plugin setup, configuration, and custom key bindings. ## Built on atelier `tricorder` is built on the **atelier** toolkit, also developed in this repository: -- [`atelier-prelude`](https://github.com/atelier-hub/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions -- [`atelier-core`](https://github.com/atelier-hub/tricorder/tree/main/atelier-core) — foundational effects and utilities -- [`atelier-db`](https://github.com/atelier-hub/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8) -- [`atelier-testing`](https://github.com/atelier-hub/tricorder/tree/main/atelier-testing) — database-backed test utilities +- [`atelier-prelude`](https://github.com/tweag/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions +- [`atelier-core`](https://github.com/tweag/tricorder/tree/main/atelier-core) — foundational effects and utilities +- [`atelier-db`](https://github.com/tweag/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8) +- [`atelier-testing`](https://github.com/tweag/tricorder/tree/main/atelier-testing) — database-backed test utilities ## License diff --git a/src/Tricorder.hs b/src/Tricorder.hs deleted file mode 100644 --- a/src/Tricorder.hs +++ /dev/null @@ -1,108 +0,0 @@ -module Tricorder (run) where - -import Atelier.Effects.Clock (Clock) -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.Console (Console) -import Atelier.Effects.Delay (Delay) -import Atelier.Effects.Exit (Exit) -import Atelier.Effects.File (File) -import Atelier.Effects.FileSystem (FileSystem) -import Atelier.Effects.Posix.Daemons (Daemons) -import Effectful (IOE) -import Effectful.Reader.Static (Reader, ask, asks) -import Effectful.Timeout (Timeout) - -import Atelier.Effects.Console qualified as Console -import Data.Text qualified as T - -import Tricorder.Arguments (Command (..)) -import Tricorder.BuildState (BuildState (..), DaemonInfo (..)) -import Tricorder.CLI (showLog, showSource, showStatus, showTests) -import Tricorder.Daemon (startDaemon, stopDaemon, waitForDaemon) -import Tricorder.Effects.Brick (Brick) -import Tricorder.Effects.BrickChan (BrickChan) -import Tricorder.Effects.UnixSocket (UnixSocket) -import Tricorder.Runtime (LogPath (..), PidFile (..), SocketPath (..)) -import Tricorder.Socket.Client (isDaemonRunning, queryStatus) -import Tricorder.UI (viewUi) - -import Tricorder.UI.Keys qualified as Keys - - -run - :: ( Brick :> es - , BrickChan :> es - , Clock :> es - , Conc :> es - , Console :> es - , Daemons :> es - , Delay :> es - , Exit :> es - , File :> es - , FileSystem :> es - , IOE :> es - , Reader Command :> es - , Reader Keys.Config :> es - , Reader LogPath :> es - , Reader PidFile :> es - , Reader SocketPath :> es - , Timeout :> es - , UnixSocket :> es - ) - => Eff es () -run = - ask >>= \case - Start -> do - running <- isDaemonRunning - if running then - Console.putStrLn "Daemon already running." - else do - startDaemon - Console.putStrLn "Daemon started." - Stop -> do - running <- isDaemonRunning - when running - $ stopDaemon >>= \case - Left reasons -> - Console.putTextLn - $ T.intercalate "\n" - $ "Was unable to stop the daemon:" : reasons - Right result -> do - Console.putTextLn result - Status opts -> do - running <- isDaemonRunning - if not running then - Console.putStrLn "Stopped." - else - showStatus opts - Test opts -> do - running <- isDaemonRunning - if not running then - Console.putStrLn "Stopped." - else - showTests opts - Log followMode -> do - running <- isDaemonRunning - logFile <- - if running then do - SocketPath sp <- ask - result <- queryStatus sp - LogPath fallback <- ask - pure $ case result of - Right state -> state.daemonInfo.logFile - Left _ -> fallback - else - asks @LogPath (.getLogPath) - showLog logFile followMode - UI -> do - running <- isDaemonRunning - unless running do - startDaemon - waitForDaemon - viewUi - Source moduleNames -> do - running <- isDaemonRunning - unless running $ do - startDaemon - waitForDaemon - showSource moduleNames diff --git a/src/Tricorder/Arguments.hs b/src/Tricorder/Arguments.hs deleted file mode 100644 --- a/src/Tricorder/Arguments.hs +++ /dev/null @@ -1,206 +0,0 @@ -module Tricorder.Arguments - ( Command (..) - , FollowMode (..) - , OutputFormat (..) - , StatusOptions (..) - , TestOptions (..) - , Verbosity (..) - , WaitMode (..) - , parseArguments - , runArguments - ) where - -import Atelier.Effects.Arguments (Arguments, execParser) -import Effectful.Reader.Static (Reader, runReader) -import Options.Applicative - ( Parser - , ParserInfo - , ReadM - , argument - , auto - , command - , eitherReader - , flag - , fullDesc - , header - , help - , helper - , hsubparser - , info - , infoOption - , long - , metavar - , option - , progDesc - , short - ) - -import Data.Text qualified as T - -import Tricorder.GhcPkg.Types (ModuleName (..), SourceQuery (..)) - -import Tricorder.Version qualified as Version - - -data WaitMode - = ShowCurrent - | WaitForBuild - deriving stock (Eq) - - -data OutputFormat - = TextOutput - | JsonOutput - deriving stock (Eq) - - -data Verbosity - = Concise - | Verbose - deriving stock (Eq) - - -data FollowMode - = NoFollow - | Follow - deriving stock (Eq) - - -data StatusOptions = StatusOptions - { wait :: WaitMode - , format :: OutputFormat - , verbosity :: Verbosity - , expand :: Maybe Int - } - - -data TestOptions = TestOptions - { failedOnly :: Bool - , wait :: WaitMode - } - - -data Command - = Start - | Stop - | Status StatusOptions - | Test TestOptions - | UI - | Log FollowMode - | Source [SourceQuery] - - -runArguments :: (Arguments :> es) => Eff (Reader Command : es) a -> Eff es a -runArguments eff = do - args <- parseArguments - runReader args eff - - -parseArguments :: (Arguments :> es) => Eff es Command -parseArguments = execParser opts - - -opts :: ParserInfo Command -opts = - info (commandParser <**> versionOption <**> helper) - $ fullDesc - <> progDesc "tricorder — daemon-based GHCi build status" - <> header "tricorder — robust GHCi daemon with structured querying" - - -versionOption :: Parser (a -> a) -versionOption = infoOption (toString Version.gitHash) (long "version" <> help "Show version and exit") - - -commandParser :: Parser Command -commandParser = - hsubparser - ( command "start" (info (pure Start) (progDesc "Start the daemon (no-op if already running)")) - <> command "stop" (info (pure Stop) (progDesc "Stop the daemon")) - <> command "status" (info statusParser (progDesc "Print build diagnostics (--json for machine-readable output)")) - <> command "test-results" (info testParser (progDesc "Show output from the latest test run")) - <> command "ui" (info (pure UI) (progDesc "Auto-refreshing terminal display")) - <> command "log" (info logParser (progDesc "Show daemon log output")) - <> command "source" (info sourceParser (progDesc "Print the Haskell source of one or more installed modules")) - ) - - -logParser :: Parser Command -logParser = - Log - <$> flag - NoFollow - Follow - ( long "follow" - <> short 'f' - <> help "Keep streaming new log lines as they are written" - ) - - -statusParser :: Parser Command -statusParser = - Status - <$> ( StatusOptions - <$> flag - ShowCurrent - WaitForBuild - ( long "wait" - <> help "Block until the current build cycle completes" - ) - <*> flag - TextOutput - JsonOutput - ( long "json" - <> help "Output full build state as JSON" - ) - <*> flag - Concise - Verbose - ( long "verbose" - <> short 'v' - <> help "Print full GHC message body under each diagnostic" - ) - <*> optional - ( option - auto - ( long "expand" - <> metavar "N" - <> help "Print full GHC message body for diagnostic #N" - ) - ) - ) - - -testParser :: Parser Command -testParser = - Test - <$> ( TestOptions - <$> flag - False - True - ( long "failed" - <> help "Only show output from failed test suites" - ) - <*> flag - ShowCurrent - WaitForBuild - ( long "wait" - <> help "Block until the current build cycle completes" - ) - ) - - -sourceParser :: Parser Command -sourceParser = - Source <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function")) - - -queryReader :: ReadM SourceQuery -queryReader = eitherReader $ \s -> - let t = toText s - (m, rest) = T.break (== '#') t - in Right - $ SourceQuery - { moduleName = ModuleName m - , function = if T.null rest then Nothing else Just (T.tail rest) - } diff --git a/src/Tricorder/Build.hs b/src/Tricorder/Build.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Build.hs @@ -0,0 +1,101 @@ +module Tricorder.Build + ( BuildState (..) + , BuildId (..) + , BuildPhase (..) + , BuildProgress (..) + , BuildResult (..) + , PostBuild (..) + , Diagnostic (..) + , Severity (..) + ) where + +import Atelier.Effects.Clock (UTCTime) +import Atelier.Time (Millisecond) +import Data.Aeson (FromJSON (..), ToJSON (..), withText) +import GHC.Generics (Generically (..)) + +import Tricorder.Daemon.DaemonInfo (DaemonInfo) +import Tricorder.Session.TestTarget (TestTarget) + +import Tricorder.Build.EvalComment qualified as Eval +import Tricorder.Build.Test qualified as Test + + +data BuildState = BuildState + { daemonInfo :: DaemonInfo + , phase :: BuildPhase + , buildId :: BuildId + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically BuildState + + +newtype BuildId = BuildId {getBuildId :: Int} + deriving stock (Eq, Show) + deriving (FromJSON, Num, ToJSON) via Int + + +data BuildPhase + = Starting + | Building [TestTarget] BuildProgress + | Failed Text + | PostBuilding BuildResult PostBuild + | Finished BuildResult PostBuild + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically BuildPhase + + +data BuildProgress = BuildProgress + { compiled :: Int + , total :: Int + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically BuildProgress + + +data BuildResult = BuildResult + { completedAt :: UTCTime + , duration :: Millisecond + , moduleCount :: Int + , diagnostics :: [Diagnostic] + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically BuildResult + + +data PostBuild = PostBuild + { testSuites :: Test.Suites + , evalComments :: Eval.Phase + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically PostBuild + + +data Diagnostic = Diagnostic + { severity :: Severity + , file :: FilePath + , line :: Int + , col :: Int + , endLine :: Int + , endCol :: Int + , title :: Text + , text :: Text + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Diagnostic + + +data Severity = SError | SWarning + deriving stock (Eq, Ord, Show) + + +instance FromJSON Severity where + parseJSON = withText "Severity" \case + "error" -> pure SError + "warning" -> pure SWarning + other -> fail $ "unknown severity: " <> toString other + + +instance ToJSON Severity where + toJSON SError = "error" + toJSON SWarning = "warning" diff --git a/src/Tricorder/Build/Changes.hs b/src/Tricorder/Build/Changes.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Build/Changes.hs @@ -0,0 +1,19 @@ +module Tricorder.Build.Changes + ( ChangeKind (..) + , CabalChangeDetected (..) + , SourceChangeDetected (..) + ) where + +import Atelier.Effects.FileWatcher (FileEvent) + + +-- | Classifies what kind of file change triggered a dirty signal. +-- 'CabalChange' takes priority over 'SourceChange': if both fire before the +-- next build starts, the session will be fully restarted rather than reloaded. +data ChangeKind = SourceChange | CabalChange deriving stock (Eq, Ord, Show) + + +data CabalChangeDetected = CabalChangeDetected FilePath FileEvent + deriving stock (Eq, Show) +data SourceChangeDetected = SourceChangeDetected FilePath FileEvent + deriving stock (Eq, Show) diff --git a/src/Tricorder/Build/EvalComment.hs b/src/Tricorder/Build/EvalComment.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Build/EvalComment.hs @@ -0,0 +1,218 @@ +module Tricorder.Build.EvalComment + ( Phase (..) + , phasePending + , Comments (..) + , anyRunningComments + , Evaluation (..) + , Comment (..) + , findComments + , evalCommentP + , singleLineEvalCommentP + , multiLineEvalCommentP + , blockCommentEvalP + , State (..) + , JsonOutput (..) + ) where + +import Atelier.Types.QuietSnake (QuietSnake (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, (.:)) +import GHC.Generics (Generically (..)) +import Text.Megaparsec + ( MonadParsec (takeWhile1P, takeWhileP) + , Parsec + , SourcePos (..) + , anySingle + , eof + , getSourcePos + , manyTill + , parse + , try + , unPos + ) +import Text.Megaparsec.Char (char, hspace, space, string) + +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T + + +data Phase + = Looking + | Found Comments + | NoneFound + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Phase + + +phasePending :: Phase -> Bool +phasePending = \case + Looking -> True + NoneFound -> False + Found comments -> anyRunningComments comments + + +data Comments = Comments {getComments :: NonEmpty Evaluation} + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Comments + + +anyRunningComments :: Comments -> Bool +anyRunningComments = any ((== Pending) . (.state)) . (.getComments) + + +data Evaluation = Evaluation + { file :: FilePath + , comment :: Comment + , state :: State + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Evaluation + + +-- | An eval comment found in a source file: a @-- $> \@ annotation. +data Comment = Comment + { lineNumber :: Int + , expression :: Text + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Comment + + +-- | Scan source file content for eval comments. +-- Returns one 'Comment' per match, in source order. +findComments :: Text -> [Comment] +findComments content = + case parse fileP "" content of + Left _ -> [] + Right comments -> comments + where + fileP = catMaybes <$> manyTill lineP eof + lineP = hspace *> ((Just <$> try evalCommentP) <|> (Nothing <$ skipRestOfLine)) + skipRestOfLine = void $ takeWhileP Nothing (/= '\n') *> optional (char '\n') + + +evalCommentP :: Parser Comment +evalCommentP = singleLineEvalCommentP <|> multiLineEvalCommentP <|> blockCommentEvalP + + +-- | @-- $> \@ on a single line. +singleLineEvalCommentP :: Parser Comment +singleLineEvalCommentP = do + _ <- string "-- $>" + space + SourcePos {sourceLine} <- getSourcePos + expression <- takeWhile1P (Just "eval comment character") (/= '\n') + pure + Comment + { lineNumber = unPos sourceLine + , expression + } + + +-- | Multi-line line-comment block: +-- +-- @ +-- -- $$> +-- -- line one +-- -- line two +-- -- \<$$ +-- @ +-- +-- Each content line must start with @--@ (optionally followed by a space). +-- The leading @-- @ is stripped; relative indentation within the block is +-- preserved. +multiLineEvalCommentP :: Parser Comment +multiLineEvalCommentP = do + SourcePos {sourceLine} <- getSourcePos + _ <- string "-- $$>" + expression <- try multiLineExpr <|> inlineExpr + pure + Comment + { expression + , lineNumber = unPos sourceLine + } + where + multiLineExpr = do + _ <- optional (char '\n') + lineContents <- manyTill commentLineP (try (string "-- <$$")) + pure $ T.intercalate "\n" lineContents + inlineExpr = do + chars <- manyTill anySingle (string "<$$") + pure $ T.strip (toText chars) + commentLineP = do + _ <- string "--" + _ <- optional (char ' ') + content <- takeWhileP Nothing (/= '\n') + _ <- optional (char '\n') + pure content + + +-- | Block-comment eval: +-- +-- @ +-- {- $$> +-- expr +-- \<$$ -} +-- @ +-- +-- Content between the markers is stripped of leading\/trailing whitespace. +-- For multi-line expressions use the layout that GHCi expects; do not indent +-- the body relative to the opening @{- $>@ marker. +blockCommentEvalP :: Parser Comment +blockCommentEvalP = do + SourcePos {sourceLine} <- getSourcePos + _ <- string "{- $$>" + _ <- optional (char '\n') + chars <- manyTill anySingle (string "<$$ -}") + pure + Comment + { expression = T.strip (toText chars) + , lineNumber = unPos sourceLine + } + + +type Parser = Parsec Void Text + + +data State + = -- | The eval comment has yet to complete evaluation. + Pending + | -- | Combined stdout+stderr from GHCi, or an error message. + Completed Text + deriving stock (Eq, Generic, Show) + + +instance ToJSON State where + toJSON = \case + Pending -> + toJSON + $ KM.fromList + [ ("state", String "pending") + ] + Completed output -> + toJSON + $ KM.fromList + [ ("state", String "completed") + , ("output", String output) + ] + + +instance FromJSON State where + parseJSON = withObject "State" \o -> do + state :: Text <- o .: "state" + case state of + "pending" -> pure $ Pending + "completed" -> do + output <- o .: "output" + pure $ Completed output + _ -> fail "invalid 'state' property" + + +data JsonOutput + = Starting + | Building + | Failed Text + | Evaluating + | NoEvalCommentsFound + | Done Comments + deriving stock (Generic) + deriving (ToJSON) via QuietSnake JsonOutput diff --git a/src/Tricorder/Build/Test.hs b/src/Tricorder/Build/Test.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Build/Test.hs @@ -0,0 +1,111 @@ +module Tricorder.Build.Test + ( Suites (..) + , hasFailedTests + , suiteRuns + , anyRunningTests + , nullSuites + , Suite (..) + , isFailedRun + , Progress (..) + , Outcome (..) + , Case (..) + , caseFailed + , SuiteCompletion (..) + , SuiteError (..) + ) where + +import Atelier.Time (Millisecond) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generically (..)) + +import Data.Map.Strict qualified as Map + +import Tricorder.Session.TestTarget (TestTarget) + + +newtype Suites = Suites {getSuites :: Map TestTarget Suite} + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Suites + deriving (Monoid, Semigroup) via Map TestTarget Suite + + +hasFailedTests :: Suites -> Bool +hasFailedTests = any isFailedRun . suiteRuns + + +suiteRuns :: Suites -> [Suite] +suiteRuns = Map.elems . getSuites + + +anyRunningTests :: Suites -> Bool +anyRunningTests = + any + ( \case + SuiteRunning _ -> True + _ -> False + ) + . toList + . getSuites + + +nullSuites :: Suites -> Bool +nullSuites = Map.null . getSuites + + +data Suite + = SuiteRunning (Maybe Progress) + | SuiteErrored SuiteError + | SuiteCompleted SuiteCompletion + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Generically Suite) + + +isFailedRun :: Suite -> Bool +isFailedRun (SuiteCompleted c) = not c.passed +isFailedRun (SuiteErrored _) = True +isFailedRun (SuiteRunning _) = False + + +data Progress = Progress + { compiled :: Int + , total :: Int + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically Progress + + +data Outcome + = Passed + | Failed Text + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Generically Outcome) + + +data Case = Case + { description :: Text + , outcome :: Outcome + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Generically Case) + + +caseFailed :: Case -> Bool +caseFailed (Case _ (Failed _)) = True +caseFailed _ = False + + +newtype SuiteError = SuiteError + { message :: Text + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Generically SuiteError) + + +data SuiteCompletion = SuiteCompletion + { passed :: Bool + , output :: Text + , testCases :: [Case] + , duration :: Maybe Millisecond + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Generically SuiteCompletion) diff --git a/src/Tricorder/BuildState.hs b/src/Tricorder/BuildState.hs deleted file mode 100644 --- a/src/Tricorder/BuildState.hs +++ /dev/null @@ -1,238 +0,0 @@ --- | Shared wire-protocol vocabulary for the build system. --- --- Every type here is serialised (most via 'FromJSON' / 'ToJSON') and crosses --- module boundaries between the daemon, the socket layer, the CLI, the UI, --- and external clients. Components' /internal/ caches and bookkeeping (e.g. --- the Builder's per-cycle module map and diagnostic accumulator) do not --- belong here — they live next to the component that owns them. -module Tricorder.BuildState - ( BuildId (..) - , BuildState (..) - , BuildPhase (..) - , BuildProgress (..) - , BuildResult (..) - , TestRun (..) - , TestRunError (..) - , TestRunCompletion (..) - , TestCase (..) - , TestCaseOutcome (..) - , DaemonInfo (..) - , loadDaemonInfo - , runDaemonInfo - , Diagnostic (..) - , Severity (..) - , ChangeKind (..) - , initialBuildState - , stateLabel - , CabalChangeDetected (..) - , SourceChangeDetected (..) - ) where - -import Atelier.Effects.FileWatcher (FileEvent) -import Atelier.Effects.Input (Input, runInputEff) -import Atelier.Time (Millisecond) -import Data.Aeson (FromJSON (..), ToJSON (..), withText) -import Data.Time (UTCTime) -import Effectful.Reader.Static (Reader, ask) -import System.FilePath (makeRelative) - -import Tricorder.Effects.SessionStore (SessionStore) -import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..)) -import Tricorder.Session (Session (..), Target, WatchDirs (..)) - -import Tricorder.Effects.SessionStore qualified as SessionStore -import Tricorder.Observability qualified as Observability - - -newtype BuildId = BuildId Int - deriving stock (Eq, Show) - deriving newtype (FromJSON, ToJSON) - deriving (Num) via Int - - -data DaemonInfo = DaemonInfo - { targets :: [Target] - , watchDirs :: [FilePath] - , sockPath :: FilePath - , logFile :: FilePath - , metricsPort :: Maybe Int - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -loadDaemonInfo - :: ( Reader LogPath :> es - , Reader Observability.Config :> es - , Reader ProjectRoot :> es - , Reader SocketPath :> es - , SessionStore :> es - ) - => Eff es DaemonInfo -loadDaemonInfo = do - session <- SessionStore.get - obsCfg <- ask @Observability.Config - ProjectRoot projectRoot <- ask - SocketPath sockPath <- ask - LogPath logFile <- ask - pure - $ DaemonInfo - { targets = session.targets - , watchDirs = map (makeRelative projectRoot) session.watchDirs.getWatchDirs - , sockPath - , logFile - , metricsPort = if obsCfg.metrics.enabled then Just obsCfg.metrics.port else Nothing - } - - -runDaemonInfo - :: ( Reader LogPath :> es - , Reader Observability.Config :> es - , Reader ProjectRoot :> es - , Reader SocketPath :> es - , SessionStore :> es - ) - => Eff (Input DaemonInfo : es) a -> Eff es a -runDaemonInfo = runInputEff loadDaemonInfo - - -data TestCaseOutcome - = TestCasePassed - | TestCaseFailed Text - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data TestCase = TestCase - { description :: Text - , outcome :: TestCaseOutcome - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data TestRunError = TestRunError - { target :: Text - , message :: Text - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data TestRunCompletion = TestRunCompletion - { target :: Text - , passed :: Bool - , output :: Text - , testCases :: [TestCase] - , duration :: Maybe Millisecond - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data TestRun - = TestRunning Text (Maybe BuildProgress) - | TestRunErrored TestRunError - | TestRunCompleted TestRunCompletion - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data BuildResult = BuildResult - { completedAt :: UTCTime - , duration :: Millisecond - , moduleCount :: Int - , diagnostics :: [Diagnostic] - , testRuns :: [TestRun] - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data BuildProgress = BuildProgress - { compiled :: Int - , total :: Int - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data BuildPhase - = Building (Maybe BuildProgress) - | Restarting - | Testing BuildResult - | Done BuildResult - | BuildFailed Text - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data BuildState = BuildState - { buildId :: BuildId - , phase :: BuildPhase - , daemonInfo :: DaemonInfo - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data Diagnostic = Diagnostic - { severity :: Severity - , file :: FilePath - , line :: Int - , col :: Int - , endLine :: Int - , endCol :: Int - , title :: Text - , text :: Text - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) - - -data Severity = SError | SWarning - deriving stock (Eq, Ord, Show) - - -instance FromJSON Severity where - parseJSON = withText "Severity" \case - "error" -> pure SError - "warning" -> pure SWarning - other -> fail $ "unknown severity: " <> toString other - - -instance ToJSON Severity where - toJSON SError = "error" - toJSON SWarning = "warning" - - -stateLabel :: BuildPhase -> Text -stateLabel (Building _) = "building" -stateLabel Restarting = "restarting" -stateLabel (Testing _) = "testing" -stateLabel (Done result) - | any (\m -> m.severity == SError) result.diagnostics = "error" - | any (\m -> m.severity == SWarning) result.diagnostics = "warning" - | otherwise = "ok" -stateLabel (BuildFailed _) = "error" - - --- | Classifies what kind of file change triggered a dirty signal. --- 'CabalChange' takes priority over 'SourceChange': if both fire before the --- next build starts, the session will be fully restarted rather than reloaded. -data ChangeKind = SourceChange | CabalChange deriving stock (Eq, Ord, Show) - - -data CabalChangeDetected = CabalChangeDetected FilePath FileEvent - deriving stock (Eq, Show) -data SourceChangeDetected = SourceChangeDetected FilePath FileEvent - deriving stock (Eq, Show) - - -initialBuildState :: DaemonInfo -> BuildState -initialBuildState di = - BuildState - { buildId = BuildId 0 - , phase = Building Nothing - , daemonInfo = di - } diff --git a/src/Tricorder/Builder.hs b/src/Tricorder/Builder.hs deleted file mode 100644 --- a/src/Tricorder/Builder.hs +++ /dev/null @@ -1,675 +0,0 @@ -module Tricorder.Builder - ( component - , BuildConfig (..) - - -- * Internals exposed for testing - , NewLoadResult (..) - , EnteringNewPhase (..) - , compileLoadResultsIntoBuildResults - , requestTestRunsForNewBuildResults - , buildWithGhciOnChange - , interruptCurrent - , onRestart - , reloadOnSourceChange - , setNewPhase - , restartOnCabalChange - ) where - -import Atelier.Component (Component (..), defaultComponent) -import Atelier.Effects.Clock (Clock, UTCTime) -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.Debounce (Debounce, debounced) -import Atelier.Effects.Log (Log) -import Atelier.Effects.Publishing (Sub) -import Atelier.Time (Millisecond, nominalDiffTime) -import Control.Concurrent.STM (check, readTVar, retry, writeTVar) -import Data.Default (Default (..)) -import Data.Time (diffUTCTime) -import Effectful.Concurrent (Concurrent) -import Effectful.Concurrent.STM (atomically, newTVar) -import Effectful.Exception (finally, trySync) -import Effectful.Reader.Static (Reader, ask) -import Effectful.State.Static.Shared (State, get, modify, put, state) -import System.FilePath (normalise) - -import Atelier.Effects.Clock qualified as Clock -import Atelier.Effects.Conc qualified as Conc -import Atelier.Effects.Log qualified as Log -import Atelier.Effects.Publishing qualified as Sub -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set - -import Tricorder.BuildState - ( BuildId (..) - , BuildPhase (..) - , BuildResult (..) - , CabalChangeDetected (..) - , Diagnostic (..) - , Severity (..) - , SourceChangeDetected (..) - , TestRun (..) - ) -import Tricorder.Builder.Dispatch - ( BuilderState (..) - , DispatchAction (..) - , KnownTargetNames (..) - , dispatch - , emptyBuilderState - , filterToWatchDirs - , mergeDiagnostics - , preserveFailureVisibility - ) -import Tricorder.Effects.BuildStore (BuildStore) -import Tricorder.Effects.GhciSession (GhciSession, LoadResult (..)) -import Tricorder.Effects.GhciSession.GhciParser (resolveKnownTargets) -import Tricorder.Effects.GhciSession.GhciProcess (GhciProcessError (..)) -import Tricorder.Effects.SessionStore (SessionStore) -import Tricorder.Effects.TestRunner (TestRunner) -import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Command (..), Session (..), Target, TestTargets, WatchDirs, getTestTargets, renderTarget) - -import Tricorder.Effects.BuildStore qualified as BuildStore -import Tricorder.Effects.GhciSession qualified as GhciSession -import Tricorder.Effects.SessionStore qualified as SessionStore -import Tricorder.Effects.TestRunner qualified as TestRunner - - --- | Builder component. --- Starts a GHCi session, performs an initial load, then listens for changes --- from the watcher. -component - :: ( BuildStore :> es - , Clock :> es - , Conc :> es - , Concurrent :> es - , Debounce Text :> es - , GhciSession :> es - , Log :> es - , Reader ProjectRoot :> es - , SessionStore :> es - , State BuildId :> es - , State BuilderState :> es - , Sub CabalChangeDetected :> es - , Sub SourceChangeDetected :> es - , TestRunner :> es - ) - => Component es -component = - defaultComponent - { name = "Builder" - , listeners = pure [runBuilder defaultGhciSessionHooks] - } - - --- | A subset of 'Session' with just the properties that 'Builder' cares about. -data BuildConfig = BuildConfig - { command :: Command - , targets :: [Target] - , testTargets :: TestTargets - , watchDirs :: WatchDirs - } - deriving stock (Eq) - - -instance Default BuildConfig where - def = - BuildConfig - { command = session.command - , targets = session.targets - , testTargets = session.testTargets - , watchDirs = session.watchDirs - } - where - session = def @Session - - --------------------------------------------------------------------------------- --- Level 1 — Builder lifecycle: supervise the tricorder session --------------------------------------------------------------------------------- - --- | Level 1 — supervise the /tricorder session/ (the project config). For the --- current config, run successive GHCi sessions; whenever a @.cabal@ file --- changes, reload the config and restart everything. --- --- Cabal-change events flip a TVar; 'restartOnCabalChange' consumes the flag, --- runs @preRestart@ (transition to 'Restarting', reload the config), --- then exits the inner scope which cancels the in-flight GHCi session. The next --- iteration reloads the config via 'loadBuildConfig' and forks a fresh --- 'runGhciSessions'. -runBuilder - :: ( BuildStore :> es - , Clock :> es - , Conc :> es - , Concurrent :> es - , Debounce Text :> es - , GhciSession :> es - , Log :> es - , Reader ProjectRoot :> es - , SessionStore :> es - , State BuildId :> es - , State BuilderState :> es - , Sub CabalChangeDetected :> es - , Sub SourceChangeDetected :> es - , TestRunner :> es - ) - => GhciSessionHooks es - -> Eff es Void -runBuilder hooks = - restartOnCabalChange preRestart loadBuildConfig session - where - -- The tricorder session's restart hook: the outer loop reloading *its own* - -- config. This is not a GHCi-session concern, so it lives here rather than - -- in 'GhciSessionHooks'. - preRestart = do - -- Flip the UI to 'Restarting' immediately so the user sees the change - -- has been picked up before scope teardown (which kills cabal repl and - -- waits for graceful exit). - enterPhase Restarting - -- Pick up cabal/package.yaml edits before the next iteration. - SessionStore.rawReload - - session config = runGhciSessions hooks config `finally` onRestart - - --- | Read the current tricorder 'Session' and project the parts the Builder --- cares about. Runs at the start of each restart iteration. -loadBuildConfig - :: ( Log :> es - , SessionStore :> es - ) - => Eff es BuildConfig -loadBuildConfig = do - session <- SessionStore.get - let config = - BuildConfig - { command = session.command - , targets = session.targets - , testTargets = session.testTargets - , watchDirs = session.watchDirs - } - Log.info $ "Builder.component: resolved command = " <> coerce config.command - pure config - - -onRestart - :: ( BuildStore :> es - , Log :> es - , State BuildId :> es - ) - => Eff es () -onRestart = do - Log.info "Restarting builder..." - buildId <- get - modify @BuildId (+ 1) - setNewPhase $ EnteringNewPhase buildId $ Building Nothing - - --------------------------------------------------------------------------------- --- Level 2 — GHCi-session lifecycle --------------------------------------------------------------------------------- - --- | The lifecycle hooks for one /GHCi session/. Each field is one moment in a --- GHCi session's life; the coordinators below (@runGhciSessions@ / --- @watchSourceChanges@) own the /when/, these own the /what/. --- --- These are deliberately GHCi-session hooks only. Reloading the /tricorder --- session/ (the project config) on a @.cabal@ change belongs to the outer loop --- and lives inline in 'runBuilder' — keeping it out of here is what stops a --- \"child restarting its parent\". Tests supply their own record to observe a --- single hook in isolation. -data GhciSessionHooks es = GhciSessionHooks - { onStart :: Eff es () - -- ^ A fresh GHCi session is about to launch: reset accumulated state. - , onInitialLoad :: BuildConfig -> NewLoadResult -> Eff es () - -- ^ The initial load finished: run the post-load pipeline. - , onSourceChange :: BuildConfig -> GhciSession.Controls (Eff es) -> SourceChangeDetected -> Eff es () - -- ^ A debounced source change arrived: run one build/test cycle. - , onStartupFail :: SomeException -> Eff es () - -- ^ GHCi failed to start: surface 'BuildFailed' and wait to retry. - } - - --- | The default GHCi-session hooks. -defaultGhciSessionHooks - :: ( BuildStore :> es - , Clock :> es - , Log :> es - , Reader ProjectRoot :> es - , State BuildId :> es - , State BuilderState :> es - , Sub SourceChangeDetected :> es - , TestRunner :> es - ) - => GhciSessionHooks es -defaultGhciSessionHooks = - GhciSessionHooks - { onStart = put emptyBuilderState - , onInitialLoad = afterLoad - , onSourceChange = reloadOnSourceChange - , onStartupFail = recoverFromStartupFailure - } - - --- | Level 2 — run successive /GHCi sessions/ for one tricorder session, each --- retried on startup failure. Reads top-to-bottom as a GHCi session's phases: --- --- 1. 'onStart' — reset accumulated state. --- 2. launch GHCi; on its initial load, 'onInitialLoad' runs the pipeline. --- 3. 'watchSourceChanges' — the inner loop, until the session is torn down. --- 4. 'onStartupFail' — if the launch itself threw, recover and retry. -runGhciSessions - :: ( BuildStore :> es - , Clock :> es - , Conc :> es - , Concurrent :> es - , Debounce Text :> es - , GhciSession :> es - , Log :> es - , Reader ProjectRoot :> es - , State BuildId :> es - , State BuilderState :> es - , Sub SourceChangeDetected :> es - , TestRunner :> es - ) - => GhciSessionHooks es - -> BuildConfig - -> Eff es Void -runGhciSessions hooks config = forever do - hooks.onStart - root@(ProjectRoot rootPath) <- ask - BuildId n <- get - Log.info $ "Starting GHCi session #" <> show n <> ": " <> coerce config.command - - startTime <- Clock.currentTime - result <- trySync $ GhciSession.withGhci config.command root \initialLoad controls -> do - endTime <- Clock.currentTime - let filteredMsgs = filterToWatchDirs rootPath config.watchDirs initialLoad.diagnostics - Log.info - $ mconcat - ["GHCi started (session #", show n, "): ", show (length filteredMsgs), " diagnostics"] - hooks.onInitialLoad config NewLoadResult {startTime, endTime, loadResult = initialLoad} - modify \s -> - s - { loadedModules = resolveKnownTargets Map.empty initialLoad - , knownTargets = KnownTargetNames (Set.fromList initialLoad.targetNames) - } - watchSourceChanges hooks config controls - case result of - Right _ -> pure () - Left ex -> hooks.onStartupFail ex - - --- | The GHCi-session loop with the default 'defaultGhciSessionHooks'. Kept as a --- named entry point for tests; 'runBuilder' wraps this with the tricorder --- session's cabal-restart handling. -buildWithGhciOnChange - :: ( BuildStore :> es - , Clock :> es - , Conc :> es - , Concurrent :> es - , Debounce Text :> es - , GhciSession :> es - , Log :> es - , Reader ProjectRoot :> es - , State BuildId :> es - , State BuilderState :> es - , Sub SourceChangeDetected :> es - , TestRunner :> es - ) - => BuildConfig - -> Eff es Void -buildWithGhciOnChange = runGhciSessions defaultGhciSessionHooks - - --- | Default 'onStartupFail': surface 'BuildFailed', then wait for a source --- change to retry the launch. --- --- A cabal change is handled out-of-band by 'runBuilder' cancelling this scope. --- Without the wait, a startup failure was a dead end: the user could fix the --- offending source file and nothing would happen, because no --- 'SourceChangeDetected' listener is active on this path. -recoverFromStartupFailure - :: ( BuildStore :> es - , Log :> es - , State BuildId :> es - , Sub SourceChangeDetected :> es - ) - => SomeException -> Eff es () -recoverFromStartupFailure ex = do - Log.err $ "GHCi session failed to start: " <> show ex - enterPhase $ BuildFailed $ renderStartupError ex - Log.info "Build command failed; waiting for a source change to retry" - void $ Sub.listenOnce_ @SourceChangeDetected - - --------------------------------------------------------------------------------- --- Level 3 — Source-change loop and build/test cycle --------------------------------------------------------------------------------- - --- | Level 3 — the inner loop. Wait for source changes and drive one build/test --- cycle ('onSourceChange') per change. --- --- Coalesce debounced source-change events through a single-slot register: the --- debounced listener writes the latest event into the slot, and a single worker --- fork drains it. Events that arrive while the worker is processing the previous --- one simply overwrite the slot, so a burst of N touches collapses into exactly --- one trailing cycle (carrying the most recent event) rather than queueing N --- back-to-back cycles. This matters whenever 'interruptCurrent' can't drop the --- in-flight cycle promptly — e.g. when a 'status --wait' caller has registered --- as a waiter, gating 'interruptCurrent' to a no-op. -watchSourceChanges - :: ( BuildStore :> es - , Conc :> es - , Concurrent :> es - , Debounce Text :> es - , Log :> es - , State BuildId :> es - , Sub SourceChangeDetected :> es - , TestRunner :> es - ) - => GhciSessionHooks es - -> BuildConfig - -> GhciSession.Controls (Eff es) - -> Eff es Void -watchSourceChanges hooks config controls = Conc.scoped do - BuildId n <- get - Log.debug $ "Builder: waiting for dirty flag (build #" <> show n <> ")" - forever $ Conc.scoped do - pending <- atomically (newTVar @(Maybe SourceChangeDetected) Nothing) - Conc.fork_ $ Sub.listen_ \ev -> - debounced 200 "source_change_reloader" - $ atomically (writeTVar pending (Just ev)) - Conc.fork_ $ Sub.listen_ \_ -> interruptCurrent controls - Conc.fork_ $ forever do - ev <- atomically do - readTVar pending >>= \case - Nothing -> retry - Just e -> writeTVar pending Nothing >> pure e - hooks.onSourceChange config controls ev - Conc.awaitAll - - --- 'controls.interrupt' is a safe no-op when GHCi is idle, and 'GhciSession' --- serialises subsequent reloads through its own STM state. -interruptCurrent - :: ( BuildStore :> es - , Log :> es - , TestRunner :> es - ) - => GhciSession.Controls (Eff es) -> Eff es () -interruptCurrent controls = do - hasWaiters <- BuildStore.hasWaiters - unless hasWaiters do - Log.info "Change detected with no waiters. Interrupting current build/tests." - controls.interrupt - TestRunner.interruptCurrent - - -reloadOnSourceChange - :: ( BuildStore :> es - , Clock :> es - , Log :> es - , Reader ProjectRoot :> es - , State BuildId :> es - , State BuilderState :> es - , TestRunner :> es - ) - => BuildConfig - -> GhciSession.Controls (Eff es) - -> SourceChangeDetected - -> Eff es () -reloadOnSourceChange config controls (SourceChangeDetected fp event) = do - Log.debug $ "Builder: source change detected " <> show event <> " " <> toText fp - builderState <- get @BuilderState - let known = Map.lookup (normalise fp) builderState.loadedModules - case dispatch builderState.knownTargets known fp event of - Nothing -> - Log.debug - $ "Builder: no-op for " - <> show event - <> " of file not loaded in GHCi: " - <> toText fp - Just action -> do - enterPhase $ Building Nothing - - res <- trySync do - startTime <- Clock.currentTime - res <- runAction controls action - endTime <- Clock.currentTime - pure (startTime, endTime, res) - - case res of - Left e -> do - now <- Clock.currentTime - Log.err $ show now <> " Reload errored: " <> show e - -- Resolve the UI instead of stranding it in 'Building': a - -- reload that errors (rather than producing a result) must - -- not leave the daemon stuck until the next source change - -- happens to arrive and succeed. - enterPhase $ BuildFailed $ "Reload failed: " <> toText (displayException e) - Right (startTime, endTime, loadResult) -> do - modify \s -> - s - { loadedModules = resolveKnownTargets s.loadedModules loadResult - , knownTargets = KnownTargetNames (Set.fromList loadResult.targetNames) - } - afterLoad config NewLoadResult {startTime, endTime, loadResult} - - -runAction :: GhciSession.Controls (Eff es) -> DispatchAction -> Eff es LoadResult -runAction controls = \case - Reload -> controls.reload - Add fp -> controls.add fp - Unadd mn -> controls.unadd mn - - --- | Run the post-load pipeline synchronously: compile diagnostics into a --- 'BuildResult', then (optionally) run tests and transition through the --- corresponding phases. -afterLoad - :: ( BuildStore :> es - , Log :> es - , Reader ProjectRoot :> es - , State BuildId :> es - , State BuilderState :> es - , TestRunner :> es - ) - => BuildConfig -> NewLoadResult -> Eff es () -afterLoad config newLoadResult = do - buildResult <- compileLoadResultsIntoBuildResults config newLoadResult - requestTestRunsForNewBuildResults config buildResult - - -compileLoadResultsIntoBuildResults - :: ( Reader ProjectRoot :> es - , State BuilderState :> es - ) - => BuildConfig - -> NewLoadResult - -> Eff es BuildResult -compileLoadResultsIntoBuildResults session newLoadResult = do - ProjectRoot projectRoot <- ask - let filteredResult = - loadResult - { GhciSession.diagnostics = - preserveFailureVisibility loadResult.diagnostics - $ filterToWatchDirs projectRoot watchDirs loadResult.diagnostics - } - - newAccumulated <- state \s -> - let merged = mergeDiagnostics s.diagnosticMap filteredResult - in (merged, s {diagnosticMap = merged}) - - pure - BuildResult - { completedAt = endTime - , duration = nominalDiffTime (diffUTCTime endTime startTime) :: Millisecond - , moduleCount = loadResult.moduleCount - , diagnostics = sortOn (\d -> (d.severity, d.file, d.line, d.col)) $ concat (Map.elems newAccumulated) - , testRuns = [] - } - where - BuildConfig {watchDirs} = session - NewLoadResult {startTime, endTime, loadResult} = newLoadResult - - -requestTestRunsForNewBuildResults - :: ( BuildStore :> es - , Log :> es - , State BuildId :> es - , TestRunner :> es - ) - => BuildConfig - -> BuildResult - -> Eff es () -requestTestRunsForNewBuildResults config partialResult = do - buildId <- get - runTestsIfClean config buildId partialResult >>= \case - Nothing -> Log.info "Test run aborted by source change; skipping Done transition." - Just testRuns -> - setNewPhase $ EnteringNewPhase buildId $ Done partialResult {testRuns} - - --- Run all configured test suites if the build has no errors. --- Transitions to 'Testing' phase while suites are running. --- --- Returns 'Nothing' if the run was aborted mid-flight by a source change --- (the caller should not transition to a Done phase in that case). Returns --- 'Just' with the collected results otherwise. -runTestsIfClean - :: ( BuildStore :> es - , Log :> es - , TestRunner :> es - ) - => BuildConfig - -> BuildId - -> BuildResult - -> Eff es (Maybe [TestRun]) -runTestsIfClean (BuildConfig {testTargets}) bid partialResult - | null targetNames || any (\d -> d.severity == SError) partialResult.diagnostics = pure (Just []) - | otherwise = do - TestRunner.resetAbort - setNewPhase - $ EnteringNewPhase bid - $ Testing partialResult {testRuns = map (`TestRunning` Nothing) targetNames} - - Log.info $ "Running " <> show (length targetNames) <> " test suite(s)" - - let initial = (\t -> (t, TestRunning t Nothing)) <$> targetNames - runLoop initial targetNames - where - -- The runner consumes the @test:@ targets as cabal/ghci arguments, so - -- render the structured targets to their textual form at this boundary. - targetNames = map renderTarget testTargets.getTestTargets - runLoop acc [] = pure (Just (snd <$> acc)) - runLoop acc (target : rest) = do - Log.info $ "Running tests: " <> target - result <- TestRunner.runTestSuite target - aborted <- TestRunner.isAborted - if aborted then - pure Nothing - else do - let acc' = insert target result acc - setNewPhase - $ EnteringNewPhase bid - $ Testing partialResult {testRuns = snd <$> acc'} - runLoop acc' rest - - insert _ _ [] = [] - insert k v ((k', v') : xs) - | k == k' = (k, v) : xs - | otherwise = (k', v') : insert k v xs - - --------------------------------------------------------------------------------- --- Restart machinery --------------------------------------------------------------------------------- - --- | Run @action@ in a loop that restarts whenever a 'CabalChangeDetected' --- event arrives. At most one iteration of @action@ runs at any moment: cabal --- events arriving during a restart collapse into a single next iteration. --- --- A TVar flag funnels the events: the cabal listener writes 'True' to it; a --- single coordinator drains it via 'restartableForkWith', runs @preRestart@, --- and exits the inner scope. Scope teardown cancels the current @action@ --- (including the 'cabal repl' subprocess via its bracket) and waits for it to --- finish before the next iteration starts — so we never have two builders --- racing for the same dist-newstyle directory. -restartOnCabalChange - :: ( Conc :> es - , Concurrent :> es - , Log :> es - , Sub CabalChangeDetected :> es - ) - => Eff es () - -- ^ Pre-restart hook: runs in the coordinator thread after the flag has - -- been drained but before the inner scope is torn down. Use this to set - -- the UI to 'Restarting' and reload the session. - -> Eff es r - -- ^ Setup: runs at the start of each iteration, before @action@ is forked. - -> (r -> Eff es Void) - -- ^ Inner action. Must never return. - -> Eff es Void -restartOnCabalChange preRestart setup action = do - needsRestart <- atomically (newTVar False) - Conc.scoped do - Conc.fork_ $ Conc.restartableForkWith (signal needsRestart) setup action - Sub.listen_ @CabalChangeDetected $ \(CabalChangeDetected path event) -> do - Log.info $ "Cabal file changed (" <> show event <> " " <> toText path <> "); queued restart" - atomically (writeTVar needsRestart True) - where - signal needsRestart = do - atomically do - check =<< readTVar needsRestart - writeTVar needsRestart False - preRestart - - --------------------------------------------------------------------------------- --- Phase-transition helpers --------------------------------------------------------------------------------- - -setNewPhase - :: (BuildStore :> es) - => EnteringNewPhase -> Eff es () -setNewPhase (EnteringNewPhase bid phase) = - BuildStore.setPhase bid phase - - --- | Transition the /current/ build into @phase@. -enterPhase - :: ( BuildStore :> es - , State BuildId :> es - ) - => BuildPhase -> Eff es () -enterPhase phase = do - buildId <- get - setNewPhase $ EnteringNewPhase buildId phase - - -renderStartupError :: SomeException -> Text -renderStartupError ex = case fromException ex of - Just (StartupFailed msg) -> msg - Just StartupTimeout -> "Build command did not produce a GHCi banner before timing out." - Just (UnexpectedExit cmd lastLine) -> - "Build command exited unexpectedly: " - <> cmd - <> maybe "" (\l -> "\n" <> l) lastLine - Nothing -> toText (displayException ex) - - --------------------------------------------------------------------------------- --- Supporting types --------------------------------------------------------------------------------- - -data NewLoadResult = NewLoadResult - { startTime :: UTCTime - , endTime :: UTCTime - , loadResult :: LoadResult - } - deriving stock (Eq, Show) - - --- | A pending phase transition. Carried by 'setNewPhase' into the 'BuildStore'. -data EnteringNewPhase = EnteringNewPhase BuildId BuildPhase - deriving stock (Eq, Show) diff --git a/src/Tricorder/Builder/Dispatch.hs b/src/Tricorder/Builder/Dispatch.hs deleted file mode 100644 --- a/src/Tricorder/Builder/Dispatch.hs +++ /dev/null @@ -1,199 +0,0 @@ -module Tricorder.Builder.Dispatch - ( BuilderState (..) - , DiagnosticMap - , DispatchAction (..) - , KnownTargetNames (..) - , dispatch - , emptyBuilderState - , fileMatchesAnyTarget - , filterToWatchDirs - , mergeDiagnostics - , preserveFailureVisibility - ) where - -import Atelier.Effects.FileWatcher (FileEvent (..)) -import Data.Default (Default (..)) -import System.FilePath (isAbsolute, normalise, splitDirectories, takeExtension, ()) - -import Data.List qualified as List -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set - -import Tricorder.BuildState (Diagnostic (..), Severity (..)) -import Tricorder.Effects.GhciSession (LoadResult (..), LoadedModule (..)) -import Tricorder.Effects.GhciSession.GhciParser - ( isLocationLess - , pathSuffixesAsModuleName - , unattributedFailure - ) -import Tricorder.Session (WatchDirs (..)) - - --- | The Builder's per-GHCi-session cache: what it last saw from GHCi plus its --- accumulated diagnostics. Reset on every GHCi restart in --- @buildWithGhciOnChange@; 'BuildId' is intentionally /not/ here because it --- counts across restarts. -data BuilderState = BuilderState - { loadedModules :: Map FilePath LoadedModule - , knownTargets :: KnownTargetNames - , diagnosticMap :: DiagnosticMap - } - deriving stock (Eq, Show) - - -instance Default BuilderState where - def = emptyBuilderState - - -emptyBuilderState :: BuilderState -emptyBuilderState = - BuilderState - { loadedModules = mempty - , knownTargets = KnownTargetNames mempty - , diagnosticMap = mempty - } - - -type DiagnosticMap = Map FilePath [Diagnostic] - - --- | Merge a new 'LoadResult' into the accumulated per-file diagnostic map. --- --- Files in 'compiledFiles' have their previous diagnostics cleared and replaced --- by any new diagnostics produced for them in this cycle. Files absent from --- 'compiledFiles' were skipped by incremental compilation and retain their --- previous diagnostics unchanged. --- --- Location-less diagnostics (see 'isLocationLess') are never keyed to a real --- source file, so they would never appear in 'compiledFiles' and would persist --- forever once raised. They describe the current load's outcome, so we clear --- them every cycle and let this cycle's 'diagnostics' re-add them if the --- failure is still present. -mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap -mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} = - let retained = Map.filterWithKey (\f _ -> not (isLocationLess f)) prev - cleared = foldr Map.delete retained compiledFiles - newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics] - in Map.union newByFile cleared - - --- | GHCi's current target set, as raw entries from @:show targets@ --- (typically dotted module names under @cabal repl --enable-multi-repl@). --- Survives every compile failure mode, so the dispatcher can recognise a --- target even when it's absent from the path-keyed module map. -newtype KnownTargetNames = KnownTargetNames {unKnownTargetNames :: Set Text} - deriving stock (Eq, Show) - - --- | Whether a file path corresponds to one of GHCi's targets. --- --- @:show targets@ entries are either dotted module names (e.g. --- @Tricorder.CLI.Main@) or file paths (e.g. @app/Main.hs@). GHCi uses the path --- form when a module name is ambiguous across home units — i.e. every --- executable/test 'Main'. We match both forms. --- --- The path form matters because a /failed/ executable 'Main' drops out of --- @:show modules@ but survives in @:show targets@ as its path. Without matching --- it, fixing the executable would dispatch a no-op 'Add' instead of a 'Reload', --- leaving the diagnostic stale. -fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool -fileMatchesAnyTarget (KnownTargetNames targets) fp = - any (`Set.member` targets) (pathSuffixesAsModuleName fp) - || any (pathTargetMatches fp . toString) (Set.toList targets) - - --- | Whether a path-shaped @:show targets@ entry refers to the given file, --- compared on directory-segment boundaries (so @app/Main.hs@ matches --- @./tricorder/app/Main.hs@ but @pp/Main.hs@ does not). Module-name targets --- (no @.hs@ extension) are left to the module-name branch above. -pathTargetMatches :: FilePath -> FilePath -> Bool -pathTargetMatches file target = - takeExtension target == ".hs" - && splitDirectories (normalise target) `List.isSuffixOf` splitDirectories (normalise file) - - --- | A GHCi command to issue in response to a source file change. -data DispatchAction - = Reload - | Add FilePath - | Unadd Text - deriving stock (Eq, Show) - - --- | Decide what GHCi action a source-file change requires. --- --- The path-keyed module map misses targets that failed on first load, --- so we fall back to 'KnownTargetNames' for those — otherwise we would --- issue @:add@ (a no-op for an already-tracked cabal target), leaving --- stale diagnostics in place. -dispatch - :: KnownTargetNames - -> Maybe LoadedModule - -> FilePath - -> FileEvent - -> Maybe DispatchAction -dispatch knownTargets known fp event = case known of - Just lm -> Just $ case event of - Added -> Reload - Modified -> Reload - Removed -> Unadd lm.moduleName - Nothing - | fileMatchesAnyTarget knownTargets fp -> case event of - Added -> Just Reload - Modified -> Just Reload - Removed -> Nothing - | otherwise -> case event of - Added -> Just (Add fp) - Modified -> Just (Add fp) - Removed -> Nothing - - --- | Keep only diagnostics whose file is under one of the watched directories. --- --- Diagnostics from outside the project (e.g. @.h@ files in the Nix store) and --- those with mangled filenames produced by the C preprocessor (e.g. --- @"In file included from ..."@) are dropped here, before they can enter the --- accumulation map where they would be impossible to evict. --- --- Location-less diagnostics (see 'isLocationLess') are always kept: they carry --- no path to test against a watch dir, but they represent genuine build-level --- failures (e.g. a home-unit GHC plugin that can't load under --- @--enable-multi-repl@) that must not be dropped, or the build would silently --- read as clean. -filterToWatchDirs :: FilePath -> WatchDirs -> [Diagnostic] -> [Diagnostic] -filterToWatchDirs _ (WatchDirs []) diags = diags -filterToWatchDirs projectRoot (WatchDirs watchDirs) diags = - filter (\d -> isLocationLess d.file || isUnderAnyWatchDir d.file) diags - where - absWatchDirs = map toAbsWd watchDirs - toAbsWd wd - | wd == "." = projectRoot - | isAbsolute wd = wd - | otherwise = projectRoot wd - isUnderAnyWatchDir file - | not (isAbsolute file) && not ("./" `isPrefixOf` file) = False - | isAbsolute file = - any (\wd -> (wd ++ "/") `isPrefixOf` file || wd == file) absWatchDirs - | otherwise = - let absFile = projectRoot drop 2 file - in any (\wd -> (wd ++ "/") `isPrefixOf` absFile || wd == absFile) absWatchDirs - - --- | Keep a failed build from ever reading as clean after watch-dir filtering. --- --- 'filterToWatchDirs' drops diagnostics outside the watched directories. If a --- load failed but every error it produced lay outside those dirs (e.g. a --- compile error in a sibling home unit not under @watchDirs@), filtering would --- leave no diagnostics and the broken build would look green. Detecting that an --- error was present /before/ filtering but none survived, we re-attach the --- location-less synthetic failure (which filtering always keeps) so the failure --- still surfaces. --- --- Takes the pre-filter diagnostics and the post-filter diagnostics; returns the --- post-filter list, with the synthetic failure appended only when needed. -preserveFailureVisibility :: [Diagnostic] -> [Diagnostic] -> [Diagnostic] -preserveFailureVisibility raw filtered - | any isError raw && not (any isError filtered) = filtered ++ [unattributedFailure] - | otherwise = filtered - where - isError d = d.severity == SError diff --git a/src/Tricorder/CLI.hs b/src/Tricorder/CLI.hs deleted file mode 100644 --- a/src/Tricorder/CLI.hs +++ /dev/null @@ -1,281 +0,0 @@ -module Tricorder.CLI - ( showLog - , showSource - , showStatus - , showTests - ) where - -import Atelier.Effects.Clock (Clock, currentTimeZone) -import Atelier.Effects.Console (Console) -import Atelier.Effects.Delay (Delay) -import Atelier.Effects.Exit (Exit, exitFailure) -import Atelier.Effects.File (File) -import Atelier.Effects.FileSystem (FileSystem, doesFileExist, followFile, readFileLbs) -import Data.Aeson (encode) -import Data.Time.Format (defaultTimeLocale, formatTime) -import Data.Time.LocalTime (utcToLocalTime) -import Effectful.Reader.Static (Reader, ask) - -import Atelier.Effects.Console qualified as Console -import Data.ByteString.Lazy qualified as BSL -import Data.Text qualified as T - -import Tricorder.Arguments - ( FollowMode (..) - , OutputFormat (..) - , StatusOptions (..) - , TestOptions (..) - , Verbosity (..) - , WaitMode (..) - ) -import Tricorder.BuildState - ( BuildPhase (..) - , BuildProgress (..) - , BuildResult (..) - , BuildState (..) - , Diagnostic (..) - , Severity (..) - , TestCase (..) - , TestCaseOutcome (..) - , TestRun (..) - , TestRunCompletion (..) - , TestRunError (..) - ) -import Tricorder.CLI.Render - ( diagnosticLineIndexed - , formatDuration - , renderSourceResults - ) -import Tricorder.Effects.UnixSocket (UnixSocket) -import Tricorder.GhcPkg.Types (SourceQuery) -import Tricorder.Runtime (SocketPath (..)) -import Tricorder.Socket.Client - ( querySource - , queryStatus - , queryStatusWait - ) -import Tricorder.TestOutput (stripGhciNoise) - - --- | Print a build-command failure message and exit non-zero. -reportBuildFailed :: (Console :> es, Exit :> es) => Text -> Eff es a -reportBuildFailed msg = do - Console.putTextLn "Build command failed:" - Console.putTextLn msg - exitFailure - - -showStatus - :: ( Clock :> es - , Console :> es - , Exit :> es - , File :> es - , Reader SocketPath :> es - , UnixSocket :> es - ) - => StatusOptions -> Eff es () -showStatus opts = do - SocketPath sockPath <- ask - when (opts.wait == WaitForBuild && opts.format == TextOutput) $ do - current <- queryStatus sockPath - case current of - Right BuildState {phase = Building _} -> Console.putStrLn "Building..." - Right BuildState {phase = Restarting} -> Console.putStrLn "Restarting..." - Right BuildState {phase = Testing _} -> Console.putStrLn "Testing..." - _ -> pure () - result <- - case opts.wait of - WaitForBuild -> queryStatusWait sockPath - ShowCurrent -> queryStatus sockPath - case result of - Left err -> Console.putTextLn $ "Error: " <> err - Right state -> - case opts.format of - JsonOutput -> do - Console.putStr $ BSL.toStrict $ encode state - Console.putStrLn "" - TextOutput -> - renderText opts.verbosity opts.expand state - where - renderText verbosity expand state = case state.phase of - Building _ -> Console.putStrLn "Building..." - Restarting -> Console.putStrLn "Restarting..." - Testing _ -> Console.putStrLn "Testing..." - BuildFailed msg -> reportBuildFailed msg - Done r -> do - tz <- currentTimeZone - case expand of - Just n -> - case r.diagnostics !!? (n - 1) of - Nothing -> - Console.putTextLn - $ "No diagnostic #" - <> show n - <> " (current build has " - <> show (length r.diagnostics) - <> ")" - Just d -> do - Console.putTextLn $ diagnosticLineIndexed n d - Console.putText d.text - Nothing -> do - let printDiag (i, d) = case verbosity of - Verbose -> do - Console.putTextLn $ diagnosticLineIndexed i d - Console.putText d.text - Concise -> - Console.putTextLn $ diagnosticLineIndexed i d - mapM_ printDiag (zip [1 ..] r.diagnostics) - Console.putTextLn $ buildSummary tz r - mapM_ (printTestRun verbosity) r.testRuns - when (buildHasErrors r || testsFailed r) exitFailure - - printTestRun verbosity tr = do - Console.putTextLn $ case tr of - TestRunning t Nothing -> t <> " running..." - TestRunning t (Just p) -> t <> " running... (" <> show p.compiled <> "/" <> show p.total <> ")" - TestRunErrored e -> e.target <> " error: " <> e.message - TestRunCompleted c -> c.target <> " " <> completionSummary c - when (verbosity == Verbose) $ case tr of - TestRunCompleted c -> - mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (T.lines c.output)) - _ -> pure () - - buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics - testsFailed r = any isFailedRun r.testRuns - where - isFailedRun (TestRunCompleted c) = not c.passed - isFailedRun (TestRunErrored _) = True - isFailedRun (TestRunning _ _) = False - - buildSummary tz r = - let errs = length $ filter ((== SError) . (.severity)) r.diagnostics - warns = length $ filter ((== SWarning) . (.severity)) r.diagnostics - ts = toText $ "— " <> formatTime defaultTimeLocale "%H:%M:%S" (utcToLocalTime tz r.completedAt) - stats = toText $ "(" <> show r.moduleCount <> " modules, " <> formatDuration r.duration <> ")" - in if null r.diagnostics then - "All good. " <> stats <> " " <> ts - else - show errs <> " error(s), " <> show warns <> " warning(s) " <> stats <> " " <> ts - - -completionSummary :: TestRunCompletion -> Text -completionSummary c = statusText <> maybe "" (\d -> " (" <> formatDuration d <> ")") c.duration - where - statusText - | null c.testCases = if c.passed then "passed" else "failed" - | otherwise = - let total = length c.testCases - failedCount = length $ filter isFailedCase c.testCases - in if failedCount == 0 then - "passed (" <> show total <> ")" - else - show failedCount <> "/" <> show total <> " failed" - isFailedCase (TestCase _ (TestCaseFailed _)) = True - isFailedCase _ = False - - -showLog - :: ( Console :> es - , Delay :> es - , FileSystem :> es - ) - => FilePath -> FollowMode -> Eff es () -showLog path followMode = do - exists <- doesFileExist path - if not exists then - Console.putTextLn $ "Log file does not exist yet: " <> toText path - else case followMode of - Follow -> followFile path Console.putStr - NoFollow -> readFileLbs path >>= Console.putStr . BSL.toStrict - - -showTests - :: ( Console :> es - , Exit :> es - , File :> es - , Reader SocketPath :> es - , UnixSocket :> es - ) - => TestOptions -> Eff es () -showTests opts = do - SocketPath sockPath <- ask - result <- - case opts.wait of - WaitForBuild -> queryStatusWait sockPath - ShowCurrent -> queryStatus sockPath - case result of - Left err -> Console.putTextLn $ "Error: " <> err - Right state -> - case state.phase of - Building _ -> Console.putStrLn "Build in progress, no test results yet." - Restarting -> Console.putStrLn "Daemon restarting, no test results yet." - Testing r -> renderTestRuns r.testRuns - Done r -> renderTestRuns r.testRuns - BuildFailed msg -> reportBuildFailed msg - where - renderTestRuns [] = Console.putStrLn "No test results." - renderTestRuns testRuns - | null runs = do - Console.putStrLn "All passed." - mapM_ (Console.putTextLn . (" " <>) . testRunTarget) testRuns - | otherwise = do - mapM_ printTestOutput runs - when (any isFailed runs) exitFailure - where - runs = - if opts.failedOnly then - filter isFailed testRuns - else - testRuns - - isFailed (TestRunCompleted c) = not c.passed - isFailed (TestRunErrored _) = True - isFailed (TestRunning _ _) = False - - testRunTarget (TestRunning t _) = t - testRunTarget (TestRunErrored e) = e.target - testRunTarget (TestRunCompleted c) = c.target - - printTestOutput tr = case tr of - TestRunning t Nothing -> - Console.putTextLn $ t <> " running..." - TestRunning t (Just p) -> - Console.putTextLn $ t <> " running... (" <> show p.compiled <> "/" <> show p.total <> ")" - TestRunErrored e -> - Console.putTextLn $ e.target <> " error: " <> e.message - TestRunCompleted c -> do - Console.putTextLn $ c.target <> " " <> completionSummary c - if opts.failedOnly then - if null c.testCases then do - Console.putTextLn " (unrecognised test runner format — showing full output)" - mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (lines c.output)) - else - mapM_ printFailedCase (filter isCaseFailed c.testCases) - else - mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (lines c.output)) - - isCaseFailed (TestCase _ (TestCaseFailed _)) = True - isCaseFailed _ = False - - printFailedCase tc = do - Console.putTextLn $ " " <> tc.description - case tc.outcome of - TestCaseFailed details -> - mapM_ (Console.putTextLn . (" " <>)) (T.lines details) - TestCasePassed -> pure () - - -showSource - :: ( Console :> es - , File :> es - , Reader SocketPath :> es - , UnixSocket :> es - ) - => [SourceQuery] - -> Eff es () -showSource queries = do - SocketPath sockPath <- ask - result <- querySource sockPath queries - case result of - Left err -> Console.putTextLn $ "Error: " <> err - Right results -> renderSourceResults results diff --git a/src/Tricorder/CLI/App.hs b/src/Tricorder/CLI/App.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/App.hs @@ -0,0 +1,141 @@ +module Tricorder.CLI.App (run) where + +import Atelier.Effects.Clock (Clock) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Console (Console) +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.Exit (Exit) +import Atelier.Effects.File (File) +import Atelier.Effects.FileSystem (FileSystem) +import Atelier.Effects.Posix.Daemons (Daemons) +import Atelier.Effects.Process (Process) +import Atelier.Effects.Timeout (Timeout) +import Effectful (IOE) +import Effectful.Concurrent (Concurrent) +import Effectful.Reader.Static (Reader, ask, asks) +import Prelude hiding (force) + +import Atelier.Effects.Console qualified as Console +import Data.Text qualified as T + +import Tricorder.Build (BuildState (..)) +import Tricorder.CLI.Arguments (Command (..), LogMode (..)) +import Tricorder.CLI.Daemon + ( restartDaemon + , startDaemon + , stopDaemon + , waitForDaemon + ) +import Tricorder.CLI.Operations + ( showEvalComments + , showLog + , showSource + , showStatus + , showTests + ) +import Tricorder.CLI.UI (viewUi) +import Tricorder.CLI.UI.Brick (Brick) +import Tricorder.CLI.UI.BrickChan (BrickChan) +import Tricorder.Daemon.DaemonInfo (DaemonInfo (..)) +import Tricorder.Runtime (LogPath (..), PidFile (..), SocketPath (..)) +import Tricorder.Socket.Client (isDaemonRunning, queryStatus) +import Tricorder.Socket.UnixSocket (UnixSocket) + +import Tricorder.CLI.UI.Keys qualified as Keys + + +run + :: ( Brick :> es + , BrickChan :> es + , Clock :> es + , Conc :> es + , Concurrent :> es + , Console :> es + , Daemons :> es + , Delay :> es + , Exit :> es + , File :> es + , FileSystem :> es + , IOE :> es + , Process :> es + , Reader Command :> es + , Reader Keys.Config :> es + , Reader LogPath :> es + , Reader PidFile :> es + , Reader SocketPath :> es + , Timeout :> es + , UnixSocket :> es + ) + => Eff es () +run = + ask >>= \case + Start -> do + running <- isDaemonRunning + if running then + Console.putStrLn "Daemon already running." + else do + startDaemon + ready <- waitForDaemon + if ready then + Console.putStrLn "Daemon started." + else + Console.putStrLn "Daemon started, but the socket is not responding yet." + Stop force -> do + running <- isDaemonRunning + when running + $ stopDaemon force >>= \case + Left reasons -> + Console.putTextLn + $ T.intercalate "\n" + $ "Was unable to stop the daemon:" : reasons + Right result -> do + Console.putTextLn result + Status opts -> do + running <- isDaemonRunning + if not running then + Console.putStrLn "Stopped." + else + showStatus opts + Test opts -> do + running <- isDaemonRunning + if not running then + Console.putStrLn "Stopped." + else + showTests opts + Log logMode -> do + running <- isDaemonRunning + logFile <- + if running then do + SocketPath sp <- ask + result <- queryStatus sp + LogPath fallback <- ask + pure $ case result of + Right state -> state.daemonInfo.logFile + Left _ -> fallback + else + asks @LogPath (.getLogPath) + case logMode of + ShowLog followMode -> showLog logFile followMode + ShowLogPath -> Console.putTextLn (toText logFile) + UI -> do + running <- isDaemonRunning + unless running do + startDaemon + void waitForDaemon + viewUi + Source moduleNames -> do + running <- isDaemonRunning + unless running $ do + startDaemon + void waitForDaemon + showSource moduleNames + Restart force -> + restartDaemon force >>= \case + Just (Left reasons) -> traverse_ Console.putTextLn reasons + _ -> pass + EvalComments opts -> do + running <- isDaemonRunning + unless running do + startDaemon + void waitForDaemon + showEvalComments opts diff --git a/src/Tricorder/CLI/Arguments.hs b/src/Tricorder/CLI/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/Arguments.hs @@ -0,0 +1,263 @@ +module Tricorder.CLI.Arguments + ( Command (..) + , FollowMode (..) + , LogMode (..) + , OutputFormat (..) + , StatusOptions (..) + , TestOptions (..) + , EvalCommentsOptions (..) + , Verbosity (..) + , WaitMode (..) + , parseArguments + , runArguments + ) where + +import Atelier.Effects.Arguments (Arguments, execParser) +import Effectful.Reader.Static (Reader, runReader) +import Options.Applicative + ( Parser + , ParserInfo + , ReadM + , argument + , auto + , command + , eitherReader + , flag + , flag' + , fullDesc + , header + , help + , helper + , hsubparser + , info + , infoOption + , long + , metavar + , option + , progDesc + , short + ) + +import Data.Text qualified as T + +import Tricorder.Module (ModuleName (..)) +import Tricorder.Socket.Protocol (Force (..)) +import Tricorder.SourceLookup (SourceQuery (..)) + +import Tricorder.Version qualified as Version + + +data WaitMode + = ShowCurrent + | WaitForBuild + deriving stock (Eq) + + +data OutputFormat + = TextOutput + | JsonOutput + deriving stock (Eq) + + +data Verbosity + = Concise + | Verbose + deriving stock (Eq) + + +data FollowMode + = NoFollow + | Follow + deriving stock (Eq) + + +data LogMode + = ShowLog FollowMode + | ShowLogPath + + +data StatusOptions = StatusOptions + { wait :: WaitMode + , format :: OutputFormat + , verbosity :: Verbosity + , expand :: Maybe Int + } + + +data TestOptions = TestOptions + { failedOnly :: Bool + , wait :: WaitMode + } + + +data EvalCommentsOptions = EvalCommentsOptions + { wait :: WaitMode + , format :: OutputFormat + } + + +data Command + = Start + | Stop Force + | Status StatusOptions + | Test TestOptions + | UI + | Log LogMode + | Source [SourceQuery] + | Restart Force + | EvalComments EvalCommentsOptions + + +runArguments :: (Arguments :> es) => Eff (Reader Command : es) a -> Eff es a +runArguments eff = do + args <- parseArguments + runReader args eff + + +parseArguments :: (Arguments :> es) => Eff es Command +parseArguments = execParser opts + + +opts :: ParserInfo Command +opts = + info (commandParser <**> versionOption <**> helper) + $ fullDesc + <> progDesc "tricorder — daemon-based GHCi build status" + <> header "tricorder — robust GHCi daemon with structured querying" + + +versionOption :: Parser (a -> a) +versionOption = infoOption (toString Version.gitHash) (long "version" <> help "Show version and exit") + + +commandParser :: Parser Command +commandParser = + hsubparser + ( command "start" (info (pure Start) (progDesc "Start the daemon (no-op if already running)")) + <> command "stop" (info stopParser (progDesc "Stop the daemon")) + <> command "status" (info statusParser (progDesc "Print build diagnostics (--json for machine-readable output)")) + <> command "test-results" (info testParser (progDesc "Show output from the latest test run")) + <> command "ui" (info (pure UI) (progDesc "Auto-refreshing terminal display")) + <> command "log" (info logParser (progDesc "Show daemon log output")) + <> command "source" (info sourceParser (progDesc "Print the Haskell source of one or more installed modules")) + <> command "restart" (info restartParser (progDesc "Restart the daemon")) + <> command "eval-comments" (info evalCommentsParser (progDesc "Show eval comments from the latest build")) + ) + + +logParser :: Parser Command +logParser = + Log <$> (pathFlag <|> followFlag) + where + pathFlag = + flag' + ShowLogPath + ( long "print-path" + <> help "Print the path to the log file instead of its contents" + ) + followFlag = + ShowLog + <$> flag + NoFollow + Follow + ( long "follow" + <> short 'f' + <> help "Keep streaming new log lines as they are written" + ) + + +statusParser :: Parser Command +statusParser = + Status + <$> ( StatusOptions + <$> waitParser + <*> jsonFormatToggleParser + <*> flag + Concise + Verbose + ( long "verbose" + <> short 'v' + <> help "Print full GHC message body under each diagnostic" + ) + <*> optional + ( option + auto + ( long "expand" + <> metavar "N" + <> help "Print full GHC message body for diagnostic #N" + ) + ) + ) + + +testParser :: Parser Command +testParser = + Test + <$> ( TestOptions + <$> flag + False + True + ( long "failed" + <> help "Only show output from failed test suites" + ) + <*> waitParser + ) + + +sourceParser :: Parser Command +sourceParser = + Source <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function")) + + +stopParser :: Parser Command +stopParser = + Stop <$> forceParser "Ignore waiting queries when stopping the daemon" + + +restartParser :: Parser Command +restartParser = + Restart <$> forceParser "Ignore watiting queries when restarting the daemon" + + +forceParser :: String -> Parser Force +forceParser helpText = flag NoForce Force $ long "force" <> help helpText + + +evalCommentsParser :: Parser Command +evalCommentsParser = + EvalComments + <$> ( EvalCommentsOptions + <$> waitParser + <*> jsonFormatToggleParser + ) + + +waitParser :: Parser WaitMode +waitParser = + flag + ShowCurrent + WaitForBuild + ( long "wait" + <> help "Block until the current build cycle completes" + ) + + +jsonFormatToggleParser :: Parser OutputFormat +jsonFormatToggleParser = + flag + TextOutput + JsonOutput + ( long "json" + <> help "Output full build state as JSON" + ) + + +queryReader :: ReadM SourceQuery +queryReader = eitherReader $ \s -> + let t = toText s + (m, rest) = T.break (== '#') t + in Right + $ SourceQuery + { moduleName = ModuleName m + , function = if T.null rest then Nothing else Just (T.tail rest) + } diff --git a/src/Tricorder/CLI/Daemon.hs b/src/Tricorder/CLI/Daemon.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/Daemon.hs @@ -0,0 +1,148 @@ +module Tricorder.CLI.Daemon + ( startDaemon + , stopDaemon + , restartDaemon + , waitForDaemon + ) where + +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.File (File) +import Atelier.Effects.Posix.Daemons (Daemons) +import Atelier.Effects.Timeout (Timeout, timeout) +import Atelier.Time (Millisecond, Second) +import Effectful (IOE) +import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet) +import Effectful.Reader.Static (Reader, ask) +import Effectful.Writer.Static.Local (runWriter, tell) +import Prelude hiding (force) + +import Atelier.Effects.Delay qualified as Delay +import Atelier.Effects.Posix.Daemons qualified as Daemons + +import Tricorder.Runtime (PidFile, SocketPath (..)) +import Tricorder.Socket.Client (isDaemonReady, isDaemonRunning, requestShutdown) +import Tricorder.Socket.Protocol (Force (..)) +import Tricorder.Socket.UnixSocket (UnixSocket) + +import Tricorder.Daemon.Main qualified as Daemon.Main + + +startDaemon + :: ( Daemons :> es + , IOE :> es + , Reader PidFile :> es + ) + => Eff es () +startDaemon = do + pidFile <- ask + Daemons.daemonize pidFile $ liftIO Daemon.Main.main + + +-- | Attempts to stop the daemon in progressively more forceful ways. +-- 1. First attempts to make the daemon stop using the API. +-- 2. Then attempts to stop the daemon by sending `SIGKILL` to its process. +stopDaemon + :: ( Daemons :> es + , Delay :> es + , File :> es + , Reader PidFile :> es + , Reader SocketPath :> es + , Timeout :> es + , UnixSocket :> es + ) + => Force -> Eff es (Either [Text] Text) +stopDaemon force = do + SocketPath sockPath <- ask + pidFile <- ask + res <- + runWriter @[Text] + $ fmap rightToMaybe + $ runNonDet OnEmptyKeep + $ requestStop sockPath pidFile + <|> sendKill pidFile + case res of + (Just r, _) -> pure $ Right r + (Nothing, es) -> pure $ Left es + where + timeoutDelay :: Second = case force of + Force -> 3 + NoForce -> 6 + requestStop sockPath pidFile = do + timeout1second (requestShutdown force sockPath) >>= \_ -> do + didStop <- fmap isJust $ timeout timeoutDelay $ waitForStop pidFile + if didStop then + pure "Daemon stopped." + else do + tell ["Daemon did not stop as requested."] + emptyEff + + sendKill pidFile = do + timeout1second (Daemons.forceKillAndWait pidFile) >>= \case + Nothing -> pure "Daemon stopped with SIGKILL." + Just ex -> do + tell ["Daemon did not respond to SIGKILL: " <> show ex] + emptyEff + + timeout1second = fmap (join . fmap rightToMaybe) . timeout (1 :: Second) + + waitForStop :: forall es'. (Daemons :> es', Delay :> es') => PidFile -> Eff es' () + waitForStop pidFile = fix \rec -> do + running <- Daemons.isRunning pidFile + if running then do + Delay.wait (500 :: Millisecond) + rec + else + pure () + + +-- | Restart the daemon: stop it (if running) and then start a fresh instance. +-- Returns the outcome of the stop attempt, or 'Nothing' if the daemon was not +-- running. The daemon is started unconditionally afterwards, mirroring the +-- @restart@ subcommand. +restartDaemon + :: ( Daemons :> es + , Delay :> es + , File :> es + , IOE :> es + , Reader PidFile :> es + , Reader SocketPath :> es + , Timeout :> es + , UnixSocket :> es + ) + => Force + -> Eff es (Maybe (Either [Text] Text)) +restartDaemon force = do + running <- isDaemonRunning + res <- if running then Just <$> stopDaemon force else pure Nothing + startDaemon + pure res + + +-- | Poll until the daemon binds to the socket, giving up after roughly +-- ten seconds. Returns 'True' once the socket is accepting connections. +-- +-- We poll the socket rather than the PID file for two reasons: the daemon +-- writes its PID /before/ it binds the socket (a client connecting in that +-- window gets a "connection refused" error), and right after forking the PID +-- file may not exist yet — so the PID is not a reliable readiness signal either +-- way. +waitForDaemon + :: ( Delay :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => Eff es Bool +waitForDaemon = do + SocketPath sockPath <- ask + go sockPath maxAttempts + where + -- 50 attempts × 200ms ≈ 10s + maxAttempts = 50 :: Int + go _ 0 = pure False + go sockPath n = do + ready <- isDaemonReady sockPath + if ready then + pure True + else do + Delay.wait (200 :: Millisecond) + go sockPath (n - 1) diff --git a/src/Tricorder/CLI/Main.hs b/src/Tricorder/CLI/Main.hs --- a/src/Tricorder/CLI/Main.hs +++ b/src/Tricorder/CLI/Main.hs @@ -10,19 +10,20 @@ import Atelier.Effects.File (runFile) import Atelier.Effects.FileSystem (runFileSystemIO) import Atelier.Effects.Posix.Daemons (runDaemons) +import Atelier.Effects.Process (runProcessIO) +import Atelier.Effects.Timeout (runTimeout) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) -import Effectful.Timeout (runTimeout) -import Tricorder.Arguments (runArguments) +import Tricorder.CLI.Arguments (runArguments) +import Tricorder.CLI.UI.Brick (runBrick) +import Tricorder.CLI.UI.BrickChan (runBrickChan) import Tricorder.Config (runLoadedConfig) -import Tricorder.Effects.Brick (runBrick) -import Tricorder.Effects.BrickChan (runBrickChan) -import Tricorder.Effects.UnixSocket (runUnixSocketIO) import Tricorder.Runtime (runLogPath, runPidFile, runProjectRoot, runRuntimeDir, runSocketPath) +import Tricorder.Socket.UnixSocket (runUnixSocketIO) -import Tricorder qualified -import Tricorder.UI.Keys qualified as Keys +import Tricorder.CLI.App qualified as App +import Tricorder.CLI.UI.Keys qualified as Keys main :: IO () @@ -47,7 +48,8 @@ . runLoadedConfig . runConfig @"keybindings" @Keys.Config . runDaemons + . runProcessIO . runArgumentsIO . runArguments . runUnixSocketIO - $ Tricorder.run + $ App.run diff --git a/src/Tricorder/CLI/Operations.hs b/src/Tricorder/CLI/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/Operations.hs @@ -0,0 +1,406 @@ +module Tricorder.CLI.Operations + ( showLog + , showSource + , showStatus + , showTests + , showEvalComments + ) where + +import Atelier.Effects.Clock (Clock, currentTimeZone) +import Atelier.Effects.Console (Console) +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.Exit (Exit, exitFailure) +import Atelier.Effects.File (File) +import Atelier.Effects.FileSystem (FileSystem, doesFileExist, followFile, readFileLbs) +import Data.Aeson (encode) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (utcToLocalTime) +import Effectful.Reader.Static (Reader, ask) + +import Atelier.Effects.Console qualified as Console +import Data.ByteString.Lazy qualified as BSL +import Data.Map.Strict qualified as Map +import Data.Text qualified as T + +import Tricorder.Build (BuildState (..), Severity (..)) +import Tricorder.Build.Test (Suites (..)) +import Tricorder.CLI.Arguments + ( EvalCommentsOptions (..) + , FollowMode (..) + , OutputFormat (..) + , StatusOptions (..) + , TestOptions (..) + , Verbosity (..) + , WaitMode (..) + ) +import Tricorder.CLI.Render + ( diagnosticLineIndexed + , formatDuration + , renderSourceResults + ) +import Tricorder.Runtime (SocketPath (..)) +import Tricorder.Session.TestTarget (renderTestTarget) +import Tricorder.Socket.Client (querySource, queryStatus, queryStatusWait) +import Tricorder.Socket.UnixSocket (UnixSocket) +import Tricorder.SourceLookup (SourceQuery) +import Tricorder.TestOutput (stripGhciNoise) + +import Tricorder.Build qualified as Build +import Tricorder.Build.EvalComment qualified as Eval +import Tricorder.Build.Test qualified as Test +import Tricorder.Build.Test qualified as Tests + + +-- | Print a build-command failure message and exit non-zero. +reportBuildFailed :: (Console :> es, Exit :> es) => Text -> Eff es a +reportBuildFailed msg = do + Console.putTextLn "Build command failed:" + Console.putTextLn msg + exitFailure + + +showStatus + :: ( Clock :> es + , Console :> es + , Exit :> es + , File :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => StatusOptions -> Eff es () +showStatus opts = do + when (opts.wait == WaitForBuild && opts.format == TextOutput) do + displayPendingBuildStatus + result <- awaitBuildStatus opts.wait + case result of + Left err -> Console.putTextLn $ "Error: " <> err + Right state -> + case opts.format of + JsonOutput -> do + Console.putStr $ BSL.toStrict $ encode state + Console.putStrLn "" + TextOutput -> + renderText opts.verbosity opts.expand state + where + renderText verbosity expand state = case state.phase of + Build.Starting -> Console.putStrLn "Building..." + Build.Building _ _ -> Console.putStrLn "Building..." + Build.Failed msg -> reportBuildFailed msg + Build.PostBuilding _ postBuild -> + let + testsRunning = Test.anyRunningTests postBuild.testSuites + commentsEvaluating = Eval.phasePending postBuild.evalComments + in + if + | testsRunning && commentsEvaluating -> + Console.putStrLn "Testing and evaluating comments..." + | testsRunning -> + Console.putStrLn "Testing..." + | commentsEvaluating -> + Console.putStrLn "Evaluating comments..." + | otherwise -> + Console.putStrLn "Post-procesing..." + Build.Finished result postBuild -> do + tz <- currentTimeZone + case expand of + Just n -> + case result.diagnostics !!? (n - 1) of + Nothing -> + Console.putTextLn + $ "No diagnostic #" + <> show n + <> " (current build has " + <> show (length result.diagnostics) + <> ")" + Just d -> do + Console.putTextLn $ diagnosticLineIndexed n d + Console.putText d.text + Nothing -> do + let printDiag (i, d) = case verbosity of + Verbose -> do + Console.putTextLn $ diagnosticLineIndexed i d + Console.putText d.text + Concise -> + Console.putTextLn $ diagnosticLineIndexed i d + mapM_ printDiag (zip [1 ..] result.diagnostics) + Console.putTextLn $ buildSummary tz result + mapM_ (uncurry (printTestRun verbosity)) $ Map.toList postBuild.testSuites.getSuites + when (buildHasErrors result || Test.hasFailedTests postBuild.testSuites) exitFailure + + printTestRun verbosity tgt tr = do + Console.putTextLn $ case tr of + Test.SuiteRunning Nothing -> t <> " running..." + Test.SuiteRunning (Just p) -> t <> " running... (" <> show p.compiled <> "/" <> show p.total <> ")" + Test.SuiteErrored e -> t <> " error: " <> e.message + Test.SuiteCompleted c -> t <> " " <> completionSummary c + when (verbosity == Verbose) $ case tr of + Test.SuiteCompleted c -> + mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (T.lines c.output)) + _ -> pure () + where + t = renderTestTarget tgt + + buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics + buildSummary tz r = + let errs = length $ filter ((== SError) . (.severity)) r.diagnostics + warns = length $ filter ((== SWarning) . (.severity)) r.diagnostics + ts = toText $ "— " <> formatTime defaultTimeLocale "%H:%M:%S" (utcToLocalTime tz r.completedAt) + stats = toText $ "(" <> show r.moduleCount <> " modules, " <> formatDuration r.duration <> ")" + in if null r.diagnostics then + "All good. " <> stats <> " " <> ts + else + show errs <> " error(s), " <> show warns <> " warning(s) " <> stats <> " " <> ts + + +completionSummary :: Test.SuiteCompletion -> Text +completionSummary c = statusText <> maybe "" (\d -> " (" <> formatDuration d <> ")") c.duration + where + statusText + | null c.testCases = if c.passed then "passed" else "failed" + | otherwise = + let total = length c.testCases + failedCount = length $ filter isFailedCase c.testCases + in if failedCount == 0 then + "passed (" <> show total <> ")" + else + show failedCount <> "/" <> show total <> " failed" + isFailedCase (Test.Case _ (Test.Failed _)) = True + isFailedCase _ = False + + +showLog + :: ( Console :> es + , Delay :> es + , FileSystem :> es + ) + => FilePath -> FollowMode -> Eff es () +showLog path followMode = do + exists <- doesFileExist path + if not exists then + Console.putTextLn $ "Log file does not exist yet: " <> toText path + else case followMode of + Follow -> followFile path Console.putStr + NoFollow -> readFileLbs path >>= Console.putStr . BSL.toStrict + + +showTests + :: ( Console :> es + , Exit :> es + , File :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => TestOptions -> Eff es () +showTests opts = do + result <- awaitBuildStatus opts.wait + case result of + Left err -> Console.putTextLn $ "Error: " <> err + Right state -> + case state.phase of + Build.Starting -> Console.putStrLn "Daemon starting, no test results yet." + Build.Building _ _ -> Console.putStrLn "Build in progress, no test results yet." + Build.PostBuilding _ postBuild -> renderTestRuns postBuild.testSuites.getSuites + Build.Finished _ postBuild -> renderTestRuns postBuild.testSuites.getSuites + Build.Failed msg -> reportBuildFailed msg + where + renderTestRuns suites + | Map.null suites = Console.putStrLn "No test results." + | Map.null filteredSuites = do + Console.putStrLn "All passed." + mapM_ (Console.putTextLn . (" " <>) . renderTestTarget) $ Map.keys suites + | otherwise = do + mapM_ (uncurry printTestOutput) $ Map.toList filteredSuites + when (any Test.isFailedRun filteredSuites) exitFailure + where + filteredSuites = + if opts.failedOnly then + Map.filter Test.isFailedRun suites + else + suites + + printTestOutput tgt tr = case tr of + Test.SuiteRunning Nothing -> + Console.putTextLn $ t <> "running..." + Test.SuiteRunning (Just p) -> + Console.putTextLn $ t <> "running... (" <> show p.compiled <> "/" <> show p.total <> ")" + Test.SuiteErrored e -> + Console.putTextLn $ t <> "error: " <> e.message + Test.SuiteCompleted c -> do + Console.putTextLn $ t <> completionSummary c + if opts.failedOnly then + if null c.testCases then do + Console.putTextLn " (unrecognised test runner format — showing full output)" + mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (lines c.output)) + else + mapM_ printFailedCase (filter Test.caseFailed c.testCases) + else + mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (lines c.output)) + where + t = renderTestTarget tgt <> " " + + printFailedCase tc = do + Console.putTextLn $ " " <> tc.description + case tc.outcome of + Test.Failed details -> + mapM_ (Console.putTextLn . (" " <>)) (T.lines details) + Test.Passed -> pure () + + +showSource + :: ( Console :> es + , File :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => [SourceQuery] + -> Eff es () +showSource queries = do + SocketPath sockPath <- ask + result <- querySource sockPath queries + case result of + Left err -> Console.putTextLn $ "Error: " <> err + Right results -> renderSourceResults results + + +showEvalComments + :: ( Console :> es + , Exit :> es + , File :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => EvalCommentsOptions -> Eff es () +showEvalComments opts = do + when (opts.wait == WaitForBuild && opts.format == TextOutput) do + displayPendingBuildStatus + result <- awaitBuildStatus opts.wait + case opts.format of + TextOutput -> displayTextOutput result + JsonOutput -> displayJsonOutput result + + +displayTextOutput + :: ( Console :> es + , Exit :> es + ) + => Either Text BuildState -> Eff es () +displayTextOutput = \case + Left err -> do + Console.putTextLn $ "Error: " <> err + exitFailure + Right (BuildState _ phase _) -> case phase of + Build.Starting -> Console.putStrLn "Starting..." + Build.Building _ _ -> Console.putStrLn "Building..." + Build.PostBuilding _ postBuild -> txtEvalComments postBuild + Build.Finished _ postBuild -> txtEvalComments postBuild + Build.Failed err -> do + Console.putTextLn $ "Error: " <> err + exitFailure + where + txtEvalComments postBuild = + let evalutatingComments = Eval.phasePending postBuild.evalComments + in if + | Tests.anyRunningTests postBuild.testSuites && evalutatingComments -> + Console.putStrLn "Testing and evaluating comments..." + | Tests.anyRunningTests postBuild.testSuites -> Console.putStrLn "Testing..." + | evalutatingComments -> Console.putStrLn "Evaluating comments..." + | otherwise -> case postBuild.evalComments of + Eval.Looking -> Console.putStrLn "Looking for eval comments..." + Eval.NoneFound -> Console.putStrLn "No eval comments found" + Eval.Found comments + | Eval.anyRunningComments comments -> Console.putStrLn "Evaluating comments..." + | otherwise -> + Console.putTextLn + . T.intercalate "\n\n" + . toList + $ showEvalRun <$> comments.getComments + showEvalRun run = + T.intercalate + "\n" + [ showEvalRunInfo run + , showEvalState run + ] + showEvalRunInfo evaluation = + T.intercalate + "\n" + [ toText evaluation.file <> ":" <> show evaluation.comment.lineNumber + , "Expression:" + , evaluation.comment.expression + ] + showEvalState evaluation = + case evaluation.state of + Eval.Pending -> "Pending..." + Eval.Completed output -> + T.intercalate + "\n" + [ "Output:" + , output + ] + + +displayJsonOutput :: (Console :> es, Exit :> es) => Either Text BuildState -> Eff es () +displayJsonOutput = \case + Left err -> do + putJson $ Eval.Failed err + exitFailure + Right (BuildState _ phase _) -> case phase of + Build.Starting -> putJson Eval.Starting + Build.Building _ _ -> putJson Eval.Building + Build.Failed msg -> do + putJson $ Eval.Failed msg + exitFailure + Build.PostBuilding _ postBuild -> jsonEvalComments postBuild + Build.Finished _ postBuild -> jsonEvalComments postBuild + where + jsonEvalComments postBuild = case postBuild.evalComments of + Eval.Looking -> putJson Eval.Evaluating + Eval.NoneFound -> putJson $ Eval.NoEvalCommentsFound + Eval.Found comments + | Eval.anyRunningComments comments -> putJson Eval.Evaluating + | otherwise -> putJson $ Eval.Done comments + putJson = Console.putStrLn . toStrict . encode + + +displayPendingBuildStatus + :: ( Console :> es + , File :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => Eff es () +displayPendingBuildStatus = do + SocketPath sockPath <- ask + current <- queryStatus sockPath + case current of + Right BuildState {phase = Build.Starting} -> Console.putStrLn "Starting..." + Right BuildState {phase = Build.Building _ _} -> Console.putStrLn "Building..." + Right BuildState {phase = Build.Finished _ postBuild} -> + displayPostBuildStatus postBuild + Right BuildState {phase = Build.PostBuilding _ postBuild} -> + displayPostBuildStatus postBuild + Right BuildState {phase = Build.Failed _} -> pure () + Left _ -> pure () + where + displayPostBuildStatus postBuild + | Tests.anyRunningTests postBuild.testSuites && evaluatingComments = + Console.putStrLn "Testing and evaluating comments..." + | Tests.anyRunningTests postBuild.testSuites = + Console.putStrLn "Testing..." + | evaluatingComments = + Console.putStrLn "Evaluating comments..." + | otherwise = pure () + where + evaluatingComments = Eval.phasePending postBuild.evalComments + + +awaitBuildStatus + :: ( File :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => WaitMode -> Eff es (Either Text BuildState) +awaitBuildStatus wait = do + SocketPath sockPath <- ask + case wait of + WaitForBuild -> queryStatusWait sockPath + ShowCurrent -> queryStatus sockPath diff --git a/src/Tricorder/CLI/Render.hs b/src/Tricorder/CLI/Render.hs --- a/src/Tricorder/CLI/Render.hs +++ b/src/Tricorder/CLI/Render.hs @@ -11,14 +11,10 @@ import Atelier.Time (Millisecond, toMicroseconds) import Atelier.Effects.Console qualified as Console -import Data.Text qualified as T -import Tricorder.BuildState - ( Diagnostic (..) - , Severity (..) - ) -import Tricorder.GhcPkg.Types (ModuleName (..), PackageId (..)) -import Tricorder.SourceLookup (ModuleSourceResult (..), ReExport (..), SourceQuery (..)) +import Tricorder.Build (Diagnostic (..), Severity (..)) +import Tricorder.Module (ModuleName (..), PackageId (..)) +import Tricorder.SourceLookup (ModuleSourceResult (..), SourceQuery (..)) formatDuration :: Millisecond -> Text @@ -56,27 +52,22 @@ renderSourceResults :: (Console :> es) => [ModuleSourceResult] -> Eff es () renderSourceResults results = mapM_ renderOne results where - renderOne (SourceFound query src reExports) = do + renderOne (SourceFound query src) = do when (length results > 1) $ Console.putTextLn $ header query Console.putText src - unless (null reExports || isJust query.function) - $ Console.putTextLn - $ "\n-- Re-exports: " <> T.intercalate ", " (map renderReExport reExports) when (length results > 1) $ Console.putStrLn "" renderOne (SourceNotFound query) = Console.putTextLn $ "Not found: " <> unModuleName query.moduleName <> " (module not in any installed package)" - renderOne (SourceNoHaddock query pkgId) = + renderOne (SourceUnavailable query pkgId) = Console.putTextLn $ "No source available: " <> unModuleName query.moduleName - <> " (package " - <> unPackageId pkgId - <> " was built without documentation; try `cabal get " + <> " (could not locate or fetch a source tarball for " <> unPackageId pkgId - <> "`)" + <> ")" renderOne (FunctionNotFound query) = Console.putTextLn $ "tricorder: " @@ -89,6 +80,3 @@ "-- " <> unModuleName query.moduleName <> maybe "" ("#" <>) query.function - - renderReExport (ReExportModule m) = "module " <> m - renderReExport (ReExportName name src) = name <> " (from " <> src <> ")" diff --git a/src/Tricorder/CLI/UI.hs b/src/Tricorder/CLI/UI.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI.hs @@ -0,0 +1,119 @@ +module Tricorder.CLI.UI + ( viewUi + ) where + +import Atelier.Effects.Clock (Clock) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Console (Console) +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.File (File) +import Atelier.Effects.Process (Process, getExecutablePath, proc, runProcess) +import Brick (App (..), neverShowCursor) +import Brick.BChan (BChan, writeBChanNonBlocking) +import Brick.Keybindings (KeyConfig) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar) +import Effectful.Exception (bracket_, trySync) +import Effectful.Reader.Static (Reader, ask) + +import Atelier.Effects.Conc qualified as Conc + +import Tricorder.CLI.Daemon (waitForDaemon) +import Tricorder.CLI.UI.Brick (Brick) +import Tricorder.CLI.UI.BrickChan (BrickChan) +import Tricorder.CLI.UI.Event (Event (..), handleEvent) +import Tricorder.CLI.UI.Keys (KeyEvent, dispatcher) +import Tricorder.CLI.UI.State (State (..), Viewports (..)) +import Tricorder.CLI.UI.View (mkAttrMap, view) +import Tricorder.Runtime (SocketPath (..)) +import Tricorder.Socket.Client (queryWatch) +import Tricorder.Socket.UnixSocket (UnixSocket) + +import Tricorder.CLI.UI.Brick qualified as Brick +import Tricorder.CLI.UI.BrickChan qualified as BrickChan +import Tricorder.CLI.UI.Keys qualified as Keys +import Tricorder.CLI.UI.State qualified as Model + + +-- | Connect to the daemon and render a live-updating build status display using +-- a brick TUI. Quits on @q@ or @Esc@; arrow keys scroll the viewport; @R@ +-- restarts the daemon. +viewUi + :: ( Brick :> es + , BrickChan :> es + , Clock :> es + , Conc :> es + , Concurrent :> es + , Console :> es + , Delay :> es + , File :> es + , Process :> es + , Reader Keys.Config :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => Eff es () +viewUi = do + SocketPath sockPath <- ask + chan <- BrickChan.newBChan 10 + restartChan <- BrickChan.newBChan 1 + -- Set while a restart we triggered is in flight, so the watch loop stays + -- patient and reconnects to the fresh daemon instead of giving up. + restarting <- newTVarIO False + initialState <- Model.init + Conc.scoped do + _ <- + Conc.fork do + queryWatch sockPath (readTVarIO restarting) + $ BrickChan.writeBChan chan . NewBuildState + BrickChan.writeBChan chan $ FailedBuild "Lost contact with the daemon" + _ <- Conc.fork $ restartWorker restartChan restarting + keyConfig <- Keys.mkKeyConfig + let requestRestart = void $ writeBChanNonBlocking restartChan () + void + $ Brick.runBrickApp + chan + (watchApp requestRestart keyConfig) + initialState + + +-- | Wait for restart requests from the TUI and service each one by spawning a +-- fresh @tricorder restart@ process. +-- +-- The restart must happen out-of-process: starting the daemon double-forks (see +-- "System.Posix.Daemon"), and forking this vty-controlled process knocks the +-- terminal out of the raw mode brick set up, so keystrokes stop being captured. +-- Delegating to a separate process keeps the fork isolated. The brick event +-- handler signals us over @restartChan@ because it cannot run these effects. +restartWorker + :: ( BrickChan :> es + , Concurrent :> es + , Delay :> es + , Process :> es + , Reader SocketPath :> es + , UnixSocket :> es + ) + => BChan () + -> TVar Bool + -> Eff es () +restartWorker restartChan restarting = forever + $ bracket_ + (BrickChan.readBChan restartChan >> atomically (writeTVar restarting True)) + (atomically $ writeTVar restarting False) + do + self <- getExecutablePath + -- Swallow failures: a restart that errors must not take down the TUI, and + -- the flag has to be cleared either way. + _ <- trySync $ runProcess $ proc self ["restart"] + void waitForDaemon + + +watchApp :: IO () -> KeyConfig KeyEvent -> App State Event Viewports +watchApp requestRestart kc = + App + { appDraw = view kc + , appHandleEvent = handleEvent $ dispatcher requestRestart kc + , appStartEvent = pure () + , appAttrMap = mkAttrMap + , appChooseCursor = neverShowCursor + } diff --git a/src/Tricorder/CLI/UI/Brick.hs b/src/Tricorder/CLI/UI/Brick.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/Brick.hs @@ -0,0 +1,48 @@ +module Tricorder.CLI.UI.Brick + ( -- * Brick + Brick + , runBrickApp + , runBrick + ) where + +import Brick.Main (App, customMain) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) +import Graphics.Vty (Mode (Mouse), outputIface, setMode) +import Graphics.Vty.Config (userConfig) +import Graphics.Vty.CrossPlatform (mkVty) + +import Tricorder.CLI.UI.BrickChan (BChan) + + +data Brick :: Effect where + RunBrickApp + :: (Ord resource) + => BChan event + -- ^ Channel for publishing events for the app from outside the app + -> App state event resource + -- ^ App to run + -> state + -- ^ Initial state + -> Brick m state + + +makeEffect ''Brick + + +runBrick :: (IOE :> es) => Eff (Brick : es) a -> Eff es a +runBrick = interpret_ \case + RunBrickApp chan app initialState -> liftIO do + let buildVty = do + cfg <- userConfig + vty <- mkVty cfg + setMode (outputIface vty) Mouse True + pure vty + initialVty <- liftIO buildVty + customMain + initialVty + buildVty + (Just chan) + app + initialState diff --git a/src/Tricorder/CLI/UI/BrickChan.hs b/src/Tricorder/CLI/UI/BrickChan.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/BrickChan.hs @@ -0,0 +1,34 @@ +module Tricorder.CLI.UI.BrickChan + ( BrickChan + , BChan + , newBChan + , writeBChan + , readBChan + , runBrickChan + ) where + +import Brick.BChan (BChan) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) + +import Brick.BChan qualified as BChan + + +data BrickChan :: Effect where + -- | Lifted `Brick.BChan.newBChan` + NewBChan :: Int -> BrickChan m (BChan a) + -- | Lifted `Brick.BChan.writeBChan` + WriteBChan :: BChan a -> a -> BrickChan m () + -- | Lifted `Brick.BChan.readBChan` + ReadBChan :: BChan a -> BrickChan m a + + +makeEffect ''BrickChan + + +runBrickChan :: (IOE :> es) => Eff (BrickChan : es) a -> Eff es a +runBrickChan = interpret_ \case + NewBChan n -> liftIO $ BChan.newBChan n + WriteBChan c x -> liftIO $ BChan.writeBChan c x + ReadBChan c -> liftIO $ BChan.readBChan c diff --git a/src/Tricorder/CLI/UI/Event.hs b/src/Tricorder/CLI/UI/Event.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/Event.hs @@ -0,0 +1,38 @@ +module Tricorder.CLI.UI.Event + ( Event (..) + , handleEvent + ) where + +import Brick (BrickEvent (..), EventM, vScrollBy, viewportScroll) +import Brick.Keybindings (KeyDispatcher, handleKey) +import Control.Monad.State (modify) + +import Graphics.Vty qualified as Vty + +import Tricorder.Build (BuildState (..)) +import Tricorder.CLI.UI.Keys (KeyEvent) +import Tricorder.CLI.UI.State (Processed (..), State (..), Viewports (..)) +import Tricorder.Socket.Client (Restarting (..)) + + +data Event + = NewBuildState (Either Restarting BuildState) + | FailedBuild Text + + +handleEvent :: KeyDispatcher KeyEvent (EventM Viewports State) -> BrickEvent Viewports Event -> EventM Viewports State () +handleEvent _ (AppEvent ev) = handleAppEvent ev +handleEvent d (VtyEvent (Vty.EvKey key modifiers)) = void $ handleKey d key modifiers +handleEvent _ (MouseDown vp Vty.BScrollUp _ _) = vScrollBy (viewportScroll vp) (-1) +handleEvent _ (MouseDown vp Vty.BScrollDown _ _) = vScrollBy (viewportScroll vp) 1 +handleEvent _ _ = pure () + + +handleAppEvent :: Event -> EventM Viewports State () +handleAppEvent = \case + NewBuildState (Left Restarting) -> + modify \s -> s {buildState = Waiting} + NewBuildState (Right bs) -> + modify \s -> s {buildState = Success bs} + FailedBuild reason -> + modify \s -> s {buildState = Failure reason} diff --git a/src/Tricorder/CLI/UI/Keys.hs b/src/Tricorder/CLI/UI/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/Keys.hs @@ -0,0 +1,264 @@ +module Tricorder.CLI.UI.Keys + ( KeyEvent + , Config + , keys + , dispatcher + , viewKeybindings + , mkKeyConfig + , keybindForRoute + ) where + +import Atelier.Effects.Console (Console) +import Brick + ( EventM + , Widget + , halt + , txt + , vBox + , vScrollBy + , viewportScroll + ) +import Brick.Keybindings + ( Binding + , BindingState + , EventTrigger (..) + , Handler (..) + , KeyConfig + , KeyDispatcher + , KeyEventHandler (..) + , KeyEvents + , KeyHandler (..) + , ToBinding (..) + , allActiveBindings + , binding + , ctrl + , keyDispatcher + , keyEvents + , newKeyConfig + , onEvent + , parseBindingList + ) +import Brick.Keybindings.KeyConfig (firstActiveBinding) +import Brick.Keybindings.Pretty (ppBinding) +import Brick.Widgets.Core (hBox) +import Control.Monad.State (gets, modify) +import Data.Aeson (FromJSON (..)) +import Data.Default (Default (..)) +import Effectful.Exception (throwIO) +import Effectful.Reader.Static (Reader, ask) +import Graphics.Vty (Key (..)) +import System.IO.Error (userError) +import Text.Casing (quietSnake) + +import Atelier.Effects.Console qualified as Console +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T + +import Tricorder.CLI.UI.Misc (warn) +import Tricorder.CLI.UI.Route (Route) +import Tricorder.CLI.UI.State + ( Processed (Waiting) + , State (..) + , Viewports (..) + , currentRoute + , cycleTestFilter + , navigate + , viewToViewport + ) + +import Tricorder.CLI.UI.Route qualified as Route + + +-- | [tag:keybinding_events] The TUI key events. This type is the source of truth +-- for the event names documented in README.md under "Custom Key Bindings", which +-- points back here with a matching @ref@. Whenever you add, remove, or rename a +-- 'KeyEvent', update that list to match — @tagref check@ flags the dangling +-- reference if this tag is renamed or dropped without touching the docs. +data KeyEvent + = ToggleDaemonInfoView + | ToggleHelp + | CycleTestView + | ToggleEvalComments + | RestartDaemon + | ExitView + | ScrollUp + | ScrollDown + | Quit + deriving stock (Bounded, Enum, Eq, Ord, Show) + + +keyEventToText :: KeyEvent -> Text +keyEventToText = toText . quietSnake . show + + +keyEventTextMap :: Map Text KeyEvent +keyEventTextMap = Map.fromList $ (\e -> (keyEventToText e, e)) <$> universe + + +textToKeyEvent :: Text -> Maybe KeyEvent +textToKeyEvent = (`Map.lookup` keyEventTextMap) + + +keys :: KeyEvents KeyEvent +keys = + keyEvents + [ ("toggle daemon info", ToggleDaemonInfoView) + , ("toggle help", ToggleHelp) + , ("cycle test view", CycleTestView) + , ("toggle eval comments", ToggleEvalComments) + , ("restart daemon", RestartDaemon) + , ("exit view", ExitView) + , ("scroll up", ScrollUp) + , ("scroll down", ScrollDown) + , ("quit", Quit) + ] + + +bindings :: [(KeyEvent, [Binding])] +bindings = + [ (ToggleDaemonInfoView, [bind 'g']) + , (ToggleHelp, [bind 'h']) + , (CycleTestView, [bind 't']) + , (ToggleEvalComments, [bind 'e']) + , (RestartDaemon, [bind 'R']) + , (ExitView, [binding KEsc []]) + , (ScrollUp, [binding KUp []]) + , (ScrollDown, [binding KDown []]) + , (Quit, [bind 'q', ctrl 'c']) + ] + + +mkKeyConfig :: (Console :> es, Reader Config :> es) => Eff es (KeyConfig KeyEvent) +mkKeyConfig = do + customBindings <- parseCustomBindings + pure $ newKeyConfig keys bindings customBindings + + +newtype Config = Config (Map Text Text) + deriving stock (Generic) + deriving newtype (FromJSON) + + +instance Default Config where + def = Config mempty + + +parseCustomBindings + :: ( Console :> es + , Reader Config :> es + ) + => Eff es [(KeyEvent, BindingState)] +parseCustomBindings = do + Config cfg <- ask + let (errors, customBindings) = partitionEithers $ uncurry parseEntry <$> Map.toList cfg + unless (null errors) do + Console.putTextLn "Error(s) encountered when attempting to parse key bindings:" + traverse_ (Console.putTextLn . toText) errors + throwIO $ userError "Malformed keybindings" + pure customBindings + + +parseEntry :: Text -> Text -> Either Text (KeyEvent, BindingState) +parseEntry ev binds = + (,) <$> parsedEvent <*> parsedBinds + where + parsedEvent = parseKeyEvent ev + parsedBinds = first toText $ parseBindingList binds + + +parseKeyEvent :: Text -> Either Text KeyEvent +parseKeyEvent ev = maybeToRight ("Unrecognized key event: " <> ev) $ textToKeyEvent ev + + +-- | Build the key dispatcher. @requestRestart@ is run (in 'IO') when the restart +-- key is pressed; it hands the request off to the worker that owns the daemon +-- control effects, since brick's 'EventM' cannot run them directly. +dispatcher :: IO () -> KeyConfig KeyEvent -> KeyDispatcher KeyEvent (EventM Viewports State) +dispatcher requestRestart cfg = + -- TODO: Handle this error more gracefully. + either (error . ("Invalid key dispatcher config: " <>) . stringify) id + $ keyDispatcher + cfg + [ onEvent ToggleDaemonInfoView "Toggle daemon info view" do + modify \s -> + if currentRoute s == Route.DaemonInfo then + navigate Route.Main s + else + navigate Route.DaemonInfo s + , onEvent ToggleHelp "Toggle help" do + modify \s -> + if currentRoute s == Route.Help then + navigate Route.Main s + else + navigate Route.Help s + , onEvent CycleTestView "Cycle test results view" do + modify \s -> case currentRoute s of + Route.Tests -> + if s.testFilter == maxBound then + navigate Route.Main s {testFilter = minBound} + else + s {testFilter = cycleTestFilter s.testFilter} + _ -> navigate Route.Tests s + , onEvent ToggleEvalComments "Toggle eval comments view" do + modify \s -> + if currentRoute s == Route.Evals then + navigate Route.Main s + else + navigate Route.Evals s + , onEvent RestartDaemon "Restart the daemon" do + liftIO requestRestart + modify \s -> s {buildState = Waiting} + , onEvent ExitView "Exit or go back" do + gets (.route) >>= \case + Route.Main -> halt + _ -> modify $ navigate Route.Main + , onEvent ScrollUp "Scroll up" do + mvp <- gets (viewToViewport . currentRoute) + case mvp of + Just vp -> vScrollBy (viewportScroll vp) (-1) + Nothing -> pure () + , onEvent ScrollDown "Scroll down" do + mvp <- gets (viewToViewport . currentRoute) + case mvp of + Just vp -> + vScrollBy (viewportScroll vp) 1 + Nothing -> pure () + , onEvent Quit "Exit" do + halt + ] + where + stringify = + show . fmap (second $ fmap $ handlerDescription . kehHandler . khHandler) + + +viewKeybindings :: (Ord k, Show k) => KeyConfig k -> [KeyEventHandler k m] -> Widget n +viewKeybindings kc = + vBox + . fmap (uncurry (viewEventAndTriggers kc)) + . Map.toList + . foldr groupByEventName Map.empty + where + groupByEventName ev = Map.insertWith (<>) ev.kehHandler.handlerDescription [ev.kehEventTrigger] + + +viewEventAndTriggers :: (Ord k, Show k) => KeyConfig k -> Text -> [EventTrigger k] -> Widget n +viewEventAndTriggers kc eventName triggers = + hBox + [ warn $ txt $ eventName <> ": " + , txt $ showBindings $ mconcat $ getBindings <$> triggers + ] + where + showBindings = T.intercalate ", " . fmap ppBinding . sort . toList + getBindings = \case + ByKey k -> Set.singleton k + ByEvent e -> Set.fromList $ allActiveBindings kc e + + +keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding +keybindForRoute kc = \case + Route.Main -> Nothing + Route.DaemonInfo -> firstActiveBinding kc ToggleDaemonInfoView + Route.Help -> firstActiveBinding kc ToggleHelp + Route.Tests -> firstActiveBinding kc CycleTestView + Route.Evals -> firstActiveBinding kc ToggleEvalComments diff --git a/src/Tricorder/CLI/UI/Misc.hs b/src/Tricorder/CLI/UI/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/Misc.hs @@ -0,0 +1,50 @@ +module Tricorder.CLI.UI.Misc + ( err + , warn + , ok + , emphasis + , subtle + , hBoxSpaced + , vBoxSpaced + ) where + +import Brick + ( Padding (..) + , Widget + , attrName + , hBox + , padLeft + , padTop + , vBox + , withDefAttr + ) + + +err :: Widget n -> Widget n +err = withDefAttr $ attrName "error" + + +warn :: Widget n -> Widget n +warn = withDefAttr $ attrName "warning" + + +ok :: Widget n -> Widget n +ok = withDefAttr $ attrName "ok" + + +emphasis :: Widget n -> Widget n +emphasis = withDefAttr $ attrName "emphasis" + + +subtle :: Widget n -> Widget n +subtle = withDefAttr $ attrName "subtle" + + +hBoxSpaced :: Int -> [Widget n] -> Widget n +hBoxSpaced _ [] = hBox [] +hBoxSpaced pad (x : xs) = hBox $ x : (padLeft (Pad pad) <$> xs) + + +vBoxSpaced :: Int -> [Widget n] -> Widget n +vBoxSpaced _ [] = vBox [] +vBoxSpaced pad (x : xs) = vBox $ x : (padTop (Pad pad) <$> xs) diff --git a/src/Tricorder/CLI/UI/Route.hs b/src/Tricorder/CLI/UI/Route.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/Route.hs @@ -0,0 +1,22 @@ +module Tricorder.CLI.UI.Route + ( Route (..) + , name + ) where + + +data Route + = Main + | Help + | DaemonInfo + | Tests + | Evals + deriving stock (Bounded, Enum, Eq) + + +name :: Route -> Text +name = \case + Main -> "Dashboard" + Help -> "Help" + DaemonInfo -> "Daemon info" + Tests -> "Tests" + Evals -> "Eval comments" diff --git a/src/Tricorder/CLI/UI/State.hs b/src/Tricorder/CLI/UI/State.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/State.hs @@ -0,0 +1,78 @@ +module Tricorder.CLI.UI.State + ( Viewports (..) + , State (..) + , Processed (..) + , TestFilter (..) + , init + , currentRoute + , viewToViewport + , cycleTestFilter + , navigate + ) where + +import Atelier.Effects.Clock (Clock, TimeZone) +import Prelude hiding (init) + +import Atelier.Effects.Clock qualified as Clock + +import Tricorder.Build (BuildState) +import Tricorder.CLI.UI.Route (Route) + +import Tricorder.CLI.UI.Route qualified as Route + + +data Viewports + = MainViewport + | DiagnosticViewport + | TestViewport + | EvalResultsViewport + deriving stock (Eq, Ord, Show) + + +data State = State + { buildState :: Processed Text BuildState + , timeZone :: TimeZone + , route :: Route + , testFilter :: TestFilter + } + + +data TestFilter = TestFilterAll | TestFilterFailedOnly + deriving stock (Bounded, Enum, Eq) + + +cycleTestFilter :: TestFilter -> TestFilter +cycleTestFilter x = if x == maxBound then minBound else succ x + + +data Processed e a + = Waiting + | Failure e + | Success a + + +currentRoute :: State -> Route +currentRoute = (.route) + + +viewToViewport :: Route -> Maybe Viewports +viewToViewport = \case + Route.Tests -> Just TestViewport + Route.Main -> Just DiagnosticViewport + _ -> Nothing + + +navigate :: Route -> State -> State +navigate route s = s {route} + + +init :: (Clock :> es) => Eff es State +init = do + tz <- Clock.currentTimeZone + pure + State + { buildState = Waiting + , timeZone = tz + , route = Route.Main + , testFilter = minBound + } diff --git a/src/Tricorder/CLI/UI/View.hs b/src/Tricorder/CLI/UI/View.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/CLI/UI/View.hs @@ -0,0 +1,556 @@ +module Tricorder.CLI.UI.View (mkAttrMap, view) where + +import Atelier.Effects.Clock (TimeZone) +import Atelier.Time (Millisecond, toMicroseconds) +import Brick + ( AttrMap + , AttrName + , VScrollBarOrientation (..) + , ViewportType (..) + , Widget + , attrMap + , attrName + , vBox + , viewport + ) +import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList, ppBinding) +import Brick.Widgets.Core + ( Padding (..) + , emptyWidget + , hBox + , padLeft + , txt + , txtWrap + , withClickableVScrollBars + , withDefAttr + , withVScrollBarHandles + , withVScrollBars + ) +import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime) +import System.FilePath (isAbsolute) + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Graphics.Vty.Attributes qualified as Attr +import Graphics.Vty.Attributes.Color qualified as Color + +import Tricorder.Build (BuildPhase, BuildResult, BuildState, Diagnostic, Severity (..)) +import Tricorder.CLI.UI.Keys (KeyEvent, keybindForRoute, viewKeybindings) +import Tricorder.CLI.UI.Misc (emphasis, err, hBoxSpaced, ok, subtle, vBoxSpaced, warn) +import Tricorder.CLI.UI.Route (Route) +import Tricorder.CLI.UI.State (Processed (..), State (..), TestFilter (..), Viewports (..), currentRoute) +import Tricorder.Daemon.DaemonInfo (DaemonInfo (..)) +import Tricorder.Session.Target (Target, renderTarget) +import Tricorder.Session.TestTarget (TestTarget, renderTestTarget) +import Tricorder.TestOutput (stripGhciNoise) + +import Tricorder.Build qualified as Build +import Tricorder.Build.EvalComment qualified as Eval +import Tricorder.Build.Test qualified as Test +import Tricorder.CLI.UI.Keys qualified as Keys +import Tricorder.CLI.UI.Route qualified as Route +import Tricorder.Version qualified as Version + + +mkAttrMap :: State -> AttrMap +mkAttrMap = + const + ( attrMap + Attr.defAttr + [ (attrName "ok", Attr.withForeColor Attr.defAttr Color.green) + , (attrName "warning", Attr.withForeColor Attr.defAttr Color.yellow) + , (attrName "error", Attr.withForeColor Attr.defAttr Color.red) + , (attrName "emphasis", Attr.withStyle Attr.defAttr Attr.bold) + , (attrName "subtle", Attr.withForeColor Attr.defAttr $ Color.rgbColor @Int 148 148 148) + ] + ) + + +view :: KeyConfig KeyEvent -> State -> [Widget Viewports] +view kc ws = + [ vBoxSpaced + 1 + [ vBox + [ viewAppHeader ws + , viewTabs kc ws + ] + , case currentRoute ws of + Route.Help -> + viewHelp kc + Route.DaemonInfo -> + viewDaemonInfo ws + Route.Tests -> + viewTests ws + Route.Main -> + viewMain ws + Route.Evals -> + viewEvals ws + ] + ] + + +viewTabs :: KeyConfig KeyEvent -> State -> Widget n +viewTabs kc ws = + hBoxSpaced 1 + $ intersperse (subtle $ txt "-") + $ viewRouteTab kc ws <$> universe @Route + + +viewRouteTab :: KeyConfig KeyEvent -> State -> Route -> Widget n +viewRouteTab kc ws route = + style $ txt $ Route.name route <> keyBind + where + style = if route == currentRoute ws then id else subtle + showBinding = (" " <>) . ("[" <>) . (<> "]") . ppBinding + keyBind = maybe "" showBinding $ keybindForRoute kc route + + +viewDaemonInfo :: State -> Widget Viewports +viewDaemonInfo ws = + withBuildState ws (viewExpandedDaemonInfo . (.daemonInfo)) + + +viewTests :: State -> Widget Viewports +viewTests ws = + withBuildState ws (viewTestResultsPanel ws) + + +viewEvals :: State -> Widget Viewports +viewEvals ws = + withBuildState ws $ viewEvalCommentsPanel ws + + +viewMain :: State -> Widget Viewports +viewMain ws = withBuildState ws (viewDefaultPanel ws.timeZone) + + +viewHelp :: KeyConfig KeyEvent -> Widget n +viewHelp kc = viewKeybindings kc handlers + where + -- The dispatcher is built only to enumerate handler descriptions for the help + -- view, so the restart action is a no-op here. + handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher (pure ()) kc) + + +withBuildState :: State -> (BuildState -> Widget Viewports) -> Widget Viewports +withBuildState ws render = + case ws.buildState of + Waiting -> + txt "Waiting for build..." + Failure reason -> + txt $ "Error when contacting daemon: " <> reason + Success bs -> + render bs + + +viewAppHeader :: State -> Widget n +viewAppHeader ws = + ok + $ emphasis + $ txt + $ "Tricorder" + <> maybe + "" + (" - " <>) + (viewHeading ws) + + +viewHeading :: State -> Maybe Text +viewHeading ws = case currentRoute ws of + Route.Tests -> case ws.testFilter of + TestFilterAll -> Just "Tests" + TestFilterFailedOnly -> Just "Tests - Failed only" + Route.Help -> Just "Help" + Route.DaemonInfo -> Just "Daemon info" + Route.Main -> Nothing + Route.Evals -> Just "Eval comments" + + +viewDefaultPanel :: TimeZone -> BuildState -> Widget Viewports +viewDefaultPanel tz bs = viewBuildPhase tz bs.phase + + +viewTestResultsPanel :: State -> BuildState -> Widget Viewports +viewTestResultsPanel ws bs = + vBoxSpaced + 1 + [ viewBuildPhaseLine ws.timeZone bs.phase + , viewTestPanel ws.testFilter (phaseTestRuns bs.phase) + ] + + +viewEvalCommentsPanel :: State -> BuildState -> Widget Viewports +viewEvalCommentsPanel ws bs = + vBoxSpaced + 1 + [ viewBuildPhaseLine ws.timeZone bs.phase + , case bs.phase of + Build.Finished _ postBuild -> viewEvalComments postBuild.evalComments + Build.PostBuilding _ postBuild -> viewEvalComments postBuild.evalComments + _ -> txt "Waiting for build..." + ] + + +viewEvalComments :: Eval.Phase -> Widget Viewports +viewEvalComments Eval.Looking = txt "Looking for eval comments..." +viewEvalComments Eval.NoneFound = txt "No eval comments detected" +viewEvalComments (Eval.Found (Eval.Comments results)) = + vScrollViewport EvalResultsViewport + $ vBoxSpaced 1 + $ toList + $ viewEvaluation <$> results + + +viewEvaluation :: Eval.Evaluation -> Widget n +viewEvaluation evaluation = + vBox + $ [ hBoxSpaced + 1 + [ subtle $ txt "File:" + , txt $ toText evaluation.file <> ":" <> show evaluation.comment.lineNumber + ] + , subtle $ txt "Expression:" + , txt evaluation.comment.expression + ] + <> case evaluation.state of + Eval.Completed output -> + [ subtle $ txt "Result:" + , vBox $ txt <$> T.lines output + ] + Eval.Pending -> + [ subtle $ txt "Running..." + ] + + +viewExpandedDaemonInfo :: DaemonInfo -> Widget n +viewExpandedDaemonInfo di = + vBox + [ viewVersion + , viewTargets di.targets + , viewWatchDirs di.watchDirs + , viewSockPath di.sockPath + , viewLogFile di.logFile + ] + + +viewVersion :: Widget n +viewVersion = + hBoxSpaced + 1 + [ emphasis $ txt "Client version:" + , txt Version.gitHash + ] + + +viewTargets :: [Target] -> Widget n +viewTargets targets = + hBoxSpaced + 1 + [ emphasis $ txt "Targets:" + , if null targets then + txt "(all)" + else + txtWrap (T.intercalate " " (map renderTarget targets)) + ] + + +viewLogFile :: FilePath -> Widget n +viewLogFile p = hBoxSpaced 1 [emphasis $ txt "Log:", txt $ toText p] + + +viewSockPath :: FilePath -> Widget n +viewSockPath sockPath = + hBoxSpaced 1 [emphasis $ txt "Socket:", txt $ toText sockPath] + + +viewWatchDirs :: [FilePath] -> Widget n +viewWatchDirs watchDirs = + vBox + [ emphasis $ txt "Watching:" + , padLeft (Pad 2) + $ vBox + $ viewWatchDir <$> watchDirs + ] + + +viewWatchDir :: FilePath -> Widget n +viewWatchDir dir = hBox [txt "- ", txt $ toText displayDir] + where + displayDir + | isAbsolute dir = dir + | dir == "." = "./" + | otherwise = "./" <> dir + + +viewBuildPhase :: TimeZone -> BuildPhase -> Widget Viewports +viewBuildPhase tz = \case + Build.Starting -> + warn $ txt "Starting..." + Build.Building testTargets phase -> + vBoxSpaced + 1 + [ warn $ txt $ "Building (" <> show phase.compiled <> "/" <> show phase.total <> ")..." + , viewPendingTestTargets testTargets + ] + Build.PostBuilding result postBuild -> + vBoxSpaced + 1 + [ viewBuildResult tz result + , viewTestRuns postBuild.testSuites + ] + Build.Finished result postBuild -> + vBoxSpaced + 1 + [ viewBuildResult tz result + , viewTestRuns postBuild.testSuites + ] + Build.Failed msg -> + viewBuildFailed msg + + +viewPendingTestTargets :: [TestTarget] -> Widget n +viewPendingTestTargets = + vBox + . ([txt "Pending test suites:"] <>) + . fmap (subtle . txt . renderTestTarget) + + +viewBuildFailed :: Text -> Widget Viewports +viewBuildFailed msg = + vBox + [ err $ txt "Build command failed" + , vScrollViewport DiagnosticViewport (vBox $ txtWrap <$> T.lines msg) + ] + + +-- | A vertically-scrollable viewport with clickable scrollbars on the right. +vScrollViewport :: (Ord vp, Show vp) => vp -> Widget vp -> Widget vp +vScrollViewport vp = + withClickableVScrollBars (\_ _ -> vp) + . withVScrollBarHandles + . withVScrollBars OnRight + . viewport vp Vertical + + +viewBuildResult :: TimeZone -> BuildResult -> Widget Viewports +viewBuildResult tz result + | null result.diagnostics = + hBoxSpaced + 1 + [ ok $ txt "All good." + , viewBuildSummary result.moduleCount result.duration + , viewTimestamp tz result.completedAt + ] + | otherwise = + let msgs = result.diagnostics + errCount = length $ filter (\m -> m.severity == SError) msgs + warnCount = length $ filter (\m -> m.severity == SWarning) msgs + header = + if errCount > 0 then + err $ txt $ show errCount <> " error(s), " <> show warnCount <> " warning(s)" + else + warn $ txt $ show warnCount <> " warning(s)" + in vBoxSpaced + 1 + [ hBoxSpaced + 1 + [ header + , viewDuration result.duration + , viewTimestamp tz result.completedAt + ] + , vScrollViewport DiagnosticViewport $ vBox $ viewDiagnostic <$> msgs + ] + + +viewDiagnostic :: Diagnostic -> Widget n +viewDiagnostic m = + vBox + [ hBoxSpaced + 1 + [ severityLabel + , txt $ toText loc + ] + , txtWrap m.text + ] + where + loc = m.file <> ":" <> show m.line <> ":" <> show m.col + severityLabel = withDefAttr (severityToAttrName m.severity) $ txt $ case m.severity of + SError -> "error:" + SWarning -> "warning:" + + +severityToAttrName :: Severity -> AttrName +severityToAttrName SError = attrName "error" +severityToAttrName SWarning = attrName "warning" + + +viewDuration :: Millisecond -> Widget n +viewDuration d = txt $ "(" <> formatDuration d <> ")" + + +viewTestRuns :: Test.Suites -> Widget n +viewTestRuns suites = vBox $ uncurry viewTestRun <$> Map.toList suites.getSuites + + +viewTestRun :: TestTarget -> Test.Suite -> Widget n +viewTestRun tgt run = + hBox $ [txt $ renderTestTarget tgt, txt " "] <> status + where + status = case run of + Test.SuiteRunning Nothing -> + [ warn $ txt "running..." + ] + Test.SuiteRunning (Just p) -> + [ warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")" + ] + Test.SuiteErrored e -> + [ err $ txt "error: " + , txt e.message + ] + Test.SuiteCompleted c -> + [ viewCompletionStatus c + ] + + +viewCompletionStatus :: Test.SuiteCompletion -> Widget n +viewCompletionStatus c = case c.duration of + Nothing -> statusWidget + Just d -> hBoxSpaced 1 [statusWidget, subtle $ viewDuration d] + where + statusWidget + | null c.testCases = if c.passed then ok (txt "passed") else err (txt "failed") + | otherwise = + let total = length c.testCases + failed = length $ filter Test.caseFailed c.testCases + in if failed == 0 then + ok $ txt $ "passed (" <> show total <> ")" + else + err $ txt $ show failed <> "/" <> show total <> " failed" + + +viewTimestamp :: TimeZone -> UTCTime -> Widget n +viewTimestamp tz t = txt $ "— " <> toText (formatTime defaultTimeLocale "%H:%M:%S" $ utcToLocalTime tz t) + + +viewBuildSummary :: Int -> Millisecond -> Widget n +viewBuildSummary moduleCount duration = + txt $ "(" <> show moduleCount <> " modules, " <> formatDuration duration <> ")" + + +formatDuration :: Millisecond -> Text +formatDuration d = + let ms = toMicroseconds d `div` 1000 + in if ms < 1000 then + show ms <> "ms" + else + show (ms `div` 1000) <> "." <> show ((ms `mod` 1000) `div` 100) <> "s" + + +-- | Single-line build status with no scrollable diagnostics list, used as a +-- compact header when a secondary panel (test results, daemon info) is open. +viewBuildPhaseLine :: TimeZone -> BuildPhase -> Widget n +viewBuildPhaseLine tz = \case + Build.Starting -> + warn $ txt "Starting..." + Build.Building _ phase -> + warn $ txt $ "Building (" <> show phase.compiled <> "/" <> show phase.total <> ")..." + Build.PostBuilding result _ -> + viewBuildResultLine tz result + Build.Finished result _ -> + viewBuildResultLine tz result + Build.Failed _ -> + err $ txt "Build command failed" + + +viewBuildResultLine :: TimeZone -> BuildResult -> Widget n +viewBuildResultLine tz result + | null result.diagnostics = + hBoxSpaced + 1 + [ ok $ txt "All good." + , viewBuildSummary result.moduleCount result.duration + , viewTimestamp tz result.completedAt + ] + | otherwise = + let errCount = length $ filter (\m -> m.severity == SError) result.diagnostics + warnCount = length $ filter (\m -> m.severity == SWarning) result.diagnostics + header = + if errCount > 0 then + err $ txt $ show errCount <> " error(s), " <> show warnCount <> " warning(s)" + else + warn $ txt $ show warnCount <> " warning(s)" + in hBoxSpaced 1 [header, viewDuration result.duration, viewTimestamp tz result.completedAt] + + +phaseTestRuns :: BuildPhase -> Test.Suites +phaseTestRuns (Build.PostBuilding _ postBuild) = postBuild.testSuites +phaseTestRuns (Build.Finished _ postBuild) = postBuild.testSuites +phaseTestRuns _ = Test.Suites mempty + + +viewTestPanel :: TestFilter -> Test.Suites -> Widget Viewports +viewTestPanel tvf suites + | Test.nullSuites suites = subtle $ txt "No test results." + | otherwise = scrollableRuns tvf suites + + +scrollableRuns :: TestFilter -> Test.Suites -> Widget Viewports +scrollableRuns tvf suites = + vScrollViewport TestViewport + $ vBox + $ uncurry (viewTestRunDetail tvf) <$> Map.toList suites.getSuites + + +viewTestRunDetail :: TestFilter -> TestTarget -> Test.Suite -> Widget n +viewTestRunDetail tvf tgt = \case + Test.SuiteRunning Nothing -> + hBox + [ txt t + , txt " " + , warn $ txt "running..." + ] + Test.SuiteRunning (Just p) -> + hBox + [ txt t + , txt " " + , warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")" + ] + Test.SuiteErrored e -> + hBoxSpaced + 1 + [ txt t + , err $ txt "error:" + , txt e.message + ] + Test.SuiteCompleted c -> + vBox + [ hBox [txt $ t <> " ", viewCompletionStatus c] + , viewTestOutput tvf c + ] + where + t = renderTestTarget tgt + + +viewTestOutput :: TestFilter -> Test.SuiteCompletion -> Widget n +viewTestOutput TestFilterAll c = + padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output) +viewTestOutput TestFilterFailedOnly c + | not (any Test.caseFailed c.testCases) && c.passed = emptyWidget + | null c.testCases = + padLeft (Pad 2) + $ vBox + [ subtle $ txt "(unrecognised test runner — showing full output)" + , vBox $ txt <$> stripGhciNoise (T.lines c.output) + ] + | otherwise = + padLeft (Pad 2) $ vBox $ viewFailedCase <$> filter Test.caseFailed c.testCases + + +viewFailedCase :: Test.Case -> Widget n +viewFailedCase tc = + vBox + [ err $ txt tc.description + , case tc.outcome of + Test.Failed details -> padLeft (Pad 2) $ txtWrap details + Test.Passed -> emptyWidget + ] diff --git a/src/Tricorder/Config.hs b/src/Tricorder/Config.hs --- a/src/Tricorder/Config.hs +++ b/src/Tricorder/Config.hs @@ -1,22 +1,17 @@ module Tricorder.Config ( LoadedConfig (..) , runLoadedConfig - , restartOnConfigChange + , inputLoadedConfig + , configFileName ) where import Atelier.Config (LoadedConfig (..)) -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.Debounce (Debounce) import Atelier.Effects.FileSystem (FileSystem) -import Atelier.Effects.FileWatcher (FileWatcher) -import Data.List (isSuffixOf) -import Effectful.Concurrent.MVar (Concurrent, newEmptyMVar, putMVar, takeMVar) +import Atelier.Effects.Input (Input, runInputEff) import Effectful.Reader.Static (Reader, ask, runReader) import System.FilePath (()) -import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.FileSystem qualified as FileSystem -import Atelier.Effects.FileWatcher qualified as FileWatcher import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KM import Data.Yaml qualified as Yaml @@ -55,27 +50,11 @@ runReader cfg act -restartOnConfigChange - :: ( Conc :> es - , Concurrent :> es - , Debounce FilePath :> es - , FileWatcher :> es +inputLoadedConfig + :: ( FileSystem :> es , Reader ProjectRoot :> es ) - => Eff es a -> Eff es a -restartOnConfigChange act = do + => Eff (Input LoadedConfig : es) a -> Eff es a +inputLoadedConfig = runInputEff do ProjectRoot projectRoot <- ask - ref <- newEmptyMVar - var <- Conc.scoped do - void $ Conc.fork do - res <- act - putMVar ref $ Just res - - Conc.fork_ $ FileWatcher.watchFilePathsDebounced - [FileWatcher.dirWhere projectRoot (configFileName `isSuffixOf`)] - \_ _ -> putMVar ref Nothing - - takeMVar ref - case var of - Nothing -> restartOnConfigChange act - Just x -> pure x + loadTricorderConfig projectRoot diff --git a/src/Tricorder/Daemon.hs b/src/Tricorder/Daemon.hs deleted file mode 100644 --- a/src/Tricorder/Daemon.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Tricorder.Daemon - ( startDaemon - , stopDaemon - , waitForDaemon - ) where - -import Atelier.Effects.Delay (Delay) -import Atelier.Effects.File (File) -import Atelier.Effects.Posix.Daemons (Daemons) -import Atelier.Time (Millisecond) -import Effectful (IOE) -import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet) -import Effectful.Reader.Static (Reader, ask) -import Effectful.Timeout (Timeout, timeout) -import Effectful.Writer.Static.Local (runWriter, tell) - -import Atelier.Effects.Delay qualified as Delay -import Atelier.Effects.Posix.Daemons qualified as Daemons - -import Tricorder.Effects.UnixSocket (UnixSocket) -import Tricorder.Runtime (PidFile, SocketPath (..)) -import Tricorder.Socket.Client (isDaemonRunning, requestShutdown) - -import Tricorder.Daemon.Main qualified as Daemon.Main - - -startDaemon - :: ( Daemons :> es - , IOE :> es - , Reader PidFile :> es - ) - => Eff es () -startDaemon = do - pidFile <- ask - Daemons.daemonize pidFile $ liftIO Daemon.Main.main - - --- | Attempts to stop the daemon in progressively more forceful ways. --- 1. First attempts to make the daemon stop using the API. --- 2. Then attempts to stop the daemon by sending `SIGKILL` to its process. -stopDaemon - :: ( Daemons :> es - , Delay :> es - , File :> es - , Reader PidFile :> es - , Reader SocketPath :> es - , Timeout :> es - , UnixSocket :> es - ) - => Eff es (Either [Text] Text) -stopDaemon = do - SocketPath sockPath <- ask - pidFile <- ask - res <- - runWriter @[Text] - $ fmap rightToMaybe - $ runNonDet OnEmptyKeep - $ requestStop sockPath pidFile - <|> sendKill pidFile - case res of - (Just r, _) -> pure $ Right r - (Nothing, es) -> pure $ Left es - where - requestStop sockPath pidFile = do - timeout1second (requestShutdown sockPath) >>= \_ -> do - didStop <- fmap isJust $ timeout 3_000_000 $ waitForStop pidFile - if didStop then - pure "Daemon stopped." - else do - tell ["Daemon did not stop as requested."] - emptyEff - - sendKill pidFile = do - timeout1second (Daemons.forceKillAndWait pidFile) >>= \case - Nothing -> pure "Daemon stopped with SIGKILL." - Just ex -> do - tell ["Daemon did not respond to SIGKILL: " <> show ex] - emptyEff - - timeout1second = fmap (join . fmap rightToMaybe) . timeout 1_000_000 - - waitForStop :: forall es'. (Daemons :> es', Delay :> es') => PidFile -> Eff es' () - waitForStop pidFile = fix \rec -> do - running <- Daemons.isRunning pidFile - if running then do - Delay.wait (500 :: Millisecond) - rec - else - pure () - - --- | Poll until the daemon socket becomes connectable. -waitForDaemon :: (Daemons :> es, Delay :> es, Reader PidFile :> es, UnixSocket :> es) => Eff es () -waitForDaemon = do - Delay.wait (200 :: Millisecond) - running <- isDaemonRunning - unless running waitForDaemon diff --git a/src/Tricorder/Daemon/Builder.hs b/src/Tricorder/Daemon/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/Builder.hs @@ -0,0 +1,191 @@ +module Tricorder.Daemon.Builder + ( Builder (..) + , NewLoadResult (..) + , BuildConsideration (..) + , BuildFailure (..) + , build + , consider + , with + , compileBuildResults + ) where + +import Atelier.Effects.Clock (Clock, UTCTime) +import Atelier.Effects.FileWatcher (FileEvent) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Publishing.Pub (Pub) +import Atelier.Time (Millisecond, nominalDiffTime) +import Data.Time (diffUTCTime) +import Effectful (Effect, inject) +import Effectful.Dispatch.Dynamic (reinterpretWith_) +import Effectful.Exception (trySync) +import Effectful.Reader.Static (Reader, ask) +import Effectful.State.Static.Shared (State, get, modify) +import Effectful.TH (makeEffect) +import System.FilePath (normalise) + +import Atelier.Effects.Clock qualified as Clock +import Atelier.Effects.Log qualified as Log +import Atelier.Effects.Publishing.Pub qualified as Pub +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Effectful.State.Static.Shared qualified as State + +import Tricorder.Build (BuildId (..), BuildProgress, BuildResult (..), Diagnostic (..)) +import Tricorder.Daemon.Dispatch + ( BuilderState (..) + , DiagnosticMap + , DispatchAction (..) + , KnownTargetNames (..) + , dispatch + , emptyBuilderState + , filterToWatchDirs + , mergeDiagnostics + , preserveFailureVisibility + ) +import Tricorder.Daemon.GhciSession (GhciSession, LoadResult (..)) +import Tricorder.Daemon.GhciSession.GhciParser (resolveKnownTargets) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Command (Command) +import Tricorder.Session.WatchDirs (WatchDirs) + +import Tricorder.Daemon.GhciSession qualified as GhciSession + + +data Builder :: Effect where + Consider :: FilePath -> FileEvent -> Builder m BuildConsideration + Build :: DispatchAction -> Builder m (Either BuildFailure NewLoadResult) + + +data BuildConsideration + = SkipBuilding + | ShouldBuild DispatchAction + + +data BuildFailure + = ReloadFailed SomeException + deriving stock (Show) + + +data NewLoadResult = NewLoadResult + { startTime :: UTCTime + , endTime :: UTCTime + , loadResult :: LoadResult + } + deriving stock (Eq, Show) + + +makeEffect ''Builder + + +with + :: ( Clock :> es + , GhciSession :> es + , Log :> es + , Pub BuildProgress :> es + , Reader ProjectRoot :> es + ) + => BuildId + -> Command + -> WatchDirs + -> (BuilderState -> NewLoadResult -> Eff (Builder : es) a) + -> Eff es (Either SomeException a) +with buildId command watchDirs action = do + root <- ask + startTime <- Clock.currentTime + trySync $ GhciSession.withGhciWith Pub.publish command root \initialLoad controls -> do + endTime <- Clock.currentTime + let filteredMsgs = filterToWatchDirs root.getProjectRoot watchDirs initialLoad.diagnostics + Log.info + $ mconcat + [ "GHCi started (session #" + , show buildId.getBuildId + , "): " + , show (length filteredMsgs) + , " diagnostics" + ] + let initialLoadResult = NewLoadResult {startTime, endTime, loadResult = initialLoad} + let initialBuilderState = + emptyBuilderState + { loadedModules = resolveKnownTargets Map.empty initialLoad + , knownTargets = KnownTargetNames (Set.fromList initialLoad.targetNames) + } + reinterpretWith_ + (State.evalState initialBuilderState) + (action initialBuilderState initialLoadResult) + \case + Consider fp event -> considerBuild fp event + Build dispatchAction -> + buildSource (GhciSession.transformControls inject controls) dispatchAction + + +considerBuild + :: (State BuilderState :> es) + => FilePath + -> FileEvent + -> Eff es BuildConsideration +considerBuild fp event = do + builderState <- get + let known = Map.lookup (normalise fp) builderState.loadedModules + case dispatch builderState.knownTargets known fp event of + Nothing -> + -- File not loaded in GHCi, so we skip building. + pure SkipBuilding + Just action -> do + pure $ ShouldBuild action + + +buildSource + :: (Clock :> es, State BuilderState :> es) + => GhciSession.Controls (Eff es) + -> DispatchAction + -> Eff es (Either BuildFailure NewLoadResult) +buildSource controls action = do + res <- trySync do + startTime <- Clock.currentTime + res <- runAction controls action + endTime <- Clock.currentTime + pure (startTime, endTime, res) + + case res of + Left e -> do + pure $ Left $ ReloadFailed e + Right (startTime, endTime, loadResult) -> do + modify \s -> + s + { loadedModules = resolveKnownTargets s.loadedModules loadResult + , knownTargets = KnownTargetNames (Set.fromList loadResult.targetNames) + } + pure $ Right $ NewLoadResult {startTime, endTime, loadResult} + + +compileBuildResults + :: ProjectRoot + -> WatchDirs + -> DiagnosticMap + -> NewLoadResult + -> (DiagnosticMap, BuildResult) +compileBuildResults (ProjectRoot projectRoot) watchDirs diagnosticMap newLoadResult = + (merged, buildResult) + where + NewLoadResult {startTime, endTime, loadResult} = newLoadResult + merged = mergeDiagnostics diagnosticMap filteredResult + filteredResult = + loadResult + { GhciSession.diagnostics = + preserveFailureVisibility loadResult.diagnostics + $ filterToWatchDirs projectRoot watchDirs loadResult.diagnostics + } + buildResult = + BuildResult + { completedAt = endTime + , duration = nominalDiffTime (diffUTCTime endTime startTime) :: Millisecond + , moduleCount = loadResult.moduleCount + , diagnostics = sortOn (\d -> (d.severity, d.file, d.line, d.col)) $ concat $ Map.elems merged + } + + +runAction :: GhciSession.Controls (Eff es) -> DispatchAction -> Eff es LoadResult +runAction controls = \case + Reload -> controls.reload + Add fp -> controls.add fp + Unadd mn -> controls.unadd mn diff --git a/src/Tricorder/Daemon/Core.hs b/src/Tricorder/Daemon/Core.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/Core.hs @@ -0,0 +1,392 @@ +module Tricorder.Daemon.Core (main) where + +import Atelier.Config (LoadedConfig) +import Atelier.Effects.Chan (Chan) +import Atelier.Effects.Clock (Clock) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Debounce (Debounce) +import Atelier.Effects.FileSystem (FileSystem) +import Atelier.Effects.FileWatcher (FileEvent, FileWatcher) +import Atelier.Effects.Input (Input) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Publishing (runPubSub_) +import Atelier.Effects.Publishing.Pub (Pub) +import Atelier.Effects.Publishing.Sub (Sub) +import Data.List (isSuffixOf) +import Effectful.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) +import Effectful.Concurrent.STM (Concurrent, atomically, newEmptyTMVar, takeTMVar, writeTMVar) +import Effectful.Reader.Static (Reader) +import Effectful.State.Static.Shared (State) +import Relude.Extra.Tuple (dup) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.FileWatcher qualified as FileWatcher +import Atelier.Effects.Log qualified as Log +import Atelier.Effects.Publishing.Pub qualified as Pub +import Atelier.Effects.Publishing.Sub qualified as Sub +import Data.Map.Strict qualified as Map +import Effectful.Reader.Static qualified as Reader +import Effectful.State.Static.Shared qualified as State + +import Tricorder.Build (BuildId, BuildPhase, BuildResult, PostBuild (..), Severity (..)) +import Tricorder.Build.Changes (CabalChangeDetected (..), SourceChangeDetected (..)) +import Tricorder.Daemon.Builder + ( BuildConsideration (..) + , BuildFailure + , Builder + , NewLoadResult + , compileBuildResults + ) +import Tricorder.Daemon.Dispatch + ( BuilderState (..) + , DispatchAction + , emptyBuilderState + ) +import Tricorder.Daemon.EvalCommentRunner + ( EvalCommentRunner + , findEvalCommentsInModules + ) +import Tricorder.Daemon.GhciSession (GhciSession) +import Tricorder.Daemon.GhciSession.GhciParser + ( LoadResult + , LoadedModule (..) + , resolveKnownTargets + ) +import Tricorder.Daemon.TestRunner (TestRunner) +import Tricorder.Daemon.Watch (WatchedFile) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session (Session (..), loadSession) +import Tricorder.Session.CabalFile (CabalFile) +import Tricorder.Session.TestTarget (TestTarget, renderTestTarget) +import Tricorder.Session.TestTimeout (TestTimeout) +import Tricorder.Waiters (Waiters) + +import Tricorder.Build qualified as Build +import Tricorder.Build.EvalComment qualified as Eval +import Tricorder.Build.Test qualified as Test +import Tricorder.Config qualified as Config +import Tricorder.Daemon.Builder qualified as Builder +import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner +import Tricorder.Daemon.TestRunner qualified as TestRunner +import Tricorder.Daemon.Watch qualified as Watch +import Tricorder.Waiters qualified as Waiters + + +data ReloadSession = ReloadSession +data RestartBuilder = RestartBuilder +data ReloadBuilder = ReloadBuilder FilePath FileEvent + + +-- | Top of the build loop. Responsible for handling changes to the Tricorder +-- config, as well as setting up other build-specific effects. +main + :: ( Chan :> es + , Clock :> es + , Conc :> es + , Concurrent :> es + , Debounce FilePath :> es + , EvalCommentRunner :> es + , FileSystem :> es + , FileWatcher :> es + , GhciSession :> es + , Input LoadedConfig :> es + , Input [CabalFile] :> es + , Log :> es + , Pub BuildPhase :> es + , Reader ProjectRoot :> es + , State BuildId :> es + , TestRunner :> es + , Waiters :> es + ) + => Eff es Void +main = runPubSub_ @ReloadSession + . runPubSub_ @WatchedFile + . runPubSub_ @CabalChangeDetected + . runPubSub_ @SourceChangeDetected + . runPubSub_ @RestartBuilder + . runPubSub_ @ReloadBuilder + $ Conc.restartableFork waitForReloadSession do + root <- Reader.ask + session <- loadSession + Conc.fork_ $ watchConfigFile root + + Conc.fork_ $ Watch.files root session + Conc.fork_ $ Sub.listen_ Watch.publishChange + + Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) -> do + needsSessionReload <- shouldReloadSession session + if needsSessionReload then + Pub.publish ReloadSession + else + Pub.publish RestartBuilder + Conc.fork_ $ Sub.listen_ \(SourceChangeDetected fp event) -> + Pub.publish $ ReloadBuilder fp event + + State.evalState emptyBuilderState $ withSession session + where + waitForReloadSession = Waiters.wait $ Sub.listenOnce_ @ReloadSession + + +shouldReloadSession + :: ( FileSystem :> es + , Input LoadedConfig :> es + , Input [CabalFile] :> es + , Log :> es + , Reader ProjectRoot :> es + ) + => Session -> Eff es Bool +shouldReloadSession oldSession = do + newSession <- loadSession + pure $ newSession /= oldSession + + +watchConfigFile + :: ( Debounce FilePath :> es + , FileWatcher :> es + , Pub ReloadSession :> es + ) + => ProjectRoot -> Eff es Void +watchConfigFile root = do + FileWatcher.watchFilePathsDebounced + [FileWatcher.dirWhere root.getProjectRoot (Config.configFileName `isSuffixOf`)] + \_ _ -> Pub.publish $ ReloadSession + + +-- | For a given session, handles controlling the build process itself, +-- restarting it as necessary. +withSession + :: ( Clock :> es + , Conc :> es + , Concurrent :> es + , EvalCommentRunner :> es + , GhciSession :> es + , Log :> es + , Pub BuildPhase :> es + , Reader ProjectRoot :> es + , State BuildId :> es + , State BuilderState :> es + , Sub ReloadBuilder :> es + , Sub RestartBuilder :> es + , TestRunner :> es + , Waiters :> es + ) + => Session -> Eff es Void +withSession session = do + Conc.restartableFork (Waiters.wait $ Sub.listenOnce_ @RestartBuilder) do + buildId <- State.state (\s -> (s, s + 1)) + runSession buildId session + + +-- | Starts the initial build with GHCi, and waits for source changes. +runSession + :: ( Clock :> es + , Conc :> es + , Concurrent :> es + , EvalCommentRunner :> es + , GhciSession :> es + , Log.Log :> es + , Pub BuildPhase :> es + , Reader ProjectRoot :> es + , State BuilderState :> es + , Sub ReloadBuilder :> es + , TestRunner :> es + , Waiters :> es + ) + => BuildId -> Session -> Eff es () +runSession buildId session = do + Log.info $ "Starting session " <> show buildId.getBuildId + Pub.publish Build.Starting + startupError <- fmap (either id absurd) + $ Pub.map (Build.Building session.testTargets) + $ Builder.with buildId session.command session.watchDirs \_ initialLoad -> do + processPostBuild session $ Right initialLoad + Log.debug "Waiting for reload" + newestReloadEvent <- atomically newEmptyTMVar + cancelSem <- newEmptyMVar + let requestCancel = tryPutMVar cancelSem () + checkCancel = takeMVar cancelSem + Conc.fork_ $ Sub.listen_ @ReloadBuilder \event -> do + atomically $ writeTMVar newestReloadEvent event + Waiters.without do + Pub.publish Build.Starting + Log.debug "Cancelling current build" + requestCancel + forever do + event <- atomically $ takeTMVar newestReloadEvent + Conc.restartableFork checkCancel + $ waitForReload session event + + Pub.publish $ Build.Failed $ show startupError + + +-- | Handles source changes as they come, determining whether the source change +-- detected warrants a rebuild. +waitForReload + :: ( Builder :> es + , Conc :> es + , EvalCommentRunner :> es + , Log :> es + , Pub BuildPhase :> es + , Reader ProjectRoot :> es + , State BuilderState :> es + , TestRunner :> es + ) + => Session -> ReloadBuilder -> Eff es () +waitForReload session (ReloadBuilder fp event) = do + Log.debug $ "Considering " <> toText fp + consideration <- Builder.consider fp event + case consideration of + SkipBuilding -> do + Log.debug $ "Skipping " <> toText fp + pure () + ShouldBuild action -> do + Log.debug $ "Should build " <> toText fp + processSource session action + Log.info "Reload finished" + + +-- | Rebuilds the project on source change. +processSource + :: ( Builder :> es + , Conc :> es + , EvalCommentRunner :> es + , Log :> es + , Pub BuildPhase :> es + , Reader ProjectRoot :> es + , State BuilderState :> es + , TestRunner :> es + ) + => Session + -> DispatchAction + -> Eff es () +processSource session action = do + res <- Builder.build action + Log.debug "Finished build" + processPostBuild session res + + +processPostBuild + :: ( Conc :> es + , EvalCommentRunner :> es + , Log :> es + , Pub BuildPhase :> es + , Reader ProjectRoot :> es + , State BuilderState :> es + , TestRunner :> es + ) + => Session -> Either BuildFailure NewLoadResult -> Eff es () +processPostBuild session = \case + Left buildFailure -> do + Log.debug "Build failure" + Pub.publish $ Build.Failed $ show buildFailure + Right newLoadResult -> do + Log.debug "Built" + buildResult <- newLoadResultToBuildResult session newLoadResult + let initialPostBuild = PostBuild mempty Eval.Looking + Pub.publish $ Build.PostBuilding buildResult initialPostBuild + State.evalState initialPostBuild $ Conc.scoped do + evalCommentsP <- + Conc.fork + $ Pub.consume (updateEvalComments buildResult) + $ runEvalComments session newLoadResult.loadResult + testsP <- + Conc.fork + $ Pub.consume (updateTestSuites buildResult) + $ runTests session buildResult + evalComments <- Conc.await evalCommentsP + Log.debug "Eval comments finished" + tests <- Conc.await testsP + Log.debug "Tests finished" + Pub.publish $ Build.Finished buildResult $ PostBuild tests evalComments + where + updateEvalComments buildResult evalComments = do + newPostBuild <- State.state \postBuild -> dup $ postBuild {evalComments} + Pub.publish $ Build.PostBuilding buildResult newPostBuild + updateTestSuites buildResult testSuites = do + newPostBuild <- State.state \postBuild -> dup $ postBuild {testSuites} + Pub.publish $ Build.PostBuilding buildResult newPostBuild + + +runEvalComments + :: ( EvalCommentRunner :> es + , Pub Eval.Phase :> es + , State BuilderState :> es + ) + => Session -> LoadResult -> Eff es Eval.Phase +runEvalComments session loadResult = do + builderState <- State.get @BuilderState + evalComments <- findEvalCommentsInModules $ resolveKnownTargets builderState.loadedModules loadResult + + case nonEmpty evalComments of + Nothing -> pure Eval.NoneFound + Just nonEmptyComments -> do + let pendingComments = + sconcat $ (\(lm, ecs) -> toPending lm.relPath <$> ecs) <$> nonEmptyComments + Pub.publish $ Eval.Found $ Eval.Comments pendingComments + evaluatedComments <- EvalCommentRunner.evaluateComments session.command nonEmptyComments + pure $ Eval.Found $ Eval.Comments evaluatedComments + where + toPending file comment = + Eval.Evaluation + { file + , comment + , state = Eval.Pending + } + + +runTests + :: ( Log :> es + , Pub Test.Suites :> es + , TestRunner :> es + ) + => Session -> BuildResult -> Eff es Test.Suites +runTests session buildResult + | hasTargets session.testTargets && noErrors buildResult.diagnostics = + runTestsForTargets session.testTimeout session.testTargets + | otherwise = pure mempty + where + hasTargets = not . null + noErrors = all \d -> d.severity /= SError + + +runTestsForTargets + :: ( Log :> es + , Pub Test.Suites :> es + , TestRunner :> es + ) + => TestTimeout + -> [TestTarget] + -> Eff es Test.Suites +runTestsForTargets testTimeout testTargets = do + Pub.publish $ Test.Suites initial + Log.info $ "Running " <> show (length testTargets) <> " test suite(s)" + fmap Test.Suites . State.execState initial $ traverse_ go testTargets + where + initial = Map.fromList $ (,Test.SuiteRunning Nothing) <$> testTargets + go target = do + Log.info $ "Running tests: " <> renderTestTarget target + finishedSuite <- + TestRunner.runTestSuite + ( \suite -> do + updated <- State.state $ dup . Map.insert target suite + Pub.publish $ Test.Suites updated + ) + testTimeout + target + updated <- State.state $ dup . Map.insert target finishedSuite + Pub.publish $ Test.Suites updated + + +newLoadResultToBuildResult + :: (Reader ProjectRoot :> es, State BuilderState :> es) + => Session -> NewLoadResult -> Eff es BuildResult +newLoadResultToBuildResult session newLoadResult = do + root <- Reader.ask + State.state \s -> + let (newDiagnosticMap, buildResult) = + compileBuildResults + root + session.watchDirs + s.diagnosticMap + newLoadResult + in (buildResult, s {diagnosticMap = newDiagnosticMap}) diff --git a/src/Tricorder/Daemon/DaemonInfo.hs b/src/Tricorder/Daemon/DaemonInfo.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/DaemonInfo.hs @@ -0,0 +1,57 @@ +module Tricorder.Daemon.DaemonInfo + ( DaemonInfo (..) + , load + , runInput + ) where + +import Atelier.Effects.Input (Input, input, runInputEff) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Effectful.Reader.Static (Reader, ask) +import GHC.Generics (Generically (..)) +import System.FilePath (makeRelative) + +import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..)) +import Tricorder.Session (Session (..)) +import Tricorder.Session.Target (Target) +import Tricorder.Session.WatchDirs (WatchDirs (..)) + + +data DaemonInfo = DaemonInfo + { targets :: [Target] + , watchDirs :: [FilePath] + , sockPath :: FilePath + , logFile :: FilePath + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Generically DaemonInfo + + +load + :: ( Input Session :> es + , Reader LogPath :> es + , Reader ProjectRoot :> es + , Reader SocketPath :> es + ) + => Eff es DaemonInfo +load = do + session <- input + ProjectRoot projectRoot <- ask + SocketPath sockPath <- ask + LogPath logFile <- ask + pure + $ DaemonInfo + { targets = session.targets + , watchDirs = map (makeRelative projectRoot) session.watchDirs.getWatchDirs + , sockPath + , logFile + } + + +runInput + :: ( Input Session :> es + , Reader LogPath :> es + , Reader ProjectRoot :> es + , Reader SocketPath :> es + ) + => Eff (Input DaemonInfo : es) a -> Eff es a +runInput = runInputEff load diff --git a/src/Tricorder/Daemon/Dispatch.hs b/src/Tricorder/Daemon/Dispatch.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/Dispatch.hs @@ -0,0 +1,202 @@ +module Tricorder.Daemon.Dispatch + ( BuilderState (..) + , DiagnosticMap + , DispatchAction (..) + , KnownTargetNames (..) + , dispatch + , emptyBuilderState + , fileMatchesAnyTarget + , filterToWatchDirs + , mergeDiagnostics + , preserveFailureVisibility + ) where + +import Atelier.Effects.FileWatcher (FileEvent (..)) +import System.FilePath (isAbsolute, normalise, splitDirectories, takeExtension, ()) + +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + +import Tricorder.Build (Diagnostic (..), Severity (..)) +import Tricorder.Daemon.GhciSession.GhciParser + ( LoadResult (..) + , LoadedModule (..) + , isLocationLess + , pathSuffixesAsModuleName + , unattributedFailure + ) +import Tricorder.Session.WatchDirs (WatchDirs (..)) + + +-- | The Builder's per-GHCi-session cache: what it last saw from GHCi plus its +-- accumulated diagnostics. Reset on every GHCi restart in +-- @buildWithGhciOnChange@; 'BuildId' is intentionally /not/ here because it +-- counts across restarts. +data BuilderState = BuilderState + { loadedModules :: Map FilePath LoadedModule + , knownTargets :: KnownTargetNames + , diagnosticMap :: DiagnosticMap + } + deriving stock (Eq, Show) + + +emptyBuilderState :: BuilderState +emptyBuilderState = + BuilderState + { loadedModules = mempty + , knownTargets = KnownTargetNames mempty + , diagnosticMap = mempty + } + + +type DiagnosticMap = Map FilePath [Diagnostic] + + +-- | Merge a new 'LoadResult' into the accumulated per-file diagnostic map. +-- +-- Files in 'compiledFiles' have their previous diagnostics cleared and replaced +-- by any new diagnostics produced for them in this cycle. Files absent from +-- 'compiledFiles' were skipped by incremental compilation and retain their +-- previous diagnostics unchanged. +-- +-- Location-less diagnostics (see 'isLocationLess') are never keyed to a real +-- source file, so they would never appear in 'compiledFiles' and would persist +-- forever once raised. They describe the current load's outcome, so we clear +-- them every cycle and let this cycle's 'diagnostics' re-add them if the +-- failure is still present. +mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap +mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} = + let retained = Map.filterWithKey (\f _ -> not (isLocationLess f)) prev + cleared = foldr Map.delete retained compiledFiles + newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics] + in Map.union newByFile cleared + + +-- | GHCi's current target set, as raw entries from @:show targets@ +-- (typically dotted module names under @cabal repl --enable-multi-repl@). +-- Survives every compile failure mode, so the dispatcher can recognise a +-- target even when it's absent from the path-keyed module map. +newtype KnownTargetNames = KnownTargetNames {unKnownTargetNames :: Set Text} + deriving stock (Eq, Show) + + +-- | Whether a file path corresponds to one of GHCi's targets. +-- +-- @:show targets@ entries are either dotted module names (e.g. +-- @Tricorder.CLI.Main@) or file paths (e.g. @app/Main.hs@). GHCi uses the path +-- form when a module name is ambiguous across home units — i.e. every +-- executable/test 'Main'. We match both forms. +-- +-- The path form matters because a /failed/ executable 'Main' drops out of +-- @:show modules@ but survives in @:show targets@ as its path. Without matching +-- it, fixing the executable would dispatch a no-op 'Add' instead of a 'Reload', +-- leaving the diagnostic stale. +fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool +fileMatchesAnyTarget (KnownTargetNames targets) fp = + any (`Set.member` targets) (pathSuffixesAsModuleName fp) + || any (pathTargetMatches fp . toString) (Set.toList targets) + + +-- | Whether a path-shaped @:show targets@ entry refers to the given file, +-- compared on directory-segment boundaries (so @app/Main.hs@ matches +-- @./tricorder/app/Main.hs@ but @pp/Main.hs@ does not). Module-name targets +-- (no @.hs@ extension) are left to the module-name branch above. +pathTargetMatches :: FilePath -> FilePath -> Bool +pathTargetMatches file target = + takeExtension target == ".hs" + && splitDirectories (normalise target) `List.isSuffixOf` splitDirectories (normalise file) + + +-- | A GHCi command to issue in response to a source file change. +data DispatchAction + = Reload + | Add FilePath + | Unadd Text + deriving stock (Eq, Show) + + +-- | Decide what GHCi action a source-file change requires. +-- +-- The path-keyed module map misses targets that failed on first load, +-- so we fall back to 'KnownTargetNames' for those — otherwise we would +-- issue @:add@ (a no-op for an already-tracked cabal target), leaving +-- stale diagnostics in place. +dispatch + :: KnownTargetNames + -> Maybe LoadedModule + -> FilePath + -> FileEvent + -> Maybe DispatchAction +dispatch knownTargets known fp event = case known of + Just lm -> Just $ case event of + Added -> Reload + Modified -> Reload + Removed -> Unadd lm.moduleName + Nothing + | fileMatchesAnyTarget knownTargets fp -> case event of + Added -> Just Reload + Modified -> Just Reload + Removed -> Nothing + | otherwise -> case event of + Added -> Just (Add fp) + Modified -> Just (Add fp) + Removed -> Nothing + + +-- | Keep only diagnostics whose file is under one of the watched directories. +-- +-- Diagnostics from outside the project (e.g. @.h@ files in the Nix store) and +-- those with mangled filenames produced by the C preprocessor (e.g. +-- @"In file included from ..."@) are dropped here, before they can enter the +-- accumulation map where they would be impossible to evict. +-- +-- Location-less diagnostics (see 'isLocationLess') are always kept: they carry +-- no path to test against a watch dir, but they represent genuine build-level +-- failures (e.g. a home-unit GHC plugin that can't load under +-- @--enable-multi-repl@) that must not be dropped, or the build would silently +-- read as clean. +filterToWatchDirs :: FilePath -> WatchDirs -> [Diagnostic] -> [Diagnostic] +filterToWatchDirs _ (WatchDirs []) diags = diags +filterToWatchDirs projectRoot (WatchDirs watchDirs) diags = + filter (\d -> isLocationLess d.file || isUnderAnyWatchDir d.file) diags + where + absWatchDirs = map toAbsWd watchDirs + toAbsWd wd + | wd == "." = projectRoot + | isAbsolute wd = wd + | otherwise = projectRoot wd + isUnderAnyWatchDir file + | isCPPMangledFile file = False + | isAbsolute file = + any (\wd -> (wd ++ "/") `isPrefixOf` file || wd == file) absWatchDirs + | otherwise = + let absFile = projectRoot normalizeRelativePath file + in any (\wd -> (wd ++ "/") `isPrefixOf` absFile || wd == absFile) absWatchDirs + isCPPMangledFile = ("In file included from" `isPrefixOf`) + normalizeRelativePath file + -- GHCi reports filenames relative to the project root for + -- single-package repos. E.g. "src/Foo/Bar.hs", instead of + -- an absolute path or a "./" prefixed path. + | "./" `isPrefixOf` file = drop 2 file + | otherwise = file + + +-- | Keep a failed build from ever reading as clean after watch-dir filtering. +-- +-- 'filterToWatchDirs' drops diagnostics outside the watched directories. If a +-- load failed but every error it produced lay outside those dirs (e.g. a +-- compile error in a sibling home unit not under @watchDirs@), filtering would +-- leave no diagnostics and the broken build would look green. Detecting that an +-- error was present /before/ filtering but none survived, we re-attach the +-- location-less synthetic failure (which filtering always keeps) so the failure +-- still surfaces. +-- +-- Takes the pre-filter diagnostics and the post-filter diagnostics; returns the +-- post-filter list, with the synthetic failure appended only when needed. +preserveFailureVisibility :: [Diagnostic] -> [Diagnostic] -> [Diagnostic] +preserveFailureVisibility raw filtered + | any isError raw && not (any isError filtered) = filtered ++ [unattributedFailure] + | otherwise = filtered + where + isError d = d.severity == SError diff --git a/src/Tricorder/Daemon/EvalCommentRunner.hs b/src/Tricorder/Daemon/EvalCommentRunner.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/EvalCommentRunner.hs @@ -0,0 +1,156 @@ +module Tricorder.Daemon.EvalCommentRunner + ( -- * Effect + EvalCommentRunner (..) + , evaluateComments + , findEvalCommentsInModules + + -- * Interpreters + , run + ) where + +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.File (File) +import Atelier.Effects.FileSystem (FileSystem, readFileBs) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Process (Process) +import Atelier.Effects.Timeout (Timeout) +import Data.Default (def) +import Data.Text.Encoding (decodeUtf8Lenient) +import Data.Traversable (for) +import Effectful (Effect) +import Effectful.Concurrent (Concurrent) +import Effectful.Dispatch.Dynamic (interpretWith_) +import Effectful.Exception (trySync) +import Effectful.Reader.Static (Reader, ask) +import Effectful.TH (makeEffect) + +import Atelier.Effects.Log qualified as Log +import Data.Map.Strict qualified as Map +import Data.Text qualified as T + +import Tricorder.Daemon.GhciSession.GhciParser (LoadedModule (..)) +import Tricorder.Daemon.GhciSession.GhciProcess (execGhci, withGhciProcess) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Command (Command) + +import Tricorder.Build.EvalComment qualified as Eval + + +data EvalCommentRunner :: Effect where + -- | Scan all loaded source files for eval comments and evaluate them, each + -- in a fresh GHCi session started in that file's module context. + EvaluateComments + :: Command + -> NonEmpty (LoadedModule, NonEmpty Eval.Comment) + -> EvalCommentRunner m (NonEmpty Eval.Evaluation) + -- | Extract eval comments from provided source files. Returns a map of all + -- files that have at least 1 eval comment. + FindEvalCommentsInModules + :: Map FilePath LoadedModule + -> EvalCommentRunner m [(LoadedModule, NonEmpty Eval.Comment)] + + +makeEffect ''EvalCommentRunner + + +-- | Production interpreter: spawns one short-lived @cabal repl@ session per +-- source file that contains at least one eval comment, then runs each +-- eval comment in that module's context. +run + :: ( Conc :> es + , Concurrent :> es + , File :> es + , FileSystem :> es + , Log :> es + , Process :> es + , Reader ProjectRoot :> es + , Timeout :> es + ) + => Eff (EvalCommentRunner : es) a -> Eff es a +run act = do + interpretWith_ act \case + FindEvalCommentsInModules loadedModules -> do + concat <$> for (Map.toList loadedModules) \(absPath, lm) -> do + fileResult <- trySync $ readFileBs absPath + pure $ case fileResult of + Left _ -> [] + Right bs -> + case Eval.findComments $ decodeUtf8Lenient bs of + [] -> [] + x : xs -> [(lm, x :| xs)] + EvaluateComments command moduleComments -> do + fmap sconcat $ for moduleComments \(lm, comments) -> do + runFileEvals + command + lm.relPath + lm.moduleName + comments + + +-- --------------------------------------------------------------------------- +-- Internal helpers + +-- | Spawn a fresh @cabal repl@ session for one source file and run all of its +-- eval comments in that module's context. Returns an 'Evaluation' for each +-- comment; on session startup failure returns a single error evaluation. +-- +-- The process is registered in @currentProcRef@ as soon as @cabal repl@ has +-- it running (before the initial compile drain), so that a concurrent +-- 'InterruptCurrent' can terminate it promptly. +runFileEvals + :: ( Conc :> es + , Concurrent :> es + , File :> es + , Log :> es + , Process :> es + , Reader ProjectRoot :> es + , Timeout :> es + ) + => Command + -> FilePath + -- ^ Relative path to the source file (stored in results). + -> Text + -- ^ Module name (e.g. @"Tricorder.Builder"@), used to load the module + -- in interpreted mode so that its full local scope is available. + -> NonEmpty Eval.Comment + -> Eff es (NonEmpty Eval.Evaluation) +runFileEvals cmd relPath moduleName comments = do + ProjectRoot projectRoot <- ask + let noProgress = \_ -> pure () + noSetup = \_ -> pure () + wrapForGhci expr + | T.elem '\n' expr = ":{" <> "\n" <> expr <> "\n" <> ":}" + | otherwise = expr + sessionResult <- trySync + $ withGhciProcess def cmd projectRoot noProgress noSetup \ghci _ -> do + _ <- execGhci ghci (":load *" <> moduleName) noProgress + for comments \comment -> do + outputResult <- trySync $ execGhci ghci (wrapForGhci comment.expression) noProgress + pure + Eval.Evaluation + { file = relPath + , comment + , state = Eval.Completed $ case outputResult of + Left ex -> "error: " <> toText (displayException ex) + Right ls -> T.unlines ls + } + case sessionResult of + Right results -> pure results + Left ex -> do + let errMsg = + "EvalRunner: session startup failed for " + <> toText relPath + <> ": " + <> toText (displayException ex) + Log.warn errMsg + pure + $ Eval.Evaluation + { file = relPath + , comment = + Eval.Comment + { lineNumber = 0 + , expression = "" + } + , state = Eval.Completed errMsg + } + :| [] diff --git a/src/Tricorder/Daemon/GhciSession.hs b/src/Tricorder/Daemon/GhciSession.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/GhciSession.hs @@ -0,0 +1,165 @@ +module Tricorder.Daemon.GhciSession + ( -- * Effect + GhciSession + , Controls (..) + , transformControls + , withGhciWith + , withGhci + + -- * Types + , LoadResult (..) + , LoadedModule (..) + + -- * Interpreters + , runGhciSession + , runGhciSessionScripted + ) where + +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.File (File) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Process (Process) +import Atelier.Effects.Publishing.Pub (Pub) +import Atelier.Effects.Timeout (Timeout) +import Data.Default (def) +import Effectful + ( Effect + , Limit (..) + , Persistence (..) + , UnliftStrategy (..) + ) +import Effectful.Concurrent (Concurrent) +import Effectful.Dispatch.Dynamic + ( interpret + , localLift + , localSeqLift + , localSeqUnlift + , localUnlift + , reinterpret + ) +import Effectful.Exception (throwIO) +import Effectful.State.Static.Shared (State, evalState, state) +import Effectful.TH (makeEffect) + +import Atelier.Effects.Publishing.Pub qualified as Pub + +import Tricorder.Build (BuildProgress (..)) +import Tricorder.Daemon.GhciSession.GhciParser + ( GhciLoading (..) + , LoadResult (..) + , LoadedModule (..) + ) +import Tricorder.Daemon.GhciSession.GhciProcess (addGhci, collectGhciResult, interruptGhci, reloadGhci, unaddGhci, withGhciProcess) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Command (Command) + + +data GhciSession :: Effect where + -- | Start a new GHCi session and run the handler with that session active. + -- The handler is also provided an action to reload the GHCi session, + -- returning new messages with module counts. The GHCi session is closed + -- when the handler returns. + WithGhciWith + :: (BuildProgress -> m ()) + -- ^ Action to run when reporting progress + -> Command + -> ProjectRoot + -> (LoadResult -> Controls m -> m a) + -> GhciSession m a + + +data Controls m = Controls + { reload :: m LoadResult + , interrupt :: m () + , add :: FilePath -> m LoadResult + , unadd :: Text -> m LoadResult + } + + +makeEffect ''GhciSession + + +transformControls :: (forall a. m a -> n a) -> Controls m -> Controls n +transformControls f ctrls = + Controls + { reload = f ctrls.reload + , interrupt = f ctrls.interrupt + , add = f . ctrls.add + , unadd = f . ctrls.unadd + } + + +withGhci + :: (GhciSession :> es, Pub BuildProgress :> es) + => Command + -> ProjectRoot + -> (LoadResult -> Controls (Eff es) -> Eff es a) + -> Eff es a +withGhci cmd root handler = do + withGhciWith Pub.publish cmd root handler + + +-- | Scripted interpreter for testing. +-- +-- Each call to 'startGhci' or 'reloadGhci' pops the next result from the +-- pre-loaded list. 'Left' results are re-thrown as exceptions, simulating +-- GHCi crashes. 'stopGhci' is always a no-op. +runGhciSessionScripted :: forall es a. [Either SomeException LoadResult] -> Eff (GhciSession : es) a -> Eff es a +runGhciSessionScripted results = reinterpret (evalState results) $ \env -> + let popResult :: Eff (State [Either SomeException LoadResult] : es) LoadResult + popResult = do + x <- state \case + x : xs -> (x, xs) + [] -> error "GhciSessionScripted: no more results in queue" + case x of + Left ex -> throwIO ex + Right r -> pure r + in \case + WithGhciWith _ _ _ handler -> do + initial <- popResult + localSeqLift env \liftEff -> + localSeqUnlift env \unlift -> + unlift + $ handler + initial + Controls + { reload = liftEff popResult + , interrupt = pure () + , add = \_ -> liftEff popResult + , unadd = \_ -> liftEff popResult + } + + +-- | GHCi session manager backed by 'Tricorder.Daemon.GhciSession.GhciProcess' +-- and 'Tricorder.Daemon.GhciSession.GhciParser'. +runGhciSession + :: ( Conc :> es + , Concurrent :> es + , File :> es + , Log :> es + , Process :> es + , Timeout :> es + ) + => Eff (GhciSession : es) a -> Eff es a +runGhciSession = interpret $ \env -> \case + WithGhciWith onProgress cmd (ProjectRoot dir) handler -> do + localLift env (ConcUnlift Persistent Unlimited) \liftEff -> + localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do + let reportProgress loading = + unlift + $ onProgress + $ BuildProgress + { compiled = loading.index + , total = loading.total + } + withGhciProcess def cmd dir reportProgress (\_ -> pure ()) \process startupLines -> do + initialResult <- collectGhciResult process startupLines dir + unlift + $ handler initialResult + $ transformControls liftEff + $ Controls + { reload = reloadGhci process dir reportProgress + , interrupt = interruptGhci process + , add = \fp -> addGhci process fp dir reportProgress + , unadd = \mn -> unaddGhci process mn dir reportProgress + } diff --git a/src/Tricorder/Daemon/GhciSession/GhciParser.hs b/src/Tricorder/Daemon/GhciSession/GhciParser.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/GhciSession/GhciParser.hs @@ -0,0 +1,669 @@ +module Tricorder.Daemon.GhciSession.GhciParser + ( GhciLoad (..) + , GhciLoading (..) + , GhciMessage (..) + , GhciSeverity (..) + , LoadOutcome (..) + , LoadResult (..) + , LoadedModule (..) + , Position (..) + , collectResult + , collectResultCustom + , isLocationLess + , reloadFailed + , parseProgressLine + , parseReload + , parseShowModules + , parseShowTargets + , pathSuffixesAsModuleName + , resolveKnownTargets + , stripAnsi + , extractTitle + , toAbsolute + , toRelative + , unattributedFailure + ) where + +import Data.Char (isAlpha, isDigit, isSpace, toLower) +import System.FilePath (dropExtension, isAbsolute, makeRelative, normalise, splitDirectories, ()) +import Text.Megaparsec +import Text.Megaparsec.Char (char, string) +import Prelude hiding (many) + +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Text.Megaparsec.Char.Lexer qualified as L + +import Tricorder.Build (Diagnostic (..), Severity (..)) + + +-- | Severity of a GHCi diagnostic message. +data GhciSeverity = GWarning | GError + deriving stock (Eq, Ord, Show) + + +-- | Payload for a @[N of M] Compiling Mod ( file, ... )@ line. +data GhciLoading = GhciLoading + { index :: Int + -- ^ N (this module's index in the compilation sequence) + , total :: Int + -- ^ M (total modules to compile) + , moduleName :: Text + , sourceFile :: FilePath + } + deriving stock (Eq, Show) + + +-- | A source position (1-based line and column). @(0, 0)@ when unavailable. +data Position = Position + { line :: Int + , col :: Int + } + deriving stock (Eq, Show) + + +-- | Payload for a compiler diagnostic (error or warning). +data GhciMessage = GhciMessage + { severity :: GhciSeverity + , file :: FilePath + , startPos :: Position + , endPos :: Position + -- ^ equals 'startPos' when no span + , messageLines :: [Text] + -- ^ raw lines (with any ANSI), header first + } + deriving stock (Eq, Show) + + +-- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@ +-- on success or @Failed, …@ on failure. +data LoadOutcome = LoadSucceeded | LoadFailed + deriving stock (Eq, Show) + + +-- | A structured item from GHCi's reload output. +data GhciLoad + = GLoading GhciLoading + | GMessage GhciMessage + | GLoadConfig FilePath + | GSummary LoadOutcome + deriving stock (Eq, Show) + + +-- | A module currently loaded in the GHCi session. +data LoadedModule = LoadedModule + { relPath :: FilePath + -- ^ Path relative to the project root (e.g. @"./src/Foo.hs"@). + , moduleName :: Text + } + deriving stock (Eq, Show) + + +-- | The result of a GHCi load or reload operation. +data LoadResult = LoadResult + { moduleCount :: Int + , compiledFiles :: Set FilePath + -- ^ Files compiled in this cycle (derived from 'GLoading' items). + -- Used by the session layer to decide which files' previous diagnostics to replace vs. retain. + , loadedModules :: Map FilePath LoadedModule + -- ^ Map from canonical absolute path to module metadata, derived from @:show modules@ output. + -- Lists only modules that compiled successfully this cycle — GHCi drops + -- failed-compile modules from @:show modules@. + , targetNames :: [Text] + -- ^ Raw entries from @:show targets@ — typically dotted module names + -- in @cabal repl --enable-multi-repl@. Unlike 'loadedModules' this + -- survives failed compiles, so the Builder feeds it into + -- @KnownTargetNames@ for the dispatcher's fallback lookup. + , diagnostics :: [Diagnostic] + } + deriving stock (Eq, Show) + + +-- --------------------------------------------------------------------------- +-- LineStream: a Stream instance for [Text] where Token = Text +-- --------------------------------------------------------------------------- + +-- | Wrapper so we can define Stream / VisualStream / TraversableStream for +-- a list of 'Text' lines without orphan-instance conflicts. +newtype LineStream = LineStream [Text] + + +instance Stream LineStream where + type Token LineStream = Text + type Tokens LineStream = [Text] + tokenToChunk Proxy = pure + tokensToChunk Proxy = id + chunkToTokens Proxy = id + chunkLength Proxy = length + chunkEmpty Proxy = null + take1_ (LineStream []) = Nothing + take1_ (LineStream (t : ts)) = Just (t, LineStream ts) + takeN_ n (LineStream s) + | n <= 0 = Just ([], LineStream s) + | null s = Nothing + | otherwise = let (a, b) = splitAt n s in Just (a, LineStream b) + takeWhile_ p (LineStream s) = + let (a, b) = span p s in (a, LineStream b) + + +-- --------------------------------------------------------------------------- +-- Parser type aliases +-- --------------------------------------------------------------------------- + +-- | Parser over a stream of 'Text' lines. +type LineParser = Parsec Void LineStream + + +-- | Parser over a single 'Text' value. +type TextParser = Parsec Void Text + + +-- --------------------------------------------------------------------------- +-- Text-level sub-parsers (helpers for diagnostic header parsing) +-- --------------------------------------------------------------------------- + +-- | Run a 'TextParser' on a 'Text' value, returning 'Nothing' on failure. +runTP :: TextParser a -> Text -> Maybe a +runTP p t = case parse p "" t of + Right x -> Just x + Left _ -> Nothing + + +-- | Parse a GHCi position in one of the formats: +-- @(L1,C1)-(L2,C2):@, @L:C:@, or @L:C-C2:@. +-- Consumes the trailing colon. +positionP :: TextParser (Position, Position) +positionP = parenForm <|> simpleForm + where + parenForm = do + _ <- char '(' + l1 <- L.decimal + _ <- char ',' + c1 <- L.decimal + _ <- char ')' + _ <- char '-' + _ <- char '(' + _ <- optional (char '(') -- some GHCi versions emit "(L1,C1)-((L2,C2):" + l2 <- L.decimal + _ <- char ',' + c2 <- L.decimal + _ <- char ')' + _ <- char ':' + pure (Position l1 c1, Position l2 c2) + simpleForm = do + l <- L.decimal + _ <- char ':' + c <- L.decimal + choice + [ do + _ <- char ':' + pure (Position l c, Position l c) + , do + _ <- char '-' + c2 <- L.decimal + _ <- char ':' + pure (Position l c, Position l c2) + ] + + +-- | Parse the full diagnostic header: +-- @file:pos:@ or @drive:path:pos:@ for Windows. +-- Returns @(file, startPos, endPos, textAfterColon)@. +diagHeaderP :: TextParser (Text, Position, Position, Text) +diagHeaderP = do + a <- takeWhile1P Nothing (/= ':') + _ <- char ':' + filePart <- + if T.length a == 1 && isAlpha (T.head a) then do + pathRest <- takeWhile1P Nothing (/= ':') + _ <- char ':' + pure (a <> ":" <> pathRest) + else + pure a + (sp, ep) <- positionP + afterPos <- getInput + pure (filePart, sp, ep, afterPos) + + +-- --------------------------------------------------------------------------- +-- Line-level helpers +-- --------------------------------------------------------------------------- + +-- | Check if a line is a continuation of a diagnostic message body. +isMessageBody :: Text -> Bool +isMessageBody line = + " " `T.isPrefixOf` line + || "\t" `T.isPrefixOf` line + || case T.break (== '|') line of + (prefix, rest) + | not (T.null rest) -> + T.all (\c -> isSpace c || isDigit c) prefix + _ -> False + + +-- | Consume a line whose stripped form satisfies the predicate. +-- Returns @(originalLine, strippedLine)@. +satisfyStripped :: (Text -> Bool) -> LineParser (Text, Text) +satisfyStripped p = token testLine mempty + where + testLine line = + let stripped = stripAnsi line + in if p stripped then Just (line, stripped) else Nothing + + +-- --------------------------------------------------------------------------- +-- parseReload +-- --------------------------------------------------------------------------- + +-- | Parse the output of @:reload@ from GHCi into structured items. +parseReload :: [Text] -> [GhciLoad] +parseReload ls = + case parse (catMaybes <$> many reloadItem <* eof) "" (LineStream ls) of + Right items -> items + Left _ -> [] + + +-- | Parse one item (or skip one line) from the reload output. +reloadItem :: LineParser (Maybe GhciLoad) +reloadItem = + choice + [ -- Pattern: "Loaded GHCi configuration from " + fmap Just $ do + (_, stripped) <- satisfyStripped ("Loaded GHCi configuration from " `T.isPrefixOf`) + let file = toString $ T.drop (T.length "Loaded GHCi configuration from ") stripped + pure (GLoadConfig file) + , -- Pattern: "[N of M] Compiling ..." + do + (_, stripped) <- satisfyStripped ("[" `T.isPrefixOf`) + pure (runTP loadingLineP stripped) + , -- Pattern: terminal summary line "Ok, ..." / "Failed, ..." + fmap Just $ do + (_, stripped) <- + satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s) + pure + $ GSummary + $ if "Failed, " `T.isPrefixOf` stripped then LoadFailed else LoadSucceeded + , -- Pattern: ": 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 + } + + +-- | Assemble a 'LoadResult' from the raw reload output plus the @:show +-- modules@ / @:show targets@ output. +-- +-- This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload +-- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a +-- location-less failure we don't otherwise attribute to a file), a synthetic +-- error diagnostic is appended so the build can never be reported as clean +-- while GHCi considers it failed. +collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult +collectResult projectRoot reloadLines modules targets = + let loads = parseReload reloadLines + base = collectResultCustom projectRoot loads modules targets + hasError = any (\d -> d.severity == SError) base.diagnostics + in if reloadFailed loads && not hasError then + base {diagnostics = base.diagnostics ++ [unattributedFailure]} + else + base + + +-- | Synthetic diagnostic for a failed load with no located error. Without a +-- source span it cannot point anywhere, but it stops the build reading as +-- clean and tells the user where to look. +unattributedFailure :: Diagnostic +unattributedFailure = + Diagnostic + { severity = SError + , file = "" + , line = 0 + , col = 0 + , endLine = 0 + , endCol = 0 + , title = "GHCi reported a failed load with no located error" + , text = "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n" + } + + +-- | Whether GHCi's load ended in failure, decided from the 'GSummary' items +-- 'parseReload' produces — the single place that classifies GHCi's terminal +-- @Ok, …@ / @Failed, …@ summary line. +-- +-- GHCi emits the real summary last, after all compilation output. Output +-- produced /during/ the load (a Template Haskell splice, top-level IO run while +-- interpreting) can contain an earlier line that looks like a summary, so only +-- the /last/ 'GSummary' reflects the true outcome. +reloadFailed :: [GhciLoad] -> Bool +reloadFailed loads = + case [outcome | GSummary outcome <- loads] of + [] -> False + outcomes -> List.last outcomes == LoadFailed + + +-- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully +-- @\<…\>@-bracketed marker such as @\@ or @\@ +-- rather than a real source path. These carry no source span but can still +-- represent genuine build-level failures, so callers treat them specially +-- (kept rather than dropped, cleared every cycle rather than retained). +-- +-- We require both the opening @\<@ and a closing @\>@ so a real (if exotic) +-- path that merely starts with @\<@, e.g. @\/Foo.hs@, is not +-- mistaken for a marker. +isLocationLess :: FilePath -> Bool +isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f + + +-- | Path↔module-name map for the next cycle: this round's @:show modules@ +-- plus carryover from @prev@ for targets that failed mid-session and so +-- dropped out. Never-compiled targets are absent here (no path↔name +-- mapping); the dispatcher recognises those via 'KnownTargetNames'. +resolveKnownTargets + :: Map FilePath LoadedModule + -- ^ Previous known-targets map (carryover source). + -> LoadResult + -> Map FilePath LoadedModule +resolveKnownTargets prev lr = + let primary = lr.loadedModules + primaryNames = Set.fromList [lm.moduleName | lm <- Map.elems primary] + prevByName = Map.fromList [(lm.moduleName, (path, lm)) | (path, lm) <- Map.toList prev] + carryover = + Map.fromList + [ (path, lm) + | name <- lr.targetNames + , not (Set.member name primaryNames) + , Just (path, lm) <- [Map.lookup name prevByName] + ] + in Map.union primary carryover + + +toDiagnostics :: (FilePath -> FilePath) -> [GhciLoad] -> [Diagnostic] +toDiagnostics rel loads = mapMaybe toMsg loads + where + -- Location-less messages (e.g. @@, @@) carry + -- no source span. We keep the *errors* — a @@ error is a + -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in + -- @--enable-multi-repl@) and must not be silently dropped — but discard + -- location-less warnings, which are just noise without a file to attach to. + toMsg (GMessage m) | isLocationLess m.file, m.severity /= GError = Nothing + toMsg (GMessage m) = + Just + Diagnostic + { severity = case m.severity of + GWarning -> SWarning + GError -> SError + , file = rel m.file + , line = m.startPos.line + , col = m.startPos.col + , endLine = m.endPos.line + , endCol = m.endPos.col + , title = extractTitle (map toString m.messageLines) + , text = unlines (map toText m.messageLines) + } + toMsg _ = Nothing + + +-- | Extract a short human-readable title from GHCi message lines. +-- +-- The header line (@"file:line:col: severity: rest"@) is the first element. +-- The human-readable text is either: +-- +-- * Inline, after @"error:"@ \/ @"warning:"@ in the header (old GHC style), or +-- * On subsequent indented lines (new GHC style, when header ends with a +-- diagnostic code such as @[GHC-83865]@ or @[-Wmissing-deriving-strategies]@). +-- +-- Source-display lines (@"39 | ..."@, @" | ^^^^"@) are skipped when +-- scanning body lines for content. +extractTitle :: [String] -> Text +extractTitle [] = "" +extractTitle (header : body) = + fromMaybe (firstBodyLine body) (inlineFromHeader (toString (stripAnsi (toText header)))) + where + inlineFromHeader :: String -> Maybe Text + inlineFromHeader h = + let lower = map toLower h + in case headerAfter "error:" lower h <|> headerAfter "warning:" lower h of + Nothing -> Nothing + Just rest -> + let content = stripDiagCodes (dropWhile isSpace rest) + in if null content then Nothing else Just (toText content) + + headerAfter :: String -> String -> String -> Maybe String + headerAfter needle haystack original = + fmap (\i -> drop (i + length needle) original) + $ List.findIndex (needle `List.isPrefixOf`) (List.tails haystack) + + stripDiagCodes :: String -> String + stripDiagCodes s = case dropWhile isSpace s of + '[' : rest -> + let after = dropWhile isSpace (drop 1 (dropWhile (/= ']') rest)) + in stripDiagCodes after + other -> other + + firstBodyLine :: [String] -> Text + firstBodyLine xs = + case [ t + | x <- xs + , let t = dropWhile isSpace (toString (stripAnsi (toText x))) + , not (null t) + , not (isSourceLine t) + ] of + (t : _) -> toText t + [] -> "" + + isSourceLine :: String -> Bool + isSourceLine s = case dropWhile (\c -> isDigit c || c == ' ') s of + ('|' : _) -> True + _ -> not (null s) && all (\c -> c `elem` ("^~_ " :: String)) s diff --git a/src/Tricorder/Daemon/GhciSession/GhciProcess.hs b/src/Tricorder/Daemon/GhciSession/GhciProcess.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/GhciSession/GhciProcess.hs @@ -0,0 +1,551 @@ +module Tricorder.Daemon.GhciSession.GhciProcess + ( Config (..) + , GhciProcess (..) + , GhciProcessError (..) + , SessionState (..) + , InterruptDecision (..) + , decideInterrupt + , waitForBannerOrFail + , withGhciProcess + , execGhci + , interruptGhci + , terminateGhciProcess + , collectGhciResult + , reloadGhci + , addGhci + , unaddGhci + ) where + +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.File (BufferMode (..), File, Handle) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Process + ( Process + , RunningProcess + , createPipe + , getStderr + , getStdin + , getStdout + , setStderr + , setStdin + , setStdout + , setWorkingDir + , shell + ) +import Atelier.Effects.Timeout (Timeout, timeout) +import Control.Concurrent.STM (TVar, modifyTVar', readTVar, retry, writeTVar) +import Data.Default (Default (..)) +import Data.Time.Units (Second) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (atomically, newTVarIO) +import Effectful.Exception (finally, throwIO, trySync) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.File qualified as File +import Atelier.Effects.Log qualified as Log +import Atelier.Effects.Process qualified as Process +import Data.Text qualified as T + +import Tricorder.Daemon.GhciSession.GhciParser + ( GhciLoading (..) + , LoadResult (..) + , collectResult + , parseProgressLine + , parseShowModules + , parseShowTargets + , stripAnsi + , unattributedFailure + ) +import Tricorder.Session.Command (Command (..)) + + +-- | Configuration for GHCi process management. +data Config = Config + { startupTimeout :: Second + -- ^ How long to wait for the GHCi version banner on startup. + , shutdownTimeout :: Second + -- ^ How long to wait for the process to exit gracefully before force-killing. + , extraSetupCommands :: [Text] + -- ^ Additional GHCi commands to send after the fixed setup block. + -- Use this to inject session-wide options such as @:set -XOverloadedStrings@. + } + + +instance Default Config where + def = + Config + { startupTimeout = 60 + , shutdownTimeout = 5 + , extraSetupCommands = [] + } + + +data SessionState = Idle Int | Busy Int + deriving stock (Eq, Show) + + +-- | The outcome of consulting the 'SessionState' when an interrupt arrives. +-- +-- 'NoOpIdle' means the GHCi session is at the prompt — sending SIGINT and a +-- sync marker would dirty the buffers and desync the next 'execGhci'. +-- 'SendInterruptFor n' means a command was in flight (state 'Busy n') and +-- the caller should SIGINT the process group and re-write @markerFor n@ (that +-- command's own marker) to unblock the in-progress 'drainUntil'. +data InterruptDecision + = NoOpIdle + | SendInterruptFor Int + deriving stock (Eq, Show) + + +-- | Pure state machine for 'interruptGhci'. Returns the new 'SessionState' +-- to install along with the 'InterruptDecision' the caller should act on. +decideInterrupt :: SessionState -> (SessionState, InterruptDecision) +decideInterrupt s@(Idle _) = (s, NoOpIdle) +decideInterrupt (Busy n) = (Idle (n + 1), SendInterruptFor n) + + +-- | A handle to a running GHCi subprocess. +data GhciProcess = GhciProcess + { stdin :: Handle + , stdout :: Handle + , stderr :: Handle + , handle :: RunningProcess Handle Handle Handle + , stateVar :: TVar SessionState + } + + +-- | Errors that can occur during GHCi process management. +data GhciProcessError + = StartupTimeout + | UnexpectedExit Text (Maybe Text) + | -- | The build command exited (or printed nothing parseable) before GHCi + -- produced its version banner. The 'Text' is the captured stderr+stdout + -- output so callers can surface a useful error (e.g. cabal's dependency + -- resolution failure). + StartupFailed Text + deriving stock (Eq, Show) + + +instance Exception GhciProcessError + + +-- | Set up the GHCi protocol on an already-started process and return its +-- handle together with the output captured during startup. +-- +-- The spawn and group teardown are owned by 'withGhciProcess'. +setupGhciProcess + :: ( Conc :> es + , Concurrent :> es + , File :> es + , Timeout :> es + ) + => Config + -> RunningProcess Handle Handle Handle + -> (GhciLoading -> Eff es ()) + -- ^ Called as each @[N of M] Compiling …@ line is streamed during the + -- initial-build drain, so the UI can update the progress bar live + -- instead of replaying everything once compilation finishes. + -> (GhciProcess -> Eff es ()) + -- ^ @onReady@. Called once the 'GhciProcess' is constructed but before the + -- banner wait and initial-build drain — so callers can register the process + -- for interruption while the slow @cabal repl@ startup (dependency build + -- and recompilation) is still in progress. + -> Eff es (GhciProcess, [Text]) +setupGhciProcess config p onProgress onReady = do + let inp = getStdin p + out = getStdout p + err = getStderr p + File.hSetBuffering inp LineBuffering + File.hSetBuffering out LineBuffering + File.hSetBuffering err LineBuffering + + -- Register the process for interruption before the (possibly slow) banner + -- wait, so an interrupt during @cabal repl@ startup can terminate it. + stateVar <- newTVarIO (Idle 0) + let ghciProcess = + GhciProcess + { stdin = inp + , stdout = out + , stderr = err + , handle = p + , stateVar = stateVar + } + onReady ghciProcess + + -- Send a blank line to kick GHCi into producing output + File.hPutTextLn inp "" + File.hFlush inp + + -- Wait for the version banner. We concurrently capture stderr so that if + -- the build command exits before printing a banner (e.g. cabal's + -- dependency resolution fails) we can surface its error output. + waitForBannerOrFail config.startupTimeout out err + + -- Send fixed setup commands (protocol requirements) + File.hPutTextLn inp ":set prompt \"\"" + File.hPutTextLn inp ":set prompt-cont \"\"" + File.hPutTextLn inp ":set +c" + -- Send any caller-supplied extra setup commands + for_ config.extraSetupCommands \c -> + File.hPutTextLn inp c + File.hFlush inp + + -- Sync: drain until marker 1 seen, then set counter to 2. + -- Capture lines from both streams — the stderr output contains the initial + -- compilation progress and any startup diagnostics. The line hook fires + -- 'onProgress' for each "[N of M] Compiling …" line as it arrives, so the + -- UI can update the progress bar live during the initial build. + let marker1 = markerFor 1 + hook = progressLineHook onProgress + sendSyncCommand inp marker1 + initialLines <- Conc.scoped do + stdoutThread <- Conc.fork $ drainUntil out marker1 hook + stderrThread <- Conc.fork $ drainUntil err marker1 hook + stdoutLines <- Conc.await stdoutThread + stderrLines <- Conc.await stderrThread + pure (stdoutLines ++ stderrLines) + atomically $ writeTVar stateVar (Idle 2) + + pure (ghciProcess, initialLines) + + +-- | Run a GHCi @cabal repl@ session for the duration of @action@. +-- +-- The session runs in its own process group, so the whole group is torn down on +-- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The +-- action receives the process handle and the output captured during startup. +-- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks. +withGhciProcess + :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es) + => Config + -> Command + -> FilePath + -> (GhciLoading -> Eff es ()) + -> (GhciProcess -> Eff es ()) + -> (GhciProcess -> [Text] -> Eff es a) + -> Eff es a +withGhciProcess config cmd dir onProgress onReady action = + Process.withProcessGroup processConfig \p -> do + (ghciProcess, initialLines) <- setupGhciProcess config p onProgress onReady + action ghciProcess initialLines `finally` quitGhci config ghciProcess + where + processConfig = + setStdin createPipe + $ setStdout createPipe + $ setStderr createPipe + $ setWorkingDir dir + $ shell (toString cmd.getCommand) + + +-- | Execute a command in GHCi and return the combined stdout+stderr output +-- lines. The @onProgress@ callback fires for each @[N of M] Compiling …@ line +-- as it arrives, so reload/add/unadd progress is streamed live to the UI. +-- Pass @\\_ -> pure ()@ for commands that do not trigger compilation. +execGhci + :: ( Conc :> es + , Concurrent :> es + , File :> es + ) + => GhciProcess -> Text -> (GhciLoading -> Eff es ()) -> Eff es [Text] +execGhci ghciProcess command onProgress = do + n <- atomically do + readTVar ghciProcess.stateVar >>= \case + Idle n -> writeTVar ghciProcess.stateVar (Busy n) $> n + Busy _ -> retry + doExec n `finally` atomically (writeTVar ghciProcess.stateVar (Idle (n + 1))) + where + doExec n = do + let marker = markerFor n + hook = progressLineHook onProgress + File.hPutTextLn ghciProcess.stdin command + File.hFlush ghciProcess.stdin + sendSyncCommand ghciProcess.stdin marker + -- Scoped so that an exception from one drain (e.g. 'UnexpectedExit' + -- when the underlying process is terminated mid-command) is + -- contained here, re-raised by 'await', and caught by the caller's + -- 'trySync'. Without 'scoped', Ki propagates the exception to the + -- \*ambient* scope — typically the builder's listener scope — which + -- tears down the whole builder loop instead of just failing this + -- one command. + (stdoutLines, stderrLines) <- Conc.scoped do + stdoutThread <- Conc.fork $ drainUntil ghciProcess.stdout marker hook + stderrThread <- Conc.fork $ drainUntil ghciProcess.stderr marker hook + (,) <$> Conc.await stdoutThread <*> Conc.await stderrThread + pure (stdoutLines ++ stderrLines) + + +-- | Interrupt the currently running GHCi command (if any). +-- +-- If a command is in progress (state 'Busy n'), sends SIGINT to the GHCi +-- process group and re-writes /that command's own/ sync marker (@markerFor n@) +-- so the in-progress 'drainUntil', which is waiting for exactly that marker, +-- unblocks. The next command runs as @n + 1@ and waits for @markerFor (n + 1)@, +-- so any duplicate @markerFor n@ left in the buffers is skipped by 'drainUntil' +-- rather than mistaken for the next command's marker. +-- +-- When GHCi is 'Idle' this is a true no-op: sending SIGINT and a sync marker to +-- an idle GHCi leaves leftover marker output in the buffers. +interruptGhci :: (Concurrent :> es, File :> es, Process :> es) => GhciProcess -> Eff es () +interruptGhci ghciProcess = do + decision <- atomically do + s <- readTVar ghciProcess.stateVar + let (s', d) = decideInterrupt s + writeTVar ghciProcess.stateVar s' + pure d + case decision of + NoOpIdle -> pure () + SendInterruptFor n -> do + Process.interruptProcessGroup ghciProcess.handle + sendSyncCommand ghciProcess.stdin (markerFor n) + + +-- | Forcefully terminate a GHCi process and its whole group. +-- +-- Stronger than 'interruptGhci': intended for one-shot processes (such as the +-- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is +-- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT +-- handlers that finalise the current run rather than aborting it. Safe to call +-- from another thread while the session is running. +terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es () +terminateGhciProcess ghciProcess = + Process.terminateProcessGroup ghciProcess.handle + + +-- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it +-- shut down gracefully before the enclosing 'withGhciProcess' tears down the +-- group. Never throws. +quitGhci :: (File :> es, Process :> es, Timeout :> es) => Config -> GhciProcess -> Eff es () +quitGhci config ghciProcess = do + void $ trySync $ do + File.hPutTextLn ghciProcess.stdin ":quit" + File.hFlush ghciProcess.stdin + void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle) + + +-- --------------------------------------------------------------------------- +-- Internal helpers + +-- | Build the finish marker for counter value @n@. +markerFor :: Int -> Text +markerFor n = markerPrefix <> show n <> "~#" + + +-- | The prefix shared by all finish markers. +markerPrefix :: Text +markerPrefix = "#~TRI-FINISH-" + + +-- | Write the synchronisation Haskell statements to GHCi stdin. +-- +-- After each user command, these cause GHCi to emit the finish marker on both +-- stdout and stderr, so 'drainUntil' knows when to stop. +-- +-- The marker is emitted as two standalone, fully-qualified statements — one per +-- stream — using only 'System.IO.hPutStrLn'. This is deliberate: a +-- SIGINT-interrupted ':reload' empties GHCi's interactive scope, dropping the +-- implicit @import Prelude@, so bare names like @putStrLn@ (and even the @>>@ +-- operator) fall out of scope. A marker built from those would /error/ instead +-- of printing — its marker would never appear and 'drainUntil' would block +-- forever waiting for it (the "stuck Building…" stall). Fully-qualified +-- 'System.IO.hPutStrLn' resolves via GHCi's implicit qualified imports even +-- with an emptied scope, so the marker survives an interrupt. +sendSyncCommand :: (File :> es) => Handle -> Text -> Eff es () +sendSyncCommand h marker = do + -- Use show to produce a valid Haskell string literal for the marker text. + let markerLit = toText (show @String (toString marker)) -- e.g. "\"#~TRI-FINISH-3~#\"" + File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stdout " <> markerLit) + File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stderr " <> markerLit) + File.hFlush h + + +-- | Read lines from a handle until /this command's/ finish marker is seen (or +-- EOF). +-- +-- Stops only on a line containing the exact @marker@ it was given. A line +-- carrying a /different/ finish marker — a stale leftover from a prior command +-- that was interrupted mid-flight — is skipped rather than matched, so it can +-- never make a later drain return prematurely (the "0 modules"/hang desync). +-- Each ordinary line is passed to @onLine@ as it arrives, so callers can stream +-- progress without waiting for the full drain to complete. Returns accumulated +-- non-marker lines in order. Throws 'UnexpectedExit' on EOF before the marker. +drainUntil :: (File :> es) => Handle -> Text -> (Text -> Eff es ()) -> Eff es [Text] +drainUntil h marker onLine = go [] + where + go acc = do + result <- trySync $ File.hGetLine h + case result of + Left _ -> + throwIO $ UnexpectedExit marker (listToMaybe (reverse acc)) + Right line + | marker `T.isInfixOf` line -> pure (reverse acc) + -- A stale marker from an interrupted command: drop it, keep going. + | markerPrefix `T.isInfixOf` line -> go acc + | otherwise -> do + onLine line + go (line : acc) + + +-- | Convert a 'GhciLoading' progress callback into a per-line hook suitable +-- for 'drainUntil'. Non-progress lines are ignored. +progressLineHook :: (GhciLoading -> Eff es ()) -> Text -> Eff es () +progressLineHook onProgress line = traverse_ onProgress (parseProgressLine line) + + +-- | Wait up to the given number of seconds for a GHCi version banner on +-- stdout, capturing stderr (and any non-banner stdout lines) in case the +-- build command fails before printing a banner. +-- +-- Throws 'StartupFailed' with the captured output if stdout EOFs (the build +-- command exited) or 'StartupTimeout' if the banner never arrives. +waitForBannerOrFail + :: ( Conc :> es + , Concurrent :> es + , File :> es + , Timeout :> es + ) + => Second -> Handle -> Handle -> Eff es () +waitForBannerOrFail delay out err = do + capturedVar <- newTVarIO ([] :: [Text]) + let captureLine line = atomically $ modifyTVar' capturedVar (line :) + drainStderr = drainUntilEof err captureLine + watchStdout = waitForBannerStdout out captureLine + + Conc.scoped do + stderrThread <- Conc.fork drainStderr + result <- timeout delay $ trySync watchStdout + case result of + Just (Right ()) -> pure () + Just (Left ex) -> do + -- stdout EOF before the banner: the build command exited. Wait + -- for the stderr drain to reach EOF too (bounded, in case the + -- pipe lingers) so we surface its *complete* output — e.g. + -- cabal's dependency-resolution error — rather than whatever + -- the drain happened to have read so far. + _ <- timeout (1 :: Second) (Conc.await stderrThread) + captured <- atomically $ readTVar capturedVar + throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured) + Nothing -> do + captured <- atomically $ readTVar capturedVar + throwIO $ maybe StartupTimeout StartupFailed (renderCapturedLines captured) + + +waitForBannerStdout :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es () +waitForBannerStdout h captureLine = go + where + isVersionLine :: Text -> Bool + isVersionLine line = + let stripped = stripAnsi line + in "GHCi, version " `T.isInfixOf` stripped + || "GHCJSi, version " `T.isInfixOf` stripped + || "Clashi, version " `T.isInfixOf` stripped + + go = do + result <- trySync $ File.hGetLine h + case result of + Left ex -> throwIO ex + Right line -> + if isVersionLine line then + pure () + else do + captureLine line + go + + +drainUntilEof :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es () +drainUntilEof h onLine = go + where + go = do + result <- trySync $ File.hGetLine h + case result of + Left _ -> pure () + Right line -> onLine line >> go + + +-- | Render the captured (reverse-order) output lines into an error message, +-- stripping ANSI escapes and dropping blank lines. Returns 'Nothing' when +-- nothing useful remains, so callers can fall back to a generic message. +renderCapturedLines :: [Text] -> Maybe Text +renderCapturedLines capturedRev = + let cleaned = filter (not . T.null . T.strip) (map stripAnsi (reverse capturedRev)) + in if null cleaned then Nothing else Just (T.intercalate "\n" cleaned) + + +-- | Fallback message when the build command exited before the banner without +-- printing anything we could capture. +startupExitedMessage :: SomeException -> Text +startupExitedMessage ex = + "Build command exited before GHCi started: " <> toText (displayException ex) + + +-- | Parse already-drained GHCi output lines into a 'LoadResult', fetching the +-- current module list via @:show modules@. +-- +-- Progress is emitted live by 'drainUntil' as lines arrive, so no replay +-- callback is needed here — this function only assembles the final result. +collectGhciResult + :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) + => GhciProcess + -> [Text] + -> FilePath + -> Eff es LoadResult +collectGhciResult process lines' projectRoot = do + let noProgress = \_ -> pure () + moduleLines <- execGhci process ":show modules" noProgress + targetLines <- execGhci process ":show targets" noProgress + let result = + collectResult + projectRoot + lines' + (parseShowModules moduleLines) + (parseShowTargets targetLines) + -- A failed load with no located error produces only the synthetic + -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in + -- that case, so log the raw GHCi output — it's the only way to see what + -- actually went wrong, and the synthetic diagnostic points here. + when (any (== unattributedFailure) result.diagnostics) + $ Log.info + $ "GHCi reported a failed load with no located error. Full GHCi output:\n" + <> T.unlines lines' + pure result + + +-- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events +-- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read. +reloadGhci + :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) + => GhciProcess + -> FilePath + -> (GhciLoading -> Eff es ()) + -> Eff es LoadResult +reloadGhci process projectRoot onProgress = do + reloadLines <- execGhci process ":reload" onProgress + collectGhciResult process reloadLines projectRoot + + +-- | Execute @:add@ for the given file and return the assembled 'LoadResult'. +-- Progress events fire live via @onProgress@ as compilation proceeds. +addGhci + :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) + => GhciProcess + -> FilePath -- the file to :add + -> FilePath -- projectRoot + -> (GhciLoading -> Eff es ()) + -> Eff es LoadResult +addGhci process filePath projectRoot onProgress = do + addLines <- execGhci process (":add " <> T.pack filePath) onProgress + collectGhciResult process addLines projectRoot + + +-- | Execute @:unadd@ for the given module and return the assembled +-- 'LoadResult'. Progress events fire live via @onProgress@ as compilation +-- proceeds. +unaddGhci + :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) + => GhciProcess + -> Text -- the module name to :unadd + -> FilePath -- projectRoot + -> (GhciLoading -> Eff es ()) + -> Eff es LoadResult +unaddGhci process moduleName projectRoot onProgress = do + unaddLines <- execGhci process (":unadd " <> moduleName) onProgress + collectGhciResult process unaddLines projectRoot diff --git a/src/Tricorder/Daemon/Main.hs b/src/Tricorder/Daemon/Main.hs --- a/src/Tricorder/Daemon/Main.hs +++ b/src/Tricorder/Daemon/Main.hs @@ -1,21 +1,18 @@ module Tricorder.Daemon.Main (main) where -import Atelier.Component (runSystem) -import Atelier.Config (runConfig) import Atelier.Effects.Cache (runCacheTtl) import Atelier.Effects.Chan (runChan) import Atelier.Effects.Clock (runClock) import Atelier.Effects.Conc (runConc) import Atelier.Effects.Debounce (runDebounce) import Atelier.Effects.Delay (runDelay) +import Atelier.Effects.Env (runEnv) import Atelier.Effects.Exit (runExit) import Atelier.Effects.File (runFile) import Atelier.Effects.FileSystem (runFileSystemIO) import Atelier.Effects.FileWatcher (runFileWatcherIO) -import Atelier.Effects.Monitoring.Metrics.Server (runMetricsServerIO) -import Atelier.Effects.Monitoring.Tracing (TracingConfig, runTracingFromConfig) import Atelier.Effects.Process (runProcessIO) -import Atelier.Effects.Publishing (runPubSub) +import Atelier.Effects.Publishing (runPubSub_) import Atelier.Effects.Timeout (runTimeout) import Data.Default (def) import Effectful (runEff) @@ -24,29 +21,31 @@ import Effectful.State.Static.Shared (evalState) import Atelier.Effects.Cache.Config qualified as CacheConfig +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Input qualified as Input import Atelier.Effects.Log qualified as Log -import Tricorder.BuildState (BuildId (..), runDaemonInfo) -import Tricorder.Config (restartOnConfigChange, runLoadedConfig) -import Tricorder.Effects.BuildStore (runBuildStore) -import Tricorder.Effects.GhcPkg (runGhcPkgIO) -import Tricorder.Effects.GhciSession (runGhciSession) -import Tricorder.Effects.Logging (runLogging) -import Tricorder.Effects.SessionStore (runSessionStore) -import Tricorder.Effects.TestRunner (runTestRunnerIO) -import Tricorder.Effects.UnixSocket (runUnixSocketIO) +import Tricorder.Build (BuildId (..), BuildPhase) +import Tricorder.Config (inputLoadedConfig) +import Tricorder.Daemon.GhciSession (runGhciSession) +import Tricorder.Logging (runLogging) +import Tricorder.Module (ModuleName, PackageId) import Tricorder.Runtime (runLogPath, runProjectRoot, runRuntimeDir, runSocketPath) +import Tricorder.Session (inputSession) +import Tricorder.Session.CabalFile (inputCabalFiles) +import Tricorder.Socket.UnixSocket (runUnixSocketIO) +import Tricorder.SourceLookup (SourceQuery) +import Tricorder.SourceLookup.Cabal (runCabalIO) +import Tricorder.SourceLookup.GhcPkg (runGhcPkgIO) -import Tricorder.BuildState qualified as BuildState -import Tricorder.Builder qualified as Builder -import Tricorder.Builder.Dispatch qualified as Dispatch -import Tricorder.Effects.SessionStore qualified as SessionStore -import Tricorder.GhcPkg.Types qualified as GhcPkg -import Tricorder.Observability qualified as Observability -import Tricorder.Socket.Server qualified as SocketServer +import Tricorder.Daemon.Core qualified as Core +import Tricorder.Daemon.DaemonInfo qualified as DaemonInfo +import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner +import Tricorder.Daemon.TestRunner qualified as TestRunner +import Tricorder.Socket.Server qualified as Server import Tricorder.SourceLookup qualified as SourceLookup import Tricorder.Version qualified as Version -import Tricorder.Watcher qualified as Watcher +import Tricorder.Waiters qualified as Waiters -- | Run the daemon for the given project root. @@ -60,45 +59,37 @@ . runDelay . runTimeout . runDebounce @FilePath - . runDebounce @Text . runFileWatcherIO . runFileSystemIO . runProjectRoot - . restartOnConfigChange . runExit . runFile . runRuntimeDir . runSocketPath . runLogPath . runLogging - . runLoadedConfig - . runConfig @"observability" @Observability.Config - . runConfig @"observability.tracing" @TracingConfig - . runTracingFromConfig + . inputLoadedConfig . runChan - . runPubSub @SessionStore.SessionStoreReloaded - . runSessionStore + . inputCabalFiles + . inputSession . runReader @CacheConfig.Config def - . runPubSub @Watcher.WatchedFile - . runPubSub @BuildState.CabalChangeDetected - . runPubSub @BuildState.SourceChangeDetected - . runDaemonInfo - . runCacheTtl @GhcPkg.ModuleName @GhcPkg.PackageId - . runCacheTtl @(GhcPkg.PackageId, GhcPkg.SourceQuery) @(Text, [SourceLookup.ReExport]) - . runBuildStore + . DaemonInfo.runInput + . runCacheTtl @ModuleName @PackageId + . runCacheTtl @(PackageId, SourceQuery) @SourceLookup.ModuleSourceResult . runProcessIO - . runMetricsServerIO - . runTestRunnerIO + . runCabalIO + . runEnv . runGhcPkgIO . runUnixSocketIO . runGhciSession . evalState (BuildId 1) - . evalState @Dispatch.BuilderState Dispatch.emptyBuilderState + . Input.fromState @BuildId + . runPubSub_ @BuildPhase + . EvalCommentRunner.run + . TestRunner.run + . Waiters.run $ do Log.info $ "Starting tricorder " <> Version.gitHash - runSystem - [ Observability.component - , Watcher.component - , Builder.component - , SocketServer.component - ] + Conc.fork_ Core.main + Conc.fork_ Server.main + Conc.awaitAll diff --git a/src/Tricorder/Daemon/TestRunner.hs b/src/Tricorder/Daemon/TestRunner.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/TestRunner.hs @@ -0,0 +1,203 @@ +module Tricorder.Daemon.TestRunner + ( -- * Effect + TestRunner (..) + , runTestSuite + + -- * Interpreters + , run + , runScripted + + -- * Parsing utilities + , GhciOutcome (..) + , detectOutcome + + -- * Internal helpers (exported for testing) + , loadingToProgress + ) where + +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.File (File) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Process (Process) +import Atelier.Effects.Timeout (Timeout, timeout) +import Control.Exception (throwIO) +import Data.Default (def) +import Data.Time.Units (Second) +import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (ConcUnlift)) +import Effectful.Concurrent (Concurrent) +import Effectful.Dispatch.Dynamic (interpretWith, localUnlift, reinterpret_) +import Effectful.Exception (trySync) +import Effectful.Reader.Static (Reader, ask) +import Effectful.State.Static.Shared (State, evalState, get, put) +import Effectful.TH (makeEffect) + +import Atelier.Effects.Log qualified as Log +import Data.List qualified as List +import Data.Text qualified as T + +import Tricorder.Daemon.GhciSession.GhciParser (GhciLoading (..)) +import Tricorder.Daemon.GhciSession.GhciProcess + ( execGhci + , withGhciProcess + ) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Command (Command (..)) +import Tricorder.Session.TestTarget (TestTarget, renderTestTarget) +import Tricorder.Session.TestTimeout (TestTimeout (..)) +import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) + +import Tricorder.Build.Test qualified as Test + + +data TestRunner :: Effect where + -- | Run a single test suite in a short-lived @cabal repl@ process and + -- return the captured output and detected outcome. + RunTestSuite + :: (Test.Suite -> m ()) + -- ^ Handler for test run progress + -> TestTimeout + -> TestTarget + -> TestRunner m Test.Suite + + +makeEffect ''TestRunner + + +-- | Production interpreter that spawns a short-lived @cabal repl test:\@ +-- process for each suite, feeds @:main\\n:quit\\n@ to stdin, captures combined +-- stdout+stderr, and detects the outcome via 'detectOutcome'. +run + :: ( Conc :> es + , Concurrent :> es + , File :> es + , Log :> es + , Process :> es + , Reader ProjectRoot :> es + , Timeout :> es + ) + => Eff (TestRunner : es) a -> Eff es a +run act = do + interpretWith act \env -> \case + RunTestSuite progressHandler testTimeout target -> + localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do + let onProgress = unlift . progressHandler . loadingToProgress + noProgress _ = pure () + noReady _ = pure () + ProjectRoot projectRoot <- ask + result <- trySync + $ withGhciProcess def (Command $ "cabal repl " <> renderTestTarget target) projectRoot onProgress noReady \ghci _ -> + case testTimeout of + TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress + TestTimeout secs -> + let duration = fromIntegral secs :: Second + in maybeToRight secs + <$> timeout duration (execGhci ghci ":main" noProgress) + case result of + Left ex -> + pure + $ Test.SuiteErrored + $ Test.SuiteError {message = show ex} + Right (Left secs) -> do + Log.warn + $ mconcat + [ "Test suite " + , renderTestTarget target + , " timed out after " + , show secs + , "s" + ] + pure + $ Test.SuiteErrored + $ Test.SuiteError + { message = "Test suite timed out after " <> show secs <> "s" + } + Right (Right mainLines) -> + pure + $ let output = T.unlines mainLines + in case detectOutcome output of + GhciCrashed msg -> + Test.SuiteErrored $ Test.SuiteError {message = msg} + outcome -> + Test.SuiteCompleted + $ Test.SuiteCompletion + { passed = outcome == GhciPassed + , output + , testCases = parseHspecOutput output + , duration = parseHspecDuration output + } + + +-- | Scripted interpreter for testing. +-- +-- Each call to 'runTestSuite' pops the next result from the pre-loaded list. +-- 'Left' results are re-thrown as exceptions, simulating process failures. +runScripted + :: forall es a + . (IOE :> es) + => [Either SomeException Test.Suite] + -> Eff (TestRunner : es) a + -> Eff es a +runScripted results = + reinterpret_ + (evalState results) + (\(RunTestSuite _ _ _) -> popResult) + where + popResult :: Eff (State [Either SomeException Test.Suite] : es) Test.Suite + popResult = + get >>= \case + [] -> error "TestRunnerScripted: no more results in queue" + Left ex : rest -> put rest >> liftIO (throwIO ex) + Right r : rest -> put rest >> pure r + + +loadingToProgress :: GhciLoading -> Test.Suite +loadingToProgress loading = + Test.SuiteRunning + $ Just + $ Test.Progress {compiled = loading.index, total = loading.total} + + +data GhciOutcome + = GhciPassed + | GhciFailed + | GhciCrashed Text + deriving stock (Eq, Show) + + +-- | Detect the test outcome from raw GHCi output. +-- +-- All major test frameworks (@hspec@, @tasty@, @HUnit@) call +-- 'System.Exit.exitWith' on completion. GHCi surfaces this as a line +-- matching @*** Exception: ExitSuccess@ (pass) or +-- @*** Exception: ExitFailure N@ (fail). Any other @*** Exception:@ line +-- means the runner crashed. +-- +-- When no exception line is present, the absence is ambiguous: either the +-- test ran and printed nothing exit-related, or @:main@ never ran at all +-- (e.g. the test target failed to compile, so @main@ is not in scope). +-- A line containing @": error:"@ in the captured output is treated as the +-- latter — a GHC compile/load error that prevented the suite from running. +detectOutcome :: Text -> GhciOutcome +detectOutcome output = + case List.find ("*** Exception: " `T.isPrefixOf`) outputLines of + Just line -> + case T.stripPrefix "*** Exception: " line of + Nothing -> GhciPassed + Just rest -> + let r = T.strip rest + in if r == "ExitSuccess" then + GhciPassed + else + if "ExitFailure" `T.isPrefixOf` r then + GhciFailed + else + GhciCrashed r + Nothing -> case List.find isCompileErrorLine outputLines of + Just errLine -> GhciCrashed (T.strip errLine) + Nothing -> GhciPassed + where + outputLines = T.lines output + -- GHC compile/load errors are formatted as + -- @: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/Daemon/Watch.hs b/src/Tricorder/Daemon/Watch.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Daemon/Watch.hs @@ -0,0 +1,105 @@ +module Tricorder.Daemon.Watch + ( WatchedFile (..) + , files + , publishChange + , specs + , isCabalFile + ) where + +import Atelier.Effects.Debounce (Debounce) +import Atelier.Effects.FileWatcher + ( FileEvent + , FileWatcher + , Watch + , containing + , dirExt + , dirWhere + , excluding + ) +import Atelier.Effects.Publishing.Pub (Pub) +import System.FilePath (takeExtension, takeFileName) +import Text.Regex.TDFA (ExecOption (..), blankCompOpt, blankExecOpt, match) +import Text.Regex.TDFA.TDFA (patternToRegex) + +import Atelier.Effects.FileWatcher qualified as FileWatcher +import Atelier.Effects.Publishing.Pub qualified as Pub + +import Tricorder.Build.Changes + ( CabalChangeDetected (..) + , ChangeKind (..) + , SourceChangeDetected (..) + ) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session (Session (..)) +import Tricorder.Session.WatchDirs (WatchDirs (..)) +import Tricorder.Session.WatchExclusionPatterns (Pattern, WatchExclusionPatterns (..)) + + +data WatchedFile = WatchedFile + { path :: FilePath + , event :: FileEvent + } + + +files + :: ( Debounce FilePath :> es + , FileWatcher :> es + , Pub WatchedFile :> es + ) + => ProjectRoot -> Session -> Eff es Void +files projectRoot session = + FileWatcher.watchFilePathsDebounced watches \filePath fileEvent -> + Pub.publish $ WatchedFile filePath fileEvent + where + watches = specs projectRoot session.watchExclusionPatterns session.watchDirs + + +publishChange + :: ( Pub CabalChangeDetected :> es + , Pub SourceChangeDetected :> es + ) + => WatchedFile -> Eff es () +publishChange f = + case changeKindFor f.path of + CabalChange -> Pub.publish (CabalChangeDetected f.path f.event) + SourceChange -> Pub.publish (SourceChangeDetected f.path f.event) + + +changeKindFor :: FilePath -> ChangeKind +changeKindFor path + | isCabalFile path = CabalChange + | otherwise = SourceChange + + +specs :: ProjectRoot -> WatchExclusionPatterns -> WatchDirs -> [Watch] +specs projectRoot watchExclusionPatterns watchDirs = + sourceWatches (coerce watchExclusionPatterns) (coerce watchDirs) + <> cabalWatches projectRoot + + +sourceWatches :: [Pattern] -> [FilePath] -> [Watch] +sourceWatches exclusionPatterns = + map \d -> + dirExt d ".hs" + `excluding` containing "dist-newstyle" + `excluding` exclusionMatches exclusionPatterns + + +exclusionMatches :: [Pattern] -> FilePath -> Bool +exclusionMatches exclusionPatterns fp = any matchPattern exclusionPatterns + where + matchPattern p = + match + (patternToRegex p blankCompOpt blankExecOpt {captureGroups = False}) + fp + + +cabalWatches :: ProjectRoot -> [Watch] +cabalWatches (ProjectRoot projectRoot) = + [dirWhere projectRoot isCabalFile `excluding` containing "dist-newstyle"] + + +isCabalFile :: FilePath -> Bool +isCabalFile f = + takeExtension f == ".cabal" + || takeFileName f `elem` ["cabal.project", "package.yaml"] diff --git a/src/Tricorder/Effects/Brick.hs b/src/Tricorder/Effects/Brick.hs deleted file mode 100644 --- a/src/Tricorder/Effects/Brick.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Tricorder.Effects.Brick - ( -- * Brick - Brick - , runBrickApp - , runBrick - ) where - -import Brick.Main (App, customMain) -import Effectful (Effect, IOE) -import Effectful.Dispatch.Dynamic (interpret_) -import Effectful.TH (makeEffect) -import Graphics.Vty (Mode (Mouse), outputIface, setMode) -import Graphics.Vty.Config (userConfig) -import Graphics.Vty.CrossPlatform (mkVty) - -import Tricorder.Effects.BrickChan (BChan) - - -data Brick :: Effect where - RunBrickApp - :: (Ord resource) - => BChan event - -- ^ Channel for publishing events for the app from outside the app - -> App state event resource - -- ^ App to run - -> state - -- ^ Initial state - -> Brick m state - - -makeEffect ''Brick - - -runBrick :: (IOE :> es) => Eff (Brick : es) a -> Eff es a -runBrick = interpret_ \case - RunBrickApp chan app initialState -> liftIO do - let buildVty = do - cfg <- userConfig - vty <- mkVty cfg - setMode (outputIface vty) Mouse True - pure vty - initialVty <- liftIO buildVty - customMain - initialVty - buildVty - (Just chan) - app - initialState diff --git a/src/Tricorder/Effects/BrickChan.hs b/src/Tricorder/Effects/BrickChan.hs deleted file mode 100644 --- a/src/Tricorder/Effects/BrickChan.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Tricorder.Effects.BrickChan - ( BrickChan - , BChan - , newBChan - , writeBChan - , writeBChanNonBlocking - , readBChan - , readBChan2 - , runBrickChan - ) where - -import Brick.BChan (BChan) -import Effectful (Effect, IOE) -import Effectful.Dispatch.Dynamic (interpret_) -import Effectful.TH (makeEffect) - -import Brick.BChan qualified as BChan - - -data BrickChan :: Effect where - -- | Lifted `Brick.BChan.newBChan` - NewBChan :: Int -> BrickChan m (BChan a) - -- | Lifted `Brick.BChan.writeBChan` - WriteBChan :: BChan a -> a -> BrickChan m () - -- | Lifted `Brick.BChan.writeBChanNonBlocking` - WriteBChanNonBlocking :: BChan a -> a -> BrickChan m Bool - -- | Lifted `Brick.BChan.readBChan` - ReadBChan :: BChan a -> BrickChan m a - -- | Lifted `Brick.BChan.readBChan2` - ReadBChan2 :: BChan a -> BChan b -> BrickChan m (Either a b) - - -makeEffect ''BrickChan - - -runBrickChan :: (IOE :> es) => Eff (BrickChan : es) a -> Eff es a -runBrickChan = interpret_ \case - NewBChan n -> liftIO $ BChan.newBChan n - WriteBChan c x -> liftIO $ BChan.writeBChan c x - WriteBChanNonBlocking c x -> liftIO $ BChan.writeBChanNonBlocking c x - ReadBChan c -> liftIO $ BChan.readBChan c - ReadBChan2 c1 c2 -> liftIO $ BChan.readBChan2 c1 c2 diff --git a/src/Tricorder/Effects/BuildStore.hs b/src/Tricorder/Effects/BuildStore.hs deleted file mode 100644 --- a/src/Tricorder/Effects/BuildStore.hs +++ /dev/null @@ -1,216 +0,0 @@ -module Tricorder.Effects.BuildStore - ( -- * Effect - BuildStore (..) - , getState - , modifyPhase - , waitUntilDone - , waitForNext - , waitForAnyChange - , setPhase - , markDirty - , waitDirty - , hasWaiters - - -- * Interpreters - , runBuildStoreScripted - , runBuildStore - ) where - -import Atelier.Effects.Input (Input, input) -import Effectful (Effect) -import Effectful.Concurrent (Concurrent) -import Effectful.Concurrent.STM (TChan, TVar, atomically, dupTChan, modifyTVar, newBroadcastTChan, newTVar, readTChan, readTVar, retry, writeTChan, writeTVar) -import Effectful.Dispatch.Dynamic (interpretWith_, reinterpret) -import Effectful.Exception (bracket_) -import Effectful.State.Static.Shared (State, evalState, get, put) -import Effectful.TH (makeEffect) - -import Tricorder.BuildState - ( BuildId - , BuildPhase (..) - , BuildState (..) - , ChangeKind (..) - , DaemonInfo (..) - , initialBuildState - ) - - -data BuildStore :: Effect where - -- | Read the current build state without blocking. - GetState :: BuildStore m BuildState - -- | Atomically update the phase of the current build, keeping its - -- 'BuildId'. The function sees the live state, so a progress update can - -- inspect the current phase and leave it untouched if it has moved on. - ModifyPhase :: (BuildState -> BuildPhase) -> BuildStore m () - -- | Block until the current build cycle completes (phase transitions to Done). - WaitUntilDone :: BuildStore m BuildState - -- | Block until a completed build with a different 'BuildId' is available. - WaitForNext :: BuildId -> BuildStore m BuildState - -- | Block until the build state changes from the given state (any field). - WaitForAnyChange :: BuildState -> BuildStore m BuildState - -- | Update the build id and phase without touching other fields (e.g. daemonInfo). - SetPhase :: BuildId -> BuildPhase -> BuildStore m () - -- | Signal that files have changed and a rebuild is needed. - -- 'CabalChange' upgrades a pending 'SourceChange' but never downgrades. - MarkDirty :: ChangeKind -> BuildStore m () - -- | Block until dirty, atomically clear the flag, and return the change kind. - WaitDirty :: BuildStore m ChangeKind - -- | Return True if any callers are currently blocked in 'waitUntilDone'. - HasWaiters :: BuildStore m Bool - - -makeEffect ''BuildStore - - --- | Mutable state shared between the production interpreters and writers --- (e.g. 'GhciSession'). Internal to this module. -data BuildStateRef = BuildStateRef - { stateRef :: TVar BuildState - , dirtyRef :: TVar (Maybe ChangeKind) - , waitersRef :: TVar Int - , transitions :: TChan BuildState - -- ^ Broadcast channel of every phase transition. Writers (setPhase / - -- modifyPhase) atomically update 'stateRef' AND broadcast on this chan in - -- the same STM transaction; waiters 'dupTChan' it on entry and consume - -- every transition. A transient 'Done' followed immediately by - -- 'Building (N+1)' is therefore observable as two messages on the - -- channel — the waiter can't be woken on the 'Done' and then miss it - -- because the 'Building' overwrote 'stateRef' before the waiter re-ran. - } - - --- | Allocate the shared STM state, seeding the build state from @di@. The --- record's field types pin the otherwise-polymorphic 'newTVar' and --- 'newBroadcastTChan' results. -newBuildStateRef :: (Concurrent :> es) => DaemonInfo -> Eff es BuildStateRef -newBuildStateRef di = - atomically - $ BuildStateRef - <$> newTVar (initialBuildState di) - <*> newTVar Nothing - <*> newTVar 0 - <*> newBroadcastTChan - - -isBuilding :: BuildState -> Bool -isBuilding s = case s.phase of - Building _ -> True - Restarting -> True - Testing _ -> True - Done _ -> False - BuildFailed _ -> False - - --- | Block until the build state satisfies @predicate@, then return it. --- --- Subscribes to 'transitions' before reading the current state, so every --- subsequent state change is observable as a discrete message even if the --- TVar value is overwritten before the waiter is rescheduled. This is what --- prevents a transient 'Done' from being missed when 'Building (N+1)' --- follows it within the scheduler's wake-up latency. -waitForState - :: (Concurrent :> es) - => TVar BuildState - -> TChan BuildState - -> (BuildState -> Bool) - -> Eff es BuildState -waitForState ref transitions predicate = do - myChan <- atomically (dupTChan transitions) - -- Snapshot AFTER subscribing so we don't race past a transition: any - -- state change that happens between subscribing and reading 'ref' also - -- lands on 'myChan', so the loop will pick it up. - s0 <- atomically (readTVar ref) - if predicate s0 then pure s0 else drainUntilMatch myChan - where - drainUntilMatch ch = do - s <- atomically (readTChan ch) - if predicate s then pure s else drainUntilMatch ch - - --- | Atomically take the dirty marker, blocking until one is set. -takeDirty :: (Concurrent :> es) => TVar (Maybe ChangeKind) -> Eff es ChangeKind -takeDirty dirtyRef = atomically do - readTVar dirtyRef >>= \case - Just ck -> writeTVar dirtyRef Nothing >> pure ck - Nothing -> retry - - --- | Scripted interpreter for testing. --- --- Advances through a pre-loaded list of 'BuildState' values for blocking --- operations. Useful for testing components that read build state without --- needing a real 'TVar' or concurrency. --- --- * 'getState' peeks at the head of the list without consuming it. --- * 'modifyPhase' rewrites the head's phase in place. --- * 'waitUntilDone' pops states until it finds one where @phase /= Building@. --- * 'waitForNext' pops states until it finds a Done state with a different 'BuildId'. -runBuildStoreScripted :: [BuildState] -> Eff (BuildStore : es) a -> Eff es a -runBuildStoreScripted states = reinterpret (evalState states) $ \_ -> \case - GetState -> - get >>= \case - [] -> error "BuildStoreScripted: getState called on empty state list" - s : _ -> pure s - ModifyPhase f -> - get >>= \case - [] -> pure () - s : rest -> put (s {phase = f s} : rest) - WaitUntilDone -> advance (not . isBuilding) - WaitForNext bid -> advance \s -> not (isBuilding s) && s.buildId /= bid - WaitForAnyChange prev -> advance (/= prev) - SetPhase bid phase -> do - get >>= \case - [] -> pure () - s : rest -> put (s {buildId = bid, phase = phase} : rest) - MarkDirty _ -> pure () - WaitDirty -> pure SourceChange - HasWaiters -> pure False - where - advance :: (BuildState -> Bool) -> Eff (State [BuildState] : es) BuildState - advance predicate = - get >>= \case - [] -> error "BuildStoreScripted: no matching state in list" - s : rest - | predicate s -> put rest >> pure s - | otherwise -> put rest >> advance predicate - - --- | Production interpreter backed by a 'TVar', sharing its STM state with --- writers (e.g. 'GhciSession'). Seeds the state with 'initialBuildState' for --- the current 'DaemonInfo' and refreshes it on every phase change. --- --- Blocking operations use STM @retry@ rather than polling, so a transient --- 'Done' state cannot be missed by a poll cycle landing on the surrounding --- 'Building' phases. 'atomically' is interruptible, so async exceptions --- (e.g. Ki's @ScopeClosing@) propagate during daemon shutdown. -runBuildStore - :: ( Concurrent :> es - , Input DaemonInfo :> es - ) - => Eff (BuildStore : es) a -> Eff es a -runBuildStore eff = do - di <- input - refs <- newBuildStateRef di - interpretWith_ eff \case - GetState -> atomically (readTVar refs.stateRef) - ModifyPhase f -> do - daemonInfo <- input - atomically do - modifyTVar refs.stateRef \bs -> bs {phase = f bs, daemonInfo} - readTVar refs.stateRef >>= writeTChan refs.transitions - WaitUntilDone -> - bracket_ - (atomically (modifyTVar refs.waitersRef (+ 1))) - (atomically (modifyTVar refs.waitersRef (subtract 1))) - (waitForState refs.stateRef refs.transitions (not . isBuilding)) - WaitForNext bid -> - waitForState refs.stateRef refs.transitions \s -> not (isBuilding s) && s.buildId /= bid - WaitForAnyChange prev -> waitForState refs.stateRef refs.transitions (/= prev) - SetPhase bid phase -> do - daemonInfo <- input - atomically do - modifyTVar refs.stateRef \bs -> bs {buildId = bid, phase = phase, daemonInfo} - readTVar refs.stateRef >>= writeTChan refs.transitions - MarkDirty ck -> atomically (modifyTVar refs.dirtyRef (max (Just ck))) - WaitDirty -> takeDirty refs.dirtyRef - HasWaiters -> fmap (> 0) $ atomically (readTVar refs.waitersRef) diff --git a/src/Tricorder/Effects/GhcPkg.hs b/src/Tricorder/Effects/GhcPkg.hs deleted file mode 100644 --- a/src/Tricorder/Effects/GhcPkg.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Tricorder.Effects.GhcPkg - ( GhcPkg - , findModule - , getHaddockHtml - , runGhcPkgIO - , runGhcPkgScripted - , GhcPkgScript (..) - ) where - -import Atelier.Effects.Process (Process, readProcessSafe) -import Effectful (Effect) -import Effectful.Dispatch.Dynamic (interpret, reinterpret) -import Effectful.State.Static.Shared (evalState, get, put) -import Effectful.TH (makeEffect) - -import Data.Text qualified as T - -import Tricorder.GhcPkg.Types (ModuleName (..), PackageId (..)) - - -data GhcPkg :: Effect where - FindModule :: ModuleName -> GhcPkg m (Maybe PackageId) - GetHaddockHtml :: PackageId -> GhcPkg m (Maybe FilePath) - - -makeEffect ''GhcPkg - - -runGhcPkgIO :: (Process :> es) => Eff (GhcPkg : es) a -> Eff es a -runGhcPkgIO = interpret \_ -> \case - FindModule modName -> do - out <- readProcessSafe "ghc-pkg" ["find-module", "--simple-output", toString (unModuleName modName)] - pure $ out >>= fmap PackageId . listToMaybe . filter (not . T.null) . map T.strip . T.lines - GetHaddockHtml pkgId -> do - out <- readProcessSafe "ghc-pkg" ["field", toString (unPackageId pkgId), "haddock-html", "--simple-output"] - pure $ out >>= listToMaybe . map toString . T.words - - --- | Script element for the test interpreter. -data GhcPkgScript - = -- | Return this value for the next 'findModule' call. - NextFindModule (Maybe PackageId) - | -- | Return this value for the next 'getHaddockHtml' call. - NextGetHaddockHtml (Maybe FilePath) - - --- | Scripted interpreter for testing. Does not require 'IOE'. -runGhcPkgScripted :: [GhcPkgScript] -> Eff (GhcPkg : es) a -> Eff es a -runGhcPkgScripted script = reinterpret (evalState script) \_ -> \case - FindModule _ -> - get >>= \case - NextFindModule result : rest -> put rest >> pure result - _ -> error "GhcPkgScripted: expected NextFindModule but queue was empty or mismatched" - GetHaddockHtml _ -> - get >>= \case - NextGetHaddockHtml result : rest -> put rest >> pure result - _ -> error "GhcPkgScripted: expected NextGetHaddockHtml but queue was empty or mismatched" diff --git a/src/Tricorder/Effects/GhciSession.hs b/src/Tricorder/Effects/GhciSession.hs deleted file mode 100644 --- a/src/Tricorder/Effects/GhciSession.hs +++ /dev/null @@ -1,135 +0,0 @@ -module Tricorder.Effects.GhciSession - ( -- * Effect - GhciSession - , Controls (..) - , withGhci - - -- * Types - , LoadResult (..) - , LoadedModule (..) - - -- * Interpreters - , runGhciSession - , runGhciSessionScripted - ) where - -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.File (File) -import Atelier.Effects.Log (Log) -import Atelier.Effects.Process (Process) -import Atelier.Effects.Timeout (Timeout) -import Data.Default (def) -import Effectful - ( Effect - , Limit (..) - , Persistence (..) - , UnliftStrategy (..) - ) -import Effectful.Concurrent (Concurrent) -import Effectful.Dispatch.Dynamic - ( interpret - , localLift - , localSeqLift - , localSeqUnlift - , localUnlift - , reinterpret - ) -import Effectful.Exception (throwIO) -import Effectful.State.Static.Shared (State, evalState, state) -import Effectful.TH (makeEffect) - -import Tricorder.BuildState (BuildPhase (..), BuildProgress (..)) -import Tricorder.Effects.BuildStore (BuildStore, modifyPhase) -import Tricorder.Effects.GhciSession.GhciParser - ( GhciLoading (..) - , LoadResult (..) - , LoadedModule (..) - ) -import Tricorder.Effects.GhciSession.GhciProcess (addGhci, collectGhciResult, interruptGhci, reloadGhci, unaddGhci, withGhciProcess) -import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Command) - - -data GhciSession :: Effect where - -- | Start a new GHCi session and run the handler with that session active. - -- The handler is also provided an action to reload the GHCi session, - -- returning new messages with module counts. The GHCi session is closed - -- when the handler returns. - WithGhci :: Command -> ProjectRoot -> (LoadResult -> Controls m -> m a) -> GhciSession m a - - -data Controls m = Controls - { reload :: m LoadResult - , interrupt :: m () - , add :: FilePath -> m LoadResult - , unadd :: Text -> m LoadResult - } - - -makeEffect ''GhciSession - - --- | Scripted interpreter for testing. --- --- Each call to 'startGhci' or 'reloadGhci' pops the next result from the --- pre-loaded list. 'Left' results are re-thrown as exceptions, simulating --- GHCi crashes. 'stopGhci' is always a no-op. -runGhciSessionScripted :: forall es a. [Either SomeException LoadResult] -> Eff (GhciSession : es) a -> Eff es a -runGhciSessionScripted results = reinterpret (evalState results) $ \env -> - let popResult :: Eff (State [Either SomeException LoadResult] : es) LoadResult - popResult = do - x <- state \case - x : xs -> (x, xs) - [] -> error "GhciSessionScripted: no more results in queue" - case x of - Left ex -> throwIO ex - Right r -> pure r - in \case - WithGhci _ _ handler -> do - initial <- popResult - localSeqLift env \liftEff -> - localSeqUnlift env \unlift -> - unlift - $ handler - initial - Controls - { reload = liftEff popResult - , interrupt = pure () - , add = \_ -> liftEff popResult - , unadd = \_ -> liftEff popResult - } - - --- | GHCi session manager backed by 'Tricorder.Effects.GhciSession.GhciProcess' --- and 'Tricorder.Effects.GhciSession.GhciParser'. -runGhciSession - :: ( BuildStore :> es - , Conc :> es - , Concurrent :> es - , File :> es - , Log :> es - , Process :> es - , Timeout :> es - ) - => Eff (GhciSession : es) a -> Eff es a -runGhciSession = interpret $ \env -> \case - WithGhci cmd (ProjectRoot dir) handler -> do - let onProgress loading = - modifyPhase \_ -> - Building - $ Just - $ BuildProgress {compiled = loading.index, total = loading.total} - withGhciProcess def cmd dir onProgress (\_ -> pure ()) \process startupLines -> - localLift env (ConcUnlift Persistent Unlimited) \liftEff -> - localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do - let doReload = liftEff $ reloadGhci process dir onProgress - initialResult <- unlift $ liftEff $ collectGhciResult process startupLines dir - unlift - $ handler - initialResult - Controls - { reload = doReload - , interrupt = liftEff (interruptGhci process) - , add = \fp -> liftEff $ addGhci process fp dir onProgress - , unadd = \mn -> liftEff $ unaddGhci process mn dir onProgress - } diff --git a/src/Tricorder/Effects/GhciSession/GhciParser.hs b/src/Tricorder/Effects/GhciSession/GhciParser.hs deleted file mode 100644 --- a/src/Tricorder/Effects/GhciSession/GhciParser.hs +++ /dev/null @@ -1,671 +0,0 @@ -module Tricorder.Effects.GhciSession.GhciParser - ( GhciLoad (..) - , GhciLoading (..) - , GhciMessage (..) - , GhciSeverity (..) - , LoadOutcome (..) - , LoadResult (..) - , LoadedModule (..) - , Position (..) - , collectResult - , collectResultCustom - , isLocationLess - , reloadFailed - , parseProgressLine - , parseReload - , parseShowModules - , parseShowTargets - , pathSuffixesAsModuleName - , resolveKnownTargets - , stripAnsi - , extractTitle - , toAbsolute - , toRelative - , unattributedFailure - ) where - -import Data.Char (isAlpha, isDigit, isSpace, toLower) -import System.FilePath (dropExtension, isAbsolute, makeRelative, normalise, splitDirectories, ()) -import Text.Megaparsec -import Text.Megaparsec.Char (char, string) -import Prelude hiding (many) - -import Data.List qualified as List -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Data.Text qualified as T -import Text.Megaparsec.Char.Lexer qualified as L - -import Tricorder.BuildState (Diagnostic, Severity (..)) - -import Tricorder.BuildState qualified as BuildState - - --- | Severity of a GHCi diagnostic message. -data GhciSeverity = GWarning | GError - deriving stock (Eq, Ord, Show) - - --- | Payload for a @[N of M] Compiling Mod ( file, ... )@ line. -data GhciLoading = GhciLoading - { index :: Int - -- ^ N (this module's index in the compilation sequence) - , total :: Int - -- ^ M (total modules to compile) - , moduleName :: Text - , sourceFile :: FilePath - } - deriving stock (Eq, Show) - - --- | A source position (1-based line and column). @(0, 0)@ when unavailable. -data Position = Position - { line :: Int - , col :: Int - } - deriving stock (Eq, Show) - - --- | Payload for a compiler diagnostic (error or warning). -data GhciMessage = GhciMessage - { severity :: GhciSeverity - , file :: FilePath - , startPos :: Position - , endPos :: Position - -- ^ equals 'startPos' when no span - , messageLines :: [Text] - -- ^ raw lines (with any ANSI), header first - } - deriving stock (Eq, Show) - - --- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@ --- on success or @Failed, …@ on failure. -data LoadOutcome = LoadSucceeded | LoadFailed - deriving stock (Eq, Show) - - --- | A structured item from GHCi's reload output. -data GhciLoad - = GLoading GhciLoading - | GMessage GhciMessage - | GLoadConfig FilePath - | GSummary LoadOutcome - deriving stock (Eq, Show) - - --- | A module currently loaded in the GHCi session. -data LoadedModule = LoadedModule - { relPath :: FilePath - -- ^ Path relative to the project root (e.g. @"./src/Foo.hs"@). - , moduleName :: Text - } - deriving stock (Eq, Show) - - --- | The result of a GHCi load or reload operation. -data LoadResult = LoadResult - { moduleCount :: Int - , compiledFiles :: Set FilePath - -- ^ Files compiled in this cycle (derived from 'GLoading' items). - -- Used by the session layer to decide which files' previous diagnostics to replace vs. retain. - , loadedModules :: Map FilePath LoadedModule - -- ^ Map from canonical absolute path to module metadata, derived from @:show modules@ output. - -- Lists only modules that compiled successfully this cycle — GHCi drops - -- failed-compile modules from @:show modules@. - , targetNames :: [Text] - -- ^ Raw entries from @:show targets@ — typically dotted module names - -- in @cabal repl --enable-multi-repl@. Unlike 'loadedModules' this - -- survives failed compiles, so the Builder feeds it into - -- @KnownTargetNames@ for the dispatcher's fallback lookup. - , diagnostics :: [Diagnostic] - } - deriving stock (Eq, Show) - - --- --------------------------------------------------------------------------- --- LineStream: a Stream instance for [Text] where Token = Text --- --------------------------------------------------------------------------- - --- | Wrapper so we can define Stream / VisualStream / TraversableStream for --- a list of 'Text' lines without orphan-instance conflicts. -newtype LineStream = LineStream [Text] - - -instance Stream LineStream where - type Token LineStream = Text - type Tokens LineStream = [Text] - tokenToChunk Proxy = pure - tokensToChunk Proxy = id - chunkToTokens Proxy = id - chunkLength Proxy = length - chunkEmpty Proxy = null - take1_ (LineStream []) = Nothing - take1_ (LineStream (t : ts)) = Just (t, LineStream ts) - takeN_ n (LineStream s) - | n <= 0 = Just ([], LineStream s) - | null s = Nothing - | otherwise = let (a, b) = splitAt n s in Just (a, LineStream b) - takeWhile_ p (LineStream s) = - let (a, b) = span p s in (a, LineStream b) - - --- --------------------------------------------------------------------------- --- Parser type aliases --- --------------------------------------------------------------------------- - --- | Parser over a stream of 'Text' lines. -type LineParser = Parsec Void LineStream - - --- | Parser over a single 'Text' value. -type TextParser = Parsec Void Text - - --- --------------------------------------------------------------------------- --- Text-level sub-parsers (helpers for diagnostic header parsing) --- --------------------------------------------------------------------------- - --- | Run a 'TextParser' on a 'Text' value, returning 'Nothing' on failure. -runTP :: TextParser a -> Text -> Maybe a -runTP p t = case parse p "" t of - Right x -> Just x - Left _ -> Nothing - - --- | Parse a GHCi position in one of the formats: --- @(L1,C1)-(L2,C2):@, @L:C:@, or @L:C-C2:@. --- Consumes the trailing colon. -positionP :: TextParser (Position, Position) -positionP = parenForm <|> simpleForm - where - parenForm = do - _ <- char '(' - l1 <- L.decimal - _ <- char ',' - c1 <- L.decimal - _ <- char ')' - _ <- char '-' - _ <- char '(' - _ <- optional (char '(') -- some GHCi versions emit "(L1,C1)-((L2,C2):" - l2 <- L.decimal - _ <- char ',' - c2 <- L.decimal - _ <- char ')' - _ <- char ':' - pure (Position l1 c1, Position l2 c2) - simpleForm = do - l <- L.decimal - _ <- char ':' - c <- L.decimal - choice - [ do - _ <- char ':' - pure (Position l c, Position l c) - , do - _ <- char '-' - c2 <- L.decimal - _ <- char ':' - pure (Position l c, Position l c2) - ] - - --- | Parse the full diagnostic header: --- @file:pos:@ or @drive:path:pos:@ for Windows. --- Returns @(file, startPos, endPos, textAfterColon)@. -diagHeaderP :: TextParser (Text, Position, Position, Text) -diagHeaderP = do - a <- takeWhile1P Nothing (/= ':') - _ <- char ':' - filePart <- - if T.length a == 1 && isAlpha (T.head a) then do - pathRest <- takeWhile1P Nothing (/= ':') - _ <- char ':' - pure (a <> ":" <> pathRest) - else - pure a - (sp, ep) <- positionP - afterPos <- getInput - pure (filePart, sp, ep, afterPos) - - --- --------------------------------------------------------------------------- --- Line-level helpers --- --------------------------------------------------------------------------- - --- | Check if a line is a continuation of a diagnostic message body. -isMessageBody :: Text -> Bool -isMessageBody line = - " " `T.isPrefixOf` line - || "\t" `T.isPrefixOf` line - || case T.break (== '|') line of - (prefix, rest) - | not (T.null rest) -> - T.all (\c -> isSpace c || isDigit c) prefix - _ -> False - - --- | Consume a line whose stripped form satisfies the predicate. --- Returns @(originalLine, strippedLine)@. -satisfyStripped :: (Text -> Bool) -> LineParser (Text, Text) -satisfyStripped p = token testLine mempty - where - testLine line = - let stripped = stripAnsi line - in if p stripped then Just (line, stripped) else Nothing - - --- --------------------------------------------------------------------------- --- parseReload --- --------------------------------------------------------------------------- - --- | Parse the output of @:reload@ from GHCi into structured items. -parseReload :: [Text] -> [GhciLoad] -parseReload ls = - case parse (catMaybes <$> many reloadItem <* eof) "" (LineStream ls) of - Right items -> items - Left _ -> [] - - --- | Parse one item (or skip one line) from the reload output. -reloadItem :: LineParser (Maybe GhciLoad) -reloadItem = - choice - [ -- Pattern: "Loaded GHCi configuration from " - fmap Just $ do - (_, stripped) <- satisfyStripped ("Loaded GHCi configuration from " `T.isPrefixOf`) - let file = toString $ T.drop (T.length "Loaded GHCi configuration from ") stripped - pure (GLoadConfig file) - , -- Pattern: "[N of M] Compiling ..." - do - (_, stripped) <- satisfyStripped ("[" `T.isPrefixOf`) - pure (runTP loadingLineP stripped) - , -- Pattern: terminal summary line "Ok, ..." / "Failed, ..." - fmap Just $ do - (_, stripped) <- - satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s) - pure - $ GSummary - $ if "Failed, " `T.isPrefixOf` stripped then LoadFailed else LoadSucceeded - , -- Pattern: ": 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 - } - - --- | Assemble a 'LoadResult' from the raw reload output plus the @:show --- modules@ / @:show targets@ output. --- --- This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload --- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a --- location-less failure we don't otherwise attribute to a file), a synthetic --- error diagnostic is appended so the build can never be reported as clean --- while GHCi considers it failed. -collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult -collectResult projectRoot reloadLines modules targets = - let loads = parseReload reloadLines - base = collectResultCustom projectRoot loads modules targets - hasError = any (\d -> d.severity == SError) base.diagnostics - in if reloadFailed loads && not hasError then - base {diagnostics = base.diagnostics ++ [unattributedFailure]} - else - base - - --- | Synthetic diagnostic for a failed load with no located error. Without a --- source span it cannot point anywhere, but it stops the build reading as --- clean and tells the user where to look. -unattributedFailure :: Diagnostic -unattributedFailure = - BuildState.Diagnostic - { severity = SError - , file = "" - , line = 0 - , col = 0 - , endLine = 0 - , endCol = 0 - , title = "GHCi reported a failed load with no located error" - , text = "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n" - } - - --- | Whether GHCi's load ended in failure, decided from the 'GSummary' items --- 'parseReload' produces — the single place that classifies GHCi's terminal --- @Ok, …@ / @Failed, …@ summary line. --- --- GHCi emits the real summary last, after all compilation output. Output --- produced /during/ the load (a Template Haskell splice, top-level IO run while --- interpreting) can contain an earlier line that looks like a summary, so only --- the /last/ 'GSummary' reflects the true outcome. -reloadFailed :: [GhciLoad] -> Bool -reloadFailed loads = - case [outcome | GSummary outcome <- loads] of - [] -> False - outcomes -> List.last outcomes == LoadFailed - - --- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully --- @\<…\>@-bracketed marker such as @\@ or @\@ --- rather than a real source path. These carry no source span but can still --- represent genuine build-level failures, so callers treat them specially --- (kept rather than dropped, cleared every cycle rather than retained). --- --- We require both the opening @\<@ and a closing @\>@ so a real (if exotic) --- path that merely starts with @\<@, e.g. @\/Foo.hs@, is not --- mistaken for a marker. -isLocationLess :: FilePath -> Bool -isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f - - --- | Path↔module-name map for the next cycle: this round's @:show modules@ --- plus carryover from @prev@ for targets that failed mid-session and so --- dropped out. Never-compiled targets are absent here (no path↔name --- mapping); the dispatcher recognises those via 'KnownTargetNames'. -resolveKnownTargets - :: Map FilePath LoadedModule - -- ^ Previous known-targets map (carryover source). - -> LoadResult - -> Map FilePath LoadedModule -resolveKnownTargets prev lr = - let primary = lr.loadedModules - primaryNames = Set.fromList [lm.moduleName | lm <- Map.elems primary] - prevByName = Map.fromList [(lm.moduleName, (path, lm)) | (path, lm) <- Map.toList prev] - carryover = - Map.fromList - [ (path, lm) - | name <- lr.targetNames - , not (Set.member name primaryNames) - , Just (path, lm) <- [Map.lookup name prevByName] - ] - in Map.union primary carryover - - -toDiagnostics :: (FilePath -> FilePath) -> [GhciLoad] -> [BuildState.Diagnostic] -toDiagnostics rel loads = mapMaybe toMsg loads - where - -- Location-less messages (e.g. @@, @@) carry - -- no source span. We keep the *errors* — a @@ error is a - -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in - -- @--enable-multi-repl@) and must not be silently dropped — but discard - -- location-less warnings, which are just noise without a file to attach to. - toMsg (GMessage m) | isLocationLess m.file, m.severity /= GError = Nothing - toMsg (GMessage m) = - Just - BuildState.Diagnostic - { severity = case m.severity of - GWarning -> SWarning - GError -> SError - , file = rel m.file - , line = m.startPos.line - , col = m.startPos.col - , endLine = m.endPos.line - , endCol = m.endPos.col - , title = extractTitle (map toString m.messageLines) - , text = unlines (map toText m.messageLines) - } - toMsg _ = Nothing - - --- | Extract a short human-readable title from GHCi message lines. --- --- The header line (@"file:line:col: severity: rest"@) is the first element. --- The human-readable text is either: --- --- * Inline, after @"error:"@ \/ @"warning:"@ in the header (old GHC style), or --- * On subsequent indented lines (new GHC style, when header ends with a --- diagnostic code such as @[GHC-83865]@ or @[-Wmissing-deriving-strategies]@). --- --- Source-display lines (@"39 | ..."@, @" | ^^^^"@) are skipped when --- scanning body lines for content. -extractTitle :: [String] -> Text -extractTitle [] = "" -extractTitle (header : body) = - fromMaybe (firstBodyLine body) (inlineFromHeader (toString (stripAnsi (toText header)))) - where - inlineFromHeader :: String -> Maybe Text - inlineFromHeader h = - let lower = map toLower h - in case headerAfter "error:" lower h <|> headerAfter "warning:" lower h of - Nothing -> Nothing - Just rest -> - let content = stripDiagCodes (dropWhile isSpace rest) - in if null content then Nothing else Just (toText content) - - headerAfter :: String -> String -> String -> Maybe String - headerAfter needle haystack original = - fmap (\i -> drop (i + length needle) original) - $ List.findIndex (needle `List.isPrefixOf`) (List.tails haystack) - - stripDiagCodes :: String -> String - stripDiagCodes s = case dropWhile isSpace s of - '[' : rest -> - let after = dropWhile isSpace (drop 1 (dropWhile (/= ']') rest)) - in stripDiagCodes after - other -> other - - firstBodyLine :: [String] -> Text - firstBodyLine xs = - case [ t - | x <- xs - , let t = dropWhile isSpace (toString (stripAnsi (toText x))) - , not (null t) - , not (isSourceLine t) - ] of - (t : _) -> toText t - [] -> "" - - isSourceLine :: String -> Bool - isSourceLine s = case dropWhile (\c -> isDigit c || c == ' ') s of - ('|' : _) -> True - _ -> not (null s) && all (\c -> c `elem` ("^~_ " :: String)) s diff --git a/src/Tricorder/Effects/GhciSession/GhciProcess.hs b/src/Tricorder/Effects/GhciSession/GhciProcess.hs deleted file mode 100644 --- a/src/Tricorder/Effects/GhciSession/GhciProcess.hs +++ /dev/null @@ -1,551 +0,0 @@ -module Tricorder.Effects.GhciSession.GhciProcess - ( Config (..) - , GhciProcess (..) - , GhciProcessError (..) - , SessionState (..) - , InterruptDecision (..) - , decideInterrupt - , waitForBannerOrFail - , withGhciProcess - , execGhci - , interruptGhci - , terminateGhciProcess - , collectGhciResult - , reloadGhci - , addGhci - , unaddGhci - ) where - -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.File (BufferMode (..), File, Handle) -import Atelier.Effects.Log (Log) -import Atelier.Effects.Process - ( Process - , RunningProcess - , createPipe - , getStderr - , getStdin - , getStdout - , setStderr - , setStdin - , setStdout - , setWorkingDir - , shell - ) -import Atelier.Effects.Timeout (Timeout, timeout) -import Control.Concurrent.STM (TVar, modifyTVar', readTVar, retry, writeTVar) -import Data.Default (Default (..)) -import Data.Time.Units (Second) -import Effectful.Concurrent (Concurrent) -import Effectful.Concurrent.STM (atomically, newTVarIO) -import Effectful.Exception (finally, throwIO, trySync) - -import Atelier.Effects.Conc qualified as Conc -import Atelier.Effects.File qualified as File -import Atelier.Effects.Log qualified as Log -import Atelier.Effects.Process qualified as Process -import Data.Text qualified as T - -import Tricorder.Effects.GhciSession.GhciParser - ( GhciLoading (..) - , LoadResult (..) - , collectResult - , parseProgressLine - , parseShowModules - , parseShowTargets - , stripAnsi - , unattributedFailure - ) -import Tricorder.Session (Command (..)) - - --- | Configuration for GHCi process management. -data Config = Config - { startupTimeout :: Second - -- ^ How long to wait for the GHCi version banner on startup. - , shutdownTimeout :: Second - -- ^ How long to wait for the process to exit gracefully before force-killing. - , extraSetupCommands :: [Text] - -- ^ Additional GHCi commands to send after the fixed setup block. - -- Use this to inject session-wide options such as @:set -XOverloadedStrings@. - } - - -instance Default Config where - def = - Config - { startupTimeout = 60 - , shutdownTimeout = 5 - , extraSetupCommands = [] - } - - -data SessionState = Idle Int | Busy Int - deriving stock (Eq, Show) - - --- | The outcome of consulting the 'SessionState' when an interrupt arrives. --- --- 'NoOpIdle' means the GHCi session is at the prompt — sending SIGINT and a --- sync marker would dirty the buffers and desync the next 'execGhci'. --- 'SendInterruptFor n' means a command was in flight (state 'Busy n') and --- the caller should SIGINT the process group and re-write @markerFor n@ (that --- command's own marker) to unblock the in-progress 'drainUntil'. -data InterruptDecision - = NoOpIdle - | SendInterruptFor Int - deriving stock (Eq, Show) - - --- | Pure state machine for 'interruptGhci'. Returns the new 'SessionState' --- to install along with the 'InterruptDecision' the caller should act on. -decideInterrupt :: SessionState -> (SessionState, InterruptDecision) -decideInterrupt s@(Idle _) = (s, NoOpIdle) -decideInterrupt (Busy n) = (Idle (n + 1), SendInterruptFor n) - - --- | A handle to a running GHCi subprocess. -data GhciProcess = GhciProcess - { stdin :: Handle - , stdout :: Handle - , stderr :: Handle - , handle :: RunningProcess Handle Handle Handle - , stateVar :: TVar SessionState - } - - --- | Errors that can occur during GHCi process management. -data GhciProcessError - = StartupTimeout - | UnexpectedExit Text (Maybe Text) - | -- | The build command exited (or printed nothing parseable) before GHCi - -- produced its version banner. The 'Text' is the captured stderr+stdout - -- output so callers can surface a useful error (e.g. cabal's dependency - -- resolution failure). - StartupFailed Text - deriving stock (Eq, Show) - - -instance Exception GhciProcessError - - --- | Set up the GHCi protocol on an already-started process and return its --- handle together with the output captured during startup. --- --- The spawn and group teardown are owned by 'withGhciProcess'. -setupGhciProcess - :: ( Conc :> es - , Concurrent :> es - , File :> es - , Timeout :> es - ) - => Config - -> RunningProcess Handle Handle Handle - -> (GhciLoading -> Eff es ()) - -- ^ Called as each @[N of M] Compiling …@ line is streamed during the - -- initial-build drain, so the UI can update the progress bar live - -- instead of replaying everything once compilation finishes. - -> (GhciProcess -> Eff es ()) - -- ^ @onReady@. Called once the 'GhciProcess' is constructed but before the - -- banner wait and initial-build drain — so callers can register the process - -- for interruption while the slow @cabal repl@ startup (dependency build - -- and recompilation) is still in progress. - -> Eff es (GhciProcess, [Text]) -setupGhciProcess config p onProgress onReady = do - let inp = getStdin p - out = getStdout p - err = getStderr p - File.hSetBuffering inp LineBuffering - File.hSetBuffering out LineBuffering - File.hSetBuffering err LineBuffering - - -- Register the process for interruption before the (possibly slow) banner - -- wait, so an interrupt during @cabal repl@ startup can terminate it. - stateVar <- newTVarIO (Idle 0) - let ghciProcess = - GhciProcess - { stdin = inp - , stdout = out - , stderr = err - , handle = p - , stateVar = stateVar - } - onReady ghciProcess - - -- Send a blank line to kick GHCi into producing output - File.hPutTextLn inp "" - File.hFlush inp - - -- Wait for the version banner. We concurrently capture stderr so that if - -- the build command exits before printing a banner (e.g. cabal's - -- dependency resolution fails) we can surface its error output. - waitForBannerOrFail config.startupTimeout out err - - -- Send fixed setup commands (protocol requirements) - File.hPutTextLn inp ":set prompt \"\"" - File.hPutTextLn inp ":set prompt-cont \"\"" - File.hPutTextLn inp ":set +c" - -- Send any caller-supplied extra setup commands - for_ config.extraSetupCommands \c -> - File.hPutTextLn inp c - File.hFlush inp - - -- Sync: drain until marker 1 seen, then set counter to 2. - -- Capture lines from both streams — the stderr output contains the initial - -- compilation progress and any startup diagnostics. The line hook fires - -- 'onProgress' for each "[N of M] Compiling …" line as it arrives, so the - -- UI can update the progress bar live during the initial build. - let marker1 = markerFor 1 - hook = progressLineHook onProgress - sendSyncCommand inp marker1 - initialLines <- Conc.scoped do - stdoutThread <- Conc.fork $ drainUntil out marker1 hook - stderrThread <- Conc.fork $ drainUntil err marker1 hook - stdoutLines <- Conc.await stdoutThread - stderrLines <- Conc.await stderrThread - pure (stdoutLines ++ stderrLines) - atomically $ writeTVar stateVar (Idle 2) - - pure (ghciProcess, initialLines) - - --- | Run a GHCi @cabal repl@ session for the duration of @action@. --- --- The session runs in its own process group, so the whole group is torn down on --- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The --- action receives the process handle and the output captured during startup. --- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks. -withGhciProcess - :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es) - => Config - -> Command - -> FilePath - -> (GhciLoading -> Eff es ()) - -> (GhciProcess -> Eff es ()) - -> (GhciProcess -> [Text] -> Eff es a) - -> Eff es a -withGhciProcess config cmd dir onProgress onReady action = - Process.withProcessGroup processConfig \p -> do - (ghciProcess, initialLines) <- setupGhciProcess config p onProgress onReady - action ghciProcess initialLines `finally` quitGhci config ghciProcess - where - processConfig = - setStdin createPipe - $ setStdout createPipe - $ setStderr createPipe - $ setWorkingDir dir - $ shell (toString cmd.getCommand) - - --- | Execute a command in GHCi and return the combined stdout+stderr output --- lines. The @onProgress@ callback fires for each @[N of M] Compiling …@ line --- as it arrives, so reload/add/unadd progress is streamed live to the UI. --- Pass @\\_ -> pure ()@ for commands that do not trigger compilation. -execGhci - :: ( Conc :> es - , Concurrent :> es - , File :> es - ) - => GhciProcess -> Text -> (GhciLoading -> Eff es ()) -> Eff es [Text] -execGhci ghciProcess command onProgress = do - n <- atomically do - readTVar ghciProcess.stateVar >>= \case - Idle n -> writeTVar ghciProcess.stateVar (Busy n) $> n - Busy _ -> retry - doExec n `finally` atomically (writeTVar ghciProcess.stateVar (Idle (n + 1))) - where - doExec n = do - let marker = markerFor n - hook = progressLineHook onProgress - File.hPutTextLn ghciProcess.stdin command - File.hFlush ghciProcess.stdin - sendSyncCommand ghciProcess.stdin marker - -- Scoped so that an exception from one drain (e.g. 'UnexpectedExit' - -- when the underlying process is terminated mid-command) is - -- contained here, re-raised by 'await', and caught by the caller's - -- 'trySync'. Without 'scoped', Ki propagates the exception to the - -- \*ambient* scope — typically the builder's listener scope — which - -- tears down the whole builder loop instead of just failing this - -- one command. - (stdoutLines, stderrLines) <- Conc.scoped do - stdoutThread <- Conc.fork $ drainUntil ghciProcess.stdout marker hook - stderrThread <- Conc.fork $ drainUntil ghciProcess.stderr marker hook - (,) <$> Conc.await stdoutThread <*> Conc.await stderrThread - pure (stdoutLines ++ stderrLines) - - --- | Interrupt the currently running GHCi command (if any). --- --- If a command is in progress (state 'Busy n'), sends SIGINT to the GHCi --- process group and re-writes /that command's own/ sync marker (@markerFor n@) --- so the in-progress 'drainUntil', which is waiting for exactly that marker, --- unblocks. The next command runs as @n + 1@ and waits for @markerFor (n + 1)@, --- so any duplicate @markerFor n@ left in the buffers is skipped by 'drainUntil' --- rather than mistaken for the next command's marker. --- --- When GHCi is 'Idle' this is a true no-op: sending SIGINT and a sync marker to --- an idle GHCi leaves leftover marker output in the buffers. -interruptGhci :: (Concurrent :> es, File :> es, Process :> es) => GhciProcess -> Eff es () -interruptGhci ghciProcess = do - decision <- atomically do - s <- readTVar ghciProcess.stateVar - let (s', d) = decideInterrupt s - writeTVar ghciProcess.stateVar s' - pure d - case decision of - NoOpIdle -> pure () - SendInterruptFor n -> do - Process.interruptProcessGroup ghciProcess.handle - sendSyncCommand ghciProcess.stdin (markerFor n) - - --- | Forcefully terminate a GHCi process and its whole group. --- --- Stronger than 'interruptGhci': intended for one-shot processes (such as the --- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is --- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT --- handlers that finalise the current run rather than aborting it. Safe to call --- from another thread while the session is running. -terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es () -terminateGhciProcess ghciProcess = - Process.terminateProcessGroup ghciProcess.handle - - --- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it --- shut down gracefully before the enclosing 'withGhciProcess' tears down the --- group. Never throws. -quitGhci :: (File :> es, Process :> es, Timeout :> es) => Config -> GhciProcess -> Eff es () -quitGhci config ghciProcess = do - void $ trySync $ do - File.hPutTextLn ghciProcess.stdin ":quit" - File.hFlush ghciProcess.stdin - void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle) - - --- --------------------------------------------------------------------------- --- Internal helpers - --- | Build the finish marker for counter value @n@. -markerFor :: Int -> Text -markerFor n = markerPrefix <> show n <> "~#" - - --- | The prefix shared by all finish markers. -markerPrefix :: Text -markerPrefix = "#~TRI-FINISH-" - - --- | Write the synchronisation Haskell statements to GHCi stdin. --- --- After each user command, these cause GHCi to emit the finish marker on both --- stdout and stderr, so 'drainUntil' knows when to stop. --- --- The marker is emitted as two standalone, fully-qualified statements — one per --- stream — using only 'System.IO.hPutStrLn'. This is deliberate: a --- SIGINT-interrupted ':reload' empties GHCi's interactive scope, dropping the --- implicit @import Prelude@, so bare names like @putStrLn@ (and even the @>>@ --- operator) fall out of scope. A marker built from those would /error/ instead --- of printing — its marker would never appear and 'drainUntil' would block --- forever waiting for it (the "stuck Building…" stall). Fully-qualified --- 'System.IO.hPutStrLn' resolves via GHCi's implicit qualified imports even --- with an emptied scope, so the marker survives an interrupt. -sendSyncCommand :: (File :> es) => Handle -> Text -> Eff es () -sendSyncCommand h marker = do - -- Use show to produce a valid Haskell string literal for the marker text. - let markerLit = toText (show @String (toString marker)) -- e.g. "\"#~TRI-FINISH-3~#\"" - File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stdout " <> markerLit) - File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stderr " <> markerLit) - File.hFlush h - - --- | Read lines from a handle until /this command's/ finish marker is seen (or --- EOF). --- --- Stops only on a line containing the exact @marker@ it was given. A line --- carrying a /different/ finish marker — a stale leftover from a prior command --- that was interrupted mid-flight — is skipped rather than matched, so it can --- never make a later drain return prematurely (the "0 modules"/hang desync). --- Each ordinary line is passed to @onLine@ as it arrives, so callers can stream --- progress without waiting for the full drain to complete. Returns accumulated --- non-marker lines in order. Throws 'UnexpectedExit' on EOF before the marker. -drainUntil :: (File :> es) => Handle -> Text -> (Text -> Eff es ()) -> Eff es [Text] -drainUntil h marker onLine = go [] - where - go acc = do - result <- trySync $ File.hGetLine h - case result of - Left _ -> - throwIO $ UnexpectedExit marker (listToMaybe (reverse acc)) - Right line - | marker `T.isInfixOf` line -> pure (reverse acc) - -- A stale marker from an interrupted command: drop it, keep going. - | markerPrefix `T.isInfixOf` line -> go acc - | otherwise -> do - onLine line - go (line : acc) - - --- | Convert a 'GhciLoading' progress callback into a per-line hook suitable --- for 'drainUntil'. Non-progress lines are ignored. -progressLineHook :: (GhciLoading -> Eff es ()) -> Text -> Eff es () -progressLineHook onProgress line = traverse_ onProgress (parseProgressLine line) - - --- | Wait up to the given number of seconds for a GHCi version banner on --- stdout, capturing stderr (and any non-banner stdout lines) in case the --- build command fails before printing a banner. --- --- Throws 'StartupFailed' with the captured output if stdout EOFs (the build --- command exited) or 'StartupTimeout' if the banner never arrives. -waitForBannerOrFail - :: ( Conc :> es - , Concurrent :> es - , File :> es - , Timeout :> es - ) - => Second -> Handle -> Handle -> Eff es () -waitForBannerOrFail delay out err = do - capturedVar <- newTVarIO ([] :: [Text]) - let captureLine line = atomically $ modifyTVar' capturedVar (line :) - drainStderr = drainUntilEof err captureLine - watchStdout = waitForBannerStdout out captureLine - - Conc.scoped do - stderrThread <- Conc.fork drainStderr - result <- timeout delay $ trySync watchStdout - case result of - Just (Right ()) -> pure () - Just (Left ex) -> do - -- stdout EOF before the banner: the build command exited. Wait - -- for the stderr drain to reach EOF too (bounded, in case the - -- pipe lingers) so we surface its *complete* output — e.g. - -- cabal's dependency-resolution error — rather than whatever - -- the drain happened to have read so far. - _ <- timeout (1 :: Second) (Conc.await stderrThread) - captured <- atomically $ readTVar capturedVar - throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured) - Nothing -> do - captured <- atomically $ readTVar capturedVar - throwIO $ maybe StartupTimeout StartupFailed (renderCapturedLines captured) - - -waitForBannerStdout :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es () -waitForBannerStdout h captureLine = go - where - isVersionLine :: Text -> Bool - isVersionLine line = - let stripped = stripAnsi line - in "GHCi, version " `T.isInfixOf` stripped - || "GHCJSi, version " `T.isInfixOf` stripped - || "Clashi, version " `T.isInfixOf` stripped - - go = do - result <- trySync $ File.hGetLine h - case result of - Left ex -> throwIO ex - Right line -> - if isVersionLine line then - pure () - else do - captureLine line - go - - -drainUntilEof :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es () -drainUntilEof h onLine = go - where - go = do - result <- trySync $ File.hGetLine h - case result of - Left _ -> pure () - Right line -> onLine line >> go - - --- | Render the captured (reverse-order) output lines into an error message, --- stripping ANSI escapes and dropping blank lines. Returns 'Nothing' when --- nothing useful remains, so callers can fall back to a generic message. -renderCapturedLines :: [Text] -> Maybe Text -renderCapturedLines capturedRev = - let cleaned = filter (not . T.null . T.strip) (map stripAnsi (reverse capturedRev)) - in if null cleaned then Nothing else Just (T.intercalate "\n" cleaned) - - --- | Fallback message when the build command exited before the banner without --- printing anything we could capture. -startupExitedMessage :: SomeException -> Text -startupExitedMessage ex = - "Build command exited before GHCi started: " <> toText (displayException ex) - - --- | Parse already-drained GHCi output lines into a 'LoadResult', fetching the --- current module list via @:show modules@. --- --- Progress is emitted live by 'drainUntil' as lines arrive, so no replay --- callback is needed here — this function only assembles the final result. -collectGhciResult - :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) - => GhciProcess - -> [Text] - -> FilePath - -> Eff es LoadResult -collectGhciResult process lines' projectRoot = do - let noProgress = \_ -> pure () - moduleLines <- execGhci process ":show modules" noProgress - targetLines <- execGhci process ":show targets" noProgress - let result = - collectResult - projectRoot - lines' - (parseShowModules moduleLines) - (parseShowTargets targetLines) - -- A failed load with no located error produces only the synthetic - -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in - -- that case, so log the raw GHCi output — it's the only way to see what - -- actually went wrong, and the synthetic diagnostic points here. - when (any (== unattributedFailure) result.diagnostics) - $ Log.info - $ "GHCi reported a failed load with no located error. Full GHCi output:\n" - <> T.unlines lines' - pure result - - --- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events --- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read. -reloadGhci - :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) - => GhciProcess - -> FilePath - -> (GhciLoading -> Eff es ()) - -> Eff es LoadResult -reloadGhci process projectRoot onProgress = do - reloadLines <- execGhci process ":reload" onProgress - collectGhciResult process reloadLines projectRoot - - --- | Execute @:add@ for the given file and return the assembled 'LoadResult'. --- Progress events fire live via @onProgress@ as compilation proceeds. -addGhci - :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) - => GhciProcess - -> FilePath -- the file to :add - -> FilePath -- projectRoot - -> (GhciLoading -> Eff es ()) - -> Eff es LoadResult -addGhci process filePath projectRoot onProgress = do - addLines <- execGhci process (":add " <> T.pack filePath) onProgress - collectGhciResult process addLines projectRoot - - --- | Execute @:unadd@ for the given module and return the assembled --- 'LoadResult'. Progress events fire live via @onProgress@ as compilation --- proceeds. -unaddGhci - :: (Conc :> es, Concurrent :> es, File :> es, Log :> es) - => GhciProcess - -> Text -- the module name to :unadd - -> FilePath -- projectRoot - -> (GhciLoading -> Eff es ()) - -> Eff es LoadResult -unaddGhci process moduleName projectRoot onProgress = do - unaddLines <- execGhci process (":unadd " <> moduleName) onProgress - collectGhciResult process unaddLines projectRoot diff --git a/src/Tricorder/Effects/Logging.hs b/src/Tricorder/Effects/Logging.hs deleted file mode 100644 --- a/src/Tricorder/Effects/Logging.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Tricorder.Effects.Logging (runLogging) where - -import Atelier.Effects.File (BufferMode (..), File) -import Atelier.Effects.Log (Log, Severity (..), runLogToHandle) -import Effectful (IOE) -import Effectful.Reader.Static (Reader, asks) - -import Atelier.Effects.File qualified as File - -import Tricorder.Runtime (LogPath (..)) - - -runLogging :: (File :> es, IOE :> es, Reader LogPath :> es) => Eff (Log : es) a -> Eff es a -runLogging act = do - path <- asks @LogPath (.getLogPath) - File.withFile path AppendMode \h -> do - File.hSetBuffering h LineBuffering - runLogToHandle h INFO act diff --git a/src/Tricorder/Effects/SessionStore.hs b/src/Tricorder/Effects/SessionStore.hs deleted file mode 100644 --- a/src/Tricorder/Effects/SessionStore.hs +++ /dev/null @@ -1,120 +0,0 @@ -module Tricorder.Effects.SessionStore - ( SessionStore (..) - , SessionStoreReloaded (..) - , get - , rawReload - , withSession - , withSubSession - , ActiveSession (..) - , Reloader (..) - , runSessionStore - , runSessionStoreConst - ) where - -import Atelier.Config (LoadedConfig) -import Atelier.Effects.Chan (Chan) -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.FileSystem (FileSystem) -import Atelier.Effects.Log (Log) -import Atelier.Effects.Publishing (Pub, Sub, publish) -import Effectful (Effect) -import Effectful.Concurrent (Concurrent) -import Effectful.Dispatch.Dynamic (interpret_, reinterpretWith_) -import Effectful.Reader.Static (Reader) -import Effectful.TH (makeEffect) -import Relude.Extra.Tuple (dup) - -import Atelier.Effects.Conc qualified as Conc -import Atelier.Effects.Iterator qualified as Iter -import Atelier.Effects.Publishing qualified as Sub -import Effectful.State.Static.Shared qualified as State - -import Tricorder.Runtime (ProjectRoot) -import Tricorder.Session (Session, loadSession) - - -data SessionStore :: Effect where - Get :: SessionStore m Session - RawReload :: SessionStore m () - - -makeEffect ''SessionStore - - -data ActiveSession es = ActiveSession - { session :: Session - , reloader :: Reloader es - } - - -newtype Reloader es = Reloader {reload :: Eff es ()} - - --- | Operate on the most recent 'Session' stored. Whenever the session is --- reloaded, the passed action is cancelled, and started again with the new --- 'Session'. -withSession - :: ( Conc :> es - , SessionStore :> es - , Sub SessionStoreReloaded :> es - ) - => (ActiveSession es -> Eff es a) - -> Eff es Void -withSession act = - Conc.restartableForkWith (void $ Sub.listenOnce_ @SessionStoreReloaded) get \session -> - act ActiveSession {session, reloader = Reloader rawReload} - - --- | Tracks the parts of 'Session' that the caller cares about, and restarts --- the passed function whenever those parts change based on the 'subSession's --- 'Eq' instance. -withSubSession - :: forall subSession es a - . ( Chan :> es - , Conc :> es - , Concurrent :> es - , Eq subSession - , SessionStore :> es - , Sub SessionStoreReloaded :> es - ) - => (Session -> subSession) - -> Session - -> (Reloader es -> subSession -> Eff es a) - -> Eff es Void -withSubSession mkSubSession initialSession action = - Iter.fromEvents @SessionStoreReloaded \iter -> - let initialSubSession = mkSubSession initialSession - subIter = - Iter.changes - initialSubSession - (fmap (\(SessionStoreReloaded s) -> mkSubSession s) iter) - in Conc.restartableForkLoop - initialSubSession - (Iter.next subIter) - \cfg -> action (Reloader rawReload) cfg - - -data SessionStoreReloaded = SessionStoreReloaded Session - - -runSessionStore - :: ( FileSystem :> es - , Log :> es - , Pub SessionStoreReloaded :> es - , Reader LoadedConfig :> es - , Reader ProjectRoot :> es - ) - => Eff (SessionStore : es) a -> Eff es a -runSessionStore act = do - initialSession <- loadSession - reinterpretWith_ (State.evalState initialSession) act \case - Get -> State.get - RawReload -> do - session <- State.stateM (\_ -> dup <$> loadSession) - publish $ SessionStoreReloaded session - - -runSessionStoreConst :: Session -> Eff (SessionStore : es) a -> Eff es a -runSessionStoreConst session = interpret_ \case - Get -> pure session - RawReload -> pure () diff --git a/src/Tricorder/Effects/TestRunner.hs b/src/Tricorder/Effects/TestRunner.hs deleted file mode 100644 --- a/src/Tricorder/Effects/TestRunner.hs +++ /dev/null @@ -1,288 +0,0 @@ -module Tricorder.Effects.TestRunner - ( -- * Effect - TestRunner (..) - , runTestSuite - , interruptCurrent - , resetAbort - , isAborted - - -- * Interpreters - , runTestRunnerIO - , runTestRunnerScripted - - -- * Parsing utilities - , GhciOutcome (..) - , detectOutcome - - -- * Internal helpers (exported for testing) - , abortGatedProgress - , reportTestProgress - ) where - -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.File (File) -import Atelier.Effects.Log (Log) -import Atelier.Effects.Process (Process) -import Atelier.Effects.Timeout (Timeout, timeout) -import Control.Concurrent.STM (TVar, readTVar, writeTVar) -import Control.Exception (throwIO) -import Data.Default (def) -import Data.Time.Units (Second) -import Effectful (Effect, IOE) -import Effectful.Concurrent (Concurrent) -import Effectful.Concurrent.STM (atomically, newTVarIO) -import Effectful.Dispatch.Dynamic (interpretWith_, reinterpret) -import Effectful.Exception (bracket_, trySync) -import Effectful.Reader.Static (Reader, ask) -import Effectful.State.Static.Shared (State, evalState, get, put) -import Effectful.TH (makeEffect) - -import Atelier.Effects.Log qualified as Log -import Data.List qualified as List -import Data.Text qualified as T - -import Tricorder.BuildState - ( BuildPhase (..) - , BuildProgress (..) - , BuildResult (..) - , BuildState (..) - , TestRun (..) - , TestRunCompletion (..) - , TestRunError (..) - ) -import Tricorder.Effects.BuildStore (BuildStore, modifyPhase) -import Tricorder.Effects.GhciSession.GhciParser (GhciLoading (..)) -import Tricorder.Effects.GhciSession.GhciProcess (GhciProcess, execGhci, terminateGhciProcess, withGhciProcess) -import Tricorder.Effects.SessionStore (SessionStore) -import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Command (..), Session (..), TestTimeout (..)) -import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) - -import Tricorder.Effects.SessionStore qualified as SessionStore - - -data TestRunner :: Effect where - -- | Run a single test suite in a short-lived @cabal repl@ process and - -- return the captured output and detected outcome. - RunTestSuite :: Text -> TestRunner m TestRun - -- | Interrupt the test currently in flight (if any) and latch an abort - -- flag so that subsequent 'RunTestSuite' calls short-circuit until - -- 'ResetAbort' is called. - InterruptCurrent :: TestRunner m () - -- | Clear the abort flag. Call this at the start of a new test run. - ResetAbort :: TestRunner m () - -- | Read the abort flag without clearing it. - IsAborted :: TestRunner m Bool - - -makeEffect ''TestRunner - - --- | Production interpreter that spawns a short-lived @cabal repl test:\@ --- process for each suite, feeds @:main\\n:quit\\n@ to stdin, captures combined --- stdout+stderr, and detects the outcome via 'detectOutcome'. -runTestRunnerIO - :: ( BuildStore :> es - , Conc :> es - , Concurrent :> es - , File :> es - , Log :> es - , Process :> es - , Reader ProjectRoot :> es - , SessionStore :> es - , Timeout :> es - ) - => Eff (TestRunner : es) a -> Eff es a -runTestRunnerIO act = do - ProjectRoot projectRoot <- ask - currentProcRef <- newTVarIO (Nothing :: Maybe GhciProcess) - abortedRef <- newTVarIO False - interpretWith_ act \case - InterruptCurrent -> do - -- Terminate (not just SIGINT) the test process: hspec/tasty - -- install their own SIGINT handlers that finalise the current - -- run rather than aborting it. Each test runs in its own - -- short-lived @cabal repl@ process, so killing it outright is - -- safe and gets a prompt abort. 'execGhci' then raises - -- 'UnexpectedExit', 'trySync' catches it, and the run loop - -- short-circuits on @abortedRef@. - mProc <- atomically do - writeTVar abortedRef True - readTVar currentProcRef - for_ mProc terminateGhciProcess - ResetAbort -> atomically (writeTVar abortedRef False) - IsAborted -> atomically (readTVar abortedRef) - RunTestSuite target -> do - alreadyAborted <- atomically (readTVar abortedRef) - if alreadyAborted then - pure $ TestRunErrored $ TestRunError {target, message = "Test run aborted"} - else do - Session {testTimeout} <- SessionStore.get - let onProgress = abortGatedProgress abortedRef target - noProgress = \_ -> pure () - -- Register the process as soon as 'setupGhciProcess' - -- constructs it — before the initial @cabal repl@ - -- compile drain runs. Without this, an interrupt that - -- arrives during that drain would find - -- 'currentProcRef' empty and have nothing to kill, so - -- the new build's cycle would have to wait several - -- seconds for the doomed @cabal repl@ to finish - -- compiling its test code before the cycle lock was - -- released. - onReady ghci = atomically (writeTVar currentProcRef (Just ghci)) - -- Outer bracket: always clear 'currentProcRef' on exit, - -- whether 'withGhciProcess' completed normally or threw. - result <- trySync - $ bracket_ - (pure ()) - (atomically (writeTVar currentProcRef Nothing)) - $ withGhciProcess def (Command $ "cabal repl " <> target) projectRoot onProgress onReady \ghci _ -> - atomically (readTVar abortedRef) >>= \case - -- An interrupt may have landed during the - -- @cabal repl@ load. The returned value is - -- discarded by the run loop once it sees - -- 'abortedRef'. - True -> pure (Right []) - False -> case testTimeout of - TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress - TestTimeout secs -> - timeout (fromIntegral secs :: Second) (execGhci ghci ":main" noProgress) >>= \case - Nothing -> pure (Left secs) - Just ls -> pure (Right ls) - case result of - Left ex -> - pure $ TestRunErrored $ TestRunError {target, message = show ex} - Right (Left secs) -> do - Log.warn $ "Test suite " <> target <> " timed out after " <> show secs <> "s" - pure $ TestRunErrored $ TestRunError {target, message = "Test suite timed out after " <> show secs <> "s"} - Right (Right mainLines) -> - pure - $ let output = T.unlines mainLines - in case detectOutcome output of - GhciCrashed msg -> - TestRunErrored $ TestRunError {target, message = msg} - outcome -> - TestRunCompleted - $ TestRunCompletion - { target - , passed = outcome == GhciPassed - , output - , testCases = parseHspecOutput output - , duration = parseHspecDuration output - } - - --- | Scripted interpreter for testing. --- --- Each call to 'runTestSuite' pops the next result from the pre-loaded list. --- 'Left' results are re-thrown as exceptions, simulating process failures. -runTestRunnerScripted - :: forall es a - . (Concurrent :> es, IOE :> es) - => [Either SomeException TestRun] - -> Eff (TestRunner : es) a - -> Eff es a -runTestRunnerScripted results act = do - -- Mirror the IO interpreter's abort semantics so tests that drive - -- 'runTestsIfClean' through an interrupt can actually observe the - -- short-circuit via 'isAborted'. A hard-coded 'pure False' would - -- silently mask any regression in that flow. - abortedRef <- newTVarIO False - reinterpret - (evalState results) - ( \_ -> \case - RunTestSuite _ -> popResult - InterruptCurrent -> atomically (writeTVar abortedRef True) - ResetAbort -> atomically (writeTVar abortedRef False) - IsAborted -> atomically (readTVar abortedRef) - ) - act - where - popResult :: Eff (State [Either SomeException TestRun] : es) TestRun - popResult = - get >>= \case - [] -> error "TestRunnerScripted: no more results in queue" - Left ex : rest -> put rest >> liftIO (throwIO ex) - Right r : rest -> put rest >> pure r - - --- | Progress callback used while a test suite is running. Reads the test --- runner's abort flag before applying the update so that pipe-buffered --- '[N of M] Compiling' lines emitted by a dying test process — after the --- user has already touched a file — do not push the counter forward. -abortGatedProgress - :: (BuildStore :> es, Concurrent :> es) - => TVar Bool -> Text -> GhciLoading -> Eff es () -abortGatedProgress abortedRef target loading = do - aborted <- atomically (readTVar abortedRef) - unless aborted $ reportTestProgress target loading - - --- | Patch live compile progress for a test suite into the current 'Testing' --- phase of the build state. --- --- A test suite's @cabal repl@ session typically recompiles a slice of the --- project before running @:main@. Mirroring the main-build progress bar, we --- update the matching 'TestRunning' entry as each @[N of M] Compiling …@ --- line arrives so the UI shows @running... (N/M)@ live. --- --- The update is best-effort: if the phase has moved on (e.g. a source change --- triggered 'Restarting' or 'Building'), the progress event is dropped rather --- than reverting the phase. -reportTestProgress - :: (BuildStore :> es) => Text -> GhciLoading -> Eff es () -reportTestProgress target loading = - modifyPhase \state -> case state.phase of - Testing partialResult -> - let progress = BuildProgress {compiled = loading.index, total = loading.total} - updateRun (TestRunning t _) | t == target = TestRunning t (Just progress) - updateRun r = r - newRuns = map updateRun partialResult.testRuns - in Testing partialResult {testRuns = newRuns} - other -> other - - -data GhciOutcome - = GhciPassed - | GhciFailed - | GhciCrashed Text - deriving stock (Eq, Show) - - --- | Detect the test outcome from raw GHCi output. --- --- All major test frameworks (@hspec@, @tasty@, @HUnit@) call --- 'System.Exit.exitWith' on completion. GHCi surfaces this as a line --- matching @*** Exception: ExitSuccess@ (pass) or --- @*** Exception: ExitFailure N@ (fail). Any other @*** Exception:@ line --- means the runner crashed. --- --- When no exception line is present, the absence is ambiguous: either the --- test ran and printed nothing exit-related, or @:main@ never ran at all --- (e.g. the test target failed to compile, so @main@ is not in scope). --- A line containing @": error:"@ in the captured output is treated as the --- latter — a GHC compile/load error that prevented the suite from running. -detectOutcome :: Text -> GhciOutcome -detectOutcome output = - case List.find ("*** Exception: " `T.isPrefixOf`) outputLines of - Just line -> - case T.stripPrefix "*** Exception: " line of - Nothing -> GhciPassed - Just rest -> - let r = T.strip rest - in if r == "ExitSuccess" then - GhciPassed - else - if "ExitFailure" `T.isPrefixOf` r then - GhciFailed - else - GhciCrashed r - Nothing -> case List.find isCompileErrorLine outputLines of - Just errLine -> GhciCrashed (T.strip errLine) - Nothing -> GhciPassed - where - outputLines = T.lines output - -- GHC compile/load errors are formatted as - -- @: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 deleted file mode 100644 --- a/src/Tricorder/Effects/UnixSocket.hs +++ /dev/null @@ -1,154 +0,0 @@ -module Tricorder.Effects.UnixSocket - ( -- * Effect - UnixSocket - , bindSocket - , acceptHandle - , withConnection - , readLine - , sendLine - , closeHandle - , removeSocketFile - , socketFileExists - - -- * Interpreters - , runUnixSocketIO - , runUnixSocketScripted - , SocketScript (..) - ) where - -import Atelier.Effects.File (BufferMode (..), File, Handle) -import Atelier.Exception (trySyncIO) -import Effectful (Effect, IOE) -import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, reinterpret) -import Effectful.Exception (finally) -import Effectful.State.Static.Shared (evalState, get, put) -import Effectful.TH (makeEffect) -import Network.Socket - ( Family (..) - , SockAddr (..) - , Socket - , SocketType (..) - , accept - , bind - , defaultProtocol - , listen - , socket - , socketToHandle - ) -import System.Directory (doesPathExist, removeFile) -import System.IO (hSetEncoding, utf8) - -import Atelier.Effects.File qualified as File -import Network.Socket qualified as Net - - -data UnixSocket :: Effect where - -- | Create, bind, and listen on a Unix socket at the given path. - BindSocket :: FilePath -> UnixSocket m Socket - -- | Accept the next incoming connection and return a line-buffered 'Handle'. - AcceptHandle :: Socket -> UnixSocket m Handle - -- | Connect to a Unix socket and run the callback with the resulting handle. - -- The handle is closed when the callback returns. - WithConnection :: FilePath -> (Handle -> m a) -> UnixSocket m a - -- | Read a line from a connected handle. - ReadLine :: Handle -> UnixSocket m Text - -- | Write a line to a connected handle and flush. - SendLine :: Handle -> Text -> UnixSocket m () - -- | Close a connected handle. - CloseHandle :: Handle -> UnixSocket m () - -- | Remove the socket file, ignoring errors (e.g. file not found). - RemoveSocketFile :: FilePath -> UnixSocket m () - -- | Check whether the socket file exists. - SocketFileExists :: FilePath -> UnixSocket m Bool - - -makeEffect ''UnixSocket - - --- | Production interpreter backed by real Unix sockets. --- --- Socket creation and encoding setup require raw IO (no @File@ equivalent), --- but the handle-level reads, writes, buffering and closing go through the --- 'File' effect. -runUnixSocketIO :: (File :> es, IOE :> es) => Eff (UnixSocket : es) a -> Eff es a -runUnixSocketIO eff = interpretWith eff \env -> \case - BindSocket path -> liftIO do - sock <- socket AF_UNIX Stream defaultProtocol - bind sock (SockAddrUnix path) - listen sock 5 - pure sock - AcceptHandle sock -> do - h <- liftIO do - (conn, _) <- accept sock - h <- socketToHandle conn ReadWriteMode - hSetEncoding h utf8 - pure h - File.hSetBuffering h LineBuffering - pure h - WithConnection sockPath callback -> - localSeqUnlift env \unlift -> do - h <- liftIO do - sock <- socket AF_UNIX Stream defaultProtocol - Net.connect sock (SockAddrUnix sockPath) - h <- socketToHandle sock ReadWriteMode - hSetEncoding h utf8 - pure h - File.hSetBuffering h LineBuffering - unlift (callback h) `finally` File.hClose h - ReadLine h -> File.hGetLine h - SendLine h line -> File.hPutTextLn h line >> File.hFlush h - CloseHandle h -> File.hClose h - RemoveSocketFile path -> - liftIO $ void $ trySyncIO $ removeFile path - SocketFileExists path -> - liftIO $ doesPathExist path - - --- | Script element for the test interpreter. -data SocketScript - = -- | Return this 'Handle' for the next 'acceptHandle' call. - NextAccept Handle - | -- | Return this 'Bool' for the next 'socketFileExists' call. - NextFileCheck Bool - | -- | Use this 'Handle' for the next 'withConnection' call. - NextConnect Handle - | -- | Return this text for the next 'readLine' call. - NextReadLine Text - - --- | Scripted interpreter for testing. --- --- 'bindSocket' creates a real (unbound) socket so that the returned 'Socket' --- is a valid value, but does not actually bind to the filesystem. --- 'acceptHandle' pops the next 'NextAccept' entry from the queue and sets --- line buffering on it. 'removeSocketFile' is always a no-op. --- 'socketFileExists' pops the next 'NextFileCheck' entry. --- 'withConnection' pops the next 'NextConnect' entry and passes it to the callback. -runUnixSocketScripted :: (File :> es, IOE :> es) => [SocketScript] -> Eff (UnixSocket : es) a -> Eff es a -runUnixSocketScripted script = reinterpret (evalState script) \env -> \case - BindSocket _ -> - liftIO $ Net.socket AF_UNIX Stream defaultProtocol - AcceptHandle _ -> - get >>= \case - NextAccept h : rest -> do - put rest - File.hSetBuffering h LineBuffering - pure h - _ -> error "UnixSocketScripted: expected NextAccept but queue was empty or mismatched" - WithConnection _ callback -> - get >>= \case - NextConnect h : rest -> do - put rest - localSeqUnlift env \unlift -> unlift (callback h) - _ -> error "UnixSocketScripted: expected NextConnect but queue was empty or mismatched" - ReadLine _ -> - get >>= \case - NextReadLine line : rest -> put rest >> pure line - _ -> error "UnixSocketScripted: expected NextReadLine but queue was empty or mismatched" - SendLine _ _ -> pure () - CloseHandle _ -> pure () - RemoveSocketFile _ -> pure () - SocketFileExists _ -> - get >>= \case - NextFileCheck b : rest -> put rest >> pure b - _ -> error "UnixSocketScripted: expected NextFileCheck but queue was empty or mismatched" diff --git a/src/Tricorder/Events/FileChanged.hs b/src/Tricorder/Events/FileChanged.hs deleted file mode 100644 --- a/src/Tricorder/Events/FileChanged.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Tricorder.Events.FileChanged (FileChanged (..)) where - - --- | A relevant source file was modified on disk. -newtype FileChanged = FileChanged {path :: FilePath} - deriving stock (Eq, Show) diff --git a/src/Tricorder/GhcPkg/Types.hs b/src/Tricorder/GhcPkg/Types.hs deleted file mode 100644 --- a/src/Tricorder/GhcPkg/Types.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Tricorder.GhcPkg.Types - ( ModuleName (..) - , PackageId (..) - , SourceQuery (..) - ) where - -import Data.Aeson (FromJSON, ToJSON) - - --- | A dotted Haskell module name, e.g. @"Data.Map.Strict"@. -newtype ModuleName = ModuleName {unModuleName :: Text} - deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON) - - --- | A @ghc-pkg@ package identifier, e.g. @"containers-0.6.8"@. -newtype PackageId = PackageId {unPackageId :: Text} - deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON) - - --- | A query for module source: optionally scoped to a single top-level binding. -data SourceQuery = SourceQuery - { moduleName :: ModuleName - , function :: Maybe Text -- Nothing = whole module, Just fn = single binding - } - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, Hashable, ToJSON) diff --git a/src/Tricorder/Logging.hs b/src/Tricorder/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Logging.hs @@ -0,0 +1,18 @@ +module Tricorder.Logging (runLogging) where + +import Atelier.Effects.File (BufferMode (..), File) +import Atelier.Effects.Log (Log, Severity (..), runLogToHandle) +import Effectful (IOE) +import Effectful.Reader.Static (Reader, asks) + +import Atelier.Effects.File qualified as File + +import Tricorder.Runtime (LogPath (..)) + + +runLogging :: (File :> es, IOE :> es, Reader LogPath :> es) => Eff (Log : es) a -> Eff es a +runLogging act = do + path <- asks @LogPath (.getLogPath) + File.withFile path AppendMode \h -> do + File.hSetBuffering h LineBuffering + runLogToHandle h INFO act diff --git a/src/Tricorder/Module.hs b/src/Tricorder/Module.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Module.hs @@ -0,0 +1,13 @@ +module Tricorder.Module (ModuleName (..), PackageId (..)) where + +import Data.Aeson (FromJSON, ToJSON) + + +-- | A dotted Haskell module name, e.g. @"Data.Map.Strict"@. +newtype ModuleName = ModuleName {unModuleName :: Text} + deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON) + + +-- | A @ghc-pkg@ package identifier, e.g. @"containers-0.6.8"@. +newtype PackageId = PackageId {unPackageId :: Text} + deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON) diff --git a/src/Tricorder/Observability.hs b/src/Tricorder/Observability.hs deleted file mode 100644 --- a/src/Tricorder/Observability.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Tricorder.Observability - ( Config (..) - , MetricsConfig (..) - , component - ) where - -import Atelier.Component (Component (..), Trigger, defaultComponent) -import Atelier.Effects.Delay (Delay) -import Atelier.Effects.Log (Log) -import Atelier.Effects.Monitoring.Metrics.Server (MetricsServer) -import Atelier.Effects.Monitoring.Tracing (TracingConfig) -import Atelier.Time (Millisecond) -import Atelier.Types.QuietSnake (QuietSnake (..)) -import Atelier.Types.WithDefaults (WithDefaults (..)) -import Data.Aeson (FromJSON, ToJSON) -import Data.Default (Default (..)) -import Effectful.Exception (trySync) -import Effectful.Reader.Static (Reader, ask) - -import Atelier.Effects.Delay qualified as Delay -import Atelier.Effects.Log qualified as Log -import Atelier.Effects.Monitoring.Metrics.Server qualified as MetricsServer - - -data MetricsConfig = MetricsConfig - { enabled :: Bool - , port :: Int - } - deriving stock (Eq, Generic, Show) - deriving (ToJSON) via QuietSnake MetricsConfig - deriving (FromJSON) via WithDefaults (QuietSnake MetricsConfig) - - -instance Default MetricsConfig where - def = MetricsConfig {enabled = False, port = 9091} - - -data Config = Config - { metrics :: MetricsConfig - , tracing :: TracingConfig - } - deriving stock (Eq, Generic, Show) - deriving (FromJSON) via QuietSnake Config - - -instance Default Config where - def = Config {metrics = def, tracing = def} - - -component :: (Delay :> es, Log :> es, MetricsServer :> es, Reader Config :> es) => Component es -component = - defaultComponent - { name = "Observability" - , triggers = do - cfg <- ask @Config - pure - $ if cfg.metrics.enabled then - [metricsServerTrigger cfg.metrics.port] - else - [] - } - - -metricsServerTrigger :: (Delay :> es, Log :> es, MetricsServer :> es) => Int -> Trigger es -metricsServerTrigger port = do - result <- trySync $ MetricsServer.runMetricsServer port - case result of - Right () -> pure () - Left e -> - Log.warn $ "Metrics server on port " <> show port <> " failed to start: " <> show e - forever $ Delay.wait (3_600_000 :: Millisecond) diff --git a/src/Tricorder/Session.hs b/src/Tricorder/Session.hs --- a/src/Tricorder/Session.hs +++ b/src/Tricorder/Session.hs @@ -1,541 +1,97 @@ module Tricorder.Session ( Session (..) - , Config (..) - , Command (..) - , TestTargets - , getTestTargets - , parseTestTargets - , Target (..) - , ComponentKind (..) - , parseTarget - , renderTarget - , WatchDirs (..) - , WatchExclusionPatterns (..) - , ReplBuildDir (..) - , TestTimeout (..) - , Pattern , loadSession - , resolveCommand - , resolveTargets - , discoverCabalFiles - , allComponentTargets - , resolveTestTargets - , resolveWatchDirs - , sourceDirsForTarget - , compareTargets + , inputSession ) where import Atelier.Config (LoadedConfig, extractConfig) -import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs) +import Atelier.Effects.FileSystem (FileSystem) +import Atelier.Effects.Input (Input, input, runInputEff) import Atelier.Effects.Log (Log) -import Atelier.Types.QuietSnake (QuietSnake (..)) -import Atelier.Types.WithDefaults (WithDefaults (..)) -import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Default (Default (..)) -import Data.List (nub) -import Distribution.Compat.Lens (view) -import Distribution.Fields (Field (..), FieldLine (..), Name (..), readFields) -import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) -import Distribution.Types.CondTree (condTreeData) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription - , condBenchmarks - , condExecutables - , condForeignLibs - , condLibrary - , condSubLibraries - , condTestSuites - , packageDescription - ) -import Distribution.Types.PackageDescription (package) -import Distribution.Types.PackageId (pkgName) -import Distribution.Types.PackageName (unPackageName) -import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName) -import Distribution.Utils.Path (getSymbolicPath) -import Effectful.Exception (throwIO) import Effectful.Reader.Static (Reader, ask) -import System.FilePath (normalise, takeDirectory, takeExtension, ()) -import System.IO.Error (userError) -import Text.Regex.TDFA.ReadRegex (parseRegex) import Atelier.Effects.Log qualified as Log -import Data.ByteString.Char8 qualified as BC import Data.Text qualified as T -import Distribution.Types.BuildInfo.Lens qualified as Lens -import Text.Regex.TDFA.Pattern qualified as Regex import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.CabalFile (CabalFile) +import Tricorder.Session.Command (Command (..), resolveCommand) +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.ReplBuildDir (ReplBuildDir (..)) +import Tricorder.Session.Target (Target, definesCustomPrelude, resolveTargets) +import Tricorder.Session.TestTarget (TestTarget, resolveTestTargets) +import Tricorder.Session.TestTimeout (TestTimeout (..)) +import Tricorder.Session.WatchDirs (WatchDirs (..), resolveWatchDirs) +import Tricorder.Session.WatchExclusionPatterns (WatchExclusionPatterns (..), resolveWatchExclusionPatterns) data Session = Session { command :: Command , targets :: [Target] - , testTargets :: TestTargets + , testTargets :: [TestTarget] , watchDirs :: WatchDirs , watchExclusionPatterns :: WatchExclusionPatterns , replBuildDir :: ReplBuildDir , testTimeout :: TestTimeout } - - -type Pattern = (Regex.Pattern, (Regex.GroupIndex, Regex.DoPa)) + deriving stock (Eq) instance Default Session where def = Session - { command = Command "" - , targets = [] - , testTargets = projectTestTargets [] - , watchDirs = WatchDirs [] - , watchExclusionPatterns = WatchExclusionPatterns [] - , replBuildDir = ReplBuildDir "/tmp" - , testTimeout = TestTimeout 10 - } - - -data Config = Config - { command :: Maybe Text - , targets :: [Text] - , watchDirs :: [FilePath] - , watchExclusionPatterns :: [Text] - , testTargets :: Maybe [Text] - , replBuildDir :: FilePath - , testTimeout :: Int - } - deriving stock (Eq, Generic, Show) - deriving (FromJSON) via WithDefaults (QuietSnake Config) - - -instance Default Config where - def = - Config - { command = Nothing + { command = def , targets = [] - , watchDirs = [] - , watchExclusionPatterns = [] - , testTargets = Nothing - , replBuildDir = "dist-newstyle/tricorder" - , testTimeout = 10 + , testTargets = [] + , watchDirs = def + , watchExclusionPatterns = def + , replBuildDir = def + , testTimeout = def } -newtype Command = Command {getCommand :: Text} - deriving stock (Eq, Generic, Show) - deriving (FromJSON, ToJSON) via Text - - --- | The test suites to run after a clean build. Built only by projecting a --- target list onto its @test:@ components via 'projectTestTargets'; the data --- constructor is not exported, so a 'TestTargets' can never hold a non-test --- target [ref:test_targets_invariant]. -newtype TestTargets = TestTargets {getTestTargets :: [Target]} - deriving stock (Eq, Generic, Show) - deriving (FromJSON, ToJSON) via [Target] - - --- | [tag:test_targets_invariant] Project a target list onto its test suites — --- the only way to build a 'TestTargets', so the @test:@-only invariant holds by --- construction. -projectTestTargets :: [Target] -> TestTargets -projectTestTargets = TestTargets . filter isTestTarget - where - isTestTarget (Qualified Test _) = True - isTestTarget _ = False - - --- | Parse raw target strings (e.g. the @test_targets@ config) and project them --- onto their test suites — non-test entries are dropped. -parseTestTargets :: [Text] -> TestTargets -parseTestTargets = projectTestTargets . map parseTarget - - --- | A cabal build target, parsed from its textual @[kind:]name@ form. Used to --- resolve which source directories belong to a target. -data Target - = -- | A @kind:name@ reference, e.g. @lib:foo@, @exe:foo@, @test:foo@. An - -- empty name with 'Lib' (i.e. @lib:@) denotes the package's main library. - Qualified ComponentKind Text - | -- | A name with no @kind:@ prefix. Refers either to a package (all of its - -- components) or to a single component matched by name. - Bare Text - | -- | A form we don't recognize: an unknown kind, or extra colons. - Unrecognized Text - deriving stock (Eq, Show) - - --- | The kind of cabal component a 'Qualified' target names. Covers every --- component kind cabal models (matching @Distribution.Types.ComponentName@). -data ComponentKind = Lib | FLib | Exe | Test | Bench - deriving stock (Bounded, Enum, Eq, Show) - - --- | [tag:kind_prefix_sole_source] The canonical prefix cabal uses for each --- component kind. Single source of truth shared by 'parseTarget' and --- 'renderTarget' — keep this the only place the prefix strings appear. --- --- We deliberately model only these canonical prefixes, not cabal's full set of --- aliases (@executable@, @test-suite@, …) or its case-folding. Those would mean --- hand-mirroring an unexported, internally-inconsistent cabal table; instead an --- aliased spelling falls to 'Unrecognized', which is still handed to cabal --- verbatim for the build and still resolves watch dirs by matching its trailing --- component name [ref:alias_name_match]. -kindPrefix :: ComponentKind -> Text -kindPrefix = \case - Lib -> "lib" - FLib -> "flib" - Exe -> "exe" - Test -> "test" - Bench -> "bench" - - --- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two --- never drift apart [ref:kind_prefix_sole_source]. -parseKind :: Text -> Maybe ComponentKind -parseKind = inverseMap kindPrefix - - --- | Classify a target's textual form. The grammar is @[kind:]name@ where --- @kind@ is one of @lib@, @flib@, @exe@, @test@, or @bench@; anything else (an --- unknown kind, a cabal alias such as @executable@, or extra colons) is --- 'Unrecognized'. -parseTarget :: Text -> Target -parseTarget target = case T.splitOn ":" target of - [prefix, name] | Just kind <- parseKind prefix -> Qualified kind name - [name] -> Bare name - _ -> Unrecognized target - - --- | Render a 'Target' back to the textual form cabal understands. Inverse of --- 'parseTarget' (lossless: @parseTarget . renderTarget == id@). Builds prefixes --- via 'kindPrefix' rather than hardcoding them [ref:kind_prefix_sole_source]. -renderTarget :: Target -> Text -renderTarget = \case - Qualified kind name -> kindPrefix kind <> ":" <> name - Bare name -> name - Unrecognized raw -> raw - - -instance ToJSON Target where - toJSON = toJSON . renderTarget - - -instance FromJSON Target where - parseJSON = fmap parseTarget . parseJSON - - -newtype WatchDirs = WatchDirs {getWatchDirs :: [FilePath]} - deriving stock (Eq, Generic, Show) - deriving (FromJSON, ToJSON) via [FilePath] - - -newtype WatchExclusionPatterns = WatchExclusionPatterns {getWatchExclusionPatterns :: [Pattern]} - deriving stock (Eq, Generic, Show) - - -newtype ReplBuildDir = ReplBuildDir {getReplBuildDir :: FilePath} - deriving stock (Eq, Generic, Show) - deriving (FromJSON, ToJSON) via FilePath - - -newtype TestTimeout = TestTimeout {getTestTimeout :: Int} - deriving stock (Eq, Generic, Show) - deriving (FromJSON, ToJSON) via Int - - --- | Resolve the GHCi command, using config if set or autodetecting otherwise. --- --- The @testTargets@ are the discovered @test:@ components; they are appended to --- the auto-detected @all@ target (see 'detectCommand'). They are ignored when --- the user has pinned an explicit @command@ or explicit @targets@ in config. -resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> TestTargets -> Eff es Command -resolveCommand projectRoot cfg targets testTargets = - case cfg.command of - Just cmd -> pure $ Command cmd - Nothing -> detectCommand targets testTargets cfg.replBuildDir projectRoot - - --- | Build the autodetected GHCi command. --- --- Configured @targets@ are spelled out verbatim. Otherwise we use cabal's --- catch-all @all@ plus the discovered @test:@ targets, because --- @cabal repl --enable-multi-repl all@ omits test suites unless the project sets --- @tests: True@ in @cabal.project@ — so test errors would go unnoticed. --- --- We keep @all@ rather than enumerating every component: @all@ lets cabal order --- the multi-repl units, and GHCi makes the /last/ unit the active one. If that --- unit imports a custom @Prelude@ from a sibling home package, GHCi reports it --- "not loaded" and the session dies — which a naive discovery-order enumeration --- triggers but @all@ avoids. Appending already-included test targets is a no-op --- (cabal deduplicates). -detectCommand :: (FileSystem :> es) => [Target] -> TestTargets -> FilePath -> ProjectRoot -> Eff es Command -detectCommand targets (TestTargets testTargets) replBuildDir (ProjectRoot projectRoot) = do - hasCabalProject <- doesFileExist (projectRoot "cabal.project") - cabalFiles <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory projectRoot - hasStack <- doesFileExist (projectRoot "stack.yaml") - let targetStr - | not (null targets) = unwords (map renderTarget targets) - | otherwise = unwords ("all" : map renderTarget testTargets) - buildDirFlag = "--builddir " <> toText replBuildDir <> " " - pure - if - | hasCabalProject || not (null cabalFiles) -> - Command $ "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr - | hasStack -> Command $ "stack ghci " <> targetStr - | otherwise -> Command $ "cabal repl " <> buildDirFlag <> targetStr - - --- | Resolve the directories to watch. --- --- Priority: --- 1. @watch_dirs@ from config, if non-empty (used as-is relative to project root) --- 2. @hs-source-dirs@ inferred from cabal targets, if targets are set --- 3. Falls back to @["."]@ (project root) if neither is available -resolveWatchDirs :: (FileSystem :> es) => ProjectRoot -> [FilePath] -> Config -> [Target] -> Eff es WatchDirs -resolveWatchDirs projectRoot cabalFiles cfg targets = - case cfg.watchDirs of - dirs@(_ : _) -> pure $ WatchDirs $ map (coerce projectRoot ) dirs - [] -> resolveWatchDirsFromTargets cabalFiles targets - - -resolveWatchDirsFromTargets :: (FileSystem :> es) => [FilePath] -> [Target] -> Eff es WatchDirs -resolveWatchDirsFromTargets _ [] = pure $ WatchDirs ["."] -resolveWatchDirsFromTargets cabalFiles targets = do - dirs <- nub . concat <$> traverse watchDirsForCabal cabalFiles - pure $ WatchDirs $ if null dirs then ["."] else dirs - where - -- @hs-source-dirs@ are relative to the package's own directory, so scope - -- them to the directory holding that package's @.cabal@. In a - -- single-package project that directory is the project root; in a - -- multi-package project it's the per-package subdirectory. Targets that - -- don't belong to this package yield no dirs. - watchDirsForCabal cabalFile = do - contents <- readFileBs cabalFile - let pkgDir = takeDirectory cabalFile - pure $ case parseGenericPackageDescriptionMaybe contents of - Nothing -> [] - Just gpd -> map (pkgDir ) (concatMap (sourceDirsForTarget gpd) targets) - - -sourceDirsForTarget :: GenericPackageDescription -> Target -> [FilePath] -sourceDirsForTarget gpd target = - map getSymbolicPath $ case target of - Qualified Lib "" -> mainLibSourceDirs - Qualified Lib name - | toString name == mainPkgName -> mainLibSourceDirs - | otherwise -> subLibSourceDirs name - Qualified FLib name -> flibSourceDirs name - Qualified Exe name -> exeSourceDirs name - Qualified Test name -> testSourceDirs name - Qualified Bench name -> benchSourceDirs name - -- A bare target (no @kind:@ prefix) is a package name or a component - -- name. A package name covers every component; otherwise match a - -- single component by name across the kinds. - Bare name - | toString name == mainPkgName -> allComponentSourceDirs - | otherwise -> componentSourceDirsByName name - -- [tag:alias_name_match] A form we couldn't parse into a kind — a cabal - -- alias (@executable:@) or a case variant (@Lib:@). The kind is - -- untrustworthy, but cabal component names are unique within a package, - -- so we match the trailing name across every kind. This recovers precise - -- watch dirs for aliased spellings; worst case we over-match a - -- same-named component, never miss one. (The raw string is still handed - -- to cabal verbatim for the build.) - Unrecognized raw -> componentSourceDirsByName (T.takeWhileEnd (/= ':') raw) - where - mainPkgName = unPackageName . pkgName . package . packageDescription $ gpd - - -- @hs-source-dirs@ of any component, via the @HasBuildInfo@ lens — one - -- accessor that works uniformly across libraries, foreign libs, exes, - -- tests, and benchmarks, so we don't repeat a per-kind @buildInfo@ getter. - componentDirs component = view Lens.hsSourceDirs component - - mainLibSourceDirs = maybe [] (componentDirs . condTreeData) (condLibrary gpd) - subLibSourceDirs name = dirsForComponent (condSubLibraries gpd) name - flibSourceDirs name = dirsForComponent (condForeignLibs gpd) name - exeSourceDirs name = dirsForComponent (condExecutables gpd) name - testSourceDirs name = dirsForComponent (condTestSuites gpd) name - benchSourceDirs name = dirsForComponent (condBenchmarks gpd) name - - -- Match a component name across every kind. The main library is keyed by - -- the package name rather than an unqualified component name, so it joins - -- in only when @name@ is the package name. - componentSourceDirsByName name = - mainLibForName name - <> subLibSourceDirs name - <> flibSourceDirs name - <> exeSourceDirs name - <> testSourceDirs name - <> benchSourceDirs name - - mainLibForName name - | toString name == mainPkgName = mainLibSourceDirs - | otherwise = [] - - allComponentSourceDirs = - mainLibSourceDirs - <> concatMap (componentDirs . condTreeData . snd) (condSubLibraries gpd) - <> concatMap (componentDirs . condTreeData . snd) (condForeignLibs gpd) - <> concatMap (componentDirs . condTreeData . snd) (condExecutables gpd) - <> concatMap (componentDirs . condTreeData . snd) (condTestSuites gpd) - <> concatMap (componentDirs . condTreeData . snd) (condBenchmarks gpd) - - dirsForComponent components name = - let ucn = mkUnqualComponentName (toString name) - in concatMap (componentDirs . condTreeData . snd) $ filter ((== ucn) . fst) components - - --- | Infer the effective targets to build and watch. This is the boundary where --- raw target strings (from config) are parsed into structured 'Target's: the --- configured targets are parsed as-is, or all components across every --- discovered package are auto-detected when no targets are configured. Either --- way the result is sorted with 'compareTargets' so libraries come last --- [ref:lib_sort_order]. -resolveTargets :: (FileSystem :> es) => [FilePath] -> [Text] -> Eff es [Target] -resolveTargets _ targets@(_ : _) = pure $ sortBy compareTargets $ map parseTarget targets -resolveTargets cabalFiles [] = - sortBy compareTargets . concat <$> traverse targetsFromCabal cabalFiles - where - targetsFromCabal path = do - contents <- readFileBs path - pure $ maybe [] allComponentTargets (parseGenericPackageDescriptionMaybe contents) - - --- | [tag:lib_sort_order] When running @cabal repl @, GHCi fails because it attempts to load the --- provided @Prelude@ module before loading the package itself. This is not a --- problem if the package defining the prelude module is not the first component --- listed. --- --- Because of this GHCi quirk, we sort all packages beginning with @lib:@ last. --- This is based on the assumption that components defining custom preludes --- usually reside in libraries. If we can then place at least one target that --- does not specify a custom prelude a before targets that do, we will prevent --- the user from being hit with this rather obscure error message. -compareTargets :: Target -> Target -> Ordering -compareTargets a b - | isLib a && not (isLib b) = GT - | not (isLib a) && isLib b = LT - | otherwise = compare (renderTarget a) (renderTarget b) - where - isLib (Qualified Lib _) = True - isLib _ = False - - --- | Locate every package's @.cabal@ file, logging what drove the result. In a --- multi-package project the packages live in subdirectories listed under --- @packages:@ in @cabal.project@; in a single-package project the @.cabal@ --- file(s) sit in the root. Called once per session load; the result is shared --- by target and watch-dir resolution. -discoverCabalFiles :: (FileSystem :> es, Log :> es) => ProjectRoot -> Eff es [FilePath] -discoverCabalFiles (ProjectRoot projectRoot) = do - hasProject <- doesFileExist projectFile - cabalFiles <- - if hasProject then do - contents <- readFileBs projectFile - concat <$> traverse cabalFilesForEntry (projectPackageEntries contents) - else - cabalFilesIn projectRoot - let listed - | null cabalFiles = "none" - | otherwise = T.intercalate ", " (map toText cabalFiles) - if hasProject then - Log.info - $ "Found cabal.project; discovered " - <> show (length cabalFiles) - <> " package cabal file(s): " - <> listed - else - Log.info $ "No cabal.project; using cabal file(s) in project root: " <> listed - pure cabalFiles - where - projectFile = projectRoot "cabal.project" - - -- A @packages:@ entry is either a direct path to a @.cabal@ file or a - -- directory to search for one. - cabalFilesForEntry entry - | takeExtension entry == ".cabal" = pure [projectRoot entry] - | otherwise = cabalFilesIn (normalise (projectRoot entry)) - - --- | List the @.cabal@ files directly inside a directory. -cabalFilesIn :: (FileSystem :> es) => FilePath -> Eff es [FilePath] -cabalFilesIn dir = do - entries <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory dir - pure $ map (dir ) entries - - --- | Extract the directory/file entries from the @packages:@ field of a --- @cabal.project@. Glob entries (containing @*@) are not expanded and are --- skipped. -projectPackageEntries :: ByteString -> [FilePath] -projectPackageEntries contents = - case readFields contents of - Left _ -> [] - Right fields -> filter (notElem '*') (concatMap fromField fields) - where - fromField (Field (Name _ name) fieldLines) - | name == "packages" = concatMap fromLine fieldLines - fromField _ = [] - fromLine (FieldLine _ bs) = map BC.unpack (BC.words bs) - - -allComponentTargets :: GenericPackageDescription -> [Target] -allComponentTargets gpd = - mainLibTargets - ++ subLibTargets - ++ flibTargets - ++ exeTargets - ++ testTargets - ++ benchTargets - where - mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd - mainLibTargets = maybe [] (const [Qualified Lib mainPkgName]) (condLibrary gpd) - subLibTargets = map (\(n, _) -> Qualified Lib (componentName n)) (condSubLibraries gpd) - flibTargets = map (\(n, _) -> Qualified FLib (componentName n)) (condForeignLibs gpd) - exeTargets = map (\(n, _) -> Qualified Exe (componentName n)) (condExecutables gpd) - testTargets = map (\(n, _) -> Qualified Test (componentName n)) (condTestSuites gpd) - benchTargets = map (\(n, _) -> Qualified Bench (componentName n)) (condBenchmarks gpd) - componentName = toText . unUnqualComponentName - - --- | Resolve which test suites to run after a clean build. Either source — the --- explicit @test_targets@ config or the build 'targets' — is projected onto its --- @test:@ components (see 'projectTestTargets'), so non-test entries are --- dropped and the result only ever names test suites [ref:test_targets_invariant]. -resolveTestTargets :: Config -> [Target] -> TestTargets -resolveTestTargets cfg targets = case cfg.testTargets of - Just explicit -> parseTestTargets explicit - Nothing -> projectTestTargets targets - - -resolveWatchExclusionPatterns :: [Text] -> Eff es WatchExclusionPatterns -resolveWatchExclusionPatterns rawPatterns = do - either (throwIO . userError . show) (pure . WatchExclusionPatterns) - $ traverse - ( parseRegex - . toString - ) - rawPatterns - - loadSession :: ( FileSystem :> es + , Input LoadedConfig :> es + , Input [CabalFile] :> es , Log :> es - , Reader LoadedConfig :> es , Reader ProjectRoot :> es ) => Eff es Session loadSession = do projectRoot <- ask @ProjectRoot - loadedCfg <- ask + loadedCfg <- input + projectFiles <- input + let cfgFile = extractConfig @"session" @Config loadedCfg - cabalFiles <- discoverCabalFiles projectRoot - effectiveTargets <- resolveTargets cabalFiles cfgFile.targets - let testTargets = resolveTestTargets cfgFile effectiveTargets + effectiveTargets = resolveTargets projectFiles cfgFile.targets + testTargets = resolveTestTargets cfgFile effectiveTargets + watchDirs = resolveWatchDirs projectRoot projectFiles cfgFile effectiveTargets + + watchExclusionPatterns <- + case resolveWatchExclusionPatterns cfgFile.watchExclusionPatterns of + Left err -> do + Log.err + $ T.intercalate + "\n" + [ "Failed to parse watch exclusion patterns:" + , err + , "Defaulting to no exclusion patterns." + ] + pure $ WatchExclusionPatterns [] + Right pts -> pure pts + + when (not (null effectiveTargets) && all (definesCustomPrelude projectFiles) effectiveTargets) + $ Log.warn + "Every resolved target exposes a custom Prelude module. GHCi may \ + \fail to start because the first target's Prelude will be loaded \ + \before its package is ready. Consider adding a target that does \ + \not define its own Prelude, or set an explicit command in your \ + \tricorder configuration." + command <- resolveCommand projectRoot cfgFile effectiveTargets testTargets - watchDirs <- resolveWatchDirs projectRoot cabalFiles cfgFile effectiveTargets - watchExclusionPatterns <- resolveWatchExclusionPatterns cfgFile.watchExclusionPatterns + pure $ Session { targets = effectiveTargets @@ -546,3 +102,14 @@ , replBuildDir = ReplBuildDir cfgFile.replBuildDir , testTimeout = TestTimeout cfgFile.testTimeout } + + +inputSession + :: ( FileSystem :> es + , Input LoadedConfig :> es + , Input [CabalFile] :> es + , Log :> es + , Reader ProjectRoot :> es + ) + => Eff (Input Session : es) a -> Eff es a +inputSession = runInputEff loadSession diff --git a/src/Tricorder/Session/CabalFile.hs b/src/Tricorder/Session/CabalFile.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/CabalFile.hs @@ -0,0 +1,108 @@ +module Tricorder.Session.CabalFile + ( CabalFile (..) + , inputCabalFiles + , discoverCabalFiles + ) where + +import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs) +import Atelier.Effects.Input (Input, runInputEff) +import Atelier.Effects.Log (Log) +import Data.Traversable (for) +import Distribution.Fields (Field (..), FieldLine (..), Name (..), readFields) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Effectful.Reader.Static (Reader, ask) +import System.FilePath (normalise, takeExtension, ()) + +import Atelier.Effects.Log qualified as Log +import Data.ByteString.Char8 qualified as BC +import Data.Text qualified as T + +import Tricorder.Runtime (ProjectRoot (..)) + + +data CabalFile = CabalFile + { projectFilePath :: FilePath + , projectPackageDescription :: GenericPackageDescription + } + deriving stock (Show) + + +inputCabalFiles + :: ( FileSystem :> es + , Log :> es + , Reader ProjectRoot :> es + ) + => Eff (Input [CabalFile] : es) a -> Eff es a +inputCabalFiles = runInputEff do + projectRoot <- ask + projectFilePaths <- discoverCabalFiles projectRoot + (faileds, packageDescriptions) <- + partitionEithers <$> for projectFilePaths \p -> do + contents <- readFileBs p + case parseGenericPackageDescriptionMaybe contents of + Nothing -> pure $ Left p + Just gpd -> pure $ Right $ CabalFile p gpd + unless (null faileds) do + Log.warn + $ "Failed to parse .cabal files for the following packages: " + <> T.intercalate ", " (toText <$> faileds) + pure $ packageDescriptions + + +-- | Locate every package's @.cabal@ file, logging what drove the result. In a +-- multi-package project the packages live in subdirectories listed under +-- @packages:@ in @cabal.project@; in a single-package project the @.cabal@ +-- file(s) sit in the root. Called once per session load; the result is shared +-- by target and watch-dir resolution. +discoverCabalFiles :: (FileSystem :> es, Log :> es) => ProjectRoot -> Eff es [FilePath] +discoverCabalFiles (ProjectRoot projectRoot) = do + hasProject <- doesFileExist projectFile + cabalFiles <- + if hasProject then do + contents <- readFileBs projectFile + concat <$> traverse cabalFilesForEntry (projectPackageEntries contents) + else + cabalFilesIn projectRoot + let listed + | null cabalFiles = "none" + | otherwise = T.intercalate ", " (map toText cabalFiles) + if hasProject then + Log.debug + $ "Found cabal.project; discovered " + <> show (length cabalFiles) + <> " package cabal file(s): " + <> listed + else + Log.debug $ "No cabal.project; using cabal file(s) in project root: " <> listed + pure cabalFiles + where + projectFile = projectRoot "cabal.project" + + -- A @packages:@ entry is either a direct path to a @.cabal@ file or a + -- directory to search for one. + cabalFilesForEntry entry + | takeExtension entry == ".cabal" = pure [projectRoot entry] + | otherwise = cabalFilesIn (normalise (projectRoot entry)) + + +-- | List the @.cabal@ files directly inside a directory. +cabalFilesIn :: (FileSystem :> es) => FilePath -> Eff es [FilePath] +cabalFilesIn dir = do + entries <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory dir + pure $ map (dir ) entries + + +-- | Extract the directory/file entries from the @packages:@ field of a +-- @cabal.project@. Glob entries (containing @*@) are not expanded and are +-- skipped. +projectPackageEntries :: ByteString -> [FilePath] +projectPackageEntries contents = + case readFields contents of + Left _ -> [] + Right fields -> filter (notElem '*') $ concatMap fromField fields + where + fromField (Field (Name _ name) fieldLines) + | name == "packages" = concatMap fromLine fieldLines + fromField _ = [] + fromLine (FieldLine _ bs) = map BC.unpack (BC.words bs) diff --git a/src/Tricorder/Session/Command.hs b/src/Tricorder/Session/Command.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/Command.hs @@ -0,0 +1,65 @@ +module Tricorder.Session.Command + ( Command (..) + , resolveCommand + ) where + +import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Default (Default (..)) +import System.FilePath (takeExtension, ()) + +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.Target (Target, renderTarget) +import Tricorder.Session.TestTarget (TestTarget, renderTestTarget) + + +newtype Command = Command {getCommand :: Text} + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Text + + +instance Default Command where + def = Command "" + + +-- | Resolve the GHCi command, using config if set or autodetecting otherwise. +-- +-- The @testTargets@ are the discovered @test:@ components; they are appended to +-- the auto-detected @all@ target (see 'detectCommand'). They are ignored when +-- the user has pinned an explicit @command@ or explicit @targets@ in config. +resolveCommand :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> [TestTarget] -> Eff es Command +resolveCommand projectRoot cfg targets testTargets = + case cfg.command of + Just cmd -> pure $ Command cmd + Nothing -> detectCommand targets testTargets cfg.replBuildDir projectRoot + + +-- | Build the autodetected GHCi command. +-- +-- Configured @targets@ are spelled out verbatim. Otherwise we use cabal's +-- catch-all @all@ plus the discovered @test:@ targets, because +-- @cabal repl --enable-multi-repl all@ omits test suites unless the project sets +-- @tests: True@ in @cabal.project@ — so test errors would go unnoticed. +-- +-- We keep @all@ rather than enumerating every component: @all@ lets cabal order +-- the multi-repl units, and GHCi makes the /last/ unit the active one. If that +-- unit imports a custom @Prelude@ from a sibling home package, GHCi reports it +-- "not loaded" and the session dies — which a naive discovery-order enumeration +-- triggers but @all@ avoids. Appending already-included test targets is a no-op +-- (cabal deduplicates). +detectCommand :: (FileSystem :> es) => [Target] -> [TestTarget] -> FilePath -> ProjectRoot -> Eff es Command +detectCommand targets testTargets replBuildDir (ProjectRoot projectRoot) = do + hasCabalProject <- doesFileExist (projectRoot "cabal.project") + cabalFiles <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory projectRoot + hasStack <- doesFileExist (projectRoot "stack.yaml") + let targetStr + | not (null targets) = unwords (map renderTarget targets) + | otherwise = unwords ("all" : map renderTestTarget testTargets) + buildDirFlag = "--builddir " <> toText replBuildDir <> " " + pure + if + | hasCabalProject || not (null cabalFiles) -> + Command $ "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr + | hasStack -> Command $ "stack ghci " <> targetStr + | otherwise -> Command $ "cabal repl " <> buildDirFlag <> targetStr diff --git a/src/Tricorder/Session/Config.hs b/src/Tricorder/Session/Config.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/Config.hs @@ -0,0 +1,32 @@ +module Tricorder.Session.Config (Config (..)) where + +import Atelier.Types.QuietSnake (QuietSnake (..)) +import Atelier.Types.WithDefaults (WithDefaults (..)) +import Data.Aeson (FromJSON (..)) +import Data.Default (Default (..)) + + +data Config = Config + { command :: Maybe Text + , targets :: [Text] + , watchDirs :: [FilePath] + , watchExclusionPatterns :: [Text] + , testTargets :: Maybe [Text] + , replBuildDir :: FilePath + , testTimeout :: Int + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON) via WithDefaults (QuietSnake Config) + + +instance Default Config where + def = + Config + { command = Nothing + , targets = [] + , watchDirs = [] + , watchExclusionPatterns = [] + , testTargets = Nothing + , replBuildDir = "dist-newstyle/tricorder" + , testTimeout = 10 + } diff --git a/src/Tricorder/Session/ReplBuildDir.hs b/src/Tricorder/Session/ReplBuildDir.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/ReplBuildDir.hs @@ -0,0 +1,13 @@ +module Tricorder.Session.ReplBuildDir (ReplBuildDir (..)) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (Default (..)) + + +newtype ReplBuildDir = ReplBuildDir {getReplBuildDir :: FilePath} + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via FilePath + + +instance Default ReplBuildDir where + def = ReplBuildDir "/tmp" diff --git a/src/Tricorder/Session/Target.hs b/src/Tricorder/Session/Target.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/Target.hs @@ -0,0 +1,192 @@ +module Tricorder.Session.Target + ( Target (..) + , ComponentKind (..) + , parseTarget + , renderTarget + , resolveTargets + , definesCustomPrelude + , compareTargets + , allComponentTargets + ) where + +import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) +import Distribution.Types.CondTree (condTreeData) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription + , condBenchmarks + , condExecutables + , condForeignLibs + , condLibrary + , condSubLibraries + , condTestSuites + , packageDescription + ) +import Distribution.Types.Library (exposedModules) +import Distribution.Types.PackageDescription (package) +import Distribution.Types.PackageId (pkgName) +import Distribution.Types.PackageName (unPackageName) +import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName) + +import Data.Text qualified as T + +import Tricorder.Session.CabalFile (CabalFile (..)) + + +-- | A cabal build target, parsed from its textual @[kind:]name@ form. Used to +-- resolve which source directories belong to a target. +data Target + = -- | A @kind:name@ reference, e.g. @lib:foo@, @exe:foo@, @test:foo@. An + -- empty name with 'Lib' (i.e. @lib:@) denotes the package's main library. + Qualified ComponentKind Text + | -- | A name with no @kind:@ prefix. Refers either to a package (all of its + -- components) or to a single component matched by name. + Bare Text + | -- | A form we don't recognize: an unknown kind, or extra colons. + Unrecognized Text + deriving stock (Eq, Generic, Ord, Show) + + +instance ToJSON Target where + toJSON = toJSON . renderTarget + + +instance FromJSON Target where + parseJSON = fmap parseTarget . parseJSON + + +instance ToJSONKey Target +instance FromJSONKey Target + + +-- | The kind of cabal component a 'Qualified' target names. Covers every +-- component kind cabal models (matching @Distribution.Types.ComponentName@). +data ComponentKind = Lib | FLib | Exe | Test | Bench + deriving stock (Bounded, Enum, Eq, Generic, Ord, Show) + + +-- | [tag:kind_prefix_sole_source] The canonical prefix cabal uses for each +-- component kind. Single source of truth shared by 'parseTarget' and +-- 'renderTarget' — keep this the only place the prefix strings appear. +-- +-- We deliberately model only these canonical prefixes, not cabal's full set of +-- aliases (@executable@, @test-suite@, …) or its case-folding. Those would mean +-- hand-mirroring an unexported, internally-inconsistent cabal table; instead an +-- aliased spelling falls to 'Unrecognized', which is still handed to cabal +-- verbatim for the build and still resolves watch dirs by matching its trailing +-- component name [ref:alias_name_match]. +kindPrefix :: ComponentKind -> Text +kindPrefix = \case + Lib -> "lib" + FLib -> "flib" + Exe -> "exe" + Test -> "test" + Bench -> "bench" + + +-- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two +-- never drift apart [ref:kind_prefix_sole_source]. +parseKind :: Text -> Maybe ComponentKind +parseKind = inverseMap kindPrefix + + +-- | Classify a target's textual form. The grammar is @[kind:]name@ where +-- @kind@ is one of @lib@, @flib@, @exe@, @test@, or @bench@; anything else (an +-- unknown kind, a cabal alias such as @executable@, or extra colons) is +-- 'Unrecognized'. +parseTarget :: Text -> Target +parseTarget target = case T.splitOn ":" target of + [prefix, name] | Just kind <- parseKind prefix -> Qualified kind name + [name] -> Bare name + _ -> Unrecognized target + + +-- | Render a 'Target' back to the textual form cabal understands. Inverse of +-- 'parseTarget' (lossless: @parseTarget . renderTarget == id@). Builds prefixes +-- via 'kindPrefix' rather than hardcoding them [ref:kind_prefix_sole_source]. +renderTarget :: Target -> Text +renderTarget = \case + Qualified kind name -> kindPrefix kind <> ":" <> name + Bare name -> name + Unrecognized raw -> raw + + +-- | Infer the effective targets to build and watch. This is the boundary where +-- raw target strings (from config) are parsed into structured 'Target's: the +-- configured targets are parsed as-is, or all components across every +-- discovered package are auto-detected when no targets are configured. Either +-- way the result is sorted with 'compareTargets' so libraries exposing a custom +-- @Prelude@ come last [ref:lib_sort_order]. +resolveTargets :: [CabalFile] -> [Text] -> [Target] +resolveTargets cabalFiles targets@(_ : _) = + sortBy (compareTargets (definesCustomPrelude cabalFiles)) $ parseTarget <$> targets +resolveTargets cabalFiles [] = + sortBy (compareTargets (definesCustomPrelude cabalFiles)) + $ foldMap (allComponentTargets . (.projectPackageDescription)) cabalFiles + + +-- | [tag:lib_sort_order] When running @cabal repl @, GHCi fails because it attempts to load the +-- provided @Prelude@ module before loading the package itself. This is not a +-- problem if the package defining the prelude module is not the first component +-- listed. +-- +-- We check each library target against the discovered cabal files via +-- 'definesCustomPrelude': only those that expose a @Prelude@ module are sorted +-- last. This is more precise than sorting every @lib:@ target last — only the +-- libraries that actually cause the failure are reordered. +compareTargets :: (Target -> Bool) -> Target -> Target -> Ordering +compareTargets definesPrelude a b + | definesPrelude a && not (definesPrelude b) = GT + | not (definesPrelude a) && definesPrelude b = LT + | otherwise = compare (renderTarget a) (renderTarget b) + + +-- | Check whether any of the discovered packages' libraries expose a @Prelude@ +-- module for the given target. Used to build the predicate passed to +-- 'compareTargets' so that only the libraries that actually cause the GHCi +-- startup failure are sorted last [ref:lib_sort_order]. +definesCustomPrelude :: [CabalFile] -> Target -> Bool +definesCustomPrelude cabalFiles target = any check cabalFiles + where + check cabalFile = any hasPrelude $ relevantLibs cabalFile.projectPackageDescription + hasPrelude lib = "Prelude" `elem` exposedModules lib + relevantLibs gpd = + let pkgN = unPackageName gpd.packageDescription.package.pkgName + in case target of + Qualified Lib "" -> + toList $ condTreeData <$> condLibrary gpd + Qualified Lib name + | toString name == pkgN -> + toList $ condTreeData <$> condLibrary gpd + | otherwise -> + subLibsNamed gpd (toString name) + Bare name + | toString name == pkgN -> + toList (condTreeData <$> condLibrary gpd) + <> (condTreeData . snd <$> condSubLibraries gpd) + | otherwise -> + subLibsNamed gpd (toString name) + _ -> [] + subLibsNamed gpd name = + map (condTreeData . snd) + $ filter ((== mkUnqualComponentName name) . fst) + $ condSubLibraries gpd + + +allComponentTargets :: GenericPackageDescription -> [Target] +allComponentTargets gpd = + mainLibTargets + ++ subLibTargets + ++ flibTargets + ++ exeTargets + ++ testTargets + ++ benchTargets + where + mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd + mainLibTargets = maybe [] (const [Qualified Lib mainPkgName]) (condLibrary gpd) + subLibTargets = map (\(n, _) -> Qualified Lib (componentName n)) (condSubLibraries gpd) + flibTargets = map (\(n, _) -> Qualified FLib (componentName n)) (condForeignLibs gpd) + exeTargets = map (\(n, _) -> Qualified Exe (componentName n)) (condExecutables gpd) + testTargets = map (\(n, _) -> Qualified Test (componentName n)) (condTestSuites gpd) + benchTargets = map (\(n, _) -> Qualified Bench (componentName n)) (condBenchmarks gpd) + componentName = toText . unUnqualComponentName diff --git a/src/Tricorder/Session/TestTarget.hs b/src/Tricorder/Session/TestTarget.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/TestTarget.hs @@ -0,0 +1,48 @@ +module Tricorder.Session.TestTarget + ( TestTarget (..) + , renderTestTarget + , parseTestTargets + , resolveTestTargets + , projectTestTargets + ) where + +import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) + +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.Target (ComponentKind (..), Target (..), parseTarget, renderTarget) + + +newtype TestTarget = TestTarget {getTestTarget :: Target} + deriving stock (Eq, Generic, Ord, Show) + deriving (FromJSON, ToJSON) via Target + deriving (FromJSONKey, ToJSONKey) via Target + + +renderTestTarget :: TestTarget -> Text +renderTestTarget = renderTarget . getTestTarget + + +-- | Parse raw target strings (e.g. the @test_targets@ config) and project them +-- onto their test suites — non-test entries are dropped. +parseTestTargets :: [Text] -> [TestTarget] +parseTestTargets = projectTestTargets . map parseTarget + + +-- | [tag:test_targets_invariant] Project a target list onto its test suites — +-- the only way to build a 'TestTargets', so the @test:@-only invariant holds by +-- construction. +projectTestTargets :: [Target] -> [TestTarget] +projectTestTargets = mapMaybe mkTestTarget + where + mkTestTarget tgt@(Qualified Test _) = Just $ TestTarget tgt + mkTestTarget _ = Nothing + + +-- | Resolve which test suites to run after a clean build. Either source — the +-- explicit @test_targets@ config or the build 'targets' — is projected onto its +-- @test:@ components (see 'projectTestTargets'), so non-test entries are +-- dropped and the result only ever names test suites [ref:test_targets_invariant]. +resolveTestTargets :: Config -> [Target] -> [TestTarget] +resolveTestTargets cfg targets = case cfg.testTargets of + Just explicit -> parseTestTargets explicit + Nothing -> projectTestTargets targets diff --git a/src/Tricorder/Session/TestTimeout.hs b/src/Tricorder/Session/TestTimeout.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/TestTimeout.hs @@ -0,0 +1,13 @@ +module Tricorder.Session.TestTimeout (TestTimeout (..)) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (Default (..)) + + +newtype TestTimeout = TestTimeout {getTestTimeout :: Int} + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via Int + + +instance Default TestTimeout where + def = TestTimeout 10 diff --git a/src/Tricorder/Session/WatchDirs.hs b/src/Tricorder/Session/WatchDirs.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/WatchDirs.hs @@ -0,0 +1,144 @@ +module Tricorder.Session.WatchDirs + ( WatchDirs (..) + , resolveWatchDirs + , sourceDirsForTarget + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Default (Default (..)) +import Data.List (nub) +import Distribution.Compat.Lens (view) +import Distribution.Types.CondTree (condTreeData) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription + , condBenchmarks + , condExecutables + , condForeignLibs + , condLibrary + , condSubLibraries + , condTestSuites + , packageDescription + ) +import Distribution.Types.PackageDescription (package) +import Distribution.Types.PackageId (pkgName) +import Distribution.Types.PackageName (unPackageName) +import Distribution.Types.UnqualComponentName (mkUnqualComponentName) +import Distribution.Utils.Path (getSymbolicPath) +import System.FilePath (takeDirectory, ()) + +import Data.Text qualified as T +import Distribution.Types.BuildInfo.Lens qualified as Lens + +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.CabalFile (CabalFile (..)) +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.Target (ComponentKind (..), Target (..)) + + +newtype WatchDirs = WatchDirs {getWatchDirs :: [FilePath]} + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via [FilePath] + + +instance Default WatchDirs where + def = WatchDirs [] + + +-- | Resolve the directories to watch. +-- +-- Priority: +-- 1. @watch_dirs@ from config, if non-empty (used as-is relative to project root) +-- 2. @hs-source-dirs@ inferred from cabal targets, if targets are set +-- 3. Falls back to @["."]@ (project root) if neither is available +resolveWatchDirs :: ProjectRoot -> [CabalFile] -> Config -> [Target] -> WatchDirs +resolveWatchDirs projectRoot projectFiles cfg targets = + case cfg.watchDirs of + dirs@(_ : _) -> WatchDirs $ map (coerce projectRoot ) dirs + [] -> resolveWatchDirsFromTargets projectFiles targets + + +resolveWatchDirsFromTargets :: [CabalFile] -> [Target] -> WatchDirs +resolveWatchDirsFromTargets _ [] = WatchDirs ["."] +resolveWatchDirsFromTargets projectFiles targets = + WatchDirs $ case dirs of + [] -> ["."] + _ -> dirs + where + dirs = nub . concat $ watchDirsForCabal <$> projectFiles + -- @hs-source-dirs@ are relative to the package's own directory, so scope + -- them to the directory holding that package's @.cabal@. In a + -- single-package project that directory is the project root; in a + -- multi-package project it's the per-package subdirectory. Targets that + -- don't belong to this package yield no dirs. + watchDirsForCabal projectFile = + let pkgDir = takeDirectory projectFile.projectFilePath + sourceDirs = sourceDirsForTarget projectFile.projectPackageDescription + in (pkgDir ) <$> concatMap sourceDirs targets + + +sourceDirsForTarget :: GenericPackageDescription -> Target -> [FilePath] +sourceDirsForTarget gpd target = + map getSymbolicPath $ case target of + Qualified Lib "" -> mainLibSourceDirs + Qualified Lib name + | toString name == mainPkgName -> mainLibSourceDirs + | otherwise -> subLibSourceDirs name + Qualified FLib name -> flibSourceDirs name + Qualified Exe name -> exeSourceDirs name + Qualified Test name -> testSourceDirs name + Qualified Bench name -> benchSourceDirs name + -- A bare target (no @kind:@ prefix) is a package name or a component + -- name. A package name covers every component; otherwise match a + -- single component by name across the kinds. + Bare name + | toString name == mainPkgName -> allComponentSourceDirs + | otherwise -> componentSourceDirsByName name + -- [tag:alias_name_match] A form we couldn't parse into a kind — a cabal + -- alias (@executable:@) or a case variant (@Lib:@). The kind is + -- untrustworthy, but cabal component names are unique within a package, + -- so we match the trailing name across every kind. This recovers precise + -- watch dirs for aliased spellings; worst case we over-match a + -- same-named component, never miss one. (The raw string is still handed + -- to cabal verbatim for the build.) + Unrecognized raw -> componentSourceDirsByName (T.takeWhileEnd (/= ':') raw) + where + mainPkgName = unPackageName . pkgName . package . packageDescription $ gpd + + -- @hs-source-dirs@ of any component, via the @HasBuildInfo@ lens — one + -- accessor that works uniformly across libraries, foreign libs, exes, + -- tests, and benchmarks, so we don't repeat a per-kind @buildInfo@ getter. + componentDirs component = view Lens.hsSourceDirs component + + mainLibSourceDirs = maybe [] (componentDirs . condTreeData) (condLibrary gpd) + subLibSourceDirs name = dirsForComponent (condSubLibraries gpd) name + flibSourceDirs name = dirsForComponent (condForeignLibs gpd) name + exeSourceDirs name = dirsForComponent (condExecutables gpd) name + testSourceDirs name = dirsForComponent (condTestSuites gpd) name + benchSourceDirs name = dirsForComponent (condBenchmarks gpd) name + + -- Match a component name across every kind. The main library is keyed by + -- the package name rather than an unqualified component name, so it joins + -- in only when @name@ is the package name. + componentSourceDirsByName name = + mainLibForName name + <> subLibSourceDirs name + <> flibSourceDirs name + <> exeSourceDirs name + <> testSourceDirs name + <> benchSourceDirs name + + mainLibForName name + | toString name == mainPkgName = mainLibSourceDirs + | otherwise = [] + + allComponentSourceDirs = + mainLibSourceDirs + <> concatMap (componentDirs . condTreeData . snd) (condSubLibraries gpd) + <> concatMap (componentDirs . condTreeData . snd) (condForeignLibs gpd) + <> concatMap (componentDirs . condTreeData . snd) (condExecutables gpd) + <> concatMap (componentDirs . condTreeData . snd) (condTestSuites gpd) + <> concatMap (componentDirs . condTreeData . snd) (condBenchmarks gpd) + + dirsForComponent components name = + let ucn = mkUnqualComponentName (toString name) + in concatMap (componentDirs . condTreeData . snd) $ filter ((== ucn) . fst) components diff --git a/src/Tricorder/Session/WatchExclusionPatterns.hs b/src/Tricorder/Session/WatchExclusionPatterns.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Session/WatchExclusionPatterns.hs @@ -0,0 +1,27 @@ +module Tricorder.Session.WatchExclusionPatterns + ( WatchExclusionPatterns (..) + , Pattern + , resolveWatchExclusionPatterns + ) where + +import Data.Default (Default (..)) +import Text.Regex.TDFA.ReadRegex (parseRegex) + +import Text.Regex.TDFA.Pattern qualified as Regex + + +newtype WatchExclusionPatterns = WatchExclusionPatterns {getWatchExclusionPatterns :: [Pattern]} + deriving stock (Eq, Generic, Show) + + +instance Default WatchExclusionPatterns where + def = WatchExclusionPatterns [] + + +type Pattern = (Regex.Pattern, (Regex.GroupIndex, Regex.DoPa)) + + +resolveWatchExclusionPatterns :: [Text] -> Either Text WatchExclusionPatterns +resolveWatchExclusionPatterns rawPatterns = do + bimap show WatchExclusionPatterns + $ traverse (parseRegex . toString) rawPatterns diff --git a/src/Tricorder/Socket/Client.hs b/src/Tricorder/Socket/Client.hs --- a/src/Tricorder/Socket/Client.hs +++ b/src/Tricorder/Socket/Client.hs @@ -7,6 +7,7 @@ , queryDiagnostic , requestShutdown , isDaemonRunning + , isDaemonReady ) where import Atelier.Effects.Delay (Delay) @@ -19,18 +20,25 @@ import Effectful.Reader.Static (Reader, ask) import Effectful.State.Static.Shared (evalState, get, modify, put) import System.IO.Error (isEOFError) +import Prelude hiding (force) import Atelier.Effects.Delay qualified as Delay import Atelier.Effects.File qualified as File import Atelier.Effects.Posix.Daemons qualified as Daemons import Data.ByteString.Lazy qualified as BSL -import Tricorder.BuildState (BuildState, Diagnostic) -import Tricorder.Effects.UnixSocket (UnixSocket, withConnection) -import Tricorder.GhcPkg.Types (SourceQuery) +import Tricorder.Build (BuildState, Diagnostic) import Tricorder.Runtime (PidFile) -import Tricorder.Socket.Protocol (ClientMessage (..), DiagnosticQuery (..), Query (..), StatusQuery (..)) -import Tricorder.SourceLookup (ModuleSourceResult) +import Tricorder.Socket.Protocol + ( ClientMessage (..) + , DiagnosticQuery (..) + , Force (..) + , Query (..) + , StatusQuery (..) + , Waiters (..) + ) +import Tricorder.Socket.UnixSocket (UnixSocket, withConnection) +import Tricorder.SourceLookup (ModuleSourceResult, SourceQuery) import Tricorder.Version qualified as Version @@ -60,23 +68,30 @@ -- | Connect and stream build updates, calling the handler after each completed build. -- Retries automatically when the connection is lost or the daemon is restarting. +-- +-- A transient drop is tolerated for a few attempts before giving up. While +-- @isRestarting@ reports 'True' (a restart we initiated is in flight) the retry +-- budget is ignored and reconnection continues indefinitely, so the watch +-- survives the gap between stopping the old daemon and the new one binding its +-- socket. queryWatch :: forall es . (Delay :> es, File :> es, UnixSocket :> es) => FilePath + -> Eff es Bool + -- ^ Whether a restart is currently in progress. -> (Either Restarting BuildState -> Eff es ()) -> Eff es () -queryWatch sockPath handler = evalState retryLimit retryLoop +queryWatch sockPath isRestarting handler = evalState retryLimit retryLoop where retryLimit = 3 :: Int retryLoop = do retries <- get @Int - if retries <= 0 then - pure () - else do + keepGoing <- if retries > 0 then pure True else inject isRestarting + when keepGoing do void $ trySync $ withConnection sockPath \h -> sendQuery h Watch >> loop h Delay.wait (500 :: Millisecond) - modify $ subtract 1 + when (retries > 0) $ modify $ subtract 1 retryLoop loop h = do @@ -123,20 +138,38 @@ Right d -> pure $ Right d -requestShutdown :: (File :> es, UnixSocket :> es) => FilePath -> Eff es (Either Text ()) -requestShutdown sockPath = withConnection sockPath \h -> do - sendQuery h Quit +requestShutdown + :: (File :> es, UnixSocket :> es) + => Force -> FilePath -> Eff es (Either Text ()) +requestShutdown force sockPath = withConnection sockPath \h -> do + sendQuery h $ Quit waiters line <- File.hGetLine h if eitherDecode (BSL.fromStrict (encodeUtf8 line)) == Right True then pure $ Right () else pure $ Left "Failed to request shutdown" + where + waiters = case force of + Force -> IgnoreWaiters + NoForce -> WaitForWaiters isDaemonRunning :: (Daemons :> es, Reader PidFile :> es) => Eff es Bool isDaemonRunning = do pidFile <- ask Daemons.isRunning pidFile + + +-- | Check whether the daemon socket is bound and accepting connections. +-- +-- The PID file can appear before the daemon has bound its socket, so a +-- running process is not enough to guarantee a client can connect. This opens +-- (and immediately closes) a throwaway connection and reports whether it +-- succeeded. +isDaemonReady :: (UnixSocket :> es) => FilePath -> Eff es Bool +isDaemonReady sockPath = + either (const False) (const True) + <$> trySync (withConnection sockPath \_ -> pass) -- internals diff --git a/src/Tricorder/Socket/Protocol.hs b/src/Tricorder/Socket/Protocol.hs --- a/src/Tricorder/Socket/Protocol.hs +++ b/src/Tricorder/Socket/Protocol.hs @@ -1,16 +1,21 @@ module Tricorder.Socket.Protocol - ( Query (..) + ( Force (..) + , Query (..) , StatusQuery (..) , DiagnosticQuery (..) , ErrorResponse (..) , ClientMessage (..) + , Waiters (..) ) where import Data.Aeson (FromJSON, ToJSON) -import Tricorder.GhcPkg.Types (SourceQuery) +import Tricorder.SourceLookup (SourceQuery) +data Force = Force | NoForce + + data StatusQuery = StatusQuery {awaitDone :: Bool} deriving stock (Eq, Generic, Show) deriving anyclass (FromJSON, ToJSON) @@ -26,7 +31,12 @@ | Watch | Source [SourceQuery] | DiagnosticAt DiagnosticQuery - | Quit + | Quit Waiters + deriving stock (Eq, Generic, Show) + deriving anyclass (FromJSON, ToJSON) + + +data Waiters = WaitForWaiters | IgnoreWaiters deriving stock (Eq, Generic, Show) deriving anyclass (FromJSON, ToJSON) diff --git a/src/Tricorder/Socket/Server.hs b/src/Tricorder/Socket/Server.hs --- a/src/Tricorder/Socket/Server.hs +++ b/src/Tricorder/Socket/Server.hs @@ -1,26 +1,37 @@ -module Tricorder.Socket.Server (component, SocketRemoved (..)) where +module Tricorder.Socket.Server (main, SocketRemoved (..)) where -import Atelier.Component (Component (..), Trigger, defaultComponent) import Atelier.Effects.Cache (Cache) import Atelier.Effects.Conc (Conc) -import Atelier.Effects.Delay (Delay, wait) +import Atelier.Effects.Env (Env) import Atelier.Effects.Exit (Exit, exitSuccess) import Atelier.Effects.FileSystem (FileSystem) +import Atelier.Effects.Input (Input, input) import Atelier.Effects.Log (Log) -import Atelier.Time (Millisecond) +import Atelier.Effects.Publishing.Sub (Sub) import Data.Aeson (ToJSON, decode, encode) import Effectful.Exception (IOException, finally) import Effectful.Reader.Static (Reader, ask) +import Effectful.State.Static.Shared (State) import System.IO (Handle) import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Log qualified as Log +import Atelier.Effects.Publishing.Sub qualified as Sub import Data.ByteString.Lazy qualified as BSL +import Effectful.State.Static.Shared qualified as State -import Tricorder.BuildState (BuildPhase (..), BuildResult (..), BuildState (..), Diagnostic) -import Tricorder.Effects.BuildStore (BuildStore, getState, waitForAnyChange, waitUntilDone) -import Tricorder.Effects.GhcPkg (GhcPkg) -import Tricorder.Effects.UnixSocket +import Tricorder.Build (BuildId, BuildPhase, BuildState (..), Diagnostic) +import Tricorder.Daemon.DaemonInfo (DaemonInfo) +import Tricorder.Module (ModuleName, PackageId) +import Tricorder.Runtime (SocketPath (..)) +import Tricorder.Socket.Protocol + ( ClientMessage (..) + , DiagnosticQuery (..) + , ErrorResponse (..) + , Query (..) + , StatusQuery (..) + ) +import Tricorder.Socket.UnixSocket ( UnixSocket , acceptHandle , bindSocket @@ -29,58 +40,68 @@ , removeSocketFile , sendLine ) -import Tricorder.GhcPkg.Types (SourceQuery (..)) -import Tricorder.Runtime (SocketPath (..)) -import Tricorder.Socket.Protocol (ClientMessage (..), DiagnosticQuery (..), ErrorResponse (..), Query (..), StatusQuery (..)) -import Tricorder.SourceLookup (ModuleName, PackageId, ReExport, lookupModuleSource) +import Tricorder.SourceLookup (ModuleSourceResult, SourceQuery (..), lookupModuleSource) +import Tricorder.SourceLookup.Cabal (Cabal) +import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.Version (VersionMismatch (..), checkVersion) +import Tricorder.Waiters (Waiters) +import Tricorder.Build qualified as Build +import Tricorder.Build.EvalComment qualified as Eval +import Tricorder.Build.Test qualified as Test +import Tricorder.Socket.Protocol qualified as Protocol +import Tricorder.Waiters qualified as Waiters + data SocketRemoved = SocketRemoved deriving stock (Eq, Show) - deriving anyclass (Exception) --- | SocketServer component. --- Listens on a Unix socket and responds to status/watch/source queries. -component - :: ( BuildStore :> es - , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es +main + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es , Conc :> es - , Delay :> es + , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es + , Input BuildId :> es + , Input DaemonInfo :> es , Log :> es , Reader SocketPath :> es + , Sub BuildPhase :> es , UnixSocket :> es + , Waiters :> es ) - => Component es -component = - defaultComponent - { name = "SocketServer" - , setup = do - SocketPath sockPath <- ask - removeSocketFile sockPath - , triggers = pure [acceptTrigger] - } + => Eff es Void +main = State.evalState Build.Starting do + Conc.fork_ $ Sub.listen_ @BuildPhase State.put + SocketPath sockPath <- ask + removeSocketFile sockPath + acceptTrigger + acceptTrigger - :: ( BuildStore :> es - , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es , Conc :> es - , Delay :> es + , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es + , Input BuildId :> es + , Input DaemonInfo :> es , Log :> es , Reader SocketPath :> es + , State BuildPhase :> es + , Sub BuildPhase :> es , UnixSocket :> es + , Waiters :> es ) - => Trigger es + => Eff es Void acceptTrigger = do SocketPath sockPath <- ask sock <- bindSocket sockPath @@ -91,15 +112,21 @@ handleConnection - :: ( BuildStore :> es - , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es - , Delay :> es + , Conc :> es + , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es + , Input BuildId :> es + , Input DaemonInfo :> es , Log :> es + , State BuildPhase :> es + , Sub BuildPhase :> es , UnixSocket :> es + , Waiters :> es ) => Handle -> Eff es () @@ -117,15 +144,21 @@ dispatch - :: ( BuildStore :> es - , Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es - , Delay :> es + , Conc :> es + , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es + , Input BuildId :> es + , Input DaemonInfo :> es , Log :> es + , State BuildPhase :> es + , Sub BuildPhase :> es , UnixSocket :> es + , Waiters :> es ) => Query -> Handle @@ -136,88 +169,106 @@ Watch -> watchStream h Source moduleNames -> respondSource moduleNames h DiagnosticAt dq -> respondDiagnostic dq.index h - Quit -> quit h + Quit waiters -> quit h waiters -quit :: (Exit :> es, Log :> es, UnixSocket :> es) => Handle -> Eff es () -quit h = do - sendJson h True - Log.info "Shutting down." - exitSuccess +quit + :: ( Exit :> es + , Log :> es + , UnixSocket :> es + , Waiters :> es + ) + => Handle -> Protocol.Waiters -> Eff es () +quit h = \case + Protocol.WaitForWaiters -> Waiters.wait doQuit + Protocol.IgnoreWaiters -> doQuit + where + doQuit = do + sendJson h True + Log.info "Shutting down." + exitSuccess -respondOnce :: (BuildStore :> es, UnixSocket :> es) => Handle -> Eff es () -respondOnce h = getState >>= sendJson h +respondOnce + :: ( Input BuildId :> es + , Input DaemonInfo :> es + , State BuildPhase :> es + , UnixSocket :> es + ) + => Handle -> Eff es () +respondOnce h = do + progress <- State.get + mkBuildState progress >>= sendJson h --- | Wait for a completed build, then respond. --- --- If the build is already done when this is called, we may be racing the file --- watcher's debounce: a file was just changed but the reload hasn't been --- dispatched yet (default debounce is 100ms). Poll for up to 250ms to let --- any in-flight debounce fire before falling back to the current result. -respondWhenDone :: (BuildStore :> es, Delay :> es, UnixSocket :> es) => Handle -> Eff es () -respondWhenDone h = awaitResult >>= sendJson h +respondWhenDone + :: ( Conc :> es + , Input BuildId :> es + , Input DaemonInfo :> es + , State BuildPhase :> es + , Sub BuildPhase :> es + , UnixSocket :> es + ) + => Handle -> Eff es () +respondWhenDone h = awaitResult >>= mkBuildState >>= sendJson h where - awaitResult = do - s <- getState - case s.phase of - Building _ -> waitUntilDone - Restarting -> waitUntilDone - Testing _ -> waitUntilDone - Done _ -> awaitBuildStart (5 :: Int) s - BuildFailed _ -> pure s + awaitResult = Conc.scoped do + progressP <- Conc.fork $ Sub.listenUntil_ \case + failed@(Build.Failed _) -> Just failed + finished@(Build.Finished _ _) -> Just finished + _ -> Nothing + s <- State.get + waitOrStart progressP s - -- Poll up to n × 50ms for a build to start, then wait for it to finish. - awaitBuildStart 0 s = pure s - awaitBuildStart n _ = do - wait (50 :: Millisecond) - s' <- getState - case s'.phase of - Building _ -> waitUntilDone - Restarting -> waitUntilDone - Testing _ -> waitUntilDone - Done _ -> awaitBuildStart (n - 1) s' - BuildFailed _ -> pure s' + waitOrStart p = \case + finished@(Build.Finished _ _) -> pure finished + failed@(Build.Failed _) -> pure failed + _ -> Conc.await p --- | Stream a JSON object after each state change (loops until handle closes or error). -watchStream :: (BuildStore :> es, UnixSocket :> es) => Handle -> Eff es () +-- | Stream a JSON object after each state change event. +watchStream + :: ( Input BuildId :> es + , Input DaemonInfo :> es + , State BuildPhase :> es + , Sub BuildPhase :> es + , UnixSocket :> es + ) + => Handle -> Eff es () watchStream h = do - state0 <- getState - sendJson h state0 - loop state0 - where - loop prev = do - newState <- waitForAnyChange prev - sendJson h newState - loop newState + progress0 <- State.get + mkBuildState progress0 >>= sendJson h + vacuous $ Sub.listen_ \progress -> + mkBuildState progress >>= sendJson h -respondDiagnostic :: (BuildStore :> es, UnixSocket :> es) => Int -> Handle -> Eff es () +respondDiagnostic :: (State BuildPhase :> es, UnixSocket :> es) => Int -> Handle -> Eff es () respondDiagnostic idx h = do - state <- getState - case state.phase of - Done r -> case r.diagnostics !!? (idx - 1) of - Nothing -> - sendJson h - $ ErrorResponse - $ "No diagnostic #" - <> show idx - <> " (current build has " - <> show (length r.diagnostics) - <> ")" - Just d -> sendJson h (d :: Diagnostic) - BuildFailed msg -> sendJson h $ ErrorResponse $ "Build command failed:\n" <> msg - Building _ -> sendJson h $ ErrorResponse "Build in progress" - Restarting -> sendJson h $ ErrorResponse "Build in progress" - Testing _ -> sendJson h $ ErrorResponse "Build in progress" + progress <- State.get + case progress of + Build.Finished result postBuild + | not $ Test.anyRunningTests postBuild.testSuites && Eval.phasePending postBuild.evalComments -> + case result.diagnostics !!? (idx - 1) of + Nothing -> + sendJson h + $ ErrorResponse + $ "No diagnostic #" + <> show idx + <> " (current build has " + <> show (length result.diagnostics) + <> ")" + Just d -> sendJson h (d :: Diagnostic) + | otherwise -> sendJson h $ ErrorResponse "Build in progress" + Build.Failed msg -> sendJson h $ ErrorResponse $ "Build command failed:\n" <> msg + _ -> sendJson h $ ErrorResponse "Build in progress" -- | Look up source for each requested module and send the results as a JSON array. respondSource - :: ( Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es + , Env :> es , FileSystem :> es , GhcPkg :> es , Log :> es @@ -233,3 +284,10 @@ sendJson :: (ToJSON a, UnixSocket :> es) => Handle -> a -> Eff es () sendJson h val = sendLine h (decodeUtf8 (BSL.toStrict (encode val))) + + +mkBuildState :: (Input BuildId :> es, Input DaemonInfo :> es) => BuildPhase -> Eff es BuildState +mkBuildState phase = do + daemonInfo <- input + buildId <- input + pure $ BuildState {daemonInfo, buildId, phase} diff --git a/src/Tricorder/Socket/UnixSocket.hs b/src/Tricorder/Socket/UnixSocket.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Socket/UnixSocket.hs @@ -0,0 +1,154 @@ +module Tricorder.Socket.UnixSocket + ( -- * Effect + UnixSocket + , bindSocket + , acceptHandle + , withConnection + , readLine + , sendLine + , closeHandle + , removeSocketFile + , socketFileExists + + -- * Interpreters + , runUnixSocketIO + , runUnixSocketScripted + , SocketScript (..) + ) where + +import Atelier.Effects.File (BufferMode (..), File, Handle) +import Atelier.Exception (trySyncIO) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, reinterpret) +import Effectful.Exception (finally) +import Effectful.State.Static.Shared (evalState, get, put) +import Effectful.TH (makeEffect) +import Network.Socket + ( Family (..) + , SockAddr (..) + , Socket + , SocketType (..) + , accept + , bind + , defaultProtocol + , listen + , socket + , socketToHandle + ) +import System.Directory (doesPathExist, removeFile) +import System.IO (hSetEncoding, utf8) + +import Atelier.Effects.File qualified as File +import Network.Socket qualified as Net + + +data UnixSocket :: Effect where + -- | Create, bind, and listen on a Unix socket at the given path. + BindSocket :: FilePath -> UnixSocket m Socket + -- | Accept the next incoming connection and return a line-buffered 'Handle'. + AcceptHandle :: Socket -> UnixSocket m Handle + -- | Connect to a Unix socket and run the callback with the resulting handle. + -- The handle is closed when the callback returns. + WithConnection :: FilePath -> (Handle -> m a) -> UnixSocket m a + -- | Read a line from a connected handle. + ReadLine :: Handle -> UnixSocket m Text + -- | Write a line to a connected handle and flush. + SendLine :: Handle -> Text -> UnixSocket m () + -- | Close a connected handle. + CloseHandle :: Handle -> UnixSocket m () + -- | Remove the socket file, ignoring errors (e.g. file not found). + RemoveSocketFile :: FilePath -> UnixSocket m () + -- | Check whether the socket file exists. + SocketFileExists :: FilePath -> UnixSocket m Bool + + +makeEffect ''UnixSocket + + +-- | Production interpreter backed by real Unix sockets. +-- +-- Socket creation and encoding setup require raw IO (no @File@ equivalent), +-- but the handle-level reads, writes, buffering and closing go through the +-- 'File' effect. +runUnixSocketIO :: (File :> es, IOE :> es) => Eff (UnixSocket : es) a -> Eff es a +runUnixSocketIO eff = interpretWith eff \env -> \case + BindSocket path -> liftIO do + sock <- socket AF_UNIX Stream defaultProtocol + bind sock (SockAddrUnix path) + listen sock 5 + pure sock + AcceptHandle sock -> do + h <- liftIO do + (conn, _) <- accept sock + h <- socketToHandle conn ReadWriteMode + hSetEncoding h utf8 + pure h + File.hSetBuffering h LineBuffering + pure h + WithConnection sockPath callback -> + localSeqUnlift env \unlift -> do + h <- liftIO do + sock <- socket AF_UNIX Stream defaultProtocol + Net.connect sock (SockAddrUnix sockPath) + h <- socketToHandle sock ReadWriteMode + hSetEncoding h utf8 + pure h + File.hSetBuffering h LineBuffering + unlift (callback h) `finally` File.hClose h + ReadLine h -> File.hGetLine h + SendLine h line -> File.hPutTextLn h line >> File.hFlush h + CloseHandle h -> File.hClose h + RemoveSocketFile path -> + liftIO $ void $ trySyncIO $ removeFile path + SocketFileExists path -> + liftIO $ doesPathExist path + + +-- | Script element for the test interpreter. +data SocketScript + = -- | Return this 'Handle' for the next 'acceptHandle' call. + NextAccept Handle + | -- | Return this 'Bool' for the next 'socketFileExists' call. + NextFileCheck Bool + | -- | Use this 'Handle' for the next 'withConnection' call. + NextConnect Handle + | -- | Return this text for the next 'readLine' call. + NextReadLine Text + + +-- | Scripted interpreter for testing. +-- +-- 'bindSocket' creates a real (unbound) socket so that the returned 'Socket' +-- is a valid value, but does not actually bind to the filesystem. +-- 'acceptHandle' pops the next 'NextAccept' entry from the queue and sets +-- line buffering on it. 'removeSocketFile' is always a no-op. +-- 'socketFileExists' pops the next 'NextFileCheck' entry. +-- 'withConnection' pops the next 'NextConnect' entry and passes it to the callback. +runUnixSocketScripted :: (File :> es, IOE :> es) => [SocketScript] -> Eff (UnixSocket : es) a -> Eff es a +runUnixSocketScripted script = reinterpret (evalState script) \env -> \case + BindSocket _ -> + liftIO $ Net.socket AF_UNIX Stream defaultProtocol + AcceptHandle _ -> + get >>= \case + NextAccept h : rest -> do + put rest + File.hSetBuffering h LineBuffering + pure h + _ -> error "UnixSocketScripted: expected NextAccept but queue was empty or mismatched" + WithConnection _ callback -> + get >>= \case + NextConnect h : rest -> do + put rest + localSeqUnlift env \unlift -> unlift (callback h) + _ -> error "UnixSocketScripted: expected NextConnect but queue was empty or mismatched" + ReadLine _ -> + get >>= \case + NextReadLine line : rest -> put rest >> pure line + _ -> error "UnixSocketScripted: expected NextReadLine but queue was empty or mismatched" + SendLine _ _ -> pure () + CloseHandle _ -> pure () + RemoveSocketFile _ -> pure () + SocketFileExists _ -> + get >>= \case + NextFileCheck b : rest -> put rest >> pure b + _ -> error "UnixSocketScripted: expected NextFileCheck but queue was empty or mismatched" diff --git a/src/Tricorder/SourceLookup.hs b/src/Tricorder/SourceLookup.hs --- a/src/Tricorder/SourceLookup.hs +++ b/src/Tricorder/SourceLookup.hs @@ -1,72 +1,75 @@ module Tricorder.SourceLookup ( -- * Types - ModuleName - , PackageId - , SourceQuery (..) + SourceQuery (..) , ModuleSourceResult (..) - , ReExport (..) -- * Lookup , lookupModuleSource - - -- * HTML extraction - , extractSource - , extractFunctionSource - , extractReExports - , stripAnnotations - , stripTags - , unescapeEntities ) where import Atelier.Effects.Cache (Cache, cacheInsert, cacheLookup) -import Atelier.Effects.FileSystem (FileSystem, doesFileExist, readFileLbs) +import Atelier.Effects.Env (Env) +import Atelier.Effects.FileSystem (FileSystem) import Atelier.Effects.Log (Log) import Data.Aeson (FromJSON, ToJSON) -import Data.List (findIndex) -import System.FilePath (()) import Atelier.Effects.Log qualified as Log -import Data.ByteString.Lazy qualified as BSL -import Data.Text qualified as T -import Tricorder.Effects.GhcPkg (GhcPkg) -import Tricorder.GhcPkg.Types (ModuleName (..), PackageId (..), SourceQuery (..)) - -import Tricorder.Effects.GhcPkg qualified as GhcPkg - +import Tricorder.Module (ModuleName (..), PackageId (..)) +import Tricorder.SourceLookup.Cabal (Cabal) +import Tricorder.SourceLookup.GhcPkg (GhcPkg) +import Tricorder.SourceLookup.Slice (sliceSymbol) +import Tricorder.SourceLookup.Tarball + ( TarballOutcome (..) + , obtainTarball + , readModuleMember + ) --- | A re-exported name or module from a module's export list. -data ReExport - = -- | Whole-module re-export: @module GHC.Enum@ - ReExportModule Text - | -- | Single name re-export: (name, source-module) - ReExportName Text Text - deriving stock (Eq, Generic, Show) - deriving anyclass (FromJSON, ToJSON) +import Tricorder.SourceLookup.GhcPkg qualified as GhcPkg -- | The result of a source lookup for a single module. data ModuleSourceResult - = -- | Source was found; contains the stripped Haskell source text and re-exports. - SourceFound SourceQuery Text [ReExport] + = -- | Source was found; contains the module (or single-symbol) source text. + SourceFound SourceQuery Text | -- | The module is not provided by any installed package. SourceNotFound SourceQuery - | -- | The package was found but has no haddock-html field (built without docs). - SourceNoHaddock SourceQuery PackageId - | -- | The module was found but the requested function was not in the source. + | -- | The package was resolved but no source tarball could be located or + -- fetched (no index, offline, yanked, or the archive could not be read). + SourceUnavailable SourceQuery PackageId + | -- | The module source was found but the requested symbol was not in it. FunctionNotFound SourceQuery deriving stock (Eq, Generic, Show) deriving anyclass (FromJSON, ToJSON) +-- | A query for module source: optionally scoped to a single top-level symbol. +data SourceQuery = SourceQuery + { moduleName :: ModuleName + , function :: Maybe Text + -- ^ The symbol to slice: 'Nothing' is the whole module; @'Just' name@ is a + -- single top-level declaration — a value binding, or (by initial casing) a + -- type, class, or constructor. + } + deriving stock (Eq, Generic, Show) + deriving anyclass (FromJSON, Hashable, ToJSON) + + -- ── Lookup logic ─────────────────────────────────────────────────────────── -- | Resolve and return the source for a single module. -- --- Checks both cache levels before issuing any shell-outs. +-- Resolves the module to its project-pinned 'PackageId' via @ghc-pkg@, then +-- serves source from that package's sdist tarball in cabal's global cache, +-- fetching it on demand if absent. A symbol query slices the relevant +-- declaration (with its doc comment) from the module source. Both resolution +-- steps are cached, so the fetch + read cost is paid at most once per +-- (package, query). lookupModuleSource - :: ( Cache (PackageId, SourceQuery) (Text, [ReExport]) :> es + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es + , Env :> es , FileSystem :> es , GhcPkg :> es , Log :> es @@ -74,223 +77,68 @@ => SourceQuery -> Eff es ModuleSourceResult lookupModuleSource query = do - mCachedPkg <- cacheLookup @ModuleName @PackageId query.moduleName - pkgId <- case mCachedPkg of - Just p -> do - Log.debug $ "Source: " <> unModuleName query.moduleName <> " → " <> unPackageId p <> " (cached)" - pure (Just p) - Nothing -> do - result <- GhcPkg.findModule query.moduleName - Log.debug $ "Source: find-module " <> unModuleName query.moduleName <> " → " <> show result - case result of - Nothing -> pure Nothing - Just p -> do - cacheInsert @ModuleName @PackageId query.moduleName p - pure (Just p) - case pkgId of + mPkg <- resolvePackage query.moduleName + case mPkg of Nothing -> pure (SourceNotFound query) Just p -> do - mCachedSrc <- cacheLookup @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query) - case mCachedSrc of - Just (src, reExports) -> do + mCached <- cacheLookup @(PackageId, SourceQuery) @ModuleSourceResult (p, query) + case mCached of + Just result -> do Log.debug $ "Source: " <> unModuleName query.moduleName <> " source hit (cached)" - pure (SourceFound query src reExports) - Nothing -> do - mHtmlRoot <- GhcPkg.getHaddockHtml p - Log.debug $ "Source: haddock-html for " <> unPackageId p <> " → " <> show mHtmlRoot - case mHtmlRoot of - Nothing -> pure (SourceNoHaddock query p) - Just htmlRoot -> do - -- Haddock generates hyperlinked source in one of two layouts: - -- dotted: src/Data.Map.Strict.html (newer Haddock / haskell.nix) - -- slashed: src/Data/Map/Strict.html (older Haddock / cabal local) - let htmlPathDotted = htmlRoot "src" toString (unModuleName query.moduleName) <> ".html" - htmlPathSlashed = htmlRoot "src" toString (T.map dotToSlash (unModuleName query.moduleName)) <> ".html" - Log.debug $ "Source: reading " <> toText htmlPathDotted - mHtml <- - readHaddockHtml htmlPathDotted >>= \case - Just html -> pure (Just html) - Nothing -> readHaddockHtml htmlPathSlashed - case mHtml of - Nothing -> do - Log.debug $ "Source: file not found: " <> toText htmlPathDotted - pure (SourceNoHaddock query p) - Just html -> do - let reExports = extractReExports query.moduleName html - case query.function of - Nothing -> do - let src = extractSource html - cacheInsert @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query) (src, reExports) - pure (SourceFound query src reExports) - Just fn -> - case extractFunctionSource fn html of - Just src -> do - cacheInsert @(PackageId, SourceQuery) @(Text, [ReExport]) (p, query) (src, reExports) - pure (SourceFound query src reExports) - Nothing -> - pure (FunctionNotFound query) - where - dotToSlash '.' = '/' - dotToSlash c = c - - --- ── HTML extraction ──────────────────────────────────────────────────────── - --- | Read the raw Haddock hyperlinked-source HTML file. -readHaddockHtml :: (FileSystem :> es) => FilePath -> Eff es (Maybe Text) -readHaddockHtml htmlPath = do - exists <- doesFileExist htmlPath - if not exists then - pure Nothing - else - Just . decodeUtf8 . BSL.toStrict <$> readFileLbs htmlPath - - --- | Extract the raw Haskell source from Haddock hyperlinked-source HTML. --- Line spans are split and their numeric prefixes stripped before annotation --- removal so that 'stripAnnotations' sees well-formed per-line chunks. -extractSource :: Text -> Text -extractSource html = - let (_, after) = T.breakOn "') 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 + pure result + Nothing -> serveFromTarball query p --- | Extract the source of a single top-level binding from Haddock source HTML. --- Finds the span with id matching the function name, then expands to the --- surrounding blank-line-delimited block (type sig + docstring above, body below). -extractFunctionSource :: Text -> Text -> Maybe Text -extractFunctionSource funcName html = - let (_, after) = T.breakOn "') 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))) +-- | Resolve a module to its package, consulting the module -> package cache first. +resolvePackage + :: (Cache ModuleName PackageId :> es, GhcPkg :> es, Log :> es) + => ModuleName + -> Eff es (Maybe PackageId) +resolvePackage modName = do + mCachedPkg <- cacheLookup @ModuleName @PackageId modName + case mCachedPkg of + Just p -> do + Log.debug $ "Source: " <> unModuleName modName <> " → " <> unPackageId p <> " (cached)" + pure (Just p) + Nothing -> do + result <- GhcPkg.findModule modName + Log.debug $ "Source: find-module " <> unModuleName modName <> " → " <> show result + whenJust result (cacheInsert @ModuleName @PackageId modName) + pure result --- | Extract re-exported names\/modules from Haddock source HTML. -extractReExports :: ModuleName -> Text -> [ReExport] -extractReExports modName html = - let afterMod = snd $ T.breakOn "module" html - exportRgn = fst $ T.breakOn "where" afterMod - in go exportRgn +-- | Locate (or fetch) the package's tarball, read the module member, and slice +-- the requested symbol if any. Caches and returns the result. +serveFromTarball + :: ( Cabal :> es + , Cache (PackageId, SourceQuery) ModuleSourceResult :> es + , Env :> es + , FileSystem :> es + ) + => SourceQuery + -> PackageId + -> Eff es ModuleSourceResult +serveFromTarball query p = + obtainTarball p >>= \case + -- A failed `cabal fetch` is transient (offline, stale index), so return + -- unavailable WITHOUT caching: a later lookup retries once the network or + -- index recovers, rather than serving the negative for the whole window. + TarballFetchFailed -> pure (SourceUnavailable query p) + -- The package is genuinely absent — a deterministic negative, safe to + -- cache alongside the read/slice outcomes below. + TarballAbsent -> cacheResult (SourceUnavailable query p) + TarballAt tarball -> do + mModuleSrc <- readModuleMember tarball query.moduleName + cacheResult $ case mModuleSrc of + Nothing -> SourceUnavailable query p + Just moduleSrc -> case query.function of + Nothing -> SourceFound query moduleSrc + Just symbol -> case sliceSymbol symbol moduleSrc of + Just slice -> SourceFound query slice + Nothing -> FunctionNotFound query where - modFile = unModuleName modName <> ".html" - - go :: Text -> [ReExport] - go region - | T.null region = [] - | otherwise = - let (before, rest) = T.breakOn "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 """ "\"" + -- Cache a deterministic outcome so the fetch + read/slice cost is paid at + -- most once per (package, query) within the cache window. + cacheResult result = do + cacheInsert @(PackageId, SourceQuery) @ModuleSourceResult (p, query) result + pure result diff --git a/src/Tricorder/SourceLookup/Cabal.hs b/src/Tricorder/SourceLookup/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/SourceLookup/Cabal.hs @@ -0,0 +1,99 @@ +-- | A narrow effect for the non-interactive @cabal@ subcommands tricorder +-- needs. The interpreter is the /sole/ spawner of the @cabal@ executable, and +-- it only ever runs the specific, pre-validated commands modelled here — +-- callers can neither pass arbitrary arguments nor choose the working +-- directory (fetches are pinned to the project root). Interactive +-- @cabal repl@ sessions are a separate concern, handled by +-- "Tricorder.Daemon.GhciSession.GhciProcess". +module Tricorder.SourceLookup.Cabal + ( -- * Effect + Cabal + , FetchResult (..) + , fetchSource + + -- * Interpreters + , runCabalIO + , runCabalFetchWith + , CabalScript (..) + ) where + +import Atelier.Effects.Log (Log) +import Atelier.Effects.Process (Process, proc, readProcess, setWorkingDir) +import Effectful (Effect) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.Exception (trySync) +import Effectful.Reader.Static (Reader, ask) +import Effectful.TH (makeEffect) +import System.Exit (ExitCode (..)) + +import Atelier.Effects.Log qualified as Log +import Data.Text qualified as T + +import Tricorder.Module (PackageId (..)) +import Tricorder.Runtime (ProjectRoot (..)) + + +-- | Whether an on-demand fetch exited cleanly. A clean exit that still leaves +-- no tarball is a /deterministic/ absence (safe to cache); a failed fetch is +-- /transient/ (must not be cached). +data FetchResult = Fetched | FetchFailed + deriving stock (Eq, Show) + + +-- | The non-interactive @cabal@ subcommands tricorder drives. Each runs the +-- user's /own/ @cabal@ executable inside their project — tricorder deliberately +-- does not bring the @Cabal@ library along as a Haskell dependency, so +-- behaviour always matches the user's toolchain and project configuration. +data Cabal :: Effect where + -- | @cabal fetch --no-dependencies \@, run in the project root so it + -- honours the project's configured repositories (CHaP, constraints). + -- Reports only whether the fetch exited cleanly, so a transient failure + -- (offline, stale index, yanked) stays distinguishable from a genuine + -- absence and is not cached. + FetchSource :: PackageId -> Cabal m FetchResult + + +makeEffect ''Cabal + + +-- | Production interpreter. The only code path that spawns @cabal@. +runCabalIO + :: (Log :> es, Process :> es, Reader ProjectRoot :> es) + => Eff (Cabal : es) a + -> Eff es a +runCabalIO = interpret \_ -> \case + FetchSource pkgId -> do + ProjectRoot projectRoot <- ask + Log.info $ "Source: cabal fetch " <> unPackageId pkgId + let cfg = + setWorkingDir projectRoot + $ proc "cabal" ["fetch", "--no-dependencies", toString (unPackageId pkgId)] + result <- trySync (readProcess cfg) + case result of + Right (ExitSuccess, _, _) -> pure Fetched + Right (ExitFailure _, out, err) -> do + let details = T.strip (decodeUtf8 (err <> out)) + suffix = if T.null details then "" else ": " <> details + Log.warn $ "Source: cabal fetch failed for " <> unPackageId pkgId <> suffix + pure FetchFailed + Left e -> do + Log.warn $ "Source: cabal fetch failed for " <> unPackageId pkgId <> ": " <> show e + pure FetchFailed + + +-- | Test interpreter: every 'fetchSource' yields the result of @onFetch@, which +-- runs in the remaining effects so it can model the fetch's observable side +-- effect — e.g. populating a fake filesystem to mimic a warmed cache. +-- 'cabalVersion' is unsupported. Use this when the unit under test drives +-- @cabal@ solely through 'fetchSource'. +runCabalFetchWith :: Eff es FetchResult -> Eff (Cabal : es) a -> Eff es a +runCabalFetchWith onFetch = interpret \_ -> \case + FetchSource _ -> onFetch + + +-- | Script element for the pure test interpreter. +data CabalScript + = -- | Return this value for the next 'fetchSource' call. + NextFetch FetchResult + | -- | Return this value for the next 'cabalVersion' call. + NextVersion (Maybe Text) diff --git a/src/Tricorder/SourceLookup/GhcPkg.hs b/src/Tricorder/SourceLookup/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/SourceLookup/GhcPkg.hs @@ -0,0 +1,46 @@ +module Tricorder.SourceLookup.GhcPkg + ( GhcPkg + , findModule + , runGhcPkgIO + , runGhcPkgScripted + , GhcPkgScript (..) + ) where + +import Atelier.Effects.Process (Process, readProcessSafe) +import Effectful (Effect) +import Effectful.Dispatch.Dynamic (interpret, reinterpret) +import Effectful.State.Static.Shared (evalState, get, put) +import Effectful.TH (makeEffect) + +import Data.Text qualified as T + +import Tricorder.Module (ModuleName (..), PackageId (..)) + + +data GhcPkg :: Effect where + FindModule :: ModuleName -> GhcPkg m (Maybe PackageId) + + +makeEffect ''GhcPkg + + +runGhcPkgIO :: (Process :> es) => Eff (GhcPkg : es) a -> Eff es a +runGhcPkgIO = interpret \_ -> \case + FindModule modName -> do + out <- readProcessSafe "ghc-pkg" ["find-module", "--simple-output", toString (unModuleName modName)] + pure $ out >>= fmap PackageId . listToMaybe . filter (not . T.null) . map T.strip . T.lines + + +-- | Script element for the test interpreter. +newtype GhcPkgScript + = -- | Return this value for the next 'findModule' call. + NextFindModule (Maybe PackageId) + + +-- | Scripted interpreter for testing. Does not require 'IOE'. +runGhcPkgScripted :: [GhcPkgScript] -> Eff (GhcPkg : es) a -> Eff es a +runGhcPkgScripted script = reinterpret (evalState script) \_ -> \case + FindModule _ -> + get >>= \case + NextFindModule result : rest -> put rest >> pure result + _ -> error "GhcPkgScripted: expected NextFindModule but queue was empty or mismatched" diff --git a/src/Tricorder/SourceLookup/Slice.hs b/src/Tricorder/SourceLookup/Slice.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/SourceLookup/Slice.hs @@ -0,0 +1,265 @@ +-- | A pure, lexical source slicer. +-- +-- It is deliberately /lexical/. It reasons about column-0 anchors, leading +-- keywords, and blank-line boundaries; it never builds a real Haskell AST. That +-- keeps it robust to CPP, unknown language extensions, and exotic syntax: a +-- shape it cannot make sense of simply yields 'Nothing', and the caller falls +-- back to the whole module (or reports the symbol as not found). It never +-- throws. +module Tricorder.SourceLookup.Slice + ( sliceSymbol + ) where + +import Data.Char (isAlphaNum, isSpace, isUpper) + +import Data.List qualified as List +import Data.Text qualified as T + + +-- | Slice the declaration that introduces @symbol@ from @source@. +-- +-- Returns the top-level declaration that introduces the symbol: the declaration +-- head, any type signature directly above it, and the contiguous doc-comment +-- block above that — terminating at the blank line or the next top-level +-- declaration that ends it. 'Nothing' when no introducing declaration is found. +sliceSymbol :: Text -> Text -> Maybe Text +sliceSymbol symbol source + | T.null symbol = Nothing + | otherwise = + let ls = T.lines source + in if isTypeSymbol symbol then + sliceType symbol ls <|> sliceConstructor symbol ls + else + sliceValue symbol ls + + +-- | Evaluate whether the symbol references a type-level entity. +isTypeSymbol :: Text -> Bool +isTypeSymbol = maybe False (isUpper . fst) . T.uncons + + +-- ── Value bindings ───────────────────────────────────────────────────────── + +-- | Slice the value binding introducing @name@ (a function, CAF, or operator). +sliceValue :: Text -> [Text] -> Maybe Text +sliceValue name ls = + (\i -> expandAt (belongsToValue name) i ls) <$> List.findIndex (introducesValue name) ls + + +-- | Whether a line introduces the value @name@ at column 0 — its type +-- signature, an equation head, or a bare binding. Operators are matched in +-- their parenthesised @(op)@ form. +introducesValue :: Text -> Text -> Bool +introducesValue name line = + isCol0 line + && ( leadingIdent line == name + || ("(" <> name <> ")") `T.isPrefixOf` line + ) + + +-- | Whether a column-0 line below the anchor still belongs to the value binding +-- for @name@: a further equation or signature (same leading identifier or +-- @(name)@ head), or — for an operator — an infix equation whose left-hand side +-- uses it (e.g. @a \<+\> b = …@, which leads with the argument rather than the +-- operator). +belongsToValue :: Text -> Text -> Bool +belongsToValue name line = + introducesValue name line + || (isOperatorName name && usesOperatorInHead name line) + + +-- | Whether @line@ is an equation whose left-hand side applies operator @name@ +-- infix. The head is the text before the first @=@; the operator must appear +-- there as a whitespace-delimited token, so an unrelated binding that merely +-- mentions the operator in its /body/ (@merge x y = x \<+\> y@) is excluded. +usesOperatorInHead :: Text -> Text -> Bool +usesOperatorInHead name line = + (" " <> name <> " ") `T.isInfixOf` (" " <> T.strip head_ <> " ") + where + head_ = fst (T.breakOn "=" line) + + +-- | Whether @name@ is an operator (its first character is not identifier-like). +isOperatorName :: Text -> Bool +isOperatorName = maybe False (not . isIdentChar . fst) . T.uncons + + +-- ── Type / class declarations ────────────────────────────────────────────── + +-- | Slice the type-level declaration head introducing @name@. A type\/class +-- body is entirely indented, so no column-0 line below the head belongs to it. +sliceType :: Text -> [Text] -> Maybe Text +sliceType name ls = + (\i -> expandAt (const False) i ls) <$> List.findIndex (introducesType name) ls + + +-- | Whether a column-0 line is a declaration head for the type-level @name@. +introducesType :: Text -> Text -> Bool +introducesType name line = + isCol0 line + && case T.words line of + ("data" : "family" : n : _) -> tok n == name + ("type" : "family" : n : _) -> tok n == name + ("data" : n : _) -> tok n == name + ("newtype" : n : _) -> tok n == name + ("type" : n : _) -> tok n == name + ("class" : ws) -> maybe False ((== name) . tok) (classHead ws) + _ -> False + where + tok = T.takeWhile isIdentChar + + +-- | The class name from the words following the @class@ keyword: the first word +-- after the superclass context (the last @=>@), or the very first word when +-- there is no context. So @class Eq a => Ord a where@ yields @Ord@, not the +-- superclass @Eq@. +classHead :: [Text] -> Maybe Text +classHead ws = + case break (== "=>") (reverse (takeWhile (/= "where") ws)) of + (afterContext, _ : _) -> viaNonEmpty last afterContext + (_, []) -> listToMaybe ws + + +-- | Slice the @data@ \/ @newtype@ declaration whose body defines @name@ as a +-- constructor, returning that whole declaration block. Used as a fallback for +-- uppercase queries that do not name a type head. +sliceConstructor :: Text -> [Text] -> Maybe Text +sliceConstructor name ls = + List.find (mentionsConstructor name) (map (\i -> expandAt (const False) i ls) dataHeads) + where + dataHeads = List.findIndices isDataNewtypeHead ls + + +-- | Whether a column-0 line opens a @data@ or @newtype@ declaration. +isDataNewtypeHead :: Text -> Bool +isDataNewtypeHead line = + isCol0 line + && case T.words line of + ("data" : _) -> True + ("newtype" : _) -> True + _ -> False + + +-- | Whether a declaration block defines @name@ as a constructor. Lexical and +-- approximate, but it looks only at /constructor positions/ — the leading token +-- of each @|@-separated alternative in an ADT, or the names before @::@ in a +-- GADT — so a mention of @name@ as a field type or inside a doc comment does not +-- count, and we do not return a @data@ block that merely references it. +mentionsConstructor :: Text -> Text -> Bool +mentionsConstructor name block = name `elem` constructorNames block + + +-- | The constructor names introduced by a @data@ \/ @newtype@ block, ignoring +-- doc comments. Handles both ADT syntax (@= A x | B y@) and GADT syntax +-- (@A, B :: …@ lines under a @where@ head). +constructorNames :: Text -> [Text] +constructorNames block = + case filter (not . isCommentLine) (T.lines block) of + [] -> [] + code@(headLine : rest) + | "where" `elem` T.words headLine -> concatMap gadtCons rest + | otherwise -> adtCons (T.unwords code) + where + -- ADT: names lead each alternative after the first @=@. + adtCons decl = + let rhs = T.drop 1 (T.dropWhile (/= '=') decl) + in mapMaybe (leadingCon . T.stripStart) (T.splitOn "|" rhs) + -- GADT: @Con1, Con2 :: …@ — names before the @::@. + gadtCons line + | "::" `T.isInfixOf` line = + mapMaybe (leadingCon . T.strip) (T.splitOn "," (fst (T.breakOn "::" line))) + | otherwise = [] + leadingCon t = case leadingIdent t of + "" -> Nothing + ident -> Just ident + + +-- ── Block expansion ──────────────────────────────────────────────────────── + +-- | Expand the declaration anchored at line index @i@ into its full slice: the +-- contiguous doc-comment block above @i@, then the declaration from @i@ down to +-- (but not including) the next top-level declaration. +-- +-- The block ends at the next top-level (column-0) declaration. Indented lines, +-- blank lines, and CPP directives all continue it — so a blank line inside a +-- @where@ clause or between guards does not truncate the slice — while +-- @sameDecl@ recognises the column-0 lines that also continue it (further +-- equations of a value binding, or an operator's infix body). Trailing blank +-- lines picked up before the boundary are trimmed off. +expandAt :: (Text -> Bool) -> Int -> [Text] -> Text +expandAt sameDecl i ls = + let (before, rest) = splitAt i ls + docBlock = docCommentAbove before + body = case rest of + [] -> [] + (hd : tl) -> hd : takeWhile continuesBody tl + in T.intercalate "\n" (docBlock <> dropTrailingBlanks body) + where + continuesBody line = + isBlank line + || not (isCol0 line) + || isCppLine line + || sameDecl line + dropTrailingBlanks = reverse . dropWhile isBlank . reverse + + +-- | The contiguous doc-comment block immediately above a declaration, in source +-- order. Handles line comments (@--@) and multi-line block comments +-- (@{- … -}@), whose interior and closing lines are not themselves +-- comment-prefixed. Stops at the first non-comment (or blank) line. +docCommentAbove :: [Text] -> [Text] +docCommentAbove before = reverse (takeDoc (reverse before)) + where + takeDoc [] = [] + takeDoc (l : ls) + | isCommentLine l = l : takeDoc ls + | closesBlockComment l = + let (blockBody, ls') = consumeToBlockOpen ls + in (l : blockBody) <> takeDoc ls' + | otherwise = [] + -- Consume upward (source-reversed) until the line that opens the block. + consumeToBlockOpen [] = ([], []) + consumeToBlockOpen (l : ls) + | opensBlockComment l = ([l], ls) + | otherwise = let (blockBody, ls') = consumeToBlockOpen ls in (l : blockBody, ls') + closesBlockComment l = "-}" `T.isSuffixOf` T.stripEnd l && not (opensBlockComment l) + opensBlockComment l = "{-" `T.isPrefixOf` T.stripStart l + + +-- ── Lexical helpers ──────────────────────────────────────────────────────── + +-- | A line that is empty or only whitespace. +isBlank :: Text -> Bool +isBlank = T.null . T.strip + + +-- | A line whose first non-blank content opens a comment (@--@ or @{-@). Used +-- to gather the doc block above a declaration. +isCommentLine :: Text -> Bool +isCommentLine line = + let s = T.stripStart line + in "--" `T.isPrefixOf` s || "{-" `T.isPrefixOf` s + + +-- | A CPP directive line (@#if@, @#else@, @#endif@, …). These sit at column 0 +-- but are transparent to declaration boundaries, so a slice spans them. +isCppLine :: Text -> Bool +isCppLine = T.isPrefixOf "#" . T.stripStart + + +-- | A line whose first character is in column 0 (not indented, not empty). +isCol0 :: Text -> Bool +isCol0 line = case T.uncons line of + Just (c, _) -> not (isSpace c) + Nothing -> False + + +-- | The leading identifier token of a line, or @""@ when it does not start with +-- one. E.g. @"foo x = 1"@ → @"foo"@, @"foo :: Int"@ → @"foo"@, @"-- doc"@ → @""@. +leadingIdent :: Text -> Text +leadingIdent = T.takeWhile isIdentChar + + +-- | Characters that may appear in a Haskell identifier. +isIdentChar :: Char -> Bool +isIdentChar c = isAlphaNum c || c == '_' || c == '\'' diff --git a/src/Tricorder/SourceLookup/Tarball.hs b/src/Tricorder/SourceLookup/Tarball.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/SourceLookup/Tarball.hs @@ -0,0 +1,244 @@ +-- | Locate, fetch, and read a package's source from its Hackage sdist tarball +-- in cabal's global package cache. +module Tricorder.SourceLookup.Tarball + ( -- * High-level + TarballOutcome (..) + , obtainTarball + , readModuleMember + + -- * Pure helpers (exposed for testing) + , splitPackageId + , tarballPath + , cabalPackagesDirs + , matchesModule + , extractModule + ) where + +import Atelier.Effects.Env (Env, getEnvironment) +import Atelier.Effects.FileSystem + ( FileSystem + , doesFileExist + , doesPathExist + , listDirectory + , readFileLbs + ) +import Data.Char (isUpper) +import Effectful.Exception (trySync) +import System.FilePath (splitDirectories, ()) + +import Codec.Archive.Tar qualified as Tar +import Codec.Compression.GZip qualified as GZip +import Data.ByteString.Lazy qualified as BSL +import Data.List qualified as List +import Data.Text qualified as T + +import Tricorder.Module (ModuleName (..), PackageId (..)) +import Tricorder.SourceLookup.Cabal (Cabal, FetchResult (..), fetchSource) + + +-- | The default repository subdirectory under the cabal package cache. +hackageRepo :: FilePath +hackageRepo = "hackage.haskell.org" + + +-- ── High-level ───────────────────────────────────────────────────────────── + +-- | The result of locating (and, if needed, fetching) a package's tarball. +data TarballOutcome + = TarballAt FilePath + | -- | No tarball, though the lookup completed cleanly (absent from every + -- configured repository, or yanked). + TarballAbsent + | -- | The on-demand @cabal fetch@ itself failed (offline, stale index, …). + TarballFetchFailed + deriving stock (Eq, Show) + + +-- | Locate @pkgId@'s sdist tarball in the cabal cache, fetching it on demand if +-- absent. +-- +-- The cache holds one @\-\.tar.gz@ per resolved package at a +-- predictable path. On a hit we return that path directly. On a miss we warm +-- the cache with @cabal fetch --no-dependencies@ — the exact version @ghc-pkg@ +-- reports — and look again. The outcome distinguishes a genuine absence from a +-- transient fetch failure. +obtainTarball + :: (Cabal :> es, Env :> es, FileSystem :> es) + => PackageId + -> Eff es TarballOutcome +obtainTarball pkgId = do + found <- findTarball pkgId + case found of + Just path -> pure (TarballAt path) + Nothing -> do + fetched <- fetchSource pkgId + refound <- findTarball pkgId + pure $ case refound of + Just path -> TarballAt path + Nothing -> case fetched of + Fetched -> TarballAbsent + FetchFailed -> TarballFetchFailed + + +-- | Read a single module's source from a tarball, in-process. 'Nothing' when +-- the member is absent or the archive cannot be read (any decompression or +-- parse error is caught, never propagated). +readModuleMember :: (FileSystem :> es) => FilePath -> ModuleName -> Eff es (Maybe Text) +readModuleMember tarball modName = do + raw <- readFileLbs tarball + -- 'force' drives the lazy gunzip + tar parse to completion inside 'trySync', + -- so a corrupt archive yields 'Nothing' instead of a deferred exception. + result <- trySync (pure $! force (extractModule modName raw)) + pure (either (const Nothing) id result) + + +-- ── Locate ───────────────────────────────────────────────────────────────── + +-- | Search every candidate cabal cache directory (and every repository subdir +-- within it) for @pkgId@'s tarball, preferring @hackage.haskell.org@. +findTarball :: (Env :> es, FileSystem :> es) => PackageId -> Eff es (Maybe FilePath) +findTarball pkgId = do + env <- getEnvironment + candidates <- concat <$> traverse basePaths (cabalPackagesDirs env) + firstExisting candidates + where + basePaths base = do + repos <- listRepos base + pure [tarballPath base repo pkgId | repo <- repos] + firstExisting [] = pure Nothing + firstExisting (p : ps) = do + exists <- doesFileExist p + if exists then pure (Just p) else firstExisting ps + + +-- | The repository subdirectories under the cache, @hackage.haskell.org@ first. +-- Falls back to just @hackage.haskell.org@ when the cache directory is absent. +listRepos :: (FileSystem :> es) => FilePath -> Eff es [FilePath] +listRepos base = do + exists <- doesPathExist base + if not exists then + pure [hackageRepo] + else do + entries <- listDirectory base + pure (hackageRepo : filter (/= hackageRepo) entries) + + +-- | Candidate cabal package-cache directories to search, most-preferred first. +-- +-- Honors @CABAL_DIR@; otherwise searches the XDG cache and both the modern +-- @~\/.cache\/cabal@ and the legacy pre-XDG @~\/.cabal@ layouts, since which one +-- cabal uses depends on its version and on whether @~\/.cabal@ already exists. +-- +-- Only absolute candidates are produced: when @HOME@ (and the cabal vars) are +-- unset — as in a stripped daemon environment — the result is empty rather than +-- a path resolved relative to the working directory. +cabalPackagesDirs :: [(String, String)] -> [FilePath] +cabalPackagesDirs env = + case List.lookup "CABAL_DIR" env of + Just dir | not (null dir) -> [dir "packages"] + _ -> xdgCandidate <> homeCandidates + where + xdgCandidate = case List.lookup "XDG_CACHE_HOME" env of + Just x | not (null x) -> [x "cabal" "packages"] + _ -> [] + homeCandidates = case List.lookup "HOME" env of + Just h + | not (null h) -> + [ h ".cache" "cabal" "packages" + , h ".cabal" "packages" + ] + _ -> [] + + +-- ── Pure helpers ─────────────────────────────────────────────────────────── + +-- | Split a 'PackageId' into its package name and version. The version is the +-- final hyphen-delimited component (versions are dot-, not hyphen-separated), +-- so @"list-t-1.0.5.7"@ → @("list-t", "1.0.5.7")@. +splitPackageId :: PackageId -> (Text, Text) +splitPackageId (PackageId pid) = + case reverse (T.splitOn "-" pid) of + (ver : nameParts@(_ : _)) -> (T.intercalate "-" (reverse nameParts), ver) + _ -> (pid, "") + + +-- | The cache path of a package's tarball under one repository subdir: +-- @\\/\\/\\/\\/\-\.tar.gz@. +tarballPath :: FilePath -> FilePath -> PackageId -> FilePath +tarballPath base repo pkgId = + let (name, ver) = splitPackageId pkgId + in base repo toString name toString ver toString (name <> "-" <> ver <> ".tar.gz") + + +-- | Whether a tarball entry path is the source file for @modName@. Matches the +-- module's dotted-to-slashed path plus a Haskell source extension as a suffix, +-- which resolves @src\/@, @lib\/@, and flat layouts uniformly +-- (@\-\\/src\/Data\/Aeson.hs@ etc.) and covers preprocessed sources +-- (@.hsc@, @.lhs@, @.chs@). +-- +-- The path component immediately before the match must be a source root (e.g. +-- @src@, the package dir), not another module component — otherwise module +-- @Lens@ would spuriously match the file for @Control.Lens@. +matchesModule :: ModuleName -> FilePath -> Bool +matchesModule modName path = any matchesWithExtension sourceExtensions + where + slashed = T.map dotToSlash (unModuleName modName) + txt = toText path + matchesWithExtension ext = case T.stripSuffix ("/" <> slashed <> ext) txt of + Just before -> not (endsWithModuleComponent before) + Nothing -> False + endsWithModuleComponent before = case T.uncons (T.takeWhileEnd (/= '/') before) of + Just (c, _) -> isUpper c + Nothing -> False + dotToSlash '.' = '/' + dotToSlash c = c + + +-- | Source-file extensions whose base name equals the final module component. +sourceExtensions :: [Text] +sourceExtensions = [".hs", ".lhs", ".hsc", ".chs"] + + +-- | Extract @modName@'s source text from a gzipped tarball. 'Nothing' when no +-- member matches. +extractModule :: ModuleName -> LByteString -> Maybe Text +extractModule modName tarGz = + decodeUtf8 . BSL.toStrict <$> extractMember (matchesModule modName) tarGz + + +-- | The bytes of the best regular-file entry whose path satisfies the +-- predicate: a library path in preference to a same-named copy under a +-- @test@\/@bench@\/@example@ tree, then the shallowest path. This keeps a +-- package's test module from shadowing the library module of the same name. +extractMember :: (FilePath -> Bool) -> LByteString -> Maybe LByteString +extractMember matches tarGz = + snd <$> viaNonEmpty head (List.sortOn rank candidates) + where + entries = Tar.read (GZip.decompress tarGz) + candidates = Tar.foldEntries step [] (const []) entries + step entry acc = case Tar.entryContent entry of + Tar.NormalFile bytes _ + | matches path -> (path, bytes) : acc + where + path = Tar.entryPath entry + _ -> acc + rank (path, _) = (isNonLibraryPath path, length (splitDirectories path)) + + +-- | Whether a path lies under a non-library source tree (tests, benchmarks, +-- examples), which we deprioritise when the same module appears more than once. +isNonLibraryPath :: FilePath -> Bool +isNonLibraryPath path = any (`elem` nonLibraryDirs) (splitDirectories path) + where + nonLibraryDirs :: [FilePath] + nonLibraryDirs = + [ "test" + , "tests" + , "bench" + , "benchmark" + , "benchmarks" + , "example" + , "examples" + , "spec" + , "specs" + ] diff --git a/src/Tricorder/TestOutput.hs b/src/Tricorder/TestOutput.hs --- a/src/Tricorder/TestOutput.hs +++ b/src/Tricorder/TestOutput.hs @@ -5,7 +5,7 @@ import Data.Text qualified as T -import Tricorder.BuildState (TestCase (..), TestCaseOutcome (..)) +import Tricorder.Build.Test qualified as Test -- | Parse hspec output into individual test case results. @@ -14,18 +14,18 @@ -- with or without a trailing timing annotation like @(0.05s)@ or @(120ms)@. -- For failing tests, collects the indented detail lines that follow as the -- failure message. -parseHspecOutput :: Text -> [TestCase] +parseHspecOutput :: Text -> [Test.Case] parseHspecOutput = go . T.lines where go [] = [] go (l : ls) | T.isSuffixOf "OK" norm = - TestCase {description = extractDesc "OK" norm, outcome = TestCasePassed} + Test.Case {description = extractDesc "OK" norm, outcome = Test.Passed} : go ls | T.isSuffixOf "FAIL" norm = let (detailLines, rest) = span (\dl -> indentOf dl > indentOf l) ls details = T.intercalate "\n" $ filter (not . T.null) $ map T.strip detailLines - in TestCase {description = extractDesc "FAIL" norm, outcome = TestCaseFailed details} + in Test.Case {description = extractDesc "FAIL" norm, outcome = Test.Failed details} : go rest | otherwise = go ls where diff --git a/src/Tricorder/UI.hs b/src/Tricorder/UI.hs deleted file mode 100644 --- a/src/Tricorder/UI.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Tricorder.UI - ( viewUi - ) where - -import Atelier.Effects.Clock (Clock) -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.Console (Console) -import Atelier.Effects.Delay (Delay) -import Atelier.Effects.File (File) -import Brick (App (..), neverShowCursor) -import Brick.Keybindings (KeyConfig) -import Effectful.Reader.Static (Reader, ask) - -import Atelier.Effects.Conc qualified as Conc - -import Tricorder.Effects.Brick (Brick) -import Tricorder.Effects.BrickChan (BrickChan) -import Tricorder.Effects.UnixSocket (UnixSocket) -import Tricorder.Runtime (SocketPath (..)) -import Tricorder.Socket.Client (queryWatch) -import Tricorder.UI.Event (Event (..), handleEvent) -import Tricorder.UI.Keys (KeyEvent, dispatcher) -import Tricorder.UI.State (State (..), Viewports (..)) -import Tricorder.UI.View (mkAttrMap, view) - -import Tricorder.Effects.Brick qualified as Brick -import Tricorder.Effects.BrickChan qualified as BrickChan -import Tricorder.UI.Keys qualified as Keys -import Tricorder.UI.State qualified as Model - - --- | Connect to the daemon and render a live-updating build status display using --- a brick TUI. Quits on @q@ or @Esc@; arrow keys scroll the viewport. -viewUi - :: ( Brick :> es - , BrickChan :> es - , Clock :> es - , Conc :> es - , Console :> es - , Delay :> es - , File :> es - , Reader Keys.Config :> es - , Reader SocketPath :> es - , UnixSocket :> es - ) - => Eff es () -viewUi = do - SocketPath sockPath <- ask - chan <- BrickChan.newBChan 10 - initialState <- Model.init - Conc.scoped do - _ <- - Conc.fork do - queryWatch sockPath $ BrickChan.writeBChan chan . NewBuildState - BrickChan.writeBChan chan $ FailedBuild "Lost contact with the daemon" - keyConfig <- Keys.mkKeyConfig - void - $ Brick.runBrickApp - chan - (watchApp keyConfig) - initialState - - -watchApp :: KeyConfig KeyEvent -> App State Event Viewports -watchApp kc = - App - { appDraw = view kc - , appHandleEvent = handleEvent $ dispatcher kc - , appStartEvent = pure () - , appAttrMap = mkAttrMap - , appChooseCursor = neverShowCursor - } diff --git a/src/Tricorder/UI/Event.hs b/src/Tricorder/UI/Event.hs deleted file mode 100644 --- a/src/Tricorder/UI/Event.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Tricorder.UI.Event - ( Event (..) - , handleEvent - ) where - -import Brick (BrickEvent (..), EventM, vScrollBy, viewportScroll) -import Brick.Keybindings (KeyDispatcher, handleKey) -import Control.Monad.State (modify) - -import Graphics.Vty qualified as Vty - -import Tricorder.BuildState (BuildState (..)) -import Tricorder.Socket.Client (Restarting (..)) -import Tricorder.UI.Keys (KeyEvent) -import Tricorder.UI.State (Processed (..), State (..), Viewports (..)) - - -data Event - = NewBuildState (Either Restarting BuildState) - | FailedBuild Text - - -handleEvent :: KeyDispatcher KeyEvent (EventM Viewports State) -> BrickEvent Viewports Event -> EventM Viewports State () -handleEvent _ (AppEvent ev) = handleAppEvent ev -handleEvent d (VtyEvent (Vty.EvKey key modifiers)) = void $ handleKey d key modifiers -handleEvent _ (MouseDown vp Vty.BScrollUp _ _) = vScrollBy (viewportScroll vp) (-1) -handleEvent _ (MouseDown vp Vty.BScrollDown _ _) = vScrollBy (viewportScroll vp) 1 -handleEvent _ _ = pure () - - -handleAppEvent :: Event -> EventM Viewports State () -handleAppEvent = \case - NewBuildState (Left Restarting) -> - modify \s -> s {buildState = Waiting} - NewBuildState (Right bs) -> - modify \s -> s {buildState = Success bs} - FailedBuild reason -> - modify \s -> s {buildState = Failure reason} diff --git a/src/Tricorder/UI/Keys.hs b/src/Tricorder/UI/Keys.hs deleted file mode 100644 --- a/src/Tricorder/UI/Keys.hs +++ /dev/null @@ -1,240 +0,0 @@ -module Tricorder.UI.Keys - ( KeyEvent - , Config - , keys - , dispatcher - , viewKeybindings - , mkKeyConfig - , keybindForRoute - ) where - -import Atelier.Effects.Console (Console) -import Brick - ( EventM - , Widget - , halt - , txt - , vBox - , vScrollBy - , viewportScroll - ) -import Brick.Keybindings - ( Binding - , BindingState - , EventTrigger (..) - , Handler (..) - , KeyConfig - , KeyDispatcher - , KeyEventHandler (..) - , KeyEvents - , KeyHandler (..) - , ToBinding (..) - , allActiveBindings - , binding - , ctrl - , keyDispatcher - , keyEvents - , newKeyConfig - , onEvent - , parseBindingList - ) -import Brick.Keybindings.KeyConfig (firstActiveBinding) -import Brick.Keybindings.Pretty (ppBinding) -import Brick.Widgets.Core (hBox) -import Control.Monad.State (gets, modify) -import Data.Aeson (FromJSON (..)) -import Data.Default (Default (..)) -import Effectful.Exception (throwIO) -import Effectful.Reader.Static (Reader, ask) -import Graphics.Vty (Key (..)) -import System.IO.Error (userError) -import Text.Casing (quietSnake) - -import Atelier.Effects.Console qualified as Console -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Data.Text qualified as T - -import Tricorder.UI.Misc (warn) -import Tricorder.UI.Route (Route) -import Tricorder.UI.State - ( State (..) - , Viewports (..) - , currentRoute - , cycleTestFilter - , navigate - , viewToViewport - ) - -import Tricorder.UI.Route qualified as Route - - --- When adding a new event here, also list it in the README under "Custom Key Bindings". -data KeyEvent - = ToggleDaemonInfoView - | ToggleHelp - | CycleTestView - | ExitView - | ScrollUp - | ScrollDown - | Quit - deriving stock (Bounded, Enum, Eq, Ord, Show) - - -keyEventToText :: KeyEvent -> Text -keyEventToText = toText . quietSnake . show - - -keyEventTextMap :: Map Text KeyEvent -keyEventTextMap = Map.fromList $ (\e -> (keyEventToText e, e)) <$> universe - - -textToKeyEvent :: Text -> Maybe KeyEvent -textToKeyEvent = (`Map.lookup` keyEventTextMap) - - -keys :: KeyEvents KeyEvent -keys = - keyEvents - [ ("toggle daemon info", ToggleDaemonInfoView) - , ("toggle help", ToggleHelp) - , ("cycle test view", CycleTestView) - , ("exit view", ExitView) - , ("scroll up", ScrollUp) - , ("scroll down", ScrollDown) - , ("quit", Quit) - ] - - -bindings :: [(KeyEvent, [Binding])] -bindings = - [ (ToggleDaemonInfoView, [bind 'g']) - , (ToggleHelp, [bind 'h']) - , (CycleTestView, [bind 't']) - , (ExitView, [binding KEsc []]) - , (ScrollUp, [binding KUp []]) - , (ScrollDown, [binding KDown []]) - , (Quit, [bind 'q', ctrl 'c']) - ] - - -mkKeyConfig :: (Console :> es, Reader Config :> es) => Eff es (KeyConfig KeyEvent) -mkKeyConfig = do - customBindings <- parseCustomBindings - pure $ newKeyConfig keys bindings customBindings - - -newtype Config = Config (Map Text Text) - deriving stock (Generic) - deriving newtype (FromJSON) - - -instance Default Config where - def = Config mempty - - -parseCustomBindings - :: ( Console :> es - , Reader Config :> es - ) - => Eff es [(KeyEvent, BindingState)] -parseCustomBindings = do - Config cfg <- ask - let (errors, customBindings) = partitionEithers $ uncurry parseEntry <$> Map.toList cfg - unless (null errors) do - Console.putTextLn "Error(s) encountered when attempting to parse key bindings:" - traverse_ (Console.putTextLn . toText) errors - throwIO $ userError "Malformed keybindings" - pure customBindings - - -parseEntry :: Text -> Text -> Either Text (KeyEvent, BindingState) -parseEntry ev binds = - (,) <$> parsedEvent <*> parsedBinds - where - parsedEvent = parseKeyEvent ev - parsedBinds = first toText $ parseBindingList binds - - -parseKeyEvent :: Text -> Either Text KeyEvent -parseKeyEvent ev = maybeToRight ("Unrecognized key event: " <> ev) $ textToKeyEvent ev - - -dispatcher :: KeyConfig KeyEvent -> KeyDispatcher KeyEvent (EventM Viewports State) -dispatcher cfg = - -- TODO: Handle this error more gracefully. - either (error . ("Invalid key dispatcher config: " <>) . stringify) id - $ keyDispatcher - cfg - [ onEvent ToggleDaemonInfoView "Toggle daemon info view" do - modify \s -> - if currentRoute s == Route.DaemonInfo then - navigate Route.Main s - else - navigate Route.DaemonInfo s - , onEvent ToggleHelp "Toggle help" do - modify \s -> - if currentRoute s == Route.Help then - navigate Route.Main s - else - navigate Route.Help s - , onEvent CycleTestView "Cycle test results view" do - modify \s -> case currentRoute s of - Route.Tests -> - if s.testFilter == maxBound then - navigate Route.Main s {testFilter = minBound} - else - s {testFilter = cycleTestFilter s.testFilter} - _ -> navigate Route.Tests s - , onEvent ExitView "Exit or go back" do - gets (.route) >>= \case - Route.Main -> halt - _ -> modify $ navigate Route.Main - , onEvent ScrollUp "Scroll up" do - mvp <- gets (viewToViewport . currentRoute) - case mvp of - Just vp -> vScrollBy (viewportScroll vp) (-1) - Nothing -> pure () - , onEvent ScrollDown "Scroll down" do - mvp <- gets (viewToViewport . currentRoute) - case mvp of - Just vp -> - vScrollBy (viewportScroll vp) 1 - Nothing -> pure () - , onEvent Quit "Exit" do - halt - ] - where - stringify = - show . fmap (second $ fmap $ handlerDescription . kehHandler . khHandler) - - -viewKeybindings :: (Ord k, Show k) => KeyConfig k -> [KeyEventHandler k m] -> Widget n -viewKeybindings kc = - vBox - . fmap (uncurry (viewEventAndTriggers kc)) - . Map.toList - . foldr groupByEventName Map.empty - where - groupByEventName ev = Map.insertWith (<>) ev.kehHandler.handlerDescription [ev.kehEventTrigger] - - -viewEventAndTriggers :: (Ord k, Show k) => KeyConfig k -> Text -> [EventTrigger k] -> Widget n -viewEventAndTriggers kc eventName triggers = - hBox - [ warn $ txt $ eventName <> ": " - , txt $ showBindings $ mconcat $ getBindings <$> triggers - ] - where - showBindings = T.intercalate ", " . fmap ppBinding . sort . toList - getBindings = \case - ByKey k -> Set.singleton k - ByEvent e -> Set.fromList $ allActiveBindings kc e - - -keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding -keybindForRoute kc = \case - Route.Main -> Nothing - Route.DaemonInfo -> firstActiveBinding kc ToggleDaemonInfoView - Route.Help -> firstActiveBinding kc ToggleHelp - Route.Tests -> firstActiveBinding kc CycleTestView diff --git a/src/Tricorder/UI/Misc.hs b/src/Tricorder/UI/Misc.hs deleted file mode 100644 --- a/src/Tricorder/UI/Misc.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Tricorder.UI.Misc - ( err - , warn - , ok - , emphasis - , subtle - , hBoxSpaced - , vBoxSpaced - ) where - -import Brick - ( Padding (..) - , Widget - , attrName - , hBox - , padLeft - , padTop - , vBox - , withDefAttr - ) - - -err :: Widget n -> Widget n -err = withDefAttr $ attrName "error" - - -warn :: Widget n -> Widget n -warn = withDefAttr $ attrName "warning" - - -ok :: Widget n -> Widget n -ok = withDefAttr $ attrName "ok" - - -emphasis :: Widget n -> Widget n -emphasis = withDefAttr $ attrName "emphasis" - - -subtle :: Widget n -> Widget n -subtle = withDefAttr $ attrName "subtle" - - -hBoxSpaced :: Int -> [Widget n] -> Widget n -hBoxSpaced _ [] = hBox [] -hBoxSpaced pad (x : xs) = hBox $ x : (padLeft (Pad pad) <$> xs) - - -vBoxSpaced :: Int -> [Widget n] -> Widget n -vBoxSpaced _ [] = vBox [] -vBoxSpaced pad (x : xs) = vBox $ x : (padTop (Pad pad) <$> xs) diff --git a/src/Tricorder/UI/Route.hs b/src/Tricorder/UI/Route.hs deleted file mode 100644 --- a/src/Tricorder/UI/Route.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Tricorder.UI.Route - ( Route (..) - , name - ) where - - -data Route - = Main - | Help - | DaemonInfo - | Tests - deriving stock (Bounded, Enum, Eq) - - -name :: Route -> Text -name = \case - Main -> "Dashboard" - Help -> "Help" - DaemonInfo -> "Daemon info" - Tests -> "Tests" diff --git a/src/Tricorder/UI/State.hs b/src/Tricorder/UI/State.hs deleted file mode 100644 --- a/src/Tricorder/UI/State.hs +++ /dev/null @@ -1,77 +0,0 @@ -module Tricorder.UI.State - ( Viewports (..) - , State (..) - , Processed (..) - , TestFilter (..) - , init - , currentRoute - , viewToViewport - , cycleTestFilter - , navigate - ) where - -import Atelier.Effects.Clock (Clock, TimeZone) -import Prelude hiding (init) - -import Atelier.Effects.Clock qualified as Clock - -import Tricorder.BuildState (BuildState (..)) -import Tricorder.UI.Route (Route) - -import Tricorder.UI.Route qualified as Route - - -data Viewports - = MainViewport - | DiagnosticViewport - | TestViewport - deriving stock (Eq, Ord, Show) - - -data State = State - { buildState :: Processed Text BuildState - , timeZone :: TimeZone - , route :: Route - , testFilter :: TestFilter - } - - -data TestFilter = TestFilterAll | TestFilterFailedOnly - deriving stock (Bounded, Enum, Eq) - - -cycleTestFilter :: TestFilter -> TestFilter -cycleTestFilter x = if x == maxBound then minBound else succ x - - -data Processed e a - = Waiting - | Failure e - | Success a - - -currentRoute :: State -> Route -currentRoute = (.route) - - -viewToViewport :: Route -> Maybe Viewports -viewToViewport = \case - Route.Tests -> Just TestViewport - Route.Main -> Just DiagnosticViewport - _ -> Nothing - - -navigate :: Route -> State -> State -navigate route s = s {route} - - -init :: (Clock :> es) => Eff es State -init = do - tz <- Clock.currentTimeZone - pure - State - { buildState = Waiting - , timeZone = tz - , route = Route.Main - , testFilter = minBound - } diff --git a/src/Tricorder/UI/View.hs b/src/Tricorder/UI/View.hs deleted file mode 100644 --- a/src/Tricorder/UI/View.hs +++ /dev/null @@ -1,473 +0,0 @@ -module Tricorder.UI.View (mkAttrMap, view) where - -import Atelier.Effects.Clock (TimeZone) -import Atelier.Time (Millisecond, toMicroseconds) -import Brick - ( AttrMap - , AttrName - , VScrollBarOrientation (..) - , ViewportType (..) - , Widget - , attrMap - , attrName - , vBox - , viewport - ) -import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList, ppBinding) -import Brick.Widgets.Core - ( Padding (..) - , emptyWidget - , hBox - , padLeft - , txt - , txtWrap - , withClickableVScrollBars - , withDefAttr - , withVScrollBarHandles - , withVScrollBars - ) -import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime) -import System.FilePath (isAbsolute) - -import Data.Text qualified as T -import Graphics.Vty.Attributes qualified as Attr -import Graphics.Vty.Attributes.Color qualified as Color - -import Tricorder.BuildState - ( BuildPhase (..) - , BuildProgress (..) - , BuildResult (..) - , BuildState (..) - , DaemonInfo (..) - , Diagnostic (..) - , Severity (..) - , TestCase (..) - , TestCaseOutcome (..) - , TestRun (..) - , TestRunCompletion (..) - , TestRunError (..) - ) -import Tricorder.Session (Target, renderTarget) -import Tricorder.TestOutput (stripGhciNoise) -import Tricorder.UI.Keys (KeyEvent, keybindForRoute, viewKeybindings) -import Tricorder.UI.Misc (emphasis, err, hBoxSpaced, ok, subtle, vBoxSpaced, warn) -import Tricorder.UI.Route (Route) -import Tricorder.UI.State (Processed (..), State (..), TestFilter (..), Viewports (..), currentRoute) - -import Tricorder.UI.Keys qualified as Keys -import Tricorder.UI.Route qualified as Route -import Tricorder.Version qualified as Version - - -mkAttrMap :: State -> AttrMap -mkAttrMap = - const - ( attrMap - Attr.defAttr - [ (attrName "ok", Attr.withForeColor Attr.defAttr Color.green) - , (attrName "warning", Attr.withForeColor Attr.defAttr Color.yellow) - , (attrName "error", Attr.withForeColor Attr.defAttr Color.red) - , (attrName "emphasis", Attr.withStyle Attr.defAttr Attr.bold) - , (attrName "subtle", Attr.withForeColor Attr.defAttr $ Color.rgbColor @Int 148 148 148) - ] - ) - - -view :: KeyConfig KeyEvent -> State -> [Widget Viewports] -view kc ws = - [ vBoxSpaced - 1 - [ vBox - [ viewAppHeader ws - , viewTabs kc ws - ] - , case currentRoute ws of - Route.Help -> - viewHelp kc - Route.DaemonInfo -> - viewDaemonInfo ws - Route.Tests -> - viewTests ws - Route.Main -> - viewMain ws - ] - ] - - -viewTabs :: KeyConfig KeyEvent -> State -> Widget n -viewTabs kc ws = - hBoxSpaced 1 - $ intersperse (subtle $ txt "-") - $ viewRouteTab kc ws <$> universe @Route - - -viewRouteTab :: KeyConfig KeyEvent -> State -> Route -> Widget n -viewRouteTab kc ws route = - style $ txt $ Route.name route <> keyBind - where - style = if route == currentRoute ws then id else subtle - showBinding = (" " <>) . ("[" <>) . (<> "]") . ppBinding - keyBind = maybe "" showBinding $ keybindForRoute kc route - - -viewDaemonInfo :: State -> Widget Viewports -viewDaemonInfo ws = - withBuildState ws (viewExpandedDaemonInfo . (.daemonInfo)) - - -viewTests :: State -> Widget Viewports -viewTests ws = - withBuildState ws (viewTestResultsPanel ws) - - -viewMain :: State -> Widget Viewports -viewMain ws = withBuildState ws (viewDefaultPanel ws.timeZone) - - -viewHelp :: KeyConfig KeyEvent -> Widget n -viewHelp kc = viewKeybindings kc handlers - where - handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher kc) - - -withBuildState :: State -> (BuildState -> Widget Viewports) -> Widget Viewports -withBuildState ws render = - case ws.buildState of - Waiting -> - txt "Waiting for build..." - Failure reason -> - txt $ "Error when contacting daemon: " <> reason - Success bs -> - render bs - - -viewAppHeader :: State -> Widget n -viewAppHeader ws = - ok - $ emphasis - $ txt - $ "Tricorder" - <> maybe - "" - (" - " <>) - (viewHeading ws) - - -viewHeading :: State -> Maybe Text -viewHeading ws = case currentRoute ws of - Route.Tests -> case ws.testFilter of - TestFilterAll -> Just "Tests" - TestFilterFailedOnly -> Just "Tests - Failed only" - Route.Help -> Just "Help" - Route.DaemonInfo -> Just "Daemon info" - Route.Main -> Nothing - - -viewDefaultPanel :: TimeZone -> BuildState -> Widget Viewports -viewDefaultPanel tz bs = viewBuildPhase tz bs.phase - - -viewTestResultsPanel :: State -> BuildState -> Widget Viewports -viewTestResultsPanel ws bs = - vBoxSpaced - 1 - [ viewBuildPhaseLine ws.timeZone bs.phase - , viewTestPanel ws.testFilter (phaseTestRuns bs.phase) - ] - - -viewExpandedDaemonInfo :: DaemonInfo -> Widget n -viewExpandedDaemonInfo di = - vBox - [ viewVersion - , viewTargets di.targets - , viewWatchDirs di.watchDirs - , viewSockPath di.sockPath - , viewLogFile di.logFile - , viewMetrics di.metricsPort - ] - - -viewVersion :: Widget n -viewVersion = - hBoxSpaced - 1 - [ emphasis $ txt "Client version:" - , txt Version.gitHash - ] - - -viewTargets :: [Target] -> Widget n -viewTargets targets = - hBoxSpaced - 1 - [ emphasis $ txt "Targets:" - , if null targets then - txt "(all)" - else - txtWrap (T.intercalate " " (map renderTarget targets)) - ] - - -viewMetrics :: Maybe Int -> Widget n -viewMetrics Nothing = - hBoxSpaced - 1 - [ emphasis $ txt "Metrics:" - , warn $ txt "disabled" - ] -viewMetrics (Just port) = - hBoxSpaced - 1 - [ emphasis $ txt "Metrics:" - , ok $ txt $ "http://localhost:" <> show port <> "/metrics" - ] - - -viewLogFile :: FilePath -> Widget n -viewLogFile p = hBoxSpaced 1 [emphasis $ txt "Log:", txt $ toText p] - - -viewSockPath :: FilePath -> Widget n -viewSockPath sockPath = - hBoxSpaced 1 [emphasis $ txt "Socket:", txt $ toText sockPath] - - -viewWatchDirs :: [FilePath] -> Widget n -viewWatchDirs watchDirs = - vBox - [ emphasis $ txt "Watching:" - , padLeft (Pad 2) - $ vBox - $ viewWatchDir <$> watchDirs - ] - - -viewWatchDir :: FilePath -> Widget n -viewWatchDir dir = hBox [txt "- ", txt $ toText displayDir] - where - displayDir - | isAbsolute dir = dir - | dir == "." = "./" - | otherwise = "./" <> dir - - -viewBuildPhase :: TimeZone -> BuildPhase -> Widget Viewports -viewBuildPhase tz = \case - Building Nothing -> warn $ txt "Building..." - Building (Just p) -> warn $ txt $ "Building (" <> show p.compiled <> "/" <> show p.total <> ")..." - Restarting -> warn $ txt "Restarting..." - Testing result -> vBoxSpaced 1 [viewBuildResult tz result, viewTestRuns result.testRuns] - Done result -> vBoxSpaced 1 [viewBuildResult tz result, viewTestRuns result.testRuns] - BuildFailed msg -> viewBuildFailed msg - - -viewBuildFailed :: Text -> Widget Viewports -viewBuildFailed msg = - vBox - [ err $ txt "Build command failed" - , vScrollViewport DiagnosticViewport (txtWrap <$> T.lines msg) - ] - - --- | A vertically-scrollable viewport with clickable scrollbars on the right. -vScrollViewport :: Viewports -> [Widget Viewports] -> Widget Viewports -vScrollViewport vp children = - withClickableVScrollBars (\_ _ -> vp) - $ withVScrollBarHandles - $ withVScrollBars OnRight - $ viewport vp Vertical - $ vBox children - - -viewBuildResult :: TimeZone -> BuildResult -> Widget Viewports -viewBuildResult tz result - | null result.diagnostics = - hBoxSpaced - 1 - [ ok $ txt "All good." - , viewBuildSummary result.moduleCount result.duration - , viewTimestamp tz result.completedAt - ] - | otherwise = - let msgs = result.diagnostics - errCount = length $ filter (\m -> m.severity == SError) msgs - warnCount = length $ filter (\m -> m.severity == SWarning) msgs - header = - if errCount > 0 then - err $ txt $ show errCount <> " error(s), " <> show warnCount <> " warning(s)" - else - warn $ txt $ show warnCount <> " warning(s)" - in vBoxSpaced - 1 - [ hBoxSpaced - 1 - [ header - , viewDuration result.duration - , viewTimestamp tz result.completedAt - ] - , vScrollViewport DiagnosticViewport (viewDiagnostic <$> msgs) - ] - - -viewDiagnostic :: Diagnostic -> Widget n -viewDiagnostic m = - vBox - [ hBoxSpaced - 1 - [ severityLabel - , txt $ toText loc - ] - , txtWrap m.text - ] - where - loc = m.file <> ":" <> show m.line <> ":" <> show m.col - severityLabel = withDefAttr (severityToAttrName m.severity) $ txt $ case m.severity of - SError -> "error:" - SWarning -> "warning:" - - -severityToAttrName :: Severity -> AttrName -severityToAttrName SError = attrName "error" -severityToAttrName SWarning = attrName "warning" - - -viewDuration :: Millisecond -> Widget n -viewDuration d = txt $ "(" <> formatDuration d <> ")" - - -viewTestRuns :: [TestRun] -> Widget n -viewTestRuns [] = emptyWidget -viewTestRuns runs = vBox $ viewTestRun <$> runs - - -viewTestRun :: TestRun -> Widget n -viewTestRun (TestRunning t Nothing) = hBox [txt t, txt " ", warn $ txt "running..."] -viewTestRun (TestRunning t (Just p)) = - hBox [txt t, txt " ", warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"] -viewTestRun (TestRunErrored e) = hBox [txt e.target, txt " ", err $ txt "error: ", txt e.message] -viewTestRun (TestRunCompleted c) = hBox [txt c.target, txt " ", viewCompletionStatus c] - - -viewCompletionStatus :: TestRunCompletion -> Widget n -viewCompletionStatus c = case c.duration of - Nothing -> statusWidget - Just d -> hBoxSpaced 1 [statusWidget, subtle $ viewDuration d] - where - statusWidget - | null c.testCases = if c.passed then ok (txt "passed") else err (txt "failed") - | otherwise = - let total = length c.testCases - failed = length $ filter isCaseFailed c.testCases - in if failed == 0 then - ok $ txt $ "passed (" <> show total <> ")" - else - err $ txt $ show failed <> "/" <> show total <> " failed" - - -viewTimestamp :: TimeZone -> UTCTime -> Widget n -viewTimestamp tz t = txt $ "— " <> toText (formatTime defaultTimeLocale "%H:%M:%S" $ utcToLocalTime tz t) - - -viewBuildSummary :: Int -> Millisecond -> Widget n -viewBuildSummary moduleCount duration = - txt $ "(" <> show moduleCount <> " modules, " <> formatDuration duration <> ")" - - -formatDuration :: Millisecond -> Text -formatDuration d = - let ms = toMicroseconds d `div` 1000 - in if ms < 1000 then - show ms <> "ms" - else - show (ms `div` 1000) <> "." <> show ((ms `mod` 1000) `div` 100) <> "s" - - --- | Single-line build status with no scrollable diagnostics list, used as a --- compact header when a secondary panel (test results, daemon info) is open. -viewBuildPhaseLine :: TimeZone -> BuildPhase -> Widget n -viewBuildPhaseLine tz = \case - Building Nothing -> warn $ txt "Building..." - Building (Just p) -> warn $ txt $ "Building (" <> show p.compiled <> "/" <> show p.total <> ")..." - Restarting -> warn $ txt "Restarting..." - Testing result -> viewBuildResultLine tz result - Done result -> viewBuildResultLine tz result - BuildFailed _ -> err $ txt "Build command failed" - - -viewBuildResultLine :: TimeZone -> BuildResult -> Widget n -viewBuildResultLine tz result - | null result.diagnostics = - hBoxSpaced - 1 - [ ok $ txt "All good." - , viewBuildSummary result.moduleCount result.duration - , viewTimestamp tz result.completedAt - ] - | otherwise = - let errCount = length $ filter (\m -> m.severity == SError) result.diagnostics - warnCount = length $ filter (\m -> m.severity == SWarning) result.diagnostics - header = - if errCount > 0 then - err $ txt $ show errCount <> " error(s), " <> show warnCount <> " warning(s)" - else - warn $ txt $ show warnCount <> " warning(s)" - in hBoxSpaced 1 [header, viewDuration result.duration, viewTimestamp tz result.completedAt] - - -phaseTestRuns :: BuildPhase -> [TestRun] -phaseTestRuns (Testing r) = r.testRuns -phaseTestRuns (Done r) = r.testRuns -phaseTestRuns _ = [] - - -viewTestPanel :: TestFilter -> [TestRun] -> Widget Viewports -viewTestPanel _ [] = subtle $ txt "No test results." -viewTestPanel tvf runs = scrollableRuns tvf runs - - -scrollableRuns :: TestFilter -> [TestRun] -> Widget Viewports -scrollableRuns tvf runs = - vScrollViewport TestViewport (viewTestRunDetail tvf <$> runs) - - -viewTestRunDetail :: TestFilter -> TestRun -> Widget n -viewTestRunDetail _ (TestRunning t Nothing) = hBox [txt t, txt " ", warn $ txt "running..."] -viewTestRunDetail _ (TestRunning t (Just p)) = - hBox [txt t, txt " ", warn $ txt $ "running... (" <> show p.compiled <> "/" <> show p.total <> ")"] -viewTestRunDetail _ (TestRunErrored e) = hBoxSpaced 1 [txt e.target, err $ txt "error:", txt e.message] -viewTestRunDetail tvf (TestRunCompleted c) = - vBox - [ hBox [txt c.target, txt " ", viewCompletionStatus c] - , viewTestOutput tvf c - ] - - -viewTestOutput :: TestFilter -> TestRunCompletion -> Widget n -viewTestOutput TestFilterAll c = - padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output) -viewTestOutput TestFilterFailedOnly c - | not (any isCaseFailed c.testCases) && c.passed = emptyWidget - | null c.testCases = - padLeft (Pad 2) - $ vBox - [ subtle $ txt "(unrecognised test runner — showing full output)" - , vBox $ txt <$> stripGhciNoise (T.lines c.output) - ] - | otherwise = - padLeft (Pad 2) $ vBox $ viewFailedCase <$> filter isCaseFailed c.testCases - - -isCaseFailed :: TestCase -> Bool -isCaseFailed (TestCase _ (TestCaseFailed _)) = True -isCaseFailed _ = False - - -viewFailedCase :: TestCase -> Widget n -viewFailedCase tc = - vBox - [ err $ txt tc.description - , case tc.outcome of - TestCaseFailed details -> padLeft (Pad 2) $ txtWrap details - TestCasePassed -> emptyWidget - ] diff --git a/src/Tricorder/Waiters.hs b/src/Tricorder/Waiters.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/Waiters.hs @@ -0,0 +1,49 @@ +module Tricorder.Waiters + ( Waiters (..) + , with + , without + , wait + , run + ) where + +import Effectful (Effect) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, retry) +import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift) +import Effectful.Exception (bracket_) +import Effectful.TH (makeEffect) + + +data Waiters :: Effect where + -- | Perform an action, signalling that there is a waiter inhabiting the + -- action. + With :: m a -> Waiters m a + -- | Perform an action only if there are no waiters. + Without :: m a -> Waiters m () + -- | Wait for there to be no waiters, then perform the passed action. + Wait :: m a -> Waiters m a + + +makeEffect ''Waiters + + +run :: (Concurrent :> es) => Eff (Waiters : es) a -> Eff es a +run act = do + waiters <- newTVarIO (0 :: Int) + interpretWith act \env -> \case + With m -> localSeqUnlift env \unlift -> do + bracket_ + (atomically $ modifyTVar' waiters (+ 1)) + (atomically $ modifyTVar' waiters (max 0 . subtract 1)) + $ unlift m + Without m -> localSeqUnlift env \unlift -> do + noWaiters <- atomically do + n <- readTVar waiters + pure (n <= 0) + when noWaiters do + void $ unlift m + Wait m -> localSeqUnlift env \unlift -> do + atomically do + n <- readTVar waiters + when (n > 0) retry + unlift m diff --git a/src/Tricorder/Watcher.hs b/src/Tricorder/Watcher.hs deleted file mode 100644 --- a/src/Tricorder/Watcher.hs +++ /dev/null @@ -1,178 +0,0 @@ -module Tricorder.Watcher - ( component - , WatchedFile (..) - , WatcherSession (..) - , isCabalFile - , makeWatches - , markWatchedFiles - ) where - -import Atelier.Component (Component (..), defaultComponent) -import Atelier.Effects.Chan (Chan) -import Atelier.Effects.Conc (Conc) -import Atelier.Effects.Debounce (Debounce) -import Atelier.Effects.FileWatcher - ( FileEvent - , FileWatcher - , Watch - , containing - , dirExt - , dirWhere - , excluding - , watchFilePathsDebounced - ) -import Atelier.Effects.Publishing (Pub, Sub, publish) -import Effectful.Concurrent (Concurrent) -import Effectful.Reader.Static (Reader, ask) -import System.FilePath (takeExtension, takeFileName) -import Text.Regex.TDFA (ExecOption (..), blankCompOpt, blankExecOpt, match) -import Text.Regex.TDFA.TDFA (patternToRegex) - -import Atelier.Effects.Publishing qualified as Sub - -import Tricorder.BuildState - ( CabalChangeDetected (..) - , ChangeKind (..) - , SourceChangeDetected (..) - ) -import Tricorder.Effects.BuildStore (BuildStore) -import Tricorder.Effects.SessionStore (SessionStore, SessionStoreReloaded) -import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Pattern, Session (..), WatchDirs (..), WatchExclusionPatterns (..)) - -import Tricorder.Effects.BuildStore qualified as BuildStore -import Tricorder.Effects.SessionStore qualified as SessionStore - - --- | Watcher component. --- Watches source files and cabal-related files for changes, setting the dirty --- flag in 'BuildStore'. 'GhciSession' polls this flag and triggers a rebuild --- or session restart accordingly. -component - :: ( BuildStore :> es - , Chan :> es - , Conc :> es - , Concurrent :> es - , Debounce FilePath :> es - , FileWatcher :> es - , Pub CabalChangeDetected :> es - , Pub SourceChangeDetected :> es - , Pub WatchedFile :> es - , Reader ProjectRoot :> es - , SessionStore :> es - , Sub SessionStoreReloaded :> es - , Sub WatchedFile :> es - ) - => Component es -component = - defaultComponent - { name = "Watcher" - , triggers = pure [watchFiles] - , listeners = pure [Sub.listen_ markWatchedFiles] - } - - -markWatchedFiles - :: ( BuildStore :> es - , Pub CabalChangeDetected :> es - , Pub SourceChangeDetected :> es - ) - => WatchedFile -> Eff es () -markWatchedFiles f = do - BuildStore.markDirty change - case change of - CabalChange -> publish (CabalChangeDetected f.path f.event) - SourceChange -> publish (SourceChangeDetected f.path f.event) - where - change = changeKindFor f.path - - -data WatchedFile = WatchedFile - { path :: FilePath - , event :: FileEvent - } - - -data WatcherSession = WatcherSession - { watchDirs :: WatchDirs - , watchExclusionPatterns :: WatchExclusionPatterns - } - deriving stock (Eq) - - -withWatcherSession - :: ( Chan :> es - , Conc :> es - , Concurrent :> es - , SessionStore :> es - , Sub SessionStoreReloaded :> es - ) - => Session - -> (SessionStore.Reloader es -> WatcherSession -> Eff es Void) - -> Eff es Void -withWatcherSession = - SessionStore.withSubSession $ \session -> - WatcherSession - { watchDirs = session.watchDirs - , watchExclusionPatterns = session.watchExclusionPatterns - } - - -watchFiles - :: ( Chan :> es - , Conc :> es - , Concurrent :> es - , Debounce FilePath :> es - , FileWatcher :> es - , Pub WatchedFile :> es - , Reader ProjectRoot :> es - , SessionStore :> es - , Sub SessionStoreReloaded :> es - ) - => Eff es Void -watchFiles = do - initialSession <- SessionStore.get - withWatcherSession initialSession $ \_ session -> do - projectRoot <- ask - let watches = makeWatches projectRoot session - watchFilePathsDebounced watches \filePath fileEvent -> publish (WatchedFile filePath fileEvent) - - -makeWatches :: ProjectRoot -> WatcherSession -> [Watch] -makeWatches projectRoot session = - sourceWatches (coerce session.watchExclusionPatterns) (coerce session.watchDirs) - <> cabalWatches projectRoot - - -sourceWatches :: [Pattern] -> [FilePath] -> [Watch] -sourceWatches exclusionPatterns = - map \d -> - dirExt d ".hs" - `excluding` containing "dist-newstyle" - `excluding` exclusionMatches exclusionPatterns - - -exclusionMatches :: [Pattern] -> FilePath -> Bool -exclusionMatches exclusionPatterns fp = any matchPattern exclusionPatterns - where - matchPattern p = - match - (patternToRegex p blankCompOpt blankExecOpt {captureGroups = False}) - fp - - -cabalWatches :: ProjectRoot -> [Watch] -cabalWatches (ProjectRoot projectRoot) = - [dirWhere projectRoot isCabalFile `excluding` containing "dist-newstyle"] - - -isCabalFile :: FilePath -> Bool -isCabalFile f = - takeExtension f == ".cabal" - || takeFileName f `elem` ["cabal.project", "package.yaml"] - - -changeKindFor :: FilePath -> ChangeKind -changeKindFor path - | isCabalFile path = CabalChange - | otherwise = SourceChange diff --git a/test/Unit/Tricorder/Build/EvalCommentSpec.hs b/test/Unit/Tricorder/Build/EvalCommentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Build/EvalCommentSpec.hs @@ -0,0 +1,177 @@ +module Unit.Tricorder.Build.EvalCommentSpec (spec_EvalComment) where + +import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy) +import Text.Megaparsec (parse) + +import Tricorder.Build.EvalComment qualified as Eval + + +spec_EvalComment :: Spec +spec_EvalComment = do + describe "singleLineEvalCommentP" testSingleLine + describe "multiLineEvalCommentP" testMultiLine + describe "blockCommentEvalP" testBlockComment + describe "findComments" testFindComments + + +-------------------------------------------------------------------------------- +-- singleLineEvalCommentP +-------------------------------------------------------------------------------- + +testSingleLine :: Spec +testSingleLine = do + it "parses a basic expression" do + parse Eval.singleLineEvalCommentP "" "-- $> 1 + 2" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "1 + 2"} + + it "handles no space between marker and expression" do + parse Eval.singleLineEvalCommentP "" "-- $>expr" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"} + + it "strips leading whitespace from the expression" do + parse Eval.singleLineEvalCommentP "" "-- $> expr" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"} + + it "captures the full expression including inner spaces" do + parse Eval.singleLineEvalCommentP "" "-- $> foo bar baz" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "foo bar baz"} + + it "stops at a newline, not consuming it" do + parse Eval.singleLineEvalCommentP "" "-- $> expr\nnext line" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"} + + it "fails when there is no expression after the marker" do + parse Eval.singleLineEvalCommentP "" "-- $>" `shouldSatisfy` isLeft + + it "fails on the multi-line opening marker" do + parse Eval.singleLineEvalCommentP "" "-- $$> expr -- <$$" `shouldSatisfy` isLeft + + it "fails on other text between comment start and eval marker" do + parse Eval.singleLineEvalCommentP "" "-- foo $> 1 + 2" `shouldSatisfy` isLeft + + it "fails on unrelated text" do + parse Eval.singleLineEvalCommentP "" "hello world" `shouldSatisfy` isLeft + + +-------------------------------------------------------------------------------- +-- multiLineEvalCommentP +-------------------------------------------------------------------------------- + +testMultiLine :: Spec +testMultiLine = do + it "parses a single content line, stripping the -- prefix" do + parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr\n-- <$$" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"} + + it "parses multiple content lines, stripping -- prefixes" do + parse Eval.multiLineEvalCommentP "" "-- $$>\n-- foo\n-- bar\n-- <$$" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "foo\nbar"} + + it "preserves relative indentation after stripping -- prefix" do + parse Eval.multiLineEvalCommentP "" "-- $$>\n-- let x = 1\n-- y = 2\n-- in x + y\n-- <$$" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n y = 2\nin x + y"} + + it "handles -- with no trailing space" do + parse Eval.multiLineEvalCommentP "" "-- $$>\n--expr\n-- <$$" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"} + + it "parse multi-line eval comment in a single line" do + parse Eval.multiLineEvalCommentP "" "-- $$> expr <$$" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"} + + it "fails when the closing marker is absent" do + parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr" `shouldSatisfy` isLeft + + it "fails on the single-line marker" do + parse Eval.multiLineEvalCommentP "" "-- $> expr" `shouldSatisfy` isLeft + + it "fails on unrelated text" do + parse Eval.multiLineEvalCommentP "" "hello world" `shouldSatisfy` isLeft + + +-------------------------------------------------------------------------------- +-- blockCommentEvalP +-------------------------------------------------------------------------------- + +testBlockComment :: Spec +testBlockComment = do + it "parses a single-line expression on its own line" do + parse Eval.blockCommentEvalP "" "{- $$>\n2 + 2\n<$$ -}" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "2 + 2"} + + it "parses an inline one-liner" do + parse Eval.blockCommentEvalP "" "{- $$> 2 + 2 <$$ -}" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "2 + 2"} + + it "parses a multi-line expression preserving layout" do + parse Eval.blockCommentEvalP "" "{- $$>\nlet x = 1\n y = 2\nin x + y\n<$$ -}" + `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n y = 2\nin x + y"} + + it "fails when the closing marker is absent" do + parse Eval.blockCommentEvalP "" "{- $$>\nexpr" `shouldSatisfy` isLeft + + it "fails on the line-comment multi-line eval marker" do + parse Eval.blockCommentEvalP "" "-- $$> expr" `shouldSatisfy` isLeft + + it "fails on the single-line eval marker" do + parse Eval.blockCommentEvalP "" "{- $> expr -}" `shouldSatisfy` isLeft + + it "fails on unrelated text" do + parse Eval.blockCommentEvalP "" "hello world" `shouldSatisfy` isLeft + + +-------------------------------------------------------------------------------- +-- findComments +-------------------------------------------------------------------------------- + +testFindComments :: Spec +testFindComments = do + it "returns empty list for empty text" do + Eval.findComments "" `shouldMatchList` [] + + it "returns empty list when there are no eval comments" do + Eval.findComments "hello world\nno comments here" `shouldMatchList` [] + + it "finds a single single-line eval comment" do + Eval.findComments "x = 1\n-- $> x\ny = 2" + `shouldMatchList` [Eval.Comment {lineNumber = 2, expression = "x"}] + + it "finds multiple single-line eval comments in source order" do + Eval.findComments "-- $> a\n-- $> b" + `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"} + , Eval.Comment {lineNumber = 2, expression = "b"} + ] + + it "reports correct line numbers" do + Eval.findComments "line1\nline2\n-- $> expr\nline4" + `shouldMatchList` [Eval.Comment {lineNumber = 3, expression = "expr"}] + + it "ignores lines that look like partial markers" do + Eval.findComments "-- $\n-- $> expr" + `shouldMatchList` [Eval.Comment {lineNumber = 2, expression = "expr"}] + + it "does not match an eval marker embedded in another comment" do + Eval.findComments "-- foo -- $> expr" `shouldMatchList` [] + + it "does not match an inline eval marker appearing after code" do + Eval.findComments "x = 1 -- $> x" `shouldMatchList` [] + + it "finds a multi-line eval comment, stripping -- prefixes" do + Eval.findComments "-- $$>\n-- expr\n-- <$$" + `shouldMatchList` [Eval.Comment {lineNumber = 1, expression = "expr"}] + + it "finds a block comment eval" do + Eval.findComments "{- $$>\nexpr\n<$$ -}" + `shouldMatchList` [Eval.Comment {lineNumber = 1, expression = "expr"}] + + it "finds both single-line and multi-line eval comments" do + Eval.findComments "-- $> a\n-- $$>\n-- b\n-- <$$" + `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"} + , Eval.Comment {lineNumber = 2, expression = "b"} + ] + + it "finds both single-line and block comment eval comments" do + Eval.findComments "-- $> a\n{- $$>\nb\n<$$ -}" + `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"} + , Eval.Comment {lineNumber = 2, expression = "b"} + ] diff --git a/test/Unit/Tricorder/BuildStateSpec.hs b/test/Unit/Tricorder/BuildStateSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/BuildStateSpec.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Unit.Tricorder.BuildStateSpec (spec_BuildState) where - -import Data.Aeson (eitherDecode, encode) -import Data.Time (UTCTime (..), fromGregorian) -import Test.Hspec - -import Tricorder.BuildState (BuildId (..), BuildPhase (..), BuildResult (..), BuildState (..), DaemonInfo (..), Diagnostic (..), Severity (..)) - - -spec_BuildState :: Spec -spec_BuildState = do - describe "JSON round-trip" do - it "survives Unicode smart quotes in message text" do - let msg = - Diagnostic - { severity = SWarning - , file = "" - , 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 deleted file mode 100644 --- a/test/Unit/Tricorder/BuildStoreSpec.hs +++ /dev/null @@ -1,184 +0,0 @@ -module Unit.Tricorder.BuildStoreSpec (spec_BuildStore) where - -import Atelier.Effects.Conc (Conc, runConc) -import Atelier.Effects.Delay (Delay, runDelay) -import Atelier.Effects.Input (Input, runInputConst) -import Control.Concurrent (threadDelay) -import Data.Time (UTCTime (..), fromGregorian) -import Effectful (IOE, runEff, runPureEff) -import Effectful.Concurrent (Concurrent, runConcurrent) -import Test.Hspec - -import Atelier.Effects.Conc qualified as Conc - -import Tricorder.BuildState (BuildId (..), BuildPhase (..), BuildResult (..), BuildState (..), DaemonInfo (..)) -import Tricorder.Effects.BuildStore - ( BuildStore - , getState - , runBuildStore - , runBuildStoreScripted - , setPhase - , waitForNext - , waitUntilDone - ) - - -spec_BuildStore :: Spec -spec_BuildStore = do - describe "runBuildStoreScripted" testScripted - describe "runBuildStoreSTM" testSTM - - --------------------------------------------------------------------------------- --- Scripted interpreter tests (pure, no IO) --------------------------------------------------------------------------------- - -testScripted :: Spec -testScripted = do - describe "getState" do - it "returns the head of the state list" do - let result = runScripted [buildingAt 0, doneAt 1] getState - result.buildId `shouldBe` BuildId 0 - - it "does not consume the state" do - let result = runScripted [doneAt 1] do - _ <- getState - getState - result.buildId `shouldBe` BuildId 1 - - describe "waitUntilDone" do - it "returns immediately when head is already Done" do - let result = runScripted [doneAt 1, doneAt 2] waitUntilDone - result.buildId `shouldBe` BuildId 1 - - it "skips Building states and returns the first Done" do - let result = runScripted [buildingAt 0, buildingAt 0, doneAt 1] waitUntilDone - result.buildId `shouldBe` BuildId 1 - - it "consumes states up to and including the matched Done" do - let result = runScripted [buildingAt 0, doneAt 1, doneAt 2] do - _ <- waitUntilDone - waitUntilDone - result.buildId `shouldBe` BuildId 2 - - describe "waitForNext" do - it "skips states with the same buildId" do - let result = runScripted [doneAt 1, doneAt 2] (waitForNext (BuildId 1)) - result.buildId `shouldBe` BuildId 2 - - it "skips Building states regardless of buildId" do - let result = runScripted [buildingAt 2, doneAt 2] (waitForNext (BuildId 1)) - result.buildId `shouldBe` BuildId 2 - - it "skips Building and same-id Done before returning next Done" do - let states = [buildingAt 1, doneAt 1, buildingAt 2, doneAt 2] - let result = runScripted states (waitForNext (BuildId 1)) - result.buildId `shouldBe` BuildId 2 - - --------------------------------------------------------------------------------- --- STM interpreter tests (concurrent) --------------------------------------------------------------------------------- - -testSTM :: Spec -testSTM = do - describe "getState" do - it "returns the initial Building state" do - result <- runStm getState - result `shouldBe` buildingAt 0 - - describe "setPhase / getState" do - it "reflects a written state" do - result <- runStm do - setPhase (BuildId 1) donePhase - getState - result `shouldBe` doneAt 1 - - describe "waitUntilDone" do - it "returns immediately when state is already Done" do - result <- runStm do - setPhase (BuildId 1) donePhase - waitUntilDone - result.buildId `shouldBe` BuildId 1 - - it "blocks until a Done phase is set from another thread" do - result <- runStmConc do - void $ Conc.fork do - liftIO (threadDelay 10_000) - setPhase (BuildId 1) donePhase - waitUntilDone - result.buildId `shouldBe` BuildId 1 - - describe "waitForNext" do - it "blocks until a Done state with a different buildId appears" do - result <- runStmConc do - setPhase (BuildId 1) donePhase - void $ Conc.fork do - liftIO (threadDelay 10_000) - setPhase (BuildId 2) donePhase - waitForNext (BuildId 1) - result.buildId `shouldBe` BuildId 2 - - -- Regression for the bug behind the user's "status --wait waits until - -- the LAST cycle finishes" report: a polling-based 'waitUntilDone' - -- could miss a transient 'Done' state if the next 'Building' phase - -- overwrote the TVar within the poll interval, and an STM-retry - -- version still races against the scheduler's wake-up latency. The - -- broadcast 'TChan' of transitions makes every phase change a - -- discrete message that can't be overwritten — so even if - -- 'setPhase Done >> setPhase Building' happens back-to-back, the - -- waiter observes the Done. - describe "atomic transition capture" do - it "observes a transient Done even if Building immediately follows" do - result <- runStmConc do - setPhase (BuildId 1) (Building Nothing) - -- The publisher thread fires Done and then immediately - -- overwrites it with Building (N+1), the exact pattern the - -- coalescing worker produces between two queued cycles. - void $ Conc.fork do - liftIO (threadDelay 5_000) - setPhase (BuildId 1) donePhase - setPhase (BuildId 2) (Building Nothing) - waitUntilDone - -- The waiter must report Done(1), NOT skip past it and report - -- the later Done(2) (or block forever). - result.buildId `shouldBe` BuildId 1 - case result.phase of - Done _ -> pure () - p -> expectationFailure $ "expected Done phase, got: " <> show p - - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -emptyDaemonInfo :: DaemonInfo -emptyDaemonInfo = DaemonInfo {targets = [], watchDirs = [], sockPath = "", logFile = "", metricsPort = Nothing} - - -buildingAt :: Int -> BuildState -buildingAt n = BuildState (BuildId n) (Building Nothing) emptyDaemonInfo - - -donePhase :: BuildPhase -donePhase = Done (BuildResult {completedAt = epoch, duration = 0, moduleCount = 0, diagnostics = [], testRuns = []}) - - -doneAt :: Int -> BuildState -doneAt n = BuildState (BuildId n) donePhase emptyDaemonInfo - - -epoch :: UTCTime -epoch = UTCTime (fromGregorian 1970 1 1) 0 - - -runScripted :: [BuildState] -> Eff '[BuildStore] a -> a -runScripted states = runPureEff . runBuildStoreScripted states - - -runStm :: Eff '[BuildStore, Input DaemonInfo, Delay, Concurrent, IOE] a -> IO a -runStm = runEff . runConcurrent . runDelay . runInputConst emptyDaemonInfo . runBuildStore - - -runStmConc :: Eff '[Conc, BuildStore, Input DaemonInfo, Delay, Concurrent, IOE] a -> IO a -runStmConc = runEff . runConcurrent . runDelay . runInputConst emptyDaemonInfo . runBuildStore . runConc diff --git a/test/Unit/Tricorder/BuilderSpec.hs b/test/Unit/Tricorder/BuilderSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/BuilderSpec.hs +++ /dev/null @@ -1,1204 +0,0 @@ -module Unit.Tricorder.BuilderSpec (spec_Builder) where - -import Atelier.Effects.Chan (runChan) -import Atelier.Effects.Clock (runClockConst) -import Atelier.Effects.Conc (runConc) -import Atelier.Effects.Debounce (debounced, runDebounce, runDebounceNoOp) -import Atelier.Effects.Delay (runDelay) -import Atelier.Effects.FileWatcher (FileEvent (..)) -import Atelier.Effects.Input (runInputConst) -import Atelier.Effects.Log (runLogNoOp) -import Atelier.Effects.Monitoring.Tracing (runTracingNoOp) -import Atelier.Effects.Publishing (listen_, publish, runPubSub) -import Atelier.Time (Millisecond) -import Control.Concurrent.STM (modifyTVar', newTVarIO, readTVar, retry, writeTVar) -import Control.Exception (ErrorCall (..)) -import Data.Default (def) -import Data.Time (UTCTime (..), addUTCTime, fromGregorian) -import Effectful (runEff, runPureEff) -import Effectful.Concurrent (Concurrent, runConcurrent) -import Effectful.Concurrent.STM (atomically) -import Effectful.Dispatch.Dynamic (interpret_) -import Effectful.Error.Static (runErrorNoCallStack, throwError) -import Effectful.Exception (throwIO) -import Effectful.Reader.Static (runReader) -import Effectful.State.Static.Shared (evalState, runState) -import Effectful.Writer.Static.Shared (Writer, execWriter, tell) -import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy) - -import Atelier.Effects.Conc qualified as Conc -import Atelier.Effects.Delay qualified as Delay -import Control.Concurrent.STM qualified as STM -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set - -import Tricorder.BuildState - ( BuildId (..) - , BuildPhase (..) - , BuildResult (..) - , BuildState (..) - , CabalChangeDetected (..) - , DaemonInfo (..) - , Diagnostic (..) - , Severity (..) - , SourceChangeDetected (..) - , TestRun (..) - , TestRunCompletion (..) - ) -import Tricorder.Builder - ( BuildConfig (..) - , EnteringNewPhase (..) - , NewLoadResult (..) - , compileLoadResultsIntoBuildResults - , onRestart - , reloadOnSourceChange - , requestTestRunsForNewBuildResults - , setNewPhase - ) -import Tricorder.Builder.Dispatch - ( BuilderState (..) - , KnownTargetNames (..) - , emptyBuilderState - , fileMatchesAnyTarget - , filterToWatchDirs - , mergeDiagnostics - , preserveFailureVisibility - ) -import Tricorder.Effects.GhciSession (Controls (..), LoadResult (..), LoadedModule (..), runGhciSessionScripted) -import Tricorder.Effects.GhciSession.GhciParser (collectResult, extractTitle, resolveKnownTargets) -import Tricorder.Effects.TestRunner (TestRunner (..), runTestRunnerScripted) -import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Command (..), WatchDirs (..), parseTestTargets) - -import Tricorder.BuildState qualified as BuildState -import Tricorder.Builder qualified as Builder -import Tricorder.Effects.BuildStore qualified as BuildStore - - -spec_Builder :: Spec -spec_Builder = do - describe "mergeDiagnostics" testMergeDiagnostics - describe "filterToWatchDirs" testFilterToWatchDirs - describe "extractTitle" testExtractTitle - describe "compileLoadResultsIntoBuildResults" testCompileLoadResultsIntoBuildResults - describe "requestTestRunsForNewBuildResults" testRequestTestRunsForNewBuildResults - describe "setNewPhase" testSetNewPhase - describe "onRestart" testOnRestart - describe "restartOnCabalChange" testRestartOnCabalChange - describe "buildWithGhciOnChange (startup-failure recovery)" testBuildWithGhciRecovery - describe "reloadOnSourceChange" testReloadOnSourceChange - describe "watchSourceChanges (event coalescing)" testEventCoalescing - describe "interruptCurrent" testInterruptCurrent - describe "resolveKnownTargets" testResolveKnownTargets - describe "fileMatchesAnyTarget" testFileMatchesAnyTarget - - -testOnRestart :: Spec -testOnRestart = do - it "transitions BuildStore to the Building phase" do - (st, _) <- runTest - st.phase `shouldBe` Building Nothing - - it "should increment the build ID" do - (_, buildId) <- runTest - buildId `shouldBe` BuildId 2 - where - runTest = - runEff - . runConcurrent - . runDelay - . runLogNoOp - . runInputConst emptyDaemonInfo - . BuildStore.runBuildStore - . runState (BuildId 1) - $ do - onRestart - BuildStore.getState - - -testRestartOnCabalChange :: Spec -testRestartOnCabalChange = do - it "restarts the supervised action when CabalChangeDetected is published" do - countVar <- newTVarIO @Int 0 - - runTest do - Conc.scoped do - _ <- - Conc.fork - $ Builder.restartOnCabalChange - (pure ()) - (pure ()) - ( \_ -> do - atomically (modifyTVar' countVar (+ 1)) - -- Block forever; we want to verify the action is - -- cancelled and re-entered, not that it returns. - forever (Delay.wait (10 :: Millisecond)) - ) - Delay.wait (20 :: Millisecond) -- let the first iteration land - publish (CabalChangeDetected "foo.cabal" Modified) - Delay.wait (50 :: Millisecond) -- let the restart land - finalCount <- STM.atomically (readTVar countVar) - finalCount `shouldBe` 2 - where - runTest = - runEff - . runConcurrent - . runTracingNoOp - . runClockConst epoch - . runChan - . runDelay - . runLogNoOp - . runPubSub @CabalChangeDetected - . runConc - - --- | Regression for the startup-failure dead-end: when the build command --- fails to start, 'buildWithGhciOnChange' must surface 'BuildFailed' and then --- stay able to retry once a source file changes. The original code parked on --- 'atomically retry' after 'BuildFailed', so it could only ever recover via a --- *cabal* change (runBuilder cancelling its scope) — a source edit that --- fixed the underlying problem was ignored and the daemon stayed stuck. -testBuildWithGhciRecovery :: Spec -testBuildWithGhciRecovery = do - it "retries the build on a source change after a startup failure" do - phases <- - runTest - -- First launch throws (startup failure); the retry succeeds. - [ Left (toException (ErrorCall "ghci failed to start")) - , Right successLoad - ] - do - Conc.scoped do - Conc.fork_ (Builder.buildWithGhciOnChange (def @BuildConfig)) - Delay.wait (40 :: Millisecond) -- let the first launch fail + subscribe - publish (SourceChangeDetected "/abs/path/Foo.hs" Modified) - Delay.wait (60 :: Millisecond) -- let the retry land - -- The failed launch reports BuildFailed exactly once. - length [() | EnteringNewPhase _ (BuildFailed _) <- phases] `shouldBe` 1 - -- The source change drove a second, successful launch to completion. - -- With the bug the builder is parked, so no Done is ever emitted. - length [() | EnteringNewPhase _ (Done _) <- phases] `shouldSatisfy` (>= 1) - where - successLoad = - LoadResult - { moduleCount = 1 - , compiledFiles = Set.empty - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - - runTest script body = - runEff - . runConcurrent - . runTracingNoOp - . runClockConst epoch - . runChan - . runDelay - . runReader (ProjectRoot "/") - . evalState (BuildId 1) - . evalState emptyBuilderState - . runLogNoOp - . execWriter @[EnteringNewPhase] - . runBuildStoreCapture - . runTestRunnerScripted [] - . runGhciSessionScripted script - . runPubSub @SourceChangeDetected - . runConc - . runDebounceNoOp - $ body - - --------------------------------------------------------------------------------- --- Effect stack for integration tests --------------------------------------------------------------------------------- - -data StopSignal = StopSignal - deriving stock (Show) - - -testReloadOnSourceChange :: Spec -testReloadOnSourceChange = do - describe "Modified" do - describe "when the file is loaded in GHCi" do - it "transitions through Building then Done" do - phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Modified) - phases `shouldBe` flow reloadLr - - it "calls controls.reload" do - phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Modified) - buildResultsFrom phases `shouldMatchList` [resultFor reloadLr] - - describe "when the file is not loaded in GHCi" do - it "calls controls.add (the editor just wrote a new file)" do - phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/New.hs" Modified) - buildResultsFrom phases `shouldMatchList` [resultFor addLr] - - -- Regression test for stale-diagnostics bug: cold-start with a - -- pre-existing error then fix it. Foo is in :show targets but - -- not :show modules, so dispatch must consult KnownTargetNames to - -- avoid issuing a no-op :add. - describe "when the file is a known target that failed on initial load" do - it "calls controls.reload, not controls.add" do - phases <- - runTest - Map.empty - (KnownTargetNames (Set.singleton "Foo")) - distinctCtrls - (SourceChangeDetected "/abs/src/Foo.hs" Modified) - buildResultsFrom phases `shouldMatchList` [resultFor reloadLr] - - -- A failed executable 'Main' appears in :show targets only as its - -- path ("app/Main.hs", since the name 'Main' is ambiguous across home - -- units), so dispatch must match that path form to Reload, not :add. - describe "when the file is a path-shaped target that failed on initial load" do - it "calls controls.reload, not controls.add" do - phases <- - runTest - Map.empty - (KnownTargetNames (Set.singleton "app/Main.hs")) - distinctCtrls - (SourceChangeDetected "/abs/app/Main.hs" Modified) - buildResultsFrom phases `shouldMatchList` [resultFor reloadLr] - - describe "Added" do - describe "when the file is not loaded" $ it "calls controls.add" do - phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Added) - buildResultsFrom phases `shouldMatchList` [resultFor addLr] - - describe "when the file is already loaded" $ it "calls controls.reload (re-add is a reload)" do - phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Added) - buildResultsFrom phases `shouldMatchList` [resultFor reloadLr] - - describe "Removed" do - describe "when the file is loaded" $ it "calls controls.unadd" do - phases <- runTest knownFoo noTargets distinctCtrls (SourceChangeDetected "/abs/path/Foo.hs" Removed) - buildResultsFrom phases `shouldMatchList` [resultFor unaddLr] - - describe "when the file is not loaded" $ it "is a no-op" do - phases <- runTest Map.empty noTargets distinctCtrls (SourceChangeDetected "/abs/path/Unknown.hs" Removed) - phases `shouldBe` [] - - describe "when the reload throws (e.g. interrupted mid-flight)" do - it "resolves to BuildFailed instead of stranding the UI in Building" do - phases <- runTest knownFoo noTargets throwingCtrls (SourceChangeDetected "/abs/path/Foo.hs" Modified) - -- Regression: a reload that errors must resolve the build, not - -- leave 'Building' as the terminal phase (the daemon would be - -- stuck until the next change happened to succeed). - viaNonEmpty last [p | EnteringNewPhase _ p <- phases] - `shouldSatisfy` \case - Just (BuildFailed _) -> True - _ -> False - where - runTest initialModuleMap initialTargets ctrls event = - runEff - . runConcurrent - . runClockConst epoch - . runReader (ProjectRoot "/") - . evalState (BuildId 1) - . evalState - emptyBuilderState - { loadedModules = initialModuleMap - , knownTargets = initialTargets - } - . runLogNoOp - . execWriter @[EnteringNewPhase] - . runBuildStoreCapture - . runTestRunnerScripted [] - $ reloadOnSourceChange (def @BuildConfig) ctrls event - - flow lr = - [ EnteringNewPhase (BuildId 1) (Building Nothing) - , EnteringNewPhase (BuildId 1) (Done (resultFor lr)) - ] - - buildResultsFrom phases = [r | EnteringNewPhase _ (Done r) <- phases] - - resultFor lr = - BuildResult - { completedAt = epoch - , duration = 0 - , moduleCount = lr.moduleCount - , diagnostics = [] - , testRuns = [] - } - - noTargets = KnownTargetNames Set.empty - - distinctCtrls = - Controls - { reload = pure reloadLr - , interrupt = pure () - , add = \_ -> pure addLr - , unadd = \_ -> pure unaddLr - } - - -- A reload that throws, as if SIGINT'd by a second rapid source change. - throwingCtrls = distinctCtrls {reload = throwIO (ErrorCall "reload interrupted")} - - knownFoo = - Map.fromList - [ - ( "/abs/path/Foo.hs" - , LoadedModule {relPath = "./src/Foo.hs", moduleName = "MyModule"} - ) - ] - - -- Distinct LoadResults so tests can identify which control was invoked. - mkLr :: Int -> LoadResult - mkLr n = - LoadResult - { moduleCount = n - , compiledFiles = Set.singleton errMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - reloadLr = mkLr 10 - addLr = mkLr 20 - unaddLr = mkLr 30 - - -testSetNewPhase :: Spec -testSetNewPhase = do - it "should set build phase" do - state <- runEff - . runConcurrent - . runDelay - . runInputConst emptyDaemonInfo - . BuildStore.runBuildStore - $ do - setNewPhase $ EnteringNewPhase (BuildId 1) (Building Nothing) - BuildStore.getState - state - `shouldBe` BuildState - { buildId = BuildId 1 - , phase = Building Nothing - , daemonInfo = emptyDaemonInfo - } - - -testCompileLoadResultsIntoBuildResults :: Spec -testCompileLoadResultsIntoBuildResults = do - it "uses NewLoadResult's times to calculate duration" do - let (_, r) = - runTest - mempty - NewLoadResult - { startTime = addUTCTime 10 epoch - , endTime = addUTCTime 20 epoch - , loadResult = - LoadResult - { moduleCount = 2 - , compiledFiles = Set.singleton errMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - } - r.duration `shouldBe` 10_000 - it "merges with existing results" do - let (m, _) = - runTest (Map.fromList [(errMsg.file, [errMsg])]) - $ NewLoadResult - { startTime = epoch - , endTime = epoch - , loadResult = - LoadResult - { moduleCount = 2 - , compiledFiles = Set.singleton warnMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [warnMsg] - } - } - m - `shouldBe` fromList - [ (warnMsg.file, [warnMsg]) - , (errMsg.file, [errMsg]) - ] - - it "returns a BuildResult" do - let (_, r) = - runTest mempty - $ NewLoadResult - { startTime = epoch - , endTime = addUTCTime 10 epoch - , loadResult = - LoadResult - { moduleCount = 2 - , compiledFiles = Set.singleton warnMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [warnMsg] - } - } - expected = - BuildResult - { completedAt = addUTCTime 10 epoch - , duration = 10_000 - , moduleCount = 2 - , diagnostics = [warnMsg] - , testRuns = [] - } - r `shouldBe` expected - where - runTest acc nlr = - let (buildResult, builderState) = - runPureEff - . runReader (ProjectRoot "/") - . runState (emptyBuilderState {diagnosticMap = acc}) - $ compileLoadResultsIntoBuildResults (def {Builder.watchDirs = WatchDirs ["/src"]}) nlr - in (builderState.diagnosticMap, buildResult) - - -testRequestTestRunsForNewBuildResults :: Spec -testRequestTestRunsForNewBuildResults = do - describe "when there are no test targets" $ it "should skip testing" do - phases <- runTest (parseTestTargets []) [] expected - length phases `shouldBe` 1 - phases `shouldMatchList` [EnteringNewPhase (BuildId 1) $ Done expected] - - describe "when there are errors" $ it "should skip testing" do - let expected' = expected {BuildState.diagnostics = [errMsg]} - phases <- runTest (parseTestTargets ["test:foo"]) [] expected' - length phases `shouldBe` 1 - phases `shouldMatchList` [EnteringNewPhase (BuildId 1) $ Done expected'] - - it "should emit EnteringNewPhase events for each test target" do - phases <- - runTest - (parseTestTargets ["test:foo", "test:bar"]) - [ Right $ mkTestRun "test:foo" - , Right $ mkTestRun "test:bar" - ] - expected - length phases `shouldBe` 4 - let expectedPhases = - [ mkTesting . buildWithTests - $ [ TestRunning "test:foo" Nothing - , TestRunning "test:bar" Nothing - ] - , mkTesting . buildWithTests - $ [ mkTestRun "test:foo" - , TestRunning "test:bar" Nothing - ] - , mkTesting . buildWithTests - $ [ mkTestRun "test:foo" - , mkTestRun "test:bar" - ] - , mkDone . buildWithTests - $ [ mkTestRun "test:foo" - , mkTestRun "test:bar" - ] - ] - phases `shouldMatchList` expectedPhases - - -- Regression for the abort handling in 'runTestsIfClean': when an - -- interrupt arrives mid-run loop, 'isAborted' becomes True and the loop - -- returns 'Nothing'. The caller MUST then skip the 'Done' transition — - -- otherwise the BuildStore briefly publishes a Done with a partial - -- testRuns list, and a 'status --wait' caller reads that stale result - -- before the new cycle starts. - it "does not transition to Done when the run is aborted mid-flight" do - phases <- - runEff - . runConcurrent - . runLogNoOp - . evalState (BuildId 1) - . execWriter @[EnteringNewPhase] - . runBuildStoreCapture - . runTestRunnerAbortAfterFirst (mkTestRun "test:foo") - $ requestTestRunsForNewBuildResults - BuildConfig - { command = Command "" - , targets = [] - , testTargets = parseTestTargets ["test:foo", "test:bar"] - , watchDirs = WatchDirs [] - } - expected - -- The critical assertion: no Done phase, because the run was - -- aborted before completing the second suite. A Done here would - -- briefly publish a half-finished testRuns list that a - -- 'status --wait' caller could observe. - length [() | EnteringNewPhase _ (Done _) <- phases] `shouldBe` 0 - -- Sanity: only the initial Testing transition was published; the - -- run loop short-circuited after the first 'isAborted' check, so - -- the post-foo Testing update never fired. - length phases `shouldBe` 1 - where - runTest testTargets script partial = - runEff - . runConcurrent - . runLogNoOp - . evalState (BuildId 1) - . execWriter @[EnteringNewPhase] - . runBuildStoreCapture - . runTestRunnerScripted script - $ requestTestRunsForNewBuildResults - BuildConfig - { command = Command "" - , targets = [] - , testTargets - , watchDirs = WatchDirs [] - } - partial - - mkPhase = EnteringNewPhase (BuildId 1) - mkTesting = mkPhase . Testing - mkDone = mkPhase . Done - buildWithTests testRuns = expected {testRuns} - - expected = - BuildResult - { completedAt = addUTCTime 10 epoch - , duration = 10_000 - , moduleCount = 2 - , diagnostics = [warnMsg] - , testRuns = [] - } - - mkTestRun target = - TestRunCompleted - $ TestRunCompletion - { target - , passed = True - , output = "" - , testCases = [] - , duration = Nothing - } - - --------------------------------------------------------------------------------- --- resolveKnownTargets tests --------------------------------------------------------------------------------- - -testResolveKnownTargets :: Spec -testResolveKnownTargets = do - it "uses :show modules as the primary source for path↔name mapping" do - let result = - emptyLr - { loadedModules = - Map.fromList - [ - ( "/abs/src/Foo.hs" - , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} - ) - ] - , targetNames = ["Foo"] - } - resolveKnownTargets Map.empty result - `shouldBe` Map.fromList - [ - ( "/abs/src/Foo.hs" - , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} - ) - ] - - -- Regression test for the stale-results bug. After a failed compile, the - -- module disappears from :show modules but stays in :show targets. The - -- prior state's entry must be carried over so the dispatcher continues to - -- see the file as "known" and issues :reload (not :add) when the user - -- fixes the error. - it "carries over prior state for targets that are no longer in :show modules" do - let prev = - Map.fromList - [ - ( "/abs/src/Foo.hs" - , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} - ) - ] - result = - emptyLr - { loadedModules = Map.empty -- Foo failed to compile - , targetNames = ["Foo"] -- but is still a target - } - resolveKnownTargets prev result `shouldBe` prev - - it "drops targets that are no longer in :show targets" do - let prev = - Map.fromList - [ - ( "/abs/src/Foo.hs" - , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} - ) - ] - result = emptyLr {loadedModules = Map.empty, targetNames = []} - resolveKnownTargets prev result `shouldBe` Map.empty - - -- Dropped from the path-keyed map because we have no path↔name entry; - -- the dispatcher still handles them via 'KnownTargetNames'. - it "drops targets that have neither a current :show modules entry nor prior state" do - let result = emptyLr {loadedModules = Map.empty, targetNames = ["BrandNew"]} - resolveKnownTargets Map.empty result `shouldBe` Map.empty - where - emptyLr = - LoadResult - { moduleCount = 0 - , compiledFiles = Set.empty - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - - --------------------------------------------------------------------------------- --- fileMatchesAnyTarget tests --------------------------------------------------------------------------------- - -testFileMatchesAnyTarget :: Spec -testFileMatchesAnyTarget = do - it "matches when the path's uppercase-suffix equals a target" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "Tricorder.Version")) - "./tricorder/src/Tricorder/Version.hs" - `shouldBe` True - - it "matches a single-segment module" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "Main")) - "./app/Main.hs" - `shouldBe` True - - it "does not match when no uppercase-suffix equals a target" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "Other.Module")) - "./tricorder/src/Tricorder/Version.hs" - `shouldBe` False - - it "does not match a lowercase-prefix even if textually contained" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "src.Tricorder.Version")) - "./tricorder/src/Tricorder/Version.hs" - `shouldBe` False - - it "handles .lhs extension" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "Foo.Bar")) - "./src/Foo/Bar.lhs" - `shouldBe` True - - -- GHCi renders a target whose module name is ambiguous across home units - -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs". - it "matches a path-shaped target on directory-segment boundaries" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "app/Main.hs")) - "./tricorder/app/Main.hs" - `shouldBe` True - - it "does not match a path-shaped target on a partial segment" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "pp/Main.hs")) - "./tricorder/app/Main.hs" - `shouldBe` False - - it "does not match a path-shaped target for a different file" do - fileMatchesAnyTarget - (KnownTargetNames (Set.singleton "daemon/Main.hs")) - "./tricorder/app/Main.hs" - `shouldBe` False - - --------------------------------------------------------------------------------- --- mergeDiagnostics tests --------------------------------------------------------------------------------- - -testMergeDiagnostics :: Spec -testMergeDiagnostics = do - it "retains diagnostics from files not in compiledFiles" do - -- Foo has an error, Bar has a warning. - -- Only Foo is recompiled (and fixed). Bar is unchanged, so Bar's - -- warning must survive. - let prev = Map.fromList [(errMsg.file, [errMsg]), (warnMsg.file, [warnMsg])] - result = - LoadResult - { moduleCount = 2 - , compiledFiles = Set.singleton errMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - let merged = mergeDiagnostics prev result - Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg] - - it "clears diagnostics when a recompiled file now has no issues" do - let prev = Map.fromList [(errMsg.file, [errMsg])] - result = - LoadResult - { moduleCount = 1 - , compiledFiles = Set.singleton errMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - let merged = mergeDiagnostics prev result - Map.lookup errMsg.file merged `shouldBe` Nothing - - it "replaces diagnostics for recompiled files" do - let newErr = errMsg {title = "new error", text = "new error\n"} - prev = Map.fromList [(errMsg.file, [errMsg])] - result = - LoadResult - { moduleCount = 1 - , compiledFiles = Set.singleton errMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [newErr] - } - let merged = mergeDiagnostics prev result - Map.lookup errMsg.file merged `shouldBe` Just [newErr] - - it "accumulates diagnostics for newly seen files" do - let result = - LoadResult - { moduleCount = 1 - , compiledFiles = Set.singleton warnMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [warnMsg] - } - let merged = mergeDiagnostics Map.empty result - Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg] - - describe "when the cycle reports none" $ it "clears a stale location-less diagnostic" do - -- is never in compiledFiles, so without special - -- handling it would persist forever. A cycle with no location-less - -- diagnostic must evict it. - let noLoc = errMsg {file = ""} - prev = Map.fromList [(noLoc.file, [noLoc])] - result = - LoadResult - { moduleCount = 1 - , compiledFiles = Set.singleton errMsg.file - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [] - } - let merged = mergeDiagnostics prev result - Map.lookup noLoc.file merged `shouldBe` Nothing - - it "refreshes a location-less diagnostic that is still present" do - let noLoc = errMsg {file = ""} - prev = Map.fromList [(noLoc.file, [noLoc])] - result = - LoadResult - { moduleCount = 1 - , compiledFiles = Set.empty - , loadedModules = Map.empty - , targetNames = [] - , diagnostics = [noLoc] - } - let merged = mergeDiagnostics prev result - Map.lookup noLoc.file merged `shouldBe` Just [noLoc] - - --------------------------------------------------------------------------------- --- filterToWatchDirs tests --------------------------------------------------------------------------------- - -testFilterToWatchDirs :: Spec -testFilterToWatchDirs = do - let root = "/project" - watchDirs = WatchDirs ["/project/src"] - - it "keeps diagnostics under a watched directory" do - -- ./src/Foo.hs is what toRelative produces for an absolute project file - let d = errMsg {file = "./src/Foo.hs"} - filterToWatchDirs root watchDirs [d] `shouldBe` [d] - - it "drops diagnostics from outside the project (e.g. Nix store .h files)" do - let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"} - filterToWatchDirs root watchDirs [d] `shouldBe` [] - - it "drops diagnostics with mangled CPP filenames" do - -- The ghcid parser produces "In file included from " as the file - -- field for GCC-style CPP include-chain messages. - let d = errMsg {file = "In file included from src/Foo.hs"} - filterToWatchDirs root watchDirs [d] `shouldBe` [] - - it "drops mangled CPP filenames when watchDirs is [\".\"] (project root)" do - -- With watchDirs=["."], the watch dir resolves to projectRoot itself. - -- A mangled path joined onto projectRoot would incorrectly start with - -- projectRoot+"/", so this case requires an explicit guard. - let d = errMsg {file = "In file included from src/Foo.hs"} - filterToWatchDirs root (WatchDirs ["."]) [d] `shouldBe` [] - - it "passes everything through when watchDirs is empty" do - let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"} - filterToWatchDirs root (WatchDirs []) [d] `shouldBe` [d] - - it "works with the '.' fallback watch dir (whole project root)" do - let d = errMsg {file = "./src/Foo.hs"} - nixD = errMsg {file = "/nix/store/abc123/ghcautoconf.h"} - filterToWatchDirs root (WatchDirs ["."]) [d, nixD] `shouldBe` [d] - - describe "when diagnostic has no path it" $ it "keeps location-less errors" do - -- A home-unit GHC plugin that can't load under --enable-multi-repl - -- produces a error. It has no path to test against a - -- watch dir, but must survive or the failed build reads as clean. - let d = errMsg {file = ""} - filterToWatchDirs root watchDirs [d] `shouldBe` [d] - - it "does not treat a real <-prefixed path as a location-less marker" do - -- isLocationLess requires a closing '>'. A real (if exotic) path that - -- merely starts with '<' is an ordinary out-of-watch file and must be - -- dropped, not kept as a build-level marker. - let d = errMsg {file = "/Foo.hs"} - filterToWatchDirs root watchDirs [d] `shouldBe` [] - - describe "when its only error is out of watch dirs" $ it "a failed load does not read as clean" do - -- collectResult only injects its synthetic failure when no SError is - -- present. Here GHCi Failed with a single *located* error in a file - -- outside the watch dirs, so collectResult adds no synthetic — and then - -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The - -- Builder pipeline composes preserveFailureVisibility after filtering to - -- re-attach the failure, so a failed build never survives with zero - -- diagnostics. - let reloadOutput = - [ "/other/Dep.hs:5:1: error: boom" - , "Failed, 0 modules loaded." - ] - result = collectResult root reloadOutput [] [] - filtered = filterToWatchDirs root watchDirs result.diagnostics - preserveFailureVisibility result.diagnostics filtered - `shouldSatisfy` (not . null) - - --------------------------------------------------------------------------------- --- extractTitle tests --------------------------------------------------------------------------------- - -testExtractTitle :: Spec -testExtractTitle = do - it "returns empty string for empty message" do - extractTitle [] `shouldBe` "" - - -- New GHC style: header ends with [GHC-XXXXX], content on body lines. - -- Captured from GHC 9.10.2 with -Weverything. - it "extracts first body line for error with [GHC-XXXXX] code" do - extractTitle - [ "src/Tricorder/Config.hs:39:20: error: [GHC-83865]" - , " \8226 Couldn't match expected type 'Int' with actual type 'Bool'" - , " \8226 In the expression: True" - , " In an equation for '_deliberateError': _deliberateError = True" - , " |" - , "39 | _deliberateError = True" - , " | ^^^^" - ] - `shouldBe` "\8226 Couldn't match expected type 'Int' with actual type 'Bool'" - - it "extracts first body line for warning with [GHC-XXXXX] [-Wfoo] codes" do - extractTitle - [ "src/Tricorder/Config.hs:38:26: warning: [GHC-55631] [-Wmissing-deriving-strategies]" - , " No deriving strategy specified. Did you want stock, newtype, or anyclass?" - , " |" - , "38 | data TestWarn = TestWarn deriving (Eq)" - , " | ^^^^^^^^^^^^^" - ] - `shouldBe` "No deriving strategy specified. Did you want stock, newtype, or anyclass?" - - -- Old GHC style: message text is inline on the header line. - it "extracts inline content for old-style single-line error" do - extractTitle ["GHCi.hs:70:1: error: Parse error: naked expression at top level"] - `shouldBe` "Parse error: naked expression at top level" - - it "extracts inline content for old-style Warning (capital W)" do - extractTitle ["GHCi.hs:81:1: Warning: Defined but not used: \8216foo\8217"] - `shouldBe` "Defined but not used: \8216foo\8217" - - -- Multi-line without any inline message: position-only or "Warning:" header. - it "extracts first body line when header has position only" do - extractTitle - [ "GHCi.hs:72:13:" - , " No instance for (Num ([String] -> [String]))" - , " arising from the literal '1'" - ] - `shouldBe` "No instance for (Num ([String] -> [String]))" - - it "extracts first body line when header ends with 'Warning:'" do - extractTitle - [ "/src/TrieSpec.hs:(192,7)-(193,76): Warning:" - , " A do-notation statement discarded a result of type '[()]'" - ] - `shouldBe` "A do-notation statement discarded a result of type '[()]'" - - -- Source display lines (pipe/caret) must be skipped. - it "skips source display lines when scanning body" do - extractTitle - [ "file.hs:1:1: error: [GHC-12345]" - , " |" - , "1 | foo bar" - , " | ^^^" - , " actual content here" - ] - `shouldBe` "actual content here" - - -- ANSI-escaped header (colour output): strip escapes before searching. - it "handles ANSI-escaped headers" do - extractTitle - [ "\ESC[;1msrc/Types.hs:11:1: \ESC[35mwarning:\ESC[0m \ESC[35m[-Wunused-imports]\ESC[0m" - , " The import of 'Data.Data' is redundant" - ] - `shouldBe` "The import of 'Data.Data' is redundant" - - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -errMsg :: Diagnostic -errMsg = - Diagnostic - { severity = SError - , file = "./src/Foo.hs" - , line = 1 - , col = 1 - , endLine = 1 - , endCol = 5 - , title = "Variable not in scope: foo" - , text = "Variable not in scope: foo" - } - - -warnMsg :: Diagnostic -warnMsg = - Diagnostic - { severity = SWarning - , file = "./src/Bar.hs" - , line = 10 - , col = 3 - , endLine = 10 - , endCol = 8 - , title = "Unused import" - , text = "Unused import" - } - - -epoch :: UTCTime -epoch = UTCTime (fromGregorian 1970 1 1) 0 - - -emptyDaemonInfo :: DaemonInfo -emptyDaemonInfo = - DaemonInfo - { targets = [] - , watchDirs = [] - , sockPath = "" - , logFile = "" - , metricsPort = Nothing - } - - --------------------------------------------------------------------------------- --- Event coalescing (watchSourceChanges) --- --- Regression for the parallel-cycles bug. When source-change events arrive --- more than 200ms apart, debounce fires each callback separately. While one --- cycle is in flight, the rest must collapse into AT MOST ONE trailing cycle --- rather than queueing N back-to-back cycles — otherwise a 'status --wait' --- caller wouldn't see "Done" until the last queued cycle finished. This --- mirrors the single-slot register + single-worker pattern that --- 'watchSourceChanges' uses to coalesce a burst into one trailing reload. --------------------------------------------------------------------------------- - -testEventCoalescing :: Spec -testEventCoalescing = do - -- Whenever 'interruptCurrent' cannot drop the in-flight cycle promptly - -- (e.g. a 'status --wait' caller has registered as a waiter, gating - -- 'interruptCurrent' to a no-op), additional source-change events would - -- previously each queue their own follow-up cycle. - -- N touches spaced wider than the 200ms debounce window therefore - -- produced N back-to-back cycles after the in-flight one finished — and - -- a 'status --wait' caller wouldn't see "Done" until the last queued - -- cycle completed. - -- - -- Desired behaviour: while a cycle is in flight, additional source - -- changes coalesce into AT MOST ONE trailing cycle, regardless of how - -- many events arrived. This mirrors the single-slot register + - -- single-worker pattern that 'watchSourceChanges' uses. - it "coalesces source-change events into one follow-up cycle while busy" do - cycleRunsRef <- newTVarIO (0 :: Int) - releaseFirst <- STM.newEmptyTMVarIO @() - isFirstRef <- newTVarIO True - let onEvent _ = do - atomically (modifyTVar' cycleRunsRef (+ 1)) - -- The first invocation blocks until released, simulating - -- the in-flight cycle. Subsequent invocations return - -- immediately. - wasFirst <- atomically (STM.swapTVar isFirstRef False) - when wasFirst $ atomically (STM.takeTMVar releaseFirst) - result <- - runEff - . runConcurrent - . runTracingNoOp - . runClockConst epoch - . runChan - . runDelay - . runPubSub @SourceChangeDetected - . runErrorNoCallStack @StopSignal - . runConc - . runDebounce @Text - $ do - pending <- atomically (STM.newTVar @(Maybe SourceChangeDetected) Nothing) - Conc.scoped do - -- Listener: debounce + write the latest event into - -- the single-slot register. - Conc.fork_ - $ listen_ \(ev :: SourceChangeDetected) -> - debounced - (200 :: Millisecond) - ("source_change_reloader" :: Text) - (atomically (writeTVar pending (Just ev))) - -- Worker: drain the register, run the action. - -- Bursts of events that arrive while 'onEvent' is in - -- flight overwrite the slot, so the worker sees only - -- the most recent one. - Conc.fork_ $ forever do - ev <- atomically do - readTVar pending >>= \case - Nothing -> retry - Just e -> writeTVar pending Nothing >> pure e - onEvent ev - -- Let the listener's 'dupChan' subscribe before we - -- start publishing — otherwise the first event is - -- dropped because no subscriber sees it. - Delay.wait (50 :: Millisecond) - -- Four events spaced wider than 200ms so the - -- debounce window does NOT collapse them by itself. - -- The first becomes the in-flight cycle; the rest - -- must collapse into ONE trailing invocation. - publish (SourceChangeDetected "/x" Modified) - Delay.wait (250 :: Millisecond) - publish (SourceChangeDetected "/y" Modified) - Delay.wait (250 :: Millisecond) - publish (SourceChangeDetected "/z" Modified) - Delay.wait (250 :: Millisecond) - publish (SourceChangeDetected "/w" Modified) - -- Let the last debounce window expire so the latest - -- event lands in the slot. - Delay.wait (300 :: Millisecond) - -- Release the in-flight cycle; the slot drains and - -- the trailing cycle runs. - atomically (STM.putTMVar releaseFirst ()) - Delay.wait (300 :: Millisecond) - throwError StopSignal - case result of - Left StopSignal -> pure () - Right () -> pure () - runs <- STM.atomically (readTVar cycleRunsRef) - -- 1 in-flight + 1 coalesced trailing = 2. - runs `shouldBe` 2 - - --- | Pins down the abort path on every source change: when no 'status --wait' --- caller is holding the build, 'interruptCurrent' must drive both --- 'controls.interrupt' (which terminates the in-flight GHCi command) and --- 'TestRunner.interruptCurrent' (which terminates the in-flight test --- process). When a waiter IS present, both are suppressed so the waiter --- gets the result it's blocked on rather than a half-cancelled cycle. -testInterruptCurrent :: Spec -testInterruptCurrent = do - it "drives controls.interrupt and TestRunner.interruptCurrent when no waiter" do - (ctrls, testRun) <- runInterruptCurrent False - ctrls `shouldBe` 1 - testRun `shouldBe` 1 - - it "suppresses both interrupts when a waiter is present" do - (ctrls, testRun) <- runInterruptCurrent True - ctrls `shouldBe` 0 - testRun `shouldBe` 0 - where - runInterruptCurrent waiterPresent = do - ctrlsCalled <- newTVarIO (0 :: Int) - trCalled <- newTVarIO (0 :: Int) - -- Wrap the unused fields in 'pure' so the 'error' is the Eff - -- \*action*, not the field value — Controls uses StrictData, which - -- would otherwise force the bottoms when the record is constructed. - let mockCtrls = - Controls - { reload = pure (error "interruptCurrent must not call reload") - , interrupt = atomically (modifyTVar' ctrlsCalled (+ 1)) - , add = \_ -> pure (error "interruptCurrent must not call add") - , unadd = \_ -> pure (error "interruptCurrent must not call unadd") - } - runEff - . runConcurrent - . runLogNoOp - . runHasWaitersConst waiterPresent - . runTestRunnerInterruptCounter trCalled - $ Builder.interruptCurrent mockCtrls - (,) - <$> STM.atomically (readTVar ctrlsCalled) - <*> STM.atomically (readTVar trCalled) - - -- 'interruptCurrent' only calls 'hasWaiters' on the BuildStore — every - -- other op is unreachable from this code path, so we trap them. - runHasWaitersConst - :: Bool - -> Eff (BuildStore.BuildStore : es) a - -> Eff es a - runHasWaitersConst hasWaiters = interpret_ \case - BuildStore.HasWaiters -> pure hasWaiters - BuildStore.SetPhase _ _ -> error "interruptCurrent must not setPhase" - BuildStore.MarkDirty _ -> error "interruptCurrent must not markDirty" - BuildStore.GetState -> error "interruptCurrent must not getState" - BuildStore.ModifyPhase _ -> error "interruptCurrent must not modifyPhase" - BuildStore.WaitUntilDone -> error "interruptCurrent must not waitUntilDone" - BuildStore.WaitForNext _ -> error "interruptCurrent must not waitForNext" - BuildStore.WaitForAnyChange _ -> error "interruptCurrent must not waitForAnyChange" - BuildStore.WaitDirty -> error "interruptCurrent must not waitDirty" - - -- Counts 'InterruptCurrent' invocations; the other ops are unreachable - -- from 'Builder.interruptCurrent'. - runTestRunnerInterruptCounter - :: (Concurrent :> es) - => STM.TVar Int - -> Eff (TestRunner : es) a - -> Eff es a - runTestRunnerInterruptCounter counter = interpret_ \case - InterruptCurrent -> atomically (modifyTVar' counter (+ 1)) - RunTestSuite _ -> error "Builder.interruptCurrent must not runTestSuite" - ResetAbort -> error "Builder.interruptCurrent must not resetAbort" - IsAborted -> error "Builder.interruptCurrent must not isAborted" - - --- | A 'TestRunner' interpreter that returns the same result for every --- 'RunTestSuite' call, but latches 'IsAborted' to True after the first one --- — simulating an external interrupt that arrives between two test suites. -runTestRunnerAbortAfterFirst - :: (Concurrent :> es) - => TestRun -> Eff (TestRunner : es) a -> Eff es a -runTestRunnerAbortAfterFirst result act = do - callCountRef <- atomically (STM.newTVar (0 :: Int)) - abortedRef <- atomically (STM.newTVar False) - interpret_ - ( \case - RunTestSuite _ -> do - n <- atomically do - modifyTVar' callCountRef (+ 1) - readTVar callCountRef - when (n == 1) $ atomically (writeTVar abortedRef True) - pure result - InterruptCurrent -> atomically (writeTVar abortedRef True) - ResetAbort -> atomically (writeTVar abortedRef False) - IsAborted -> atomically (readTVar abortedRef) - ) - act - - --- | A 'BuildStore' interpreter that records every 'setPhase' call into a --- 'Writer'. Only the operations used by the Builder pipeline tests are --- implemented; the rest error. -runBuildStoreCapture - :: (Writer [EnteringNewPhase] :> es) - => Eff (BuildStore.BuildStore : es) a -> Eff es a -runBuildStoreCapture = interpret_ \case - BuildStore.SetPhase bid phase -> tell [EnteringNewPhase bid phase] - BuildStore.HasWaiters -> pure False - BuildStore.MarkDirty _ -> pure () - BuildStore.GetState -> error "runBuildStoreCapture: GetState unsupported" - BuildStore.ModifyPhase _ -> error "runBuildStoreCapture: ModifyPhase unsupported" - BuildStore.WaitUntilDone -> error "runBuildStoreCapture: WaitUntilDone unsupported" - BuildStore.WaitForNext _ -> error "runBuildStoreCapture: WaitForNext unsupported" - BuildStore.WaitForAnyChange _ -> error "runBuildStoreCapture: WaitForAnyChange unsupported" - BuildStore.WaitDirty -> error "runBuildStoreCapture: WaitDirty unsupported" diff --git a/test/Unit/Tricorder/CLI/RenderSpec.hs b/test/Unit/Tricorder/CLI/RenderSpec.hs --- a/test/Unit/Tricorder/CLI/RenderSpec.hs +++ b/test/Unit/Tricorder/CLI/RenderSpec.hs @@ -2,10 +2,7 @@ import Test.Hspec -import Tricorder.BuildState - ( Diagnostic (..) - , Severity (..) - ) +import Tricorder.Build (Diagnostic (..), Severity (..)) import Tricorder.CLI.Render (diagnosticBlock) diff --git a/test/Unit/Tricorder/Daemon/BuildStateSpec.hs b/test/Unit/Tricorder/Daemon/BuildStateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/BuildStateSpec.hs @@ -0,0 +1,107 @@ +module Unit.Tricorder.Daemon.BuildStateSpec (spec_BuildState) where + +import Data.Aeson (eitherDecode, encode) +import Data.Time (UTCTime (..), fromGregorian) +import Test.Hspec + +import Tricorder.Build + ( BuildId (..) + , BuildResult (..) + , BuildState (..) + , Diagnostic (..) + , PostBuild (..) + , Severity (..) + ) +import Tricorder.Daemon.DaemonInfo (DaemonInfo (..)) + +import Tricorder.Build qualified as Build +import Tricorder.Build.EvalComment qualified as Eval + + +spec_BuildState :: Spec +spec_BuildState = do + describe "JSON round-trip" do + it "survives Unicode smart quotes in message text" do + let msg = + Diagnostic + { severity = SWarning + , file = "" + , 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 = + Build.Failed + "cabal: Could not resolve dependencies:\n[__0] trying: \8216base\8217\nrejecting: ..." + } + eitherDecode (encode failed) `shouldBe` Right failed + + +mkBuildState :: [Diagnostic] -> BuildState +mkBuildState msgs = + BuildState + { buildId = BuildId 1 + , phase = + Build.Finished + ( BuildResult + { completedAt = epoch + , duration = 0 + , moduleCount = 0 + , diagnostics = msgs + } + ) + $ PostBuild mempty Eval.NoneFound + , daemonInfo = + DaemonInfo + { targets = [] + , watchDirs = [] + , sockPath = "" + , logFile = "" + } + } + where + epoch = UTCTime (fromGregorian 1970 1 1) 0 diff --git a/test/Unit/Tricorder/Daemon/BuilderSpec.hs b/test/Unit/Tricorder/Daemon/BuilderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/BuilderSpec.hs @@ -0,0 +1,286 @@ +module Unit.Tricorder.Daemon.BuilderSpec (spec_Builder) where + +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + +import Tricorder.Build (BuildResult (..), Diagnostic (..), Severity (..)) +import Tricorder.Daemon.Builder (NewLoadResult (..), compileBuildResults) +import Tricorder.Daemon.GhciSession.GhciParser + ( LoadResult (..) + , LoadedModule (..) + , extractTitle + , resolveKnownTargets + ) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.WatchDirs (WatchDirs (..)) + + +spec_Builder :: Spec +spec_Builder = do + describe "extractTitle" testExtractTitle + describe "compileBuildResults" testCompileBuildResults + describe "resolveKnownTargets" testResolveKnownTargets + + +data StopSignal = StopSignal + deriving stock (Show) + + +testCompileBuildResults :: Spec +testCompileBuildResults = do + it "uses NewLoadResult's times to calculate duration" do + let (_, r) = + compileBuildResults + root + watchDirs + mempty + NewLoadResult + { startTime = addUTCTime 10 epoch + , endTime = addUTCTime 20 epoch + , loadResult = + LoadResult + { moduleCount = 2 + , compiledFiles = Set.singleton errMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [] + } + } + r.duration `shouldBe` 10_000 + it "merges with existing results" do + let (m, _) = + compileBuildResults root watchDirs (Map.fromList [(errMsg.file, [errMsg])]) + $ NewLoadResult + { startTime = epoch + , endTime = epoch + , loadResult = + LoadResult + { moduleCount = 2 + , compiledFiles = Set.singleton warnMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [warnMsg] + } + } + m + `shouldBe` fromList + [ (warnMsg.file, [warnMsg]) + , (errMsg.file, [errMsg]) + ] + + it "returns a BuildResult" do + let (_, r) = + compileBuildResults root watchDirs mempty + $ NewLoadResult + { startTime = epoch + , endTime = addUTCTime 10 epoch + , loadResult = + LoadResult + { moduleCount = 2 + , compiledFiles = Set.singleton warnMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [warnMsg] + } + } + expected = + BuildResult + { completedAt = addUTCTime 10 epoch + , duration = 10_000 + , moduleCount = 2 + , diagnostics = [warnMsg] + } + r `shouldBe` expected + where + root = ProjectRoot "/" + watchDirs = WatchDirs ["/src"] + + +-------------------------------------------------------------------------------- +-- resolveKnownTargets tests +-------------------------------------------------------------------------------- + +testResolveKnownTargets :: Spec +testResolveKnownTargets = do + it "uses :show modules as the primary source for path↔name mapping" do + let result = + emptyLr + { loadedModules = + Map.fromList + [ + ( "/abs/src/Foo.hs" + , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} + ) + ] + , targetNames = ["Foo"] + } + resolveKnownTargets Map.empty result + `shouldBe` Map.fromList + [ + ( "/abs/src/Foo.hs" + , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} + ) + ] + + -- Regression test for the stale-results bug. After a failed compile, the + -- module disappears from :show modules but stays in :show targets. The + -- prior state's entry must be carried over so the dispatcher continues to + -- see the file as "known" and issues :reload (not :add) when the user + -- fixes the error. + it "carries over prior state for targets that are no longer in :show modules" do + let prev = + Map.fromList + [ + ( "/abs/src/Foo.hs" + , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} + ) + ] + result = + emptyLr + { loadedModules = Map.empty -- Foo failed to compile + , targetNames = ["Foo"] -- but is still a target + } + resolveKnownTargets prev result `shouldBe` prev + + it "drops targets that are no longer in :show targets" do + let prev = + Map.fromList + [ + ( "/abs/src/Foo.hs" + , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"} + ) + ] + result = emptyLr {loadedModules = Map.empty, targetNames = []} + resolveKnownTargets prev result `shouldBe` Map.empty + + -- Dropped from the path-keyed map because we have no path↔name entry; + -- the dispatcher still handles them via 'KnownTargetNames'. + it "drops targets that have neither a current :show modules entry nor prior state" do + let result = emptyLr {loadedModules = Map.empty, targetNames = ["BrandNew"]} + resolveKnownTargets Map.empty result `shouldBe` Map.empty + where + emptyLr = + LoadResult + { moduleCount = 0 + , compiledFiles = Set.empty + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [] + } + + +-------------------------------------------------------------------------------- +-- extractTitle tests +-------------------------------------------------------------------------------- + +testExtractTitle :: Spec +testExtractTitle = do + it "returns empty string for empty message" do + extractTitle [] `shouldBe` "" + + -- New GHC style: header ends with [GHC-XXXXX], content on body lines. + -- Captured from GHC 9.10.2 with -Weverything. + it "extracts first body line for error with [GHC-XXXXX] code" do + extractTitle + [ "src/Tricorder/Config.hs:39:20: error: [GHC-83865]" + , " \8226 Couldn't match expected type 'Int' with actual type 'Bool'" + , " \8226 In the expression: True" + , " In an equation for '_deliberateError': _deliberateError = True" + , " |" + , "39 | _deliberateError = True" + , " | ^^^^" + ] + `shouldBe` "\8226 Couldn't match expected type 'Int' with actual type 'Bool'" + + it "extracts first body line for warning with [GHC-XXXXX] [-Wfoo] codes" do + extractTitle + [ "src/Tricorder/Config.hs:38:26: warning: [GHC-55631] [-Wmissing-deriving-strategies]" + , " No deriving strategy specified. Did you want stock, newtype, or anyclass?" + , " |" + , "38 | data TestWarn = TestWarn deriving (Eq)" + , " | ^^^^^^^^^^^^^" + ] + `shouldBe` "No deriving strategy specified. Did you want stock, newtype, or anyclass?" + + -- Old GHC style: message text is inline on the header line. + it "extracts inline content for old-style single-line error" do + extractTitle ["GHCi.hs:70:1: error: Parse error: naked expression at top level"] + `shouldBe` "Parse error: naked expression at top level" + + it "extracts inline content for old-style Warning (capital W)" do + extractTitle ["GHCi.hs:81:1: Warning: Defined but not used: \8216foo\8217"] + `shouldBe` "Defined but not used: \8216foo\8217" + + -- Multi-line without any inline message: position-only or "Warning:" header. + it "extracts first body line when header has position only" do + extractTitle + [ "GHCi.hs:72:13:" + , " No instance for (Num ([String] -> [String]))" + , " arising from the literal '1'" + ] + `shouldBe` "No instance for (Num ([String] -> [String]))" + + it "extracts first body line when header ends with 'Warning:'" do + extractTitle + [ "/src/TrieSpec.hs:(192,7)-(193,76): Warning:" + , " A do-notation statement discarded a result of type '[()]'" + ] + `shouldBe` "A do-notation statement discarded a result of type '[()]'" + + -- Source display lines (pipe/caret) must be skipped. + it "skips source display lines when scanning body" do + extractTitle + [ "file.hs:1:1: error: [GHC-12345]" + , " |" + , "1 | foo bar" + , " | ^^^" + , " actual content here" + ] + `shouldBe` "actual content here" + + -- ANSI-escaped header (colour output): strip escapes before searching. + it "handles ANSI-escaped headers" do + extractTitle + [ "\ESC[;1msrc/Types.hs:11:1: \ESC[35mwarning:\ESC[0m \ESC[35m[-Wunused-imports]\ESC[0m" + , " The import of 'Data.Data' is redundant" + ] + `shouldBe` "The import of 'Data.Data' is redundant" + + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +errMsg :: Diagnostic +errMsg = + Diagnostic + { severity = SError + , file = "./src/Foo.hs" + , line = 1 + , col = 1 + , endLine = 1 + , endCol = 5 + , title = "Variable not in scope: foo" + , text = "Variable not in scope: foo" + } + + +warnMsg :: Diagnostic +warnMsg = + Diagnostic + { severity = SWarning + , file = "./src/Bar.hs" + , line = 10 + , col = 3 + , endLine = 10 + , endCol = 8 + , title = "Unused import" + , text = "Unused import" + } + + +epoch :: UTCTime +epoch = UTCTime (fromGregorian 1970 1 1) 0 diff --git a/test/Unit/Tricorder/Daemon/DispatchSpec.hs b/test/Unit/Tricorder/Daemon/DispatchSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/DispatchSpec.hs @@ -0,0 +1,282 @@ +module Unit.Tricorder.Daemon.DispatchSpec (spec_Dispatch) where + +import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy) + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + +import Tricorder.Build (Diagnostic (..), Severity (..)) +import Tricorder.Daemon.Dispatch + ( KnownTargetNames (..) + , fileMatchesAnyTarget + , filterToWatchDirs + , mergeDiagnostics + , preserveFailureVisibility + ) +import Tricorder.Daemon.GhciSession.GhciParser (LoadResult (..), collectResult) +import Tricorder.Session.WatchDirs (WatchDirs (..)) + + +spec_Dispatch :: Spec +spec_Dispatch = do + describe "fileMatchesAnyTarget" testFileMatchesAnyTarget + describe "mergeDiagnostics" testMergeDiagnostics + describe "filterToWatchDirs" testFilterToWatchDirs + + +-------------------------------------------------------------------------------- +-- fileMatchesAnyTarget tests +-------------------------------------------------------------------------------- + +testFileMatchesAnyTarget :: Spec +testFileMatchesAnyTarget = do + it "matches when the path's uppercase-suffix equals a target" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "Tricorder.Version")) + "./tricorder/src/Tricorder/Version.hs" + `shouldBe` True + + it "matches a single-segment module" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "Main")) + "./app/Main.hs" + `shouldBe` True + + it "does not match when no uppercase-suffix equals a target" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "Other.Module")) + "./tricorder/src/Tricorder/Version.hs" + `shouldBe` False + + it "does not match a lowercase-prefix even if textually contained" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "src.Tricorder.Version")) + "./tricorder/src/Tricorder/Version.hs" + `shouldBe` False + + it "handles .lhs extension" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "Foo.Bar")) + "./src/Foo/Bar.lhs" + `shouldBe` True + + -- GHCi renders a target whose module name is ambiguous across home units + -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs". + it "matches a path-shaped target on directory-segment boundaries" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "app/Main.hs")) + "./tricorder/app/Main.hs" + `shouldBe` True + + it "does not match a path-shaped target on a partial segment" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "pp/Main.hs")) + "./tricorder/app/Main.hs" + `shouldBe` False + + it "does not match a path-shaped target for a different file" do + fileMatchesAnyTarget + (KnownTargetNames (Set.singleton "daemon/Main.hs")) + "./tricorder/app/Main.hs" + `shouldBe` False + + +-------------------------------------------------------------------------------- +-- mergeDiagnostics tests +-------------------------------------------------------------------------------- + +testMergeDiagnostics :: Spec +testMergeDiagnostics = do + it "retains diagnostics from files not in compiledFiles" do + -- Foo has an error, Bar has a warning. + -- Only Foo is recompiled (and fixed). Bar is unchanged, so Bar's + -- warning must survive. + let prev = Map.fromList [(errMsg.file, [errMsg]), (warnMsg.file, [warnMsg])] + result = + LoadResult + { moduleCount = 2 + , compiledFiles = Set.singleton errMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [] + } + let merged = mergeDiagnostics prev result + Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg] + + it "clears diagnostics when a recompiled file now has no issues" do + let prev = Map.fromList [(errMsg.file, [errMsg])] + result = + LoadResult + { moduleCount = 1 + , compiledFiles = Set.singleton errMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [] + } + let merged = mergeDiagnostics prev result + Map.lookup errMsg.file merged `shouldBe` Nothing + + it "replaces diagnostics for recompiled files" do + let newErr = errMsg {title = "new error", text = "new error\n"} + prev = Map.fromList [(errMsg.file, [errMsg])] + result = + LoadResult + { moduleCount = 1 + , compiledFiles = Set.singleton errMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [newErr] + } + let merged = mergeDiagnostics prev result + Map.lookup errMsg.file merged `shouldBe` Just [newErr] + + it "accumulates diagnostics for newly seen files" do + let result = + LoadResult + { moduleCount = 1 + , compiledFiles = Set.singleton warnMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [warnMsg] + } + let merged = mergeDiagnostics Map.empty result + Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg] + + describe "when the cycle reports none" $ it "clears a stale location-less diagnostic" do + -- is never in compiledFiles, so without special + -- handling it would persist forever. A cycle with no location-less + -- diagnostic must evict it. + let noLoc = errMsg {file = ""} + prev = Map.fromList [(noLoc.file, [noLoc])] + result = + LoadResult + { moduleCount = 1 + , compiledFiles = Set.singleton errMsg.file + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [] + } + let merged = mergeDiagnostics prev result + Map.lookup noLoc.file merged `shouldBe` Nothing + + it "refreshes a location-less diagnostic that is still present" do + let noLoc = errMsg {file = ""} + prev = Map.fromList [(noLoc.file, [noLoc])] + result = + LoadResult + { moduleCount = 1 + , compiledFiles = Set.empty + , loadedModules = Map.empty + , targetNames = [] + , diagnostics = [noLoc] + } + let merged = mergeDiagnostics prev result + Map.lookup noLoc.file merged `shouldBe` Just [noLoc] + + +-------------------------------------------------------------------------------- +-- filterToWatchDirs tests +-------------------------------------------------------------------------------- + +testFilterToWatchDirs :: Spec +testFilterToWatchDirs = do + let root = "/project" + watchDirs = WatchDirs ["/project/src"] + + it "keeps diagnostics under a watched directory" do + -- ./src/Foo.hs is what toRelative produces for an absolute project file + let d = errMsg {file = "./src/Foo.hs"} + filterToWatchDirs root watchDirs [d] `shouldBe` [d] + + it "keeps diagnostics under \".\" watched directory" do + let d = errMsg {file = "src/Foo.hs"} + filterToWatchDirs root (WatchDirs ["."]) [d] `shouldMatchList` [d] + + it "drops diagnostics from outside the project (e.g. Nix store .h files)" do + let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"} + filterToWatchDirs root watchDirs [d] `shouldBe` [] + + it "drops diagnostics with mangled CPP filenames" do + -- The ghcid parser produces "In file included from " as the file + -- field for GCC-style CPP include-chain messages. + let d = errMsg {file = "In file included from src/Foo.hs"} + filterToWatchDirs root watchDirs [d] `shouldBe` [] + + it "drops mangled CPP filenames when watchDirs is [\".\"] (project root)" do + -- With watchDirs=["."], the watch dir resolves to projectRoot itself. + -- A mangled path joined onto projectRoot would incorrectly start with + -- projectRoot+"/", so this case requires an explicit guard. + let d = errMsg {file = "In file included from src/Foo.hs"} + filterToWatchDirs root (WatchDirs ["."]) [d] `shouldBe` [] + + it "passes everything through when watchDirs is empty" do + let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"} + filterToWatchDirs root (WatchDirs []) [d] `shouldBe` [d] + + it "works with the '.' fallback watch dir (whole project root)" do + let d = errMsg {file = "./src/Foo.hs"} + nixD = errMsg {file = "/nix/store/abc123/ghcautoconf.h"} + filterToWatchDirs root (WatchDirs ["."]) [d, nixD] `shouldBe` [d] + + describe "when diagnostic has no path it" $ it "keeps location-less errors" do + -- A home-unit GHC plugin that can't load under --enable-multi-repl + -- produces a error. It has no path to test against a + -- watch dir, but must survive or the failed build reads as clean. + let d = errMsg {file = ""} + filterToWatchDirs root watchDirs [d] `shouldBe` [d] + + it "does not treat a real <-prefixed path as a location-less marker" do + -- isLocationLess requires a closing '>'. A real (if exotic) path that + -- merely starts with '<' is an ordinary out-of-watch file and must be + -- dropped, not kept as a build-level marker. + let d = errMsg {file = "/Foo.hs"} + filterToWatchDirs root watchDirs [d] `shouldBe` [] + + describe "when its only error is out of watch dirs" $ it "a failed load does not read as clean" do + -- collectResult only injects its synthetic failure when no SError is + -- present. Here GHCi Failed with a single *located* error in a file + -- outside the watch dirs, so collectResult adds no synthetic — and then + -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The + -- Builder pipeline composes preserveFailureVisibility after filtering to + -- re-attach the failure, so a failed build never survives with zero + -- diagnostics. + let reloadOutput = + [ "/other/Dep.hs:5:1: error: boom" + , "Failed, 0 modules loaded." + ] + result = collectResult root reloadOutput [] [] + filtered = filterToWatchDirs root watchDirs result.diagnostics + preserveFailureVisibility result.diagnostics filtered + `shouldSatisfy` (not . null) + + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +errMsg :: Diagnostic +errMsg = + Diagnostic + { severity = SError + , file = "./src/Foo.hs" + , line = 1 + , col = 1 + , endLine = 1 + , endCol = 5 + , title = "Variable not in scope: foo" + , text = "Variable not in scope: foo" + } + + +warnMsg :: Diagnostic +warnMsg = + Diagnostic + { severity = SWarning + , file = "./src/Bar.hs" + , line = 10 + , col = 3 + , endLine = 10 + , endCol = 8 + , title = "Unused import" + , text = "Unused import" + } diff --git a/test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs b/test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs @@ -0,0 +1,421 @@ +module Unit.Tricorder.Daemon.GhciSession.GhciParserSpec (spec_GhciParser) where + +import Test.Hspec + +import Tricorder.Build (Diagnostic (..), Severity (..)) +import Tricorder.Daemon.GhciSession.GhciParser + ( GhciLoad (..) + , GhciLoading (..) + , GhciMessage (..) + , GhciSeverity (..) + , LoadOutcome (..) + , LoadResult (..) + , Position (..) + , collectResult + , collectResultCustom + , parseReload + , parseShowModules + , parseShowTargets + ) + + +spec_GhciParser :: Spec +spec_GhciParser = do + describe "parseReload" do + describe "clean build" testCleanBuild + describe "with errors and warnings" testErrors + describe "with -fhide-source-paths (no Loading items)" testHideSourcePaths + describe "with errors" testNoLocationInfo + describe "with Loaded GHCi configuration" testLoadedConfig + + describe "parseShowModules" do + describe "typical output" testShowModules + describe "empty / blank input" testShowModulesEmpty + + describe "parseShowTargets" testShowTargets + + describe "collectResultCustom" do + describe " plugin load failure" testPluginLoadFailure + + describe "collectResult" do + describe "failed load with no located error" testUnattributedFailure + + +-------------------------------------------------------------------------------- +-- parseReload: clean build +-------------------------------------------------------------------------------- + +testCleanBuild :: Spec +testCleanBuild = do + it "produces GLoading items for each compiled module" do + let input = + [ "[1 of 3] Compiling Tricorder.Build ( src/Tricorder.Build.hs, interpreted )" + , "[2 of 3] Compiling Tricorder.Session ( src/Tricorder/Session.hs, interpreted )" + , "[3 of 3] Compiling Main ( app/Main.hs, interpreted )" + , "Ok, 3 modules loaded." + ] + parseReload input + `shouldBe` [ GLoading GhciLoading {index = 1, total = 3, moduleName = "Tricorder.Build", sourceFile = "src/Tricorder.Build.hs"} + , GLoading GhciLoading {index = 2, total = 3, moduleName = "Tricorder.Session", sourceFile = "src/Tricorder/Session.hs"} + , GLoading GhciLoading {index = 3, total = 3, moduleName = "Main", sourceFile = "app/Main.hs"} + , GSummary LoadSucceeded + ] + + it "handles padded module index (e.g. [ 1 of 47])" do + let input = + [ "[ 1 of 47] Compiling Main ( app/Main.hs, interpreted )" + , "Ok, 1 module loaded." + ] + parseReload input + `shouldBe` [ GLoading GhciLoading {index = 1, total = 47, moduleName = "Main", sourceFile = "app/Main.hs"} + , GSummary LoadSucceeded + ] + + describe "when only summary line" $ it "returns the summary outcome" do + parseReload ["Ok, 0 modules loaded."] `shouldBe` [GSummary LoadSucceeded] + + +-------------------------------------------------------------------------------- +-- parseReload: errors and warnings +-------------------------------------------------------------------------------- + +testErrors :: Spec +testErrors = do + it "parses a single-line error" do + let input = ["src/Foo.hs:10:5: error: Variable not in scope: foo"] + parseReload input + `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Foo.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]}] + + it "parses a warning with continuation lines" do + let input = + [ "src/Bar.hs:20:3: warning: [-Wunused-imports]" + , " Redundant import: Data.List" + , " Perhaps you want to remove it." + ] + parseReload input + `shouldBe` [ GMessage + GhciMessage + { severity = GWarning + , file = "src/Bar.hs" + , startPos = Position 20 3 + , endPos = Position 20 3 + , messageLines = + [ "src/Bar.hs:20:3: warning: [-Wunused-imports]" + , " Redundant import: Data.List" + , " Perhaps you want to remove it." + ] + } + ] + + it "parses a span position (L:C-C2:)" do + let input = ["src/Baz.hs:5:1-10: error: Parse error"] + parseReload input + `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Baz.hs", startPos = Position 5 1, endPos = Position 5 10, messageLines = ["src/Baz.hs:5:1-10: error: Parse error"]}] + + it "parses a span position ((L1,C1)-(L2,C2):)" do + let input = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"] + parseReload input + `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Qux.hs", startPos = Position 3 1, endPos = Position 5 20, messageLines = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]}] + + it "parses a span position with double-paren end ((L1,C1)-((L2,C2):)" do + let input = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"] + parseReload input + `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Qux.hs", startPos = Position 3 1, endPos = Position 5 20, messageLines = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]}] + + it "parses source-display continuation lines (pipe format)" do + let input = + [ "src/Foo.hs:10:5: error: Variable not in scope: foo" + , " |" + , "10 | foo bar" + , " | ^^^" + , " Suggested fix: import Foo" + ] + parseReload input + `shouldBe` [ GMessage + GhciMessage + { severity = GError + , file = "src/Foo.hs" + , startPos = Position 10 5 + , endPos = Position 10 5 + , messageLines = + [ "src/Foo.hs:10:5: error: Variable not in scope: foo" + , " |" + , "10 | foo bar" + , " | ^^^" + , " Suggested fix: import Foo" + ] + } + ] + + it "strips ANSI codes from header for matching but stores original in glMessage" do + let ansiHeader = "\ESC[1msrc/Foo.hs:10:5:\ESC[0m \ESC[91merror:\ESC[0m Variable not in scope: foo" + parseReload [ansiHeader] + `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Foo.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = [ansiHeader]}] + + it "parses a Windows drive-letter path in a diagnostic" do + let input = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"] + parseReload input + `shouldBe` [GMessage GhciMessage {severity = GError, file = "C:\\path\\file.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]}] + + it "parses mixed Loading, Message, and summary items" do + let input = + [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )" + , "src/Lib.hs:5:1: error: Oops" + , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )" + , "Failed, 1 module loaded." + ] + parseReload input + `shouldBe` [ GLoading GhciLoading {index = 1, total = 2, moduleName = "Lib", sourceFile = "src/Lib.hs"} + , GMessage GhciMessage {severity = GError, file = "src/Lib.hs", startPos = Position 5 1, endPos = Position 5 1, messageLines = ["src/Lib.hs:5:1: error: Oops"]} + , GLoading GhciLoading {index = 2, total = 2, moduleName = "Main", sourceFile = "app/Main.hs"} + , GSummary LoadFailed + ] + + +-------------------------------------------------------------------------------- +-- parseReload: -fhide-source-paths output +-------------------------------------------------------------------------------- + +testHideSourcePaths :: Spec +testHideSourcePaths = do + describe "when source paths are hidden" $ it "produces no GLoading items" do + let input = + [ "src/Foo.hs:10:5: error: Variable not in scope: foo" + , " Perhaps you meant: 'bar'" + , "Failed, one module failed to load." + ] + parseReload input + `shouldBe` [ GMessage + GhciMessage + { severity = GError + , file = "src/Foo.hs" + , startPos = Position 10 5 + , endPos = Position 10 5 + , messageLines = + [ "src/Foo.hs:10:5: error: Variable not in scope: foo" + , " Perhaps you meant: 'bar'" + ] + } + , GSummary LoadFailed + ] + + describe "when all modules are already up to date" $ it "returns the summary outcome" do + -- GHCi with -fhide-source-paths and nothing to recompile + parseReload ["Ok, 5 modules loaded."] `shouldBe` [GSummary LoadSucceeded] + + +-------------------------------------------------------------------------------- +-- parseReload: 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"} + , GSummary LoadSucceeded + ] + + +-------------------------------------------------------------------------------- +-- parseShowModules +-------------------------------------------------------------------------------- + +testShowModules :: Spec +testShowModules = do + it "parses typical :show modules output" do + let input = + [ "Tricorder.Build ( src/Tricorder.Build.hs, interpreted )" + , "Tricorder.Session ( src/Tricorder/Session.hs, interpreted )" + , "Main ( app/Main.hs, interpreted )" + ] + parseShowModules input + `shouldBe` [ ("Tricorder.Build", "src/Tricorder.Build.hs") + , ("Tricorder.Session", "src/Tricorder/Session.hs") + , ("Main", "app/Main.hs") + ] + + it "parses absolute paths" do + parseShowModules ["Lib ( /home/user/project/src/Lib.hs, interpreted )"] + `shouldBe` [("Lib", "/home/user/project/src/Lib.hs")] + + it "strips ANSI codes before parsing" do + parseShowModules ["\ESC[1mMain\ESC[0m ( app/Main.hs, interpreted )"] + `shouldBe` [("Main", "app/Main.hs")] + + +testShowModulesEmpty :: Spec +testShowModulesEmpty = do + it "returns empty list for empty input" do + parseShowModules [] `shouldBe` [] + + it "returns empty list for blank lines" do + parseShowModules ["", " ", "\t"] `shouldBe` [] + + it "skips lines without '( '" do + parseShowModules ["just some random text"] `shouldBe` [] + + +-------------------------------------------------------------------------------- +-- parseShowTargets +-------------------------------------------------------------------------------- + +testShowTargets :: Spec +testShowTargets = do + it "parses module names emitted by cabal repl --enable-multi-repl" do + parseShowTargets + [ "Atelier.Effects.Cache" + , "Atelier.Effects.Chan" + , "Paths_tricorder" + ] + `shouldBe` ["Atelier.Effects.Cache", "Atelier.Effects.Chan", "Paths_tricorder"] + + it "parses file-path targets emitted by plain ghci" do + parseShowTargets ["src/Foo.hs", "test/Bar.hs"] + `shouldBe` ["src/Foo.hs", "test/Bar.hs"] + + it "strips the leading '*' marker for the active interactive target" do + parseShowTargets ["*Main", "Foo.Bar"] `shouldBe` ["Main", "Foo.Bar"] + + it "strips ANSI escape sequences" do + parseShowTargets ["\ESC[1mFoo.Bar\ESC[0m"] `shouldBe` ["Foo.Bar"] + + it "skips blank and whitespace-only lines" do + parseShowTargets ["", " ", "\t", "Real.Target"] `shouldBe` ["Real.Target"] + + it "returns empty list for empty input" do + parseShowTargets [] `shouldBe` [] + + +-------------------------------------------------------------------------------- +-- collectResultCustom: plugin load failure +-------------------------------------------------------------------------------- + +-- | Regression test for the \"All good\" bug with home-unit GHC plugins. +-- +-- Under @cabal repl --enable-multi-repl@ every unit is interpreted, so a +-- package used as a GHC plugin in the same project is not available as a +-- compiled plugin. The unit that depends on it fails to load, GHCi reports the +-- failure with @\@ (it has no source span), and the load +-- ends with @Failed, N modules loaded@. This output must still surface as an +-- error diagnostic — otherwise the build is silently reported as clean. +testPluginLoadFailure :: Spec +testPluginLoadFailure = do + -- Shape of the GHCi output from `cabal repl --enable-multi-repl` when an + -- executable loads a home-unit GHC plugin: the plugin package's modules + -- compile, then the unit using the plugin fails with a location-less error. + let reloadOutput = + [ "[3 of 5] Compiling My.Plugin ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]" + , ": error:" + , " Could not load module \8216My.Plugin\8217." + , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217." + , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file." + , "Use -v to see a list of the files searched for." + , "" + , "[5 of 5] Compiling Main ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]" + , "Failed, 4 modules loaded." + ] + result = collectResultCustom "/project" (parseReload reloadOutput) [] [] + + it "surfaces the plugin load failure as an error diagnostic" do + map (.severity) result.diagnostics `shouldContain` [SError] + + it "carries the plugin error message in the diagnostic title" do + map (.title) result.diagnostics + `shouldContain` ["Could not load module \8216My.Plugin\8217."] + + +-------------------------------------------------------------------------------- +-- collectResult: failed load with no located error +-------------------------------------------------------------------------------- + +-- 'collectResult' is the safety net: GHCi can end a load with @Failed, …@ +-- without emitting any error that carries a source span. The build must never +-- read as clean in that case, so a synthetic error diagnostic is added. +testUnattributedFailure :: Spec +testUnattributedFailure = do + describe "when the load failed but no error was located" $ it "adds a synthetic error" do + let reloadOutput = + [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )" + , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )" + , "Failed, 1 module loaded." + ] + result = collectResult "/project" reloadOutput [] [] + map (.severity) result.diagnostics `shouldBe` [SError] + + it "does not duplicate a failure that already produced a located error" do + let reloadOutput = + [ "[1 of 1] Compiling Lib ( src/Lib.hs, interpreted )" + , "src/Lib.hs:5:1: error: Oops" + , "Failed, 0 modules loaded." + ] + result = collectResult "/project" reloadOutput [] [] + -- Only the real, located diagnostic — no synthetic one appended. + map (.file) result.diagnostics `shouldBe` ["src/Lib.hs"] + + it "adds nothing for a successful load" do + let reloadOutput = + [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )" + , "Ok, 1 module loaded." + ] + result = collectResult "/project" reloadOutput [] [] + result.diagnostics `shouldBe` [] + + describe "when 'Failed,' appears off the summary line" $ it "does not flag a clean build" do + -- The load outcome lives on GHCi's single summary line + -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a + -- Template Haskell splice or top-level IO run while interpreting — can + -- contain a line that happens to begin with "Failed,". That must not be + -- mistaken for a failed load: the summary here is "Ok," so no synthetic + -- error belongs. + let reloadOutput = + [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )" + , "Failed, retrying with fallback" -- printed by a TH splice + , "Ok, 1 module loaded." + ] + result = collectResult "/project" reloadOutput [] [] + result.diagnostics `shouldBe` [] diff --git a/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs b/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs @@ -0,0 +1,422 @@ +module Unit.Tricorder.Daemon.GhciSession.GhciProcessSpec (spec_GhciProcess) where + +import Atelier.Effects.Conc (runConc) +import Atelier.Effects.Delay (runDelay) +import Atelier.Effects.File (runFile) +import Atelier.Effects.Process (runProcessIO, terminateProcessGroup, withProcessGroup) +import Atelier.Effects.Process.Internal (RunningProcess (..)) +import Atelier.Effects.Timeout (runTimeout) +import Atelier.Time (Millisecond) +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (newTVarIO) +import Control.Exception (IOException, catch) +import Data.Char (isDigit) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Time.Units (Second) +import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.Exception (trySync) +import System.IO (hGetLine) +import System.Posix.Signals (nullSignal, sigKILL, signalProcess) +import System.Process.Typed + ( createPipe + , getStderr + , getStdin + , getStdout + , setCreateGroup + , setStderr + , setStdin + , setStdout + , shell + , startProcess + , stopProcess + , waitExitCode + ) +import Test.Hspec + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Delay qualified as Delay +import Atelier.Effects.File qualified as File +import Atelier.Effects.Process qualified as AProc +import Data.Text qualified as T +import System.Process qualified as Process +import System.Timeout qualified + +import Tricorder.Daemon.GhciSession.GhciProcess + ( GhciProcess (..) + , GhciProcessError (..) + , InterruptDecision (..) + , SessionState (..) + , decideInterrupt + , execGhci + , waitForBannerOrFail + ) + + +spec_GhciProcess :: Spec +spec_GhciProcess = do + describe "decideInterrupt" testDecideInterrupt + describe "execGhci" testExecGhciScope + describe "execGhci (stale marker desync)" testExecGhciStaleMarker + describe "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent + describe "waitForBannerOrFail" testWaitForBannerOrFail + describe "withProcessGroup (process group)" testWithProcessGroupCleanup + describe "terminateProcessGroup (process group)" testTerminateProcessGroup + + +-- | Regression for the touch-during-reload desync. Interrupting a *Busy* GHCi +-- (a reload in flight) leaves a stale sync marker in the stdout/stderr buffers +-- ahead of the next command's real output. Because 'drainUntil' used to stop on +-- ANY marker-prefix line, the next 'execGhci' matched that stale marker and +-- returned *before its command ran* — surfacing as @All good. (0 modules)@ (or, +-- on the other timing, a hang). 'execGhci' must skip markers that aren't its +-- own and stop only on the marker it is waiting for. +testExecGhciStaleMarker :: Spec +testExecGhciStaleMarker = + it "skips a stale leftover marker and returns the command's real output" do + (stdinR, stdinW) <- Process.createPipe + (stdoutR, stdoutW) <- Process.createPipe + (stderrR, stderrW) <- Process.createPipe + -- A dummy process handle to fill the record; 'execGhci' never uses it. + p <- + startProcess + $ setStdin createPipe + $ setStdout createPipe + $ setStderr createPipe + $ shell "true" + _ <- waitExitCode p + stateVar <- newTVarIO (Idle 9) + let gp = + GhciProcess + { stdin = stdinW + , stdout = stdoutR + , stderr = stderrR + , handle = RunningProcess p + , stateVar + } + -- Mirrors 'markerFor': "#~TRI-FINISH-~#". + marker n = "#~TRI-FINISH-" <> show (n :: Int) <> "~#" :: Text + result <- + runEff + . runConcurrent + . runTimeout + . runDelay + . runFile + . runConc + $ do + -- A stale 'marker 5' (left by a prior interrupted reload) + -- precedes the fresh command's real output + its 'marker 9' + -- (state is 'Idle 9', so 'execGhci' waits for marker 9). + for_ [marker 5, "out-line", marker 9] (File.hPutTextLn stdoutW) + for_ [marker 5, "err-line", marker 9] (File.hPutTextLn stderrW) + File.hClose stdoutW + File.hClose stderrW + -- Keep the stdin read-end alive across the write inside + -- 'execGhci' (otherwise it is GC-finalised → broken pipe). + r <- execGhci gp "reload" (\_ -> pure ()) + File.hClose stdinR + pure r + _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ()) + result `shouldBe` ["out-line", "err-line"] + + +-- | Root-cause regression for the "stuck Building…" stall. A SIGINT-interrupted +-- ':reload' empties GHCi's interactive scope — it drops the implicit +-- @import Prelude@ (verified against ghci 9.10). A sync marker built from bare +-- Prelude names then fails to run instead of printing: @putStrLn@ is no longer +-- in scope, and neither is the @>>@ operator. The marker never appears, so +-- 'drainUntil' blocks until the watchdog fires. The marker must therefore use +-- only fully-qualified 'System.IO.hPutStrLn' statements (which survive the +-- emptied scope), one per stream, with no bare names or operators. +-- +-- We assert on exactly what 'execGhci' writes to GHCi's stdin. +testSyncMarkerScopeIndependent :: Spec +testSyncMarkerScopeIndependent = + it "writes the finish marker using only fully-qualified names (no bare putStrLn / >>)" do + (stdinR, stdinW) <- Process.createPipe + (stdoutR, stdoutW) <- Process.createPipe + (stderrR, stderrW) <- Process.createPipe + p <- + startProcess + $ setStdin createPipe + $ setStdout createPipe + $ setStderr createPipe + $ shell "true" + _ <- waitExitCode p + stateVar <- newTVarIO (Idle 9) + let gp = + GhciProcess + { stdin = stdinW + , stdout = stdoutR + , stderr = stderrR + , handle = RunningProcess p + , stateVar + } + marker = "#~TRI-FINISH-9~#" :: Text + written <- + runEff + . runConcurrent + . runTimeout + . runDelay + . runFile + . runConc + $ do + -- Pre-seed the marker on both streams so the drain returns + -- immediately; we only care about what was written to stdin. + File.hPutTextLn stdoutW marker + File.hPutTextLn stderrW marker + File.hClose stdoutW + File.hClose stderrW + _ <- execGhci gp ":reload" (\_ -> pure ()) + File.hClose stdinW + let readAll acc = + trySync (File.hGetLine stdinR) >>= \case + Left (_ :: SomeException) -> pure (reverse acc) + Right l -> readAll (l : acc) + readAll [] + _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ()) + let blob = T.intercalate "\n" written + (" >> " `T.isInfixOf` blob) `shouldBe` False + ("System.IO.hPutStrLn System.IO.stdout" `T.isInfixOf` blob) `shouldBe` True + ("System.IO.hPutStrLn System.IO.stderr" `T.isInfixOf` blob) `shouldBe` True + + +-- | Regression: when the build command exits before printing a GHCi banner, +-- 'waitForBannerOrFail' must surface the *complete* stderr output in the +-- 'StartupFailed' error. The original implementation snapshotted the captured +-- lines as soon as the process exited (it waited on 'waitExitCode'), racing +-- the concurrent stderr drain — so a burst of error lines still buffered in +-- the pipe was truncated, and the real cabal/build failure was lost. +testWaitForBannerOrFail :: Spec +testWaitForBannerOrFail = + it "captures the full stderr output when the command exits before the banner" do + let lineCount = 200 :: Int + lastLine = "err line " <> show lineCount + -- The banner and error streams are pipes we drive ourselves, so the + -- timing is deterministic rather than a race against the OS pipe buffer. + (bannerOut, bannerOutW) <- Process.createPipe + (errR, errW) <- Process.createPipe + result <- + runEff + . runConcurrent + . runTimeout + . runDelay + . runFile + . runConc + $ do + -- No banner will ever arrive: close the write end so the + -- wait sees EOF at once and takes the "command exited" + -- failure branch. + File.hClose bannerOutW + -- Producer: pause long enough that a snapshot-at-exit reads + -- an empty buffer, THEN stream the whole error log and + -- close so the drain sees EOF. A correct implementation + -- awaits that drain before reading the captured lines. + _ <- Conc.fork do + Delay.wait (30 :: Millisecond) + for_ [1 .. lineCount] \i -> + File.hPutTextLn errW ("err line " <> show i :: Text) + File.hClose errW + trySync (waitForBannerOrFail (5 :: Second) bannerOut errR) + case result of + Right () -> expectationFailure "expected waitForBannerOrFail to throw a startup error" + Left ex -> case fromException ex of + Just (StartupFailed msg) -> + (lastLine `T.isInfixOf` msg) `shouldBe` True + other -> + expectationFailure ("expected StartupFailed, got: " <> show other) + + +-- | Regression for orphaned/zombie build subprocesses on restart and shutdown. +-- +-- The original leak was on the /graceful/ path: GHCi exits cleanly on @:quit@, +-- so its leader is reaped, yet the build subprocesses sharing its group linger. +-- 'withProcessGroup' must still sweep the whole group even after the leader has +-- gone. We simulate it with a leader that forks a long-lived child sharing its +-- group and exits on stdin input (mirroring @:quit@); after 'withProcessGroup' +-- returns, the child must be gone. +testWithProcessGroupCleanup :: Spec +testWithProcessGroupCleanup = + it "terminates the whole group on exit, even after the leader has exited" do + childPidRef <- newIORef (Nothing :: Maybe Int) + let scenario = + runEff + . runConcurrent + . runTimeout + . runDelay + . runFile + . runConc + . runProcessIO + $ withProcessGroup procConfig \p -> do + -- First stdout line is the long-lived child's pid. + line <- File.hGetLine (AProc.getStdout p) + liftIO $ writeIORef childPidRef (parsePid (T.unpack line)) + -- Let the leader exit and reap it, so the cleanup runs + -- with the leader already gone — the path the bug needed. + File.hPutTextLn (AProc.getStdin p) "" + File.hFlush (AProc.getStdin p) + void $ AProc.waitExitCode p + -- Hard wall-clock bound: a regression must surface as a failed + -- assertion, never as a hang that stalls the whole suite. + outcome <- System.Timeout.timeout (8_000_000) scenario + case outcome of + Nothing -> expectationFailure "test timed out (process did not settle)" + Just () -> + readIORef childPidRef >>= \case + Nothing -> expectationFailure "could not capture the child pid" + Just childPid -> do + died <- waitForProcessDeath childPid + -- Never leak the child if the assertion fails. + ignoring (signalProcess sigKILL (fromIntegral childPid)) + died `shouldBe` True + where + procConfig = + setStdin createPipe + $ setStdout createPipe + $ setStderr createPipe + $ shell "sleep 30 & echo \"$!\"; read _quit" + + +-- | 'terminateProcessGroup' must kill the whole group when called mid-flight +-- (the leader still alive) — the explicit early-termination path the test +-- runner uses to abort a one-shot @cabal repl test:…@ from another thread. +testTerminateProcessGroup :: Spec +testTerminateProcessGroup = + it "kills the whole group, not just the leader, mid-flight" do + outcome <- System.Timeout.timeout (8_000_000) do + p <- + startProcess + $ setStdin createPipe + $ setStdout createPipe + $ setStderr createPipe + $ setCreateGroup True + $ shell "sleep 30 & echo \"$!\"; read _quit" + childLine <- hGetLine (getStdout p) + case parsePid childLine of + Nothing -> do + ignoring (stopProcess p) + expectationFailure ("could not parse child pid from: " <> show childLine) + pure False + Just childPid -> do + runEff . runProcessIO $ terminateProcessGroup (RunningProcess p) + died <- waitForProcessDeath childPid + -- Never leak the child if the assertion fails. + ignoring (signalProcess sigKILL (fromIntegral childPid)) + pure died + outcome `shouldBe` Just True + + +-- | Parse a pid printed on its own line (tolerating surrounding whitespace). +parsePid :: String -> Maybe Int +parsePid = readMaybe . takeWhile isDigit . dropWhile (not . isDigit) + + +-- | Swallow any exception from a best-effort cleanup action. +ignoring :: IO () -> IO () +ignoring act = act `catch` \(_ :: SomeException) -> pure () + + +-- | Poll for up to ~3s for the given pid to disappear from the process table. +-- @signalProcess nullSignal@ is a liveness probe: it throws once the process is +-- gone (and reaped by init after being orphaned). +waitForProcessDeath :: Int -> IO Bool +waitForProcessDeath pid = go (60 :: Int) + where + go 0 = not <$> alive + go n = do + a <- alive + if not a then pure True else threadDelay 50_000 >> go (n - 1) + alive = + (signalProcess nullSignal (fromIntegral pid) >> pure True) + `catch` \(_ :: IOException) -> pure False + + +testDecideInterrupt :: Spec +testDecideInterrupt = do + -- Regression: an idle GHCi must not be SIGINT'd, since the matching + -- sync-marker write would leave a stale marker line in stdout/stderr + -- that the next 'execGhci' drain would match instead of the fresh one, + -- desyncing the protocol and reporting "0 modules" or hanging. + it "is a no-op when the session is Idle" do + decideInterrupt (Idle 7) `shouldBe` (Idle 7, NoOpIdle) + + it "preserves the counter for any Idle state" do + decideInterrupt (Idle 0) `shouldBe` (Idle 0, NoOpIdle) + decideInterrupt (Idle 42) `shouldBe` (Idle 42, NoOpIdle) + + it "advances to Idle (n+1) and emits SendInterruptFor n when Busy" do + decideInterrupt (Busy 7) `shouldBe` (Idle 8, SendInterruptFor 7) + + it "advances correctly from Busy 0" do + decideInterrupt (Busy 0) `shouldBe` (Idle 1, SendInterruptFor 0) + + +-- | Pins down the 'Conc.scoped' fix in 'execGhci': when the drain forks +-- raise 'UnexpectedExit' (because the underlying process exited and EOF'd +-- the pipes), the exception must be CONTAINED inside 'execGhci' and +-- surfaced via the caller's 'trySync' — not propagated to the ambient +-- 'Conc.scoped' that called 'execGhci'. +-- +-- Without the inner 'Conc.scoped' in 'execGhci', Ki propagates an +-- exception from a forked thread to its owning scope. If 'execGhci' forks +-- its drains directly into the ambient scope (the original bug), the +-- ambient scope is torn down — siblings die, the whole builder cycle +-- unwinds, and the daemon ends up in the "Restarting builder..." state +-- the user observed. +testExecGhciScope :: Spec +testExecGhciScope = + -- Spawn a real subprocess that exits immediately ('true'). Its + -- stdout/stderr pipes EOF as soon as the child exits, which makes + -- 'drainUntil' inside 'execGhci' throw 'UnexpectedExit' — exactly the + -- mid-command termination path the fix exists to handle. + it "contains drain exceptions inside its own scope so siblings survive" do + p <- + startProcess + $ setStdin createPipe + $ setStdout createPipe + $ setStderr createPipe + $ shell "true" + -- Wait for the child to actually exit so the pipes are EOF before + -- 'execGhci' starts draining (otherwise the drain blocks). + _ <- waitExitCode p + stateVar <- newTVarIO (Idle 0) + let gp = + GhciProcess + { stdin = getStdin p + , stdout = getStdout p + , stderr = getStderr p + , handle = RunningProcess p + , stateVar + } + siblingDoneRef <- newIORef False + result <- + runEff + . runConcurrent + . runTimeout + . runDelay + . runFile + . runConc + $ Conc.scoped do + -- A sibling fork in the SAME ambient scope. If the bug + -- regresses, the drain exception will tear this scope + -- down and the sibling will be cancelled before it can + -- flip the ref. + sibling <- Conc.fork do + Delay.wait (50 :: Millisecond) + liftIO (writeIORef siblingDoneRef True) + -- Drive 'execGhci' on a dead process; the drains should + -- raise 'UnexpectedExit', which 'trySync' must catch + -- here rather than letting Ki tear down the scope. + execResult <- trySync (execGhci gp "cmd" (\_ -> pure ())) + -- Wait for the sibling to run. + Conc.await sibling + pure execResult + -- stopProcess flushes the buffered command+marker to a pipe whose + -- read end is already closed, which raises ResourceVanished. The + -- subprocess has long since exited; just swallow the cleanup error. + _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ()) + siblingDone <- readIORef siblingDoneRef + siblingDone `shouldBe` True + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected execGhci to raise UnexpectedExit" diff --git a/test/Unit/Tricorder/Daemon/GhciSessionSpec.hs b/test/Unit/Tricorder/Daemon/GhciSessionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/GhciSessionSpec.hs @@ -0,0 +1,134 @@ +module Unit.Tricorder.Daemon.GhciSessionSpec (spec_GhciSession) where + +import Atelier.Effects.Publishing.Pub (Pub) +import Control.Exception (ErrorCall (..)) +import Effectful (IOE, runEff) +import Effectful.Exception (try) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +import Atelier.Effects.Publishing.Pub qualified as Pub +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + +import Tricorder.Build (BuildProgress, Diagnostic (..), Severity (..)) +import Tricorder.Daemon.GhciSession + ( Controls (..) + , GhciSession + , LoadResult (..) + , runGhciSessionScripted + , withGhci + ) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Command (Command (..)) + + +spec_GhciSession :: Spec +spec_GhciSession = do + describe "runGhciSessionScripted" testScripted + + +-------------------------------------------------------------------------------- +-- Scripted interpreter tests +-------------------------------------------------------------------------------- + +testScripted :: Spec +testScripted = do + describe "withGhci" do + describe "initial load" do + it "returns scripted messages" do + LoadResult {diagnostics = msgs} <- + runScripted [simpleResult [errMsg]] + $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial + msgs `shouldBe` [errMsg] + + it "returns empty list when scripted result has no messages" do + LoadResult {diagnostics = msgs} <- + runScripted [simpleResult []] + $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial + msgs `shouldBe` [] + + it "throws when scripted result is Left" do + result <- + runScripted [Left (toException boom)] + $ try @ErrorCall + $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial + result `shouldBe` Left boom + + describe "reloading" do + it "returns scripted messages" do + LoadResult {diagnostics = msgs} <- + runScripted [simpleResult [warnMsg], simpleResult [errMsg]] + $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload + msgs `shouldBe` [errMsg] + + it "throws when scripted result is Left" do + result <- + runScripted [Left (toException boom)] + $ try @ErrorCall + $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload + result `shouldBe` Left boom + + describe "sequencing" do + it "consumes results in order across mixed operations" do + (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do + withGhci (Command "cabal repl") (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do + LoadResult {diagnostics = b} <- controls.reload + pure (a, b) + a `shouldBe` [errMsg] + b `shouldBe` [warnMsg] + + it "recover scenario: error then success" do + result <- runScripted [Left (toException boom), simpleResult []] do + r1 <- try @ErrorCall $ withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i + LoadResult {diagnostics = r2} <- withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i + pure (r1, r2) + fst result `shouldSatisfy` isLeft + snd result `shouldBe` [] + + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +boom :: ErrorCall +boom = ErrorCall "simulated GHCi crash" + + +errMsg :: Diagnostic +errMsg = + Diagnostic + { severity = SError + , file = "src/Foo.hs" + , line = 1 + , col = 1 + , endLine = 1 + , endCol = 5 + , title = "Variable not in scope: foo" + , text = "Variable not in scope: foo" + } + + +warnMsg :: Diagnostic +warnMsg = + Diagnostic + { severity = SWarning + , file = "src/Bar.hs" + , line = 10 + , col = 3 + , endLine = 10 + , endCol = 8 + , title = "Unused import" + , text = "Unused import" + } + + +-- | Convenience constructor: a scripted result with no compiled-file info. +simpleResult :: [Diagnostic] -> Either SomeException LoadResult +simpleResult msgs = Right LoadResult {moduleCount = 0, compiledFiles = Set.empty, loadedModules = Map.empty, targetNames = [], diagnostics = msgs} + + +runScripted + :: [Either SomeException LoadResult] + -> Eff '[GhciSession, Pub BuildProgress, IOE] a + -> IO a +runScripted results = runEff . Pub.runNoOp . runGhciSessionScripted results diff --git a/test/Unit/Tricorder/Daemon/TestRunnerSpec.hs b/test/Unit/Tricorder/Daemon/TestRunnerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/TestRunnerSpec.hs @@ -0,0 +1,186 @@ +module Unit.Tricorder.Daemon.TestRunnerSpec (spec_TestRunner) where + +import Control.Exception (ErrorCall (..)) +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Effectful.Exception (try) +import Test.Hspec + +import Tricorder.Daemon.TestRunner + ( GhciOutcome (..) + , TestRunner + , detectOutcome + , runTestSuite + ) +import Tricorder.Session.Target (Target (..)) +import Tricorder.Session.TestTarget (TestTarget (..)) +import Tricorder.Session.TestTimeout (TestTimeout (..)) + +import Tricorder.Build.Test qualified as Test +import Tricorder.Daemon.TestRunner qualified as TestRunner + + +spec_TestRunner :: Spec +spec_TestRunner = do + describe "detectOutcome" testDetectOutcome + describe "runScripted" testScripted + + +-------------------------------------------------------------------------------- +-- detectOutcome tests +-------------------------------------------------------------------------------- + +testDetectOutcome :: Spec +testDetectOutcome = do + describe "no exception line" do + it "treats empty output as pass" do + detectOutcome "" `shouldBe` GhciPassed + + it "treats output with no exception as pass" do + detectOutcome "2 examples, 0 failures\n" `shouldBe` GhciPassed + + it "does not match 'ExitSuccess' without the exception prefix" do + detectOutcome "ExitSuccess\n" `shouldBe` GhciPassed + + describe "ExitSuccess" do + it "detects ExitSuccess as pass" do + detectOutcome "*** Exception: ExitSuccess\n" `shouldBe` GhciPassed + + it "detects ExitSuccess anywhere in output" do + detectOutcome "All tests passed\n*** Exception: ExitSuccess\n" + `shouldBe` GhciPassed + + describe "ExitFailure" do + it "detects ExitFailure 1 as fail" do + detectOutcome "1 failure\n*** Exception: ExitFailure 1\n" + `shouldBe` GhciFailed + + it "detects ExitFailure with any exit code as fail" do + detectOutcome "*** Exception: ExitFailure 42\n" `shouldBe` GhciFailed + + it "detects ExitFailure anywhere in output" do + detectOutcome "Some output\n*** Exception: ExitFailure 1\nMore output\n" + `shouldBe` GhciFailed + + describe "other exception" do + it "classifies unknown exception as error with message" do + detectOutcome "*** Exception: SomeException \"oops\"\n" + `shouldBe` GhciCrashed "SomeException \"oops\"" + + it "trims trailing whitespace from the error message" do + detectOutcome "*** Exception: Crashed \n" + `shouldBe` GhciCrashed "Crashed" + + describe "compile failure (no exception line, but GHC errors present)" do + it "flags ':main not in scope' as crashed" do + detectOutcome ":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 noProgress testTimeout + $ mkTestTarget "test:foo" + result `shouldBe` passingRun + + it "ignores the target name argument" do + result <- + runScripted [Right failingRun] + $ runTestSuite noProgress testTimeout + $ mkTestTarget "test:anything" + result `shouldBe` failingRun + + it "throws when scripted result is Left" do + result <- + runScripted [Left (toException boom)] + $ try @ErrorCall + $ runTestSuite noProgress testTimeout + $ mkTestTarget "test:foo" + result `shouldBe` Left boom + + describe "sequencing" do + it "consumes results in order across multiple calls" do + (a, b) <- runScripted [Right passingRun, Right failingRun] do + a <- runTestSuite noProgress testTimeout $ mkTestTarget "test:foo" + b <- runTestSuite noProgress testTimeout $ mkTestTarget "test:bar" + pure (a, b) + a `shouldBe` passingRun + b `shouldBe` failingRun + + it "recover scenario: error then success" do + result <- runScripted [Left (toException boom), Right passingRun] do + r1 <- try @ErrorCall $ runTestSuite noProgress testTimeout $ mkTestTarget "test:foo" + r2 <- runTestSuite noProgress testTimeout $ mkTestTarget "test:bar" + pure (r1, r2) + fst result `shouldBe` Left boom + snd result `shouldBe` passingRun + + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +boom :: ErrorCall +boom = ErrorCall "simulated process crash" + + +passingRun :: Test.Suite +passingRun = + Test.SuiteCompleted + $ Test.SuiteCompletion + { passed = True + , output = "2 examples, 0 failures\n" + , testCases = [] + , duration = Nothing + } + + +failingRun :: Test.Suite +failingRun = + Test.SuiteCompleted + $ Test.SuiteCompletion + { passed = False + , output = "1 example, 1 failure\n" + , testCases = [] + , duration = Nothing + } + + +runScripted :: [Either SomeException Test.Suite] -> Eff '[TestRunner, Concurrent, IOE] a -> IO a +runScripted results = runEff . runConcurrent . TestRunner.runScripted results + + +mkTestTarget :: Text -> TestTarget +mkTestTarget = TestTarget . Bare + + +testTimeout :: TestTimeout +testTimeout = TestTimeout (-1) + + +noProgress :: b -> Eff es () +noProgress = const $ pure () diff --git a/test/Unit/Tricorder/Daemon/WatchSpec.hs b/test/Unit/Tricorder/Daemon/WatchSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Daemon/WatchSpec.hs @@ -0,0 +1,150 @@ +module Unit.Tricorder.Daemon.WatchSpec (spec_Watch) where + +import Atelier.Effects.FileWatcher (FileEvent (..), matchesAny) +import Effectful (runEff) +import Effectful.Writer.Static.Shared (execWriter, runWriter) +import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList) +import Text.Regex.TDFA.ReadRegex (parseRegex) + +import Atelier.Effects.Publishing.Pub qualified as Pub + +import Tricorder.Build.Changes + ( CabalChangeDetected (..) + , SourceChangeDetected (..) + ) +import Tricorder.Daemon.Watch (WatchedFile (..)) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.WatchDirs (WatchDirs (..)) +import Tricorder.Session.WatchExclusionPatterns (WatchExclusionPatterns (..)) + +import Tricorder.Daemon.Watch qualified as Watch + + +spec_Watch :: Spec +spec_Watch = do + describe "publishChange" testPublishChange + describe "specs" testSpecs + + +testPublishChange :: Spec +testPublishChange = do + describe "with non-cabal file change" $ it "should publish SourceChangeDetected" do + (_, sourceChanges) <- runTest "foo" + sourceChanges `shouldMatchList` [SourceChangeDetected "foo" Modified] + + describe "with cabal file change" $ it "should publish CabalChangeDetected" do + (cabalChanges, _) <- runTest "foo.cabal" + cabalChanges `shouldMatchList` [CabalChangeDetected "foo.cabal" Modified] + where + runTest = + runEff + . runWriter + . Pub.toWriter @SourceChangeDetected + . execWriter + . Pub.toWriter @CabalChangeDetected + . Watch.publishChange + . (`WatchedFile` Modified) + + +testSpecs :: Spec +testSpecs = do + describe "source watches" do + it "matches .hs files in configured watch dirs" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs ["/proj/src"]) + matchesAny watches "/proj/src/Foo.hs" `shouldBe` True + + it "does not match non-.hs files" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs ["/proj/src"]) + matchesAny watches "/proj/src/Foo.txt" `shouldBe` False + + it "excludes paths containing dist-newstyle" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs ["/proj/src"]) + matchesAny watches "/proj/src/dist-newstyle/Foo.hs" `shouldBe` False + + it "excludes paths matching an exclusion pattern" do + let pat = parsePattern "vendor" + watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns [pat]) + (WatchDirs ["/proj/src"]) + matchesAny watches "/proj/src/vendor/Foo.hs" `shouldBe` False + matchesAny watches "/proj/src/Foo.hs" `shouldBe` True + + it "matches .hs files across multiple watch dirs" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs ["/proj/src", "/proj/test"]) + matchesAny watches "/proj/src/Foo.hs" `shouldBe` True + matchesAny watches "/proj/test/FooSpec.hs" `shouldBe` True + + -- Second line of defense: 'cabalWatches' registers the whole project + -- root, and 'deduplicateDirs' collapses the narrow source dirs into it, + -- so the OS watches the entire repo recursively. 'matchesAny' is what + -- re-scopes events back to the configured dirs — a .hs file in a sibling + -- package must not match. + it "does not match a .hs file in a sibling package outside the watch dirs" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs ["/proj/pkg-a/src"]) + matchesAny watches "/proj/pkg-a/src/Foo.hs" `shouldBe` True + matchesAny watches "/proj/pkg-b/src/Foo.hs" `shouldBe` False + + describe "cabal watches" do + it "matches .cabal files under project root" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs []) + matchesAny watches "/proj/foo.cabal" `shouldBe` True + + it "matches cabal.project under project root" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs []) + matchesAny watches "/proj/cabal.project" `shouldBe` True + + it "matches package.yaml under project root" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs []) + matchesAny watches "/proj/package.yaml" `shouldBe` True + + it "does not match non-cabal files" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs []) + matchesAny watches "/proj/README.md" `shouldBe` False + + it "excludes cabal files under dist-newstyle" do + let watches = + Watch.specs + (ProjectRoot "/proj") + (WatchExclusionPatterns []) + (WatchDirs []) + matchesAny watches "/proj/dist-newstyle/foo.cabal" `shouldBe` False + where + parsePattern p = fromRight (error . toText $ "bad test pattern: " <> p) (parseRegex p) diff --git a/test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs b/test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/Effects/GhciSession/GhciParserSpec.hs +++ /dev/null @@ -1,421 +0,0 @@ -module Unit.Tricorder.Effects.GhciSession.GhciParserSpec (spec_GhciParser) where - -import Test.Hspec - -import Tricorder.BuildState (Diagnostic (..), Severity (..)) -import Tricorder.Effects.GhciSession.GhciParser - ( GhciLoad (..) - , GhciLoading (..) - , GhciMessage (..) - , GhciSeverity (..) - , LoadOutcome (..) - , LoadResult (..) - , Position (..) - , collectResult - , collectResultCustom - , parseReload - , parseShowModules - , parseShowTargets - ) - - -spec_GhciParser :: Spec -spec_GhciParser = do - describe "parseReload" do - describe "clean build" testCleanBuild - describe "with errors and warnings" testErrors - describe "with -fhide-source-paths (no Loading items)" testHideSourcePaths - describe "with errors" testNoLocationInfo - describe "with Loaded GHCi configuration" testLoadedConfig - - describe "parseShowModules" do - describe "typical output" testShowModules - describe "empty / blank input" testShowModulesEmpty - - describe "parseShowTargets" testShowTargets - - describe "collectResultCustom" do - describe " plugin load failure" testPluginLoadFailure - - describe "collectResult" do - describe "failed load with no located error" testUnattributedFailure - - --------------------------------------------------------------------------------- --- parseReload: clean build --------------------------------------------------------------------------------- - -testCleanBuild :: Spec -testCleanBuild = do - it "produces GLoading items for each compiled module" do - let input = - [ "[1 of 3] Compiling Tricorder.BuildState ( src/Tricorder/BuildState.hs, interpreted )" - , "[2 of 3] Compiling Tricorder.Session ( src/Tricorder/Session.hs, interpreted )" - , "[3 of 3] Compiling Main ( app/Main.hs, interpreted )" - , "Ok, 3 modules loaded." - ] - parseReload input - `shouldBe` [ GLoading GhciLoading {index = 1, total = 3, moduleName = "Tricorder.BuildState", sourceFile = "src/Tricorder/BuildState.hs"} - , GLoading GhciLoading {index = 2, total = 3, moduleName = "Tricorder.Session", sourceFile = "src/Tricorder/Session.hs"} - , GLoading GhciLoading {index = 3, total = 3, moduleName = "Main", sourceFile = "app/Main.hs"} - , GSummary LoadSucceeded - ] - - it "handles padded module index (e.g. [ 1 of 47])" do - let input = - [ "[ 1 of 47] Compiling Main ( app/Main.hs, interpreted )" - , "Ok, 1 module loaded." - ] - parseReload input - `shouldBe` [ GLoading GhciLoading {index = 1, total = 47, moduleName = "Main", sourceFile = "app/Main.hs"} - , GSummary LoadSucceeded - ] - - describe "when only summary line" $ it "returns the summary outcome" do - parseReload ["Ok, 0 modules loaded."] `shouldBe` [GSummary LoadSucceeded] - - --------------------------------------------------------------------------------- --- parseReload: errors and warnings --------------------------------------------------------------------------------- - -testErrors :: Spec -testErrors = do - it "parses a single-line error" do - let input = ["src/Foo.hs:10:5: error: Variable not in scope: foo"] - parseReload input - `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Foo.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]}] - - it "parses a warning with continuation lines" do - let input = - [ "src/Bar.hs:20:3: warning: [-Wunused-imports]" - , " Redundant import: Data.List" - , " Perhaps you want to remove it." - ] - parseReload input - `shouldBe` [ GMessage - GhciMessage - { severity = GWarning - , file = "src/Bar.hs" - , startPos = Position 20 3 - , endPos = Position 20 3 - , messageLines = - [ "src/Bar.hs:20:3: warning: [-Wunused-imports]" - , " Redundant import: Data.List" - , " Perhaps you want to remove it." - ] - } - ] - - it "parses a span position (L:C-C2:)" do - let input = ["src/Baz.hs:5:1-10: error: Parse error"] - parseReload input - `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Baz.hs", startPos = Position 5 1, endPos = Position 5 10, messageLines = ["src/Baz.hs:5:1-10: error: Parse error"]}] - - it "parses a span position ((L1,C1)-(L2,C2):)" do - let input = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"] - parseReload input - `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Qux.hs", startPos = Position 3 1, endPos = Position 5 20, messageLines = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]}] - - it "parses a span position with double-paren end ((L1,C1)-((L2,C2):)" do - let input = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"] - parseReload input - `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Qux.hs", startPos = Position 3 1, endPos = Position 5 20, messageLines = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]}] - - it "parses source-display continuation lines (pipe format)" do - let input = - [ "src/Foo.hs:10:5: error: Variable not in scope: foo" - , " |" - , "10 | foo bar" - , " | ^^^" - , " Suggested fix: import Foo" - ] - parseReload input - `shouldBe` [ GMessage - GhciMessage - { severity = GError - , file = "src/Foo.hs" - , startPos = Position 10 5 - , endPos = Position 10 5 - , messageLines = - [ "src/Foo.hs:10:5: error: Variable not in scope: foo" - , " |" - , "10 | foo bar" - , " | ^^^" - , " Suggested fix: import Foo" - ] - } - ] - - it "strips ANSI codes from header for matching but stores original in glMessage" do - let ansiHeader = "\ESC[1msrc/Foo.hs:10:5:\ESC[0m \ESC[91merror:\ESC[0m Variable not in scope: foo" - parseReload [ansiHeader] - `shouldBe` [GMessage GhciMessage {severity = GError, file = "src/Foo.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = [ansiHeader]}] - - it "parses a Windows drive-letter path in a diagnostic" do - let input = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"] - parseReload input - `shouldBe` [GMessage GhciMessage {severity = GError, file = "C:\\path\\file.hs", startPos = Position 10 5, endPos = Position 10 5, messageLines = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]}] - - it "parses mixed Loading, Message, and summary items" do - let input = - [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )" - , "src/Lib.hs:5:1: error: Oops" - , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )" - , "Failed, 1 module loaded." - ] - parseReload input - `shouldBe` [ GLoading GhciLoading {index = 1, total = 2, moduleName = "Lib", sourceFile = "src/Lib.hs"} - , GMessage GhciMessage {severity = GError, file = "src/Lib.hs", startPos = Position 5 1, endPos = Position 5 1, messageLines = ["src/Lib.hs:5:1: error: Oops"]} - , GLoading GhciLoading {index = 2, total = 2, moduleName = "Main", sourceFile = "app/Main.hs"} - , GSummary LoadFailed - ] - - --------------------------------------------------------------------------------- --- parseReload: -fhide-source-paths output --------------------------------------------------------------------------------- - -testHideSourcePaths :: Spec -testHideSourcePaths = do - describe "when source paths are hidden" $ it "produces no GLoading items" do - let input = - [ "src/Foo.hs:10:5: error: Variable not in scope: foo" - , " Perhaps you meant: 'bar'" - , "Failed, one module failed to load." - ] - parseReload input - `shouldBe` [ GMessage - GhciMessage - { severity = GError - , file = "src/Foo.hs" - , startPos = Position 10 5 - , endPos = Position 10 5 - , messageLines = - [ "src/Foo.hs:10:5: error: Variable not in scope: foo" - , " Perhaps you meant: 'bar'" - ] - } - , GSummary LoadFailed - ] - - describe "when all modules are already up to date" $ it "returns the summary outcome" do - -- GHCi with -fhide-source-paths and nothing to recompile - parseReload ["Ok, 5 modules loaded."] `shouldBe` [GSummary LoadSucceeded] - - --------------------------------------------------------------------------------- --- parseReload: 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"} - , GSummary LoadSucceeded - ] - - --------------------------------------------------------------------------------- --- parseShowModules --------------------------------------------------------------------------------- - -testShowModules :: Spec -testShowModules = do - it "parses typical :show modules output" do - let input = - [ "Tricorder.BuildState ( src/Tricorder/BuildState.hs, interpreted )" - , "Tricorder.Session ( src/Tricorder/Session.hs, interpreted )" - , "Main ( app/Main.hs, interpreted )" - ] - parseShowModules input - `shouldBe` [ ("Tricorder.BuildState", "src/Tricorder/BuildState.hs") - , ("Tricorder.Session", "src/Tricorder/Session.hs") - , ("Main", "app/Main.hs") - ] - - it "parses absolute paths" do - parseShowModules ["Lib ( /home/user/project/src/Lib.hs, interpreted )"] - `shouldBe` [("Lib", "/home/user/project/src/Lib.hs")] - - it "strips ANSI codes before parsing" do - parseShowModules ["\ESC[1mMain\ESC[0m ( app/Main.hs, interpreted )"] - `shouldBe` [("Main", "app/Main.hs")] - - -testShowModulesEmpty :: Spec -testShowModulesEmpty = do - it "returns empty list for empty input" do - parseShowModules [] `shouldBe` [] - - it "returns empty list for blank lines" do - parseShowModules ["", " ", "\t"] `shouldBe` [] - - it "skips lines without '( '" do - parseShowModules ["just some random text"] `shouldBe` [] - - --------------------------------------------------------------------------------- --- parseShowTargets --------------------------------------------------------------------------------- - -testShowTargets :: Spec -testShowTargets = do - it "parses module names emitted by cabal repl --enable-multi-repl" do - parseShowTargets - [ "Atelier.Effects.Cache" - , "Atelier.Effects.Chan" - , "Paths_tricorder" - ] - `shouldBe` ["Atelier.Effects.Cache", "Atelier.Effects.Chan", "Paths_tricorder"] - - it "parses file-path targets emitted by plain ghci" do - parseShowTargets ["src/Foo.hs", "test/Bar.hs"] - `shouldBe` ["src/Foo.hs", "test/Bar.hs"] - - it "strips the leading '*' marker for the active interactive target" do - parseShowTargets ["*Main", "Foo.Bar"] `shouldBe` ["Main", "Foo.Bar"] - - it "strips ANSI escape sequences" do - parseShowTargets ["\ESC[1mFoo.Bar\ESC[0m"] `shouldBe` ["Foo.Bar"] - - it "skips blank and whitespace-only lines" do - parseShowTargets ["", " ", "\t", "Real.Target"] `shouldBe` ["Real.Target"] - - it "returns empty list for empty input" do - parseShowTargets [] `shouldBe` [] - - --------------------------------------------------------------------------------- --- collectResultCustom: plugin load failure --------------------------------------------------------------------------------- - --- | Regression test for the \"All good\" bug with home-unit GHC plugins. --- --- Under @cabal repl --enable-multi-repl@ every unit is interpreted, so a --- package used as a GHC plugin in the same project is not available as a --- compiled plugin. The unit that depends on it fails to load, GHCi reports the --- failure with @\@ (it has no source span), and the load --- ends with @Failed, N modules loaded@. This output must still surface as an --- error diagnostic — otherwise the build is silently reported as clean. -testPluginLoadFailure :: Spec -testPluginLoadFailure = do - -- Shape of the GHCi output from `cabal repl --enable-multi-repl` when an - -- executable loads a home-unit GHC plugin: the plugin package's modules - -- compile, then the unit using the plugin fails with a location-less error. - let reloadOutput = - [ "[3 of 5] Compiling My.Plugin ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]" - , ": error:" - , " Could not load module \8216My.Plugin\8217." - , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217." - , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file." - , "Use -v to see a list of the files searched for." - , "" - , "[5 of 5] Compiling Main ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]" - , "Failed, 4 modules loaded." - ] - result = collectResultCustom "/project" (parseReload reloadOutput) [] [] - - it "surfaces the plugin load failure as an error diagnostic" do - map (.severity) result.diagnostics `shouldContain` [SError] - - it "carries the plugin error message in the diagnostic title" do - map (.title) result.diagnostics - `shouldContain` ["Could not load module \8216My.Plugin\8217."] - - --------------------------------------------------------------------------------- --- collectResult: failed load with no located error --------------------------------------------------------------------------------- - --- 'collectResult' is the safety net: GHCi can end a load with @Failed, …@ --- without emitting any error that carries a source span. The build must never --- read as clean in that case, so a synthetic error diagnostic is added. -testUnattributedFailure :: Spec -testUnattributedFailure = do - describe "when the load failed but no error was located" $ it "adds a synthetic error" do - let reloadOutput = - [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )" - , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )" - , "Failed, 1 module loaded." - ] - result = collectResult "/project" reloadOutput [] [] - map (.severity) result.diagnostics `shouldBe` [SError] - - it "does not duplicate a failure that already produced a located error" do - let reloadOutput = - [ "[1 of 1] Compiling Lib ( src/Lib.hs, interpreted )" - , "src/Lib.hs:5:1: error: Oops" - , "Failed, 0 modules loaded." - ] - result = collectResult "/project" reloadOutput [] [] - -- Only the real, located diagnostic — no synthetic one appended. - map (.file) result.diagnostics `shouldBe` ["src/Lib.hs"] - - it "adds nothing for a successful load" do - let reloadOutput = - [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )" - , "Ok, 1 module loaded." - ] - result = collectResult "/project" reloadOutput [] [] - result.diagnostics `shouldBe` [] - - describe "when 'Failed,' appears off the summary line" $ it "does not flag a clean build" do - -- The load outcome lives on GHCi's single summary line - -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a - -- Template Haskell splice or top-level IO run while interpreting — can - -- contain a line that happens to begin with "Failed,". That must not be - -- mistaken for a failed load: the summary here is "Ok," so no synthetic - -- error belongs. - let reloadOutput = - [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )" - , "Failed, retrying with fallback" -- printed by a TH splice - , "Ok, 1 module loaded." - ] - result = collectResult "/project" reloadOutput [] [] - result.diagnostics `shouldBe` [] diff --git a/test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs b/test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/Effects/GhciSession/GhciProcessSpec.hs +++ /dev/null @@ -1,422 +0,0 @@ -module Unit.Tricorder.Effects.GhciSession.GhciProcessSpec (spec_GhciProcess) where - -import Atelier.Effects.Conc (runConc) -import Atelier.Effects.Delay (runDelay) -import Atelier.Effects.File (runFile) -import Atelier.Effects.Process (runProcessIO, terminateProcessGroup, withProcessGroup) -import Atelier.Effects.Process.Internal (RunningProcess (..)) -import Atelier.Effects.Timeout (runTimeout) -import Atelier.Time (Millisecond) -import Control.Concurrent (threadDelay) -import Control.Concurrent.STM (newTVarIO) -import Control.Exception (IOException, catch) -import Data.Char (isDigit) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Time.Units (Second) -import Effectful (runEff) -import Effectful.Concurrent (runConcurrent) -import Effectful.Exception (trySync) -import System.IO (hGetLine) -import System.Posix.Signals (nullSignal, sigKILL, signalProcess) -import System.Process.Typed - ( createPipe - , getStderr - , getStdin - , getStdout - , setCreateGroup - , setStderr - , setStdin - , setStdout - , shell - , startProcess - , stopProcess - , waitExitCode - ) -import Test.Hspec - -import Atelier.Effects.Conc qualified as Conc -import Atelier.Effects.Delay qualified as Delay -import Atelier.Effects.File qualified as File -import Atelier.Effects.Process qualified as AProc -import Data.Text qualified as T -import System.Process qualified as Process -import System.Timeout qualified - -import Tricorder.Effects.GhciSession.GhciProcess - ( GhciProcess (..) - , GhciProcessError (..) - , InterruptDecision (..) - , SessionState (..) - , decideInterrupt - , execGhci - , waitForBannerOrFail - ) - - -spec_GhciProcess :: Spec -spec_GhciProcess = do - describe "decideInterrupt" testDecideInterrupt - describe "execGhci" testExecGhciScope - describe "execGhci (stale marker desync)" testExecGhciStaleMarker - describe "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent - describe "waitForBannerOrFail" testWaitForBannerOrFail - describe "withProcessGroup (process group)" testWithProcessGroupCleanup - describe "terminateProcessGroup (process group)" testTerminateProcessGroup - - --- | Regression for the touch-during-reload desync. Interrupting a *Busy* GHCi --- (a reload in flight) leaves a stale sync marker in the stdout/stderr buffers --- ahead of the next command's real output. Because 'drainUntil' used to stop on --- ANY marker-prefix line, the next 'execGhci' matched that stale marker and --- returned *before its command ran* — surfacing as @All good. (0 modules)@ (or, --- on the other timing, a hang). 'execGhci' must skip markers that aren't its --- own and stop only on the marker it is waiting for. -testExecGhciStaleMarker :: Spec -testExecGhciStaleMarker = - it "skips a stale leftover marker and returns the command's real output" do - (stdinR, stdinW) <- Process.createPipe - (stdoutR, stdoutW) <- Process.createPipe - (stderrR, stderrW) <- Process.createPipe - -- A dummy process handle to fill the record; 'execGhci' never uses it. - p <- - startProcess - $ setStdin createPipe - $ setStdout createPipe - $ setStderr createPipe - $ shell "true" - _ <- waitExitCode p - stateVar <- newTVarIO (Idle 9) - let gp = - GhciProcess - { stdin = stdinW - , stdout = stdoutR - , stderr = stderrR - , handle = RunningProcess p - , stateVar - } - -- Mirrors 'markerFor': "#~TRI-FINISH-~#". - marker n = "#~TRI-FINISH-" <> show (n :: Int) <> "~#" :: Text - result <- - runEff - . runConcurrent - . runTimeout - . runDelay - . runFile - . runConc - $ do - -- A stale 'marker 5' (left by a prior interrupted reload) - -- precedes the fresh command's real output + its 'marker 9' - -- (state is 'Idle 9', so 'execGhci' waits for marker 9). - for_ [marker 5, "out-line", marker 9] (File.hPutTextLn stdoutW) - for_ [marker 5, "err-line", marker 9] (File.hPutTextLn stderrW) - File.hClose stdoutW - File.hClose stderrW - -- Keep the stdin read-end alive across the write inside - -- 'execGhci' (otherwise it is GC-finalised → broken pipe). - r <- execGhci gp "reload" (\_ -> pure ()) - File.hClose stdinR - pure r - _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ()) - result `shouldBe` ["out-line", "err-line"] - - --- | Root-cause regression for the "stuck Building…" stall. A SIGINT-interrupted --- ':reload' empties GHCi's interactive scope — it drops the implicit --- @import Prelude@ (verified against ghci 9.10). A sync marker built from bare --- Prelude names then fails to run instead of printing: @putStrLn@ is no longer --- in scope, and neither is the @>>@ operator. The marker never appears, so --- 'drainUntil' blocks until the watchdog fires. The marker must therefore use --- only fully-qualified 'System.IO.hPutStrLn' statements (which survive the --- emptied scope), one per stream, with no bare names or operators. --- --- We assert on exactly what 'execGhci' writes to GHCi's stdin. -testSyncMarkerScopeIndependent :: Spec -testSyncMarkerScopeIndependent = - it "writes the finish marker using only fully-qualified names (no bare putStrLn / >>)" do - (stdinR, stdinW) <- Process.createPipe - (stdoutR, stdoutW) <- Process.createPipe - (stderrR, stderrW) <- Process.createPipe - p <- - startProcess - $ setStdin createPipe - $ setStdout createPipe - $ setStderr createPipe - $ shell "true" - _ <- waitExitCode p - stateVar <- newTVarIO (Idle 9) - let gp = - GhciProcess - { stdin = stdinW - , stdout = stdoutR - , stderr = stderrR - , handle = RunningProcess p - , stateVar - } - marker = "#~TRI-FINISH-9~#" :: Text - written <- - runEff - . runConcurrent - . runTimeout - . runDelay - . runFile - . runConc - $ do - -- Pre-seed the marker on both streams so the drain returns - -- immediately; we only care about what was written to stdin. - File.hPutTextLn stdoutW marker - File.hPutTextLn stderrW marker - File.hClose stdoutW - File.hClose stderrW - _ <- execGhci gp ":reload" (\_ -> pure ()) - File.hClose stdinW - let readAll acc = - trySync (File.hGetLine stdinR) >>= \case - Left (_ :: SomeException) -> pure (reverse acc) - Right l -> readAll (l : acc) - readAll [] - _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ()) - let blob = T.intercalate "\n" written - (" >> " `T.isInfixOf` blob) `shouldBe` False - ("System.IO.hPutStrLn System.IO.stdout" `T.isInfixOf` blob) `shouldBe` True - ("System.IO.hPutStrLn System.IO.stderr" `T.isInfixOf` blob) `shouldBe` True - - --- | Regression: when the build command exits before printing a GHCi banner, --- 'waitForBannerOrFail' must surface the *complete* stderr output in the --- 'StartupFailed' error. The original implementation snapshotted the captured --- lines as soon as the process exited (it waited on 'waitExitCode'), racing --- the concurrent stderr drain — so a burst of error lines still buffered in --- the pipe was truncated, and the real cabal/build failure was lost. -testWaitForBannerOrFail :: Spec -testWaitForBannerOrFail = - it "captures the full stderr output when the command exits before the banner" do - let lineCount = 200 :: Int - lastLine = "err line " <> show lineCount - -- The banner and error streams are pipes we drive ourselves, so the - -- timing is deterministic rather than a race against the OS pipe buffer. - (bannerOut, bannerOutW) <- Process.createPipe - (errR, errW) <- Process.createPipe - result <- - runEff - . runConcurrent - . runTimeout - . runDelay - . runFile - . runConc - $ do - -- No banner will ever arrive: close the write end so the - -- wait sees EOF at once and takes the "command exited" - -- failure branch. - File.hClose bannerOutW - -- Producer: pause long enough that a snapshot-at-exit reads - -- an empty buffer, THEN stream the whole error log and - -- close so the drain sees EOF. A correct implementation - -- awaits that drain before reading the captured lines. - _ <- Conc.fork do - Delay.wait (30 :: Millisecond) - for_ [1 .. lineCount] \i -> - File.hPutTextLn errW ("err line " <> show i :: Text) - File.hClose errW - trySync (waitForBannerOrFail (5 :: Second) bannerOut errR) - case result of - Right () -> expectationFailure "expected waitForBannerOrFail to throw a startup error" - Left ex -> case fromException ex of - Just (StartupFailed msg) -> - (lastLine `T.isInfixOf` msg) `shouldBe` True - other -> - expectationFailure ("expected StartupFailed, got: " <> show other) - - --- | Regression for orphaned/zombie build subprocesses on restart and shutdown. --- --- The original leak was on the /graceful/ path: GHCi exits cleanly on @:quit@, --- so its leader is reaped, yet the build subprocesses sharing its group linger. --- 'withProcessGroup' must still sweep the whole group even after the leader has --- gone. We simulate it with a leader that forks a long-lived child sharing its --- group and exits on stdin input (mirroring @:quit@); after 'withProcessGroup' --- returns, the child must be gone. -testWithProcessGroupCleanup :: Spec -testWithProcessGroupCleanup = - it "terminates the whole group on exit, even after the leader has exited" do - childPidRef <- newIORef (Nothing :: Maybe Int) - let scenario = - runEff - . runConcurrent - . runTimeout - . runDelay - . runFile - . runConc - . runProcessIO - $ withProcessGroup procConfig \p -> do - -- First stdout line is the long-lived child's pid. - line <- File.hGetLine (AProc.getStdout p) - liftIO $ writeIORef childPidRef (parsePid (T.unpack line)) - -- Let the leader exit and reap it, so the cleanup runs - -- with the leader already gone — the path the bug needed. - File.hPutTextLn (AProc.getStdin p) "" - File.hFlush (AProc.getStdin p) - void $ AProc.waitExitCode p - -- Hard wall-clock bound: a regression must surface as a failed - -- assertion, never as a hang that stalls the whole suite. - outcome <- System.Timeout.timeout (8_000_000) scenario - case outcome of - Nothing -> expectationFailure "test timed out (process did not settle)" - Just () -> - readIORef childPidRef >>= \case - Nothing -> expectationFailure "could not capture the child pid" - Just childPid -> do - died <- waitForProcessDeath childPid - -- Never leak the child if the assertion fails. - ignoring (signalProcess sigKILL (fromIntegral childPid)) - died `shouldBe` True - where - procConfig = - setStdin createPipe - $ setStdout createPipe - $ setStderr createPipe - $ shell "sleep 30 & echo \"$!\"; read _quit" - - --- | 'terminateProcessGroup' must kill the whole group when called mid-flight --- (the leader still alive) — the explicit early-termination path the test --- runner uses to abort a one-shot @cabal repl test:…@ from another thread. -testTerminateProcessGroup :: Spec -testTerminateProcessGroup = - it "kills the whole group, not just the leader, mid-flight" do - outcome <- System.Timeout.timeout (8_000_000) do - p <- - startProcess - $ setStdin createPipe - $ setStdout createPipe - $ setStderr createPipe - $ setCreateGroup True - $ shell "sleep 30 & echo \"$!\"; read _quit" - childLine <- hGetLine (getStdout p) - case parsePid childLine of - Nothing -> do - ignoring (stopProcess p) - expectationFailure ("could not parse child pid from: " <> show childLine) - pure False - Just childPid -> do - runEff . runProcessIO $ terminateProcessGroup (RunningProcess p) - died <- waitForProcessDeath childPid - -- Never leak the child if the assertion fails. - ignoring (signalProcess sigKILL (fromIntegral childPid)) - pure died - outcome `shouldBe` Just True - - --- | Parse a pid printed on its own line (tolerating surrounding whitespace). -parsePid :: String -> Maybe Int -parsePid = readMaybe . takeWhile isDigit . dropWhile (not . isDigit) - - --- | Swallow any exception from a best-effort cleanup action. -ignoring :: IO () -> IO () -ignoring act = act `catch` \(_ :: SomeException) -> pure () - - --- | Poll for up to ~3s for the given pid to disappear from the process table. --- @signalProcess nullSignal@ is a liveness probe: it throws once the process is --- gone (and reaped by init after being orphaned). -waitForProcessDeath :: Int -> IO Bool -waitForProcessDeath pid = go (60 :: Int) - where - go 0 = not <$> alive - go n = do - a <- alive - if not a then pure True else threadDelay 50_000 >> go (n - 1) - alive = - (signalProcess nullSignal (fromIntegral pid) >> pure True) - `catch` \(_ :: IOException) -> pure False - - -testDecideInterrupt :: Spec -testDecideInterrupt = do - -- Regression: an idle GHCi must not be SIGINT'd, since the matching - -- sync-marker write would leave a stale marker line in stdout/stderr - -- that the next 'execGhci' drain would match instead of the fresh one, - -- desyncing the protocol and reporting "0 modules" or hanging. - it "is a no-op when the session is Idle" do - decideInterrupt (Idle 7) `shouldBe` (Idle 7, NoOpIdle) - - it "preserves the counter for any Idle state" do - decideInterrupt (Idle 0) `shouldBe` (Idle 0, NoOpIdle) - decideInterrupt (Idle 42) `shouldBe` (Idle 42, NoOpIdle) - - it "advances to Idle (n+1) and emits SendInterruptFor n when Busy" do - decideInterrupt (Busy 7) `shouldBe` (Idle 8, SendInterruptFor 7) - - it "advances correctly from Busy 0" do - decideInterrupt (Busy 0) `shouldBe` (Idle 1, SendInterruptFor 0) - - --- | Pins down the 'Conc.scoped' fix in 'execGhci': when the drain forks --- raise 'UnexpectedExit' (because the underlying process exited and EOF'd --- the pipes), the exception must be CONTAINED inside 'execGhci' and --- surfaced via the caller's 'trySync' — not propagated to the ambient --- 'Conc.scoped' that called 'execGhci'. --- --- Without the inner 'Conc.scoped' in 'execGhci', Ki propagates an --- exception from a forked thread to its owning scope. If 'execGhci' forks --- its drains directly into the ambient scope (the original bug), the --- ambient scope is torn down — siblings die, the whole builder cycle --- unwinds, and the daemon ends up in the "Restarting builder..." state --- the user observed. -testExecGhciScope :: Spec -testExecGhciScope = - -- Spawn a real subprocess that exits immediately ('true'). Its - -- stdout/stderr pipes EOF as soon as the child exits, which makes - -- 'drainUntil' inside 'execGhci' throw 'UnexpectedExit' — exactly the - -- mid-command termination path the fix exists to handle. - it "contains drain exceptions inside its own scope so siblings survive" do - p <- - startProcess - $ setStdin createPipe - $ setStdout createPipe - $ setStderr createPipe - $ shell "true" - -- Wait for the child to actually exit so the pipes are EOF before - -- 'execGhci' starts draining (otherwise the drain blocks). - _ <- waitExitCode p - stateVar <- newTVarIO (Idle 0) - let gp = - GhciProcess - { stdin = getStdin p - , stdout = getStdout p - , stderr = getStderr p - , handle = RunningProcess p - , stateVar - } - siblingDoneRef <- newIORef False - result <- - runEff - . runConcurrent - . runTimeout - . runDelay - . runFile - . runConc - $ Conc.scoped do - -- A sibling fork in the SAME ambient scope. If the bug - -- regresses, the drain exception will tear this scope - -- down and the sibling will be cancelled before it can - -- flip the ref. - sibling <- Conc.fork do - Delay.wait (50 :: Millisecond) - liftIO (writeIORef siblingDoneRef True) - -- Drive 'execGhci' on a dead process; the drains should - -- raise 'UnexpectedExit', which 'trySync' must catch - -- here rather than letting Ki tear down the scope. - execResult <- trySync (execGhci gp "cmd" (\_ -> pure ())) - -- Wait for the sibling to run. - Conc.await sibling - pure execResult - -- stopProcess flushes the buffered command+marker to a pipe whose - -- read end is already closed, which raises ResourceVanished. The - -- subprocess has long since exited; just swallow the cleanup error. - _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ()) - siblingDone <- readIORef siblingDoneRef - siblingDone `shouldBe` True - case result of - Left _ -> pure () - Right _ -> expectationFailure "expected execGhci to raise UnexpectedExit" diff --git a/test/Unit/Tricorder/Effects/GhciSessionSpec.hs b/test/Unit/Tricorder/Effects/GhciSessionSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/Effects/GhciSessionSpec.hs +++ /dev/null @@ -1,123 +0,0 @@ -module Unit.Tricorder.Effects.GhciSessionSpec (spec_GhciSession) where - -import Control.Exception (ErrorCall (..)) -import Effectful (IOE, runEff) -import Effectful.Exception (try) -import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) - -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set - -import Tricorder.BuildState (Diagnostic (..), Severity (..)) -import Tricorder.Effects.GhciSession (Controls (..), GhciSession, LoadResult (..), runGhciSessionScripted, withGhci) -import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Command (..)) - - -spec_GhciSession :: Spec -spec_GhciSession = do - describe "runGhciSessionScripted" testScripted - - --------------------------------------------------------------------------------- --- Scripted interpreter tests --------------------------------------------------------------------------------- - -testScripted :: Spec -testScripted = do - describe "withGhci" do - describe "initial load" do - it "returns scripted messages" do - LoadResult {diagnostics = msgs} <- - runScripted [simpleResult [errMsg]] - $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial - msgs `shouldBe` [errMsg] - - it "returns empty list when scripted result has no messages" do - LoadResult {diagnostics = msgs} <- - runScripted [simpleResult []] - $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial - msgs `shouldBe` [] - - it "throws when scripted result is Left" do - result <- - runScripted [Left (toException boom)] - $ try @ErrorCall - $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial - result `shouldBe` Left boom - - describe "reloading" do - it "returns scripted messages" do - LoadResult {diagnostics = msgs} <- - runScripted [simpleResult [warnMsg], simpleResult [errMsg]] - $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload - msgs `shouldBe` [errMsg] - - it "throws when scripted result is Left" do - result <- - runScripted [Left (toException boom)] - $ try @ErrorCall - $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload - result `shouldBe` Left boom - - describe "sequencing" do - it "consumes results in order across mixed operations" do - (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do - withGhci (Command "cabal repl") (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do - LoadResult {diagnostics = b} <- controls.reload - pure (a, b) - a `shouldBe` [errMsg] - b `shouldBe` [warnMsg] - - it "recover scenario: error then success" do - result <- runScripted [Left (toException boom), simpleResult []] do - r1 <- try @ErrorCall $ withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i - LoadResult {diagnostics = r2} <- withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i - pure (r1, r2) - fst result `shouldSatisfy` isLeft - snd result `shouldBe` [] - - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -boom :: ErrorCall -boom = ErrorCall "simulated GHCi crash" - - -errMsg :: Diagnostic -errMsg = - Diagnostic - { severity = SError - , file = "src/Foo.hs" - , line = 1 - , col = 1 - , endLine = 1 - , endCol = 5 - , title = "Variable not in scope: foo" - , text = "Variable not in scope: foo" - } - - -warnMsg :: Diagnostic -warnMsg = - Diagnostic - { severity = SWarning - , file = "src/Bar.hs" - , line = 10 - , col = 3 - , endLine = 10 - , endCol = 8 - , title = "Unused import" - , text = "Unused import" - } - - --- | Convenience constructor: a scripted result with no compiled-file info. -simpleResult :: [Diagnostic] -> Either SomeException LoadResult -simpleResult msgs = Right LoadResult {moduleCount = 0, compiledFiles = Set.empty, loadedModules = Map.empty, targetNames = [], diagnostics = msgs} - - -runScripted :: [Either SomeException LoadResult] -> Eff '[GhciSession, IOE] a -> IO a -runScripted results = runEff . runGhciSessionScripted results diff --git a/test/Unit/Tricorder/Effects/SessionStoreSpec.hs b/test/Unit/Tricorder/Effects/SessionStoreSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/Effects/SessionStoreSpec.hs +++ /dev/null @@ -1,162 +0,0 @@ -module Unit.Tricorder.Effects.SessionStoreSpec (spec_SessionStore) where - -import Atelier.Effects.Chan (Chan, runChan) -import Atelier.Effects.Clock (Clock, runClockConst) -import Atelier.Effects.Conc (Conc, runConc) -import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) -import Atelier.Effects.Publishing (Pub, Sub, publish, runPubSub) -import Control.Concurrent (threadDelay) -import Data.Default (def) -import Data.IORef (IORef) -import Data.Time (UTCTime (..), fromGregorian) -import Effectful (IOE, runEff) -import Effectful.Concurrent (Concurrent, runConcurrent) -import Effectful.Dispatch.Dynamic (interpret_) -import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) -import Test.Hspec (Spec, describe, it, shouldBe) - -import Data.IORef qualified as IORef - -import Tricorder.Effects.SessionStore - ( ActiveSession (..) - , SessionStore (..) - , SessionStoreReloaded (..) - , runSessionStoreConst - , withSession - ) -import Tricorder.Session (Command (..), Session (..)) - -import Tricorder.Effects.SessionStore qualified as SessionStore - - -spec_SessionStore :: Spec -spec_SessionStore = do - describe "withSession" testWithSession - - -testWithSession :: Spec -testWithSession = do - it "calls the action with the current session" do - cmdRef <- IORef.newIORef Nothing - _ <- runFixed session1 do - withSession \active -> do - liftIO $ IORef.writeIORef cmdRef (Just active.session.command) - throwError StopSignal - result <- IORef.readIORef cmdRef - result `shouldBe` Just session1.command - - it "provides a reloader that calls rawReload" do - reloadedRef <- IORef.newIORef False - _ <- runFlagged reloadedRef do - withSession \active -> do - active.reloader.reload - throwError StopSignal - reloaded <- IORef.readIORef reloadedRef - reloaded `shouldBe` True - - it "restarts with the new session when reloaded" do - sessionsRef <- IORef.newIORef [] - sessionRef <- IORef.newIORef session1 - callCount <- IORef.newIORef (0 :: Int) - _ <- runMutable sessionRef do - withSession \active -> do - liftIO $ IORef.modifyIORef' sessionsRef (active.session.command :) - n <- liftIO $ IORef.atomicModifyIORef' callCount (\x -> (x + 1, x + 1)) - if n == 1 then do - -- Give withSession time to call listenOnce_ before we publish. - liftIO $ threadDelay 1_000 - liftIO $ IORef.writeIORef sessionRef session2 - publish (SessionStoreReloaded session2) - else - throwError StopSignal - sessions <- reverse <$> IORef.readIORef sessionsRef - sessions `shouldBe` [session1.command, session2.command] - - --------------------------------------------------------------------------------- --- Effect stack --------------------------------------------------------------------------------- - -data StopSignal = StopSignal - deriving stock (Show) - - -type TestEs = - '[ Conc - , Error StopSignal - , Pub SessionStoreReloaded - , Sub SessionStoreReloaded - , SessionStore - , Chan - , Clock - , Tracing - , Concurrent - , IOE - ] - - -runFixed :: Session -> Eff TestEs a -> IO (Either StopSignal a) -runFixed session = - runEff - . runConcurrent - . runTracingNoOp - . runClockConst epoch - . runChan - . runSessionStoreConst session - . runPubSub @SessionStoreReloaded - . runErrorNoCallStack @StopSignal - . runConc - - -runFlagged :: IORef Bool -> Eff TestEs a -> IO (Either StopSignal a) -runFlagged flag = - runEff - . runConcurrent - . runTracingNoOp - . runClockConst epoch - . runChan - . runSessionStoreFlagged flag - . runPubSub @SessionStoreReloaded - . runErrorNoCallStack @StopSignal - . runConc - - -runMutable :: IORef Session -> Eff TestEs a -> IO (Either StopSignal a) -runMutable ref = - runEff - . runConcurrent - . runTracingNoOp - . runClockConst epoch - . runChan - . runSessionStoreMutable ref - . runPubSub @SessionStoreReloaded - . runErrorNoCallStack @StopSignal - . runConc - - -runSessionStoreFlagged :: (IOE :> es) => IORef Bool -> Eff (SessionStore : es) a -> Eff es a -runSessionStoreFlagged flag = interpret_ \case - Get -> pure session1 - RawReload -> liftIO $ IORef.writeIORef flag True - - -runSessionStoreMutable :: (IOE :> es) => IORef Session -> Eff (SessionStore : es) a -> Eff es a -runSessionStoreMutable ref = interpret_ \case - Get -> liftIO $ IORef.readIORef ref - RawReload -> pure () - - --------------------------------------------------------------------------------- --- Fixtures --------------------------------------------------------------------------------- - -session1 :: Session -session1 = def {command = Command "session-1"} - - -session2 :: Session -session2 = def {command = Command "session-2"} - - -epoch :: UTCTime -epoch = UTCTime (fromGregorian 1970 1 1) 0 diff --git a/test/Unit/Tricorder/GhcPkgSpec.hs b/test/Unit/Tricorder/GhcPkgSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/GhcPkgSpec.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Unit.Tricorder.GhcPkgSpec (spec_GhcPkg) where - -import Effectful (runPureEff) -import Test.Hspec - -import Tricorder.Effects.GhcPkg (GhcPkg, GhcPkgScript (..), findModule, getHaddockHtml, runGhcPkgScripted) - - -spec_GhcPkg :: Spec -spec_GhcPkg = do - describe "findModule" testFindModule - describe "getHaddockHtml" testGetHaddockHtml - - -testFindModule :: Spec -testFindModule = do - it "returns Just pkgId when module is known" do - let result = runScripted [NextFindModule (Just "base-4.18")] $ findModule "Prelude" - result `shouldBe` Just "base-4.18" - - it "returns Nothing for an unknown module" do - let result = runScripted [NextFindModule Nothing] $ findModule "No.Such.Module" - result `shouldBe` Nothing - - it "returns the first scripted result" do - let result = runScripted [NextFindModule (Just "pkg-1.0"), NextFindModule (Just "pkg-2.0")] $ findModule "Foo" - result `shouldBe` Just "pkg-1.0" - - -testGetHaddockHtml :: Spec -testGetHaddockHtml = do - it "returns Just path when haddock-html is set" do - let result = runScripted [NextGetHaddockHtml (Just "/nix/store/abc/share/doc/html")] $ getHaddockHtml "base-4.18" - result `shouldBe` Just "/nix/store/abc/share/doc/html" - - it "returns Nothing when haddock-html is not set" do - let result = runScripted [NextGetHaddockHtml Nothing] $ getHaddockHtml "base-4.18" - result `shouldBe` Nothing - - it "returns the first scripted result" do - let result = - runScripted - [NextGetHaddockHtml (Just "/path/one"), NextGetHaddockHtml (Just "/path/two")] - $ getHaddockHtml "pkg-1.0" - result `shouldBe` Just "/path/one" - - -runScripted :: [GhcPkgScript] -> Eff '[GhcPkg] a -> a -runScripted script = runPureEff . runGhcPkgScripted script diff --git a/test/Unit/Tricorder/Session/CabalFileSpec.hs b/test/Unit/Tricorder/Session/CabalFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Session/CabalFileSpec.hs @@ -0,0 +1,43 @@ +module Unit.Tricorder.Session.CabalFileSpec (spec_CabalFile) where + +import Atelier.Effects.FileSystem (runFileSystemState) +import Atelier.Effects.Log (runLogNoOp) +import Effectful (runPureEff) +import Effectful.State.Static.Shared (evalState) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Map.Strict qualified as Map + +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.CabalFile (discoverCabalFiles) +import Unit.Tricorder.Session.Helpers (cabalFixture, multiPackageFs) + + +spec_CabalFile :: Spec +spec_CabalFile = do + describe "discoverCabalFiles" testDiscoverCabalFiles + + +-- | Pins the discovery contract: a @cabal.project@ selects per-package +-- @.cabal@ files from its @packages:@ stanza; otherwise the @.cabal@ files in +-- the project root are used. +testDiscoverCabalFiles :: Spec +testDiscoverCabalFiles = do + describe "when there is no cabal.project" do + it "finds the .cabal files in the project root" do + let actual = + runDiscovery (Map.singleton "/myapp.cabal" cabalFixture) + $ discoverCabalFiles pr + actual `shouldBe` ["/myapp.cabal"] + + it "returns no files when the root has no cabal file" do + let actual = runDiscovery mempty $ discoverCabalFiles pr + actual `shouldBe` [] + + describe "when there is a multi-package cabal.project" do + it "resolves each listed package to its .cabal (regression: was root-only)" do + let actual = runDiscovery multiPackageFs $ discoverCabalFiles pr + actual `shouldBe` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] + where + pr = ProjectRoot "/" + runDiscovery fs = runPureEff . evalState fs . runFileSystemState . runLogNoOp diff --git a/test/Unit/Tricorder/Session/CommandSpec.hs b/test/Unit/Tricorder/Session/CommandSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Session/CommandSpec.hs @@ -0,0 +1,95 @@ +module Unit.Tricorder.Session.CommandSpec (spec_Command) where + +import Atelier.Effects.FileSystem (runFileSystemState) +import Data.Default (def) +import Effectful (runPureEff) +import Effectful.State.Static.Shared (evalState) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Map.Strict qualified as Map + +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Command (Command (..), resolveCommand) +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.Target (parseTarget) +import Tricorder.Session.TestTarget (parseTestTargets) + +import Tricorder.Session.Config qualified as Config + + +spec_Command :: Spec +spec_Command = do + describe "resolveCommand" testResolveCommand + + +testResolveCommand :: Spec +testResolveCommand = do + describe "when config has a command" do + it "should use specified command" do + let Command actual = + runPureEff + . evalState mempty + . runFileSystemState + $ resolveCommand pr def {command = Just "foo"} [] testTargets + actual `shouldBe` "foo" + + describe "when config has explicit targets" do + it "should spell them out verbatim, ignoring discovered test targets" do + let Command actual = + runPureEff + . evalState (Map.singleton "/cabal.project" "") + . runFileSystemState + $ resolveCommand pr cfg (parseTarget <$> ["lib:foo"]) testTargets + actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo" + + describe "when config does not have a command or targets" do + describe "and there is a cabal.project file" do + it "should use cabal 'all' plus the discovered test targets" do + let Command actual = + runPureEff + . evalState (Map.singleton "/cabal.project" "") + . runFileSystemState + $ resolveCommand pr cfg [] testTargets + actual + `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo" + + describe "and there is at least one *.cabal file" do + it "should use cabal 'all' plus the discovered test targets" do + let Command actual = + runPureEff + . evalState (Map.singleton "/foo.cabal" "") + . runFileSystemState + $ resolveCommand pr cfg [] testTargets + actual + `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo" + + describe "and there is a stack.yaml file" do + it "should use stack ghci with 'all' plus test targets" do + let Command actual = + runPureEff + . evalState (Map.singleton "/stack.yaml" "") + . runFileSystemState + $ resolveCommand pr cfg [] testTargets + actual `shouldBe` "stack ghci all test:foo" + + describe "but there are no project files" do + it "should use default cabal repl with 'all' plus test targets" do + let Command actual = + runPureEff + . evalState mempty + . runFileSystemState + $ resolveCommand pr cfg [] testTargets + actual `shouldBe` "cabal repl --builddir /replbuild all test:foo" + + describe "and no test targets are discovered" do + it "should fall back to plain 'all'" do + let Command actual = + runPureEff + . evalState (Map.singleton "/cabal.project" "") + . runFileSystemState + $ resolveCommand pr cfg [] (parseTestTargets []) + actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all" + where + pr = ProjectRoot "/" + cfg = def {Config.replBuildDir = "/replbuild"} + testTargets = parseTestTargets ["test:foo"] diff --git a/test/Unit/Tricorder/Session/Helpers.hs b/test/Unit/Tricorder/Session/Helpers.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Session/Helpers.hs @@ -0,0 +1,176 @@ +module Unit.Tricorder.Session.Helpers + ( multiCabalFiles + , singleCabalFile + , multiPackageFs + , preludeOnlyLibCabal + , libWithPreludeCabal + , libTestCabal + , gpdFixture + , cabalFixture + , gpd + ) where + +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T + +import Tricorder.Session.CabalFile (CabalFile (..)) + + +gpd :: GenericPackageDescription +gpd = + fromMaybe (error "cabalFixture failed to parse") + $ parseGenericPackageDescriptionMaybe cabalFixture + + +multiCabalFiles :: [CabalFile] +multiCabalFiles = + uncurry CabalFile + . second + ( fromMaybe (error "multiCabalFiles failed to parse") + . parseGenericPackageDescriptionMaybe + ) + <$> Map.toList multiPackageCabalFs + + +-- | An in-memory project root with a @cabal.project@ listing two packages, +-- each in its own subdirectory with a library and a test suite. +multiPackageFs :: Map FilePath ByteString +multiPackageFs = + Map.fromList + [ ("/cabal.project", "packages:\n pkg-a\n pkg-b\n\ntests: True\n") + ] + `Map.union` multiPackageCabalFs + + +multiPackageCabalFs :: Map FilePath ByteString +multiPackageCabalFs = + Map.fromList + [ ("/pkg-a/pkg-a.cabal", libTestCabal "pkg-a") + , ("/pkg-b/pkg-b.cabal", libTestCabal "pkg-b") + ] + + +-- | A minimal cabal file for @name@ with a single library that exposes +-- @Prelude@ and nothing else. All auto-detected targets define a custom +-- Prelude, which triggers the 'loadSession' warning. +preludeOnlyLibCabal :: Text -> ByteString +preludeOnlyLibCabal name = + encodeUtf8 + $ T.unlines + [ "cabal-version: 2.0" + , "name: " <> name + , "version: 0.1.0.0" + , "build-type: Simple" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Prelude" + , " build-depends: base" + , " default-language: Haskell2010" + ] + + +-- | A minimal cabal file for @name@ with one library that exposes @Prelude@ +-- and one executable. Used to verify that libraries defining a custom Prelude +-- are sorted last by 'resolveTargets'. +libWithPreludeCabal :: Text -> ByteString +libWithPreludeCabal name = + encodeUtf8 + $ T.unlines + [ "cabal-version: 2.0" + , "name: " <> name + , "version: 0.1.0.0" + , "build-type: Simple" + , "" + , "library" + , " hs-source-dirs: src" + , " exposed-modules: Prelude" + , " build-depends: base" + , " default-language: Haskell2010" + , "" + , "executable " <> name <> "-exe" + , " main-is: Main.hs" + , " hs-source-dirs: app" + , " build-depends: base" + , " default-language: Haskell2010" + ] + + +-- | A minimal cabal file for @name@ with one library and one test suite +-- (@-test@). +libTestCabal :: Text -> ByteString +libTestCabal name = + encodeUtf8 + $ T.unlines + [ "cabal-version: 2.0" + , "name: " <> name + , "version: 0.1.0.0" + , "build-type: Simple" + , "" + , "library" + , " hs-source-dirs: src" + , " build-depends: base" + , " default-language: Haskell2010" + , "" + , "test-suite " <> name <> "-test" + , " type: exitcode-stdio-1.0" + , " main-is: Test.hs" + , " hs-source-dirs: test" + , " build-depends: base" + , " default-language: Haskell2010" + ] + + +singleCabalFile :: [CabalFile] +singleCabalFile = [CabalFile "/myapp.cabal" gpdFixture] + + +gpdFixture :: GenericPackageDescription +gpdFixture = fromMaybe (error "gpdFixture failed to parse") $ parseGenericPackageDescriptionMaybe cabalFixture + + +cabalFixture :: ByteString +cabalFixture = + "cabal-version: 2.0\n\ + \name: myapp\n\ + \version: 0.1.0.0\n\ + \build-type: Simple\n\ + \\n\ + \library\n\ + \ hs-source-dirs: src\n\ + \ build-depends: base\n\ + \ default-language: Haskell2010\n\ + \\n\ + \library myapp-utils\n\ + \ hs-source-dirs: utils\n\ + \ build-depends: base\n\ + \ default-language: Haskell2010\n\ + \\n\ + \foreign-library myapp-flib\n\ + \ type: native-shared\n\ + \ hs-source-dirs: flib\n\ + \ build-depends: base\n\ + \ default-language: Haskell2010\n\ + \\n\ + \executable myapp-exe\n\ + \ main-is: Main.hs\n\ + \ hs-source-dirs: app\n\ + \ build-depends: base\n\ + \ default-language: Haskell2010\n\ + \\n\ + \test-suite myapp-test\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: Test.hs\n\ + \ hs-source-dirs: test\n\ + \ build-depends: base\n\ + \ default-language: Haskell2010\n\ + \\n\ + \benchmark myapp-bench\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: Bench.hs\n\ + \ hs-source-dirs: bench\n\ + \ build-depends: base\n\ + \ default-language: Haskell2010\n" diff --git a/test/Unit/Tricorder/Session/TargetSpec.hs b/test/Unit/Tricorder/Session/TargetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Session/TargetSpec.hs @@ -0,0 +1,233 @@ +module Unit.Tricorder.Session.TargetSpec (spec_Target) where + +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Test.Hspec + ( Spec + , describe + , it + , shouldBe + , shouldContain + , shouldMatchList + ) + +import Tricorder.Session.CabalFile (CabalFile (..)) +import Tricorder.Session.Target + ( ComponentKind (..) + , Target (..) + , allComponentTargets + , compareTargets + , definesCustomPrelude + , parseTarget + , resolveTargets + ) +import Unit.Tricorder.Session.Helpers + ( gpd + , libTestCabal + , libWithPreludeCabal + , multiCabalFiles + , singleCabalFile + ) + + +spec_Target :: Spec +spec_Target = do + describe "resolveTargets" testResolveTargets + describe "parseTarget" testParseTarget + describe "compareTargets" testCompareTargets + describe "allComponentTargets" testAllComponentTargets + describe "definesCustomPrelude" testDefinesCustomPrelude + + +testParseTarget :: Spec +testParseTarget = do + describe "qualified targets" do + it "parses lib: as the main library (empty name)" do + parseTarget "lib:" `shouldBe` Qualified Lib "" + + it "parses a named lib: target" do + parseTarget "lib:myapp-utils" `shouldBe` Qualified Lib "myapp-utils" + + it "parses an flib: target" do + parseTarget "flib:myapp-flib" `shouldBe` Qualified FLib "myapp-flib" + + it "parses an exe: target" do + parseTarget "exe:myapp-exe" `shouldBe` Qualified Exe "myapp-exe" + + it "parses a test: target" do + parseTarget "test:myapp-test" `shouldBe` Qualified Test "myapp-test" + + it "parses a bench: target" do + parseTarget "bench:myapp-bench" `shouldBe` Qualified Bench "myapp-bench" + + describe "a name with no kind prefix" do + it "parses as bare" do + parseTarget "myapp" `shouldBe` Bare "myapp" + + describe "unrecognized targets" do + it "rejects an unknown kind" do + parseTarget "bogus:myapp" `shouldBe` Unrecognized "bogus:myapp" + + it "rejects a form with extra colons" do + parseTarget "lib:a:b" `shouldBe` Unrecognized "lib:a:b" + + +testResolveTargets :: Spec +testResolveTargets = do + describe "when targets are configured" do + it "parses and sorts configured targets" do + let actual = resolveTargets [] ["lib:foo", "test:foo-test"] + actual `shouldBe` [Qualified Lib "foo", Qualified Test "foo-test"] + + describe "when no targets are configured" do + it "auto-detects all components from the cabal file" do + -- cabalFixture exposes no Prelude module, so all components sort + -- alphabetically by their rendered form. + let actual = resolveTargets singleCabalFile [] + actual + `shouldBe` [ Qualified Bench "myapp-bench" + , Qualified Exe "myapp-exe" + , Qualified FLib "myapp-flib" + , Qualified Lib "myapp" + , Qualified Lib "myapp-utils" + , Qualified Test "myapp-test" + ] + + it "surfaces test-suite components so they can be run after a build" do + let actual = resolveTargets singleCabalFile [] + actual `shouldContain` [Qualified Test "myapp-test"] + + it "returns no targets when there are no cabal files" do + let actual = resolveTargets [] [] + actual `shouldBe` [] + + -- [tag: test_resolve_targest_aggregate] + it "aggregates components across every package (regression: was 0)" do + let actual = resolveTargets multiCabalFiles [] + actual + `shouldMatchList` [ Qualified Test "pkg-a-test" + , Qualified Test "pkg-b-test" + , Qualified Lib "pkg-a" + , Qualified Lib "pkg-b" + ] + + it "sorts a library exposing a custom Prelude last" do + let cabalFile = + CabalFile "/myprelude.cabal" + $ fromMaybe (error "libWithPreludeCabal failed to parse") + $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude") + let actual = resolveTargets [cabalFile] [] + actual `shouldBe` [Qualified Exe "myprelude-exe", Qualified Lib "myprelude"] + + +testCompareTargets :: Spec +testCompareTargets = do + -- A predicate that stands in for 'definesCustomPrelude': marks lib: targets + -- as "defines custom Prelude" so the comparison contract is exercised + -- independently of cabal-file parsing. + let defPred (Qualified Lib _) = True + defPred _ = False + + describe "Ord" do + describe "only first target matches the predicate" do + describe "first target's render normally sorts as LT" do + it "should return GT" do + compareTargets defPred (Qualified Lib "a") (Qualified Exe "b") `shouldBe` GT + describe "both targets have the same render" do + it "should return GT" do + compareTargets defPred (Qualified Lib "a") (Qualified Exe "a") `shouldBe` GT + describe "first target's render normally sorts as GT" do + it "should return GT" do + compareTargets defPred (Qualified Lib "b") (Qualified Exe "a") `shouldBe` GT + + describe "only second target matches the predicate" do + describe "first target's render normally sorts as LT" do + it "should return LT" do + compareTargets defPred (Qualified Exe "a") (Qualified Lib "b") `shouldBe` LT + describe "both targets have the same render" do + it "should return LT" do + compareTargets defPred (Qualified Exe "a") (Qualified Lib "a") `shouldBe` LT + describe "first target's render normally sorts as GT" do + it "should return LT" do + compareTargets defPred (Qualified Exe "b") (Qualified Lib "a") `shouldBe` LT + + describe "both targets match the predicate" do + describe "first target's render normally sorts as LT" do + it "should sort normally" do + compareTargets defPred (Qualified Lib "a") (Qualified Lib "b") `shouldBe` LT + describe "both targets have the same render" do + it "should sort normally" do + compareTargets defPred (Qualified Lib "a") (Qualified Lib "a") `shouldBe` EQ + describe "first target's render normally sorts as GT" do + it "should sort normally" do + compareTargets defPred (Qualified Lib "b") (Qualified Lib "a") `shouldBe` GT + + describe "neither target matches the predicate" do + describe "first target's render normally sorts as LT" do + it "should sort normally" do + compareTargets defPred (Qualified Exe "a") (Qualified Exe "b") `shouldBe` LT + describe "both targets have the same render" do + it "should sort normally" do + compareTargets defPred (Qualified Exe "a") (Qualified Exe "a") `shouldBe` EQ + describe "first target's render normally sorts as GT" do + it "should sort normally" do + compareTargets defPred (Qualified Exe "b") (Qualified Exe "a") `shouldBe` GT + + +testAllComponentTargets :: Spec +testAllComponentTargets = do + it "returns every component for the fixture" do + allComponentTargets gpd + `shouldMatchList` [ Qualified Lib "myapp" + , Qualified Lib "myapp-utils" + , Qualified FLib "myapp-flib" + , Qualified Exe "myapp-exe" + , Qualified Test "myapp-test" + , Qualified Bench "myapp-bench" + ] + -- This test ensures `allComponentTargets`' part of the aggregate test. + -- [ref:test_resolve_targest_aggregate] + it "returns every component for test fixures" do + let actual = + allComponentTargets + $ fromMaybe (error "failed to parse cabal") + $ parseGenericPackageDescriptionMaybe + $ libTestCabal "pkg-a" + actual `shouldMatchList` [Qualified Lib "pkg-a", Qualified Test "pkg-a-test"] + + +testDefinesCustomPrelude :: Spec +testDefinesCustomPrelude = do + let preludeCF = + CabalFile "/myprelude.cabal" + $ fromMaybe (error "libWithPreludeCabal failed to parse") + $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude") + + describe "when the main library exposes Prelude" do + it "returns True for Qualified Lib \"\" (unnamed main lib)" do + definesCustomPrelude [preludeCF] (Qualified Lib "") `shouldBe` True + + it "returns True for Qualified Lib matching the package name" do + definesCustomPrelude [preludeCF] (Qualified Lib "myprelude") `shouldBe` True + + it "returns True for Bare matching the package name" do + definesCustomPrelude [preludeCF] (Bare "myprelude") `shouldBe` True + + describe "when no library exposes Prelude" do + it "returns False for a lib target in a normal package" do + definesCustomPrelude singleCabalFile (Qualified Lib "myapp") `shouldBe` False + + it "returns False for Bare matching the package name" do + definesCustomPrelude singleCabalFile (Bare "myapp") `shouldBe` False + + describe "for non-library targets" do + it "returns False for Qualified Exe" do + definesCustomPrelude [preludeCF] (Qualified Exe "myprelude-exe") `shouldBe` False + + it "returns False for Qualified Test" do + definesCustomPrelude singleCabalFile (Qualified Test "myapp-test") `shouldBe` False + + it "returns False for Unrecognized" do + definesCustomPrelude [preludeCF] (Unrecognized "library:myprelude") `shouldBe` False + + it "returns False when the cabal file list is empty" do + definesCustomPrelude [] (Qualified Lib "anything") `shouldBe` False diff --git a/test/Unit/Tricorder/Session/TestTargetSpec.hs b/test/Unit/Tricorder/Session/TestTargetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Session/TestTargetSpec.hs @@ -0,0 +1,43 @@ +module Unit.Tricorder.Session.TestTargetSpec (spec_TestTarget) where + +import Data.Default (def) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.Target (parseTarget) +import Tricorder.Session.TestTarget (parseTestTargets, resolveTestTargets) + + +spec_TestTarget :: Spec +spec_TestTarget = do + describe "resolveTestTargets" testResolveTestTargets + + +testResolveTestTargets :: Spec +testResolveTestTargets = do + it "infers test: components from targets when testTargets is absent" do + let cfg = def :: Config + resolveTestTargets cfg (mkTargets ["lib:mylib", "test:mylib-test"]) + `shouldBe` parseTestTargets ["test:mylib-test"] + + it "returns empty list when no test: components in targets" do + let cfg = def :: Config + resolveTestTargets cfg (mkTargets ["lib:mylib", "exe:myapp"]) + `shouldBe` parseTestTargets [] + + it "uses explicit testTargets list when set" do + let cfg = def {testTargets = Just ["test:b-test"]} :: Config + resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) + `shouldBe` parseTestTargets ["test:b-test"] + + it "returns empty list when testTargets is explicitly empty" do + let cfg = def {testTargets = Just []} :: Config + resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test"]) + `shouldBe` parseTestTargets [] + + it "infers multiple test: components" do + let cfg = def :: Config + resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) + `shouldBe` parseTestTargets ["test:a-test", "test:b-test"] + where + mkTargets = fmap parseTarget diff --git a/test/Unit/Tricorder/Session/WatchDirsSpec.hs b/test/Unit/Tricorder/Session/WatchDirsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/Session/WatchDirsSpec.hs @@ -0,0 +1,142 @@ +module Unit.Tricorder.Session.WatchDirsSpec (spec_WatchDirs) where + +import Data.Default (def) +import Test.Hspec (Spec, context, describe, it, shouldBe) + +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.Session.Config (Config (..)) +import Tricorder.Session.Target (ComponentKind (..), Target (..), parseTarget) +import Tricorder.Session.WatchDirs (WatchDirs (..), resolveWatchDirs, sourceDirsForTarget) +import Unit.Tricorder.Session.Helpers (gpd, multiCabalFiles, singleCabalFile) + + +spec_WatchDirs :: Spec +spec_WatchDirs = do + describe "resolveWatchDirs" testResolveWatchDirs + describe "sourceDirsForTarget" testSourceDirsForTarget + + +testResolveWatchDirs :: Spec +testResolveWatchDirs = do + describe "when watch_dirs is set in config" do + it "uses config dirs relative to project root" do + let WatchDirs actual = + resolveWatchDirs pr [] def {watchDirs = ["src", "test"]} [] + actual `shouldBe` ["/src", "/test"] + + describe "when watch_dirs is not set" do + it "falls back to [\".\"] when targets list is empty" do + let WatchDirs actual = resolveWatchDirs pr [] def [] + actual `shouldBe` ["."] + + it "infers source dirs from resolved targets" do + let WatchDirs actual = + resolveWatchDirs pr singleCabalFile def (mkTargets ["lib:myapp", "test:myapp-test"]) + actual `shouldBe` ["/src", "/test"] + + it "falls back to [\".\"] when there are no cabal files" do + let WatchDirs actual = + resolveWatchDirs pr [] def (mkTargets ["lib:myapp"]) + actual `shouldBe` ["."] + + -- Sharp edge: an unparseable .cabal yields no source dirs, so resolution + -- falls back to watching the whole project root. This pins the current + -- behavior; if it ever changes to something narrower, update this test. + it "falls back to [\".\"] when no cabal files are found or parsed" do + let WatchDirs actual = + resolveWatchDirs pr [] def (mkTargets ["lib:myapp"]) + actual `shouldBe` ["."] + + describe "when the project is a multi-package cabal.project" do + it "infers per-package source dirs, scoped to each package's directory" do + let WatchDirs actual = + resolveWatchDirs + pr + multiCabalFiles + def + (mkTargets ["lib:pkg-a", "test:pkg-a-test", "lib:pkg-b", "test:pkg-b-test"]) + actual + `shouldBe` ["/pkg-a/src", "/pkg-a/test", "/pkg-b/src", "/pkg-b/test"] + + it "scopes a bare package-name target to that package, ignoring siblings" do + let WatchDirs actual = + resolveWatchDirs pr multiCabalFiles def (mkTargets ["pkg-a"]) + actual `shouldBe` ["/pkg-a/src", "/pkg-a/test"] + where + pr = ProjectRoot "/" + + +-- | These exercise the 'Target' -> dirs resolution directly with constructed +-- 'Target' values; the string -> 'Target' parsing is covered by 'testParseTarget'. +testSourceDirsForTarget :: Spec +testSourceDirsForTarget = do + describe "Qualified Lib" do + context "when the name is empty" do + it "returns the main library source dirs" do + sourceDirsForTarget gpd (Qualified Lib "") `shouldBe` ["src"] + + context "when the name matches the package name" do + it "returns the main library source dirs" do + sourceDirsForTarget gpd (Qualified Lib "myapp") `shouldBe` ["src"] + + context "when the name matches a sub-library" do + it "returns the sub-library source dirs" do + sourceDirsForTarget gpd (Qualified Lib "myapp-utils") `shouldBe` ["utils"] + + context "when the sub-library is unknown" do + it "returns an empty list" do + sourceDirsForTarget gpd (Qualified Lib "nonexistent") `shouldBe` [] + + describe "Qualified FLib" do + it "returns the foreign-library source dirs" do + sourceDirsForTarget gpd (Qualified FLib "myapp-flib") `shouldBe` ["flib"] + + describe "Qualified Exe" do + it "returns the executable source dirs" do + sourceDirsForTarget gpd (Qualified Exe "myapp-exe") `shouldBe` ["app"] + + describe "Qualified Test" do + it "returns the test suite source dirs" do + sourceDirsForTarget gpd (Qualified Test "myapp-test") `shouldBe` ["test"] + + describe "Qualified Bench" do + it "returns the benchmark source dirs" do + sourceDirsForTarget gpd (Qualified Bench "myapp-bench") `shouldBe` ["bench"] + + describe "Bare (package name)" do + it "returns every component's source dirs" do + sourceDirsForTarget gpd (Bare "myapp") `shouldBe` ["src", "utils", "flib", "app", "test", "bench"] + + describe "Bare (component name)" do + context "when it names a sub-library" do + it "returns the sub-library source dirs" do + sourceDirsForTarget gpd (Bare "myapp-utils") `shouldBe` ["utils"] + + context "when it names an executable" do + it "returns the executable source dirs" do + sourceDirsForTarget gpd (Bare "myapp-exe") `shouldBe` ["app"] + + context "when it names a test suite" do + it "returns the test suite source dirs" do + sourceDirsForTarget gpd (Bare "myapp-test") `shouldBe` ["test"] + + context "when it matches no component" do + it "returns an empty list" do + sourceDirsForTarget gpd (Bare "unknown") `shouldBe` [] + + describe "Unrecognized" do + it "matches an aliased kind prefix by trailing name" do + sourceDirsForTarget gpd (Unrecognized "executable:myapp-exe") `shouldBe` ["app"] + + it "matches a case-variant kind prefix by trailing name" do + sourceDirsForTarget gpd (Unrecognized "Test-Suite:myapp-test") `shouldBe` ["test"] + + it "matches the main library when the trailing name is the package name" do + sourceDirsForTarget gpd (Unrecognized "library:myapp") `shouldBe` ["src"] + + it "returns an empty list when the trailing name matches no component" do + sourceDirsForTarget gpd (Unrecognized "bogus:x") `shouldBe` [] + + +mkTargets :: [Text] -> [Target] +mkTargets = fmap parseTarget diff --git a/test/Unit/Tricorder/SessionSpec.hs b/test/Unit/Tricorder/SessionSpec.hs --- a/test/Unit/Tricorder/SessionSpec.hs +++ b/test/Unit/Tricorder/SessionSpec.hs @@ -1,569 +1,59 @@ module Unit.Tricorder.SessionSpec (spec_Session) where +import Atelier.Config (LoadedConfig (..)) import Atelier.Effects.FileSystem (runFileSystemState) -import Atelier.Effects.Log (runLogNoOp) -import Data.Default (Default (..)) +import Atelier.Effects.Input (runInputConst) +import Atelier.Effects.Log (Message (..), Severity (..), runLogWriter) +import Data.Aeson (Value (Null)) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import Effectful (runPureEff) +import Effectful.Reader.Static (runReader) import Effectful.State.Static.Shared (evalState) +import Effectful.Writer.Static.Shared (execWriter) import Test.Hspec -import Data.Map.Strict qualified as Map -import Data.Text qualified as T - import Tricorder.Runtime (ProjectRoot (..)) -import Tricorder.Session (Command (..), ComponentKind (..), Config (..), Target (..), WatchDirs (..), allComponentTargets, compareTargets, discoverCabalFiles, parseTarget, parseTestTargets, resolveCommand, resolveTargets, resolveTestTargets, resolveWatchDirs, sourceDirsForTarget) +import Tricorder.Session (loadSession) +import Tricorder.Session.CabalFile (CabalFile (..)) +import Unit.Tricorder.Session.Helpers (libWithPreludeCabal, preludeOnlyLibCabal) spec_Session :: Spec spec_Session = do - describe "resolveCommand" testResolveCommand - describe "discoverCabalFiles" testDiscoverCabalFiles - describe "resolveTargets" testResolveTargets - describe "resolveWatchDirs" testResolveWatchDirs - describe "resolveTestTargets" testResolveTestTargets - describe "parseTarget" testParseTarget - describe "sourceDirsForTarget" testSourceDirsForTarget - describe "allComponentTargets" testAllComponentTargets - describe "compareTargets" testCompareTargets - - -testParseTarget :: Spec -testParseTarget = do - describe "qualified targets" do - it "parses lib: as the main library (empty name)" do - parseTarget "lib:" `shouldBe` Qualified Lib "" - - it "parses a named lib: target" do - parseTarget "lib:myapp-utils" `shouldBe` Qualified Lib "myapp-utils" - - it "parses an flib: target" do - parseTarget "flib:myapp-flib" `shouldBe` Qualified FLib "myapp-flib" - - it "parses an exe: target" do - parseTarget "exe:myapp-exe" `shouldBe` Qualified Exe "myapp-exe" - - it "parses a test: target" do - parseTarget "test:myapp-test" `shouldBe` Qualified Test "myapp-test" - - it "parses a bench: target" do - parseTarget "bench:myapp-bench" `shouldBe` Qualified Bench "myapp-bench" - - describe "a name with no kind prefix" do - it "parses as bare" do - parseTarget "myapp" `shouldBe` Bare "myapp" - - describe "unrecognized targets" do - it "rejects an unknown kind" do - parseTarget "bogus:myapp" `shouldBe` Unrecognized "bogus:myapp" - - it "rejects a form with extra colons" do - parseTarget "lib:a:b" `shouldBe` Unrecognized "lib:a:b" - - --- | These exercise the 'Target' -> dirs resolution directly with constructed --- 'Target' values; the string -> 'Target' parsing is covered by 'testParseTarget'. -testSourceDirsForTarget :: Spec -testSourceDirsForTarget = do - describe "Qualified Lib" do - context "when the name is empty" do - it "returns the main library source dirs" do - sourceDirsForTarget gpd (Qualified Lib "") `shouldBe` ["src"] - - context "when the name matches the package name" do - it "returns the main library source dirs" do - sourceDirsForTarget gpd (Qualified Lib "myapp") `shouldBe` ["src"] - - context "when the name matches a sub-library" do - it "returns the sub-library source dirs" do - sourceDirsForTarget gpd (Qualified Lib "myapp-utils") `shouldBe` ["utils"] - - context "when the sub-library is unknown" do - it "returns an empty list" do - sourceDirsForTarget gpd (Qualified Lib "nonexistent") `shouldBe` [] - - describe "Qualified FLib" do - it "returns the foreign-library source dirs" do - sourceDirsForTarget gpd (Qualified FLib "myapp-flib") `shouldBe` ["flib"] - - describe "Qualified Exe" do - it "returns the executable source dirs" do - sourceDirsForTarget gpd (Qualified Exe "myapp-exe") `shouldBe` ["app"] - - describe "Qualified Test" do - it "returns the test suite source dirs" do - sourceDirsForTarget gpd (Qualified Test "myapp-test") `shouldBe` ["test"] - - describe "Qualified Bench" do - it "returns the benchmark source dirs" do - sourceDirsForTarget gpd (Qualified Bench "myapp-bench") `shouldBe` ["bench"] - - describe "Bare (package name)" do - it "returns every component's source dirs" do - sourceDirsForTarget gpd (Bare "myapp") `shouldBe` ["src", "utils", "flib", "app", "test", "bench"] - - describe "Bare (component name)" do - context "when it names a sub-library" do - it "returns the sub-library source dirs" do - sourceDirsForTarget gpd (Bare "myapp-utils") `shouldBe` ["utils"] - - context "when it names an executable" do - it "returns the executable source dirs" do - sourceDirsForTarget gpd (Bare "myapp-exe") `shouldBe` ["app"] - - context "when it names a test suite" do - it "returns the test suite source dirs" do - sourceDirsForTarget gpd (Bare "myapp-test") `shouldBe` ["test"] - - context "when it matches no component" do - it "returns an empty list" do - sourceDirsForTarget gpd (Bare "unknown") `shouldBe` [] - - describe "Unrecognized" do - it "matches an aliased kind prefix by trailing name" do - sourceDirsForTarget gpd (Unrecognized "executable:myapp-exe") `shouldBe` ["app"] - - it "matches a case-variant kind prefix by trailing name" do - sourceDirsForTarget gpd (Unrecognized "Test-Suite:myapp-test") `shouldBe` ["test"] - - it "matches the main library when the trailing name is the package name" do - sourceDirsForTarget gpd (Unrecognized "library:myapp") `shouldBe` ["src"] - - it "returns an empty list when the trailing name matches no component" do - sourceDirsForTarget gpd (Unrecognized "bogus:x") `shouldBe` [] - - -testAllComponentTargets :: Spec -testAllComponentTargets = do - it "includes the main library as a named Qualified Lib" do - allComponentTargets gpd `shouldContain` [Qualified Lib "myapp"] - - it "includes sub-libraries" do - allComponentTargets gpd `shouldContain` [Qualified Lib "myapp-utils"] - - it "includes foreign libraries" do - allComponentTargets gpd `shouldContain` [Qualified FLib "myapp-flib"] - - it "includes executables" do - allComponentTargets gpd `shouldContain` [Qualified Exe "myapp-exe"] - - it "includes test suites" do - allComponentTargets gpd `shouldContain` [Qualified Test "myapp-test"] - - it "includes benchmarks" do - allComponentTargets gpd `shouldContain` [Qualified Bench "myapp-bench"] - - it "returns every component for the fixture" do - allComponentTargets gpd - `shouldBe` [ Qualified Lib "myapp" - , Qualified Lib "myapp-utils" - , Qualified FLib "myapp-flib" - , Qualified Exe "myapp-exe" - , Qualified Test "myapp-test" - , Qualified Bench "myapp-bench" - ] - - --- | Pins the discovery contract: a @cabal.project@ selects per-package --- @.cabal@ files from its @packages:@ stanza; otherwise the @.cabal@ files in --- the project root are used. -testDiscoverCabalFiles :: Spec -testDiscoverCabalFiles = do - describe "when there is no cabal.project" do - it "finds the .cabal files in the project root" do - let actual = - runDiscovery (Map.singleton "/myapp.cabal" cabalFixture) - $ discoverCabalFiles pr - actual `shouldBe` ["/myapp.cabal"] - - it "returns no files when the root has no cabal file" do - let actual = runDiscovery mempty $ discoverCabalFiles pr - actual `shouldBe` [] - - describe "when there is a multi-package cabal.project" do - it "resolves each listed package to its .cabal (regression: was root-only)" do - let actual = runDiscovery multiPackageFs $ discoverCabalFiles pr - actual `shouldBe` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] - where - pr = ProjectRoot "/" - runDiscovery fs = runPureEff . evalState fs . runFileSystemState . runLogNoOp - - -testResolveTargets :: Spec -testResolveTargets = do - describe "when targets are configured" do - it "returns configured targets as-is without reading any cabal file" do - -- The cabal file is absent from the mock FS, so any attempt to read - -- it would error; passing the test proves the early return. - let actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveTargets ["/myapp.cabal"] ["lib:foo", "test:foo-test"] - actual `shouldBe` [Qualified Test "foo-test", Qualified Lib "foo"] - - describe "when no targets are configured" do - it "auto-detects all components from the cabal file" do - let actual = - runPureEff - . evalState (Map.singleton "/myapp.cabal" cabalFixture) - . runFileSystemState - $ resolveTargets ["/myapp.cabal"] [] - actual - `shouldBe` [ Qualified Bench "myapp-bench" - , Qualified Exe "myapp-exe" - , Qualified FLib "myapp-flib" - , Qualified Test "myapp-test" - , Qualified Lib "myapp" - , Qualified Lib "myapp-utils" - ] - - it "surfaces test-suite components so they can be run after a build" do - let actual = - runPureEff - . evalState (Map.singleton "/myapp.cabal" cabalFixture) - . runFileSystemState - $ resolveTargets ["/myapp.cabal"] [] - actual `shouldContain` [Qualified Test "myapp-test"] - - it "returns no targets when there are no cabal files" do - let actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveTargets [] [] - actual `shouldBe` [] - - it "aggregates components across every package (regression: was 0)" do - let actual = - runPureEff - . evalState multiPackageFs - . runFileSystemState - $ resolveTargets ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] [] - actual `shouldContain` [Qualified Lib "pkg-a"] - actual `shouldContain` [Qualified Lib "pkg-b"] - [t | t@(Qualified Test _) <- actual] - `shouldBe` [Qualified Test "pkg-a-test", Qualified Test "pkg-b-test"] - - -testResolveWatchDirs :: Spec -testResolveWatchDirs = do - describe "when watch_dirs is set in config" do - it "uses config dirs relative to project root" do - let WatchDirs actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveWatchDirs pr [] def {watchDirs = ["src", "test"]} [] - actual `shouldBe` ["/src", "/test"] - - describe "when watch_dirs is not set" do - it "falls back to [\".\"] when targets list is empty" do - let WatchDirs actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveWatchDirs pr [] def [] - actual `shouldBe` ["."] - - it "infers source dirs from resolved targets" do - let WatchDirs actual = - runPureEff - . evalState (Map.singleton "/myapp.cabal" cabalFixture) - . runFileSystemState - $ resolveWatchDirs pr ["/myapp.cabal"] def (mkTargets ["lib:myapp", "test:myapp-test"]) - actual `shouldBe` ["/src", "/test"] - - it "falls back to [\".\"] when there are no cabal files" do - let WatchDirs actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveWatchDirs pr [] def (mkTargets ["lib:myapp"]) - actual `shouldBe` ["."] - - -- Sharp edge: an unparseable .cabal yields no source dirs, so resolution - -- falls back to watching the whole project root. This pins the current - -- behavior; if it ever changes to something narrower, update this test. - it "falls back to [\".\"] when the cabal file cannot be parsed" do - let WatchDirs actual = - runPureEff - . evalState (Map.singleton "/myapp.cabal" malformedCabal) - . runFileSystemState - $ resolveWatchDirs pr ["/myapp.cabal"] def (mkTargets ["lib:myapp"]) - actual `shouldBe` ["."] - - describe "when the project is a multi-package cabal.project" do - it "infers per-package source dirs, scoped to each package's directory" do - let WatchDirs actual = - runPureEff - . evalState multiPackageFs - . runFileSystemState - $ resolveWatchDirs - pr - ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] - def - (mkTargets ["lib:pkg-a", "test:pkg-a-test", "lib:pkg-b", "test:pkg-b-test"]) - actual - `shouldBe` ["/pkg-a/src", "/pkg-a/test", "/pkg-b/src", "/pkg-b/test"] - - it "scopes a bare package-name target to that package, ignoring siblings" do - let WatchDirs actual = - runPureEff - . evalState multiPackageFs - . runFileSystemState - $ resolveWatchDirs - pr - ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] - def - (mkTargets ["pkg-a"]) - actual `shouldBe` ["/pkg-a/src", "/pkg-a/test"] - where - pr = ProjectRoot "/" - - -testResolveTestTargets :: Spec -testResolveTestTargets = do - it "infers test: components from targets when testTargets is absent" do - let cfg = def :: Config - resolveTestTargets cfg (mkTargets ["lib:mylib", "test:mylib-test"]) `shouldBe` parseTestTargets ["test:mylib-test"] - - it "returns empty list when no test: components in targets" do - let cfg = def :: Config - resolveTestTargets cfg (mkTargets ["lib:mylib", "exe:myapp"]) `shouldBe` parseTestTargets [] - - it "uses explicit testTargets list when set" do - let cfg = def {testTargets = Just ["test:b-test"]} :: Config - resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) `shouldBe` parseTestTargets ["test:b-test"] - - it "returns empty list when testTargets is explicitly empty" do - let cfg = def {testTargets = Just []} :: Config - resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test"]) `shouldBe` parseTestTargets [] - - it "infers multiple test: components" do - let cfg = def :: Config - resolveTestTargets cfg (mkTargets ["lib:a", "test:a-test", "test:b-test"]) `shouldBe` parseTestTargets ["test:a-test", "test:b-test"] + describe "loadSession" testLoadSession -testResolveCommand :: Spec -testResolveCommand = do - describe "when config has a command" do - it "should use specified command" do - let Command actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveCommand pr def {command = Just "foo"} [] testTargets - actual `shouldBe` "foo" - - describe "when config has explicit targets" do - it "should spell them out verbatim, ignoring discovered test targets" do - let Command actual = - runPureEff - . evalState (Map.singleton "/cabal.project" "") - . runFileSystemState - $ resolveCommand pr cfg (mkTargets ["lib:foo"]) testTargets - actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo" - - describe "when config does not have a command or targets" do - describe "and there is a cabal.project file" do - it "should use cabal 'all' plus the discovered test targets" do - let Command actual = - runPureEff - . evalState (Map.singleton "/cabal.project" "") - . runFileSystemState - $ resolveCommand pr cfg [] testTargets - actual - `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo" - - describe "and there is at least one *.cabal file" do - it "should use cabal 'all' plus the discovered test targets" do - let Command actual = - runPureEff - . evalState (Map.singleton "/foo.cabal" "") - . runFileSystemState - $ resolveCommand pr cfg [] testTargets - actual - `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo" - - describe "and there is a stack.yaml file" do - it "should use stack ghci with 'all' plus test targets" do - let Command actual = - runPureEff - . evalState (Map.singleton "/stack.yaml" "") - . runFileSystemState - $ resolveCommand pr cfg [] testTargets - actual `shouldBe` "stack ghci all test:foo" +testLoadSession :: Spec +testLoadSession = do + describe "when every resolved target exposes a custom Prelude module" do + it "emits a WARN" do + let msgs = captureSessionLogs [preludeOnlyCF] + any (\m -> m.severity == WARN) msgs `shouldBe` True - describe "but there are no project files" do - it "should use default cabal repl with 'all' plus test targets" do - let Command actual = - runPureEff - . evalState mempty - . runFileSystemState - $ resolveCommand pr cfg [] testTargets - actual `shouldBe` "cabal repl --builddir /replbuild all test:foo" + describe "when not every resolved target exposes a custom Prelude module" do + it "does not emit a WARN" do + -- libWithPreludeCabal has both a lib (custom Prelude) and an exe (no Prelude) + let msgs = captureSessionLogs [mixedCF] + any (\m -> m.severity == WARN) msgs `shouldBe` False - describe "and no test targets are discovered" do - it "should fall back to plain 'all'" do - let Command actual = - runPureEff - . evalState (Map.singleton "/cabal.project" "") - . runFileSystemState - $ resolveCommand pr cfg [] (parseTestTargets []) - actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all" + it "does not emit a WARN when there are no resolved targets" do + any (\m -> m.severity == WARN) (captureSessionLogs []) `shouldBe` False where - pr = ProjectRoot "/" - cfg = def {replBuildDir = "/replbuild"} - testTargets = parseTestTargets ["test:foo"] - - -testCompareTargets :: Spec -testCompareTargets = do - describe "Ord" do - describe "only first target beginnings with 'lib:'" do - describe "first target's component name normally sorts as LT" do - it "should return GT" do - compareTargets (Qualified Lib "a") (Qualified Exe "b") `shouldBe` GT - describe "both targets have same component name" do - it "should return GT" do - compareTargets (Qualified Lib "a") (Qualified Exe "a") `shouldBe` GT - describe "first target's component name normally sorts as GT" do - it "should return GT" do - compareTargets (Qualified Lib "b") (Qualified Exe "a") `shouldBe` GT - - describe "only second target begins with 'lib:'" do - describe "first target's component name normally sorts as LT" do - it "should return LT" do - compareTargets (Qualified Exe "a") (Qualified Lib "b") `shouldBe` LT - describe "both targets have same component name" do - it "should return LT" do - compareTargets (Qualified Exe "a") (Qualified Lib "a") `shouldBe` LT - describe "first target's component name normally sorts as GT" do - it "should return LT" do - compareTargets (Qualified Exe "b") (Qualified Lib "a") `shouldBe` LT - - describe "both targets begin with 'lib:'" do - describe "first target's component name normally sorts as LT" do - it "should sort normally" do - compareTargets (Qualified Lib "a") (Qualified Lib "b") `shouldBe` LT - describe "both targets have same component name" do - it "should sort normally" do - compareTargets (Qualified Lib "a") (Qualified Lib "a") `shouldBe` EQ - describe "first target's component name normally sorts as GT" do - it "should sort normally" do - compareTargets (Qualified Lib "b") (Qualified Lib "a") `shouldBe` GT - - describe "neither target begin with 'lib:'" do - describe "first target's component name normally sorts as LT" do - it "should sort normally" do - compareTargets (Qualified Exe "a") (Qualified Exe "b") `shouldBe` LT - describe "both targets have same component name" do - it "should sort normally" do - compareTargets (Qualified Exe "a") (Qualified Exe "a") `shouldBe` EQ - describe "first target's component name normally sorts as GT" do - it "should sort normally" do - compareTargets (Qualified Exe "b") (Qualified Exe "a") `shouldBe` GT - - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -gpd :: GenericPackageDescription -gpd = - fromMaybe (error "cabalFixture failed to parse") - $ parseGenericPackageDescriptionMaybe cabalFixture - - --- | Build a target list from textual forms, exactly as config and cabal --- discovery do via 'parseTarget'. -mkTargets :: [Text] -> [Target] -mkTargets = map parseTarget - - --- | An in-memory project root with a @cabal.project@ listing two packages, --- each in its own subdirectory with a library and a test suite. -multiPackageFs :: Map FilePath ByteString -multiPackageFs = - Map.fromList - [ ("/cabal.project", "packages:\n pkg-a\n pkg-b\n\ntests: True\n") - , ("/pkg-a/pkg-a.cabal", libTestCabal "pkg-a") - , ("/pkg-b/pkg-b.cabal", libTestCabal "pkg-b") - ] - - --- | A minimal cabal file for @name@ with one library and one test suite --- (@-test@). -libTestCabal :: Text -> ByteString -libTestCabal name = - encodeUtf8 - $ T.unlines - [ "cabal-version: 2.0" - , "name: " <> name - , "version: 0.1.0.0" - , "build-type: Simple" - , "" - , "library" - , " hs-source-dirs: src" - , " build-depends: base" - , " default-language: Haskell2010" - , "" - , "test-suite " <> name <> "-test" - , " type: exitcode-stdio-1.0" - , " main-is: Test.hs" - , " hs-source-dirs: test" - , " build-depends: base" - , " default-language: Haskell2010" - ] - - --- | Not a valid @.cabal@ file: @parseGenericPackageDescriptionMaybe@ returns --- 'Nothing' for it. -malformedCabal :: ByteString -malformedCabal = "this is not a cabal file {{{ <<< @@@\n" - - -cabalFixture :: ByteString -cabalFixture = - "cabal-version: 2.0\n\ - \name: myapp\n\ - \version: 0.1.0.0\n\ - \build-type: Simple\n\ - \\n\ - \library\n\ - \ hs-source-dirs: src\n\ - \ build-depends: base\n\ - \ default-language: Haskell2010\n\ - \\n\ - \library myapp-utils\n\ - \ hs-source-dirs: utils\n\ - \ build-depends: base\n\ - \ default-language: Haskell2010\n\ - \\n\ - \foreign-library myapp-flib\n\ - \ type: native-shared\n\ - \ hs-source-dirs: flib\n\ - \ build-depends: base\n\ - \ default-language: Haskell2010\n\ - \\n\ - \executable myapp-exe\n\ - \ main-is: Main.hs\n\ - \ hs-source-dirs: app\n\ - \ build-depends: base\n\ - \ default-language: Haskell2010\n\ - \\n\ - \test-suite myapp-test\n\ - \ type: exitcode-stdio-1.0\n\ - \ main-is: Test.hs\n\ - \ hs-source-dirs: test\n\ - \ build-depends: base\n\ - \ default-language: Haskell2010\n\ - \\n\ - \benchmark myapp-bench\n\ - \ type: exitcode-stdio-1.0\n\ - \ main-is: Bench.hs\n\ - \ hs-source-dirs: bench\n\ - \ build-depends: base\n\ - \ default-language: Haskell2010\n" + preludeOnlyCF = + CabalFile "/p.cabal" + $ fromMaybe (error "preludeOnlyLibCabal failed to parse") + $ parseGenericPackageDescriptionMaybe (preludeOnlyLibCabal "p") + mixedCF = + CabalFile "/mixed.cabal" + $ fromMaybe (error "libWithPreludeCabal failed to parse") + $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "mixed") + captureSessionLogs cabalFiles = + runPureEff + . execWriter @[Message] + . runLogWriter + . evalState @(Map FilePath ByteString) mempty + . runFileSystemState + . runInputConst cabalFiles + . runReader (ProjectRoot "/") + . runInputConst (LoadedConfig Null) + $ loadSession diff --git a/test/Unit/Tricorder/SocketSpec.hs b/test/Unit/Tricorder/SocketSpec.hs --- a/test/Unit/Tricorder/SocketSpec.hs +++ b/test/Unit/Tricorder/SocketSpec.hs @@ -3,14 +3,16 @@ import Atelier.Effects.File (File, runFile) import Effectful (IOE, runEff) import System.IO (hClose, hGetLine, openFile, writeFile) -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldBe) -import Tricorder.Effects.UnixSocket +import Tricorder.Socket.Client (isDaemonReady) +import Tricorder.Socket.UnixSocket ( SocketScript (..) , UnixSocket , acceptHandle , bindSocket , removeSocketFile + , runUnixSocketIO , runUnixSocketScripted , socketFileExists ) @@ -19,6 +21,7 @@ spec_Socket :: Spec spec_Socket = do describe "runUnixSocketScripted" testScripted + describe "isDaemonReady" testReady -------------------------------------------------------------------------------- @@ -55,9 +58,36 @@ -------------------------------------------------------------------------------- +-- isDaemonReady (real IO interpreter) +-------------------------------------------------------------------------------- + +testReady :: Spec +testReady = do + it "returns False when nothing is listening on the path" do + -- A connect to a non-existent socket must be caught, not thrown: this is + -- the race the start/status path hit before the socket was bound. + result <- runIO' $ isDaemonReady "/tmp/tricorder-isdaemonready-absent.sock" + result `shouldBe` False + + it "returns True once a socket is bound and listening" do + let path = "/tmp/tricorder-isdaemonready-bound.sock" + result <- runIO' do + removeSocketFile path + _ <- bindSocket path + isDaemonReady path + runIO' $ removeSocketFile path + result `shouldBe` True + + +-------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- -- | Run scripted socket operations (no Delay needed). runScripted :: [SocketScript] -> Eff '[UnixSocket, File, IOE] a -> IO a runScripted script = runEff . runFile . runUnixSocketScripted script + + +-- | Run socket operations against the real IO interpreter. +runIO' :: Eff '[UnixSocket, File, IOE] a -> IO a +runIO' = runEff . runFile . runUnixSocketIO diff --git a/test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs b/test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs @@ -0,0 +1,30 @@ +module Unit.Tricorder.SourceLookup.GhcPkgSpec (spec_GhcPkg) where + +import Effectful (runPureEff) +import Test.Hspec + +import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), findModule, runGhcPkgScripted) + + +spec_GhcPkg :: Spec +spec_GhcPkg = do + describe "findModule" testFindModule + + +testFindModule :: Spec +testFindModule = do + it "returns Just pkgId when module is known" do + let result = runScripted [NextFindModule (Just "base-4.18")] $ findModule "Prelude" + result `shouldBe` Just "base-4.18" + + it "returns Nothing for an unknown module" do + let result = runScripted [NextFindModule Nothing] $ findModule "No.Such.Module" + result `shouldBe` Nothing + + it "returns the first scripted result" do + let result = runScripted [NextFindModule (Just "pkg-1.0"), NextFindModule (Just "pkg-2.0")] $ findModule "Foo" + result `shouldBe` Just "pkg-1.0" + + +runScripted :: [GhcPkgScript] -> Eff '[GhcPkg] a -> a +runScripted script = runPureEff . runGhcPkgScripted script diff --git a/test/Unit/Tricorder/SourceLookup/SliceSpec.hs b/test/Unit/Tricorder/SourceLookup/SliceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/SourceLookup/SliceSpec.hs @@ -0,0 +1,342 @@ +module Unit.Tricorder.SourceLookup.SliceSpec (spec_Slice) where + +import Test.Hspec + +import Data.Text qualified as T + +import Tricorder.SourceLookup.Slice (sliceSymbol) + + +spec_Slice :: Spec +spec_Slice = describe "sliceSymbol" do + valueBindings + typeDeclarations + constructors + compactDeclarations + robustness + capturePrecision + + +-- | Build a source fixture from individual lines. +src :: [Text] -> Text +src = T.unlines + + +valueBindings :: Spec +valueBindings = describe "value bindings" do + it "slices a function with its signature and doc block" do + let source = + src + [ "-- | The answer to everything." + , "answer :: Int" + , "answer = 42" + , "" + , "other :: Bool" + , "other = True" + ] + sliceSymbol "answer" source + `shouldBe` Just "-- | The answer to everything.\nanswer :: Int\nanswer = 42" + + it "slices a binding with no signature" do + let source = src ["foo = 1", "", "bar = 2"] + sliceSymbol "foo" source `shouldBe` Just "foo = 1" + + it "captures every equation of a multi-equation binding" do + let source = + src + [ "isJust :: Maybe a -> Bool" + , "isJust (Just _) = True" + , "isJust Nothing = False" + , "" + , "next = ()" + ] + sliceSymbol "isJust" source + `shouldBe` Just "isJust :: Maybe a -> Bool\nisJust (Just _) = True\nisJust Nothing = False" + + it "keeps a multi-line line-comment doc block" do + let source = + src + [ "-- | The answer to everything," + , "-- computed once." + , "answer :: Int" + , "answer = 42" + ] + sliceSymbol "answer" source + `shouldBe` Just "-- | The answer to everything,\n-- computed once.\nanswer :: Int\nanswer = 42" + + it "slices an operator binding in (op) form" do + let source = + src + [ "(<+>) :: Int -> Int -> Int" + , "a <+> b = a + b" + ] + sliceSymbol "<+>" source + `shouldBe` Just "(<+>) :: Int -> Int -> Int\na <+> b = a + b" + + it "does not match a different binding with a shared prefix" do + let source = src ["answer = 1", "", "answerable = 2"] + sliceSymbol "answerable" source `shouldBe` Just "answerable = 2" + + +-- | Real Hackage source frequently packs top-level declarations together with +-- no blank line between them. The slice must stop at the neighbouring +-- declaration, not swallow it. +compactDeclarations :: Spec +compactDeclarations = describe "adjacent declarations without blank lines" do + it "does not swallow the following binding" do + sliceSymbol "bar" (src ["foo = 1", "bar = 2", "baz = 3"]) + `shouldBe` Just "bar = 2" + + it "does not swallow the preceding binding and its signature" do + let source = + src + [ "foo :: Int" + , "foo = 1" + , "bar :: Int" + , "bar = 2" + ] + sliceSymbol "bar" source `shouldBe` Just "bar :: Int\nbar = 2" + + it "keeps the doc block but not a preceding declaration" do + let source = + src + [ "foo = 1" + , "-- | doc for bar" + , "bar = 2" + ] + sliceSymbol "bar" source `shouldBe` Just "-- | doc for bar\nbar = 2" + + it "keeps a multi-line doc block but not a preceding declaration" do + let source = + src + [ "foo = 1" + , "-- | doc for bar," + , "-- second line." + , "bar = 2" + ] + sliceSymbol "bar" source + `shouldBe` Just "-- | doc for bar,\n-- second line.\nbar = 2" + + +typeDeclarations :: Spec +typeDeclarations = describe "type declarations" do + it "slices a data declaration with doc and deriving clause" do + let source = + src + [ "-- | A JSON value." + , "data Value = Null | Bool Bool" + , " deriving (Show)" + , "" + , "instance Eq Value" + ] + sliceSymbol "Value" source + `shouldBe` Just "-- | A JSON value.\ndata Value = Null | Bool Bool\n deriving (Show)" + + it "keeps a multi-line block doc comment on a data declaration" do + let source = + src + [ "{- | A JSON value," + , " as parsed. -}" + , "data Value = Null | Bool Bool" + , "" + ] + sliceSymbol "Value" source + `shouldBe` Just "{- | A JSON value,\n as parsed. -}\ndata Value = Null | Bool Bool" + + it "slices a newtype" do + sliceSymbol "Age" (src ["newtype Age = Age Int", ""]) + `shouldBe` Just "newtype Age = Age Int" + + it "slices a type alias" do + sliceSymbol "Name" (src ["type Name = Text"]) + `shouldBe` Just "type Name = Text" + + it "slices a type family" do + sliceSymbol "Elem" (src ["type family Elem c"]) + `shouldBe` Just "type family Elem c" + + it "slices a class with its methods" do + let source = + src + [ "class Eq a => Container a where" + , " empty :: a" + , "" + , "foo = ()" + ] + sliceSymbol "Container" source + `shouldBe` Just "class Eq a => Container a where\n empty :: a" + + it "slices a record declaration including all fields" do + let source = + src + [ "data Person = Person" + , " { name :: Text" + , " , age :: Int" + , " }" + , " deriving (Show)" + , "" + ] + sliceSymbol "Person" source + `shouldBe` Just + ( "data Person = Person\n" + <> " { name :: Text\n" + <> " , age :: Int\n" + <> " }\n" + <> " deriving (Show)" + ) + + it "slices a GADT declaration" do + let source = + src + [ "data Expr a where" + , " Lit :: Int -> Expr Int" + , " Add :: Expr Int -> Expr Int -> Expr Int" + , "" + ] + sliceSymbol "Expr" source + `shouldBe` Just + ( "data Expr a where\n" + <> " Lit :: Int -> Expr Int\n" + <> " Add :: Expr Int -> Expr Int -> Expr Int" + ) + + +constructors :: Spec +constructors = describe "constructor queries" do + it "returns the enclosing data block for a constructor" do + let source = + src + [ "-- | Optionality." + , "data Maybe a = Nothing | Just a" + , "" + , "foo = ()" + ] + sliceSymbol "Just" source + `shouldBe` Just "-- | Optionality.\ndata Maybe a = Nothing | Just a" + + it "keeps a multi-line doc block above the enclosing data block" do + let source = + src + [ "-- | Optionality," + , "-- the Maybe type." + , "data Maybe a = Nothing | Just a" + , "" + ] + sliceSymbol "Just" source + `shouldBe` Just "-- | Optionality,\n-- the Maybe type.\ndata Maybe a = Nothing | Just a" + + it "returns the enclosing GADT block for a GADT constructor" do + let source = + src + [ "data Expr a where" + , " Lit :: Int -> Expr Int" + , " Add :: Expr Int -> Expr Int -> Expr Int" + , "" + ] + sliceSymbol "Lit" source + `shouldBe` Just + ( "data Expr a where\n" + <> " Lit :: Int -> Expr Int\n" + <> " Add :: Expr Int -> Expr Int -> Expr Int" + ) + + +robustness :: Spec +robustness = describe "robustness" do + it "returns Nothing for a missing symbol" do + sliceSymbol "nope" (src ["foo = 1", "bar = 2"]) `shouldBe` Nothing + + it "returns Nothing for an empty query" do + sliceSymbol "" (src ["foo = 1"]) `shouldBe` Nothing + + it "does not choke on CPP-laden source" do + let source = + src + [ "#if MIN_VERSION_base(4,18,0)" + , "answer :: Int" + , "#else" + , "answer :: Integer" + , "#endif" + , "answer = 42" + ] + let result = sliceSymbol "answer" source + result `shouldSatisfy` isJust + fmap (T.isInfixOf "answer = 42") result `shouldBe` Just True + + +-- | The slice must span exactly the queried declaration: not truncating it +-- early, not swallowing a neighbour, and not anchoring on the wrong entity. +-- These are the over-/under-capture shapes real Hackage source triggers. +capturePrecision :: Spec +capturePrecision = describe "capture precision" do + it "keeps a where-clause that contains a blank line" do + let source = + src + [ "foo x = go x" + , " where" + , " go y = y + 1" + , "" + , " helper = 2" + , "" + , "bar = 3" + ] + sliceSymbol "foo" source + `shouldBe` Just "foo x = go x\n where\n go y = y + 1\n\n helper = 2" + + it "does not swallow a following binding that merely uses the operator" do + let source = + src + [ "(<+>) :: Int -> Int -> Int" + , "a <+> b = a + b" + , "merge x y = x <+> y" + ] + sliceSymbol "<+>" source + `shouldBe` Just "(<+>) :: Int -> Int -> Int\na <+> b = a + b" + + it "does not anchor on a superclass name in a class head" do + let source = + src + [ "class Eq a => Ord a where" + , " compare :: a -> a -> Ordering" + ] + sliceSymbol "Eq" source `shouldBe` Nothing + + it "slices a class that has a superclass context by its own name" do + let source = + src + [ "class Eq a => Ord a where" + , " compare :: a -> a -> Ordering" + ] + sliceSymbol "Ord" source + `shouldBe` Just "class Eq a => Ord a where\n compare :: a -> a -> Ordering" + + it "picks the data block that actually defines the constructor" do + let source = + src + [ "-- | Uses Just internally." + , "data Wrapper = Wrap Int" + , "" + , "data Maybe a = Nothing | Just a" + ] + sliceSymbol "Just" source + `shouldBe` Just "data Maybe a = Nothing | Just a" + + it "does not anchor on a constructor name used as a field type elsewhere" do + let source = + src + [ "data Holder = Holder Bar" + , "" + , "data Thing = Bar | Baz" + ] + sliceSymbol "Bar" source `shouldBe` Just "data Thing = Bar | Baz" + + it "keeps a multi-line {- | -} block doc comment" do + let source = + src + [ "{- | This does X" + , " over multiple lines. -}" + , "foo :: Int" + , "foo = 1" + ] + sliceSymbol "foo" source + `shouldBe` Just "{- | This does X\n over multiple lines. -}\nfoo :: Int\nfoo = 1" diff --git a/test/Unit/Tricorder/SourceLookup/TarballSpec.hs b/test/Unit/Tricorder/SourceLookup/TarballSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/SourceLookup/TarballSpec.hs @@ -0,0 +1,107 @@ +module Unit.Tricorder.SourceLookup.TarballSpec (spec_Tarball) where + +import System.FilePath (isAbsolute, ()) +import Test.Hspec + +import Codec.Archive.Tar qualified as Tar +import Codec.Archive.Tar.Entry qualified as Tar +import Codec.Compression.GZip qualified as GZip +import Data.ByteString.Lazy qualified as BSL + +import Tricorder.SourceLookup.Tarball + ( cabalPackagesDirs + , extractModule + , matchesModule + , splitPackageId + , tarballPath + ) + + +spec_Tarball :: Spec +spec_Tarball = do + describe "splitPackageId" do + it "splits a simple package id" do + splitPackageId "aeson-2.2.5.0" `shouldBe` ("aeson", "2.2.5.0") + + it "keeps hyphens inside the package name" do + splitPackageId "list-t-1.0.5.7" `shouldBe` ("list-t", "1.0.5.7") + + describe "tarballPath" do + it "derives the cache path for a package id" do + tarballPath "/c" "hackage.haskell.org" "aeson-2.2.5.0" + `shouldBe` "/c" "hackage.haskell.org/aeson/2.2.5.0/aeson-2.2.5.0.tar.gz" + + describe "cabalPackagesDirs" do + it "honors CABAL_DIR" do + cabalPackagesDirs [("CABAL_DIR", "/cd")] `shouldBe` ["/cd/packages"] + + it "includes the legacy ~/.cabal location alongside the XDG one" do + cabalPackagesDirs [("HOME", "/h")] + `shouldBe` ["/h/.cache/cabal/packages", "/h/.cabal/packages"] + + it "yields no candidates (never a relative path) when HOME is unset" do + cabalPackagesDirs [] `shouldBe` [] + + it "only ever produces absolute candidates" do + all isAbsolute (cabalPackagesDirs [("HOME", "/h"), ("XDG_CACHE_HOME", "/x")]) + `shouldBe` True + + describe "matchesModule" do + it "matches a src/ layout entry" do + matchesModule "Data.Aeson" "aeson-2.2.5.0/src/Data/Aeson.hs" `shouldBe` True + + it "matches a lib/ layout entry" do + matchesModule "Data.Aeson" "aeson-2.2.5.0/lib/Data/Aeson.hs" `shouldBe` True + + it "matches a flat layout entry" do + matchesModule "Data.Aeson" "aeson-2.2.5.0/Data/Aeson.hs" `shouldBe` True + + it "does not match a different module under the same prefix" do + matchesModule "Data.Aeson" "aeson-2.2.5.0/src/Data/Aeson/Types.hs" `shouldBe` False + + it "does not match a deeper module whose final component coincides" do + -- Module `Lens` must not resolve to the file for `Control.Lens`. + matchesModule "Lens" "pkg-1.0/Control/Lens.hs" `shouldBe` False + + it "matches a preprocessed .hsc entry" do + matchesModule "System.Posix.Files" "unix-2.8.5.0/System/Posix/Files.hsc" `shouldBe` True + + it "matches a literate .lhs entry" do + matchesModule "Data.Ratio" "base-4.19.0.0/src/Data/Ratio.lhs" `shouldBe` True + + describe "extractModule" do + it "extracts a member by module name" do + extractModule "Data.Aeson" fixtureTarball `shouldBe` Just "module Data.Aeson where\n" + + it "returns Nothing when the module is absent" do + extractModule "Data.Missing" fixtureTarball `shouldBe` Nothing + + it "prefers a library source path over a same-named test path" do + extractModule "Data.Aeson" dupModuleTarball + `shouldBe` Just "module Data.Aeson (lib) where\n" + + +-- | A gzipped tar with a single source member. +fixtureTarball :: LByteString +fixtureTarball = mkTarball [("aeson-2.2.5.0/src/Data/Aeson.hs", "module Data.Aeson where\n")] + + +-- | A gzipped tar in which the same module appears under both a test tree and +-- the library tree, with the test copy listed first. +dupModuleTarball :: LByteString +dupModuleTarball = + mkTarball + [ ("aeson-2.2.5.0/tests/Data/Aeson.hs", "module Data.Aeson (test) where\n") + , ("aeson-2.2.5.0/src/Data/Aeson.hs", "module Data.Aeson (lib) where\n") + ] + + +-- | Build a gzipped tar from @(path, contents)@ pairs, in the given order. +mkTarball :: [(FilePath, Text)] -> LByteString +mkTarball entries = + GZip.compress (Tar.write [fileEntry path content | (path, content) <- entries]) + where + fileEntry path content = + Tar.fileEntry + (either (error . toText) id (Tar.toTarPath False path)) + (BSL.fromStrict (encodeUtf8 content)) diff --git a/test/Unit/Tricorder/SourceLookupSpec.hs b/test/Unit/Tricorder/SourceLookupSpec.hs --- a/test/Unit/Tricorder/SourceLookupSpec.hs +++ b/test/Unit/Tricorder/SourceLookupSpec.hs @@ -1,139 +1,259 @@ module Unit.Tricorder.SourceLookupSpec (spec_SourceLookup) where import Atelier.Effects.Cache (Cache, runCacheForever) +import Atelier.Effects.Env (Env, runEnvConst) import Atelier.Effects.FileSystem (FileSystem (..)) import Atelier.Effects.Log (Log, runLogNoOp) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.Reader.Static (Reader, runReader) +import Effectful.State.Static.Shared (State, evalState, gets, modify) +import System.FilePath (()) import Test.Hspec +import Codec.Archive.Tar qualified as Tar +import Codec.Archive.Tar.Entry qualified as Tar +import Codec.Compression.GZip qualified as GZip +import Data.ByteString.Lazy qualified as BSL +import Data.IORef qualified as IORef +import Data.List qualified as List import Data.Map.Strict qualified as Map +import Data.Text qualified as T -import Tricorder.Effects.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted) -import Tricorder.GhcPkg.Types (ModuleName, PackageId, SourceQuery (..)) -import Tricorder.SourceLookup (ModuleSourceResult (..), ReExport, lookupModuleSource) +import Tricorder.Module (ModuleName, PackageId) +import Tricorder.Runtime (ProjectRoot (..)) +import Tricorder.SourceLookup + ( ModuleSourceResult (..) + , SourceQuery (..) + , lookupModuleSource + ) +import Tricorder.SourceLookup.Cabal (Cabal, FetchResult (..), runCabalFetchWith) +import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted) spec_SourceLookup :: Spec -spec_SourceLookup = do - describe "lookupModuleSource" testLookupModuleSource - +spec_SourceLookup = describe "lookupModuleSource" do + it "reads the whole module from a cached tarball" do + result <- + runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch + $ lookupModuleSource (wholeModule "Data.Aeson") + result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource -testLookupModuleSource :: Spec -testLookupModuleSource = do - it "returns SourceFound when module, haddock-html, and file are present" do + it "slices a symbol (with its doc block) from a cached tarball" do result <- - runTest - [ NextFindModule (Just "pkg-1.0") - , NextGetHaddockHtml (Just "/haddock/pkg") - ] - (Map.singleton "/haddock/pkg/src/Foo.html" sampleHtml) - (lookupModuleSource (wholeModule "Foo")) - result `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" [] + runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch + $ lookupModuleSource (symbol "Data.Aeson" "encode") + result + `shouldBe` SourceFound + (symbol "Data.Aeson" "encode") + "-- | Encode a value as JSON.\nencode :: Value -> ByteString\nencode = undefined" - it "returns SourceFound on second call without re-querying GhcPkg (cache hit)" do - -- Only one NextFindModule and one NextGetHaddockHtml in the script. - -- The second call must come entirely from cache (no script pop). - (r1, r2) <- runTest - [ NextFindModule (Just "pkg-1.0") - , NextGetHaddockHtml (Just "/haddock/pkg") - ] - (Map.singleton "/haddock/pkg/src/Foo.html" sampleHtml) - $ do - r1 <- lookupModuleSource (wholeModule "Foo") - r2 <- lookupModuleSource (wholeModule "Foo") - pure (r1, r2) - r1 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" [] - r2 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" [] + it "returns FunctionNotFound for a symbol absent from the module" do + result <- + runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch + $ lookupModuleSource (symbol "Data.Aeson" "nope") + result `shouldBe` FunctionNotFound (symbol "Data.Aeson" "nope") - it "returns SourceNotFound when findModule returns Nothing" do + it "returns SourceNotFound when the module is in no package" do result <- - runTest - [NextFindModule Nothing] - Map.empty - (lookupModuleSource (wholeModule "Unknown")) - result `shouldBe` SourceNotFound (wholeModule "Unknown") + runTest [NextFindModule Nothing] Map.empty noFetch + $ lookupModuleSource (wholeModule "Data.Unknown") + result `shouldBe` SourceNotFound (wholeModule "Data.Unknown") - it "returns SourceNoHaddock when getHaddockHtml returns Nothing" do + it "fetches on a cache miss, then reads the now-present tarball" do result <- - runTest - [ NextFindModule (Just "no-docs-1.0") - , NextGetHaddockHtml Nothing - ] - Map.empty - (lookupModuleSource (wholeModule "Foo")) - result `shouldBe` SourceNoHaddock (wholeModule "Foo") "no-docs-1.0" + runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty (fetchProduces tarballPath tarballBytes) + $ lookupModuleSource (wholeModule "Data.Aeson") + result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource - it "returns SourceNoHaddock when the html file does not exist" do + it "returns SourceUnavailable when the fetch produces no tarball" do result <- - runTest - [ NextFindModule (Just "pkg-1.0") - , NextGetHaddockHtml (Just "/haddock/pkg") - ] - Map.empty - (lookupModuleSource (wholeModule "Foo")) - result `shouldBe` SourceNoHaddock (wholeModule "Foo") "pkg-1.0" + runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty noFetch + $ lookupModuleSource (wholeModule "Data.Aeson") + result `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0" - it "handles two different module names independently" do - (r1, r2) <- runTest - [ NextFindModule (Just "pkg-a-1.0") - , NextGetHaddockHtml (Just "/haddock/pkg-a") - , NextFindModule (Just "pkg-b-1.0") - , NextGetHaddockHtml (Just "/haddock/pkg-b") - ] - ( Map.fromList - [ ("/haddock/pkg-a/src/Foo.html", sampleHtml) - , ("/haddock/pkg-b/src/Bar.html", barHtml) - ] - ) - $ do - r1 <- lookupModuleSource (wholeModule "Foo") - r2 <- lookupModuleSource (wholeModule "Bar") + it "caches the result so a second lookup needs no further resolution" do + -- Only one NextFindModule is scripted; the second lookup must be served + -- entirely from cache (module→package and package→source). + (r1, r2) <- + runTest [NextFindModule (Just "aeson-2.2.5.0")] withTarball noFetch $ do + r1 <- lookupModuleSource (wholeModule "Data.Aeson") + r2 <- lookupModuleSource (wholeModule "Data.Aeson") pure (r1, r2) - r1 `shouldBe` SourceFound (wholeModule "Foo") "module Foo where" [] - r2 `shouldBe` SourceFound (wholeModule "Bar") "module Bar where" [] + r1 `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource + r2 `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource + it "caches an unavailable result and does not re-fetch on a repeat lookup" do + -- The tarball is absent and every fetch fails, so the first lookup is + -- SourceUnavailable. A repeat lookup must be served from cache — no + -- second `cabal fetch` on the (network) request path. + fetchCount <- IORef.newIORef (0 :: Int) + let countingFetch = do + liftIO (IORef.modifyIORef' fetchCount (+ 1)) + noFetch + (r1, r2) <- + runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty countingFetch $ do + r1 <- lookupModuleSource (wholeModule "Data.Aeson") + r2 <- lookupModuleSource (wholeModule "Data.Aeson") + pure (r1, r2) + r1 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0" + r2 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0" + fetches <- IORef.readIORef fetchCount + fetches `shouldBe` 1 + it "re-fetches after a failed fetch rather than caching the failure" do + -- A failed `cabal fetch` (offline, stale index) is transient, so the + -- resulting SourceUnavailable must NOT be cached: a repeat lookup has to + -- retry the fetch, or a brief network blip pins unavailability for the + -- whole cache window. + fetchCount <- IORef.newIORef (0 :: Int) + let failingFetch = do + liftIO (IORef.modifyIORef' fetchCount (+ 1)) + pure FetchFailed + (r1, r2) <- + runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty failingFetch $ do + r1 <- lookupModuleSource (wholeModule "Data.Aeson") + r2 <- lookupModuleSource (wholeModule "Data.Aeson") + pure (r1, r2) + r1 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0" + r2 `shouldBe` SourceUnavailable (wholeModule "Data.Aeson") "aeson-2.2.5.0" + fetches <- IORef.readIORef fetchCount + fetches `shouldBe` 2 + + it "finds a tarball in the legacy ~/.cabal cache location" do + result <- + runTest [NextFindModule (Just "aeson-2.2.5.0")] withLegacyTarball noFetch + $ lookupModuleSource (wholeModule "Data.Aeson") + result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource + + -------------------------------------------------------------------------------- -- Fixtures -------------------------------------------------------------------------------- -sampleHtml :: LByteString -sampleHtml = "
module Foo where
" +-- | Source of the fixture module, carried verbatim in the fixture tarball. +moduleSource :: Text +moduleSource = + T.unlines + [ "module Data.Aeson where" + , "" + , "-- | Encode a value as JSON." + , "encode :: Value -> ByteString" + , "encode = undefined" + ] -barHtml :: LByteString -barHtml = "
module Bar where
" +-- | The cabal cache path the fixture package resolves to under @HOME=\/h@. +tarballPath :: FilePath +tarballPath = + "/h/.cache/cabal/packages" "hackage.haskell.org/aeson/2.2.5.0/aeson-2.2.5.0.tar.gz" --- | Helper: a whole-module query (no function filter). +-- | A gzipped tar holding the fixture module under a @src\/@ layout. +tarballBytes :: LByteString +tarballBytes = mkTarball "aeson-2.2.5.0/src/Data/Aeson.hs" moduleSource + + +-- | A filesystem in which the fixture tarball is already cached. +withTarball :: Map FilePath LByteString +withTarball = Map.singleton tarballPath tarballBytes + + +-- | The legacy (pre-XDG) cabal cache path under @HOME=\/h@. +legacyTarballPath :: FilePath +legacyTarballPath = + "/h/.cabal/packages" "hackage.haskell.org/aeson/2.2.5.0/aeson-2.2.5.0.tar.gz" + + +-- | A filesystem in which the fixture tarball lives only in the legacy cache. +withLegacyTarball :: Map FilePath LByteString +withLegacyTarball = Map.singleton legacyTarballPath tarballBytes + + +mkTarball :: FilePath -> Text -> LByteString +mkTarball entryPath content = + GZip.compress (Tar.write [Tar.fileEntry tarPath (BSL.fromStrict (encodeUtf8 content))]) + where + tarPath = either (error . toText) id (Tar.toTarPath False entryPath) + + wholeModule :: ModuleName -> SourceQuery wholeModule m = SourceQuery {moduleName = m, function = Nothing} +symbol :: ModuleName -> Text -> SourceQuery +symbol m s = SourceQuery {moduleName = m, function = Just s} + + -------------------------------------------------------------------------------- --- Helpers +-- Harness -------------------------------------------------------------------------------- -runFileSystemScripted :: Map FilePath LByteString -> Eff (FileSystem : es) a -> Eff es a -runFileSystemScripted files = interpret_ \case - DoesFileExist path -> pure $ Map.member path files - ReadFileLbsFrom path _ -> pure $ fromMaybe "" (Map.lookup path files) - _ -> error "FileSystemScripted: unexpected operation" +-- | The action a faked @cabal fetch@ runs: 'noFetch' leaves the filesystem +-- untouched (a clean fetch that produces no tarball); 'fetchProduces' inserts a +-- file. A failed fetch is modelled by returning 'FetchFailed' directly. +noFetch :: Eff es FetchResult +noFetch = pure Fetched +fetchProduces + :: (State (Map FilePath LByteString) :> es) + => FilePath -> LByteString -> Eff es FetchResult +fetchProduces path bytes = do + modify (Map.insert path bytes) + pure Fetched + + runTest :: [GhcPkgScript] -> Map FilePath LByteString - -> Eff '[Cache ModuleName PackageId, Cache (PackageId, SourceQuery) (Text, [ReExport]), FileSystem, GhcPkg, Log, Concurrent, IOE] a + -> Eff '[FileSystem, State (Map FilePath LByteString), Log, Concurrent, IOE] FetchResult + -> Eff + '[ Cache ModuleName PackageId + , Cache (PackageId, SourceQuery) ModuleSourceResult + , GhcPkg + , Env + , Reader ProjectRoot + , Cabal + , FileSystem + , State (Map FilePath LByteString) + , Log + , Concurrent + , IOE + ] + a -> IO a -runTest pkgScript files action = +runTest pkgScript initialFs onFetch action = runEff . runConcurrent . runLogNoOp + . evalState initialFs + . runFileSystemFake + . runCabalFetchWith onFetch + . runReader (ProjectRoot "/proj") + . runEnvConst [("HOME", "/h")] . runGhcPkgScripted pkgScript - . runFileSystemScripted files - . runCacheForever @(PackageId, SourceQuery) @(Text, [ReExport]) + . runCacheForever @(PackageId, SourceQuery) @ModuleSourceResult . runCacheForever @ModuleName @PackageId $ action + + +-- | A 'FileSystem' backed by an in-memory map, with directory semantics good +-- enough for the cabal-cache layout: 'doesPathExist' treats a key as living +-- under any of its path prefixes, and 'listDirectory' returns immediate child +-- names (so a repo subdir like @hackage.haskell.org@ is discoverable). +runFileSystemFake + :: (State (Map FilePath LByteString) :> es) + => Eff (FileSystem : es) a -> Eff es a +runFileSystemFake = interpret_ \case + DoesFileExist p -> gets (Map.member p) + DoesPathExist p -> gets (any (isUnder p) . Map.keys) + ListDirectory p -> gets (ordNub . mapMaybe (childName p) . Map.keys) + ReadFileLbsFrom p _ -> gets (fromMaybe "" . Map.lookup p) + _ -> error "runFileSystemFake: unexpected operation" + where + isUnder p k = p == k || (p <> "/") `List.isPrefixOf` k + childName p k = case List.stripPrefix (p <> "/") k of + Just rest | not (null rest) -> Just (takeWhile (/= '/') rest) + _ -> Nothing diff --git a/test/Unit/Tricorder/SourceSpec.hs b/test/Unit/Tricorder/SourceSpec.hs deleted file mode 100644 --- a/test/Unit/Tricorder/SourceSpec.hs +++ /dev/null @@ -1,161 +0,0 @@ -module Unit.Tricorder.SourceSpec (spec_Source) where - -import Test.Hspec - -import Tricorder.SourceLookup (extractFunctionSource, extractSource, stripAnnotations, stripTags, unescapeEntities) - - -spec_Source :: Spec -spec_Source = do - describe "extractSource" testExtractSource - describe "extractFunctionSource" testExtractFunctionSource - describe "stripAnnotations" testStripAnnotations - describe "stripTags" testStripTags - describe "unescapeEntities" testUnescapeEntities - - -testExtractSource :: Spec -testExtractSource = do - it "returns content between 
 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
--- a/test/Unit/Tricorder/TestOutputSpec.hs
+++ b/test/Unit/Tricorder/TestOutputSpec.hs
@@ -2,10 +2,11 @@
 
 import Test.Hspec
 
-import Tricorder.BuildState (TestCase (..), TestCaseOutcome (..))
 import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput, stripGhciNoise)
 
+import Tricorder.Build.Test qualified as Test
 
+
 spec_TestOutput :: Spec
 spec_TestOutput = do
     describe "parseHspecOutput" do
@@ -15,12 +16,12 @@
         it "parses a passing test" do
             let output = "  foo\n    bar baz:                                      OK\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "bar baz:", outcome = TestCasePassed}]
+                `shouldBe` [Test.Case {description = "bar baz:", outcome = Test.Passed}]
 
         it "parses a failing test" do
             let output = "  foo\n    bar baz:                                      FAIL\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "bar baz:", outcome = TestCaseFailed ""}]
+                `shouldBe` [Test.Case {description = "bar baz:", outcome = Test.Failed ""}]
 
         it "captures failure details" do
             let output =
@@ -29,11 +30,11 @@
                         <> "       but got: 2\n"
                         <> "    another test:                                       OK\n"
             parseHspecOutput output
-                `shouldBe` [ TestCase
+                `shouldBe` [ Test.Case
                                 { description = "a test:"
-                                , outcome = TestCaseFailed "expected: 1\nbut got: 2"
+                                , outcome = Test.Failed "expected: 1\nbut got: 2"
                                 }
-                           , TestCase {description = "another test:", outcome = TestCasePassed}
+                           , Test.Case {description = "another test:", outcome = Test.Passed}
                            ]
 
         it "stops collecting details when indentation returns to test level" do
@@ -44,7 +45,7 @@
             let cases = parseHspecOutput output
             length cases `shouldBe` 2
             case cases of
-                (c : _) -> c.outcome `shouldBe` TestCaseFailed "detail line"
+                (c : _) -> c.outcome `shouldBe` Test.Failed "detail line"
                 [] -> expectationFailure "expected at least one test case"
 
         it "skips group header lines" do
@@ -53,7 +54,7 @@
                         <> "    someFunction\n"
                         <> "      does the thing:                                  OK\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "does the thing:", outcome = TestCasePassed}]
+                `shouldBe` [Test.Case {description = "does the thing:", outcome = Test.Passed}]
 
         it "parses mixed passing and failing tests" do
             let output =
@@ -63,30 +64,30 @@
                         <> "      reason\n"
                         <> "    also passes:                                       OK\n"
             parseHspecOutput output
-                `shouldBe` [ TestCase {description = "passes:", outcome = TestCasePassed}
-                           , TestCase {description = "fails:", outcome = TestCaseFailed "reason"}
-                           , TestCase {description = "also passes:", outcome = TestCasePassed}
+                `shouldBe` [ Test.Case {description = "passes:", outcome = Test.Passed}
+                           , Test.Case {description = "fails:", outcome = Test.Failed "reason"}
+                           , Test.Case {description = "also passes:", outcome = Test.Passed}
                            ]
 
         it "parses a passing test with a timing annotation" do
             let output = "  slow test:                                          OK (0.05s)\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "slow test:", outcome = TestCasePassed}]
+                `shouldBe` [Test.Case {description = "slow test:", outcome = Test.Passed}]
 
         it "parses a passing test with a millisecond annotation" do
             let output = "  fast property:                                      OK (12ms)\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "fast property:", outcome = TestCasePassed}]
+                `shouldBe` [Test.Case {description = "fast property:", outcome = Test.Passed}]
 
         it "parses a failing test with a timing annotation" do
             let output = "  slow fail:                                          FAIL (0.03s)\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "slow fail:", outcome = TestCaseFailed ""}]
+                `shouldBe` [Test.Case {description = "slow fail:", outcome = Test.Failed ""}]
 
         it "does not strip a non-timing parenthetical in the description" do
             let output = "  test (corner case):                                 OK\n"
             parseHspecOutput output
-                `shouldBe` [TestCase {description = "test (corner case):", outcome = TestCasePassed}]
+                `shouldBe` [Test.Case {description = "test (corner case):", outcome = Test.Passed}]
 
     describe "parseHspecDuration" do
         it "returns Nothing for empty output" do
diff --git a/test/Unit/Tricorder/TestRunnerSpec.hs b/test/Unit/Tricorder/TestRunnerSpec.hs
deleted file mode 100644
--- a/test/Unit/Tricorder/TestRunnerSpec.hs
+++ /dev/null
@@ -1,319 +0,0 @@
-module Unit.Tricorder.TestRunnerSpec (spec_TestRunner) where
-
-import Atelier.Effects.Clock (runClockConst)
-import Atelier.Effects.Delay (runDelay)
-import Atelier.Effects.Input (runInputConst)
-import Atelier.Effects.Log (runLogNoOp)
-import Control.Concurrent.STM (newTVarIO, writeTVar)
-import Control.Exception (ErrorCall (..))
-import Data.Time (UTCTime (..), fromGregorian)
-import Effectful (IOE, runEff)
-import Effectful.Concurrent (Concurrent, runConcurrent)
-import Effectful.Concurrent.STM (atomically)
-import Effectful.Exception (try)
-import Effectful.Reader.Static (runReader)
-import Effectful.State.Static.Shared (evalState)
-import Test.Hspec
-
-import Tricorder.BuildState
-    ( BuildId (..)
-    , BuildPhase (..)
-    , BuildProgress (..)
-    , BuildResult (..)
-    , BuildState (..)
-    , DaemonInfo (..)
-    , TestRun (..)
-    , TestRunCompletion (..)
-    )
-import Tricorder.Effects.BuildStore (getState)
-import Tricorder.Effects.GhciSession.GhciParser (GhciLoading (..))
-import Tricorder.Effects.TestRunner
-    ( GhciOutcome (..)
-    , TestRunner
-    , abortGatedProgress
-    , detectOutcome
-    , interruptCurrent
-    , isAborted
-    , resetAbort
-    , runTestRunnerScripted
-    , runTestSuite
-    )
-import Tricorder.Runtime (ProjectRoot (..))
-
-import Tricorder.Effects.BuildStore qualified as BuildStore
-
-
-spec_TestRunner :: Spec
-spec_TestRunner = do
-    describe "detectOutcome" testDetectOutcome
-    describe "runTestRunnerScripted" testScripted
-    describe "abortGatedProgress" testAbortGatedProgress
-
-
---------------------------------------------------------------------------------
--- detectOutcome tests
---------------------------------------------------------------------------------
-
-testDetectOutcome :: Spec
-testDetectOutcome = do
-    describe "no exception line" do
-        it "treats empty output as pass" do
-            detectOutcome "" `shouldBe` GhciPassed
-
-        it "treats output with no exception as pass" do
-            detectOutcome "2 examples, 0 failures\n" `shouldBe` GhciPassed
-
-        it "does not match 'ExitSuccess' without the exception prefix" do
-            detectOutcome "ExitSuccess\n" `shouldBe` GhciPassed
-
-    describe "ExitSuccess" do
-        it "detects ExitSuccess as pass" do
-            detectOutcome "*** Exception: ExitSuccess\n" `shouldBe` GhciPassed
-
-        it "detects ExitSuccess anywhere in output" do
-            detectOutcome "All tests passed\n*** Exception: ExitSuccess\n"
-                `shouldBe` GhciPassed
-
-    describe "ExitFailure" do
-        it "detects ExitFailure 1 as fail" do
-            detectOutcome "1 failure\n*** Exception: ExitFailure 1\n"
-                `shouldBe` GhciFailed
-
-        it "detects ExitFailure with any exit code as fail" do
-            detectOutcome "*** Exception: ExitFailure 42\n" `shouldBe` GhciFailed
-
-        it "detects ExitFailure anywhere in output" do
-            detectOutcome "Some output\n*** Exception: ExitFailure 1\nMore output\n"
-                `shouldBe` GhciFailed
-
-    describe "other exception" do
-        it "classifies unknown exception as error with message" do
-            detectOutcome "*** Exception: SomeException \"oops\"\n"
-                `shouldBe` GhciCrashed "SomeException \"oops\""
-
-        it "trims trailing whitespace from the error message" do
-            detectOutcome "*** Exception: Crashed  \n"
-                `shouldBe` GhciCrashed "Crashed"
-
-    describe "compile failure (no exception line, but GHC errors present)" do
-        it "flags ':main not in scope' as crashed" do
-            detectOutcome ":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/WaitersSpec.hs b/test/Unit/Tricorder/WaitersSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Unit/Tricorder/WaitersSpec.hs
@@ -0,0 +1,140 @@
+module Unit.Tricorder.WaitersSpec (spec_Waiters) where
+
+import Atelier.Effects.Conc (Conc, runConc)
+import Effectful (IOE, runEff)
+import Effectful.Concurrent (Concurrent, runConcurrent)
+import Effectful.Exception (catch, throwIO)
+import Effectful.State.Static.Shared (State, get, modify, runState)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldThrow)
+
+import Atelier.Effects.Conc qualified as Conc
+import Atelier.Types.Semaphore qualified as Sem
+
+import Tricorder.Waiters (Waiters)
+
+import Tricorder.Waiters qualified as Waiters
+
+
+-- | Test exception type, used to prove that a waiter's slot is released
+-- even when its action throws.
+data TestException = TestException Text
+    deriving stock (Eq, Show)
+    deriving anyclass (Exception)
+
+
+runWaitersTest
+    :: Eff [Waiters, State [Text], Conc, Concurrent, IOE] a
+    -> IO (a, [Text])
+runWaitersTest =
+    runEff
+        . runConcurrent
+        . runConc
+        . runState @[Text] []
+        . Waiters.run
+
+
+logEvent :: (State [Text] :> es) => Text -> Eff es ()
+logEvent name = modify (<> [name])
+
+
+spec_Waiters :: Spec
+spec_Waiters = do
+    describe "Waiters.without" do
+        describe "with waiters" $ it "skips the action" do
+            (_, events) <- runWaitersTest do
+                proceed <- Sem.new
+                started <- Sem.new
+                waiter <- Conc.fork $ Waiters.with do
+                    void $ Sem.set started
+                    Sem.wait proceed
+                    logEvent "waiter"
+                Sem.wait started
+                -- Called directly (not forked): Without never blocks, so
+                -- forking it here would race its no-waiters check against
+                -- the `Sem.set proceed` below, making the test flaky.
+                Waiters.without (logEvent "without")
+                void $ Sem.set proceed
+                Conc.await waiter
+            events `shouldBe` ["waiter"]
+        it "runs its action immediately when there are no active waiters" do
+            (_, events) <- runWaitersTest $ Waiters.without (logEvent "ran")
+            events `shouldBe` ["ran"]
+
+    describe "Waiters.with" do
+        it "runs its action" do
+            (_, events) <- runWaitersTest $ Waiters.with (logEvent "ran")
+            events `shouldBe` ["ran"]
+
+        it "lets a subsequent Waiters.wait proceed once it has completed" do
+            (_, events) <- runWaitersTest do
+                Waiters.with (logEvent "waiter")
+                Waiters.wait (logEvent "quiesced")
+            events `shouldBe` ["waiter", "quiesced"]
+
+        it "blocks a concurrent Waiters.wait until its action finishes" do
+            (_, events) <- runWaitersTest do
+                started <- Sem.new
+                proceed <- Sem.new
+                waiter <- Conc.fork $ Waiters.with do
+                    _ <- Sem.set started
+                    Sem.wait proceed
+                    logEvent "waiter-end"
+                Sem.wait started
+                quiescent <- Conc.fork $ Waiters.wait (logEvent "quiesced")
+                _ <- Sem.set proceed
+                Conc.await waiter
+                Conc.await quiescent
+            -- Blocking is guaranteed by the STM retry on the waiter count,
+            -- not by scheduling luck, so this order holds on every run.
+            events `shouldBe` ["waiter-end", "quiesced"]
+
+        it "blocks wait until every concurrent waiter finishes" do
+            (afterFirst, events) <- runWaitersTest do
+                started1 <- Sem.new
+                proceed1 <- Sem.new
+                waiter1 <- Conc.fork $ Waiters.with do
+                    _ <- Sem.set started1
+                    Sem.wait proceed1
+                    logEvent "waiter1-end"
+                Sem.wait started1
+
+                quiescent <- Conc.fork $ Waiters.wait (logEvent "quiesced")
+
+                started2 <- Sem.new
+                proceed2 <- Sem.new
+                waiter2 <- Conc.fork $ Waiters.with do
+                    _ <- Sem.set started2
+                    Sem.wait proceed2
+                    logEvent "waiter2-end"
+                Sem.wait started2
+
+                _ <- Sem.set proceed1
+                Conc.await waiter1
+                -- waiter2 is still active here, so the waiter count cannot
+                -- have reached zero yet: quiescent is still blocked, not
+                -- just "hasn't been scheduled".
+                afterFirst <- get
+                _ <- Sem.set proceed2
+                Conc.await waiter2
+                -- No snapshot is taken here: once waiter2's slot is released,
+                -- quiescent's STM retry can wake and log concurrently with
+                -- this thread, so there is no deterministic in-between state
+                -- to observe. Only the final, fully-awaited state is safe to
+                -- assert on.
+                Conc.await quiescent
+                pure afterFirst
+            afterFirst `shouldMatchList` ["waiter1-end"]
+            events `shouldMatchList` ["waiter1-end", "waiter2-end", "quiesced"]
+
+    describe "exception safety" do
+        it "propagates an exception raised by the waiter's action" do
+            let action = runWaitersTest $ Waiters.with (throwIO $ TestException "boom")
+            action `shouldThrow` \(TestException msg) -> msg == "boom"
+
+        it "releases the waiter slot even when the action throws" do
+            (_, events) <- runWaitersTest do
+                _ <-
+                    Waiters.with (throwIO $ TestException "boom")
+                        `catch` \(_ :: TestException) -> pure ()
+                Waiters.without (logEvent "quiesced")
+            events `shouldBe` ["quiesced"]
diff --git a/test/Unit/Tricorder/WatcherSpec.hs b/test/Unit/Tricorder/WatcherSpec.hs
deleted file mode 100644
--- a/test/Unit/Tricorder/WatcherSpec.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-module Unit.Tricorder.WatcherSpec (spec_Watcher) where
-
-import Atelier.Effects.Delay (runDelay)
-import Atelier.Effects.FileWatcher (FileEvent (..), matchesAny)
-import Atelier.Effects.Publishing (runPubWriter)
-import Effectful (runEff)
-import Effectful.Concurrent (runConcurrent)
-import Effectful.Dispatch.Dynamic (reinterpret_)
-import Effectful.Reader.Static (runReader)
-import Effectful.State.Static.Shared (execState, put)
-import Effectful.Writer.Static.Shared (runWriter)
-import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)
-import Text.Regex.TDFA.ReadRegex (parseRegex)
-
-import Tricorder.BuildState
-    ( CabalChangeDetected (..)
-    , ChangeKind (..)
-    , DaemonInfo (..)
-    , SourceChangeDetected (..)
-    )
-import Tricorder.Effects.BuildStore (BuildStore (..))
-import Tricorder.Runtime (ProjectRoot (..))
-import Tricorder.Session (WatchDirs (..), WatchExclusionPatterns (WatchExclusionPatterns))
-import Tricorder.Watcher (WatchedFile (..), WatcherSession (..), makeWatches, markWatchedFiles)
-
-
-spec_Watcher :: Spec
-spec_Watcher = do
-    describe "markWatchedFiles" testMarkWatchedFiles
-    describe "makeWatches" testMakeWatches
-
-
-testMarkWatchedFiles :: Spec
-testMarkWatchedFiles = do
-    it "should mark build store as dirty" do
-        ((state, _), _) <- runTest "foo"
-        state `shouldBe` Just SourceChange
-
-    describe "with non-cabal file change" $ it "should publish SourceChangeDetected" do
-        (_, sourceChanges) <- runTest "foo"
-        sourceChanges `shouldMatchList` [SourceChangeDetected "foo" Modified]
-
-    describe "with cabal file change" $ it "should publish CabalChangeDetected" do
-        ((_, cabalChanges), _) <- runTest "foo.cabal"
-        cabalChanges `shouldMatchList` [CabalChangeDetected "foo.cabal" Modified]
-  where
-    runTest =
-        runEff
-            . runConcurrent
-            . runDelay
-            . runReader emptyDaemonInfo
-            . runWriter
-            . runPubWriter @SourceChangeDetected
-            . runWriter
-            . runPubWriter @CabalChangeDetected
-            . mockBuildStore
-            . markWatchedFiles
-            . (`WatchedFile` Modified)
-    mockBuildStore :: Eff (BuildStore : es) a -> Eff es (Maybe ChangeKind)
-    mockBuildStore = reinterpret_ (execState Nothing) \case
-        MarkDirty ck -> put $ Just ck
-        _ -> error "Not implemented"
-
-
-testMakeWatches :: Spec
-testMakeWatches = do
-    describe "source watches" do
-        it "matches .hs files in configured watch dirs" do
-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])
-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True
-
-        it "does not match non-.hs files" do
-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])
-            matchesAny watches "/proj/src/Foo.txt" `shouldBe` False
-
-        it "excludes paths containing dist-newstyle" do
-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [])
-            matchesAny watches "/proj/src/dist-newstyle/Foo.hs" `shouldBe` False
-
-        it "excludes paths matching an exclusion pattern" do
-            let pat = parsePattern "vendor"
-                watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src"] [pat])
-            matchesAny watches "/proj/src/vendor/Foo.hs" `shouldBe` False
-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True
-
-        it "matches .hs files across multiple watch dirs" do
-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/src", "/proj/test"] [])
-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True
-            matchesAny watches "/proj/test/FooSpec.hs" `shouldBe` True
-
-        -- Second line of defense: 'cabalWatches' registers the whole project
-        -- root, and 'deduplicateDirs' collapses the narrow source dirs into it,
-        -- so the OS watches the entire repo recursively. 'matchesAny' is what
-        -- re-scopes events back to the configured dirs — a .hs file in a sibling
-        -- package must not match.
-        it "does not match a .hs file in a sibling package outside the watch dirs" do
-            let watches = makeWatches (ProjectRoot "/proj") (watcherSession ["/proj/pkg-a/src"] [])
-            matchesAny watches "/proj/pkg-a/src/Foo.hs" `shouldBe` True
-            matchesAny watches "/proj/pkg-b/src/Foo.hs" `shouldBe` False
-
-    describe "cabal watches" do
-        it "matches .cabal files under project root" do
-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession
-            matchesAny watches "/proj/foo.cabal" `shouldBe` True
-
-        it "matches cabal.project under project root" do
-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession
-            matchesAny watches "/proj/cabal.project" `shouldBe` True
-
-        it "matches package.yaml under project root" do
-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession
-            matchesAny watches "/proj/package.yaml" `shouldBe` True
-
-        it "does not match non-cabal files" do
-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession
-            matchesAny watches "/proj/README.md" `shouldBe` False
-
-        it "excludes cabal files under dist-newstyle" do
-            let watches = makeWatches (ProjectRoot "/proj") emptyWatcherSession
-            matchesAny watches "/proj/dist-newstyle/foo.cabal" `shouldBe` False
-  where
-    parsePattern p = fromRight (error . toText $ "bad test pattern: " <> p) (parseRegex p)
-    emptyWatcherSession = watcherSession [] []
-    watcherSession dirs patterns = WatcherSession (WatchDirs dirs) (WatchExclusionPatterns patterns)
-
-
-emptyDaemonInfo :: DaemonInfo
-emptyDaemonInfo =
-    DaemonInfo
-        { targets = []
-        , watchDirs = []
-        , sockPath = ""
-        , logFile = ""
-        , metricsPort = Nothing
-        }
diff --git a/tricorder.cabal b/tricorder.cabal
--- a/tricorder.cabal
+++ b/tricorder.cabal
@@ -5,12 +5,12 @@
 -- see: https://github.com/sol/hpack
 
 name:           tricorder
-version:        0.1.1.0
+version:        0.2.0.0
 synopsis:       Continuous Haskell build status, diagnostics, and tests via a shared daemon
 description:    tricorder rebuilds your Haskell project continuously and surfaces build status, diagnostics, test results, and documentation - for developers and LLM coding agents. Like ghcid and ghciwatch it reloads on every change, but builds run in a background daemon so multiple clients (an interactive TUI, a status CLI, an agent skill) share a single build state without triggering redundant rebuilds. It discovers components across multi-package cabal.project workspaces automatically and ships context-friendly output for agentic use via the CLI.
 category:       Development
-homepage:       https://github.com/atelier-hub/tricorder#readme
-bug-reports:    https://github.com/atelier-hub/tricorder/issues
+homepage:       https://github.com/tweag/tricorder#readme
+bug-reports:    https://github.com/tweag/tricorder/issues
 author:         Christian Georgii
 maintainer:     christian.georgii@tweag.io
 license:        MIT
@@ -22,51 +22,66 @@
 
 source-repository head
   type: git
-  location: https://github.com/atelier-hub/tricorder
+  location: https://github.com/tweag/tricorder
 
 library tricorder-internal
   exposed-modules:
-      Tricorder
-      Tricorder.Arguments
-      Tricorder.Builder
-      Tricorder.Builder.Dispatch
-      Tricorder.BuildState
-      Tricorder.CLI
+      Tricorder.Build
+      Tricorder.Build.Changes
+      Tricorder.Build.EvalComment
+      Tricorder.Build.Test
+      Tricorder.CLI.App
+      Tricorder.CLI.Arguments
+      Tricorder.CLI.Daemon
       Tricorder.CLI.Main
+      Tricorder.CLI.Operations
       Tricorder.CLI.Render
+      Tricorder.CLI.UI
+      Tricorder.CLI.UI.Brick
+      Tricorder.CLI.UI.BrickChan
+      Tricorder.CLI.UI.Event
+      Tricorder.CLI.UI.Keys
+      Tricorder.CLI.UI.Misc
+      Tricorder.CLI.UI.Route
+      Tricorder.CLI.UI.State
+      Tricorder.CLI.UI.View
       Tricorder.Config
-      Tricorder.Daemon
+      Tricorder.Daemon.Builder
+      Tricorder.Daemon.Core
+      Tricorder.Daemon.DaemonInfo
+      Tricorder.Daemon.Dispatch
+      Tricorder.Daemon.EvalCommentRunner
+      Tricorder.Daemon.GhciSession
+      Tricorder.Daemon.GhciSession.GhciParser
+      Tricorder.Daemon.GhciSession.GhciProcess
       Tricorder.Daemon.Main
-      Tricorder.Effects.Brick
-      Tricorder.Effects.BrickChan
-      Tricorder.Effects.BuildStore
-      Tricorder.Effects.GhciSession
-      Tricorder.Effects.GhciSession.GhciParser
-      Tricorder.Effects.GhciSession.GhciProcess
-      Tricorder.Effects.GhcPkg
-      Tricorder.Effects.Logging
-      Tricorder.Effects.SessionStore
-      Tricorder.Effects.TestRunner
-      Tricorder.Effects.UnixSocket
-      Tricorder.Events.FileChanged
-      Tricorder.GhcPkg.Types
-      Tricorder.Observability
+      Tricorder.Daemon.TestRunner
+      Tricorder.Daemon.Watch
+      Tricorder.Logging
+      Tricorder.Module
       Tricorder.Runtime
       Tricorder.Session
+      Tricorder.Session.CabalFile
+      Tricorder.Session.Command
+      Tricorder.Session.Config
+      Tricorder.Session.ReplBuildDir
+      Tricorder.Session.Target
+      Tricorder.Session.TestTarget
+      Tricorder.Session.TestTimeout
+      Tricorder.Session.WatchDirs
+      Tricorder.Session.WatchExclusionPatterns
       Tricorder.Socket.Client
       Tricorder.Socket.Protocol
       Tricorder.Socket.Server
+      Tricorder.Socket.UnixSocket
       Tricorder.SourceLookup
+      Tricorder.SourceLookup.Cabal
+      Tricorder.SourceLookup.GhcPkg
+      Tricorder.SourceLookup.Slice
+      Tricorder.SourceLookup.Tarball
       Tricorder.TestOutput
-      Tricorder.UI
-      Tricorder.UI.Event
-      Tricorder.UI.Keys
-      Tricorder.UI.Misc
-      Tricorder.UI.Route
-      Tricorder.UI.State
-      Tricorder.UI.View
       Tricorder.Version
-      Tricorder.Watcher
+      Tricorder.Waiters
   other-modules:
       Paths_tricorder
   autogen-modules:
@@ -92,10 +107,11 @@
       TypeFamilies
   ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded
   build-depends:
-      Cabal-syntax >=3.12 && <3.17
+      Cabal >=3.12 && <3.17
+    , Cabal-syntax >=3.12 && <3.17
     , aeson ==2.2.*
     , ansi-terminal ==1.1.*
-    , atelier-core ==0.2.*
+    , atelier-core ==0.3.*
     , atelier-prelude ==0.1.*
     , base >=4.18 && <4.23
     , brick ==2.10.*
@@ -118,6 +134,7 @@
     , regex-tdfa >=1.3.2.5 && <1.4
     , relude ==1.2.*
     , stm ==2.5.*
+    , tar >=0.6 && <0.8
     , template-haskell >=2.20 && <2.25
     , text ==2.1.*
     , time >=1.12 && <1.16
@@ -125,6 +142,7 @@
     , vty ==6.5.*
     , vty-crossplatform ==0.5.*
     , yaml ==0.11.*
+    , zlib ==0.7.*
   mixins:
       base hiding (Prelude)
   default-language: GHC2021
@@ -211,22 +229,30 @@
   type: exitcode-stdio-1.0
   main-is: Driver.hs
   other-modules:
-      Unit.Tricorder.BuilderSpec
-      Unit.Tricorder.BuildStateSpec
-      Unit.Tricorder.BuildStoreSpec
+      Unit.Tricorder.Build.EvalCommentSpec
       Unit.Tricorder.CLI.RenderSpec
-      Unit.Tricorder.Effects.GhciSession.GhciParserSpec
-      Unit.Tricorder.Effects.GhciSession.GhciProcessSpec
-      Unit.Tricorder.Effects.GhciSessionSpec
-      Unit.Tricorder.Effects.SessionStoreSpec
-      Unit.Tricorder.GhcPkgSpec
+      Unit.Tricorder.Daemon.BuilderSpec
+      Unit.Tricorder.Daemon.BuildStateSpec
+      Unit.Tricorder.Daemon.DispatchSpec
+      Unit.Tricorder.Daemon.GhciSession.GhciParserSpec
+      Unit.Tricorder.Daemon.GhciSession.GhciProcessSpec
+      Unit.Tricorder.Daemon.GhciSessionSpec
+      Unit.Tricorder.Daemon.TestRunnerSpec
+      Unit.Tricorder.Daemon.WatchSpec
+      Unit.Tricorder.Session.CabalFileSpec
+      Unit.Tricorder.Session.CommandSpec
+      Unit.Tricorder.Session.Helpers
+      Unit.Tricorder.Session.TargetSpec
+      Unit.Tricorder.Session.TestTargetSpec
+      Unit.Tricorder.Session.WatchDirsSpec
       Unit.Tricorder.SessionSpec
       Unit.Tricorder.SocketSpec
+      Unit.Tricorder.SourceLookup.GhcPkgSpec
+      Unit.Tricorder.SourceLookup.SliceSpec
+      Unit.Tricorder.SourceLookup.TarballSpec
       Unit.Tricorder.SourceLookupSpec
-      Unit.Tricorder.SourceSpec
       Unit.Tricorder.TestOutputSpec
-      Unit.Tricorder.TestRunnerSpec
-      Unit.Tricorder.WatcherSpec
+      Unit.Tricorder.WaitersSpec
       Paths_tricorder
   autogen-modules:
       Paths_tricorder
@@ -255,18 +281,22 @@
   build-depends:
       Cabal-syntax >=3.12 && <3.17
     , aeson ==2.2.*
-    , atelier-core ==0.2.*
+    , atelier-core ==0.3.*
     , atelier-prelude ==0.1.*
     , base >=4.18 && <4.23
+    , bytestring >=0.11 && <0.13
     , containers >=0.6 && <0.9
     , data-default ==0.8.*
     , effectful ==2.6.*
     , effectful-core ==2.6.*
     , effectful-plugin >=2.0 && <2.2
+    , filepath >=1.4 && <1.6
     , hspec ==2.11.*
+    , megaparsec ==9.7.*
     , process ==1.6.*
     , regex-tdfa >=1.3.2.5 && <1.4
     , stm ==2.5.*
+    , tar >=0.6 && <0.8
     , tasty ==1.5.*
     , tasty-discover ==5.2.*
     , tasty-hspec ==1.2.*
@@ -277,6 +307,7 @@
     , typed-process ==0.2.*
     , unagi-chan ==0.4.*
     , unix ==2.8.*
+    , zlib ==0.7.*
   mixins:
       base hiding (Prelude)
   default-language: GHC2021