diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,32 @@ ## [Unreleased] +## [0.4.1.1] - 2026-09-21 + +### Fixed + +- Output from eval comments no longer runs outside of the terminal, and instead + wraps around. +- Component marked as `buildable: False` are not omitted from Tricorder's list + of targets. +- GHC plugins declared via `-fplugin` are no longer silently skipped on reload + on GHC 9.14, causing a flood of spurious diagnostics. +- Frequent wakeups while idle caused Tricorder to run GC unnecessarily. The + length of time between idle checks has now been increased. (Thanks @agentm!) +- Errors and issues that occur when reading from GHCi will now be logged. To + capture specific parts of the GHCi output, Tricorder makes GHCi echo some + marker lines around the output of any issued commands from Tricorder. When we + receive back a reply that ends before seeing the ending marker, something's + gone awry, and previously Tricorder would just display + `Unexpected Exit "#~TRI-FINISH-1" Nothing` in a lot of these cases because we + failed to read from GHCi. + +### Changed + +- Reduce upper bound on `Cabal` and `Cabal-syntax` dependencies. Version `3.18` + bring with them breaking changes that Tricorder is not yet compatible with, + so this is a necessary change. + ## [0.4.1.0] - 2026-09-17 ### Added diff --git a/src/Tricorder/CLI/Main.hs b/src/Tricorder/CLI/Main.hs --- a/src/Tricorder/CLI/Main.hs +++ b/src/Tricorder/CLI/Main.hs @@ -15,6 +15,7 @@ import Atelier.Effects.Posix.Daemons (runDaemons) import Atelier.Effects.Process (runProcessIO) import Atelier.Effects.Timeout (runTimeout) +import Atelier.Signal (installTerminationHandler) import Data.Default (def) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) @@ -83,4 +84,6 @@ . GhcPkg.runGhcPkgIO . PackageStore.run . Hackage.run - $ App.run + $ do + installTerminationHandler + App.run diff --git a/src/Tricorder/CLI/UI/View.hs b/src/Tricorder/CLI/UI/View.hs --- a/src/Tricorder/CLI/UI/View.hs +++ b/src/Tricorder/CLI/UI/View.hs @@ -221,7 +221,7 @@ <> case evaluation.state of Eval.Completed output -> [ subtle $ txt "Result:" - , vBox $ txt <$> T.lines output + , txtWrap output ] Eval.Pending -> [ subtle $ txt "Running..." diff --git a/src/Tricorder/Daemon/GhciSession/GhciProcess.hs b/src/Tricorder/Daemon/GhciSession/GhciProcess.hs --- a/src/Tricorder/Daemon/GhciSession/GhciProcess.hs +++ b/src/Tricorder/Daemon/GhciSession/GhciProcess.hs @@ -8,6 +8,7 @@ , waitForBannerOrFail , withGhciProcess , execGhci + , drainUntil , interruptGhci , terminateGhciProcess , collectGhciResult @@ -36,6 +37,7 @@ import Atelier.Effects.Timeout (Timeout, timeout) import Control.Concurrent.STM (TVar, modifyTVar', readTVar, retry, writeTVar) import Data.Default (Default (..)) +import Data.Sequence ((|>)) import Data.Time.Units (Second) import Effectful.Concurrent (Concurrent) import Effectful.Concurrent.STM (atomically, newTVarIO) @@ -140,6 +142,7 @@ :: ( Conc :> es , Concurrent :> es , File :> es + , Log :> es , Timeout :> es ) => Config @@ -187,7 +190,6 @@ -- Send fixed setup commands (protocol requirements) File.hPutTextLn inp ":set prompt \"\"" File.hPutTextLn inp ":set prompt-cont \"\"" - File.hPutTextLn inp ":set +c" -- Send any caller-supplied extra setup commands for_ config.extraSetupCommands \c -> File.hPutTextLn inp c @@ -219,7 +221,7 @@ -- action receives the process handle and the output captured during startup. -- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks. withGhciProcess - :: (Conc :> es, Concurrent :> es, File :> es, Process :> es, Timeout :> es) + :: (Conc :> es, Concurrent :> es, File :> es, Log :> es, Process :> es, Timeout :> es) => Config -> Command -> FilePath @@ -250,6 +252,7 @@ :: ( Conc :> es , Concurrent :> es , File :> es + , Log :> es ) => GhciProcess -> Text -> (GhciLoading -> Eff es ()) -> Eff es [Text] execGhci ghciProcess command onProgress = do @@ -373,21 +376,47 @@ -- Each ordinary line is passed to @onLine@ as it arrives, so callers can stream -- progress without waiting for the full drain to complete. Returns accumulated -- non-marker lines in order. Throws 'UnexpectedExit' on EOF before the marker. -drainUntil :: (File :> es) => Handle -> Text -> (Text -> Eff es ()) -> Eff es [Text] -drainUntil h marker onLine = go [] +drainUntil :: (File :> es, Log :> es) => Handle -> Text -> (Text -> Eff es ()) -> Eff es [Text] +drainUntil h marker onLine = go mempty where go acc = do result <- trySync $ File.hGetLine h case result of - Left _ -> - throwIO $ UnexpectedExit marker (listToMaybe (reverse acc)) + Left ex -> do + let accumulatedLines = T.intercalate "\n" $ toList acc + Log.err + $ T.intercalate + "\n" + [ "Reached EOF before reading marker from GHCi." + , "Was looking for marker '" <> marker <> "', but no such marker was found." + , "" + ] + <> if T.null accumulatedLines + then + T.intercalate + "\n" + [ "GHCi returned no output before we reached what we believe is EOF." + , "Got the following exception when attempting to read from GHCi:" + , toText $ displayException ex + ] + else + T.intercalate + "\n" + [ "Accumulated output from GHCi so far:" + , accumulatedLines + ] + throwIO + $ UnexpectedExit marker + $ if T.null accumulatedLines + then Nothing + else Just accumulatedLines Right line - | marker `T.isInfixOf` line -> pure (reverse acc) + | marker `T.isInfixOf` line -> pure $ toList acc -- A stale marker from an interrupted command: drop it, keep going. | markerPrefix `T.isInfixOf` line -> go acc | otherwise -> do onLine line - go (line : acc) + go $ acc |> line -- | Convert a 'GhciLoading' progress callback into a per-line hook suitable diff --git a/src/Tricorder/Daemon/IdleTimer.hs b/src/Tricorder/Daemon/IdleTimer.hs --- a/src/Tricorder/Daemon/IdleTimer.hs +++ b/src/Tricorder/Daemon/IdleTimer.hs @@ -11,8 +11,8 @@ 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 Atelier.Time (Second, nominalDiffTime) +import Data.Time (NominalDiffTime, diffUTCTime) import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..)) import Effectful.Concurrent (Concurrent) import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, writeTVar) @@ -37,9 +37,14 @@ -- | 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. +-- @idle_timeout_seconds@ elapses with no open connections. A timeout of zero +-- or less disables shutdown. +-- +-- The timeout is read from 'Session' on every check rather than captured once, +-- so config reloads apply to a daemon that is already idle — within +-- 'maxCheckInterval', which bounds how long the check sleeps. Shutdown itself +-- still happens at the deadline, not at a check boundary: the last sleep is +-- trimmed to the exact time remaining. quitOnTimeout :: ( Clock :> es , Conc :> es @@ -56,22 +61,24 @@ 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 () + -- Disabled, but keep checking so re-enabling it via a config + -- reload is still picked up. + IdleTimeout secs | secs <= 0 -> Delay.wait maxCheckInterval 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 + (connections, idleSince) <- atomically do + (,) <$> readTVar activeActions <*> readTVar lastActivity + let remaining = fromIntegral secs - diffUTCTime now idleSince + if connections > 0 || remaining > 0 + then Delay.wait $ nextCheck connections remaining + else do + Log.info + $ "Idle for " + <> show secs + <> " with no active connections, shutting down." + exitSuccess interpretWith act \env -> \case WithActivity action -> do @@ -85,3 +92,26 @@ atomically do modifyTVar' activeActions (max 0 . subtract 1) writeTVar lastActivity end + + +-- | Longest the idle check will sleep between polls. +-- +-- Checking in bounded chunks rather than one sleep until the deadline keeps +-- live config reloads responsive: a changed @idle_timeout_seconds@ (including +-- re-enabling a disabled one) is picked up within this interval. It is kept +-- generous because wake-ups are not free — each one ends the RTS idle period +-- and re-arms idle GC, costing a major collection. +maxCheckInterval :: Second +maxCheckInterval = 60 + + +-- | How long to sleep before the next idle check. +-- +-- With connections open the timeout cannot fire, so there is nothing to wait +-- for but a config change. Otherwise sleep until the deadline, capped at +-- 'maxCheckInterval' and floored at one second so a sub-second remainder +-- cannot spin the loop. +nextCheck :: Int -> NominalDiffTime -> Second +nextCheck connections remaining + | connections > 0 = maxCheckInterval + | otherwise = max 1 . min maxCheckInterval $ nominalDiffTime remaining diff --git a/src/Tricorder/Daemon/Main.hs b/src/Tricorder/Daemon/Main.hs --- a/src/Tricorder/Daemon/Main.hs +++ b/src/Tricorder/Daemon/Main.hs @@ -14,6 +14,7 @@ import Atelier.Effects.Process (runProcessIO) import Atelier.Effects.Publishing (runPubSub) import Atelier.Effects.Timeout (runTimeout) +import Atelier.Signal (installTerminationHandler) import Data.Default (def) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) @@ -103,6 +104,7 @@ . TestRunner.run . Waiters.run $ do + installTerminationHandler Log.info $ "Starting tricorder " <> Version.gitHash Conc.fork_ Core.main Conc.fork_ Server.main diff --git a/src/Tricorder/Session/Target.hs b/src/Tricorder/Session/Target.hs --- a/src/Tricorder/Session/Target.hs +++ b/src/Tricorder/Session/Target.hs @@ -12,7 +12,8 @@ where import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) -import Distribution.Types.CondTree (condTreeData) +import Distribution.Compat.Lens (view) +import Distribution.Types.CondTree (CondTree, condTreeData) import Distribution.Types.GenericPackageDescription ( GenericPackageDescription , condBenchmarks @@ -30,6 +31,7 @@ import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName) import Data.Text qualified as T +import Distribution.Types.BuildInfo.Lens qualified as Lens import Tricorder.Session.CabalFile (CabalFile (..)) @@ -204,11 +206,32 @@ ++ benchTargets where mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd - mainLibTargets = maybe [] (const [qualified Lib mainPkgName]) (condLibrary gpd) - subLibTargets = map (\(n, _) -> qualified Lib (getComponentName n)) (condSubLibraries gpd) - flibTargets = map (\(n, _) -> qualified FLib (getComponentName n)) (condForeignLibs gpd) - exeTargets = map (\(n, _) -> qualified Exe (getComponentName n)) (condExecutables gpd) - testTargets = map (\(n, _) -> qualified Test (getComponentName n)) (condTestSuites gpd) - benchTargets = map (\(n, _) -> qualified Bench (getComponentName n)) (condBenchmarks gpd) + mainLibTargets = + fmap (const $ qualified Lib mainPkgName) + $ filter (view Lens.buildable . condTreeData) + $ toList + $ condLibrary gpd + subLibTargets = + fmap (\(n, _) -> qualified Lib (getComponentName n)) + $ filter isBuildable + $ condSubLibraries gpd + flibTargets = + fmap (\(n, _) -> qualified FLib (getComponentName n)) + $ filter isBuildable + $ condForeignLibs gpd + exeTargets = + fmap (\(n, _) -> qualified Exe (getComponentName n)) + $ filter isBuildable + $ condExecutables gpd + testTargets = + fmap (\(n, _) -> qualified Test (getComponentName n)) + $ filter isBuildable + $ condTestSuites gpd + benchTargets = + fmap (\(n, _) -> qualified Bench (getComponentName n)) + $ filter isBuildable + $ condBenchmarks gpd getComponentName = toText . unUnqualComponentName qualified = PackageQualified mainPkgName + isBuildable :: (Lens.HasBuildInfo val) => (a, CondTree condVar dep val) -> Bool + isBuildable = view Lens.buildable . condTreeData . snd diff --git a/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs b/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs --- a/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs +++ b/test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs @@ -3,6 +3,7 @@ import Atelier.Effects.Conc (runConc) import Atelier.Effects.Delay (runDelay) import Atelier.Effects.File (runFile) +import Atelier.Effects.Log (Message (..), Severity (..), runLogNoOp, runLogWriter) import Atelier.Effects.Process (runProcessIO, terminateProcessGroup, withProcessGroup) import Atelier.Effects.Process.Internal (RunningProcess (..)) import Atelier.Effects.Timeout (runTimeout) @@ -11,11 +12,12 @@ import Control.Concurrent.STM (newTVarIO) import Control.Exception (IOException, catch) import Data.Char (isDigit) -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Time.Units (Second) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.Exception (trySync) +import Effectful.Writer.Static.Shared (runWriter) import System.IO (hGetLine) import System.Posix.Signals (nullSignal, sigKILL, signalProcess) import System.Process.Typed @@ -48,6 +50,7 @@ , InterruptDecision (..) , SessionState (..) , decideInterrupt + , drainUntil , execGhci , waitForBannerOrFail ) @@ -56,6 +59,7 @@ spec_GhciProcess :: Spec spec_GhciProcess = do describe "decideInterrupt" testDecideInterrupt + describe "drainUntil" testDrainUntil describe "execGhci" testExecGhciScope describe "execGhci (stale marker desync)" testExecGhciStaleMarker describe "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent @@ -64,6 +68,133 @@ describe "terminateProcessGroup (process group)" testTerminateProcessGroup +-- | Mirrors the private 'markerFor' helper (not exported), using the same +-- reconstruction as 'testExecGhciStaleMarker' below. +finishMarker :: Int -> Text +finishMarker n = "#~TRI-FINISH-" <> show n <> "~#" + + +testDrainUntil :: Spec +testDrainUntil = do + it "returns accumulated non-marker lines in order and stops at the marker" do + (r, w) <- Process.createPipe + (result, _msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + for_ ["line1", "line2", finishMarker 1, "line3"] (File.hPutTextLn w) + File.hClose w + drainUntil r (finishMarker 1) (\_ -> pure ()) + result `shouldBe` ["line1", "line2"] + + it "streams each non-marker line to onLine, in order, before returning" do + (r, w) <- Process.createPipe + seenRef <- newIORef [] + (result, _msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + for_ ["a", "b", "c", finishMarker 2] (File.hPutTextLn w) + File.hClose w + drainUntil r (finishMarker 2) (\l -> liftIO $ modifyIORef' seenRef (l :)) + seen <- reverse <$> readIORef seenRef + seen `shouldBe` ["a", "b", "c"] + result `shouldBe` seen + + it "skips a stale marker with a different suffix and keeps draining" do + (r, w) <- Process.createPipe + (result, _msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + -- 'finishMarker 5' is a leftover from a prior, interrupted + -- command; the drain waiting for 'finishMarker 9' must + -- skip it rather than stopping. + for_ ["before", finishMarker 5, "after", finishMarker 9] (File.hPutTextLn w) + File.hClose w + drainUntil r (finishMarker 9) (\_ -> pure ()) + result `shouldBe` ["before", "after"] + + it "throws UnexpectedExit with ALL accumulated lines (in order) on EOF, not just the last one" do + (r, w) <- Process.createPipe + (outcome, _msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + for_ ["first", "second", "third"] (File.hPutTextLn w) + File.hClose w -- EOF before the marker ever arrives + trySync (drainUntil r (finishMarker 1) (\_ -> pure ())) + case outcome of + Right ls -> expectationFailure ("expected UnexpectedExit, got: " <> show ls) + Left ex -> case fromException ex of + Just (UnexpectedExit m ls) -> do + m `shouldBe` finishMarker 1 + ls `shouldBe` Just "first\nsecond\nthird" + other -> expectationFailure ("expected UnexpectedExit, got: " <> show other) + + it "throws UnexpectedExit with no lines when EOF is reached immediately" do + (r, w) <- Process.createPipe + (outcome, _msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + File.hClose w + trySync (drainUntil r (finishMarker 1) (\_ -> pure ())) + case outcome of + Right ls -> expectationFailure ("expected UnexpectedExit, got: " <> show ls) + Left ex -> case fromException ex of + Just (UnexpectedExit m ls) -> do + m `shouldBe` finishMarker 1 + ls `shouldBe` Nothing + other -> expectationFailure ("expected UnexpectedExit, got: " <> show other) + + it + "logs an ERROR mentioning the missing marker and the exception when EOF is reached with no output" + do + (r, w) <- Process.createPipe + (_outcome, msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + File.hClose w + trySync (drainUntil r (finishMarker 3) (\_ -> pure ())) + case filter (\m -> m.severity == ERROR) msgs of + [] -> expectationFailure "expected an ERROR log message" + (logMsg : _) -> do + (finishMarker 3 `T.isInfixOf` logMsg.text) `shouldBe` True + ("GHCi returned no output" `T.isInfixOf` logMsg.text) `shouldBe` True + + it "logs an ERROR including the accumulated output when EOF is reached mid-output" do + (r, w) <- Process.createPipe + (_outcome, msgs) <- + runEff + . runWriter @[Message] + . runLogWriter + . runFile + $ do + for_ ["oops-line-1", "oops-line-2"] (File.hPutTextLn w) + File.hClose w + trySync (drainUntil r (finishMarker 4) (\_ -> pure ())) + case filter (\m -> m.severity == ERROR) msgs of + [] -> expectationFailure "expected an ERROR log message" + (logMsg : _) -> do + (finishMarker 4 `T.isInfixOf` logMsg.text) `shouldBe` True + ("oops-line-1" `T.isInfixOf` logMsg.text) `shouldBe` True + ("oops-line-2" `T.isInfixOf` logMsg.text) `shouldBe` True + + -- | Regression for the touch-during-reload desync. Interrupting a *Busy* GHCi -- (a reload in flight) leaves a stale sync marker in the stdout/stderr buffers -- ahead of the next command's real output. Because 'drainUntil' used to stop on @@ -102,6 +233,7 @@ . runTimeout . runDelay . runFile + . runLogNoOp . runConc $ do -- A stale 'marker 5' (left by a prior interrupted reload) @@ -159,6 +291,7 @@ . runTimeout . runDelay . runFile + . runLogNoOp . runConc $ do -- Pre-seed the marker on both streams so the drain returns @@ -395,6 +528,7 @@ . runTimeout . runDelay . runFile + . runLogNoOp . runConc $ Conc.scoped do -- A sibling fork in the SAME ambient scope. If the bug diff --git a/tricorder.cabal b/tricorder.cabal --- a/tricorder.cabal +++ b/tricorder.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder -version: 0.4.1.0 +version: 0.4.1.1 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 @@ -122,8 +122,8 @@ TypeFamilies ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded build-depends: - Cabal >=3.12 && <3.19 - , Cabal-syntax >=3.12 && <3.19 + Cabal >=3.12 && <3.17 + , Cabal-syntax >=3.12 && <3.17 , Glob ==0.10.* , aeson >=2.2 && <2.4 , atelier-core ==0.7.* @@ -297,7 +297,7 @@ build-tool-depends: tasty-discover:tasty-discover build-depends: - Cabal-syntax >=3.12 && <3.19 + Cabal-syntax >=3.12 && <3.17 , aeson >=2.2 && <2.4 , atelier-core ==0.7.* , atelier-prelude ==0.4.*