tricorder 0.2.1.0 → 0.2.2.0
raw patch · 77 files changed
+1242/−499 lines, 77 filesdep +tricorder-types
Dependencies added: tricorder-types
Files
- CHANGELOG.md +24/−2
- LICENSE +1/−1
- README.md +1/−0
- src/Tricorder/Build.hs +4/−3
- src/Tricorder/Build/ByteSize.hs +97/−0
- src/Tricorder/Build/Changes.hs +4/−1
- src/Tricorder/Build/Duration.hs +9/−0
- src/Tricorder/Build/EvalComment.hs +2/−1
- src/Tricorder/Build/Test.hs +4/−3
- src/Tricorder/CLI/App.hs +31/−26
- src/Tricorder/CLI/Arguments.hs +27/−80
- src/Tricorder/CLI/Daemon.hs +20/−16
- src/Tricorder/CLI/Operations.hs +37/−28
- src/Tricorder/CLI/Render.hs +10/−7
- src/Tricorder/CLI/UI.hs +2/−1
- src/Tricorder/CLI/UI/Brick.hs +2/−1
- src/Tricorder/CLI/UI/BrickChan.hs +2/−1
- src/Tricorder/CLI/UI/Event.hs +6/−2
- src/Tricorder/CLI/UI/Keys.hs +22/−17
- src/Tricorder/CLI/UI/Misc.hs +2/−1
- src/Tricorder/CLI/UI/Route.hs +2/−1
- src/Tricorder/CLI/UI/State.hs +2/−1
- src/Tricorder/CLI/UI/View.hs +38/−27
- src/Tricorder/Config.hs +10/−8
- src/Tricorder/Daemon/Builder.hs +5/−3
- src/Tricorder/Daemon/Core.hs +73/−9
- src/Tricorder/Daemon/DaemonInfo.hs +2/−1
- src/Tricorder/Daemon/Dispatch.hs +2/−1
- src/Tricorder/Daemon/EvalCommentRunner.hs +2/−1
- src/Tricorder/Daemon/GhciSession.hs +12/−3
- src/Tricorder/Daemon/GhciSession/GhciParser.hs +22/−17
- src/Tricorder/Daemon/GhciSession/GhciProcess.hs +8/−6
- src/Tricorder/Daemon/Hpack/Effect.hs +7/−5
- src/Tricorder/Daemon/IdleTimer.hs +87/−0
- src/Tricorder/Daemon/Main.hs +10/−2
- src/Tricorder/Daemon/TestRunner.hs +55/−17
- src/Tricorder/Daemon/Watch.hs +2/−1
- src/Tricorder/Module.hs +0/−29
- src/Tricorder/Runtime.hs +2/−1
- src/Tricorder/Session.hs +30/−2
- src/Tricorder/Session/CabalFile.hs +12/−5
- src/Tricorder/Session/Command.hs +31/−24
- src/Tricorder/Session/Config.hs +8/−0
- src/Tricorder/Session/Hooks.hs +61/−0
- src/Tricorder/Session/IdleTimeout.hs +14/−0
- src/Tricorder/Session/Target.hs +4/−1
- src/Tricorder/Session/TestTarget.hs +2/−1
- src/Tricorder/Session/WatchDirs.hs +2/−1
- src/Tricorder/Session/WatchExclusionPatterns.hs +2/−1
- src/Tricorder/Socket/Client.hs +9/−6
- src/Tricorder/Socket/Protocol.hs +4/−6
- src/Tricorder/Socket/Server.hs +15/−3
- src/Tricorder/Socket/UnixSocket.hs +4/−2
- src/Tricorder/SourceLookup.hs +17/−22
- src/Tricorder/SourceLookup/GhcPkg.hs +17/−6
- src/Tricorder/SourceLookup/Hackage.hs +6/−3
- src/Tricorder/SourceLookup/PackageId.hs +25/−0
- src/Tricorder/SourceLookup/PackageStore.hs +13/−10
- src/Tricorder/SourceLookup/Slice.hs +7/−5
- src/Tricorder/SourceLookup/Tarball.hs +4/−2
- src/Tricorder/TestOutput.hs +14/−11
- src/Tricorder/Version.hs +20/−13
- src/Tricorder/Waiters.hs +2/−1
- test/Unit/Tricorder/Build/ByteSizeSpec.hs +73/−0
- test/Unit/Tricorder/Daemon/BuildStateSpec.hs +4/−2
- test/Unit/Tricorder/Daemon/BuilderSpec.hs +3/−2
- test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs +85/−10
- test/Unit/Tricorder/Daemon/GhciSessionSpec.hs +9/−1
- test/Unit/Tricorder/Daemon/TestRunnerSpec.hs +12/−7
- test/Unit/Tricorder/Session/CabalFileSpec.hs +15/−11
- test/Unit/Tricorder/Session/Helpers.hs +3/−1
- test/Unit/Tricorder/SessionSpec.hs +25/−3
- test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs +6/−3
- test/Unit/Tricorder/SourceLookup/TarballSpec.hs +1/−1
- test/Unit/Tricorder/SourceLookupSpec.hs +21/−4
- test/Unit/Tricorder/TestOutputSpec.hs +4/−3
- tricorder.cabal +10/−2
CHANGELOG.md view
@@ -7,10 +7,32 @@ ## [Unreleased] -## 0.2.1.0 - 2026-08-17+## [0.2.2.0] - 2026-09-05 ### Added +- The daemon now shuts itself down after a period of inactivity, configurable+ with `idle_timeout_seconds` (defaults to 300 seconds; `0` disables it). Any+ client request resets the countdown, and a `tricorder ui` client's+ long-lived watch connection counts as continuous activity for as long as+ it's connected. See [Configuring Tricorder](/docs/configuring-tricorder.md)+ for more information.+- Use the `test_memory_limit` configuration value to specify the maximum memory+ a test suite is allowed to consume. This is enforced through GHC's `-M` RTS+ option.+- Hooks for running arbitrary shell scripts at certain points in time in the+ build process. See [Configuring Tricorder](/docs/configuring-tricorder.md)+ for more information.++### Fixed++- Unable to correctly parse `packages` lists in `cabal.project` files when the+ list was formatted as a single-line, comma-separated list.++## [0.2.1.0] - 2026-08-17++### Added+ - Tricorder now respects all forms of `cabal.project` files, like `cabal.project.local` for example. See [Cabal's documentation on project description files](https://cabal.readthedocs.io/en/stable/cabal-project-description-file.html). ([#73](https://github.com/tweag/tricorder/issues/73))@@ -34,7 +56,7 @@ - Incorrect repl command used for eval comments. This caused eval comments not to be able to use a module's top-level definitions in its expression. - Auto-resolved targets are not compatible with `stack ghci` (and its alias- `stack ghci`). Targets are now automatically resolved with package name,+ `stack repl`). Targets are now automatically resolved with package name, `pkg:kind:name` for multi-package repos and just `name` for single-package repos, instead of just with the component name and kind `kind:name`. `stack ghci` is not compatible with the form `kind:name` (but `cabal repl` is), but
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2025 Tweag+Copyright (c) 2026 Tweag Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
README.md view
@@ -14,6 +14,7 @@ - [`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+- [`atelier-monitoring`](https://github.com/tweag/tricorder/tree/main/atelier-monitoring) - observability and monitoring effects and utilities ## License
src/Tricorder/Build.hs view
@@ -7,13 +7,14 @@ , PostBuild (..) , Diagnostic (..) , Severity (..)- ) where+ )+where import Atelier.Effects.Clock (UTCTime)-import Atelier.Time (Millisecond) import Data.Aeson (FromJSON (..), ToJSON (..), withText) import GHC.Generics (Generically (..)) +import Tricorder.Build.Duration (Duration) import Tricorder.Daemon.DaemonInfo (DaemonInfo) import Tricorder.Session.TestTarget (TestTarget) @@ -55,7 +56,7 @@ data BuildResult = BuildResult { completedAt :: UTCTime- , duration :: Millisecond+ , duration :: Duration , moduleCount :: Int , diagnostics :: [Diagnostic] }
+ src/Tricorder/Build/ByteSize.hs view
@@ -0,0 +1,97 @@+module Tricorder.Build.ByteSize+ ( ByteSize (..)+ , Unit (..)+ , asBytes+ , toRTSSize+ , fromText+ )+where++import Text.Megaparsec (Parsec, eof, parseMaybe)+import Text.Megaparsec.Char (space, string')+import Text.Megaparsec.Char.Lexer (decimal)+import Prelude hiding (toText)++import Text.Show qualified as S+++data ByteSize = ByteSize {amount :: Integer, unit :: Unit}+ deriving stock (Eq, Generic, Ord)+++instance Show ByteSize where+ show ByteSize {amount, unit} = show amount <> show unit+++data Unit+ = B+ | KB+ | KiB+ | MB+ | MiB+ | GB+ | GiB+ | TB+ | TiB+ | PB+ | PiB+ deriving stock (Eq, Generic, Ord, Show)+++asBytes :: ByteSize -> Integer+asBytes bs = bs.amount * multiplier bs.unit+++multiplier :: Unit -> Integer+multiplier = \case+ B -> 1+ KB -> 1000+ KiB -> 1024+ MB -> 1000 `pow` 2+ MiB -> 1024 `pow` 2+ GB -> 1000 `pow` 3+ GiB -> 1024 `pow` 3+ TB -> 1000 `pow` 4+ TiB -> 1024 `pow` 4+ PB -> 1000 `pow` 5+ PiB -> 1024 `pow` 5+ where+ pow :: Integer -> Integer -> Integer+ pow = (^)+++toRTSSize :: ByteSize -> Text+toRTSSize bs = show $ bs.amount * multiplier bs.unit+++fromText :: Text -> Maybe ByteSize+fromText = parseMaybe byteSizeP+++byteSizeP :: Parser ByteSize+byteSizeP = do+ amount <- decimal+ space+ unit <- unitP+ pure $ ByteSize {amount, unit}+++unitP :: Parser Unit+unitP =+ asum+ [ string' "kb" *> pure KB+ , string' "kib" *> pure KiB+ , string' "mb" *> pure MB+ , string' "mib" *> pure MiB+ , string' "gb" *> pure GB+ , string' "gib" *> pure GiB+ , string' "tb" *> pure TB+ , string' "tib" *> pure TiB+ , string' "pb" *> pure PB+ , string' "pib" *> pure PiB+ , string' "b" *> pure B+ , eof *> pure B+ ]+++type Parser = Parsec Void Text
src/Tricorder/Build/Changes.hs view
@@ -2,7 +2,8 @@ ( ChangeKind (..) , CabalChangeDetected (..) , SourceChangeDetected (..)- ) where+ )+where import Atelier.Effects.FileWatcher (FileEvent) @@ -15,5 +16,7 @@ data CabalChangeDetected = CabalChangeDetected FilePath FileEvent deriving stock (Eq, Show)++ data SourceChangeDetected = SourceChangeDetected FilePath FileEvent deriving stock (Eq, Show)
+ src/Tricorder/Build/Duration.hs view
@@ -0,0 +1,9 @@+module Tricorder.Build.Duration (Duration (..)) where++import Atelier.Time (AsRawUnit (..), Millisecond)+import Data.Aeson (FromJSON, ToJSON)+++newtype Duration = Duration {getDuration :: Millisecond}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via AsRawUnit Millisecond
src/Tricorder/Build/EvalComment.hs view
@@ -12,7 +12,8 @@ , blockCommentEvalP , State (..) , JsonOutput (..)- ) where+ )+where import Atelier.Types.QuietSnake (QuietSnake (..)) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, (.:))
src/Tricorder/Build/Test.hs view
@@ -12,14 +12,15 @@ , caseFailed , SuiteCompletion (..) , SuiteError (..)- ) where+ )+where -import Atelier.Time (Millisecond) import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generically (..)) import Data.Map.Strict qualified as Map +import Tricorder.Build.Duration (Duration) import Tricorder.Session.TestTarget (TestTarget) @@ -105,7 +106,7 @@ { passed :: Bool , output :: Text , testCases :: [Case]- , duration :: Maybe Millisecond+ , duration :: Maybe Duration } deriving stock (Eq, Generic, Show) deriving (FromJSON, ToJSON) via (Generically SuiteCompletion)
src/Tricorder/CLI/App.hs view
@@ -71,15 +71,17 @@ 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."+ 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@@ -92,28 +94,31 @@ Console.putTextLn result Status opts -> do running <- isDaemonRunning- if not running then- Console.putStrLn "Stopped."- else- showStatus opts+ 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+ 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)+ 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)
src/Tricorder/CLI/Arguments.hs view
@@ -10,7 +10,8 @@ , WaitMode (..) , parseArguments , runArguments- ) where+ )+where import Atelier.Effects.Arguments (Arguments, execParser) import Effectful.Reader.Static (Reader, runReader)@@ -37,77 +38,23 @@ , progDesc , short )--import Data.Text qualified as T--import Tricorder.Module (ModuleName (..))-import Tricorder.Socket.Protocol (Force (..))-import Tricorder.SourceLookup (SourceQuery (..))+import Tricorder.CLI.Command+ ( Command (..)+ , EvalCommentsOptions (..)+ , FollowMode (..)+ , Force (..)+ , LogMode (..)+ , OutputFormat (..)+ , StatusOptions (..)+ , TestOptions (..)+ , Verbosity (..)+ , WaitMode (..)+ )+import Tricorder.SourceLookup.SourceQuery (SourceQuery, parseSourceQuery) 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@@ -135,13 +82,19 @@ 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+ "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+ "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"))+ <> command+ "eval-comments"+ (info evalCommentsParser (progDesc "Show eval comments from the latest build")) ) @@ -206,7 +159,8 @@ sourceParser :: Parser Command sourceParser =- Source <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function"))+ Source+ <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function")) stopParser :: Parser Command@@ -253,11 +207,4 @@ 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)- }+queryReader = eitherReader $ Right . parseSourceQuery . toText
src/Tricorder/CLI/Daemon.hs view
@@ -3,7 +3,8 @@ , stopDaemon , restartDaemon , waitForDaemon- ) where+ )+where import Atelier.Effects.Delay (Delay) import Atelier.Effects.File (File)@@ -70,11 +71,12 @@ 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+ if didStop+ then+ pure "Daemon stopped."+ else do+ tell ["Daemon did not stop as requested."]+ emptyEff sendKill pidFile = do timeout1second (Daemons.forceKillAndWait pidFile) >>= \case@@ -88,11 +90,12 @@ 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 ()+ if running+ then do+ Delay.wait (500 :: Millisecond)+ rec+ else+ pure () -- | Restart the daemon: stop it (if running) and then start a fresh instance.@@ -141,8 +144,9 @@ 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)+ if ready+ then+ pure True+ else do+ Delay.wait (200 :: Millisecond)+ go sockPath (n - 1)
src/Tricorder/CLI/Operations.hs view
@@ -4,7 +4,8 @@ , showStatus , showTests , showEvalComments- ) where+ )+where import Atelier.Effects.Clock (Clock, currentTimeZone) import Atelier.Effects.Console (Console)@@ -16,6 +17,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime (utcToLocalTime) import Effectful.Reader.Static (Reader, ask)+import Tricorder.SourceLookup.SourceQuery (SourceQuery) import Atelier.Effects.Console qualified as Console import Data.ByteString.Lazy qualified as BSL@@ -23,6 +25,7 @@ import Data.Text qualified as T import Tricorder.Build (BuildState (..), Severity (..))+import Tricorder.Build.Duration (Duration (..)) import Tricorder.Build.Test (Suites (..)) import Tricorder.CLI.Arguments ( EvalCommentsOptions (..)@@ -42,7 +45,6 @@ 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@@ -145,25 +147,28 @@ 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+ stats =+ toText $ "(" <> show r.moduleCount <> " modules, " <> formatDuration r.duration.getDuration <> ")"+ 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+completionSummary c = statusText <> maybe "" (\d -> " (" <> formatDuration d.getDuration <> ")") 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"+ in if failedCount == 0+ then+ "passed (" <> show total <> ")"+ else+ show failedCount <> "/" <> show total <> " failed" isFailedCase (Test.Case _ (Test.Failed _)) = True isFailedCase _ = False @@ -176,11 +181,12 @@ => 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+ 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@@ -213,10 +219,11 @@ when (any Test.isFailedRun filteredSuites) exitFailure where filteredSuites =- if opts.failedOnly then- Map.filter Test.isFailedRun suites- else- suites+ if opts.failedOnly+ then+ Map.filter Test.isFailedRun suites+ else+ suites printTestOutput tgt tr = case tr of Test.SuiteRunning Nothing ->@@ -227,14 +234,16 @@ 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))+ 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_ printFailedCase (filter Test.caseFailed c.testCases)- else- mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (lines c.output))+ mapM_ (Console.putTextLn . (" " <>)) (stripGhciNoise (lines c.output)) where t = renderTestTarget tgt <> " "
src/Tricorder/CLI/Render.hs view
@@ -5,25 +5,28 @@ , diagnosticBlock , formatDuration , renderSourceResults- ) where+ )+where import Atelier.Effects.Console (Console) import Atelier.Time (Millisecond, toMicroseconds)+import Tricorder.SourceLookup.SourceQuery (ModuleName (..), SourceQuery (..)) import Atelier.Effects.Console qualified as Console import Tricorder.Build (Diagnostic (..), Severity (..))-import Tricorder.Module (ModuleName (..), PackageId (..))-import Tricorder.SourceLookup (ModuleSourceResult (..), SourceQuery (..))+import Tricorder.SourceLookup (ModuleSourceResult (..))+import Tricorder.SourceLookup.PackageId (PackageId (..)) 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"+ in if ms < 1000+ then+ show ms <> "ms"+ else+ show (ms `div` 1000) <> "." <> show ((ms `mod` 1000) `div` 100) <> "s" -- | Single-line diagnostic for plain-text / shell output.
src/Tricorder/CLI/UI.hs view
@@ -1,6 +1,7 @@ module Tricorder.CLI.UI ( viewUi- ) where+ )+where import Atelier.Effects.Clock (Clock) import Atelier.Effects.Conc (Conc)
src/Tricorder/CLI/UI/Brick.hs view
@@ -3,7 +3,8 @@ Brick , runBrickApp , runBrick- ) where+ )+where import Brick.Main (App, customMain) import Effectful (Effect, IOE)
src/Tricorder/CLI/UI/BrickChan.hs view
@@ -5,7 +5,8 @@ , writeBChan , readBChan , runBrickChan- ) where+ )+where import Brick.BChan (BChan) import Effectful (Effect, IOE)
src/Tricorder/CLI/UI/Event.hs view
@@ -1,7 +1,8 @@ module Tricorder.CLI.UI.Event ( Event (..) , handleEvent- ) where+ )+where import Brick (BrickEvent (..), EventM, vScrollBy, viewportScroll) import Brick.Keybindings (KeyDispatcher, handleKey)@@ -20,7 +21,10 @@ | FailedBuild Text -handleEvent :: KeyDispatcher KeyEvent (EventM Viewports State) -> BrickEvent Viewports Event -> EventM Viewports State ()+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)
src/Tricorder/CLI/UI/Keys.hs view
@@ -6,7 +6,8 @@ , viewKeybindings , mkKeyConfig , keybindForRoute- ) where+ )+where import Atelier.Effects.Console (Console) import Brick@@ -182,30 +183,34 @@ 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+ 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+ 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}+ 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+ 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}
src/Tricorder/CLI/UI/Misc.hs view
@@ -6,7 +6,8 @@ , subtle , hBoxSpaced , vBoxSpaced- ) where+ )+where import Brick ( Padding (..)
src/Tricorder/CLI/UI/Route.hs view
@@ -1,7 +1,8 @@ module Tricorder.CLI.UI.Route ( Route (..) , name- ) where+ )+where data Route
src/Tricorder/CLI/UI/State.hs view
@@ -8,7 +8,8 @@ , viewToViewport , cycleTestFilter , navigate- ) where+ )+where import Atelier.Effects.Clock (Clock, TimeZone) import Prelude hiding (init)
src/Tricorder/CLI/UI/View.hs view
@@ -1,7 +1,6 @@ module Tricorder.CLI.UI.View (mkAttrMap, view) where import Atelier.Effects.Clock (TimeZone)-import Atelier.Time (Millisecond, toMicroseconds) import Brick ( AttrMap , AttrName@@ -35,10 +34,17 @@ import Graphics.Vty.Attributes.Color qualified as Color import Tricorder.Build (BuildPhase, BuildResult, BuildState, Diagnostic, Severity (..))+import Tricorder.Build.Duration (Duration (..)) 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.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)@@ -247,10 +253,11 @@ hBoxSpaced 1 [ emphasis $ txt "Targets:"- , if null targets then- txt "(all)"- else- vBox $ (map (txt . renderTarget) targets)+ , if null targets+ then+ txt "(all)"+ else+ vBox $ (map (txt . renderTarget) targets) ] @@ -346,10 +353,11 @@ 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)"+ 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@@ -384,7 +392,7 @@ severityToAttrName SWarning = attrName "warning" -viewDuration :: Millisecond -> Widget n+viewDuration :: Duration -> Widget n viewDuration d = txt $ "(" <> formatDuration d <> ")" @@ -422,28 +430,30 @@ | 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"+ 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 :: Int -> Duration -> 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"+formatDuration :: Duration -> Text+formatDuration (Duration d) =+ let ms = toInteger d+ 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@@ -475,10 +485,11 @@ 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)"+ 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]
src/Tricorder/Config.hs view
@@ -3,7 +3,8 @@ , runLoadedConfig , inputLoadedConfig , configFileName- ) where+ )+where import Atelier.Config (LoadedConfig (..)) import Atelier.Effects.FileSystem (FileSystem)@@ -24,13 +25,14 @@ loadTricorderConfig :: (FileSystem :> es) => FilePath -> Eff es LoadedConfig loadTricorderConfig projectRoot = do exists <- FileSystem.doesFileExist yamlPath- if not exists then- pure $ LoadedConfig (Aeson.Object KM.empty)- else do- bs <- FileSystem.readFileBs yamlPath- pure . LoadedConfig $ case Yaml.decodeEither' @Aeson.Value bs of- Left _ -> Aeson.Object KM.empty- Right v -> v+ if not exists+ then+ pure $ LoadedConfig (Aeson.Object KM.empty)+ else do+ bs <- FileSystem.readFileBs yamlPath+ pure . LoadedConfig $ case Yaml.decodeEither' @Aeson.Value bs of+ Left _ -> Aeson.Object KM.empty+ Right v -> v where yamlPath = projectRoot </> configFileName
src/Tricorder/Daemon/Builder.hs view
@@ -7,13 +7,14 @@ , consider , with , compileBuildResults- ) where+ )+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 Atelier.Time (nominalDiffTime) import Data.Time (diffUTCTime) import Effectful (Effect, inject) import Effectful.Dispatch.Dynamic (reinterpretWith_)@@ -31,6 +32,7 @@ import Effectful.State.Static.Shared qualified as State import Tricorder.Build (BuildId (..), BuildProgress, BuildResult (..), Diagnostic (..))+import Tricorder.Build.Duration (Duration (..)) import Tricorder.Daemon.Dispatch ( BuilderState (..) , DiagnosticMap@@ -178,7 +180,7 @@ buildResult = BuildResult { completedAt = endTime- , duration = nominalDiffTime (diffUTCTime endTime startTime) :: Millisecond+ , duration = Duration $ nominalDiffTime (diffUTCTime endTime startTime) , moduleCount = loadResult.moduleCount , diagnostics = sortOn (\d -> (d.severity, d.file, d.line, d.col)) $ concat $ Map.elems merged }
src/Tricorder/Daemon/Core.hs view
@@ -9,6 +9,7 @@ import Atelier.Effects.FileWatcher (FileEvent, FileWatcher) import Atelier.Effects.Input (Input) import Atelier.Effects.Log (Log)+import Atelier.Effects.Process (Process) import Atelier.Effects.Publishing (runPubSub) import Atelier.Effects.Publishing.Pub (Pub) import Atelier.Effects.Publishing.Sub (Sub)@@ -19,6 +20,7 @@ import Effectful.State.Static.Shared (State) import Relude.Extra.Tuple (dup) import System.FilePath ((</>))+import Text.Regex.TDFA.Pattern (showPattern) import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.FileSystem qualified as FileSystem@@ -27,10 +29,12 @@ import Atelier.Effects.Publishing.Pub qualified as Pub import Atelier.Effects.Publishing.Sub qualified as Sub import Data.Map.Strict qualified as Map+import Data.Text qualified as T 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.ByteSize (ByteSize) import Tricorder.Build.Changes (CabalChangeDetected (..), SourceChangeDetected (..)) import Tricorder.Daemon.Builder ( BuildConsideration (..)@@ -60,10 +64,14 @@ import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session (Session (..), loadSession) import Tricorder.Session.CabalFile (CabalFile)-import Tricorder.Session.Command (Command (..))+import Tricorder.Session.Command (Command (..), Repl) import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..))+import Tricorder.Session.IdleTimeout (IdleTimeout)+import Tricorder.Session.ReplBuildDir (ReplBuildDir (..)) import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)-import Tricorder.Session.TestTimeout (TestTimeout)+import Tricorder.Session.TestTimeout (TestTimeout (..))+import Tricorder.Session.WatchDirs (WatchDirs (..))+import Tricorder.Session.WatchExclusionPatterns (WatchExclusionPatterns (..)) import Tricorder.Waiters (Waiters) import Tricorder.Build qualified as Build@@ -75,11 +83,19 @@ import Tricorder.Daemon.Hpack qualified as Hpack import Tricorder.Daemon.TestRunner qualified as TestRunner import Tricorder.Daemon.Watch qualified as Watch+import Tricorder.Session.Command qualified as Command+import Tricorder.Session.Hooks qualified as Hooks+import Tricorder.Session.Target qualified as Target+import Tricorder.Session.TestTarget qualified as TestTarget import Tricorder.Waiters qualified as Waiters data ReloadSession = ReloadSession++ data RestartBuilder = RestartBuilder++ data ReloadBuilder = ReloadBuilder FilePath FileEvent @@ -99,9 +115,12 @@ , Input LoadedConfig :> es , Input [CabalFile] :> es , Log :> es+ , Process :> es , Pub BuildPhase :> es , Reader ProjectRoot :> es , State BuildId :> es+ , State IdleTimeout :> es+ , State Repl :> es , TestRunner :> es , Waiters :> es )@@ -115,6 +134,10 @@ $ Conc.restartableFork waitForReloadSession do root <- Reader.ask session <- loadSession+ logSession session++ State.put session.command.repl+ State.put session.idleTimeout Conc.fork_ $ watchConfigFile root conditionallyWatchStackYaml root @@ -123,10 +146,11 @@ Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) -> do needsSessionReload <- shouldReloadSession session- if needsSessionReload then- Pub.publish ReloadSession- else- Pub.publish RestartBuilder+ if needsSessionReload+ then+ Pub.publish ReloadSession+ else+ Pub.publish RestartBuilder Conc.fork_ $ Sub.listen_ \(SourceChangeDetected fp event) -> Pub.publish $ ReloadBuilder fp event@@ -189,6 +213,7 @@ , EvalCommentRunner :> es , GhciSession :> es , Log :> es+ , Process :> es , Pub BuildPhase :> es , Reader ProjectRoot :> es , State BuildId :> es@@ -213,6 +238,7 @@ , EvalCommentRunner :> es , GhciSession :> es , Log.Log :> es+ , Process :> es , Pub BuildPhase :> es , Reader ProjectRoot :> es , State BuilderState :> es@@ -224,9 +250,11 @@ runSession buildId session = do Log.info $ "Starting session " <> show buildId.getBuildId Pub.publish Build.Starting+ whenJust (session.hooks.start >>= (.before)) Hooks.runHook startupError <- fmap (either id absurd) $ Pub.map (Build.Building session.testTargets) $ Builder.with buildId session.command session.watchDirs \_ initialLoad -> do+ whenJust (session.hooks.start >>= (.after)) Hooks.runHook processPostBuild session $ Right initialLoad Log.debug "Waiting for reload" newestReloadEvent <- atomically newEmptyTMVar@@ -254,6 +282,7 @@ , Conc :> es , EvalCommentRunner :> es , Log :> es+ , Process :> es , Pub BuildPhase :> es , Reader ProjectRoot :> es , State BuilderState :> es@@ -279,6 +308,7 @@ , Conc :> es , EvalCommentRunner :> es , Log :> es+ , Process :> es , Pub BuildPhase :> es , Reader ProjectRoot :> es , State BuilderState :> es@@ -288,7 +318,9 @@ -> DispatchAction -> Eff es () processSource session action = do+ whenJust (session.hooks.reload >>= (.before)) Hooks.runHook res <- Builder.build action+ whenJust (session.hooks.reload >>= (.after)) Hooks.runHook Log.debug "Finished build" processPostBuild session res @@ -343,7 +375,8 @@ => Session -> LoadResult -> Eff es Eval.Phase runEvalComments session loadResult = do builderState <- State.get @BuilderState- evalComments <- findEvalCommentsInModules $ resolveKnownTargets builderState.loadedModules loadResult+ evalComments <-+ findEvalCommentsInModules $ resolveKnownTargets builderState.loadedModules loadResult case nonEmpty evalComments of Nothing -> pure Eval.NoneFound@@ -370,7 +403,11 @@ => Session -> BuildResult -> Eff es Test.Suites runTests session buildResult | hasTargets session.testTargets && noErrors buildResult.diagnostics =- runTestsForTargets session.command session.testTimeout session.testTargets+ runTestsForTargets+ session.command+ session.testMemoryLimit+ session.testTimeout+ session.testTargets | otherwise = pure mempty where hasTargets = not . null@@ -383,10 +420,11 @@ , TestRunner :> es ) => Command+ -> Maybe ByteSize -> TestTimeout -> [TestTarget] -> Eff es Test.Suites-runTestsForTargets command testTimeout testTargets = do+runTestsForTargets command memoryLimit 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@@ -400,6 +438,7 @@ updated <- State.state $ dup . Map.insert target suite Pub.publish $ Test.Suites updated )+ memoryLimit command.repl testTimeout target@@ -420,3 +459,28 @@ s.diagnosticMap newLoadResult in (buildResult, s {diagnosticMap = newDiagnosticMap})+++logSession :: (Log :> es) => Session -> Eff es ()+logSession session =+ Log.info+ $ T.intercalate+ "\n"+ [ "Loaded session"+ , "Command: " <> Command.render session.command+ , "Targets:"+ , showList Target.renderTarget session.targets+ , "Test targets:"+ , showList TestTarget.renderTestTarget session.testTargets+ , "Watch dirs:"+ , showList toText session.watchDirs.getWatchDirs+ , "Watch exclusion patterns:"+ , showList (toText . showPattern . fst) session.watchExclusionPatterns.getWatchExclusionPatterns+ , "Repl build dir: " <> toText session.replBuildDir.getReplBuildDir+ , -- TODO: Remove " seconds" when TestTimeout is converted to a proper time unit.+ "Test timeout: " <> show session.testTimeout.getTestTimeout <> " seconds"+ , "Test memory limit: " <> show session.testMemoryLimit+ , "Generate with hpack: " <> show session.generateWithHpack.getGenerateWithHpack+ ]+ where+ showList f = T.intercalate "\n" . fmap (("- " <>) . f)
src/Tricorder/Daemon/DaemonInfo.hs view
@@ -2,7 +2,8 @@ ( DaemonInfo (..) , load , runInput- ) where+ )+where import Atelier.Effects.Input (Input, input, runInputEff) import Data.Aeson (FromJSON (..), ToJSON (..))
src/Tricorder/Daemon/Dispatch.hs view
@@ -9,7 +9,8 @@ , filterToWatchDirs , mergeDiagnostics , preserveFailureVisibility- ) where+ )+where import Atelier.Effects.FileWatcher (FileEvent (..)) import System.FilePath (isAbsolute, normalise, splitDirectories, takeExtension, (</>))
src/Tricorder/Daemon/EvalCommentRunner.hs view
@@ -6,7 +6,8 @@ -- * Interpreters , run- ) where+ )+where import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (File)
src/Tricorder/Daemon/GhciSession.hs view
@@ -13,7 +13,8 @@ -- * Interpreters , runGhciSession , runGhciSessionScripted- ) where+ )+where import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (File)@@ -49,7 +50,14 @@ , LoadResult (..) , LoadedModule (..) )-import Tricorder.Daemon.GhciSession.GhciProcess (addGhci, collectGhciResult, interruptGhci, reloadGhci, unaddGhci, withGhciProcess)+import Tricorder.Daemon.GhciSession.GhciProcess+ ( addGhci+ , collectGhciResult+ , interruptGhci+ , reloadGhci+ , unaddGhci+ , withGhciProcess+ ) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.Command (Command) @@ -104,7 +112,8 @@ -- 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+ :: 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
src/Tricorder/Daemon/GhciSession/GhciParser.hs view
@@ -22,7 +22,8 @@ , toAbsolute , toRelative , unattributedFailure- ) where+ )+where import Data.Char (isAlpha, isDigit, isSpace, toLower) import System.FilePath (dropExtension, isAbsolute, makeRelative, normalise, splitDirectories, (</>))@@ -216,12 +217,13 @@ 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+ 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)@@ -338,11 +340,12 @@ 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+ 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.@@ -515,10 +518,11 @@ 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+ 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@@ -534,7 +538,8 @@ , 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"+ , text =+ "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n" }
src/Tricorder/Daemon/GhciSession/GhciProcess.hs view
@@ -14,7 +14,8 @@ , reloadGhci , addGhci , unaddGhci- ) where+ )+where import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (BufferMode (..), File, Handle)@@ -448,11 +449,12 @@ case result of Left ex -> throwIO ex Right line ->- if isVersionLine line then- pure ()- else do- captureLine line- go+ if isVersionLine line+ then+ pure ()+ else do+ captureLine line+ go drainUntilEof :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()
src/Tricorder/Daemon/Hpack/Effect.hs view
@@ -4,7 +4,8 @@ , hpackIsInPath , hpack , run- ) where+ )+where import Atelier.Effects.Process (Process, readProcess, runProcess, setWorkingDir, shell) import Effectful (Effect)@@ -56,7 +57,8 @@ | "generated with a newer version" `B8.isInfixOf` stdout -> WasGeneratedWithNewerHpack | "was modified manually" `B8.isInfixOf` stdout -> WasEditedManually | otherwise -> UnknownSuccess $ decodeUtf8 stdout- if exitCode == ExitSuccess then- pure $ Right $ infoMsg- else- pure $ Left $ decodeUtf8 stderr+ if exitCode == ExitSuccess+ then+ pure $ Right $ infoMsg+ else+ pure $ Left $ decodeUtf8 stderr
+ src/Tricorder/Daemon/IdleTimer.hs view
@@ -0,0 +1,87 @@+module Tricorder.Daemon.IdleTimer+ ( IdleTimer+ , withActivity+ , quitOnTimeout+ )+where++import Atelier.Effects.Clock (Clock, currentTime)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Exit (Exit, exitSuccess)+import Atelier.Effects.Input (Input, input)+import Atelier.Effects.Log (Log)+import Atelier.Time (Second)+import Data.Time (diffUTCTime)+import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..))+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, writeTVar)+import Effectful.Dispatch.Dynamic (interpretWith, localUnlift)+import Effectful.Exception (finally)+import Effectful.TH (makeEffect)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.Delay qualified as Delay+import Atelier.Effects.Log qualified as Log++import Tricorder.Session.IdleTimeout (IdleTimeout (..))+++-- | Performs an interpreter-specific action after a certain amount of time has+-- passed without activity.+data IdleTimer :: Effect where+ WithActivity :: m a -> IdleTimer m a+++makeEffect ''IdleTimer+++-- | Run the idle timer, shutting the process down once+-- @idle_timeout_seconds@ (read from 'Session', re-read on every check so+-- config reloads apply live) elapses with no open connections. A timeout of+-- zero or less disables shutdown.+quitOnTimeout+ :: ( Clock :> es+ , Conc :> es+ , Concurrent :> es+ , Delay :> es+ , Exit :> es+ , Input IdleTimeout :> es+ , Log :> es+ )+ => Eff (IdleTimer : es) a -> Eff es a+quitOnTimeout act = do+ startedAt <- currentTime+ lastActivity <- newTVarIO startedAt+ activeActions <- newTVarIO (0 :: Int)++ Conc.fork_ $ Log.withNamespace "IdleTimer" $ forever do+ Delay.wait (2 :: Second)+ idleTimeout <- input+ case idleTimeout of+ IdleTimeout secs | secs <= 0 -> pure ()+ IdleTimeout secs -> do+ now <- currentTime+ shouldExit <- atomically do+ connections <- readTVar activeActions+ idleSince <- readTVar lastActivity+ pure $ connections <= 0 && diffUTCTime now idleSince >= fromIntegral secs+ when shouldExit do+ Log.info+ $ "Idle for "+ <> show secs+ <> " with no active connections, shutting down."+ exitSuccess++ interpretWith act \env -> \case+ WithActivity action -> do+ start <- currentTime+ atomically do+ modifyTVar' activeActions (+ 1)+ writeTVar lastActivity start+ localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do+ unlift action `finally` do+ end <- currentTime+ atomically do+ modifyTVar' activeActions (max 0 . subtract 1)+ writeTVar lastActivity end
src/Tricorder/Daemon/Main.hs view
@@ -19,6 +19,7 @@ import Effectful.Concurrent (runConcurrent) import Effectful.Reader.Static (runReader) import Effectful.State.Static.Shared (evalState)+import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery) import Atelier.Effects.Cache.Config qualified as CacheConfig import Atelier.Effects.Conc qualified as Conc@@ -29,19 +30,21 @@ 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.Session.IdleTimeout (IdleTimeout) import Tricorder.Socket.UnixSocket (runUnixSocketIO)-import Tricorder.SourceLookup (SourceQuery) import Tricorder.SourceLookup.GhcPkg (runGhcPkgIO)+import Tricorder.SourceLookup.PackageId (PackageId) import Tricorder.Daemon.Core qualified as Core import Tricorder.Daemon.DaemonInfo qualified as DaemonInfo import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner import Tricorder.Daemon.Hpack.Effect qualified as Hpack+import Tricorder.Daemon.IdleTimer qualified as IdleTimer import Tricorder.Daemon.TestRunner qualified as TestRunner+import Tricorder.Session.Command qualified as Repl import Tricorder.Socket.Server qualified as Server import Tricorder.SourceLookup qualified as SourceLookup import Tricorder.SourceLookup.Hackage qualified as Hackage@@ -85,6 +88,11 @@ . runGhciSession . evalState (BuildId 1) . Input.fromState @BuildId+ . evalState Repl.Unknown+ . Input.fromState @Repl.Repl+ . evalState @IdleTimeout def+ . Input.fromState @IdleTimeout+ . IdleTimer.quitOnTimeout . runPubSub @BuildPhase . Hpack.run . Hackage.run
src/Tricorder/Daemon/TestRunner.hs view
@@ -13,7 +13,8 @@ -- * Internal helpers (exported for testing) , loadingToProgress- ) where+ )+where import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (File)@@ -35,17 +36,19 @@ import Data.List qualified as List import Data.Text qualified as T +import Tricorder.Build.ByteSize (ByteSize) import Tricorder.Daemon.GhciSession.GhciParser (GhciLoading (..)) import Tricorder.Daemon.GhciSession.GhciProcess ( execGhci , withGhciProcess ) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..), Repl)+import Tricorder.Session.Command (Command (..), Repl (..)) import Tricorder.Session.TestTarget (TestTarget, getTestTarget, renderTestTarget) import Tricorder.Session.TestTimeout (TestTimeout (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) +import Tricorder.Build.ByteSize qualified as ByteSize import Tricorder.Build.Test qualified as Test @@ -55,6 +58,8 @@ RunTestSuite :: (Test.Suite -> m ()) -- ^ Handler for test run progress+ -> Maybe ByteSize+ -- ^ Memory limit for test suite -> Repl -> TestTimeout -> TestTarget@@ -79,20 +84,51 @@ => Eff (TestRunner : es) a -> Eff es a run act = do interpretWith act \env -> \case- RunTestSuite progressHandler repl testTimeout target ->+ RunTestSuite progressHandler mMemoryLimit repl testTimeout target -> localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do let onProgress = unlift . progressHandler . loadingToProgress noProgress _ = pure () noReady _ = pure ()+ memoryLimitArg =+ maybe+ []+ ( \limit ->+ let+ stack =+ [ "--ghc-options"+ , "+RTS -M"+ <> ByteSize.toRTSSize limit+ <> " -RTS"+ ]+ cabal =+ [ "--repl-options"+ , "+RTS -M"+ <> ByteSize.toRTSSize limit+ <> " -RTS"+ ]+ in+ case repl of+ Stack -> stack+ StackMulti -> stack+ Cabal -> cabal+ Unknown -> cabal+ )+ mMemoryLimit ProjectRoot projectRoot <- ask result <- trySync- $ withGhciProcess def (Command repl [] [getTestTarget 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)+ $ withGhciProcess+ def+ (Command repl memoryLimitArg [getTestTarget 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@@ -141,7 +177,7 @@ runScripted results = reinterpret_ (evalState results)- (\(RunTestSuite _ _ _ _) -> popResult)+ (\(RunTestSuite _ _ _ _ _) -> popResult) where popResult :: Eff (State [Either SomeException Test.Suite] : es) Test.Suite popResult =@@ -186,13 +222,15 @@ Nothing -> GhciPassed Just rest -> let r = T.strip rest- in if r == "ExitSuccess" then- GhciPassed- else- if "ExitFailure" `T.isPrefixOf` r then- GhciFailed+ in if r == "ExitSuccess"+ then+ GhciPassed else- GhciCrashed r+ 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
src/Tricorder/Daemon/Watch.hs view
@@ -4,7 +4,8 @@ , publishChange , specs , isCabalFile- ) where+ )+where import Atelier.Effects.Debounce (Debounce) import Atelier.Effects.FileWatcher
− src/Tricorder/Module.hs
@@ -1,29 +0,0 @@-module Tricorder.Module- ( ModuleName (..)- , PackageId (..)- , splitPackageId- ) where--import Data.Aeson (FromJSON, ToJSON)--import Data.Text qualified as T----- | 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)----- | 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/Runtime.hs view
@@ -10,7 +10,8 @@ , runSocketPath , LogPath (..) , runLogPath- ) where+ )+where import Atelier.Effects.FileSystem ( FileSystem
src/Tricorder/Session.hs view
@@ -2,7 +2,8 @@ ( Session (..) , loadSession , inputSession- ) where+ )+where import Atelier.Config (LoadedConfig, extractConfig) import Atelier.Effects.FileSystem (FileSystem)@@ -14,28 +15,39 @@ import Atelier.Effects.Log qualified as Log import Data.Text qualified as T +import Tricorder.Build.ByteSize (ByteSize) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.CabalFile (CabalFile) import Tricorder.Session.Command (Command (..), resolveCommand) import Tricorder.Session.Config (Config (..)) import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..))+import Tricorder.Session.Hooks (Hooks)+import Tricorder.Session.IdleTimeout (IdleTimeout (..)) 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)+import Tricorder.Session.WatchExclusionPatterns+ ( WatchExclusionPatterns (..)+ , resolveWatchExclusionPatterns+ ) +import Tricorder.Build.ByteSize qualified as ByteSize + data Session = Session { command :: Command , targets :: [Target] , testTargets :: [TestTarget]+ , testMemoryLimit :: Maybe ByteSize , watchDirs :: WatchDirs , watchExclusionPatterns :: WatchExclusionPatterns , replBuildDir :: ReplBuildDir , testTimeout :: TestTimeout , generateWithHpack :: GenerateWithHpack+ , hooks :: Hooks+ , idleTimeout :: IdleTimeout } deriving stock (Eq) @@ -46,11 +58,14 @@ { command = def , targets = [] , testTargets = []+ , testMemoryLimit = Nothing , watchDirs = def , watchExclusionPatterns = def , replBuildDir = def , testTimeout = def , generateWithHpack = def+ , hooks = def+ , idleTimeout = def } @@ -71,7 +86,17 @@ effectiveTargets = resolveTargets projectFiles cfgFile.targets testTargets = resolveTestTargets cfgFile effectiveTargets watchDirs = resolveWatchDirs projectRoot projectFiles cfgFile effectiveTargets+ hooks = fromMaybe def cfgFile.hooks + testMemoryLimit <- case cfgFile.testMemoryLimit of+ Nothing -> pure Nothing+ Just limit -> case ByteSize.fromText limit of+ Nothing -> do+ Log.err $ "Unable to parse test_memory_limit: " <> limit+ pure Nothing+ Just parsedLimit ->+ pure $ Just parsedLimit+ watchExclusionPatterns <- case resolveWatchExclusionPatterns cfgFile.watchExclusionPatterns of Left err -> do@@ -101,10 +126,13 @@ , command , watchDirs , watchExclusionPatterns+ , testMemoryLimit , testTargets , replBuildDir = ReplBuildDir cfgFile.replBuildDir , testTimeout = TestTimeout cfgFile.testTimeout , generateWithHpack = GenerateWithHpack cfgFile.generateWithHpack+ , hooks+ , idleTimeout = IdleTimeout $ fromIntegral cfgFile.idleTimeoutSeconds }
src/Tricorder/Session/CabalFile.hs view
@@ -2,7 +2,8 @@ ( CabalFile (..) , inputCabalFiles , discoverCabalFiles- ) where+ )+where import Atelier.Effects.Env (Env) import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs)@@ -108,7 +109,13 @@ 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)+ fromField = \case+ (Field (Name _ name) fieldLines)+ | name == "packages" -> concatMap fromLine fieldLines+ | otherwise -> []+ _ -> []+ fromLine (FieldLine _ bs) =+ fmap BC.unpack $ filter (not . BC.null) $ BC.words $ BC.map dropComma bs++ dropComma ',' = ' '+ dropComma c = c
src/Tricorder/Session/Command.hs view
@@ -3,7 +3,8 @@ , Repl (..) , render , resolveCommand- ) where+ )+where import Atelier.Effects.FileSystem (FileSystem) import Data.Default (Default (..))@@ -59,7 +60,8 @@ -- 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+ :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> [TestTarget] -> Eff es Command resolveCommand projectRoot@(ProjectRoot root) cfg targets testTargets = case cfg.command of Just cmd -> case words cmd of@@ -73,14 +75,16 @@ detectStackKind args = do hasCabalFileInRoot <- any (".cabal" `List.isSuffixOf`) <$> FileSystem.listDirectory root let repl =- if hasCabalFileInRoot then- Stack- else- StackMulti+ if hasCabalFileInRoot+ then+ Stack+ else+ StackMulti pure $ Command repl args [] -detectCommand :: (FileSystem :> es) => [Target] -> [TestTarget] -> FilePath -> ProjectRoot -> Eff es Command+detectCommand+ :: (FileSystem :> es) => [Target] -> [TestTarget] -> FilePath -> ProjectRoot -> Eff es Command detectCommand targets testTargets replBuildDir projectRoot = do cmd <- fmap (fromMaybe (fallback replBuildDir) . rightToMaybe)@@ -90,35 +94,38 @@ pure $ cmd { targets =- if not (null targets) then- targets- else- Bare "all" : (getTestTarget <$> testTargets)+ if not (null targets)+ then+ targets+ else+ Bare "all" : (getTestTarget <$> testTargets) } useStack :: (FileSystem :> es, NonDet :> es) => ProjectRoot -> Eff es Command useStack (ProjectRoot projectRoot) = do hasStack <- FileSystem.doesFileExist $ projectRoot </> "stack.yaml"- if hasStack then- pure $ Command Stack [] []- else- emptyEff+ if hasStack+ then+ pure $ Command Stack [] []+ else+ emptyEff useMultiCabal :: (FileSystem :> es, NonDet :> es) => ProjectRoot -> FilePath -> Eff es Command useMultiCabal (ProjectRoot projectRoot) replBuildDir = do hasCabalProject <- FileSystem.doesFileExist $ projectRoot </> "cabal.project" hasCabalFiles <- any (".cabal" `List.isSuffixOf`) <$> FileSystem.listDirectory projectRoot- if hasCabalFiles || hasCabalProject then- pure- $ Command- { repl = Cabal- , arguments = ["--enable-multi-repl"] <> buildDirFlag replBuildDir- , targets = []- }- else- emptyEff+ if hasCabalFiles || hasCabalProject+ then+ pure+ $ Command+ { repl = Cabal+ , arguments = ["--enable-multi-repl"] <> buildDirFlag replBuildDir+ , targets = []+ }+ else+ emptyEff fallback :: FilePath -> Command
src/Tricorder/Session/Config.hs view
@@ -5,7 +5,9 @@ import Data.Aeson (FromJSON (..)) import Data.Default (Default (..)) +import Tricorder.Session.Hooks (Hooks) + data Config = Config { command :: Maybe Text , targets :: [Text]@@ -15,6 +17,9 @@ , replBuildDir :: FilePath , testTimeout :: Int , generateWithHpack :: Bool+ , testMemoryLimit :: Maybe Text+ , hooks :: Maybe Hooks+ , idleTimeoutSeconds :: Int } deriving stock (Eq, Generic, Show) deriving (FromJSON) via WithDefaults (QuietSnake Config)@@ -31,4 +36,7 @@ , replBuildDir = "dist-newstyle/tricorder" , testTimeout = 10 , generateWithHpack = True+ , testMemoryLimit = Nothing+ , hooks = Nothing+ , idleTimeoutSeconds = 300 }
+ src/Tricorder/Session/Hooks.hs view
@@ -0,0 +1,61 @@+module Tricorder.Session.Hooks+ ( Hooks (..)+ , Hook (..)+ , runHook+ )+where++import Atelier.Effects.Process (Process)+import Atelier.Types.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+import Effectful.Exception (trySync)+import Effectful.Reader.Static (Reader)++import Atelier.Effects.Process qualified as Process+import Effectful.Reader.Static qualified as Reader++import Tricorder.Runtime (ProjectRoot (..))+++data Hooks = Hooks+ { start :: Maybe Hook+ , reload :: Maybe Hook+ }+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via QuietSnake Hooks+++instance Default Hooks where+ def =+ Hooks+ { start = def+ , reload = def+ }+++data Hook = Hook+ { before :: Maybe Text+ , after :: Maybe Text+ }+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via QuietSnake Hook+++instance Default Hook where+ def =+ Hook+ { before = Nothing+ , after = Nothing+ }+++runHook :: (Process :> es, Reader ProjectRoot :> es) => Text -> Eff es ()+runHook hook = do+ ProjectRoot root <- Reader.ask+ void+ $ trySync+ $ Process.runProcess+ $ Process.setWorkingDir root+ $ Process.shell+ $ toString hook
+ src/Tricorder/Session/IdleTimeout.hs view
@@ -0,0 +1,14 @@+module Tricorder.Session.IdleTimeout (IdleTimeout (..)) where++import Atelier.Time (AsRawUnit (..), Second)+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))+++newtype IdleTimeout = IdleTimeout {getIdleTimeout :: Second}+ deriving stock (Eq, Generic, Show)+ deriving (FromJSON, ToJSON) via AsRawUnit Second+++instance Default IdleTimeout where+ def = IdleTimeout 300
src/Tricorder/Session/Target.hs view
@@ -8,7 +8,8 @@ , definesCustomPrelude , compareTargets , allComponentTargets- ) where+ )+where import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) import Distribution.Types.CondTree (condTreeData)@@ -60,6 +61,8 @@ instance ToJSONKey Target++ instance FromJSONKey Target
src/Tricorder/Session/TestTarget.hs view
@@ -4,7 +4,8 @@ , parseTestTargets , resolveTestTargets , projectTestTargets- ) where+ )+where import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey)
src/Tricorder/Session/WatchDirs.hs view
@@ -2,7 +2,8 @@ ( WatchDirs (..) , resolveWatchDirs , sourceDirsForTarget- ) where+ )+where import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Default (Default (..))
src/Tricorder/Session/WatchExclusionPatterns.hs view
@@ -2,7 +2,8 @@ ( WatchExclusionPatterns (..) , Pattern , resolveWatchExclusionPatterns- ) where+ )+where import Data.Default (Default (..)) import Text.Regex.TDFA.ReadRegex (parseRegex)
src/Tricorder/Socket/Client.hs view
@@ -8,7 +8,8 @@ , requestShutdown , isDaemonRunning , isDaemonReady- ) where+ )+where import Atelier.Effects.Delay (Delay) import Atelier.Effects.File (File, Handle)@@ -20,6 +21,7 @@ import Effectful.Reader.Static (Reader, ask) import Effectful.State.Static.Shared (evalState, get, modify, put) import System.IO.Error (isEOFError)+import Tricorder.SourceLookup.SourceQuery (SourceQuery) import Prelude hiding (force) import Atelier.Effects.Delay qualified as Delay@@ -38,7 +40,7 @@ , Waiters (..) ) import Tricorder.Socket.UnixSocket (UnixSocket, withConnection)-import Tricorder.SourceLookup (ModuleSourceResult, SourceQuery)+import Tricorder.SourceLookup (ModuleSourceResult) import Tricorder.Version qualified as Version @@ -144,10 +146,11 @@ 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"+ 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
src/Tricorder/Socket/Protocol.hs view
@@ -6,14 +6,12 @@ , ErrorResponse (..) , ClientMessage (..) , Waiters (..)- ) where+ )+where import Data.Aeson (FromJSON, ToJSON)--import Tricorder.SourceLookup (SourceQuery)---data Force = Force | NoForce+import Tricorder.CLI.Command (Force (..))+import Tricorder.SourceLookup.SourceQuery (SourceQuery) data StatusQuery = StatusQuery {awaitDone :: Bool}
src/Tricorder/Socket/Server.hs view
@@ -12,6 +12,7 @@ import Effectful.Reader.Static (Reader, ask) import Effectful.State.Static.Shared (State) import System.IO (Handle)+import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery) import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Log qualified as Log@@ -21,8 +22,9 @@ import Tricorder.Build (BuildId, BuildPhase, BuildState (..), Diagnostic) import Tricorder.Daemon.DaemonInfo (DaemonInfo)-import Tricorder.Module (ModuleName, PackageId)+import Tricorder.Daemon.IdleTimer (IdleTimer) import Tricorder.Runtime (SocketPath (..))+import Tricorder.Session.Command (Repl) import Tricorder.Socket.Protocol ( ClientMessage (..) , DiagnosticQuery (..)@@ -39,9 +41,10 @@ , removeSocketFile , sendLine )-import Tricorder.SourceLookup (ModuleSourceResult, SourceQuery (..), lookupModuleSource)+import Tricorder.SourceLookup (ModuleSourceResult, lookupModuleSource) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage)+import Tricorder.SourceLookup.PackageId (PackageId) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.Version (VersionMismatch (..), checkVersion) import Tricorder.Waiters (Waiters)@@ -49,6 +52,7 @@ import Tricorder.Build qualified as Build import Tricorder.Build.EvalComment qualified as Eval import Tricorder.Build.Test qualified as Test+import Tricorder.Daemon.IdleTimer qualified as IdleTimer import Tricorder.Socket.Protocol qualified as Protocol import Tricorder.Waiters qualified as Waiters @@ -65,8 +69,10 @@ , FileSystem :> es , GhcPkg :> es , Hackage :> es+ , IdleTimer :> es , Input BuildId :> es , Input DaemonInfo :> es+ , Input Repl :> es , Log :> es , PackageStore :> es , Reader SocketPath :> es@@ -91,8 +97,10 @@ , FileSystem :> es , GhcPkg :> es , Hackage :> es+ , IdleTimer :> es , Input BuildId :> es , Input DaemonInfo :> es+ , Input Repl :> es , Log :> es , PackageStore :> es , Reader SocketPath :> es@@ -119,8 +127,10 @@ , FileSystem :> es , GhcPkg :> es , Hackage :> es+ , IdleTimer :> es , Input BuildId :> es , Input DaemonInfo :> es+ , Input Repl :> es , Log :> es , PackageStore :> es , State BuildPhase :> es@@ -130,7 +140,7 @@ ) => Handle -> Eff es ()-handleConnection h = do+handleConnection h = IdleTimer.withActivity do line <- readLine h case decode (BSL.fromStrict (encodeUtf8 line)) of Nothing -> sendJson h (ErrorResponse "invalid request")@@ -153,6 +163,7 @@ , Hackage :> es , Input BuildId :> es , Input DaemonInfo :> es+ , Input Repl :> es , Log :> es , PackageStore :> es , State BuildPhase :> es@@ -270,6 +281,7 @@ , FileSystem :> es , GhcPkg :> es , Hackage :> es+ , Input Repl :> es , Log :> es , PackageStore :> es , UnixSocket :> es
src/Tricorder/Socket/UnixSocket.hs view
@@ -14,7 +14,8 @@ , runUnixSocketIO , runUnixSocketScripted , SocketScript (..)- ) where+ )+where import Atelier.Effects.File (BufferMode (..), File, Handle) import Atelier.Exception (trySyncIO)@@ -124,7 +125,8 @@ -- 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+ :: (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
src/Tricorder/SourceLookup.hs view
@@ -1,22 +1,23 @@ module Tricorder.SourceLookup- ( -- * Types- SourceQuery (..)- , ModuleSourceResult (..)-- -- * Lookup+ ( ModuleSourceResult (..) , lookupModuleSource- ) where+ )+where import Atelier.Effects.Cache (Cache, cacheInsert, cacheLookup) import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Input (Input, input) import Atelier.Effects.Log (Log) import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generically (..))+import Tricorder.SourceLookup.SourceQuery (ModuleName (..), SourceQuery (..)) import Atelier.Effects.Log qualified as Log -import Tricorder.Module (ModuleName (..), PackageId (..))+import Tricorder.Session.Command (Repl) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage)+import Tricorder.SourceLookup.PackageId (PackageId (..)) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.SourceLookup.Slice (sliceSymbol) import Tricorder.SourceLookup.Tarball@@ -40,19 +41,7 @@ | -- | 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)+ deriving (FromJSON, ToJSON) via Generically ModuleSourceResult -- ── Lookup logic ───────────────────────────────────────────────────────────@@ -71,6 +60,7 @@ , FileSystem :> es , GhcPkg :> es , Hackage :> es+ , Input Repl :> es , Log :> es , PackageStore :> es )@@ -91,7 +81,11 @@ -- | Resolve a module to its package, consulting the module -> package cache first. resolvePackage- :: (Cache ModuleName PackageId :> es, GhcPkg :> es, Log :> es)+ :: ( Cache ModuleName PackageId :> es+ , GhcPkg :> es+ , Input Repl :> es+ , Log :> es+ ) => ModuleName -> Eff es (Maybe PackageId) resolvePackage modName = do@@ -101,7 +95,8 @@ Log.debug $ "Source: " <> unModuleName modName <> " → " <> unPackageId p <> " (cached)" pure (Just p) Nothing -> do- result <- GhcPkg.findModule modName+ repl <- input+ result <- GhcPkg.findModule repl modName Log.debug $ "Source: find-module " <> unModuleName modName <> " → " <> show result whenJust result (cacheInsert @ModuleName @PackageId modName) pure result
src/Tricorder/SourceLookup/GhcPkg.hs view
@@ -4,21 +4,24 @@ , runGhcPkgIO , runGhcPkgScripted , GhcPkgScript (..)- ) where+ )+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 Tricorder.SourceLookup.SourceQuery (ModuleName (..)) import Data.Text qualified as T -import Tricorder.Module (ModuleName (..), PackageId (..))+import Tricorder.Session.Command (Repl (..))+import Tricorder.SourceLookup.PackageId (PackageId (..)) data GhcPkg :: Effect where- FindModule :: ModuleName -> GhcPkg m (Maybe PackageId)+ FindModule :: Repl -> ModuleName -> GhcPkg m (Maybe PackageId) makeEffect ''GhcPkg@@ -26,8 +29,16 @@ 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)]+ FindModule repl modName -> do+ let cmd = "ghc-pkg"+ args = ["find-module", "--simple-output", toString $ unModuleName modName]+ stack = readProcessSafe "stack" $ ["exec", "--", cmd] <> args+ direct = readProcessSafe cmd args+ out <- case repl of+ Stack -> stack+ StackMulti -> stack+ Cabal -> direct+ Unknown -> direct pure $ out >>= fmap PackageId . listToMaybe . filter (not . T.null) . map T.strip . T.lines @@ -40,7 +51,7 @@ -- | Scripted interpreter for testing. Does not require 'IOE'. runGhcPkgScripted :: [GhcPkgScript] -> Eff (GhcPkg : es) a -> Eff es a runGhcPkgScripted script = reinterpret (evalState script) \_ -> \case- FindModule _ ->+ FindModule _ _ -> get >>= \case NextFindModule result : rest -> put rest >> pure result _ -> error "GhcPkgScripted: expected NextFindModule but queue was empty or mismatched"
src/Tricorder/SourceLookup/Hackage.hs view
@@ -3,7 +3,8 @@ , Result (..) , fetchPackage , run- ) where+ )+where import Atelier.Effects.Log (Log) import Effectful (Effect, IOE)@@ -30,7 +31,7 @@ import Atelier.Effects.Log qualified as Log -import Tricorder.Module (PackageId, unPackageId)+import Tricorder.SourceLookup.PackageId (PackageId (..)) data Hackage :: Effect where@@ -79,7 +80,9 @@ | statusCode == 404 -> pure NotFound | otherwise -> do- pure $ Failure $ show (responseStatusCode response) <> ": " <> decodeUtf8 (responseStatusMessage response)+ pure+ $ Failure+ $ show (responseStatusCode response) <> ": " <> decodeUtf8 (responseStatusMessage response) packageUrl :: PackageId -> Url 'Https
+ src/Tricorder/SourceLookup/PackageId.hs view
@@ -0,0 +1,25 @@+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
@@ -3,7 +3,8 @@ , add , getPath , run- ) where+ )+where import Atelier.Effects.Env (Env, getEnvironment) import Atelier.Effects.FileSystem (FileSystem)@@ -16,7 +17,7 @@ import Atelier.Effects.FileSystem qualified as FileSystem import Data.Map.Strict qualified as Map -import Tricorder.Module (PackageId, splitPackageId, unPackageId)+import Tricorder.SourceLookup.PackageId (PackageId, splitPackageId, unPackageId) data PackageStore :: Effect where@@ -43,10 +44,11 @@ GetPath packageId -> do let path = packagePath packageDir packageId exists <- FileSystem.doesPathExist path- if exists then- pure $ Just path- else- pure Nothing+ if exists+ then+ pure $ Just path+ else+ pure Nothing packagePath :: FilePath -> PackageId -> FilePath@@ -133,7 +135,8 @@ getDir :: (FileSystem :> es, NonDet :> es) => FilePath -> Eff es FilePath getDir fp = do exists <- FileSystem.doesDirectoryExist fp- if exists then- pure fp- else- emptyEff+ if exists+ then+ pure fp+ else+ emptyEff
src/Tricorder/SourceLookup/Slice.hs view
@@ -8,7 +8,8 @@ -- throws. module Tricorder.SourceLookup.Slice ( sliceSymbol- ) where+ )+where import Data.Char (isAlphaNum, isSpace, isUpper) @@ -27,10 +28,11 @@ | 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+ in if isTypeSymbol symbol+ then+ sliceType symbol ls <|> sliceConstructor symbol ls+ else+ sliceValue symbol ls -- | Evaluate whether the symbol references a type-level entity.
src/Tricorder/SourceLookup/Tarball.hs view
@@ -11,13 +11,15 @@ , cabalPackagesDirs , matchesModule , extractModule- ) where+ )+where import Atelier.Effects.FileSystem (FileSystem, readFileLbs) import Atelier.Effects.Log (Log) import Data.Char (isUpper) import Effectful.Exception (trySync) import System.FilePath (splitDirectories, (</>))+import Tricorder.SourceLookup.SourceQuery (ModuleName (..)) import Atelier.Effects.Log qualified as Log import Codec.Archive.Tar qualified as Tar@@ -26,8 +28,8 @@ import Data.List qualified as List import Data.Text qualified as T -import Tricorder.Module (ModuleName (..), PackageId (..), splitPackageId) import Tricorder.SourceLookup.Hackage (Hackage)+import Tricorder.SourceLookup.PackageId (PackageId (..), splitPackageId) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.SourceLookup.Hackage qualified as Hackage
src/Tricorder/TestOutput.hs view
@@ -1,10 +1,12 @@ module Tricorder.TestOutput (parseHspecOutput, parseHspecDuration, stripGhciNoise) where -import Atelier.Time (Millisecond, fromMicroseconds)+import Atelier.Time (fromMicroseconds) import Data.Char (isDigit) import Data.Text qualified as T +import Tricorder.Build.Duration (Duration (..))+ import Tricorder.Build.Test qualified as Test @@ -48,20 +50,21 @@ | otherwise = let withoutClose = T.init t (timePart, rest) = T.span (\c -> isDigit c || c `elem` (".smμ" :: [Char])) (T.reverse withoutClose)- in if T.null timePart then- t- else case T.uncons rest of- Just ('(', afterParen) ->- case T.uncons afterParen of- Just (' ', desc) -> T.stripEnd (T.reverse desc)- _ -> t- _ -> t+ in if T.null timePart+ then+ t+ else case T.uncons rest of+ Just ('(', afterParen) ->+ case T.uncons afterParen of+ Just (' ', desc) -> T.stripEnd (T.reverse desc)+ _ -> t+ _ -> t -- | Extract the test suite duration from hspec summary output. -- Matches non-indented summary lines ending with @"(Xs)"@, -- e.g. @"All 160 tests passed (0.33s)"@ or @"1 out of 177 tests failed (0.06s)"@.-parseHspecDuration :: Text -> Maybe Millisecond+parseHspecDuration :: Text -> Maybe Duration parseHspecDuration output = listToMaybe $ mapMaybe extractMs (T.lines output) where@@ -70,7 +73,7 @@ guard $ T.isSuffixOf "s)" line let numStr = T.takeWhileEnd (/= '(') (T.dropEnd 2 line) secs <- readMaybe (T.unpack numStr) :: Maybe Double- pure $ fromMicroseconds (round (secs * 1_000_000))+ pure $ Duration $ fromMicroseconds (round (secs * 1_000_000)) -- | Strip GHCi/cabal startup and shutdown noise from captured output lines.
src/Tricorder/Version.hs view
@@ -11,12 +11,15 @@ -- in until something else triggers a rebuild. module Tricorder.Version (gitHash, VersionMismatch (..), checkVersion) where +import Data.Version (showVersion) import Language.Haskell.TH (litE, runIO, stringL) import System.Environment (lookupEnv) import System.IO.Error (tryIOError) import System.Process (readProcess) +import Paths_tricorder qualified as Pack + -- | Short git hash of the commit this binary was built from. -- -- Resolution order at compile time:@@ -28,19 +31,23 @@ -- 3. @"unknown"@ — fallback when @git@ is unavailable. gitHash :: Text gitHash =- toText- ( $( do- hash <- runIO $ do- override <- lookupEnv "TRICORDER_VERSION"- case override of- Just v -> pure v- Nothing ->- either (const "unknown") (filter (/= '\n'))- <$> tryIOError (readProcess "git" ["rev-parse", "--short", "HEAD"] "")- litE (stringL hash)- )- :: String- )+ "v"+ <> toText (showVersion Pack.version)+ <> " ("+ <> toText+ ( $( do+ hash <- runIO $ do+ override <- lookupEnv "TRICORDER_VERSION"+ case override of+ Just v -> pure v+ Nothing ->+ either (const "unknown") (filter (/= '\n'))+ <$> tryIOError (readProcess "git" ["rev-parse", "--short", "HEAD"] "")+ litE (stringL hash)+ )+ :: String+ )+ <> ")" data VersionMismatch = VersionMismatch
src/Tricorder/Waiters.hs view
@@ -4,7 +4,8 @@ , without , wait , run- ) where+ )+where import Effectful (Effect) import Effectful.Concurrent (Concurrent)
+ test/Unit/Tricorder/Build/ByteSizeSpec.hs view
@@ -0,0 +1,73 @@+module Unit.Tricorder.Build.ByteSizeSpec (spec_ByteSize) where++import Test.Hspec (Spec, describe, it, shouldBe)++import Tricorder.Build.ByteSize (ByteSize (..), Unit (..))++import Tricorder.Build.ByteSize qualified as ByteSize+++spec_ByteSize :: Spec+spec_ByteSize = describe "fromText" testFromText+++testFromText :: Spec+testFromText = do+ it "parses no unit as bytes" do+ ByteSize.fromText "1000" `shouldBe` Just (ByteSize 1000 B)++ it "parses bytes with unit" do+ ByteSize.fromText "1000B" `shouldBe` Just (ByteSize 1000 B)++ it "parses decimal kilobytes" do+ ByteSize.fromText "10kb" `shouldBe` Just (ByteSize 10 KB)++ it "parses binary kibibytes" do+ ByteSize.fromText "10kib" `shouldBe` Just (ByteSize 10 KiB)++ it "parses decimal megabytes" do+ ByteSize.fromText "1mb" `shouldBe` Just (ByteSize 1 MB)++ it "parses binary mebibytes" do+ ByteSize.fromText "1mib" `shouldBe` Just (ByteSize 1 MiB)++ it "parses decimal gigabytes" do+ ByteSize.fromText "1gb" `shouldBe` Just (ByteSize 1 GB)++ it "parses binary gibibytes" do+ ByteSize.fromText "1gib" `shouldBe` Just (ByteSize 1 GiB)++ it "parses decimal terabytes" do+ ByteSize.fromText "1tb" `shouldBe` Just (ByteSize 1 TB)++ it "parses binary tebibytes" do+ ByteSize.fromText "1tib" `shouldBe` Just (ByteSize 1 TiB)++ it "parses decimal petabytes" do+ ByteSize.fromText "1pb" `shouldBe` Just (ByteSize 1 PB)++ it "parses binary pebibytes" do+ ByteSize.fromText "1pib" `shouldBe` Just (ByteSize 1 PiB)++ it "allows a space between the number and the unit" do+ ByteSize.fromText "10 kb" `shouldBe` Just (ByteSize 10 KB)++ it "allows multiple spaces between the number and the unit" do+ ByteSize.fromText "10 kb" `shouldBe` Just (ByteSize 10 KB)++ it "is case-insensitive on the unit" do+ ByteSize.fromText "10KB" `shouldBe` Just (ByteSize 10 KB)+ ByteSize.fromText "10Kb" `shouldBe` Just (ByteSize 10 KB)+ ByteSize.fromText "10KiB" `shouldBe` Just (ByteSize 10 KiB)++ it "fails when there is no number" do+ ByteSize.fromText "kb" `shouldBe` Nothing++ it "fails on an unrecognized unit" do+ ByteSize.fromText "10xb" `shouldBe` Nothing++ it "fails on empty text" do+ ByteSize.fromText "" `shouldBe` Nothing++ it "fails on unrelated text" do+ ByteSize.fromText "hello world" `shouldBe` Nothing
test/Unit/Tricorder/Daemon/BuildStateSpec.hs view
@@ -12,6 +12,7 @@ , PostBuild (..) , Severity (..) )+import Tricorder.Build.Duration (Duration (..)) import Tricorder.Daemon.DaemonInfo (DaemonInfo (..)) import Tricorder.Build qualified as Build@@ -31,7 +32,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."+ , 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@@ -89,7 +91,7 @@ Build.Finished ( BuildResult { completedAt = epoch- , duration = 0+ , duration = Duration 0 , moduleCount = 0 , diagnostics = msgs }
test/Unit/Tricorder/Daemon/BuilderSpec.hs view
@@ -7,6 +7,7 @@ import Data.Set qualified as Set import Tricorder.Build (BuildResult (..), Diagnostic (..), Severity (..))+import Tricorder.Build.Duration (Duration (..)) import Tricorder.Daemon.Builder (NewLoadResult (..), compileBuildResults) import Tricorder.Daemon.GhciSession.GhciParser ( LoadResult (..)@@ -49,7 +50,7 @@ , diagnostics = [] } }- r.duration `shouldBe` 10_000+ r.duration `shouldBe` Duration 10_000 it "merges with existing results" do let (m, _) = compileBuildResults root watchDirs (Map.fromList [(errMsg.file, [errMsg])])@@ -89,7 +90,7 @@ expected = BuildResult { completedAt = addUTCTime 10 epoch- , duration = 10_000+ , duration = Duration 10_000 , moduleCount = 2 , diagnostics = [warnMsg] }
test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs view
@@ -55,8 +55,20 @@ , "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"}+ `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 ]@@ -84,7 +96,15 @@ 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"]}]+ `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 =@@ -110,17 +130,41 @@ 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"]}]+ `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"]}]+ `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"]}]+ `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 =@@ -150,12 +194,28 @@ 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]}]+ `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"]}]+ `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 =@@ -166,7 +226,14 @@ ] 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"]}+ , 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 ]@@ -231,7 +298,15 @@ it "handles <no location info>: error: with no continuation" do parseReload ["<no location info>: error: some error"]- `shouldBe` [GMessage GhciMessage {severity = GError, file = "<no location info>", startPos = Position 0 0, endPos = Position 0 0, messageLines = ["<no location info>: error: some error"]}]+ `shouldBe` [ GMessage+ GhciMessage+ { severity = GError+ , file = "<no location info>"+ , startPos = Position 0 0+ , endPos = Position 0 0+ , messageLines = ["<no location info>: error: some error"]+ }+ ] --------------------------------------------------------------------------------
test/Unit/Tricorder/Daemon/GhciSessionSpec.hs view
@@ -128,7 +128,15 @@ -- | 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}+simpleResult msgs =+ Right+ LoadResult+ { moduleCount = 0+ , compiledFiles = Set.empty+ , loadedModules = Map.empty+ , targetNames = []+ , diagnostics = msgs+ } runScripted
test/Unit/Tricorder/Daemon/TestRunnerSpec.hs view
@@ -104,14 +104,14 @@ it "returns scripted TestRun" do result <- runScripted [Right passingRun]- $ runTestSuite noProgress Cabal testTimeout+ $ runTestSuite noProgress Nothing Cabal testTimeout $ mkTestTarget "test:foo" result `shouldBe` passingRun it "ignores the target name argument" do result <- runScripted [Right failingRun]- $ runTestSuite noProgress Cabal testTimeout+ $ runTestSuite noProgress Nothing Cabal testTimeout $ mkTestTarget "test:anything" result `shouldBe` failingRun @@ -119,23 +119,28 @@ result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ runTestSuite noProgress Cabal testTimeout+ $ runTestSuite noProgress Nothing Cabal 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 Cabal testTimeout $ mkTestTarget "test:foo"- b <- runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:bar"+ a <- runTestSuite noProgress Nothing Cabal testTimeout $ mkTestTarget "test:foo"+ b <- runTestSuite noProgress Nothing Cabal 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 Cabal testTimeout $ mkTestTarget "test:foo"- r2 <- runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:bar"+ r1 <-+ try @ErrorCall+ $ runTestSuite noProgress Nothing Cabal testTimeout+ $ mkTestTarget "test:foo"+ r2 <-+ runTestSuite noProgress Nothing Cabal testTimeout+ $ mkTestTarget "test:bar" pure (r1, r2) fst result `shouldBe` Left boom snd result `shouldBe` passingRun
test/Unit/Tricorder/Session/CabalFileSpec.hs view
@@ -5,13 +5,13 @@ import Effectful (runPureEff) import Effectful.Reader.Static (runReader) import Effectful.State.Static.Shared (evalState)-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList) import Data.Map.Strict qualified as Map import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.CabalFile (discoverCabalFiles)-import Unit.Tricorder.Session.Helpers (cabalFixture, libTestCabal, multiPackageFs)+import Unit.Tricorder.Session.Helpers (cabalFixture, multiPackageCabalFs, multiPackageFs) spec_CabalFile :: Spec@@ -49,7 +49,7 @@ [ ("/cabal.project.local", "packages: pkg-a\n") , ("/cabal.project", "packages: pkg-b\n") ]- `Map.union` multiPackageCabalFiles+ `Map.union` multiPackageCabalFs actual = runDiscovery fs [] discoverCabalFiles actual `shouldBe` ["/pkg-a/pkg-a.cabal"] @@ -59,7 +59,7 @@ [ ("/cabal.project.freeze", "packages: pkg-a\n") , ("/cabal.project", "packages: pkg-b\n") ]- `Map.union` multiPackageCabalFiles+ `Map.union` multiPackageCabalFs actual = runDiscovery fs [] discoverCabalFiles actual `shouldBe` ["/pkg-a/pkg-a.cabal"] @@ -70,7 +70,7 @@ [ ("/cabal.project.local", "tests: True\n") , ("/cabal.project", "packages: pkg-b\n") ]- `Map.union` multiPackageCabalFiles+ `Map.union` multiPackageCabalFs actual = runDiscovery fs [] discoverCabalFiles actual `shouldBe` ["/pkg-b/pkg-b.cabal"] @@ -90,7 +90,7 @@ it "uses $HOME/.cabal/config as a last-resort packages source" do let fs = Map.singleton "/home/user/.cabal/config" "packages: pkg-a\n"- `Map.union` multiPackageCabalFiles+ `Map.union` multiPackageCabalFs actual = runDiscovery fs [("HOME", "/home/user")] discoverCabalFiles actual `shouldBe` ["/pkg-a/pkg-a.cabal"] @@ -103,13 +103,17 @@ ] actual = runDiscovery fs [("HOME", "/home/user")] discoverCabalFiles actual `shouldBe` ["/myapp.cabal"]++ describe "packages: single-line list" do+ describe "when package list is comma-separated" do+ it "parses package names correctly" do+ let fs =+ Map.singleton "/cabal.project" "packages: pkg-a, pkg-b\n"+ `Map.union` multiPackageCabalFs+ actual = runDiscovery fs [] discoverCabalFiles+ actual `shouldMatchList` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"] where pr = ProjectRoot "/"- multiPackageCabalFiles =- Map.fromList- [ ("/pkg-a/pkg-a.cabal", libTestCabal "pkg-a")- , ("/pkg-b/pkg-b.cabal", libTestCabal "pkg-b")- ] runDiscovery fs env = runPureEff . runEnvConst env
test/Unit/Tricorder/Session/Helpers.hs view
@@ -2,13 +2,15 @@ ( multiCabalFiles , singleCabalFile , multiPackageFs+ , multiPackageCabalFs , preludeOnlyLibCabal , libWithPreludeCabal , libTestCabal , gpdFixture , cabalFixture , gpd- ) where+ )+where import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)
test/Unit/Tricorder/SessionSpec.hs view
@@ -3,8 +3,8 @@ import Atelier.Config (LoadedConfig (..)) import Atelier.Effects.FileSystem (runFileSystemState) import Atelier.Effects.Input (runInputConst)-import Atelier.Effects.Log (Message (..), Severity (..), runLogWriter)-import Data.Aeson (Value (Null))+import Atelier.Effects.Log (Message (..), Severity (..), runLogNoOp, runLogWriter)+import Data.Aeson (Value (Null), object, (.=)) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) import Effectful (runPureEff) import Effectful.Reader.Static (runReader)@@ -13,14 +13,16 @@ import Test.Hspec import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session (loadSession)+import Tricorder.Session (Session (..), loadSession) import Tricorder.Session.CabalFile (CabalFile (..))+import Tricorder.Session.IdleTimeout (IdleTimeout (..)) import Unit.Tricorder.Session.Helpers (libWithPreludeCabal, preludeOnlyLibCabal) spec_Session :: Spec spec_Session = do describe "loadSession" testLoadSession+ describe "loadSession idleTimeout" testIdleTimeout testLoadSession :: Spec@@ -56,4 +58,24 @@ . runInputConst cabalFiles . runReader (ProjectRoot "/") . runInputConst (LoadedConfig Null)+ $ loadSession+++testIdleTimeout :: Spec+testIdleTimeout = do+ it "defaults to 300 seconds when unset" do+ (loadSessionWith (LoadedConfig Null)).idleTimeout `shouldBe` IdleTimeout 300++ it "reads idle_timeout_seconds from the session config" do+ let cfg = LoadedConfig $ object ["session" .= object ["idle_timeout_seconds" .= (5 :: Int)]]+ (loadSessionWith cfg).idleTimeout `shouldBe` IdleTimeout 5+ where+ loadSessionWith cfg =+ runPureEff+ . runLogNoOp+ . evalState @(Map FilePath ByteString) mempty+ . runFileSystemState+ . runInputConst ([] :: [CabalFile])+ . runReader (ProjectRoot "/")+ . runInputConst cfg $ loadSession
test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs view
@@ -3,6 +3,7 @@ import Effectful (runPureEff) import Test.Hspec +import Tricorder.Session.Command (Repl (..)) import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), findModule, runGhcPkgScripted) @@ -14,15 +15,17 @@ testFindModule :: Spec testFindModule = do it "returns Just pkgId when module is known" do- let result = runScripted [NextFindModule (Just "base-4.18")] $ findModule "Prelude"+ let result = runScripted [NextFindModule (Just "base-4.18")] $ findModule Cabal "Prelude" result `shouldBe` Just "base-4.18" it "returns Nothing for an unknown module" do- let result = runScripted [NextFindModule Nothing] $ findModule "No.Such.Module"+ let result = runScripted [NextFindModule Nothing] $ findModule Cabal "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"+ let result =+ runScripted [NextFindModule (Just "pkg-1.0"), NextFindModule (Just "pkg-2.0")]+ $ findModule Cabal "Foo" result `shouldBe` Just "pkg-1.0"
test/Unit/Tricorder/SourceLookup/TarballSpec.hs view
@@ -8,7 +8,7 @@ import Codec.Compression.GZip qualified as GZip import Data.ByteString.Lazy qualified as BSL -import Tricorder.Module (splitPackageId)+import Tricorder.SourceLookup.PackageId (splitPackageId) import Tricorder.SourceLookup.Tarball ( cabalPackagesDirs , extractModule
test/Unit/Tricorder/SourceLookupSpec.hs view
@@ -3,6 +3,7 @@ import Atelier.Effects.Cache (Cache, runCacheForever) import Atelier.Effects.Env (Env, runEnvConst) import Atelier.Effects.FileSystem (FileSystem (..))+import Atelier.Effects.Input (Input, runInputConst) import Atelier.Effects.Log (Log, runLogNoOp) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent)@@ -10,6 +11,7 @@ import Effectful.State.Static.Shared (State, evalState, gets, modify) import System.FilePath ((</>)) import Test.Hspec+import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery (..)) import Codec.Archive.Tar qualified as Tar import Codec.Archive.Tar.Entry qualified as Tar@@ -20,14 +22,14 @@ import Data.Map.Strict qualified as Map import Data.Text qualified as T -import Tricorder.Module (ModuleName, PackageId)+import Tricorder.Session.Command (Repl (..)) import Tricorder.SourceLookup ( ModuleSourceResult (..)- , SourceQuery (..) , lookupModuleSource ) import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted) import Tricorder.SourceLookup.Hackage (Hackage (..), Result (..))+import Tricorder.SourceLookup.PackageId (PackageId) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.SourceLookup.PackageStore qualified as PackageStore@@ -64,7 +66,10 @@ it "fetches from Hackage on a cache miss, then reads the now-fetched tarball" do result <-- runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty (pure (Success (BSL.toStrict tarballBytes)))+ runTest+ [NextFindModule (Just "aeson-2.2.5.0")]+ Map.empty+ (pure (Success (BSL.toStrict tarballBytes))) $ lookupModuleSource (wholeModule "Data.Aeson") result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource @@ -204,8 +209,18 @@ runTest :: [GhcPkgScript] -> Map FilePath LByteString- -> Eff '[PackageStore, Env, FileSystem, State (Map FilePath LByteString), Log, Concurrent, IOE] Result -> Eff+ '[ PackageStore+ , Env+ , FileSystem+ , State (Map FilePath LByteString)+ , Input Repl+ , Log+ , Concurrent+ , IOE+ ]+ Result+ -> Eff '[ Cache ModuleName PackageId , Cache (PackageId, SourceQuery) ModuleSourceResult , GhcPkg@@ -214,6 +229,7 @@ , Env , FileSystem , State (Map FilePath LByteString)+ , Input Repl , Log , Concurrent , IOE@@ -224,6 +240,7 @@ runEff . runConcurrent . runLogNoOp+ . runInputConst Cabal . evalState initialFs . runFileSystemFake . runEnvConst [("HOME", "/h")]
test/Unit/Tricorder/TestOutputSpec.hs view
@@ -2,6 +2,7 @@ import Test.Hspec +import Tricorder.Build.Duration (Duration (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput, stripGhciNoise) import Tricorder.Build.Test qualified as Test@@ -98,11 +99,11 @@ it "parses duration from passing summary line" do parseHspecDuration "All 177 tests passed (0.05s)\n"- `shouldBe` Just 50+ `shouldBe` Just (Duration 50) it "parses duration from failing summary line" do parseHspecDuration "1 out of 177 tests failed (0.06s)\n"- `shouldBe` Just 60+ `shouldBe` Just (Duration 60) it "does not match indented individual test timing lines" do parseHspecDuration " entry is evicted after cleanup thread fires past TTL: OK (0.05s)\n"@@ -115,7 +116,7 @@ <> " slow test: OK (0.05s)\n" <> "\n" <> "All 2 tests passed (0.5s)\n"- parseHspecDuration output `shouldBe` Just 500+ parseHspecDuration output `shouldBe` Just (Duration 500) describe "stripGhciNoise" do it "passes through empty list" do
tricorder.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder-version: 0.2.1.0+version: 0.2.2.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@@ -27,7 +27,9 @@ library tricorder-internal exposed-modules: Tricorder.Build+ Tricorder.Build.ByteSize Tricorder.Build.Changes+ Tricorder.Build.Duration Tricorder.Build.EvalComment Tricorder.Build.Test Tricorder.CLI.App@@ -56,17 +58,19 @@ Tricorder.Daemon.GhciSession.GhciProcess Tricorder.Daemon.Hpack Tricorder.Daemon.Hpack.Effect+ Tricorder.Daemon.IdleTimer Tricorder.Daemon.Main 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.GenerateWithHpack+ Tricorder.Session.Hooks+ Tricorder.Session.IdleTimeout Tricorder.Session.ReplBuildDir Tricorder.Session.Target Tricorder.Session.TestTarget@@ -80,6 +84,7 @@ Tricorder.SourceLookup Tricorder.SourceLookup.GhcPkg Tricorder.SourceLookup.Hackage+ Tricorder.SourceLookup.PackageId Tricorder.SourceLookup.PackageStore Tricorder.SourceLookup.Slice Tricorder.SourceLookup.Tarball@@ -143,6 +148,7 @@ , text ==2.1.* , time >=1.12 && <1.17 , time-units ==1.0.*+ , tricorder-types ==0.1.* , vty >=6.5 && <6.7 , vty-crossplatform ==0.5.* , yaml ==0.11.*@@ -233,6 +239,7 @@ type: exitcode-stdio-1.0 main-is: Driver.hs other-modules:+ Unit.Tricorder.Build.ByteSizeSpec Unit.Tricorder.Build.EvalCommentSpec Unit.Tricorder.CLI.RenderSpec Unit.Tricorder.Daemon.BuilderSpec@@ -308,6 +315,7 @@ , time >=1.12 && <1.17 , time-units ==1.0.* , tricorder-internal+ , tricorder-types ==0.1.* , typed-process ==0.2.* , unagi-chan ==0.4.* , unix ==2.8.*