tricorder 0.6.0.0 → 0.7.0.0
raw patch · 50 files changed
+538/−891 lines, 50 filesdep ~tricorder-types
Dependency ranges changed: tricorder-types
Files
- CHANGELOG.md +31/−0
- src/Tricorder/CLI/App.hs +28/−61
- src/Tricorder/CLI/App/Daemon.hs +68/−0
- src/Tricorder/CLI/App/Test.hs +11/−9
- src/Tricorder/CLI/App/Test/Json.hs +18/−5
- src/Tricorder/CLI/App/Test/Json/Responses.hs +1/−1
- src/Tricorder/CLI/App/Test/SuiteView.hs +9/−85
- src/Tricorder/CLI/App/Test/Text.hs +7/−6
- src/Tricorder/CLI/Arguments.hs +17/−207
- src/Tricorder/CLI/Arguments/Daemon.hs +0/−14
- src/Tricorder/CLI/Arguments/IfDaemonIsStopped.hs +0/−14
- src/Tricorder/CLI/Arguments/OutputFormat.hs +0/−14
- src/Tricorder/CLI/Arguments/Test.hs +0/−106
- src/Tricorder/CLI/Arguments/TestFilter.hs +0/−17
- src/Tricorder/CLI/Arguments/WaitMode.hs +0/−12
- src/Tricorder/CLI/Daemon.hs +4/−3
- src/Tricorder/CLI/Main.hs +7/−5
- src/Tricorder/CLI/Operations.hs +14/−15
- src/Tricorder/CLI/Render.hs +9/−8
- src/Tricorder/CLI/UI/State.hs +3/−6
- src/Tricorder/CLI/UI/View.hs +6/−5
- src/Tricorder/Daemon/Core.hs +13/−9
- src/Tricorder/Daemon/DaemonInfo.hs +3/−2
- src/Tricorder/Daemon/EvalCommentRunner.hs +8/−10
- src/Tricorder/Daemon/Ghci/Config.hs +21/−1
- src/Tricorder/Daemon/Ghci/Config/File.hs +48/−0
- src/Tricorder/Daemon/TestRunner.hs +16/−21
- src/Tricorder/Session.hs +16/−21
- src/Tricorder/Session/CommandConfig.hs +5/−0
- src/Tricorder/Session/Stage/Build/Session.hs +17/−8
- src/Tricorder/Session/Stage/Eval/Command.hs +1/−20
- src/Tricorder/Session/Stage/Eval/Session.hs +43/−5
- src/Tricorder/Session/Stage/Test/Command.hs +2/−2
- src/Tricorder/Session/Stage/Test/Session.hs +15/−7
- src/Tricorder/Socket/Client.hs +4/−4
- src/Tricorder/Socket/Protocol.hs +1/−3
- src/Tricorder/SourceLookup.hs +6/−43
- src/Tricorder/SourceLookup/GhcPkg.hs +1/−1
- src/Tricorder/SourceLookup/Hackage.hs +2/−3
- src/Tricorder/SourceLookup/PackageId.hs +0/−25
- src/Tricorder/SourceLookup/PackageStore.hs +2/−3
- src/Tricorder/SourceLookup/Tarball.hs +3/−3
- test/Unit/Tricorder/CLI/App/Test/SuiteViewSpec.hs +4/−50
- test/Unit/Tricorder/Daemon/TestRunnerSpec.hs +7/−7
- test/Unit/Tricorder/Session/Stage/Eval/CommandSpec.hs +2/−33
- test/Unit/Tricorder/Session/Stage/Eval/SessionSpec.hs +53/−0
- test/Unit/Tricorder/Session/Stage/Test/CommandSpec.hs +2/−2
- test/Unit/Tricorder/SourceLookup/TarballSpec.hs +1/−1
- test/Unit/Tricorder/SourceLookupSpec.hs +3/−4
- tricorder.cabal +6/−10
CHANGELOG.md view
@@ -7,6 +7,37 @@ ## [Unreleased] +## [0.7.0.0] - 2026-10-23++### Added++- Option to configure how long Tricorder will wait for GHCi to start up and+ shut down.+- Option to set initial commands to pass to GHCi on startup.++### Changed++- `tricorder status` without `--verbose` now shows only the first line of a+ test suite's error message, unless `--verbose` is set.+ Previously, a test suite that failed on startup printed+ the whole cabal/GHCi log on every `status` call.+ ([#585](https://github.com/tweag/tricorder/issues/585)) (Thanks @RyosukeDTomita!)+- The following commands have been moved, and are invoked under a different name:+ - `tricorder start`: `tricorder daemon start`+ - `tricorder stop`: `tricorder daemon stop`+ - `tricorder restart`: `tricorder daemon restart`+ They otherwise function identically to before.+- The following commands `tricorder status` and `tricorder eval-comments` now+ support the `--start-daemon` flag to automatically start the daemon if it is+ not already running. This will become the default behavior for all+ subcommands in the next `MAJOR.MAJOR` release.++### Deprecated++- `tricorder start`: use `tricorder daemon start` instead.+- `tricorder stop`: use `tricorder daemon stop` instead.+- `tricorder restart`: use `tricorder daemon restart` instead.+ ## [0.6.0.0] - 2026-10-20 ### Added
src/Tricorder/CLI/App.hs view
@@ -7,35 +7,28 @@ import Atelier.Effects.Exit (Exit) import Atelier.Effects.File (File) import Atelier.Effects.FileSystem (FileSystem)-import Atelier.Effects.Input (Input, input)+import Atelier.Effects.Input (Input) import Atelier.Effects.Log (Log) 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.Provider (Provider_) import Effectful.Reader.Static (Reader, ask, asks)-import Tricorder.CLI.Command (Command (..), LogMode (..))+import Tricorder.API.Command+ ( Command (..)+ , EvalCommentsOptions (..)+ , LogMode (..)+ , StatusOptions (..)+ ) import Prelude hiding (force) import Atelier.Effects.Console qualified as Console-import Data.Text qualified as T-import Tricorder.CLI.Command.Daemon qualified as DaemonCommand+import Tricorder.API.IfDaemonIsStopped qualified as IfDaemonIsStopped -import Tricorder.CLI.Daemon- ( restartDaemon- , startDaemon- , stopDaemon- , waitForDaemon- )-import Tricorder.CLI.Operations- ( showDaemonInfo- , showEvalComments- , showLog- , showSource- , showStatus- , showTests- )+import Tricorder.CLI.Daemon (startDaemon, 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)@@ -49,6 +42,7 @@ import Tricorder.SourceLookup.Hackage (Hackage) import Tricorder.SourceLookup.PackageStore (PackageStore) +import Tricorder.CLI.App.Daemon qualified as Daemon import Tricorder.CLI.App.Test qualified as Test import Tricorder.CLI.UI.Keys qualified as Keys @@ -74,6 +68,7 @@ , Log :> es , PackageStore :> es , Process :> es+ , Provider_ Console Console.Output :> es , Reader Command :> es , Reader Keys.Config :> es , Reader LogPath :> es@@ -85,44 +80,20 @@ => 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+ if+ | not running && opts.ifDaemonIsStopped == IfDaemonIsStopped.StartDaemon -> do+ startDaemon+ void waitForDaemon showStatus opts+ | not running -> Console.putStrLn "Stopped."+ | otherwise -> showStatus opts TestResults opts -> do running <- isDaemonRunning if not running- then- Console.putStrLn "Stopped."- else- showTests opts- Test testCmd -> Test.run testCmd+ then Console.putStrLn "Stopped."+ else showTests opts Log logMode -> do logFile <- asks @LogPath (.getLogPath) case logMode of@@ -136,16 +107,12 @@ viewUi Source opts -> do showSource opts- Restart force ->- restartDaemon force >>= \case- Just (Left reasons) -> traverse_ Console.putTextLn reasons- _ -> pass EvalComments opts -> do- running <- isDaemonRunning- unless running do- startDaemon- void waitForDaemon+ when (opts.ifDaemonIsStopped == IfDaemonIsStopped.StartDaemon) do+ running <- isDaemonRunning+ unless running do+ startDaemon+ void waitForDaemon showEvalComments opts- Daemon (DaemonCommand.Info format) -> do- daemonInfo <- input- showDaemonInfo format daemonInfo+ Test testCmd -> Test.run testCmd+ Daemon cmd -> Daemon.run cmd
+ src/Tricorder/CLI/App/Daemon.hs view
@@ -0,0 +1,68 @@+module Tricorder.CLI.App.Daemon (run) where++import Atelier.Effects.Console (Console)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.File (File)+import Atelier.Effects.Input (Input, input)+import Atelier.Effects.Posix.Daemons (Daemons)+import Atelier.Effects.Timeout (Timeout)+import Effectful (IOE)+import Effectful.Reader.Static (Reader)+import Tricorder.API.Daemon.Command (Command (..))+import Prelude hiding (force)++import Atelier.Effects.Console qualified as Console+import Data.Text qualified as T++import Tricorder.CLI.Daemon (restartDaemon, startDaemon, stopDaemon, waitForDaemon)+import Tricorder.CLI.Operations (showDaemonInfo)+import Tricorder.Daemon.DaemonInfo (DaemonInfo)+import Tricorder.Runtime (PidFile (..), SocketPath (..))+import Tricorder.Socket.Client (isDaemonRunning)+import Tricorder.Socket.UnixSocket (UnixSocket)+++run+ :: ( Console :> es+ , Daemons :> es+ , Delay :> es+ , File :> es+ , IOE :> es+ , Input DaemonInfo :> es+ , Reader PidFile :> es+ , Reader SocketPath :> es+ , Timeout :> es+ , UnixSocket :> es+ )+ => Command -> Eff es ()+run = \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+ Restart force ->+ restartDaemon force >>= \case+ Just (Left reasons) -> traverse_ Console.putTextLn reasons+ _ -> pass+ Info format -> do+ daemonInfo <- input+ showDaemonInfo format daemonInfo
src/Tricorder/CLI/App/Test.hs view
@@ -7,18 +7,18 @@ import Atelier.Effects.Posix.Daemons (Daemons, PidFile) import Effectful (IOE) import Effectful.Reader.Static (Reader)-import Tricorder.CLI.Command.IfDaemonIsStopped (IfDaemonIsStopped)-import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))-import Tricorder.CLI.Command.Test (Command (..), SuitesOptions (..))-import Tricorder.CLI.Command.WaitMode (WaitMode (..))+import Tricorder.API.IfDaemonIsStopped (IfDaemonIsStopped)+import Tricorder.API.OutputFormat (OutputFormat (..))+import Tricorder.API.Test (Command (..), SuitesOptions (..))+import Tricorder.API.WaitMode (WaitMode (..)) import Atelier.Effects.Console qualified as Console import Effectful.Reader.Static qualified as Reader-import Tricorder.CLI.Command.IfDaemonIsStopped qualified as IfDaemonIsStopped-import Tricorder.FieldMask.Schema qualified as FieldMask.Schema+import Tricorder.API.FieldMask.Schema qualified as FieldMask.Schema+import Tricorder.API.IfDaemonIsStopped qualified as IfDaemonIsStopped+import Tricorder.API.Test.SuiteView.Schema qualified as SuiteView.Schema import Tricorder.Build (BuildState (..))-import Tricorder.CLI.App.Test.SuiteView (defaultFields, schema) import Tricorder.Runtime (SocketPath (..)) import Tricorder.Socket.Client (queryStatus, queryStatusWait) import Tricorder.Socket.UnixSocket (UnixSocket)@@ -88,7 +88,9 @@ where validated = do targets <- traverse parseTarget opts.suiteNames- selection <- FieldMask.Schema.select schema $ fromMaybe defaultFields opts.fields+ selection <-+ FieldMask.Schema.select SuiteView.Schema.schema+ $ fromMaybe SuiteView.Schema.defaultFields opts.fields pure (targets, selection) parseTarget suiteName = maybeToRight@@ -124,7 +126,7 @@ ensureDaemonRunning ifDaemonIsStopped continue = do isRunning <- Client.isDaemonRunning case (ifDaemonIsStopped, isRunning) of- (IfDaemonIsStopped.Fail, False) -> pure $ Left "daemon is stopped"+ (IfDaemonIsStopped.DoNothing, False) -> pure $ Left "daemon is stopped" (IfDaemonIsStopped.StartDaemon, False) -> do ensureDaemonIsRunning continue
src/Tricorder/CLI/App/Test/Json.hs view
@@ -8,13 +8,20 @@ import Data.Aeson (ToJSON, toJSON) import Data.Aeson.Text (encodeToLazyText)-import Tricorder.CLI.Command.TestFilter (TestFilter)+import Tricorder.API.TestFilter (TestFilter) import Data.Text qualified as T-import Tricorder.FieldMask.Projection qualified as FieldMask.Projection-import Tricorder.FieldMask.Schema qualified as FieldMask (Schema)+import Tricorder.API.FieldMask.Projection qualified as FieldMask.Projection+import Tricorder.API.FieldMask.Schema qualified as FieldMask (Schema) -import Tricorder.Build (BuildPhase (..), BuildState (..), PostBuild (..))+import Tricorder.Build+ ( BuildPhase (..)+ , BuildResult (..)+ , BuildState (..)+ , Diagnostic (..)+ , PostBuild (..)+ , Severity (..)+ ) import Tricorder.CLI.App.Test.Json.Responses ( MessageWithLoc (..) , Response (..)@@ -59,5 +66,11 @@ | Test.anyRunningTests postBuild.testSuites -> Responses.Pending $ MessageWithLoc "postBuild" "testing" | otherwise -> mkResponse postBuild.testSuites- Finished _ postBuild -> mkResponse postBuild.testSuites+ Finished buildResult postBuild+ | buildFailed buildResult postBuild ->+ Responses.Error $ MessageWithLoc "finished" "build failed before tests ran"+ | otherwise -> mkResponse postBuild.testSuites Failed reason -> Responses.Error $ MessageWithLoc "build" $ "build failed: " <> reason+ where+ buildFailed buildResult postBuild =+ postBuild.testSuites == mempty && any (\d -> d.severity >= SError) buildResult.diagnostics
src/Tricorder/CLI/App/Test/Json/Responses.hs view
@@ -20,7 +20,7 @@ ) import Text.Casing (quietSnake) -import Tricorder.FieldMask.Projection qualified as FieldMask (Projection)+import Tricorder.API.FieldMask.Projection qualified as FieldMask (Projection) data Response a
src/Tricorder/CLI/App/Test/SuiteView.hs view
@@ -1,28 +1,21 @@ -- | The full, unprojected view of a test suite that @tricorder test suites@ -- selects fields from. module Tricorder.CLI.App.Test.SuiteView- ( SuiteView (..)- , Status (..)- , CaseView (..)- , Outcome (..)- , schema- , defaultFields- , selectSuites+ ( selectSuites ) where -import Atelier.Types.JSON.QuietSnake (QuietSnake (..))-import Data.Aeson (ToJSON (..))-import Tricorder.CLI.Command.TestFilter (TestFilter)-import Tricorder.FieldMask (Field (..), FieldMask (..))+import Atelier.Time (AsRawUnit (..))+import Tricorder.API.Test.SuiteView (CaseView (..), Outcome (..), Status (..), SuiteView (..))+import Tricorder.API.TestFilter (TestFilter) import Data.Map.Strict qualified as Map import Data.Text qualified as T-import Tricorder.CLI.Command.TestFilter qualified as TestFilter-import Tricorder.FieldMask.Schema qualified as FieldMask (Schema (..))-import Tricorder.FieldMask.Schema qualified as FieldMask.Schema+import Tricorder.API.TestFilter qualified as TestFilter -import Tricorder.Build.Duration (Duration)+import Tricorder.Build.Duration+ ( Duration (..)+ ) import Tricorder.Session.TestTarget (TestTarget) import Tricorder.TestOutput (stripGhciNoise) @@ -30,75 +23,6 @@ import Tricorder.Session.TestTarget qualified as TestTarget --- | Fields that do not apply to a suite's 'Status' are 'Nothing', and are--- left out of the output.-data SuiteView = SuiteView- { name :: Text- , status :: Status- , error :: Maybe Text- , passedCases :: Maybe Int- , totalCases :: Maybe Int- , durationMs :: Maybe Duration- , output :: Maybe Text- , cases :: Maybe [CaseView]- }- deriving stock (Eq, Generic, Show)- deriving (ToJSON) via QuietSnake SuiteView---data Status = Running | Errored | Passed | Failed- deriving stock (Eq, Generic, Show)- deriving (ToJSON) via QuietSnake Status---data CaseView = CaseView- { description :: Text- , outcome :: Outcome- , failure :: Maybe Text- }- deriving stock (Eq, Generic, Show)- deriving (ToJSON) via QuietSnake CaseView---data Outcome = CasePassed | CaseFailed- deriving stock (Eq, Generic, Show)---instance ToJSON Outcome where- toJSON = \case- CasePassed -> "passed"- CaseFailed -> "failed"----- | Every field of a 'SuiteView', as named in its JSON encoding.-schema :: FieldMask.Schema-schema =- FieldMask.Schema- [ FieldMask.Schema.leaf "name"- , FieldMask.Schema.leaf "status"- , FieldMask.Schema.leaf "error"- , FieldMask.Schema.leaf "passed_cases"- , FieldMask.Schema.leaf "total_cases"- , FieldMask.Schema.leaf "duration_ms"- , FieldMask.Schema.leaf "output"- , FieldMask.Schema.nested- "cases"- [ FieldMask.Schema.leaf "description"- , FieldMask.Schema.leaf "outcome"- , FieldMask.Schema.leaf "failure"- ]- ]----- | A summary of each suite, leaving out the (potentially large) test output--- and test cases.-defaultFields :: FieldMask-defaultFields =- FieldMask- $ (\name -> Field name Nothing)- <$> "name" :| ["status", "error", "passed_cases", "total_cases", "duration_ms"]-- -- | Pick out the requested suites, or all of them when none are requested. -- Fails with the requested suites that do not exist. --@@ -144,7 +68,7 @@ { status = if completion.passed then Passed else Failed , passedCases = Just $ length $ filter (not . Test.caseFailed) completion.testCases , totalCases = Just $ length completion.testCases- , durationMs = completion.duration+ , durationMs = AsRawUnit . (.getDuration) <$> completion.duration , output = Just $ T.unlines $ stripGhciNoise $ T.lines completion.output , cases = Just $ toCaseView <$> filter keepCase completion.testCases }
src/Tricorder/CLI/App/Test/Text.hs view
@@ -6,12 +6,12 @@ where import Data.Aeson (toJSON)-import Tricorder.CLI.Command.TestFilter (TestFilter)+import Tricorder.API.TestFilter (TestFilter) import Data.Text qualified as T-import Tricorder.CLI.Command.TestFilter qualified as TestFilter-import Tricorder.FieldMask.Projection qualified as FieldMask.Projection-import Tricorder.FieldMask.Schema qualified as FieldMask+import Tricorder.API.FieldMask.Projection qualified as FieldMask.Projection+import Tricorder.API.FieldMask.Schema qualified as FieldMask+import Tricorder.API.TestFilter qualified as TestFilter import Tricorder.Build ( BuildPhase (..)@@ -72,12 +72,13 @@ showTests postBuild.testSuites Finished result postBuild | buildFailed result postBuild ->- Left $ "build failed before tests ran"+ Left "build failed before tests ran" | otherwise -> showTests postBuild.testSuites Failed err -> Left $ "Build failed: " <> err where- buildFailed result postBuild = postBuild.testSuites == mempty && any (\d -> d.severity >= SError) result.diagnostics+ buildFailed result postBuild =+ postBuild.testSuites == mempty && any (\d -> d.severity >= SError) result.diagnostics showTestProgress :: Test.Suites -> Text
src/Tricorder/CLI/Arguments.hs view
@@ -1,226 +1,36 @@-module Tricorder.CLI.Arguments- ( 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- , progDescDoc- , readerError- , short- )-import Tricorder.CLI.Command- ( Command (..)- , EvalCommentsOptions (..)- , Force (..)- , LogMode (..)- , SourceOptions (..)- , StatusOptions (..)- , TestOptions (..)- , Verbosity (..)- )-import Tricorder.SourceLookup.SourceQuery (SourceQuery, parseSourceQuery)+module Tricorder.CLI.Arguments (runArguments, parseArguments) where -import Options.Applicative.Help.Pretty qualified as Doc+import Atelier.Effects.Arguments (Arguments)+import Effectful.Reader.Static (Reader)+import Options.Applicative (Parser, ParserInfo)+import Tricorder.API.Command (Command) -import Tricorder.SourceLookup (ReexportLimits (..), defaultReexportLimits)+import Atelier.Effects.Arguments qualified as Args+import Effectful.Reader.Static qualified as Reader+import Options.Applicative qualified as Opt+import Tricorder.API.Command.Args qualified as Command.Args -import Tricorder.CLI.Arguments.Daemon qualified as Daemon-import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat-import Tricorder.CLI.Arguments.Test qualified as Test-import Tricorder.CLI.Arguments.WaitMode qualified as WaitMode import Tricorder.Version qualified as Version runArguments :: (Arguments :> es) => Eff (Reader Command : es) a -> Eff es a runArguments eff = do args <- parseArguments- runReader args eff+ Reader.runReader args eff parseArguments :: (Arguments :> es) => Eff es Command-parseArguments = execParser opts+parseArguments = Args.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"+ Opt.info (Command.Args.parser <**> versionOption <**> Opt.helper)+ $ Opt.fullDesc+ <> Opt.progDesc "tricorder — daemon-based GHCi build status"+ <> Opt.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- testResultsParser- ( progDescDoc- $ Just- $ "Show output from the latest test run"- <> Doc.line- <> Doc.annotate Doc.bold "DEPRECATED: use the `test suites` subcommand"- )- )- <> command "test" (Test <$> Test.parser)- <> 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 project or installed modules"))- <> command "restart" (info restartParser (progDesc "Restart the daemon"))- <> command- "eval-comments"- (info evalCommentsParser (progDesc "Show eval comments from the latest build"))- <> command "daemon" (info (Daemon <$> Daemon.parser) (progDesc "Daemon sub-commands"))- )---logParser :: Parser Command-logParser =- Log <$> pathFlag- where- pathFlag =- flag- ShowLog- ShowLogPath- ( long "print-path"- <> help "Print the path to the log file instead of its contents"- )---statusParser :: Parser Command-statusParser =- Status- <$> ( StatusOptions- <$> WaitMode.parser- <*> OutputFormat.parser- <*> 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"- )- )- )---testResultsParser :: Parser Command-testResultsParser =- TestResults- <$> ( TestOptions- <$> flag- False- True- ( long "failed"- <> help "Only show output from failed test suites"- )- <*> WaitMode.parser- )---sourceParser :: Parser Command-sourceParser =- Source- <$> ( SourceOptions- <$> some- ( argument- queryReader- (metavar "Module[#function]" <> help "Module or Module#function")- )- <*> optional- ( option- nonNegative- ( long "max-depth"- <> metavar "N"- <> help- ( "Follow at most N re-export hops when a symbol is not defined in the queried module (default: "- <> show defaultReexportLimits.maxDepth- <> ")"- )- )- )- <*> optional- ( option- nonNegative- ( long "max-modules"- <> metavar "N"- <> help- ( "Read at most N modules while following re-exports (default: "- <> show defaultReexportLimits.maxModules- <> ")"- )- )- )- )- where- nonNegative = do- n <- auto- if n < 0 then readerError "must be a non-negative integer" else pure n---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- <$> WaitMode.parser- <*> OutputFormat.parser- )---queryReader :: ReadM SourceQuery-queryReader = eitherReader $ Right . parseSourceQuery . toText+versionOption =+ Opt.infoOption (toString Version.gitHash) (Opt.long "version" <> Opt.help "Show version and exit")
− src/Tricorder/CLI/Arguments/Daemon.hs
@@ -1,14 +0,0 @@-module Tricorder.CLI.Arguments.Daemon (parser) where--import Options.Applicative (Parser, command, hsubparser, info, progDesc)-import Tricorder.CLI.Command.Daemon (DaemonCommand (..))--import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat---parser :: Parser DaemonCommand-parser = hsubparser (command "info" (info infoParser (progDesc "Information about the daemon")))---infoParser :: Parser DaemonCommand-infoParser = Info <$> OutputFormat.parser
− src/Tricorder/CLI/Arguments/IfDaemonIsStopped.hs
@@ -1,14 +0,0 @@-module Tricorder.CLI.Arguments.IfDaemonIsStopped (parser) where--import Options.Applicative (Parser, flag, help, long, short)-import Tricorder.CLI.Command.IfDaemonIsStopped (IfDaemonIsStopped (..), startDaemonFlagName)---parser :: Parser IfDaemonIsStopped-parser =- flag- Fail- StartDaemon- $ long startDaemonFlagName- <> short 'd'- <> help "Start the daemon if it is not already running."
− src/Tricorder/CLI/Arguments/OutputFormat.hs
@@ -1,14 +0,0 @@-module Tricorder.CLI.Arguments.OutputFormat (parser) where--import Options.Applicative (Parser, flag, help, long, short)-import Tricorder.CLI.Command.OutputFormat (OutputFormat (..), jsonOutputFlagName)---parser :: Parser OutputFormat-parser =- flag- TextOutput- JsonOutput- $ long jsonOutputFlagName- <> short 'j'- <> help "Output full build state as JSON"
− src/Tricorder/CLI/Arguments/Test.hs
@@ -1,106 +0,0 @@-module Tricorder.CLI.Arguments.Test (parser) where--import Options.Applicative- ( Parser- , ParserInfo- , command- , footer- , help- , helpDoc- , hsubparser- , info- , metavar- , progDesc- , strArgument- )-import Tricorder.CLI.Command.Test (Command, SuitesOptions (..))--import Data.Text qualified as T-import Options.Applicative.Help.Pretty qualified as Doc-import Tricorder.CLI.Command.Test qualified as Test-import Tricorder.FieldMask qualified as FieldMask-import Tricorder.FieldMask.Args qualified as FieldMask.Args-import Tricorder.FieldMask.Schema qualified as FieldMask (Schema (..))--import Tricorder.CLI.App.Test.SuiteView qualified as SuiteView-import Tricorder.CLI.Arguments.IfDaemonIsStopped qualified as IfDaemonIsStopped-import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat-import Tricorder.CLI.Arguments.TestFilter qualified as TestFilter-import Tricorder.CLI.Arguments.WaitMode qualified as WaitMode---parser :: ParserInfo Command-parser =- info commandParser (progDesc "See statuses and information on configured test suites.")---commandParser :: Parser Command-commandParser =- hsubparser- $ command- "suites"- ( info- suitesParser- ( progDesc "Show test suites, their test cases and output."- <> footer suitesFooter- )- )---suitesParser :: Parser Command-suitesParser =- fmap Test.Suites- $ SuitesOptions- <$> many (strArgument (metavar "TEST-TARGET..." <> help "Test suites to show (default: all)"))- <*> TestFilter.parser (help "Show only failed test suites, and only their failed test cases")- <*> FieldMask.Args.parser- ( helpDoc- $ Just- $ (<> Doc.line)- $ mconcat- $ Doc.punctuate- (Doc.line <> Doc.line)- [ "Fields to return for each test suite."- , "Available fields:"- <> Doc.line- <> Doc.indent 4 (Doc.vsep $ renderSchema SuiteView.schema)- , "Select nested fields with parentheses,"- <> Doc.line- <> "e.g. --fields 'name,cases(description,failure)'."- <> Doc.line- <> "A field without parentheses shows all of its nested fields."- , "Default fields:"- <> Doc.line- <> Doc.pretty (FieldMask.render SuiteView.defaultFields)- ]- )- <*> OutputFormat.parser- <*> WaitMode.parser- <*> IfDaemonIsStopped.parser- where- renderSchema (FieldMask.Schema fields) = renderField <$> fields- renderField (name, sub) =- Doc.pretty name- <> maybe- Doc.emptyDoc- ( \nestedSchema ->- Doc.enclose- "("- ")"- $ Doc.sep- $ Doc.punctuate ","- $ renderSchema nestedSchema- )- sub---suitesFooter :: String-suitesFooter =- toString- $ "Available fields:\n"- <> renderSchema SuiteView.schema- <> "\nSelect nested fields with parentheses, e.g. --fields 'name,cases(description,failure)'."- <> " A field without parentheses shows all of its nested fields."- where- renderSchema (FieldMask.Schema fields) = T.intercalate ", " $ renderField <$> fields- renderField (name, sub) = name <> maybe "" (\nestedSchema -> "(" <> renderSchema nestedSchema <> ")") sub
− src/Tricorder/CLI/Arguments/TestFilter.hs
@@ -1,17 +0,0 @@-module Tricorder.CLI.Arguments.TestFilter (parser) where--import Options.Applicative (FlagFields, Mod, Parser, flag, long, short)-import Tricorder.CLI.Command.TestFilter- ( TestFilter (..)- , failedOnlyFlagName- , failedOnlyFlagShortName- )-import Prelude hiding (All (..))---parser :: Mod FlagFields TestFilter -> Parser TestFilter-parser extraMods =- flag All FailedOnly- $ long failedOnlyFlagName- <> short failedOnlyFlagShortName- <> extraMods
− src/Tricorder/CLI/Arguments/WaitMode.hs
@@ -1,12 +0,0 @@-module Tricorder.CLI.Arguments.WaitMode (parser) where--import Options.Applicative (Parser, flag, help, long, short)-import Tricorder.CLI.Command.WaitMode (WaitMode (..), waitForBuildFlagName)---parser :: Parser WaitMode-parser =- flag ShowCurrent WaitForBuild- $ long waitForBuildFlagName- <> short 'w'- <> help "Block until the current build cycle completes"
src/Tricorder/CLI/Daemon.hs view
@@ -15,14 +15,15 @@ import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet) import Effectful.Reader.Static (Reader, ask) import Effectful.Writer.Static.Local (runWriter, tell)+import Tricorder.API.Force (Force) import Prelude hiding (force) import Atelier.Effects.Delay qualified as Delay import Atelier.Effects.Posix.Daemons qualified as Daemons+import Tricorder.API.Force qualified as Force 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@@ -66,8 +67,8 @@ (Nothing, es) -> pure $ Left es where timeoutDelay :: Second = case force of- Force -> 3- NoForce -> 6+ Force.Force -> 3+ Force.NoForce -> 6 requestStop sockPath pidFile = do timeout1second (requestShutdown force sockPath) >>= \_ -> do didStop <- fmap isJust $ timeout timeoutDelay $ waitForStop pidFile
src/Tricorder/CLI/Main.hs view
@@ -3,7 +3,7 @@ import Atelier.Effects.Arguments (runArgumentsIO) import Atelier.Effects.Clock (runClock) import Atelier.Effects.Conc (runConc)-import Atelier.Effects.Console (Console, runConsole, runConsoleHandle)+import Atelier.Effects.Console (Console, runConsole, runConsoleOut) import Atelier.Effects.Delay (runDelay) import Atelier.Effects.Env (runEnv) import Atelier.Effects.Exit (exitFailure, runExit)@@ -18,7 +18,6 @@ import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.Provider (provideWith_, runProvider_)-import System.IO (stderr) import Atelier.Effects.Console qualified as Console import Atelier.Effects.FileSystem.Glob qualified as Glob@@ -31,7 +30,7 @@ import Tricorder.Runtime (runLogPath, runPidFile, runProjectRoot, runRuntimeDir, runSocketPath) import Tricorder.Session.CabalFile (inputCabalFiles) import Tricorder.Session.CommandTemplate (CommandTemplate (..))-import Tricorder.Session.Stage.Build.Session (BuildSession (..))+import Tricorder.Session.Stage.Build.Session (Session (..)) import Tricorder.CLI.App qualified as App import Tricorder.CLI.UI.Keys qualified as Keys@@ -54,7 +53,7 @@ . runBrickChan . runBrick . runConsole- . runProvider_ runConsoleHandle+ . runProvider_ @Console @Console.Output runConsoleOut . runExit . runClock . runDelay@@ -83,12 +82,15 @@ $ do Session.load >>= \case Left err -> do- provideWith_ @Console stderr+ provideWith_ @Console Console.Stderr $ Console.putTextLn $ "Failed to load session: " <> err exitFailure Right session -> Input.withConst session+ -- TODO: Make whatever uses this 'Repl' value use it+ -- more sensibly. Arbitrarily using the build stage's+ -- 'Repl' doesn't seem right. . Input.withConst session.buildSession.commandTemplate.repl . GhcPkg.runGhcPkgIO . PackageStore.run
src/Tricorder/CLI/Operations.hs view
@@ -18,16 +18,18 @@ import Data.Aeson (ToJSON, encode) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime (utcToLocalTime)+import Effectful.Provider (Provider_, provideWith_) import Effectful.Reader.Static (Reader, ask)-import Tricorder.CLI.Command+import Tricorder.API.Command ( EvalCommentsOptions (..) , SourceOptions (..) , StatusOptions (..) , TestOptions (..) , Verbosity (..) )-import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))-import Tricorder.CLI.Command.WaitMode (WaitMode (..))+import Tricorder.API.OutputFormat (OutputFormat (..))+import Tricorder.API.WaitMode (WaitMode (..))+import Tricorder.SourceLookup.ReexportLimits (ReexportLimits (..), defaultReexportLimits) import Atelier.Effects.Console qualified as Console import Data.ByteString.Lazy qualified as BSL@@ -48,12 +50,7 @@ import Tricorder.Session.Repl (Repl) import Tricorder.Socket.Client (queryStatus, queryStatusWait) import Tricorder.Socket.UnixSocket (UnixSocket)-import Tricorder.SourceLookup- ( ReexportLimits (..)- , defaultReexportLimits- , lookupModuleSource- , projectSourceDirs- )+import Tricorder.SourceLookup (lookupModuleSource, projectSourceDirs) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage) import Tricorder.SourceLookup.PackageStore (PackageStore)@@ -80,13 +77,14 @@ , Console :> es , Exit :> es , File :> es+ , Provider_ Console Console.Output :> es , Reader SocketPath :> es , UnixSocket :> es ) => StatusOptions -> Eff es () showStatus opts = do when (opts.wait == WaitForBuild && opts.format == TextOutput) do- displayPendingBuildStatus+ provideWith_ @Console Console.Stderr displayPendingBuildStatus result <- awaitBuildStatus opts.wait case result of Left err -> Console.putTextLn $ "Error: " <> err@@ -147,7 +145,7 @@ 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.SuiteErrored e -> t <> " error: " <> errorText e.message Test.SuiteCompleted c -> t <> " " <> completionSummary c when (verbosity == Verbose) $ case tr of Test.SuiteCompleted c ->@@ -155,6 +153,9 @@ _ -> pure () where t = TestTarget.render tgt+ errorText message = case (verbosity, lines message) of+ (Concise, firstLine : _ : _) -> firstLine <> " (use --verbose to see the full message)"+ _ -> message buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics buildSummary tz r =@@ -421,10 +422,8 @@ 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.Finished _ postBuild} -> displayPostBuildStatus postBuild+ Right BuildState {phase = Build.PostBuilding _ postBuild} -> displayPostBuildStatus postBuild Right BuildState {phase = Build.Failed _} -> pure () Left _ -> pure () where
src/Tricorder/CLI/Render.hs view
@@ -10,13 +10,14 @@ import Atelier.Effects.Console (Console) import Atelier.Time (Millisecond, toMicroseconds)+import Tricorder.SourceLookup.ModuleSourceResult (ModuleSourceResult)+import Tricorder.SourceLookup.PackageId (PackageId (..)) import Tricorder.SourceLookup.SourceQuery (ModuleName (..), SourceQuery (..)) import Atelier.Effects.Console qualified as Console+import Tricorder.SourceLookup.ModuleSourceResult qualified as ModuleSourceResult import Tricorder.Build (Diagnostic (..), Severity (..))-import Tricorder.SourceLookup (ModuleSourceResult (..))-import Tricorder.SourceLookup.PackageId (PackageId (..)) formatDuration :: Millisecond -> Text@@ -55,28 +56,28 @@ renderSourceResults :: (Console :> es) => [ModuleSourceResult] -> Eff es () renderSourceResults results = mapM_ renderOne results where- renderOne (SourceFound query src) = do+ renderOne (ModuleSourceResult.SourceFound query src) = do when (length results > 1) $ Console.putTextLn $ header query Console.putText src when (length results > 1) $ Console.putStrLn ""- renderOne (SourceReexported query definedIn src) = do+ renderOne (ModuleSourceResult.SourceReexported query definedIn src) = do when (length results > 1) $ Console.putTextLn $ header query Console.putTextLn $ "-- Re-exported from " <> unModuleName definedIn Console.putText src when (length results > 1) $ Console.putStrLn ""- renderOne (SourceNotFound query) =+ renderOne (ModuleSourceResult.SourceNotFound query) = Console.putTextLn $ "Not found: " <> unModuleName query.moduleName <> " (module not in the project or any installed package)"- renderOne (SourceUnavailable query pkgId) =+ renderOne (ModuleSourceResult.SourceUnavailable query pkgId) = Console.putTextLn $ "No source available: " <> unModuleName query.moduleName <> " (could not locate or fetch a source tarball for "- <> unPackageId pkgId+ <> pkgId.unPackageId <> ")"- renderOne (FunctionNotFound query) =+ renderOne (ModuleSourceResult.FunctionNotFound query) = Console.putTextLn $ "tricorder: " <> unModuleName query.moduleName
src/Tricorder/CLI/UI/State.hs view
@@ -2,7 +2,6 @@ ( Viewports (..) , State (..) , Processed (..)- , TestFilter (..) , init , currentRoute , viewToViewport@@ -12,9 +11,11 @@ where import Atelier.Effects.Clock (Clock, TimeZone)+import Tricorder.API.TestFilter (TestFilter) import Prelude hiding (init) import Atelier.Effects.Clock qualified as Clock+import Tricorder.API.TestFilter qualified as TestFilter import Tricorder.Build (BuildState) import Tricorder.CLI.UI.Route (Route)@@ -39,10 +40,6 @@ } -data TestFilter = TestFilterAll | TestFilterFailedOnly- deriving stock (Bounded, Enum, Eq)-- cycleTestFilter :: TestFilter -> TestFilter cycleTestFilter x = if x == maxBound then minBound else succ x @@ -76,6 +73,6 @@ { buildState = Waiting , timeZone = tz , route = Route.Main- , testFilter = minBound+ , testFilter = TestFilter.All , showHelp = False }
src/Tricorder/CLI/UI/View.hs view
@@ -26,12 +26,14 @@ , withVScrollBars ) import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime)+import Tricorder.API.TestFilter (TestFilter) import Brick.Keybindings.KeyConfig qualified as KeyConfig 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.API.TestFilter qualified as TestFilter import Tricorder.Build (BuildPhase, BuildResult, BuildState, Diagnostic, Severity (..)) import Tricorder.Build.Duration (Duration (..))@@ -41,7 +43,6 @@ import Tricorder.CLI.UI.State ( Processed (..) , State (..)- , TestFilter (..) , Viewports (..) , currentRoute )@@ -171,8 +172,8 @@ | ws.showHelp = Just "Help" | otherwise = case currentRoute ws of Route.Tests -> case ws.testFilter of- TestFilterAll -> Just "Tests"- TestFilterFailedOnly -> Just "Tests - Failed only"+ TestFilter.All -> Just "Tests"+ TestFilter.FailedOnly -> Just "Tests - Failed only" Route.Main -> Nothing Route.Evals -> Just "Eval comments" @@ -489,9 +490,9 @@ viewTestOutput :: TestFilter -> Test.SuiteCompletion -> Widget n-viewTestOutput TestFilterAll c =+viewTestOutput TestFilter.All c = padLeft (Pad 2) $ vBox $ txt <$> stripGhciNoise (T.lines c.output)-viewTestOutput TestFilterFailedOnly c+viewTestOutput TestFilter.FailedOnly c | not (any Test.caseFailed c.testCases) && c.passed = emptyWidget | null c.testCases = padLeft (Pad 2)
src/Tricorder/Daemon/Core.hs view
@@ -39,9 +39,7 @@ import Tricorder.Daemon.TestRunner (TestRunner) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session (Session (..))-import Tricorder.Session.Stage.Build.Session (BuildSession (..)) import Tricorder.Session.Stage.Test.Command (RenderedTestCommand (..))-import Tricorder.Session.Stage.Test.Session (TestSession (..)) import Tricorder.Session.TestTimeout (TestTimeout (..)) import Tricorder.Waiters (Waiters) @@ -56,8 +54,11 @@ import Tricorder.Daemon.TestRunner qualified as TestRunner import Tricorder.Session.Hook qualified as Hook import Tricorder.Session.Hooks qualified as Hooks-import Tricorder.Session.Stage.Build.Command qualified as BuildCommand-import Tricorder.Session.Stage.Test.Command qualified as TestCommand+import Tricorder.Session.Stage.Build.Command qualified as Build.Command+import Tricorder.Session.Stage.Build.Session qualified as Build.Session+import Tricorder.Session.Stage.Test.Command qualified as Test.Command+import Tricorder.Session.Stage.Test.Session qualified as Test (Session)+import Tricorder.Session.Stage.Test.Session qualified as Test.Session import Tricorder.Session.TestTarget qualified as TestTarget import Tricorder.Waiters qualified as Waiters @@ -124,7 +125,7 @@ Pub.publish Build.Starting whenJust (session.hooks.start >>= (.before)) Hook.run startupError <- fmap (either id absurd)- $ Pub.map (Build.Building session.testSession.targets)+ $ Pub.map (Build.Building $ Test.Session.targets session.testSession) $ Builder.with buildId buildCommand session.watchDirs \_ initialLoad -> do whenJust (session.hooks.start >>= (.after)) Hook.run processPostBuild session $ Right initialLoad@@ -146,7 +147,10 @@ Pub.publish $ Build.Failed $ toText $ displayException startupError where- buildCommand = BuildCommand.render session.buildSession.commandTemplate session.buildSession.targets+ buildCommand =+ Build.Command.render+ (Build.Session.commandTemplate session.buildSession)+ session.buildSession.targets -- | Handles source changes as they come, determining whether the source change@@ -293,7 +297,7 @@ , Pub Test.Suites :> es , TestRunner :> es )- => TestSession+ => Test.Session -> Maybe ByteSize -> TestTimeout -> Eff es Test.Suites@@ -305,7 +309,7 @@ initial = Map.fromList $ (,Test.SuiteRunning Nothing) <$> testSession.targets go target = do Log.info $ "Running tests: " <> renderedTarget- let testCommand = TestCommand.render testSession memoryLimit target+ let testCommand = Test.Command.render testSession memoryLimit target publishProgress suite = do updated <- State.state $ dup . Map.insert target suite Pub.publish $ Test.Suites updated@@ -314,7 +318,7 @@ <> renderedTarget <> " command:\n" <> show testCommand.command- finishedSuite <- TestRunner.runTestSuite publishProgress testTimeout testCommand+ finishedSuite <- TestRunner.runTestSuite testSession publishProgress testTimeout testCommand case finishedSuite of Test.SuiteErrored (Test.SuiteError message) -> Log.warn $ "Test suite " <> renderedTarget <> "failed: " <> message
src/Tricorder/Daemon/DaemonInfo.hs view
@@ -15,11 +15,12 @@ import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..)) import Tricorder.Session (Session (..))-import Tricorder.Session.Stage.Build.Session (BuildSession (..)) import Tricorder.Session.Target (Target) import Tricorder.Session.WatchDirs (WatchDirs (..)) +import Tricorder.Session.Stage.Build.Session qualified as Build.Session + data DaemonInfo = DaemonInfo { targets :: [Target] , watchDirs :: [FilePath]@@ -44,7 +45,7 @@ LogPath logFile <- ask pure $ DaemonInfo- { targets = session.buildSession.targets+ { targets = Build.Session.targets session.buildSession , watchDirs = map (makeRelative projectRoot) session.watchDirs.getWatchDirs , sockPath , logFile
src/Tricorder/Daemon/EvalCommentRunner.hs view
@@ -15,7 +15,6 @@ 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)@@ -31,12 +30,11 @@ import Tricorder.Daemon.Ghci.LoadedModule (LoadedModule (..)) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.CommandTemplate (CommandTemplate)+import Tricorder.Session.Stage.Eval.Session (Session (..)) import Tricorder.Build.EvalComment qualified as Eval import Tricorder.Daemon.Ghci.LoadedModule qualified as Ghci (LoadedModule) import Tricorder.Daemon.Ghci.Process qualified as Ghci.Process-import Tricorder.Session.Stage qualified as Stage import Tricorder.Session.Stage.Eval.Command qualified as EvalCommand import Tricorder.Session.Target qualified as Target @@ -45,7 +43,7 @@ -- | 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- :: CommandTemplate 'Stage.Eval+ :: Session -> NonEmpty (Ghci.LoadedModule, NonEmpty Eval.Comment) -> EvalCommentRunner m (NonEmpty Eval.Evaluation) -- | Extract eval comments from provided source files. Returns a map of all@@ -83,9 +81,9 @@ case Eval.findComments $ decodeUtf8Lenient bs of [] -> [] x : xs -> [(lm, x :| xs)]- EvaluateComments template moduleComments -> do+ EvaluateComments session moduleComments -> do fmap sconcat $ for moduleComments \(lm, comments) ->- runFileEvals template lm.relPath lm.moduleName comments+ runFileEvals session lm.relPath lm.moduleName comments -- ---------------------------------------------------------------------------@@ -107,22 +105,22 @@ , Reader ProjectRoot :> es , Timeout :> es )- => CommandTemplate 'Stage.Eval+ => Session -> FilePath -- ^ Relative path to the source file (stored in results). -> Text -> NonEmpty Eval.Comment -> Eff es (NonEmpty Eval.Evaluation)-runFileEvals template relPath moduleName comments = do+runFileEvals session relPath moduleName comments = do ProjectRoot projectRoot <- ask let noProgress = \_ -> pure () noSetup = \_ -> pure () wrapForGhci expr | T.elem '\n' expr = ":{" <> "\n" <> expr <> "\n" <> ":}" | otherwise = expr- command = EvalCommand.render template [Target.Bare moduleName]+ command = EvalCommand.render session.commandTemplate [Target.Bare moduleName] sessionResult <- trySync- $ Ghci.Process.with def command projectRoot noProgress noSetup \ghci _ -> do+ $ Ghci.Process.with session.ghci command projectRoot noProgress noSetup \ghci _ -> do _ <- Ghci.Process.exec ghci (":m *" <> moduleName) noProgress for comments \comment -> do outputResult <- trySync $ Ghci.Process.exec ghci (wrapForGhci comment.expression) noProgress
src/Tricorder/Daemon/Ghci/Config.hs view
@@ -1,9 +1,17 @@-module Tricorder.Daemon.Ghci.Config (Config (..)) where+module Tricorder.Daemon.Ghci.Config+ ( Config (..)+ , display+ )+where import Atelier.Time (Second) import Data.Default (Default (..)) +import Data.Text qualified as T +import Tricorder.Session.Util (displayList, indent)++ -- | Configuration for GHCi process management. data Config = Config { startupTimeout :: Second@@ -14,6 +22,7 @@ -- ^ Additional GHCi commands to send after the fixed setup block. -- Use this to inject session-wide options such as @:set -XOverloadedStrings@. }+ deriving stock (Eq) instance Default Config where@@ -23,3 +32,14 @@ , shutdownTimeout = 5 , extraSetupCommands = [] }+++display :: Config -> Text+display config =+ T.intercalate+ "\n"+ [ "Startup timeout: " <> show config.startupTimeout+ , "Shutdown timeout: " <> show config.shutdownTimeout+ , "Extra setup commands:"+ , indent $ displayList id config.extraSetupCommands+ ]
+ src/Tricorder/Daemon/Ghci/Config/File.hs view
@@ -0,0 +1,48 @@+module Tricorder.Daemon.Ghci.Config.File+ ( File (..)+ , toConfig+ )+where++import Atelier.Time (AsRawUnit (..), Millisecond)+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults+ ( WithDefaults (..)+ )+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))++import Atelier.Time qualified as Time++import Tricorder.Daemon.Ghci.Config+ ( Config (..)+ )+++data File = File+ { startupTimeoutMs :: Maybe (AsRawUnit Millisecond)+ -- ^ How long to wait for the GHCi version banner on startup.+ , shutdownTimeoutMs :: Maybe (AsRawUnit Millisecond)+ -- ^ How long to wait for the process to exit gracefully before force-killing.+ , extraSetupCommands :: Maybe [Text]+ -- ^ Additional GHCi commands to send after the fixed setup block.+ -- Use this to inject session-wide options such as @:set -XOverloadedStrings@.+ }+ deriving stock (Eq, Generic, Show)+ deriving (ToJSON) via QuietSnake File+ deriving (FromJSON) via WithDefaults (QuietSnake File)+++instance Default File where+ def = File Nothing Nothing Nothing+++toConfig :: File -> Config+toConfig file =+ Config+ { startupTimeout = maybe cfg.startupTimeout (Time.convertUnit . getAsRawUnit) file.startupTimeoutMs+ , shutdownTimeout = maybe cfg.shutdownTimeout (Time.convertUnit . getAsRawUnit) file.shutdownTimeoutMs+ , extraSetupCommands = fromMaybe cfg.extraSetupCommands file.extraSetupCommands+ }+ where+ cfg = def :: Config
src/Tricorder/Daemon/TestRunner.hs view
@@ -34,7 +34,6 @@ import Atelier.Effects.Timeout (Timeout, timeout) import Control.Concurrent.STM (modifyTVar') import Control.Exception (throwIO)-import Data.Default (def) import Data.Sequence ((|>)) import Data.Time.Units (Second) import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (ConcUnlift))@@ -59,7 +58,7 @@ import Tricorder.Session.Stage (Stage (..)) import Tricorder.Session.Stage.Test.Command (RenderedTestCommand (..)) import Tricorder.Session.Stage.Test.Config (OutputMode (..))-import Tricorder.Session.Stage.Test.Session (ResolvedTestOptions (..))+import Tricorder.Session.Stage.Test.Session (ResolvedTestOptions (..), Session (..)) import Tricorder.Session.TestTimeout (TestTimeout (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) @@ -73,7 +72,8 @@ -- | Run a single test suite in a short-lived @cabal repl@ process and -- return the captured output and detected outcome. RunTestSuite- :: (Test.Suite -> m ())+ :: Session+ -> (Test.Suite -> m ()) -- ^ Handler for test run progress -> TestTimeout -> RenderedTestCommand@@ -98,11 +98,11 @@ => Eff (TestRunner : es) a -> Eff es a run act = do interpretWith act \env -> \case- RunTestSuite progressHandler testTimeout cmd ->+ RunTestSuite session progressHandler testTimeout cmd -> localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do let onProgress = unlift . progressHandler . loadingToProgress case cmd.options.outputMode of- ReplOutput -> runTestSuiteWithGHCi onProgress testTimeout cmd.command+ ReplOutput -> runTestSuiteWithGHCi session onProgress testTimeout cmd.command StdoutOutput -> runTestSuiteWithStdout onProgress testTimeout cmd.command @@ -189,26 +189,21 @@ , Reader ProjectRoot :> es , Timeout :> es )- => (Ghci.Loading -> Eff es ())+ => Session+ -> (Ghci.Loading -> Eff es ()) -> TestTimeout -> RenderedCommand 'Test -> Eff es Test.Suite-runTestSuiteWithGHCi onProgress testTimeout cmd = do+runTestSuiteWithGHCi session onProgress testTimeout cmd = do ProjectRoot projectRoot <- ask result <- trySync- $ Ghci.Process.with- def- cmd- projectRoot- onProgress- noReady- \ghci _ ->- case testTimeout of- TestTimeout secs | secs <= 0 -> Right <$> Ghci.Process.exec ghci ":main" noProgress- TestTimeout secs ->- let duration = fromIntegral secs :: Second- in maybeToRight secs- <$> timeout duration (Ghci.Process.exec ghci ":main" noProgress)+ $ Ghci.Process.with session.ghci cmd projectRoot onProgress noReady \ghci _ ->+ case testTimeout of+ TestTimeout secs | secs <= 0 -> Right <$> Ghci.Process.exec ghci ":main" noProgress+ TestTimeout secs ->+ let duration = fromIntegral secs :: Second+ in maybeToRight secs+ <$> timeout duration (Ghci.Process.exec ghci ":main" noProgress) case result of Left ex -> case fromException ex of Just (e :: Ghci.Process.Error) -> case e of@@ -266,7 +261,7 @@ runScripted results = reinterpret_ (evalState results)- (\(RunTestSuite _ _ _) -> popResult)+ (\(RunTestSuite _ _ _ _) -> popResult) where popResult :: Eff (State [Either SomeException Test.Suite] : es) Test.Suite popResult =
src/Tricorder/Session.hs view
@@ -21,20 +21,14 @@ import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.CabalFile (CabalFile) import Tricorder.Session.CommandConfig (CommandConfig (..))-import Tricorder.Session.CommandTemplate- ( CommandTemplate (..)- , hasPlaceholder- , targetPlaceholder- )+import Tricorder.Session.CommandTemplate (hasPlaceholder, targetPlaceholder) import Tricorder.Session.Config (Config (..)) import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..)) import Tricorder.Session.Hooks (Hooks) import Tricorder.Session.IdleTimeout (IdleTimeout (..)) import Tricorder.Session.Repl (resolveRepl) import Tricorder.Session.ReplBuildDir (ReplBuildDir (..))-import Tricorder.Session.Stage.Build.Session (BuildSession (..)) import Tricorder.Session.Stage.Test.Config (TestConfig (..))-import Tricorder.Session.Stage.Test.Session (TestSession (..)) import Tricorder.Session.Target (definesCustomPrelude) import Tricorder.Session.TestTarget (getTestTarget) import Tricorder.Session.TestTimeout (TestTimeout (..))@@ -48,18 +42,19 @@ import Tricorder.Build.ByteSize qualified as ByteSize import Tricorder.Config qualified as Tricorder import Tricorder.Session.Hooks qualified as Hooks-import Tricorder.Session.Stage qualified as Stage-import Tricorder.Session.Stage.Build.Session qualified as BuildSession-import Tricorder.Session.Stage.Eval.Command qualified as EvalCommand-import Tricorder.Session.Stage.Eval.Session qualified as EvalSession-import Tricorder.Session.Stage.Test.Session qualified as TestSession+import Tricorder.Session.Stage.Build.Session qualified as Build (Session)+import Tricorder.Session.Stage.Build.Session qualified as Build.Session+import Tricorder.Session.Stage.Eval.Session qualified as Eval (Session)+import Tricorder.Session.Stage.Eval.Session qualified as Eval.Session+import Tricorder.Session.Stage.Test.Session qualified as Test (Session)+import Tricorder.Session.Stage.Test.Session qualified as Test.Session import Tricorder.Session.WatchDirs qualified as WatchDirs data Session = Session- { buildSession :: BuildSession- , testSession :: TestSession- , evalSession :: CommandTemplate 'Stage.Eval+ { buildSession :: Build.Session+ , testSession :: Test.Session+ , evalSession :: Eval.Session , testMemoryLimit :: Maybe ByteSize , watchDirs :: WatchDirs , watchExclusionPatterns :: WatchExclusionPatterns@@ -139,9 +134,9 @@ Right pts -> pure pts repl <- resolveRepl projectRoot- buildSession <- BuildSession.resolve cfgFile repl projectFiles- let testSession = TestSession.resolve repl buildSession.targets cfgFile- evalSession = EvalCommand.resolve repl cfgFile+ buildSession <- Build.Session.resolve cfgFile repl projectFiles+ let testSession = Test.Session.resolve repl buildSession.targets cfgFile+ evalSession = Eval.Session.resolve repl cfgFile effectiveTargets = buildSession.targets <> (getTestTarget <$> testSession.targets) watchDirs = WatchDirs.resolve projectRoot projectFiles cfgFile effectiveTargets @@ -237,11 +232,11 @@ "\n" [ "Loaded session" , "Build configuration:"- , indent $ BuildSession.display session.buildSession+ , indent $ Build.Session.display session.buildSession , "Test configuration:"- , indent $ TestSession.display session.testSession+ , indent $ Test.Session.display session.testSession , "Eval comments configuration:"- , indent $ EvalSession.display session.evalSession+ , indent $ Eval.Session.display session.evalSession , "Watch dirs:" , indent $ displayList toText session.watchDirs.getWatchDirs , "Watch exclusion patterns:"
src/Tricorder/Session/CommandConfig.hs view
@@ -6,7 +6,9 @@ import Tricorder.Session.Stage (Stage) +import Tricorder.Daemon.Ghci.Config.File qualified as Ghci.Config (File) + -- | Configuration shared by the @build@, @test@, and @eval@ sections: an -- optional command template (falls back to Tricorder's automatically -- resolved command per detected REPL kind when unset), an optional explicit@@ -23,6 +25,8 @@ -- ^ Arguments to pass to the Tricorder-detected command for the given -- stage. Mutually exclusive with 'commandTemplate'. If both -- 'commandTemplate' and 'extraAutoArguments' are set, a warning is logged.+ , ghci :: Maybe Ghci.Config.File+ -- ^ Configuration pertaining to GHCi for the given stage. } deriving stock (Eq, Generic, Show) deriving (FromJSON, ToJSON) via QuietSnake (CommandConfig stage)@@ -34,4 +38,5 @@ { commandTemplate = Nothing , targets = Nothing , extraAutoArguments = []+ , ghci = Nothing }
src/Tricorder/Session/Stage/Build/Session.hs view
@@ -1,5 +1,5 @@ module Tricorder.Session.Stage.Build.Session- ( BuildSession (..)+ ( Session (..) , resolve , display )@@ -14,47 +14,54 @@ import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.CabalFile (CabalFile)-import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandConfig+ ( CommandConfig (..)+ ) import Tricorder.Session.CommandTemplate (CommandTemplate) import Tricorder.Session.Config (Config (..)) import Tricorder.Session.Repl (Repl) import Tricorder.Session.Target (Target) import Tricorder.Session.Util (displayList, indent) +import Tricorder.Daemon.Ghci.Config qualified as Ghci (Config)+import Tricorder.Daemon.Ghci.Config qualified as Ghci.Config+import Tricorder.Daemon.Ghci.Config.File qualified as Ghci.Config.File import Tricorder.Session.CommandTemplate qualified as CommandTemplate import Tricorder.Session.Stage qualified as Stage import Tricorder.Session.Stage.Build.Command qualified as BuildCommand import Tricorder.Session.Target qualified as Target -data BuildSession = BuildSession+data Session = Session { commandTemplate :: CommandTemplate 'Stage.Build , targets :: [Target]+ , ghci :: Ghci.Config } deriving stock (Eq) -instance Default BuildSession where- def = BuildSession def []+instance Default Session where+ def = Session def [] def resolve :: (FileSystem :> es, Reader ProjectRoot :> es)- => Config -> Repl -> [CabalFile] -> Eff es BuildSession+ => Config -> Repl -> [CabalFile] -> Eff es Session resolve config repl projectFiles = do projectRoot <- Reader.ask (commandTemplate, targets) <- BuildCommand.resolve projectRoot config repl effectiveTargets pure- $ BuildSession+ $ Session { commandTemplate , targets+ , ghci = maybe def Ghci.Config.File.toConfig config.build.ghci } where rawBuildTargets = fromMaybe config.targets config.build.targets effectiveTargets = Target.resolve projectFiles rawBuildTargets -display :: BuildSession -> Text+display :: Session -> Text display cfg = T.intercalate "\n"@@ -62,4 +69,6 @@ , indent $ CommandTemplate.display cfg.commandTemplate , "Targets:" , indent $ displayList Target.render cfg.targets+ , "GHCi config:"+ , indent $ Ghci.Config.display cfg.ghci ]
src/Tricorder/Session/Stage/Eval/Command.hs view
@@ -1,16 +1,11 @@ module Tricorder.Session.Stage.Eval.Command ( render- , resolve ) where import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))-import Tricorder.Session.CommandConfig (CommandConfig (..))-import Tricorder.Session.CommandTemplate (CommandTemplate (..), renderText, targetPlaceholder)-import Tricorder.Session.Config (Config (..))-import Tricorder.Session.Repl (Repl)+import Tricorder.Session.CommandTemplate (CommandTemplate (..), renderText) import Tricorder.Session.Stage (Stage (..))-import Tricorder.Session.Stage.Test.Session (defaultTestTemplate) import Tricorder.Session.Target (Target) @@ -18,17 +13,3 @@ -- session: the module being evaluated is substituted as the one target. render :: CommandTemplate 'Eval -> [Target] -> RenderedCommand 'Eval render commandTemplate targets = RenderedCommand $ renderText commandTemplate targets---resolve :: Repl -> Config -> CommandTemplate 'Eval-resolve repl cfg =- CommandTemplate- { repl- , template = fromMaybe (defaultEvalTemplate repl) cfg.eval.commandTemplate- , arguments = maybe cfg.eval.extraAutoArguments (const []) cfg.eval.commandTemplate- , placeholder = targetPlaceholder- }---defaultEvalTemplate :: Repl -> Text-defaultEvalTemplate = defaultTestTemplate
src/Tricorder/Session/Stage/Eval/Session.hs view
@@ -1,25 +1,63 @@ module Tricorder.Session.Stage.Eval.Session- ( EvalSession+ ( Session (..)+ , resolve , display ) where +import Data.Default (Default (..))+ import Data.Text qualified as T -import Tricorder.Session.CommandTemplate (CommandTemplate)+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..), targetPlaceholder)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl)+import Tricorder.Session.Stage.Test.Session (defaultTestTemplate) import Tricorder.Session.Util (indent) +import Tricorder.Daemon.Ghci.Config qualified as Ghci (Config)+import Tricorder.Daemon.Ghci.Config qualified as Ghci.Config+import Tricorder.Daemon.Ghci.Config.File qualified as Ghci.Config.File import Tricorder.Session.CommandTemplate qualified as CommandTemplate import Tricorder.Session.Stage qualified as Stage -type EvalSession = CommandTemplate 'Stage.Eval+data Session = Session+ { commandTemplate :: CommandTemplate 'Stage.Eval+ , ghci :: Ghci.Config+ }+ deriving stock (Eq) -display :: EvalSession -> Text+instance Default Session where+ def = Session def def+++resolve :: Repl -> Config -> Session+resolve repl cfg =+ Session+ { commandTemplate =+ CommandTemplate+ { repl+ , template = fromMaybe (defaultEvalTemplate repl) cfg.eval.commandTemplate+ , arguments = maybe cfg.eval.extraAutoArguments (const []) cfg.eval.commandTemplate+ , placeholder = targetPlaceholder+ }+ , ghci = maybe def Ghci.Config.File.toConfig cfg.eval.ghci+ }+++display :: Session -> Text display cfg = T.intercalate "\n" [ "Command template:"- , indent $ CommandTemplate.display cfg+ , indent $ CommandTemplate.display cfg.commandTemplate+ , "GHCi config:"+ , indent $ Ghci.Config.display cfg.ghci ]+++defaultEvalTemplate :: Repl -> Text+defaultEvalTemplate = defaultTestTemplate
src/Tricorder/Session/Stage/Test/Command.hs view
@@ -9,7 +9,7 @@ import Tricorder.Session.CommandTemplate (CommandTemplate (..)) import Tricorder.Session.Repl (Repl (..)) import Tricorder.Session.Stage (Stage (..))-import Tricorder.Session.Stage.Test.Session (ResolvedTestOptions (..), TestSession (..))+import Tricorder.Session.Stage.Test.Session (ResolvedTestOptions (..), Session (..)) import Tricorder.Session.TestTarget (TestTarget (..)) import Tricorder.Build.ByteSize qualified as ByteSize@@ -22,7 +22,7 @@ } -render :: TestSession -> Maybe ByteSize -> TestTarget -> RenderedTestCommand+render :: Session -> Maybe ByteSize -> TestTarget -> RenderedTestCommand render testSession mMemoryLimit target = RenderedTestCommand { command =
src/Tricorder/Session/Stage/Test/Session.hs view
@@ -1,5 +1,5 @@ module Tricorder.Session.Stage.Test.Session- ( TestSession (..)+ ( Session (..) , ResolvedTestOptions (..) , resolve , defaultTestTemplate@@ -20,25 +20,30 @@ import Tricorder.Session.TestTarget (TestTarget (..)) import Tricorder.Session.Util (displayList, indent) +import Tricorder.Daemon.Ghci.Config qualified as Ghci (Config)+import Tricorder.Daemon.Ghci.Config qualified as Ghci.Config+import Tricorder.Daemon.Ghci.Config.File qualified as Ghci.Config.File import Tricorder.Session.CommandTemplate qualified as CommandTemplate import Tricorder.Session.Stage qualified as Stage import Tricorder.Session.TestTarget qualified as TestTarget -data TestSession = TestSession+data Session = Session { commandTemplate :: CommandTemplate 'Stage.Test , targets :: [TestTarget] , options :: ResolvedTestOptions+ , ghci :: Ghci.Config } deriving stock (Eq) -instance Default TestSession where+instance Default Session where def =- TestSession+ Session { commandTemplate = def , targets = [] , options = def+ , ghci = def } @@ -52,9 +57,9 @@ def = ResolvedTestOptions ReplOutput -resolve :: Repl -> [Target] -> Config -> TestSession+resolve :: Repl -> [Target] -> Config -> Session resolve repl buildTargets cfg =- TestSession+ Session { commandTemplate = CommandTemplate { repl@@ -71,6 +76,7 @@ ResolvedTestOptions { outputMode = fromMaybe detectedOutputMode cfg.test.options.outputMode }+ , ghci = maybe def Ghci.Config.File.toConfig cfg.test.commandConfig.ghci } where template = fromMaybe (defaultTestTemplate repl) cfg.test.commandConfig.commandTemplate@@ -90,7 +96,7 @@ Unknown -> "cabal repl {target}" -display :: TestSession -> Text+display :: Session -> Text display cfg = T.intercalate "\n"@@ -100,6 +106,8 @@ , indent $ displayList TestTarget.render cfg.targets , "Options:" , indent $ showTestOptions cfg.options+ , "GHCi config:"+ , indent $ Ghci.Config.display cfg.ghci ] where showTestOptions opts =
src/Tricorder/Socket/Client.hs view
@@ -20,20 +20,20 @@ import Effectful.Reader.Static (Reader, ask) import Effectful.State.Static.Shared (evalState, get, modify, put) import System.IO.Error (isEOFError)-import Tricorder.CLI.Command (Force)+import Tricorder.API.Force (Force) 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.API.Force qualified as Force import Tricorder.Build (BuildState, Diagnostic) import Tricorder.Runtime (PidFile) import Tricorder.Socket.Protocol ( ClientMessage (..) , DiagnosticQuery (..)- , Force (..) , Query (..) , StatusQuery (..) , Waiters (..)@@ -137,8 +137,8 @@ pure $ Left "Failed to request shutdown" where waiters = case force of- Force -> IgnoreWaiters- NoForce -> WaitForWaiters+ Force.Force -> IgnoreWaiters+ Force.NoForce -> WaitForWaiters isDaemonRunning :: (Daemons :> es, Reader PidFile :> es) => Eff es Bool
src/Tricorder/Socket/Protocol.hs view
@@ -1,6 +1,5 @@ module Tricorder.Socket.Protocol- ( Force (..)- , Query (..)+ ( Query (..) , StatusQuery (..) , DiagnosticQuery (..) , ErrorResponse (..)@@ -10,7 +9,6 @@ where import Data.Aeson (FromJSON, ToJSON)-import Tricorder.CLI.Command (Force (..)) data StatusQuery = StatusQuery {awaitDone :: Bool}
src/Tricorder/SourceLookup.hs view
@@ -1,8 +1,5 @@ module Tricorder.SourceLookup- ( ModuleSourceResult (..)- , ReexportLimits (..)- , defaultReexportLimits- , lookupModuleSource+ ( lookupModuleSource , ProjectSourceDirs (..) , projectSourceDirs )@@ -11,21 +8,22 @@ import Atelier.Effects.FileSystem (FileSystem, doesFileExist, readFileLbs) import Atelier.Effects.Input (Input, input) import Atelier.Effects.Log (Log)-import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generically (..)) import System.FilePath (normalise, takeDirectory, (</>))+import Tricorder.SourceLookup.ModuleSourceResult (ModuleSourceResult (..))+import Tricorder.SourceLookup.PackageId (PackageId (..))+import Tricorder.SourceLookup.ReexportLimits (ReexportLimits (..)) import Tricorder.SourceLookup.SourceQuery (ModuleName (..), SourceQuery (..)) import Atelier.Effects.Log qualified as Log import Data.Set qualified as Set import Data.Text qualified as T+import Tricorder.SourceLookup.ModuleSourceResult qualified as ModuleSourceResult import Tricorder.Session.CabalFile (CabalFile (..)) import Tricorder.Session.Repl (Repl) import Tricorder.Session.WatchDirs (allSourceDirs) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage)-import Tricorder.SourceLookup.PackageId (PackageId (..)) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.SourceLookup.Reexport (declaresMember, exportsByName, reexportCandidates) import Tricorder.SourceLookup.Slice (sliceSymbol)@@ -39,41 +37,6 @@ import Tricorder.SourceLookup.GhcPkg qualified as GhcPkg --- | The result of a source lookup for a single module.-data ModuleSourceResult- = -- | Source was found; contains the module (or single-symbol) source text.- SourceFound SourceQuery Text- | -- | The module is neither in the project nor in any installed package.- SourceNotFound SourceQuery- | -- | 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 symbol is not defined in the queried module but re-exported by- -- it; contains the module that defines it and the symbol's source there.- SourceReexported SourceQuery ModuleName Text- | -- | The module source was found but the requested symbol was not in it.- FunctionNotFound SourceQuery- deriving stock (Eq, Generic, Show)- deriving (FromJSON, ToJSON) via Generically ModuleSourceResult----- | Bounds on the re-export search for a symbol the queried module does not--- define itself (see 'followReexports').-data ReexportLimits = ReexportLimits- { maxDepth :: Word- -- ^ Most re-export hops to follow; @0@ disables following re-exports.- , maxModules :: Word- -- ^ Most modules to read during the search.- }- deriving stock (Eq, Show)----- | Enough for the deepest chains seen in practice (@Prelude#Maybe@ takes 3--- hops through @ghc-internal@) while keeping a miss cheap.-defaultReexportLimits :: ReexportLimits-defaultReexportLimits = ReexportLimits {maxDepth = 5, maxModules = 24}-- -- | The directories holding the project's own modules: the @hs-source-dirs@ of -- every component of every project package, resolved against the package dir. newtype ProjectSourceDirs = ProjectSourceDirs [FilePath]@@ -131,7 +94,7 @@ lookupModuleSource dirs limits query = do (mOrigin, result) <- lookupLocal dirs InProject query case (result, mOrigin, query.function) of- (FunctionNotFound _, Just origin, Just symbol) ->+ (ModuleSourceResult.FunctionNotFound _, Just origin, Just symbol) -> fromMaybe result <$> followReexports dirs limits query symbol origin _ -> pure result
src/Tricorder/SourceLookup/GhcPkg.hs view
@@ -12,12 +12,12 @@ import Effectful.Dispatch.Dynamic (interpret, reinterpret) import Effectful.State.Static.Shared (evalState, get, put) import Effectful.TH (makeEffect)+import Tricorder.SourceLookup.PackageId (PackageId (..)) import Tricorder.SourceLookup.SourceQuery (ModuleName (..)) import Data.Text qualified as T import Tricorder.Session.Repl (Repl (..))-import Tricorder.SourceLookup.PackageId (PackageId (..)) data GhcPkg :: Effect where
src/Tricorder/SourceLookup/Hackage.hs view
@@ -28,12 +28,11 @@ , runReq , (/:) )+import Tricorder.SourceLookup.PackageId (PackageId (..)) import Atelier.Effects.Log qualified as Log -import Tricorder.SourceLookup.PackageId (PackageId (..)) - data Hackage :: Effect where FetchPackage :: PackageId -> Hackage m Result @@ -67,7 +66,7 @@ pure $ Failure $ "Failed to fetch "- <> unPackageId packageId+ <> packageId.unPackageId <> " from " <> show url <> "\n"
− src/Tricorder/SourceLookup/PackageId.hs
@@ -1,25 +0,0 @@-module Tricorder.SourceLookup.PackageId- ( PackageId (..)- , splitPackageId- )-where--import Data.Aeson (FromJSON, ToJSON)--import Data.Text qualified as T----- | A @ghc-pkg@ package identifier, e.g. @"containers-0.6.8"@.-newtype PackageId = PackageId {unPackageId :: Text}- deriving stock (Eq, Ord, Show)- deriving (FromJSON, Hashable, IsString, ToJSON) via Text----- | 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, "")
src/Tricorder/SourceLookup/PackageStore.hs view
@@ -13,13 +13,12 @@ import Effectful.NonDet (NonDet, OnEmptyPolicy (..), emptyEff, plusEff, runNonDet) import Effectful.TH (makeEffect) import System.FilePath (takeDirectory, (</>))+import Tricorder.SourceLookup.PackageId (PackageId (..), splitPackageId) import Atelier.Effects.FileSystem qualified as FileSystem import Data.Map.Strict qualified as Map -import Tricorder.SourceLookup.PackageId (PackageId, splitPackageId, unPackageId) - data PackageStore :: Effect where Add :: PackageId -> ByteString -> PackageStore m FilePath GetPath :: PackageId -> PackageStore m (Maybe FilePath)@@ -56,7 +55,7 @@ packageDir </> toString packageName </> toString packageVersion- </> toString (unPackageId packageId <> ".tar.gz")+ </> toString (packageId.unPackageId <> ".tar.gz") where (packageName, packageVersion) = splitPackageId packageId
src/Tricorder/SourceLookup/Tarball.hs view
@@ -20,6 +20,7 @@ import Data.Char (isUpper) import Effectful.Exception (trySync) import System.FilePath (splitDirectories, (</>))+import Tricorder.SourceLookup.PackageId (PackageId (..), splitPackageId) import Tricorder.SourceLookup.SourceQuery (ModuleName (..)) import Atelier.Effects.Log qualified as Log@@ -30,7 +31,6 @@ import Data.Text qualified as T import Tricorder.SourceLookup.Hackage (Hackage)-import Tricorder.SourceLookup.PackageId (PackageId (..), splitPackageId) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.SourceLookup.Hackage qualified as Hackage@@ -62,13 +62,13 @@ res <- Hackage.fetchPackage pkgId case res of Hackage.NotFound -> do- Log.warn $ "Package not found: " <> unPackageId pkgId+ Log.warn $ "Package not found: " <> pkgId.unPackageId pure TarballAbsent Hackage.Failure err -> do Log.err $ "Hackage fetch error: " <> err pure $ TarballFetchFailed Hackage.Success bytes -> do- Log.info $ "Storing tarball for " <> unPackageId pkgId+ Log.info $ "Storing tarball for " <> pkgId.unPackageId path <- PackageStore.add pkgId bytes Log.info $ "Tarball stored at " <> toText path pure $ TarballAt path
test/Unit/Tricorder/CLI/App/Test/SuiteViewSpec.hs view
@@ -1,26 +1,13 @@ module Unit.Tricorder.CLI.App.Test.SuiteViewSpec (test_SuiteView) where -import Data.Aeson (Value (..), toJSON) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))+import Tricorder.API.Test.SuiteView (CaseView (..), Outcome (..), Status (..), SuiteView (..)) -import Data.Aeson.Key qualified as Key-import Data.Aeson.KeyMap qualified as KeyMap import Data.Map.Strict qualified as Map-import Tricorder.CLI.Command.TestFilter qualified as TestFilter-import Tricorder.FieldMask.Schema qualified as FieldMask (Schema (..))-import Tricorder.FieldMask.Schema qualified as FieldMask.Schema+import Tricorder.API.TestFilter qualified as TestFilter -import Tricorder.Build.Duration (Duration (..))-import Tricorder.CLI.App.Test.SuiteView- ( CaseView (..)- , Outcome (..)- , Status (..)- , SuiteView (..)- , defaultFields- , schema- , selectSuites- )+import Tricorder.CLI.App.Test.SuiteView (selectSuites) import Tricorder.Session.TestTarget (TestTarget) import Tricorder.Build.Test qualified as Test@@ -31,11 +18,7 @@ test_SuiteView = testGroup "SuiteView"- [ testCase "schema lists every field of the JSON encoding" do- schemaKeys schema @?= jsonKeys (toJSON fullView)- , testCase "default fields are in the schema" do- void (FieldMask.Schema.select schema defaultFields) @?= Right ()- , testGroup "selectSuites" testSelectSuites+ [ testGroup "selectSuites" testSelectSuites ] @@ -85,35 +68,6 @@ target name = fromMaybe (Prelude.error $ "invalid test target: " <> name) $ TestTarget.parse name --- | A view with every field set, so every field shows up in its JSON.-fullView :: SuiteView-fullView =- SuiteView- { name = "test:suite"- , status = Failed- , error = Just "error"- , passedCases = Just 0- , totalCases = Just 1- , durationMs = Just $ Duration 5- , output = Just "output"- , cases = Just [CaseView "case" CaseFailed (Just "failure")]- }-- -- | Keys of a JSON value, nested keys of arrays taken from their first element. data Keys = Keys [(Text, Maybe Keys)] deriving stock (Eq, Show)---schemaKeys :: FieldMask.Schema -> Keys-schemaKeys (FieldMask.Schema fields) = Keys $ sortOn fst $ second (fmap schemaKeys) <$> fields---jsonKeys :: Value -> Keys-jsonKeys = \case- Object obj -> Keys $ sortOn fst [(Key.toText key, nestedKeys value) | (key, value) <- KeyMap.toList obj]- _ -> Keys []- where- nestedKeys = \case- Array values | Just element <- viaNonEmpty head (toList values) -> Just $ jsonKeys element- _ -> Nothing
test/Unit/Tricorder/Daemon/TestRunnerSpec.hs view
@@ -107,7 +107,7 @@ [ testCase "returns scripted TestRun" do result <- runScripted [Right passingRun]- $ runTestSuite noProgress testTimeout+ $ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:foo"@@ -115,7 +115,7 @@ , testCase "ignores the target name argument" do result <- runScripted [Right failingRun]- $ runTestSuite noProgress testTimeout+ $ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:anything"@@ -124,7 +124,7 @@ result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ runTestSuite noProgress testTimeout+ $ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:foo"@@ -134,12 +134,12 @@ [ testCase "consumes results in order across multiple calls" do (a, b) <- runScripted [Right passingRun, Right failingRun] do a <-- runTestSuite noProgress testTimeout+ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:foo" b <-- runTestSuite noProgress testTimeout+ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:bar"@@ -150,12 +150,12 @@ result <- runScripted [Left (toException boom), Right passingRun] do r1 <- try @ErrorCall- $ runTestSuite noProgress testTimeout+ $ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:foo" r2 <-- runTestSuite noProgress testTimeout+ runTestSuite def noProgress testTimeout $ mkResolved $ RenderedCommand $ "cabal repl test:bar"
test/Unit/Tricorder/Session/Stage/Eval/CommandSpec.hs view
@@ -1,16 +1,12 @@ module Unit.Tricorder.Session.Stage.Eval.CommandSpec (test_Command) where -import Data.Default (def) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))-import Tricorder.Session.CommandConfig (CommandConfig (..)) import Tricorder.Session.CommandTemplate (CommandTemplate (..), targetPlaceholder)-import Tricorder.Session.Config (Config (..)) import Tricorder.Session.Repl (Repl (..))-import Tricorder.Session.Stage (Stage (..))-import Tricorder.Session.Stage.Eval.Command (render, resolve)+import Tricorder.Session.Stage.Eval.Command (render) import Tricorder.Session.Target (Target (..)) @@ -18,8 +14,7 @@ test_Command = testGroup "Tricorder.Session.Stage.Eval.Command"- [ testGroup "resolveEvalCommand" testResolveEvalCommand- , testGroup "renderEval" testRenderEval+ [ testGroup "renderEval" testRenderEval ] @@ -34,29 +29,3 @@ ] where eval template targets = (render template targets).getRenderedCommand---testResolveEvalCommand :: [TestTree]-testResolveEvalCommand =- [ testCase "uses the built-in default template for Cabal when eval.command_template is unset" do- (resolve Cabal def).template @?= "cabal repl {target}"- , testCase "uses eval.command_template when set" do- let cfg =- def- { eval = (def :: CommandConfig 'Eval) {commandTemplate = Just "cabal repl --builddir /tmp {target}"}- }- (resolve Cabal cfg).template @?= "cabal repl --builddir /tmp {target}"- , testCase "carries eval.extra_auto_arguments when eval.command_template is unset" do- let cfg = def {eval = (def :: CommandConfig 'Eval) {extraAutoArguments = ["--flag"]}}- (resolve Cabal cfg).arguments @?= ["--flag"]- , testCase "ignores eval.extra_auto_arguments when eval.command_template is set" do- let cfg =- def- { eval =- (def :: CommandConfig 'Eval)- { commandTemplate = Just "cabal repl {target}"- , extraAutoArguments = ["--flag"]- }- }- (resolve Cabal cfg).arguments @?= []- ]
+ test/Unit/Tricorder/Session/Stage/Eval/SessionSpec.hs view
@@ -0,0 +1,53 @@+module Unit.Tricorder.Session.Stage.Eval.SessionSpec (test_Session) where++import Data.Default (def)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..))+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl (..))+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Stage.Eval.Session (Session (..), resolve)++import Tricorder.Session.CommandConfig qualified as CommandConfig+import Tricorder.Session.Config qualified as Config+++test_Session :: TestTree+test_Session =+ testGroup+ "Tricorder.Session.Stage.Eval.Session"+ [ testGroup "resolve" testResolve+ ]+++testResolve :: [TestTree]+testResolve =+ [ testCase "uses the built-in default template for Cabal when eval.command_template is unset" do+ (resolve Cabal def).commandTemplate.template @?= "cabal repl {target}"+ , testCase "uses eval.command_template when set" do+ let+ cfg =+ def+ { Config.eval =+ def+ { CommandConfig.commandTemplate = Just "cabal repl --builddir /tmp {target}"+ }+ }+ (resolve Cabal cfg).commandTemplate.template @?= "cabal repl --builddir /tmp {target}"+ , testCase "carries eval.extra_auto_arguments when eval.command_template is unset" do+ let cfg = def {eval = (def :: CommandConfig 'Eval) {extraAutoArguments = ["--flag"]}}+ (resolve Cabal cfg).commandTemplate.arguments @?= ["--flag"]+ , testCase "ignores eval.extra_auto_arguments when eval.command_template is set" do+ let cfg =+ def+ { eval =+ (def :: CommandConfig 'Eval)+ { commandTemplate = Just "cabal repl {target}"+ , extraAutoArguments = ["--flag"]+ }+ }+ (resolve Cabal cfg).commandTemplate.arguments @?= []+ ]
test/Unit/Tricorder/Session/Stage/Test/CommandSpec.hs view
@@ -15,7 +15,7 @@ , render ) import Tricorder.Session.Stage.Test.Config (TestConfig (..))-import Tricorder.Session.Stage.Test.Session (TestSession (..), resolve)+import Tricorder.Session.Stage.Test.Session (Session (..), resolve) import Tricorder.Session.TestTarget (TestTarget (..)) import Tricorder.Session.CommandConfig qualified as CommandConfig@@ -61,7 +61,7 @@ where test :: CommandTemplate 'Stage.Test -> Maybe ByteSize -> TestTarget -> Text test template mMemoryLimit target =- (render (TestSession template [] def) mMemoryLimit target).command.getRenderedCommand+ (render (Session template [] def def) mMemoryLimit target).command.getRenderedCommand testTarget = TestTarget (Target.parse "test:foo") oneByte = ByteSize 1 B
test/Unit/Tricorder/SourceLookup/TarballSpec.hs view
@@ -3,13 +3,13 @@ import System.FilePath (isAbsolute, (</>)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))+import Tricorder.SourceLookup.PackageId (splitPackageId) 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.PackageId (splitPackageId) import Tricorder.SourceLookup.Tarball ( cabalPackagesDirs , extractModule
test/Unit/Tricorder/SourceLookupSpec.hs view
@@ -12,6 +12,8 @@ import System.FilePath ((</>)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))+import Tricorder.SourceLookup.ModuleSourceResult (ModuleSourceResult (..))+import Tricorder.SourceLookup.ReexportLimits (ReexportLimits (..), defaultReexportLimits) import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery (..)) import Atelier.Effects.Input qualified as Input@@ -26,10 +28,7 @@ import Tricorder.Session.CabalFile (CabalFile (..)) import Tricorder.Session.Repl (Repl (..)) import Tricorder.SourceLookup- ( ModuleSourceResult (..)- , ProjectSourceDirs (..)- , ReexportLimits (..)- , defaultReexportLimits+ ( ProjectSourceDirs (..) , lookupModuleSource , projectSourceDirs )
tricorder.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder-version: 0.6.0.0+version: 0.7.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@@ -40,6 +40,7 @@ Tricorder.Build.Test Tricorder.CLI.App Tricorder.CLI.App.CLIResponse+ Tricorder.CLI.App.Daemon Tricorder.CLI.App.Output Tricorder.CLI.App.Test Tricorder.CLI.App.Test.Json@@ -47,12 +48,6 @@ Tricorder.CLI.App.Test.SuiteView Tricorder.CLI.App.Test.Text Tricorder.CLI.Arguments- Tricorder.CLI.Arguments.Daemon- Tricorder.CLI.Arguments.IfDaemonIsStopped- Tricorder.CLI.Arguments.OutputFormat- Tricorder.CLI.Arguments.Test- Tricorder.CLI.Arguments.TestFilter- Tricorder.CLI.Arguments.WaitMode Tricorder.CLI.Daemon Tricorder.CLI.Main Tricorder.CLI.Operations@@ -74,6 +69,7 @@ Tricorder.Daemon.Dispatch Tricorder.Daemon.EvalCommentRunner Tricorder.Daemon.Ghci.Config+ Tricorder.Daemon.Ghci.Config.File Tricorder.Daemon.Ghci.Controls Tricorder.Daemon.Ghci.Diagnostic Tricorder.Daemon.Ghci.InterruptDecision@@ -140,7 +136,6 @@ Tricorder.SourceLookup Tricorder.SourceLookup.GhcPkg Tricorder.SourceLookup.Hackage- Tricorder.SourceLookup.PackageId Tricorder.SourceLookup.PackageStore Tricorder.SourceLookup.Reexport Tricorder.SourceLookup.Slice@@ -206,7 +201,7 @@ , text ==2.1.* , time >=1.12 && <1.17 , time-units ==1.0.*- , tricorder-types ==0.5.*+ , tricorder-types ==0.6.* , vty >=6.5 && <6.7 , vty-crossplatform ==0.5.* , yaml ==0.11.*@@ -317,6 +312,7 @@ Unit.Tricorder.Session.ReplSpec Unit.Tricorder.Session.Stage.Build.CommandSpec Unit.Tricorder.Session.Stage.Eval.CommandSpec+ Unit.Tricorder.Session.Stage.Eval.SessionSpec Unit.Tricorder.Session.Stage.Test.CommandSpec Unit.Tricorder.Session.TargetSpec Unit.Tricorder.Session.TestTargetSpec@@ -380,7 +376,7 @@ , time >=1.12 && <1.17 , time-units ==1.0.* , tricorder-internal- , tricorder-types ==0.5.*+ , tricorder-types ==0.6.* , typed-process ==0.2.* , unagi-chan ==0.4.* , unix ==2.8.*