tricorder 0.4.1.0 → 0.4.1.1

raw patch · 9 files changed

+286/−39 lines, 9 filesdep ~Cabaldep ~Cabal-syntaxPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Cabal, Cabal-syntax

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−0
• src/Tricorder/CLI/Main.hs +4/−1
• src/Tricorder/CLI/UI/View.hs +1/−1
• src/Tricorder/Daemon/GhciSession/GhciProcess.hs +37/−8
• src/Tricorder/Daemon/IdleTimer.hs +47/−17
• src/Tricorder/Daemon/Main.hs +2/−0
• src/Tricorder/Session/Target.hs +30/−7
• test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs +135/−1
• tricorder.cabal +4/−4

@@ -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

@@ -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

@@ -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..."

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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.*