tricorder 0.5.0.0 → 0.6.0.0

raw patch · 105 files changed

+6184/−3838 lines, 105 filesdep ~atelier-coredep ~tricorder-typesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: atelier-core, tricorder-types

API changes (from Hackage documentation)

Files

• CHANGELOG.md +67/−0
• src/Tricorder/Build/EvalComment.hs +1/−1
• src/Tricorder/Build/Test.hs +9/−10
• src/Tricorder/CLI/App.hs +8/−10
• src/Tricorder/CLI/App/CLIResponse.hs +16/−0
• src/Tricorder/CLI/App/Output.hs +57/−0
• src/Tricorder/CLI/App/Test.hs +145/−0
• src/Tricorder/CLI/App/Test/Json.hs +63/−0
• src/Tricorder/CLI/App/Test/Json/Responses.hs +79/−0
• src/Tricorder/CLI/App/Test/SuiteView.hs +154/−0
• src/Tricorder/CLI/App/Test/Text.hs +99/−0
• src/Tricorder/CLI/Arguments.hs +64/−28
• src/Tricorder/CLI/Arguments/IfDaemonIsStopped.hs +14/−0
• src/Tricorder/CLI/Arguments/OutputFormat.hs +5/−3
• src/Tricorder/CLI/Arguments/Test.hs +106/−0
• src/Tricorder/CLI/Arguments/TestFilter.hs +17/−0
• src/Tricorder/CLI/Arguments/WaitMode.hs +12/−0
• src/Tricorder/CLI/Main.hs +33/−28
• src/Tricorder/CLI/Operations.hs +28/−18
• src/Tricorder/CLI/Render.hs +6/−1
• src/Tricorder/CLI/UI.hs +15/−9
• src/Tricorder/CLI/UI/Keys.hs +102/−96
• src/Tricorder/CLI/UI/Route.hs +0/−2
• src/Tricorder/CLI/UI/State.hs +2/−0
• src/Tricorder/CLI/UI/View.hs +63/−45
• src/Tricorder/Config.hs +29/−47
• src/Tricorder/Config/LoadedConfig.hs +92/−0
• src/Tricorder/Daemon/Builder.hs +17/−14
• src/Tricorder/Daemon/Core.hs +31/−162
• src/Tricorder/Daemon/DaemonInfo.hs +5/−3
• src/Tricorder/Daemon/Dispatch.hs +14/−15
• src/Tricorder/Daemon/EvalCommentRunner.hs +9/−8
• src/Tricorder/Daemon/Ghci/Config.hs +25/−0
• src/Tricorder/Daemon/Ghci/Controls.hs +25/−0
• src/Tricorder/Daemon/Ghci/Diagnostic.hs +56/−0
• src/Tricorder/Daemon/Ghci/InterruptDecision.hs +28/−0
• src/Tricorder/Daemon/Ghci/LineParser.hs +66/−0
• src/Tricorder/Daemon/Ghci/Load.hs +143/−0
• src/Tricorder/Daemon/Ghci/LoadOutcome.hs +7/−0
• src/Tricorder/Daemon/Ghci/LoadResult.hs +54/−0
• src/Tricorder/Daemon/Ghci/LoadedModule.hs +13/−0
• src/Tricorder/Daemon/Ghci/Loading.hs +13/−0
• src/Tricorder/Daemon/Ghci/Message.hs +17/−0
• src/Tricorder/Daemon/Ghci/Output.hs +57/−0
• src/Tricorder/Daemon/Ghci/Path.hs +41/−0
• src/Tricorder/Daemon/Ghci/Position.hs +56/−0
• src/Tricorder/Daemon/Ghci/Process.hs +547/−0
• src/Tricorder/Daemon/Ghci/Result.hs +230/−0
• src/Tricorder/Daemon/Ghci/Session.hs +131/−0
• src/Tricorder/Daemon/Ghci/Session/State.hs +5/−0
• src/Tricorder/Daemon/Ghci/Severity.hs +20/−0
• src/Tricorder/Daemon/Ghci/TextParser.hs +19/−0
• src/Tricorder/Daemon/GhciSession.hs +0/−175
• src/Tricorder/Daemon/GhciSession/GhciParser.hs +0/−674
• src/Tricorder/Daemon/GhciSession/GhciProcess.hs +0/−590
• src/Tricorder/Daemon/HookDispatch.hs +34/−0
• src/Tricorder/Daemon/Hpack.hs +14/−11
• src/Tricorder/Daemon/Main.hs +52/−37
• src/Tricorder/Daemon/TestRunner.hs +15/−18
• src/Tricorder/Daemon/Watch.hs +2/−2
• src/Tricorder/Logging.hs +27/−11
• src/Tricorder/Session.hs +39/−42
• src/Tricorder/Session/CabalFile.hs +9/−7
• src/Tricorder/Session/CommandConfig.hs +1/−1
• src/Tricorder/Session/CommandTemplate.hs +7/−9
• src/Tricorder/Session/Config.hs +3/−2
• src/Tricorder/Session/HaskellHooks.hs +43/−0
• src/Tricorder/Session/Hook.hs +31/−0
• src/Tricorder/Session/Hooks.hs +46/−27
• src/Tricorder/Session/StackProject.hs +3/−2
• src/Tricorder/Session/Stage/Build/Session.hs +6/−7
• src/Tricorder/Session/Stage/Eval/Session.hs +4/−6
• src/Tricorder/Session/Stage/Test/Config.hs +1/−1
• src/Tricorder/Session/Stage/Test/Session.hs +7/−9
• src/Tricorder/Session/State.hs +173/−0
• src/Tricorder/Session/State/Invalid.hs +10/−0
• src/Tricorder/Session/State/Result.hs +43/−0
• src/Tricorder/Session/TestTarget.hs +9/−10
• src/Tricorder/Session/Util.hs +3/−3
• src/Tricorder/Session/WatchDirs.hs +16/−0
• src/Tricorder/Socket/Client.hs +1/−0
• src/Tricorder/Socket/Server.hs +28/−28
• src/Tricorder/Socket/UnixSocket.hs +23/−63
• src/Tricorder/SourceLookup.hs +227/−60
• src/Tricorder/SourceLookup/Reexport.hs +343/−0
• src/Tricorder/SourceLookup/Tarball.hs +1/−0
• test/Unit/Tricorder/CLI/App/Test/SuiteViewSpec.hs +119/−0
• test/Unit/Tricorder/Daemon/BuilderSpec.hs +2/−151
• test/Unit/Tricorder/Daemon/DispatchSpec.hs +2/−1
• test/Unit/Tricorder/Daemon/Ghci/LoadResultSpec.hs +87/−0
• test/Unit/Tricorder/Daemon/Ghci/OutputSpec.hs +78/−0
• test/Unit/Tricorder/Daemon/Ghci/ProcessSpec.hs +564/−0
• test/Unit/Tricorder/Daemon/Ghci/ResultSpec.hs +477/−0
• test/Unit/Tricorder/Daemon/Ghci/SessionSpec.hs +152/−0
• test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs +0/−503
• test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs +0/−569
• test/Unit/Tricorder/Daemon/GhciSessionSpec.hs +0/−154
• test/Unit/Tricorder/Daemon/WatchSpec.hs +1/−1
• test/Unit/Tricorder/Session/CabalFileSpec.hs +2/−2
• test/Unit/Tricorder/Session/TestTargetSpec.hs +5/−5
• test/Unit/Tricorder/SessionSpec.hs +42/−23
• test/Unit/Tricorder/SocketSpec.hs +16/−34
• test/Unit/Tricorder/SourceLookup/ReexportSpec.hs +181/−0
• test/Unit/Tricorder/SourceLookupSpec.hs +269/−89
• tricorder.cabal +51/−11

@@ -7,6 +7,73 @@  ## [Unreleased] +## [0.6.0.0] - 2026-10-20++### Added++- `tricorder test suites [TEST-TARGET...]` shows test suites, their test cases+  and their output. `--fields` picks what to show for each suite, e.g.+  `--fields 'name,cases(description,failure)'`; by default it shows a summary+  of each suite. `--failed-only` keeps only failed suites and their failed test+  cases. Text output is YAML, and `--json` gives JSON. This will replace+  `tricorder test-results`. Non-breaking.+- `tricorder source MODULE#SYMBOL` now follows re-exports: a symbol that+  `MODULE` re-exports rather than defines (e.g. `Data.Text#pack`, defined in+  `Data.Text.Internal`) is traced to its defining module, and its source is+  printed under a `-- Re-exported from <module>` line.+- `tricorder source` now takes optional `--max-depth N` (re-export hops to+  follow, default 5; `0` disables following) and `--max-modules N` (modules to+  read while following, default 24) to bound the re-export search.+- `tricorder source` now finds modules defined in the project itself, searching+  the `hs-source-dirs` of every component of every project package before+  falling back to installed packages.++### Changed++- Navigation in `tricorder ui` is now done with the left and right arrow keys+  (or `h` and `l`), where you switch to the left or right tab accordingly. The+  previous hotkey-based solution where you had to know which key related to+  which tab felt antiquated, and less intuitive compared to just moving between+  them left and right. You will get errors when starting Tricorder with old,+  unsupported key bindings in your `keybindings` config. These take the following form:++  ```+  Error(s) encountered when attempting to parse key bindings:+  Unrecognized key event: foo_bar+  ```++- Default key binding for the "help" view is now `?`. This key binding is+  supported as expected on keyboards where `?` is inputted with a modifier key.+- Configuration parsing issues are now properly surfaced to the user, and shown+  in `tricorder ui`, as well as being outputted to `stderr` for other commands.++### Fixed++- When the build command exits before GHCi starts, its output is now shown as+  plain text in `tricorder ui`, `tricorder status` and the JSON output.+  Previously it was rendered with `show`, so it appeared as+  `StartupFailed "..."` with line breaks printed as a literal `\n`.+  ([#542](https://github.com/tweag/tricorder/issues/542)) (Thanks @RyosukeDTomita)+- Pre-built binaries on GitHub were built against paths in `/nix/store`, and+  were not portable to systems that did not have Nix installed. The binaries+  are now correctly linked to be used on non-Nix machines, and NixOS machines+  with `nix-ld` enabled.+- Tricorder would sometimes not react to `.cabal` file changes, especially when+  there were existing build failures. This should now be fixed by reverting+  parts of an earlier change where the daemon's build state logic.+- Tricorder would sometimes keep old diagnostic messages from previous build+  failures around when files were moved. This would cause said diagnostic+  failures to persist until the daemon was manually restarted either through+  `tricorder restart`, or using `Shift+R` in `tricorder ui`. This was caused by+  handling the builder state in a layer above the builder restart logic,+  causing the builder state to persist between builder restarts (which happen+  when the `.cabal` file changes, like when adding or removing modules). This+  should now be fixed.++### Deprecated++- `tricorder test-results`: to be replaced by `tricorder test suites`.+ ## [0.5.0.0] - 2026-10-02  ### Added

@@ -15,7 +15,7 @@     ) where -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, (.:)) import GHC.Generics (Generically (..)) import Text.Megaparsec

@@ -15,8 +15,8 @@     ) where -import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generically (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON (..), ToJSON (..))  import Data.Map.Strict qualified as Map @@ -26,8 +26,7 @@  newtype Suites = Suites {getSuites :: Map TestTarget Suite}     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via Generically Suites-    deriving (Monoid, Semigroup) via Map TestTarget Suite+    deriving (FromJSON, Monoid, Semigroup, ToJSON) via Map TestTarget Suite   hasFailedTests :: Suites -> Bool@@ -58,7 +57,7 @@     | SuiteErrored SuiteError     | SuiteCompleted SuiteCompletion     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via (Generically Suite)+    deriving (FromJSON, ToJSON) via QuietSnake Suite   isFailedRun :: Suite -> Bool@@ -72,14 +71,14 @@     , total :: Int     }     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via Generically Progress+    deriving (FromJSON, ToJSON) via QuietSnake Progress   data Outcome     = Passed     | Failed Text     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via (Generically Outcome)+    deriving (FromJSON, ToJSON) via QuietSnake Outcome   data Case = Case@@ -87,7 +86,7 @@     , outcome :: Outcome     }     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via (Generically Case)+    deriving (FromJSON, ToJSON) via QuietSnake Case   caseFailed :: Case -> Bool@@ -99,7 +98,7 @@     { message :: Text     }     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via (Generically SuiteError)+    deriving (FromJSON, ToJSON) via QuietSnake SuiteError   data SuiteCompletion = SuiteCompletion@@ -109,4 +108,4 @@     , duration :: Maybe Duration     }     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via (Generically SuiteCompletion)+    deriving (FromJSON, ToJSON) via QuietSnake SuiteCompletion

@@ -1,6 +1,5 @@ module Tricorder.CLI.App (run) where -import Atelier.Effects.Cache (Cache) import Atelier.Effects.Clock (Clock) import Atelier.Effects.Conc (Conc) import Atelier.Effects.Console (Console)@@ -16,14 +15,13 @@ import Effectful (IOE) import Effectful.Concurrent (Concurrent) import Effectful.Reader.Static (Reader, ask, asks)-import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery)+import Tricorder.CLI.Command (Command (..), LogMode (..)) import Prelude hiding (force)  import Atelier.Effects.Console qualified as Console import Data.Text qualified as T import Tricorder.CLI.Command.Daemon qualified as DaemonCommand -import Tricorder.CLI.Arguments (Command (..), LogMode (..)) import Tricorder.CLI.Daemon     ( restartDaemon     , startDaemon@@ -43,23 +41,21 @@ import Tricorder.CLI.UI.BrickChan (BrickChan) import Tricorder.Daemon.DaemonInfo (DaemonInfo) import Tricorder.Runtime (LogPath (..), PidFile (..), SocketPath (..))+import Tricorder.Session.CabalFile (CabalFile) import Tricorder.Session.Repl (Repl) import Tricorder.Socket.Client (isDaemonRunning) import Tricorder.Socket.UnixSocket (UnixSocket)-import Tricorder.SourceLookup (ModuleSourceResult) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage)-import Tricorder.SourceLookup.PackageId (PackageId) import Tricorder.SourceLookup.PackageStore (PackageStore) +import Tricorder.CLI.App.Test qualified as Test import Tricorder.CLI.UI.Keys qualified as Keys   run     :: ( Brick :> es        , BrickChan :> es-       , Cache (PackageId, SourceQuery) ModuleSourceResult :> es-       , Cache ModuleName PackageId :> es        , Clock :> es        , Conc :> es        , Concurrent :> es@@ -74,6 +70,7 @@        , IOE :> es        , Input DaemonInfo :> es        , Input Repl :> es+       , Input [CabalFile] :> es        , Log :> es        , PackageStore :> es        , Process :> es@@ -118,13 +115,14 @@                     Console.putStrLn "Stopped."                 else                     showStatus opts-        Test opts -> do+        TestResults opts -> do             running <- isDaemonRunning             if not running                 then                     Console.putStrLn "Stopped."                 else                     showTests opts+        Test testCmd -> Test.run testCmd         Log logMode -> do             logFile <- asks @LogPath (.getLogPath)             case logMode of@@ -136,8 +134,8 @@                 startDaemon                 void waitForDaemon             viewUi-        Source moduleNames -> do-            showSource moduleNames+        Source opts -> do+            showSource opts         Restart force ->             restartDaemon force >>= \case                 Just (Left reasons) -> traverse_ Console.putTextLn reasons

@@ -0,0 +1,16 @@+{-# LANGUAGE UndecidableInstances #-}++module Tricorder.CLI.App.CLIResponse (CLIResponse (..)) where++import Data.Aeson (ToJSON)+import Data.Aeson.Text (encodeToLazyText)+++-- | This is effectively `Text.Show`, but for printing to the terminal.+class CLIResponse a where+    -- | Render the value in such a way that it displays nicely on a terminal.+    renderCLIResponse :: a -> LText+++instance (ToJSON a) => CLIResponse a where+    renderCLIResponse = encodeToLazyText

@@ -0,0 +1,57 @@+module Tricorder.CLI.App.Output+    ( Output (..)+    , TextOutput (..)+    , JsonOutput (..)+    )+where++import Data.Aeson (ToJSON)+import Data.Aeson.Text (encodeToLazyText)+import System.Exit (ExitCode)++import Tricorder.CLI.App.CLIResponse (CLIResponse (..))+++data Output a+    = Fail ExitCode LText+    | Output a+++instance Functor Output where+    fmap f = \case+        Fail exitCode reason -> Fail exitCode reason+        Output val -> Output $ f val+++instance Applicative Output where+    pure = Output+    Fail exitCode reason <*> _ = Fail exitCode reason+    _ <*> Fail exitCode reason = Fail exitCode reason+    Output f <*> Output a = Output $ f a+++instance Monad Output where+    Fail exitCode reason >>= _ = Fail exitCode reason+    Output a >>= f = f a+++instance (CLIResponse a) => CLIResponse (Output a) where+    renderCLIResponse = \case+        Fail _ reason -> "Error: " <> reason+        Output val -> renderCLIResponse val+++-- | Textual output to the terminal.+data TextOutput a = TextOutput a+++instance (CLIResponse a) => CLIResponse (TextOutput a) where+    renderCLIResponse (TextOutput val) = renderCLIResponse val+++-- | JSON output to the terminal.+data JsonOutput a = JsonOutput a+++instance (ToJSON a) => CLIResponse (JsonOutput a) where+    renderCLIResponse (JsonOutput val) = encodeToLazyText val

@@ -0,0 +1,145 @@+module Tricorder.CLI.App.Test (run) where++import Atelier.Effects.Console (Console)+import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Exit (Exit, exitFailure)+import Atelier.Effects.File (File)+import Atelier.Effects.Posix.Daemons (Daemons, PidFile)+import Effectful (IOE)+import Effectful.Reader.Static (Reader)+import Tricorder.CLI.Command.IfDaemonIsStopped (IfDaemonIsStopped)+import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))+import Tricorder.CLI.Command.Test (Command (..), SuitesOptions (..))+import Tricorder.CLI.Command.WaitMode (WaitMode (..))++import Atelier.Effects.Console qualified as Console+import Effectful.Reader.Static qualified as Reader+import Tricorder.CLI.Command.IfDaemonIsStopped qualified as IfDaemonIsStopped+import Tricorder.FieldMask.Schema qualified as FieldMask.Schema++import Tricorder.Build (BuildState (..))+import Tricorder.CLI.App.Test.SuiteView (defaultFields, schema)+import Tricorder.Runtime (SocketPath (..))+import Tricorder.Socket.Client (queryStatus, queryStatusWait)+import Tricorder.Socket.UnixSocket (UnixSocket)++import Tricorder.CLI.App.Test.Json qualified as Json+import Tricorder.CLI.App.Test.Text qualified as Text+import Tricorder.CLI.Daemon qualified as Daemons+import Tricorder.Session.TestTarget qualified as TestTarget+import Tricorder.Socket.Client qualified as Client+++run+    :: ( Console :> es+       , Daemons :> es+       , Delay :> es+       , Exit :> es+       , File :> es+       , IOE :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Command -> Eff es ()+run command =+    printResult =<< case command of+        Suites opts -> showSuites opts+++printResult :: (Console :> es, Exit :> es) => Either Text Text -> Eff es ()+printResult = \case+    Left err -> do+        Console.putTextLn err+        exitFailure+    Right res ->+        Console.putTextLn res+++showSuites+    :: ( Daemons :> es+       , Delay :> es+       , File :> es+       , IOE :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => SuitesOptions -> Eff es (Either Text Text)+showSuites opts =+    case validated of+        Left err -> pure $ case opts.format of+            TextOutput -> Left $ "Error: " <> err+            JsonOutput -> Json.argumentError err+        Right (targets, selection) ->+            ensureDaemonRunning opts.ifDaemonIsStopped do+                result <- awaitBuildStatus opts.wait+                case opts.format of+                    TextOutput ->+                        pure+                            $ Text.wrapTextShow result+                            $ Text.showBasePhase+                            $ Text.showSuites targets opts.testFilter selection+                    JsonOutput ->+                        pure+                            $ Json.wrapResponse+                            $ Json.showBasePhase result+                            $ Json.showSuites targets opts.testFilter selection+  where+    validated = do+        targets <- traverse parseTarget opts.suiteNames+        selection <- FieldMask.Schema.select schema $ fromMaybe defaultFields opts.fields+        pure (targets, selection)+    parseTarget suiteName =+        maybeToRight+            ( "invalid test suite name: "+                <> suiteName+                <> ". Test suite names are expected to be in the format of a Cabal target."+            )+            $ TestTarget.parse suiteName+++awaitBuildStatus+    :: ( File :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => WaitMode -> Eff es (Either Text BuildState)+awaitBuildStatus wait = do+    SocketPath sockPath <- Reader.ask+    case wait of+        WaitForBuild -> queryStatusWait sockPath+        ShowCurrent -> queryStatus sockPath+++ensureDaemonRunning+    :: ( Daemons :> es+       , Delay :> es+       , IOE :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => IfDaemonIsStopped -> Eff es (Either Text Text) -> Eff es (Either Text Text)+ensureDaemonRunning ifDaemonIsStopped continue = do+    isRunning <- Client.isDaemonRunning+    case (ifDaemonIsStopped, isRunning) of+        (IfDaemonIsStopped.Fail, False) -> pure $ Left "daemon is stopped"+        (IfDaemonIsStopped.StartDaemon, False) -> do+            ensureDaemonIsRunning+            continue+        (_, True) -> continue+++ensureDaemonIsRunning+    :: ( Daemons :> es+       , Delay :> es+       , IOE :> es+       , Reader PidFile :> es+       , Reader SocketPath :> es+       , UnixSocket :> es+       )+    => Eff es ()+ensureDaemonIsRunning = do+    Daemons.startDaemon+    void Daemons.waitForDaemon

@@ -0,0 +1,63 @@+module Tricorder.CLI.App.Test.Json+    ( showSuites+    , wrapResponse+    , showBasePhase+    , argumentError+    )+where++import Data.Aeson (ToJSON, toJSON)+import Data.Aeson.Text (encodeToLazyText)+import Tricorder.CLI.Command.TestFilter (TestFilter)++import Data.Text qualified as T+import Tricorder.FieldMask.Projection qualified as FieldMask.Projection+import Tricorder.FieldMask.Schema qualified as FieldMask (Schema)++import Tricorder.Build (BuildPhase (..), BuildState (..), PostBuild (..))+import Tricorder.CLI.App.Test.Json.Responses+    ( MessageWithLoc (..)+    , Response (..)+    , SuitesResponse (..)+    )+import Tricorder.CLI.App.Test.SuiteView (selectSuites)+import Tricorder.Session.TestTarget (TestTarget)++import Tricorder.Build.Test qualified as Test+import Tricorder.CLI.App.Test.Json.Responses qualified as Responses+import Tricorder.Session.TestTarget qualified as TestTarget+++showSuites+    :: [TestTarget] -> TestFilter -> FieldMask.Schema -> Test.Suites -> Response SuitesResponse+showSuites targets testFilter selection testSuites =+    case selectSuites targets testFilter testSuites of+        Left notFound ->+            Responses.Error+                $ MessageWithLoc (T.intercalate ", " $ TestTarget.render <$> toList notFound) "not found"+        Right suites -> Responses.Success $ SuitesResponse $ FieldMask.Projection.project selection . toJSON <$> suites+++wrapResponse :: (ToJSON a) => Response a -> Either Text Text+wrapResponse resp = case resp of+    Responses.Error _ -> Left $ toStrict $ encodeToLazyText resp+    _ -> Right $ toStrict $ encodeToLazyText resp+++-- | Report invalid arguments given to a command.+argumentError :: Text -> Either Text Text+argumentError err = wrapResponse @() $ Responses.Error $ MessageWithLoc "arguments" err+++showBasePhase :: Either Text BuildState -> (Test.Suites -> Response a) -> Response a+showBasePhase result mkResponse = case result of+    Left err -> Responses.Error $ MessageWithLoc "build" err+    Right build -> case build.phase of+        Starting -> Responses.Pending $ MessageWithLoc "build" "starting"+        Building _ _ -> Responses.Pending $ MessageWithLoc "build" "building"+        PostBuilding _ postBuild+            | Test.anyRunningTests postBuild.testSuites ->+                Responses.Pending $ MessageWithLoc "postBuild" "testing"+            | otherwise -> mkResponse postBuild.testSuites+        Finished _ postBuild -> mkResponse postBuild.testSuites+        Failed reason -> Responses.Error $ MessageWithLoc "build" $ "build failed: " <> reason

@@ -0,0 +1,79 @@+module Tricorder.CLI.App.Test.Json.Responses+    ( Response (..)+    , MessageWithLoc (..)+    , SuitesResponse (..)+    )+where++import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Data.Aeson+    ( FromJSON+    , Options (..)+    , SumEncoding (..)+    , ToJSON (..)+    , defaultOptions+    , genericToEncoding+    , genericToJSON+    , object+    , pairs+    , (.=)+    )+import Text.Casing (quietSnake)++import Tricorder.FieldMask.Projection qualified as FieldMask (Projection)+++data Response a+    = Error MessageWithLoc+    | Pending MessageWithLoc+    | Success a+    deriving stock (Eq, Functor, Generic, Show)+++instance Applicative Response where+    pure = Success+    Error message <*> _ = Error message+    _ <*> Error message = Error message+    Pending message <*> _ = Pending message+    _ <*> Pending message = Pending message+    Success f <*> Success a = Success $ f a+++instance Monad Response where+    Error message >>= _ = Error message+    Pending message >>= _ = Pending message+    Success a >>= f = f a+++instance (ToJSON a) => ToJSON (Response a) where+    toJSON = genericToJSON responseOptions+    toEncoding = genericToEncoding responseOptions+++data MessageWithLoc = MessageWithLoc+    { location :: Text+    , message :: Text+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via QuietSnake MessageWithLoc+++responseOptions :: Options+responseOptions =+    defaultOptions+        { constructorTagModifier = quietSnake+        , sumEncoding = ObjectWithSingleField+        }+++-- | Test suites, cut down to the requested fields.+newtype SuitesResponse = SuitesResponse+    { suites :: [FieldMask.Projection]+    }+    deriving stock (Eq, Show)+++-- | Written by hand so 'toEncoding' keeps the field order of the projection.+instance ToJSON SuitesResponse where+    toJSON response = object ["suites" .= response.suites]+    toEncoding response = pairs ("suites" .= response.suites)

@@ -0,0 +1,154 @@+-- | The full, unprojected view of a test suite that @tricorder test suites@+-- selects fields from.+module Tricorder.CLI.App.Test.SuiteView+    ( SuiteView (..)+    , Status (..)+    , CaseView (..)+    , Outcome (..)+    , schema+    , defaultFields+    , selectSuites+    )+where++import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Data.Aeson (ToJSON (..))+import Tricorder.CLI.Command.TestFilter (TestFilter)+import Tricorder.FieldMask (Field (..), FieldMask (..))++import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Tricorder.CLI.Command.TestFilter qualified as TestFilter+import Tricorder.FieldMask.Schema qualified as FieldMask (Schema (..))+import Tricorder.FieldMask.Schema qualified as FieldMask.Schema++import Tricorder.Build.Duration (Duration)+import Tricorder.Session.TestTarget (TestTarget)+import Tricorder.TestOutput (stripGhciNoise)++import Tricorder.Build.Test qualified as Test+import Tricorder.Session.TestTarget qualified as TestTarget+++-- | Fields that do not apply to a suite's 'Status' are 'Nothing', and are+-- left out of the output.+data SuiteView = SuiteView+    { name :: Text+    , status :: Status+    , error :: Maybe Text+    , passedCases :: Maybe Int+    , totalCases :: Maybe Int+    , durationMs :: Maybe Duration+    , output :: Maybe Text+    , cases :: Maybe [CaseView]+    }+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake SuiteView+++data Status = Running | Errored | Passed | Failed+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake Status+++data CaseView = CaseView+    { description :: Text+    , outcome :: Outcome+    , failure :: Maybe Text+    }+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake CaseView+++data Outcome = CasePassed | CaseFailed+    deriving stock (Eq, Generic, Show)+++instance ToJSON Outcome where+    toJSON = \case+        CasePassed -> "passed"+        CaseFailed -> "failed"+++-- | Every field of a 'SuiteView', as named in its JSON encoding.+schema :: FieldMask.Schema+schema =+    FieldMask.Schema+        [ FieldMask.Schema.leaf "name"+        , FieldMask.Schema.leaf "status"+        , FieldMask.Schema.leaf "error"+        , FieldMask.Schema.leaf "passed_cases"+        , FieldMask.Schema.leaf "total_cases"+        , FieldMask.Schema.leaf "duration_ms"+        , FieldMask.Schema.leaf "output"+        , FieldMask.Schema.nested+            "cases"+            [ FieldMask.Schema.leaf "description"+            , FieldMask.Schema.leaf "outcome"+            , FieldMask.Schema.leaf "failure"+            ]+        ]+++-- | A summary of each suite, leaving out the (potentially large) test output+-- and test cases.+defaultFields :: FieldMask+defaultFields =+    FieldMask+        $ (\name -> Field name Nothing)+            <$> "name" :| ["status", "error", "passed_cases", "total_cases", "duration_ms"]+++-- | Pick out the requested suites, or all of them when none are requested.+-- Fails with the requested suites that do not exist.+--+-- 'TestFilter.FailedOnly' keeps only failed suites, and only the failed test+-- cases within them.+selectSuites+    :: [TestTarget] -> TestFilter -> Test.Suites -> Either (NonEmpty TestTarget) [SuiteView]+selectSuites requested testFilter (Test.Suites suites) = do+    selected <- case requested of+        [] -> Right $ Map.toList suites+        _ -> case nonEmpty missing of+            Just notFound -> Left notFound+            Nothing -> Right [(target, suite) | target <- ordNub requested, Just suite <- [Map.lookup target suites]]+    pure $ uncurry toView <$> filter (keepSuite . snd) selected+  where+    missing = filter (`Map.notMember` suites) requested++    keepSuite suite = case testFilter of+        TestFilter.FailedOnly -> Test.isFailedRun suite+        TestFilter.All -> True++    keepCase testCase = case testFilter of+        TestFilter.FailedOnly -> Test.caseFailed testCase+        TestFilter.All -> True++    toView target suite =+        let view =+                SuiteView+                    { name = TestTarget.render target+                    , status = Running+                    , error = Nothing+                    , passedCases = Nothing+                    , totalCases = Nothing+                    , durationMs = Nothing+                    , output = Nothing+                    , cases = Nothing+                    }+        in  case suite of+                Test.SuiteRunning _ -> view+                Test.SuiteErrored err -> view {status = Errored, error = Just err.message}+                Test.SuiteCompleted completion ->+                    view+                        { status = if completion.passed then Passed else Failed+                        , passedCases = Just $ length $ filter (not . Test.caseFailed) completion.testCases+                        , totalCases = Just $ length completion.testCases+                        , durationMs = completion.duration+                        , output = Just $ T.unlines $ stripGhciNoise $ T.lines completion.output+                        , cases = Just $ toCaseView <$> filter keepCase completion.testCases+                        }++    toCaseView testCase = case testCase.outcome of+        Test.Passed -> CaseView testCase.description CasePassed Nothing+        Test.Failed reason -> CaseView testCase.description CaseFailed (Just reason)

@@ -0,0 +1,99 @@+module Tricorder.CLI.App.Test.Text+    ( showSuites+    , wrapTextShow+    , showBasePhase+    )+where++import Data.Aeson (toJSON)+import Tricorder.CLI.Command.TestFilter (TestFilter)++import Data.Text qualified as T+import Tricorder.CLI.Command.TestFilter qualified as TestFilter+import Tricorder.FieldMask.Projection qualified as FieldMask.Projection+import Tricorder.FieldMask.Schema qualified as FieldMask++import Tricorder.Build+    ( BuildPhase (..)+    , BuildProgress (..)+    , BuildResult (..)+    , BuildState (..)+    , Diagnostic (..)+    , PostBuild (..)+    , Severity (..)+    )+import Tricorder.CLI.App.Test.SuiteView (selectSuites)+import Tricorder.Session.TestTarget (TestTarget)++import Tricorder.Build.Test qualified as Test+import Tricorder.Session.TestTarget qualified as TestTarget+++showSuites :: [TestTarget] -> TestFilter -> FieldMask.Schema -> Test.Suites -> Either Text Text+showSuites targets testFilter selection testSuites =+    case selectSuites targets testFilter testSuites of+        Left notFound ->+            Left $ "test suites not found: " <> T.intercalate ", " (TestTarget.render <$> toList notFound)+        Right []+            | Test.nullSuites testSuites -> Right "no test suites to run"+            | TestFilter.FailedOnly <- testFilter -> Right "no failed test suites"+        Right suites ->+            Right+                $ T.stripEnd+                $ FieldMask.Projection.renderYaml+                $ FieldMask.Projection.PArray+                $ FieldMask.Projection.project selection . toJSON <$> suites+++wrapTextShow :: Either Text BuildState -> (BuildPhase -> Either Text Text) -> Either Text Text+wrapTextShow = \case+    Left err -> const $ Left $ "Error: " <> err+    Right build -> ($ build.phase)+++showBasePhase :: (Test.Suites -> Either Text Text) -> BuildPhase -> Either Text Text+showBasePhase showTests = \case+    Starting -> Right "Starting..."+    Building _ progress ->+        Right+            $ mconcat+                [ "Building ("+                , show progress.compiled+                , "/"+                , show progress.total+                , ")..."+                ]+    PostBuilding result postBuild+        | buildFailed result postBuild ->+            Left $ "build failed before tests ran"+        | Test.anyRunningTests postBuild.testSuites ->+            Right $ showTestProgress postBuild.testSuites+        | otherwise ->+            showTests postBuild.testSuites+    Finished result postBuild+        | buildFailed result postBuild ->+            Left $ "build failed before tests ran"+        | otherwise ->+            showTests postBuild.testSuites+    Failed err -> Left $ "Build failed: " <> err+  where+    buildFailed result postBuild = postBuild.testSuites == mempty && any (\d -> d.severity >= SError) result.diagnostics+++showTestProgress :: Test.Suites -> Text+showTestProgress suites =+    mconcat+        [ "Testing (test suites finished: "+        , show+            $ length+            $ filter+                ( \case+                    Test.SuiteCompleted _ -> True+                    Test.SuiteErrored _ -> True+                    _ -> False+                )+            $ toList suites.getSuites+        , "/"+        , show $ length $ suites.getSuites+        , ")"+        ]

@@ -1,12 +1,5 @@ module Tricorder.CLI.Arguments-    ( Command (..)-    , LogMode (..)-    , StatusOptions (..)-    , TestOptions (..)-    , EvalCommentsOptions (..)-    , Verbosity (..)-    , WaitMode (..)-    , parseArguments+    ( parseArguments     , runArguments     ) where@@ -33,6 +26,8 @@     , metavar     , option     , progDesc+    , progDescDoc+    , readerError     , short     ) import Tricorder.CLI.Command@@ -40,15 +35,21 @@     , EvalCommentsOptions (..)     , Force (..)     , LogMode (..)+    , SourceOptions (..)     , StatusOptions (..)     , TestOptions (..)     , Verbosity (..)-    , WaitMode (..)     ) import Tricorder.SourceLookup.SourceQuery (SourceQuery, parseSourceQuery) +import Options.Applicative.Help.Pretty qualified as Doc++import Tricorder.SourceLookup (ReexportLimits (..), defaultReexportLimits)+ import Tricorder.CLI.Arguments.Daemon qualified as Daemon import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat+import Tricorder.CLI.Arguments.Test qualified as Test+import Tricorder.CLI.Arguments.WaitMode qualified as WaitMode import Tricorder.Version qualified as Version  @@ -82,12 +83,23 @@             <> 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+                "test-results"+                ( info+                    testResultsParser+                    ( progDescDoc+                        $ Just+                        $ "Show output from the latest test run"+                            <> Doc.line+                            <> Doc.annotate Doc.bold "DEPRECATED: use the `test suites` subcommand"+                    )+                )+            <> command "test" (Test <$> Test.parser)             <> command "ui" (info (pure UI) (progDesc "Auto-refreshing terminal display"))             <> command "log" (info logParser (progDesc "Show daemon log output"))             <> command                 "source"-                (info sourceParser (progDesc "Print the Haskell source of one or more installed modules"))+                (info sourceParser (progDesc "Print the Haskell source of one or more project or installed modules"))             <> command "restart" (info restartParser (progDesc "Restart the daemon"))             <> command                 "eval-comments"@@ -113,7 +125,7 @@ statusParser =     Status         <$> ( StatusOptions-                <$> waitParser+                <$> WaitMode.parser                 <*> OutputFormat.parser                 <*> flag                     Concise@@ -133,9 +145,9 @@             )  -testParser :: Parser Command-testParser =-    Test+testResultsParser :: Parser Command+testResultsParser =+    TestResults         <$> ( TestOptions                 <$> flag                     False@@ -143,14 +155,48 @@                     ( long "failed"                         <> help "Only show output from failed test suites"                     )-                <*> waitParser+                <*> WaitMode.parser             )   sourceParser :: Parser Command sourceParser =     Source-        <$> some (argument queryReader (metavar "MODULE[#FUNCTION]" <> help "Module or Module#function"))+        <$> ( SourceOptions+                <$> some+                    ( argument+                        queryReader+                        (metavar "Module[#function]" <> help "Module or Module#function")+                    )+                <*> optional+                    ( option+                        nonNegative+                        ( long "max-depth"+                            <> metavar "N"+                            <> help+                                ( "Follow at most N re-export hops when a symbol is not defined in the queried module (default: "+                                    <> show defaultReexportLimits.maxDepth+                                    <> ")"+                                )+                        )+                    )+                <*> optional+                    ( option+                        nonNegative+                        ( long "max-modules"+                            <> metavar "N"+                            <> help+                                ( "Read at most N modules while following re-exports (default: "+                                    <> show defaultReexportLimits.maxModules+                                    <> ")"+                                )+                        )+                    )+            )+  where+    nonNegative = do+        n <- auto+        if n < 0 then readerError "must be a non-negative integer" else pure n   stopParser :: Parser Command@@ -171,19 +217,9 @@ evalCommentsParser =     EvalComments         <$> ( EvalCommentsOptions-                <$> waitParser+                <$> WaitMode.parser                 <*> OutputFormat.parser             )---waitParser :: Parser WaitMode-waitParser =-    flag-        ShowCurrent-        WaitForBuild-        ( long "wait"-            <> help "Block until the current build cycle completes"-        )   queryReader :: ReadM SourceQuery

@@ -0,0 +1,14 @@+module Tricorder.CLI.Arguments.IfDaemonIsStopped (parser) where++import Options.Applicative (Parser, flag, help, long, short)+import Tricorder.CLI.Command.IfDaemonIsStopped (IfDaemonIsStopped (..), startDaemonFlagName)+++parser :: Parser IfDaemonIsStopped+parser =+    flag+        Fail+        StartDaemon+        $ long startDaemonFlagName+            <> short 'd'+            <> help "Start the daemon if it is not already running."

@@ -1,7 +1,7 @@ module Tricorder.CLI.Arguments.OutputFormat (parser) where -import Options.Applicative (Parser, flag, help, long)-import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))+import Options.Applicative (Parser, flag, help, long, short)+import Tricorder.CLI.Command.OutputFormat (OutputFormat (..), jsonOutputFlagName)   parser :: Parser OutputFormat@@ -9,4 +9,6 @@     flag         TextOutput         JsonOutput-        $ long "json" <> help "Output full build state as JSON"+        $ long jsonOutputFlagName+            <> short 'j'+            <> help "Output full build state as JSON"

@@ -0,0 +1,106 @@+module Tricorder.CLI.Arguments.Test (parser) where++import Options.Applicative+    ( Parser+    , ParserInfo+    , command+    , footer+    , help+    , helpDoc+    , hsubparser+    , info+    , metavar+    , progDesc+    , strArgument+    )+import Tricorder.CLI.Command.Test (Command, SuitesOptions (..))++import Data.Text qualified as T+import Options.Applicative.Help.Pretty qualified as Doc+import Tricorder.CLI.Command.Test qualified as Test+import Tricorder.FieldMask qualified as FieldMask+import Tricorder.FieldMask.Args qualified as FieldMask.Args+import Tricorder.FieldMask.Schema qualified as FieldMask (Schema (..))++import Tricorder.CLI.App.Test.SuiteView qualified as SuiteView+import Tricorder.CLI.Arguments.IfDaemonIsStopped qualified as IfDaemonIsStopped+import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat+import Tricorder.CLI.Arguments.TestFilter qualified as TestFilter+import Tricorder.CLI.Arguments.WaitMode qualified as WaitMode+++parser :: ParserInfo Command+parser =+    info commandParser (progDesc "See statuses and information on configured test suites.")+++commandParser :: Parser Command+commandParser =+    hsubparser+        $ command+            "suites"+            ( info+                suitesParser+                ( progDesc "Show test suites, their test cases and output."+                    <> footer suitesFooter+                )+            )+++suitesParser :: Parser Command+suitesParser =+    fmap Test.Suites+        $ SuitesOptions+            <$> many (strArgument (metavar "TEST-TARGET..." <> help "Test suites to show (default: all)"))+            <*> TestFilter.parser (help "Show only failed test suites, and only their failed test cases")+            <*> FieldMask.Args.parser+                ( helpDoc+                    $ Just+                    $ (<> Doc.line)+                    $ mconcat+                    $ Doc.punctuate+                        (Doc.line <> Doc.line)+                        [ "Fields to return for each test suite."+                        , "Available fields:"+                            <> Doc.line+                            <> Doc.indent 4 (Doc.vsep $ renderSchema SuiteView.schema)+                        , "Select nested fields with parentheses,"+                            <> Doc.line+                            <> "e.g. --fields 'name,cases(description,failure)'."+                            <> Doc.line+                            <> "A field without parentheses shows all of its nested fields."+                        , "Default fields:"+                            <> Doc.line+                            <> Doc.pretty (FieldMask.render SuiteView.defaultFields)+                        ]+                )+            <*> OutputFormat.parser+            <*> WaitMode.parser+            <*> IfDaemonIsStopped.parser+  where+    renderSchema (FieldMask.Schema fields) = renderField <$> fields+    renderField (name, sub) =+        Doc.pretty name+            <> maybe+                Doc.emptyDoc+                ( \nestedSchema ->+                    Doc.enclose+                        "("+                        ")"+                        $ Doc.sep+                        $ Doc.punctuate ","+                        $ renderSchema nestedSchema+                )+                sub+++suitesFooter :: String+suitesFooter =+    toString+        $ "Available fields:\n"+            <> renderSchema SuiteView.schema+            <> "\nSelect nested fields with parentheses, e.g. --fields 'name,cases(description,failure)'."+            <> " A field without parentheses shows all of its nested fields."+  where+    renderSchema (FieldMask.Schema fields) = T.intercalate ", " $ renderField <$> fields+    renderField (name, sub) = name <> maybe "" (\nestedSchema -> "(" <> renderSchema nestedSchema <> ")") sub

@@ -0,0 +1,17 @@+module Tricorder.CLI.Arguments.TestFilter (parser) where++import Options.Applicative (FlagFields, Mod, Parser, flag, long, short)+import Tricorder.CLI.Command.TestFilter+    ( TestFilter (..)+    , failedOnlyFlagName+    , failedOnlyFlagShortName+    )+import Prelude hiding (All (..))+++parser :: Mod FlagFields TestFilter -> Parser TestFilter+parser extraMods =+    flag All FailedOnly+        $ long failedOnlyFlagName+            <> short failedOnlyFlagShortName+            <> extraMods

@@ -0,0 +1,12 @@+module Tricorder.CLI.Arguments.WaitMode (parser) where++import Options.Applicative (Parser, flag, help, long, short)+import Tricorder.CLI.Command.WaitMode (WaitMode (..), waitForBuildFlagName)+++parser :: Parser WaitMode+parser =+    flag ShowCurrent WaitForBuild+        $ long waitForBuildFlagName+            <> short 'w'+            <> help "Block until the current build cycle completes"

@@ -1,16 +1,14 @@ module Tricorder.CLI.Main (main) where -import Atelier.Config (runConfig) import Atelier.Effects.Arguments (runArgumentsIO) import Atelier.Effects.Clock (runClock) import Atelier.Effects.Conc (runConc)-import Atelier.Effects.Console (runConsole)+import Atelier.Effects.Console (Console, runConsole, runConsoleHandle) import Atelier.Effects.Delay (runDelay) import Atelier.Effects.Env (runEnv)-import Atelier.Effects.Exit (runExit)+import Atelier.Effects.Exit (exitFailure, runExit) import Atelier.Effects.File (runFile) import Atelier.Effects.FileSystem (runFileSystemIO)-import Atelier.Effects.Input (input, runInputEff) import Atelier.Effects.Log (runLogNoOp) import Atelier.Effects.Posix.Daemons (runDaemons) import Atelier.Effects.Process (runProcessIO)@@ -19,30 +17,29 @@ import Data.Default (def) import Effectful (runEff) import Effectful.Concurrent (runConcurrent)-import Effectful.Reader.Static (runReader)-import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery)+import Effectful.Provider (provideWith_, runProvider_)+import System.IO (stderr) -import Atelier.Effects.Cache qualified as Cache-import Atelier.Effects.Cache qualified as CacheConfig+import Atelier.Effects.Console qualified as Console import Atelier.Effects.FileSystem.Glob qualified as Glob+import Atelier.Effects.Input qualified as Input  import Tricorder.CLI.Arguments (runArguments) import Tricorder.CLI.UI.Brick (runBrick) import Tricorder.CLI.UI.BrickChan (runBrickChan)-import Tricorder.Config (inputLoadedConfig, runLoadedConfig)+import Tricorder.Config (asInput) import Tricorder.Runtime (runLogPath, runPidFile, runProjectRoot, runRuntimeDir, runSocketPath)-import Tricorder.Session (Session (..), loadSession) import Tricorder.Session.CabalFile (inputCabalFiles) import Tricorder.Session.CommandTemplate (CommandTemplate (..)) import Tricorder.Session.Stage.Build.Session (BuildSession (..))-import Tricorder.Socket.UnixSocket (runUnixSocketIO)-import Tricorder.SourceLookup.PackageId (PackageId)  import Tricorder.CLI.App qualified as App import Tricorder.CLI.UI.Keys qualified as Keys+import Tricorder.Config.LoadedConfig qualified as LoadedConfig import Tricorder.Daemon.DaemonInfo qualified as DaemonInfo+import Tricorder.Session qualified as Session import Tricorder.Session.StackProject qualified as StackProject-import Tricorder.SourceLookup qualified as SourceLookup+import Tricorder.Socket.UnixSocket qualified as UnixSocket import Tricorder.SourceLookup.GhcPkg qualified as GhcPkg import Tricorder.SourceLookup.Hackage qualified as Hackage import Tricorder.SourceLookup.PackageStore qualified as PackageStore@@ -57,6 +54,7 @@         . runBrickChan         . runBrick         . runConsole+        . runProvider_ runConsoleHandle         . runExit         . runClock         . runDelay@@ -68,27 +66,34 @@         . runPidFile         . runSocketPath         . runLogPath-        . runLoadedConfig-        . runConfig @"keybindings" @Keys.Config+        . LoadedConfig.asInput+        . LoadedConfig.asNestedInput @"keybindings" @Keys.Config+        . Input.map (either @_ @Keys.Config (const def) id)+        . Input.toReader @Keys.Config         . runDaemons         . runProcessIO         . runArgumentsIO         . runArguments-        . runUnixSocketIO+        . UnixSocket.runIO         . runEnv-        . inputLoadedConfig         . runLogNoOp         . StackProject.inputWithCache         . inputCabalFiles-        . runInputEff loadSession-        . runInputEff ((.buildSession.commandTemplate.repl) <$> input)-        . runReader @CacheConfig.Config def-        . Cache.runCacheTtl @ModuleName @PackageId-        . Cache.runCacheTtl @(PackageId, SourceQuery) @SourceLookup.ModuleSourceResult-        . GhcPkg.runGhcPkgIO-        . PackageStore.run-        . Hackage.run-        . DaemonInfo.runInput+        . Tricorder.Config.asInput         $ do-            installTerminationHandler-            App.run+            Session.load >>= \case+                Left err -> do+                    provideWith_ @Console stderr+                        $ Console.putTextLn+                        $ "Failed to load session: " <> err+                    exitFailure+                Right session ->+                    Input.withConst session+                        . Input.withConst session.buildSession.commandTemplate.repl+                        . GhcPkg.runGhcPkgIO+                        . PackageStore.run+                        . Hackage.run+                        . DaemonInfo.runInput+                        $ do+                            installTerminationHandler+                            App.run

@@ -8,20 +8,26 @@     ) where -import Atelier.Effects.Cache (Cache) import Atelier.Effects.Clock (Clock, currentTimeZone) import Atelier.Effects.Console (Console) import Atelier.Effects.Exit (Exit, exitFailure) import Atelier.Effects.File (File) import Atelier.Effects.FileSystem (FileSystem, doesFileExist, readFileLbs)-import Atelier.Effects.Input (Input)+import Atelier.Effects.Input (Input, input) import Atelier.Effects.Log (Log) import Data.Aeson (ToJSON, encode) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime (utcToLocalTime) import Effectful.Reader.Static (Reader, ask)+import Tricorder.CLI.Command+    ( EvalCommentsOptions (..)+    , SourceOptions (..)+    , StatusOptions (..)+    , TestOptions (..)+    , Verbosity (..)+    ) import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))-import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery)+import Tricorder.CLI.Command.WaitMode (WaitMode (..))  import Atelier.Effects.Console qualified as Console import Data.ByteString.Lazy qualified as BSL@@ -31,13 +37,6 @@ import Tricorder.Build (BuildState (..), Severity (..)) import Tricorder.Build.Duration (Duration (..)) import Tricorder.Build.Test (Suites (..))-import Tricorder.CLI.Arguments-    ( EvalCommentsOptions (..)-    , StatusOptions (..)-    , TestOptions (..)-    , Verbosity (..)-    , WaitMode (..)-    ) import Tricorder.CLI.Render     ( diagnosticLineIndexed     , formatDuration@@ -45,13 +44,18 @@     ) import Tricorder.Daemon.DaemonInfo (DaemonInfo (..)) import Tricorder.Runtime (SocketPath (..))+import Tricorder.Session.CabalFile (CabalFile) import Tricorder.Session.Repl (Repl) import Tricorder.Socket.Client (queryStatus, queryStatusWait) import Tricorder.Socket.UnixSocket (UnixSocket)-import Tricorder.SourceLookup (ModuleSourceResult, lookupModuleSource)+import Tricorder.SourceLookup+    ( ReexportLimits (..)+    , defaultReexportLimits+    , lookupModuleSource+    , projectSourceDirs+    ) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage)-import Tricorder.SourceLookup.PackageId (PackageId) import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.TestOutput (stripGhciNoise) @@ -262,21 +266,27 @@   showSource-    :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es-       , Cache ModuleName PackageId :> es-       , Console :> es+    :: ( Console :> es        , FileSystem :> es        , GhcPkg :> es        , Hackage :> es        , Input Repl :> es+       , Input [CabalFile] :> es        , Log :> es        , PackageStore :> es        )-    => [SourceQuery]+    => SourceOptions     -> Eff es ()-showSource queries = do-    results <- mapM lookupModuleSource queries+showSource opts = do+    dirs <- projectSourceDirs <$> input+    results <- mapM (lookupModuleSource dirs limits) opts.queries     renderSourceResults results+  where+    limits =+        ReexportLimits+            { maxDepth = fromMaybe defaultReexportLimits.maxDepth opts.maxDepth+            , maxModules = fromMaybe defaultReexportLimits.maxModules opts.maxModules+            }   showEvalComments

@@ -59,11 +59,16 @@         when (length results > 1) $ Console.putTextLn $ header query         Console.putText src         when (length results > 1) $ Console.putStrLn ""+    renderOne (SourceReexported query definedIn src) = do+        when (length results > 1) $ Console.putTextLn $ header query+        Console.putTextLn $ "-- Re-exported from " <> unModuleName definedIn+        Console.putText src+        when (length results > 1) $ Console.putStrLn ""     renderOne (SourceNotFound query) =         Console.putTextLn             $ "Not found: "                 <> unModuleName query.moduleName-                <> " (module not in any installed package)"+                <> " (module not in the project or any installed package)"     renderOne (SourceUnavailable query pkgId) =         Console.putTextLn             $ "No source available: "

@@ -7,11 +7,12 @@ import Atelier.Effects.Conc (Conc) import Atelier.Effects.Console (Console) import Atelier.Effects.Delay (Delay)+import Atelier.Effects.Exit (Exit) import Atelier.Effects.File (File) import Atelier.Effects.Process (Process, getExecutablePath, proc, runProcess)-import Brick (App (..), neverShowCursor)+import Brick (App (..), EventM, neverShowCursor) import Brick.BChan (BChan, writeBChanNonBlocking)-import Brick.Keybindings (KeyConfig)+import Brick.Keybindings (KeyConfig, KeyDispatcher) import Effectful.Concurrent (Concurrent) import Effectful.Concurrent.STM (TVar, atomically, newTVarIO, readTVarIO, writeTVar) import Effectful.Exception (bracket_, trySync)@@ -23,7 +24,7 @@ import Tricorder.CLI.UI.Brick (Brick) import Tricorder.CLI.UI.BrickChan (BrickChan) import Tricorder.CLI.UI.Event (Event (..), handleEvent)-import Tricorder.CLI.UI.Keys (KeyEvent, dispatcher)+import Tricorder.CLI.UI.Keys (KeyEvent, mkDispatcher) import Tricorder.CLI.UI.State (State (..), Viewports (..)) import Tricorder.CLI.UI.View (mkAttrMap, view) import Tricorder.Runtime (SocketPath (..))@@ -47,6 +48,7 @@        , Concurrent :> es        , Console :> es        , Delay :> es+       , Exit :> es        , File :> es        , Process :> es        , Reader Keys.Config :> es@@ -71,10 +73,11 @@         _ <- Conc.fork $ restartWorker restartChan restarting         keyConfig <- Keys.mkKeyConfig         let requestRestart = void $ writeBChanNonBlocking restartChan ()+        dispatcher <- mkDispatcher requestRestart keyConfig         void             $ Brick.runBrickApp                 chan-                (watchApp requestRestart keyConfig)+                (watchApp keyConfig dispatcher)                 initialState  @@ -109,12 +112,15 @@             void waitForDaemon  -watchApp :: IO () -> KeyConfig KeyEvent -> App State Event Viewports-watchApp requestRestart kc =+watchApp+    :: KeyConfig KeyEvent+    -> KeyDispatcher KeyEvent (EventM Viewports State)+    -> App State Event Viewports+watchApp keyConfig dispatcher =     App-        { appDraw = view kc-        , appHandleEvent = handleEvent $ dispatcher requestRestart kc+        { appDraw = view keyConfig dispatcher+        , appChooseCursor = neverShowCursor+        , appHandleEvent = handleEvent dispatcher         , appStartEvent = pure ()         , appAttrMap = mkAttrMap-        , appChooseCursor = neverShowCursor         }

@@ -1,15 +1,15 @@ module Tricorder.CLI.UI.Keys-    ( KeyEvent+    ( KeyEvent (..)     , Config     , keys-    , dispatcher+    , mkDispatcher     , viewKeybindings     , mkKeyConfig-    , keybindForRoute     ) where  import Atelier.Effects.Console (Console)+import Atelier.Effects.Exit (Exit, exitFailure) import Brick     ( EventM     , Widget@@ -39,16 +39,13 @@     , onEvent     , parseBindingList     )-import Brick.Keybindings.KeyConfig (firstActiveBinding) import Brick.Keybindings.Pretty (ppBinding) import Brick.Widgets.Core (hBox) import Control.Monad.State (gets, modify) import Data.Aeson (FromJSON (..)) import Data.Default (Default (..))-import Effectful.Exception (throwIO) import Effectful.Reader.Static (Reader, ask) import Graphics.Vty (Key (..))-import System.IO.Error (userError) import Text.Casing (quietSnake)  import Atelier.Effects.Console qualified as Console@@ -57,14 +54,12 @@ import Data.Text qualified as T  import Tricorder.CLI.UI.Misc (warn)-import Tricorder.CLI.UI.Route (Route) import Tricorder.CLI.UI.State     ( Processed (Waiting)     , State (..)     , Viewports (..)     , currentRoute     , cycleTestFilter-    , navigate     , viewToViewport     ) @@ -77,11 +72,11 @@ -- 'KeyEvent', update that list to match — @tagref check@ flags the dangling -- reference if this tag is renamed or dropped without touching the docs. data KeyEvent-    = ToggleHelp+    = SwitchTabPrev+    | SwitchTabNext+    | ToggleHelp     | CycleTestView-    | ToggleEvalComments     | RestartDaemon-    | ExitView     | ScrollUp     | ScrollDown     | Quit@@ -100,37 +95,42 @@ textToKeyEvent = (`Map.lookup` keyEventTextMap)  +eventToDesc :: KeyEvent -> Text+eventToDesc = \case+    ToggleHelp -> "toggle help"+    SwitchTabNext -> "switch to next tab"+    SwitchTabPrev -> "switch to previous tab"+    CycleTestView -> "cycle test tab views"+    RestartDaemon -> "restart daemon"+    ScrollUp -> "scroll up"+    ScrollDown -> "scroll down"+    Quit -> "quit"++ keys :: KeyEvents KeyEvent-keys =-    keyEvents-        [ ("toggle help", ToggleHelp)-        , ("cycle test view", CycleTestView)-        , ("toggle eval comments", ToggleEvalComments)-        , ("restart daemon", RestartDaemon)-        , ("exit view", ExitView)-        , ("scroll up", ScrollUp)-        , ("scroll down", ScrollDown)-        , ("quit", Quit)-        ]+keys = keyEvents $ (\e -> (eventToDesc e, e)) <$> universe  -bindings :: [(KeyEvent, [Binding])]-bindings =-    [ (ToggleHelp, [bind 'h'])-    , (CycleTestView, [bind 't'])-    , (ToggleEvalComments, [bind 'e'])-    , (RestartDaemon, [bind 'R'])-    , (ExitView, [binding KEsc []])-    , (ScrollUp, [binding KUp []])-    , (ScrollDown, [binding KDown []])-    , (Quit, [bind 'q', ctrl 'c'])-    ]+eventToBinding :: KeyEvent -> [Binding]+eventToBinding = \case+    ToggleHelp -> [bind '?']+    SwitchTabPrev -> [bind 'h', binding KLeft []]+    SwitchTabNext -> [bind 'l', binding KRight []]+    CycleTestView -> [bind 't']+    RestartDaemon -> [bind 'R']+    ScrollUp -> [binding KUp []]+    ScrollDown -> [binding KDown []]+    Quit -> [bind 'q', ctrl 'c', binding KEsc []]  -mkKeyConfig :: (Console :> es, Reader Config :> es) => Eff es (KeyConfig KeyEvent)+defaultBindings :: [(KeyEvent, [Binding])]+defaultBindings = (\e -> (e, eventToBinding e)) <$> universe+++mkKeyConfig :: (Console :> es, Exit :> es, Reader Config :> es) => Eff es (KeyConfig KeyEvent) mkKeyConfig = do     customBindings <- parseCustomBindings-    pure $ newKeyConfig keys bindings customBindings+    pure $ newKeyConfig keys defaultBindings customBindings   newtype Config = Config (Map Text Text)@@ -144,6 +144,7 @@  parseCustomBindings     :: ( Console :> es+       , Exit :> es        , Reader Config :> es        )     => Eff es [(KeyEvent, BindingState)]@@ -153,7 +154,7 @@     unless (null errors) do         Console.putTextLn "Error(s) encountered when attempting to parse key bindings:"         traverse_ (Console.putTextLn . toText) errors-        throwIO $ userError "Malformed keybindings"+        exitFailure     pure customBindings  @@ -169,62 +170,75 @@ parseKeyEvent ev = maybeToRight ("Unrecognized key event: " <> ev) $ textToKeyEvent ev  +eventToHandler :: IO () -> KeyEvent -> KeyEventHandler KeyEvent (EventM Viewports State)+eventToHandler requestRestart = \case+    ToggleHelp -> onEvent ToggleHelp "Toggle help" do+        modify \s -> s {showHelp = not s.showHelp}+    SwitchTabNext -> onEvent SwitchTabNext "Switch to next tab" do+        modify \s ->+            s+                { route =+                    if s.route == maxBound+                        then minBound+                        else succ s.route+                }+    SwitchTabPrev -> onEvent SwitchTabPrev "Switch to previous tab" do+        modify \s ->+            s+                { route =+                    if s.route == minBound+                        then maxBound+                        else pred s.route+                }+    CycleTestView -> onEvent CycleTestView "Cycle between test tab views" do+        modify \s ->+            if+                | s.route /= Route.Tests -> s+                | otherwise -> s {testFilter = cycleTestFilter s.testFilter}+    RestartDaemon -> onEvent RestartDaemon "Restart the daemon" do+        liftIO requestRestart+        modify \s -> s {buildState = Waiting}+    ScrollUp -> onEvent ScrollUp "Scroll up" do+        mvp <- gets (viewToViewport . currentRoute)+        case mvp of+            Just vp -> vScrollBy (viewportScroll vp) (-1)+            Nothing -> pure ()+    ScrollDown -> onEvent ScrollDown "Scroll down" do+        mvp <- gets (viewToViewport . currentRoute)+        case mvp of+            Just vp ->+                vScrollBy (viewportScroll vp) 1+            Nothing -> pure ()+    Quit -> onEvent Quit "Exit" do+        halt++ -- | Build the key dispatcher. @requestRestart@ is run (in 'IO') when the restart -- key is pressed; it hands the request off to the worker that owns the daemon -- control effects, since brick's 'EventM' cannot run them directly.-dispatcher :: IO () -> KeyConfig KeyEvent -> KeyDispatcher KeyEvent (EventM Viewports State)-dispatcher requestRestart cfg =-    -- TODO: Handle this error more gracefully.-    either (error . ("Invalid key dispatcher config: " <>) . stringify) id-        $ keyDispatcher-            cfg-            [ onEvent ToggleHelp "Toggle help" do-                modify \s ->-                    if currentRoute s == Route.Help-                        then-                            navigate Route.Main s-                        else-                            navigate Route.Help s-            , onEvent CycleTestView "Cycle test results view" do-                modify \s -> case currentRoute s of-                    Route.Tests ->-                        if s.testFilter == maxBound-                            then-                                navigate Route.Main s {testFilter = minBound}-                            else-                                s {testFilter = cycleTestFilter s.testFilter}-                    _ -> navigate Route.Tests s-            , onEvent ToggleEvalComments "Toggle eval comments view" do-                modify \s ->-                    if currentRoute s == Route.Evals-                        then-                            navigate Route.Main s-                        else-                            navigate Route.Evals s-            , onEvent RestartDaemon "Restart the daemon" do-                liftIO requestRestart-                modify \s -> s {buildState = Waiting}-            , onEvent ExitView "Exit or go back" do-                gets (.route) >>= \case-                    Route.Main -> halt-                    _ -> modify $ navigate Route.Main-            , onEvent ScrollUp "Scroll up" do-                mvp <- gets (viewToViewport . currentRoute)-                case mvp of-                    Just vp -> vScrollBy (viewportScroll vp) (-1)-                    Nothing -> pure ()-            , onEvent ScrollDown "Scroll down" do-                mvp <- gets (viewToViewport . currentRoute)-                case mvp of-                    Just vp ->-                        vScrollBy (viewportScroll vp) 1-                    Nothing -> pure ()-            , onEvent Quit "Exit" do-                halt-            ]+mkDispatcher+    :: (Console :> es, Exit :> es)+    => IO ()+    -> KeyConfig KeyEvent+    -> Eff es (KeyDispatcher KeyEvent (EventM Viewports State))+mkDispatcher requestRestart cfg =+    case keyDispatcher cfg $ eventToHandler requestRestart <$> universe of+        Left collisions -> do+            Console.putTextLn+                $ T.intercalate "\n\n"+                $ "Your key bindings have collisions:"+                    : (uncurry showCollision <$> collisions)+            exitFailure+        Right dispatcher -> pure dispatcher   where-    stringify =-        show . fmap (second $ fmap $ handlerDescription . kehHandler . khHandler)+    showCollision binding' handlers =+        T.intercalate "\n"+            $ ("Key binding: " <> ppBinding binding')+                : (showCollidingHandler <$> handlers)+    showCollidingHandler handler =+        "  " <> case handler.khHandler.kehEventTrigger of+            ByEvent ev -> toText $ quietSnake $ show ev+            ByKey k -> show k   viewKeybindings :: (Ord k, Show k) => KeyConfig k -> [KeyEventHandler k m] -> Widget n@@ -248,11 +262,3 @@     getBindings = \case         ByKey k -> Set.singleton k         ByEvent e -> Set.fromList $ allActiveBindings kc e---keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding-keybindForRoute kc = \case-    Route.Main -> Nothing-    Route.Help -> firstActiveBinding kc ToggleHelp-    Route.Tests -> firstActiveBinding kc CycleTestView-    Route.Evals -> firstActiveBinding kc ToggleEvalComments

@@ -7,7 +7,6 @@  data Route     = Main-    | Help     | Tests     | Evals     deriving stock (Bounded, Enum, Eq)@@ -16,6 +15,5 @@ name :: Route -> Text name = \case     Main -> "Dashboard"-    Help -> "Help"     Tests -> "Tests"     Evals -> "Eval comments"

@@ -35,6 +35,7 @@     , timeZone :: TimeZone     , route :: Route     , testFilter :: TestFilter+    , showHelp :: Bool     }  @@ -76,4 +77,5 @@             , timeZone = tz             , route = Route.Main             , testFilter = minBound+            , showHelp = False             }

@@ -12,7 +12,7 @@     , vBox     , viewport     )-import Brick.Keybindings (KeyConfig, KeyHandler (..), keyDispatcherToList, ppBinding)+import Brick.Keybindings (KeyConfig, KeyDispatcher, KeyHandler (..), keyDispatcherToList, ppBinding) import Brick.Widgets.Core     ( Padding (..)     , emptyWidget@@ -27,6 +27,7 @@     ) import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime) +import Brick.Keybindings.KeyConfig qualified as KeyConfig import Data.Map.Strict qualified as Map import Data.Text qualified as T import Graphics.Vty.Attributes qualified as Attr@@ -34,7 +35,7 @@  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.Keys (KeyEvent, viewKeybindings) import Tricorder.CLI.UI.Misc (emphasis, err, hBoxSpaced, ok, subtle, vBoxSpaced, warn) import Tricorder.CLI.UI.Route (Route) import Tricorder.CLI.UI.State@@ -69,41 +70,35 @@         )  -view :: KeyConfig KeyEvent -> State -> [Widget Viewports]-view kc ws =+view :: KeyConfig KeyEvent -> KeyDispatcher KeyEvent m -> State -> [Widget Viewports]+view kc dispatcher ws =     [ vBoxSpaced         1         [ vBox-            [ viewAppHeader ws-            , viewTabs kc ws+            [ viewAppHeader kc ws+            , viewTabs ws             ]-        , case currentRoute ws of-            Route.Help ->-                viewHelp kc-            Route.Tests ->-                viewTests ws-            Route.Main ->-                viewMain ws-            Route.Evals ->-                viewEvals ws+        , if ws.showHelp+            then viewHelp kc dispatcher+            else case currentRoute ws of+                Route.Tests -> viewTests ws+                Route.Main -> viewMain ws+                Route.Evals -> viewEvals ws         ]     ]  -viewTabs :: KeyConfig KeyEvent -> State -> Widget n-viewTabs kc ws =-    hBoxSpaced 1-        $ intersperse (subtle $ txt "-")-        $ viewRouteTab kc ws <$> universe @Route+viewTabs :: State -> Widget n+viewTabs ws =+    hBoxSpaced 1 $ viewRouteTab ws <$> universe @Route  -viewRouteTab :: KeyConfig KeyEvent -> State -> Route -> Widget n-viewRouteTab kc ws route =-    style $ txt $ Route.name route <> keyBind+viewRouteTab :: State -> Route -> Widget n+viewRouteTab ws route =+    style $ txt $ brackets $ Route.name route   where+    brackets = if route == currentRoute ws then ("< " <>) . (<> " >") else ("  " <>) . (<> "  ")     style = if route == currentRoute ws then id else subtle-    showBinding = (" " <>) . ("[" <>) . (<> "]") . ppBinding-    keyBind = maybe "" showBinding $ keybindForRoute kc route   viewTests :: State -> Widget Viewports@@ -118,12 +113,12 @@ viewMain ws = withBuildState ws (viewDefaultPanel ws.timeZone)  -viewHelp :: KeyConfig KeyEvent -> Widget n-viewHelp kc = viewKeybindings kc handlers+viewHelp :: KeyConfig KeyEvent -> KeyDispatcher KeyEvent m -> Widget n+viewHelp kc dispatcher = viewKeybindings kc handlers   where     -- The dispatcher is built only to enumerate handler descriptions for the help     -- view, so the restart action is a no-op here.-    handlers = (.khHandler) . snd <$> keyDispatcherToList (Keys.dispatcher (pure ()) kc)+    handlers = (.khHandler) . snd <$> keyDispatcherToList dispatcher   withBuildState :: State -> (BuildState -> Widget Viewports) -> Widget Viewports@@ -137,26 +132,49 @@             render bs  -viewAppHeader :: State -> Widget n-viewAppHeader ws =-    ok-        $ emphasis-        $ txt-        $ "Tricorder"-            <> maybe-                ""-                (" - " <>)-                (viewHeading ws)+viewAppHeader :: KeyConfig KeyEvent -> State -> Widget n+viewAppHeader kc ws =+    hBoxSpaced+        1+        [ ok+            $ emphasis+            $ txt+            $ "Tricorder"+                <> maybe+                    ""+                    (" - " <>)+                    (viewHeading ws)+        , viewHelpHint kc ws+        ]  +viewHelpHint :: KeyConfig KeyEvent -> State -> Widget n+viewHelpHint kc state+    | state.showHelp = subtle $ txt $ "Press " <> exitHelpStr <> " to go back"+    | state.route == Route.Tests =+        subtle $ txt $ "Press " <> cycleTestFilterStr <> " to cycle between filters"+    | otherwise = subtle $ txt $ "Press " <> showHelpStr <> " for help"+  where+    exitHelpStr = showHint Keys.ToggleHelp+    showHelpStr = showHint Keys.ToggleHelp+    cycleTestFilterStr = showHint Keys.CycleTestView+    showHint = joinWithAndOr "or" . fmap (quote . ppBinding) . KeyConfig.allActiveBindings kc+    quote = (<> "'") . ("'" <>)+    joinWithAndOr andOr xs = case splitAt (length xs - 1) xs of+        ([], [post]) -> post+        ([pre], []) -> pre+        (pre, post) -> T.intercalate ", " pre <> " " <> andOr <> " " <> T.intercalate ", " post++ viewHeading :: State -> Maybe Text-viewHeading ws = case currentRoute ws of-    Route.Tests -> case ws.testFilter of-        TestFilterAll -> Just "Tests"-        TestFilterFailedOnly -> Just "Tests - Failed only"-    Route.Help -> Just "Help"-    Route.Main -> Nothing-    Route.Evals -> Just "Eval comments"+viewHeading ws+    | ws.showHelp = Just "Help"+    | otherwise = case currentRoute ws of+        Route.Tests -> case ws.testFilter of+            TestFilterAll -> Just "Tests"+            TestFilterFailedOnly -> Just "Tests - Failed only"+        Route.Main -> Nothing+        Route.Evals -> Just "Eval comments"   viewDefaultPanel :: TimeZone -> BuildState -> Widget Viewports

@@ -1,62 +1,44 @@ module Tricorder.Config-    ( LoadedConfig (..)-    , runLoadedConfig-    , inputLoadedConfig-    , configFileName+    ( Config (..)+    , asInput     ) where -import Atelier.Config (LoadedConfig (..))-import Atelier.Effects.FileSystem (FileSystem)-import Atelier.Effects.Input (Input, runInputEff)-import Effectful.Reader.Static (Reader, ask, runReader)-import System.FilePath ((</>))+import Atelier.Effects.Input (Input)+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..))+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..)) -import Atelier.Effects.FileSystem qualified as FileSystem+import Atelier.Effects.Input qualified as Input import Data.Aeson qualified as Aeson-import Data.Aeson.KeyMap qualified as KM import Data.Yaml qualified as Yaml -import Tricorder.Runtime (ProjectRoot (..))-+import Tricorder.Config.LoadedConfig (LoadedConfig (..)) --- | Load config from .tricorder.yaml in the project root.--- Falls back to empty config (all defaults) if the file is absent or cannot be parsed.-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-  where-    yamlPath = projectRoot </> configFileName+import Tricorder.Session.Config qualified as Session (Config)  -configFileName :: FilePath-configFileName = ".tricorder.yaml"+data Config = Config+    { session :: Maybe Session.Config+    }+    deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake Config+    deriving (FromJSON) via WithDefaults (QuietSnake Config)  -runLoadedConfig-    :: ( FileSystem :> es-       , Reader ProjectRoot :> es-       )-    => Eff (Reader LoadedConfig : es) a -> Eff es a-runLoadedConfig act = do-    ProjectRoot projectRoot <- ask-    cfg <- loadTricorderConfig projectRoot-    runReader cfg act+instance Default Config where+    def =+        Config+            { session = def+            }  -inputLoadedConfig-    :: ( FileSystem :> es-       , Reader ProjectRoot :> es-       )-    => Eff (Input LoadedConfig : es) a -> Eff es a-inputLoadedConfig = runInputEff do-    ProjectRoot projectRoot <- ask-    loadTricorderConfig projectRoot+asInput+    :: (Input LoadedConfig :> es)+    => Eff (Input (Either Text Config) : es) a -> Eff es a+asInput = Input.withEff do+    LoadedConfig bs <- Input.input+    case Yaml.decodeEither' bs of+        Right Aeson.Null -> pure $ Right def+        _ -> pure $ first (toText . Yaml.prettyPrintParseException) $ Yaml.decodeEither' bs

@@ -0,0 +1,92 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Tricorder.Config.LoadedConfig+    ( LoadedConfig (..)+    , asInput+    , asNestedInput+    , decodeNestedValue+    , configFileName+    )+where++import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Input (Input)+import Data.Aeson (FromJSON)+import Effectful.Reader.Static (Reader)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import System.FilePath ((</>))++import Atelier.Effects.FileSystem qualified as FileSystem+import Atelier.Effects.Input qualified as Input+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.List qualified as List+import Data.Text qualified as T+import Data.Yaml qualified as Yaml+import Effectful.Reader.Static qualified as Reader++import Tricorder.Runtime (ProjectRoot (..))+++newtype LoadedConfig = LoadedConfig {getLoadedConfig :: ByteString}+++asInput+    :: (FileSystem :> es, Reader ProjectRoot :> es)+    => Eff (Input LoadedConfig : es) a -> Eff es a+asInput = Input.withEff do+    ProjectRoot projectRoot <- Reader.ask+    let configFilePath = projectRoot </> configFileName+    exists <- FileSystem.doesFileExist configFilePath+    if exists+        then do+            bs <- FileSystem.readFileBs configFilePath+            pure $ LoadedConfig bs+        else pure $ LoadedConfig ""+++asNestedInput+    :: forall (key :: Symbol) r es a+     . ( FromJSON r+       , Input LoadedConfig :> es+       , KnownSymbol key+       )+    => Eff (Input (Either Text r) : es) a -> Eff es a+asNestedInput = Input.withEff do+    loadedConfig <- Input.input+    pure $ decodeNestedValue @key loadedConfig+++configFileName :: FilePath+configFileName = ".tricorder.yaml"+++decodeNestedValue+    :: forall (key :: Symbol) r. (FromJSON r, KnownSymbol key) => LoadedConfig -> Either Text r+decodeNestedValue (LoadedConfig root) =+    go [] props+        =<< first+            (toText . Yaml.prettyPrintParseException)+            (Yaml.decodeEither' root)+  where+    props = T.splitOn "." $ toText $ symbolVal $ Proxy @key++    go :: [Text] -> [Text] -> Aeson.Value -> Either Text r+    go prev (p : ps) (Aeson.Object m) =+        maybe+            (Left $ "missing property '" <> p <> "' at " <> formatPrev prev)+            (go (p : prev) ps)+            $ KM.lookup (fromString $ toString p) m+    go prev (_ : _) _ =+        Left $ "expected property to be an object: " <> formatPrev prev+    go prev [] x =+        first (\e -> "parse error for property " <> formatPrev prev <> ": " <> e)+            $ fromJSON x++    fromJSON x = case Aeson.fromJSON x of+        Aeson.Success a -> Right a+        Aeson.Error err -> Left $ toText err++    formatPrev prev+        | List.null prev = "<root object>"+        | otherwise = T.intercalate "." $ List.reverse prev

@@ -13,7 +13,7 @@ import Atelier.Effects.Clock (Clock, UTCTime) import Atelier.Effects.FileWatcher (FileEvent) import Atelier.Effects.Log (Log)-import Atelier.Effects.Publishing.Pub (Pub)+import Atelier.Effects.PubSub.Pub (Pub) import Atelier.Time (nominalDiffTime) import Data.Time (diffUTCTime) import Effectful (Effect, inject)@@ -26,7 +26,7 @@  import Atelier.Effects.Clock qualified as Clock import Atelier.Effects.Log qualified as Log-import Atelier.Effects.Publishing.Pub qualified as Pub+import Atelier.Effects.PubSub.Pub qualified as Pub import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Effectful.State.Static.Shared qualified as State@@ -44,13 +44,16 @@     , mergeDiagnostics     , preserveFailureVisibility     )-import Tricorder.Daemon.GhciSession (GhciSession, LoadResult (..))-import Tricorder.Daemon.GhciSession.GhciParser (resolveKnownTargets) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.Command.RenderedCommand (RenderedCommand) import Tricorder.Session.WatchDirs (WatchDirs) -import Tricorder.Daemon.GhciSession qualified as GhciSession+import Tricorder.Daemon.Ghci.Controls qualified as Controls+import Tricorder.Daemon.Ghci.Controls qualified as Ghci (Controls)+import Tricorder.Daemon.Ghci.LoadResult qualified as Ghci (LoadResult)+import Tricorder.Daemon.Ghci.LoadResult qualified as Ghci.LoadResult+import Tricorder.Daemon.Ghci.Session qualified as Ghci (Session)+import Tricorder.Daemon.Ghci.Session qualified as Ghci.Session import Tricorder.Session.Stage qualified as Stage  @@ -72,7 +75,7 @@ data NewLoadResult = NewLoadResult     { startTime :: UTCTime     , endTime :: UTCTime-    , loadResult :: LoadResult+    , loadResult :: Ghci.LoadResult     }     deriving stock (Eq, Show) @@ -82,7 +85,7 @@  with     :: ( Clock :> es-       , GhciSession :> es+       , Ghci.Session :> es        , Log :> es        , Pub BuildProgress :> es        , Reader ProjectRoot :> es@@ -95,7 +98,7 @@ with buildId command watchDirs action = do     root <- ask     startTime <- Clock.currentTime-    trySync $ GhciSession.withGhciWith Pub.publish command root \initialLoad controls -> do+    trySync $ Ghci.Session.with Pub.publish command root \initialLoad controls -> do         endTime <- Clock.currentTime         let filteredMsgs = filterToWatchDirs root.getProjectRoot watchDirs initialLoad.diagnostics         Log.info@@ -109,7 +112,7 @@         let initialLoadResult = NewLoadResult {startTime, endTime, loadResult = initialLoad}         let initialBuilderState =                 emptyBuilderState-                    { loadedModules = resolveKnownTargets Map.empty initialLoad+                    { loadedModules = Ghci.LoadResult.resolveKnownTargets Map.empty initialLoad                     , knownTargets = KnownTargetNames (Set.fromList initialLoad.targetNames)                     }         reinterpretWith_@@ -118,7 +121,7 @@             \case                 Consider fp event -> considerBuild fp event                 Build dispatchAction ->-                    buildSource (GhciSession.transformControls inject controls) dispatchAction+                    buildSource (Controls.lift inject controls) dispatchAction   considerBuild@@ -139,7 +142,7 @@  buildSource     :: (Clock :> es, State BuilderState :> es)-    => GhciSession.Controls (Eff es)+    => Ghci.Controls (Eff es)     -> DispatchAction     -> Eff es (Either BuildFailure NewLoadResult) buildSource controls action = do@@ -155,7 +158,7 @@         Right (startTime, endTime, loadResult) -> do             modify \s ->                 s-                    { loadedModules = resolveKnownTargets s.loadedModules loadResult+                    { loadedModules = Ghci.LoadResult.resolveKnownTargets s.loadedModules loadResult                     , knownTargets = KnownTargetNames (Set.fromList loadResult.targetNames)                     }             pure $ Right $ NewLoadResult {startTime, endTime, loadResult}@@ -174,7 +177,7 @@     merged = mergeDiagnostics diagnosticMap filteredResult     filteredResult =         loadResult-            { GhciSession.diagnostics =+            { Ghci.LoadResult.diagnostics =                 preserveFailureVisibility loadResult.diagnostics                     $ filterToWatchDirs projectRoot watchDirs loadResult.diagnostics             }@@ -187,7 +190,7 @@             }  -runAction :: GhciSession.Controls (Eff es) -> DispatchAction -> Eff es LoadResult+runAction :: Ghci.Controls (Eff es) -> DispatchAction -> Eff es Ghci.LoadResult runAction controls = \case     Reload -> controls.reload     Add fp -> controls.add fp

@@ -3,29 +3,22 @@ import Atelier.Effects.Chan (Chan) import Atelier.Effects.Clock (Clock) import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Debounce (Debounce)-import Atelier.Effects.FileSystem (FileSystem)-import Atelier.Effects.FileWatcher (FileEvent, FileWatcher)-import Atelier.Effects.Input (Input, input)+import Atelier.Effects.FileWatcher (FileEvent) 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)-import Data.List (isSuffixOf)+import Atelier.Effects.PubSub.Pub (Pub)+import Atelier.Effects.PubSub.Sub (Sub) import Effectful.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) import Effectful.Concurrent.STM (Concurrent, atomically, newEmptyTMVar, takeTMVar, writeTMVar) import Effectful.Reader.Static (Reader) import Effectful.State.Static.Shared (State) import Relude.Extra.Tuple (dup)-import System.FilePath ((</>))  import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.FileSystem qualified as FileSystem-import Atelier.Effects.FileWatcher qualified as FileWatcher import Atelier.Effects.Log qualified as Log-import Atelier.Effects.Publishing.Pub qualified as Pub-import Atelier.Effects.Publishing.Sub qualified as Sub+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub+import Atelier.Effects.PubSub.Sub qualified as Sub import Data.Map.Strict qualified as Map import Effectful.Reader.Static qualified as Reader import Effectful.State.Static.Shared qualified as State@@ -42,20 +35,10 @@     ) import Tricorder.Daemon.Dispatch (BuilderState (..), DispatchAction, emptyBuilderState) import Tricorder.Daemon.EvalCommentRunner (EvalCommentRunner, findEvalCommentsInModules)-import Tricorder.Daemon.GhciSession (GhciSession)-import Tricorder.Daemon.GhciSession.GhciParser-    ( LoadResult-    , LoadedModule (..)-    , resolveKnownTargets-    )-import Tricorder.Daemon.Hpack.Effect (Hpack)+import Tricorder.Daemon.Ghci.LoadedModule (LoadedModule (..)) import Tricorder.Daemon.TestRunner (TestRunner)-import Tricorder.Daemon.Watch (WatchedFile) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session (Session (..))-import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..))-import Tricorder.Session.IdleTimeout (IdleTimeout)-import Tricorder.Session.Repl (Repl) import Tricorder.Session.Stage.Build.Session (BuildSession (..)) import Tricorder.Session.Stage.Test.Command (RenderedTestCommand (..)) import Tricorder.Session.Stage.Test.Session (TestSession (..))@@ -65,14 +48,13 @@ import Tricorder.Build qualified as Build import Tricorder.Build.EvalComment qualified as Eval import Tricorder.Build.Test qualified as Test-import Tricorder.Config qualified as Config import Tricorder.Daemon.Builder qualified as Builder import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner-import Tricorder.Daemon.Hpack qualified as Hpack+import Tricorder.Daemon.Ghci.LoadResult qualified as Ghci (LoadResult)+import Tricorder.Daemon.Ghci.LoadResult qualified as Ghci.LoadResult+import Tricorder.Daemon.Ghci.Session qualified as Ghci (Session) import Tricorder.Daemon.TestRunner qualified as TestRunner-import Tricorder.Daemon.Watch qualified as Watch-import Tricorder.Session qualified as Session-import Tricorder.Session.CommandTemplate qualified as Command+import Tricorder.Session.Hook qualified as Hook import Tricorder.Session.Hooks qualified as Hooks import Tricorder.Session.Stage.Build.Command qualified as BuildCommand import Tricorder.Session.Stage.Test.Command qualified as TestCommand@@ -80,9 +62,6 @@ import Tricorder.Waiters qualified as Waiters  -data ReloadSession = ReloadSession-- data RestartBuilder = RestartBuilder  @@ -96,138 +75,32 @@        , Clock :> es        , Conc :> es        , Concurrent :> es-       , Debounce FilePath :> es        , EvalCommentRunner :> es-       , FileSystem :> es-       , FileWatcher :> es-       , GhciSession :> es-       , Hpack :> es-       , Input Session :> es+       , Ghci.Session :> es        , Log :> es        , Process :> es        , Pub BuildPhase :> es        , Reader ProjectRoot :> es        , State BuildId :> es-       , State IdleTimeout :> es-       , State Repl :> es-       , TestRunner :> es-       , Waiters :> es-       )-    => Eff es Void-main =-    runPubSub @ReloadSession-        . runPubSub @WatchedFile-        . runPubSub @CabalChangeDetected-        . runPubSub @SourceChangeDetected-        . runPubSub @RestartBuilder-        . runPubSub @ReloadBuilder-        . Conc.restartableFork waitForReloadSession-        $ do-            Log.debug "Before session"-            session <- input-            Log.debug "After session"-            withSession session-  where-    waitForReloadSession = Waiters.wait $ Sub.listenOnce_ @ReloadSession---withSession-    :: ( Chan :> es-       , Clock :> es-       , Conc :> es-       , Concurrent :> es-       , Debounce FilePath :> es-       , EvalCommentRunner :> es-       , FileSystem :> es-       , FileWatcher :> es-       , GhciSession :> es-       , Hpack :> es-       , Input Session :> es-       , Log :> es-       , Process :> es-       , Pub BuildPhase :> es-       , Pub CabalChangeDetected :> es-       , Pub ReloadBuilder :> es-       , Pub ReloadSession :> es-       , Pub RestartBuilder :> es-       , Pub SourceChangeDetected :> es-       , Pub WatchedFile :> es-       , Reader ProjectRoot :> es-       , State BuildId :> es-       , State IdleTimeout :> es-       , State Repl :> es        , Sub CabalChangeDetected :> es-       , Sub ReloadBuilder :> es-       , Sub RestartBuilder :> es        , Sub SourceChangeDetected :> es-       , Sub WatchedFile :> es        , TestRunner :> es        , Waiters :> es        )     => Session -> Eff es Void-withSession session = do-    root <- Reader.ask-    logSession session--    State.put session.buildSession.commandTemplate.repl-    State.put session.idleTimeout-    Conc.fork_ $ watchConfigFile root-    conditionallyWatchStackYaml root--    Conc.fork_ $ Watch.files root session-    Conc.fork_ $ Sub.listen_ Watch.publishChange--    Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) ->-        ifM-            (shouldReloadSession session)-            (Pub.publish ReloadSession)-            (Pub.publish RestartBuilder)--    Conc.fork_ $ Sub.listen_ \(SourceChangeDetected fp event) ->-        Pub.publish $ ReloadBuilder fp event--    when (coerce session.generateWithHpack)-        $ void-        $ Conc.fork Hpack.main--    State.evalState emptyBuilderState do-        Conc.restartableFork (Waiters.wait $ Sub.listenOnce_ @RestartBuilder) do+main session =+    PubSub.run @ReloadBuilder+        . PubSub.run @RestartBuilder+        $ Conc.restartableFork (Waiters.wait $ Sub.listenOnce_ @RestartBuilder) do             buildId <- State.state (\s -> (s, s + 1))-            runBuilder buildId session --shouldReloadSession :: (Input Session :> es) => Session -> Eff es Bool-shouldReloadSession oldSession = do-    newSession <- input-    pure $ newSession /= oldSession---watchConfigFile-    :: ( Debounce FilePath :> es-       , FileWatcher :> es-       , Pub ReloadSession :> es-       )-    => ProjectRoot -> Eff es Void-watchConfigFile root = do-    FileWatcher.watchFilePathsDebounced-        [FileWatcher.dirWhere root.getProjectRoot (Config.configFileName `isSuffixOf`)]-        \_ _ -> Pub.publish ReloadSession+            Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) ->+                Pub.publish RestartBuilder +            Conc.fork_ $ Sub.listen_ \(SourceChangeDetected path event) ->+                Pub.publish $ ReloadBuilder path event -conditionallyWatchStackYaml-    :: ( Conc :> es-       , Debounce FilePath :> es-       , FileSystem :> es-       , FileWatcher :> es-       , Pub RestartBuilder :> es-       )-    => ProjectRoot -> Eff es ()-conditionallyWatchStackYaml root = do-    exists <- FileSystem.doesFileExist $ root.getProjectRoot </> "stack.yaml"-    when exists do-        Conc.fork_ $ FileWatcher.watchFilePathsDebounced-            [FileWatcher.dirWhere root.getProjectRoot ("stack.yaml" `isSuffixOf`)]-            \_ _ -> Pub.publish RestartBuilder+            runBuilder buildId session   -- | Starts the initial build with GHCi, and waits for source changes.@@ -236,25 +109,24 @@        , Conc :> es        , Concurrent :> es        , EvalCommentRunner :> es-       , GhciSession :> es+       , Ghci.Session :> es        , Log.Log :> es        , Process :> es        , Pub BuildPhase :> es        , Reader ProjectRoot :> es-       , State BuilderState :> es        , Sub ReloadBuilder :> es        , TestRunner :> es        , Waiters :> es        )     => BuildId -> Session -> Eff es ()-runBuilder buildId session = do+runBuilder buildId session = State.evalState emptyBuilderState do     Log.info $ "Starting session " <> show buildId.getBuildId     Pub.publish Build.Starting-    whenJust (session.hooks.start >>= (.before)) Hooks.runHook+    whenJust (session.hooks.start >>= (.before)) Hook.run     startupError <- fmap (either id absurd)         $ Pub.map (Build.Building session.testSession.targets)         $ Builder.with buildId buildCommand session.watchDirs \_ initialLoad -> do-            whenJust (session.hooks.start >>= (.after)) Hooks.runHook+            whenJust (session.hooks.start >>= (.after)) Hook.run             processPostBuild session $ Right initialLoad             Log.debug "Waiting for reload"             newestReloadEvent <- atomically newEmptyTMVar@@ -272,7 +144,7 @@                 Conc.restartableFork checkCancel                     $ waitForReload session event -    Pub.publish $ Build.Failed $ show startupError+    Pub.publish $ Build.Failed $ toText $ displayException startupError   where     buildCommand = BuildCommand.render session.buildSession.commandTemplate session.buildSession.targets @@ -320,9 +192,9 @@     -> DispatchAction     -> Eff es () processSource session action = do-    whenJust (session.hooks.reload >>= (.before)) Hooks.runHook+    whenJust (session.hooks.reload >>= (.before)) Hook.run     res <- Builder.build action-    whenJust (session.hooks.reload >>= (.after)) Hooks.runHook+    whenJust (session.hooks.reload >>= (.after)) Hook.run     Log.debug "Finished build"     processPostBuild session res @@ -374,11 +246,12 @@        , Pub Eval.Phase :> es        , State BuilderState :> es        )-    => Session -> LoadResult -> Eff es Eval.Phase+    => Session -> Ghci.LoadResult -> Eff es Eval.Phase runEvalComments session loadResult = do     builderState <- State.get @BuilderState     evalComments <--        findEvalCommentsInModules $ resolveKnownTargets builderState.loadedModules loadResult+        findEvalCommentsInModules+            $ Ghci.LoadResult.resolveKnownTargets builderState.loadedModules loadResult      case nonEmpty evalComments of         Nothing -> pure Eval.NoneFound@@ -466,7 +339,3 @@                     s.diagnosticMap                     newLoadResult         in  (buildResult, s {diagnosticMap = newDiagnosticMap})---logSession :: (Log :> es) => Session -> Eff es ()-logSession = Log.info . (<> "\n") . Session.show

@@ -5,12 +5,14 @@     ) where -import Atelier.Effects.Input (Input, input, runInputEff)+import Atelier.Effects.Input (Input) import Data.Aeson (FromJSON (..), ToJSON (..)) import Effectful.Reader.Static (Reader, ask) import GHC.Generics (Generically (..)) import System.FilePath (makeRelative) +import Atelier.Effects.Input qualified as Input+ import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..)) import Tricorder.Session (Session (..)) import Tricorder.Session.Stage.Build.Session (BuildSession (..))@@ -36,7 +38,7 @@        )     => Eff es DaemonInfo load = do-    session <- input+    session <- Input.input     ProjectRoot projectRoot <- ask     SocketPath sockPath <- ask     LogPath logFile <- ask@@ -56,4 +58,4 @@        , Reader SocketPath :> es        )     => Eff (Input DaemonInfo : es) a -> Eff es a-runInput = runInputEff load+runInput = Input.withEff load

@@ -20,22 +20,21 @@ import Data.Set qualified as Set  import Tricorder.Build (Diagnostic (..), Severity (..))-import Tricorder.Daemon.GhciSession.GhciParser-    ( LoadResult (..)-    , LoadedModule (..)-    , isLocationLess-    , pathSuffixesAsModuleName-    , unattributedFailure-    ) import Tricorder.Session.WatchDirs (WatchDirs (..)) +import Tricorder.Daemon.Ghci.Diagnostic qualified as Ghci.Diagnostic+import Tricorder.Daemon.Ghci.LoadResult qualified as Ghci+import Tricorder.Daemon.Ghci.LoadedModule qualified as Ghci (LoadedModule)+import Tricorder.Daemon.Ghci.LoadedModule qualified as Ghci.LoadedModule+import Tricorder.Daemon.Ghci.Path qualified as Ghci.Path + -- | The Builder's per-GHCi-session cache: what it last saw from GHCi plus its -- accumulated diagnostics. Reset on every GHCi restart in -- @buildWithGhciOnChange@; 'BuildId' is intentionally /not/ here because it -- counts across restarts. data BuilderState = BuilderState-    { loadedModules :: Map FilePath LoadedModule+    { loadedModules :: Map FilePath Ghci.LoadedModule     , knownTargets :: KnownTargetNames     , diagnosticMap :: DiagnosticMap     }@@ -66,9 +65,9 @@ -- forever once raised. They describe the current load's outcome, so we clear -- them every cycle and let this cycle's 'diagnostics' re-add them if the -- failure is still present.-mergeDiagnostics :: DiagnosticMap -> LoadResult -> DiagnosticMap-mergeDiagnostics prev LoadResult {compiledFiles, diagnostics} =-    let retained = Map.filterWithKey (\f _ -> not (isLocationLess f)) prev+mergeDiagnostics :: DiagnosticMap -> Ghci.LoadResult -> DiagnosticMap+mergeDiagnostics prev Ghci.LoadResult {compiledFiles, diagnostics} =+    let retained = Map.filterWithKey (\f _ -> not (Ghci.Path.isLocationLess f)) prev         cleared = foldr Map.delete retained compiledFiles         newByFile = Map.fromListWith (++) [(d.file, [d]) | d <- diagnostics]     in  Map.union newByFile cleared@@ -95,7 +94,7 @@ -- leaving the diagnostic stale. fileMatchesAnyTarget :: KnownTargetNames -> FilePath -> Bool fileMatchesAnyTarget (KnownTargetNames targets) fp =-    any (`Set.member` targets) (pathSuffixesAsModuleName fp)+    any (`Set.member` targets) (Ghci.Path.pathSuffixesAsModuleName fp)         || any (pathTargetMatches fp . toString) (Set.toList targets)  @@ -125,7 +124,7 @@ -- stale diagnostics in place. dispatch     :: KnownTargetNames-    -> Maybe LoadedModule+    -> Maybe Ghci.LoadedModule     -> FilePath     -> FileEvent     -> Maybe DispatchAction@@ -160,7 +159,7 @@ filterToWatchDirs :: FilePath -> WatchDirs -> [Diagnostic] -> [Diagnostic] filterToWatchDirs _ (WatchDirs []) diags = diags filterToWatchDirs projectRoot (WatchDirs watchDirs) diags =-    filter (\d -> isLocationLess d.file || isUnderAnyWatchDir d.file) diags+    filter (\d -> Ghci.Path.isLocationLess d.file || isUnderAnyWatchDir d.file) diags   where     absWatchDirs = map toAbsWd watchDirs     toAbsWd wd@@ -197,7 +196,7 @@ -- post-filter list, with the synthetic failure appended only when needed. preserveFailureVisibility :: [Diagnostic] -> [Diagnostic] -> [Diagnostic] preserveFailureVisibility raw filtered-    | any isError raw && not (any isError filtered) = filtered ++ [unattributedFailure]+    | any isError raw && not (any isError filtered) = filtered ++ [Ghci.Diagnostic.unattributedFailure]     | otherwise = filtered   where     isError d = d.severity == SError

@@ -29,12 +29,13 @@ import Data.Map.Strict qualified as Map import Data.Text qualified as T -import Tricorder.Daemon.GhciSession.GhciParser (LoadedModule (..))-import Tricorder.Daemon.GhciSession.GhciProcess (execGhci, withGhciProcess)+import Tricorder.Daemon.Ghci.LoadedModule (LoadedModule (..)) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.CommandTemplate (CommandTemplate)  import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Daemon.Ghci.LoadedModule qualified as Ghci (LoadedModule)+import Tricorder.Daemon.Ghci.Process qualified as Ghci.Process import Tricorder.Session.Stage qualified as Stage import Tricorder.Session.Stage.Eval.Command qualified as EvalCommand import Tricorder.Session.Target qualified as Target@@ -45,13 +46,13 @@     -- in a fresh GHCi session started in that file's module context.     EvaluateComments         :: CommandTemplate 'Stage.Eval-        -> NonEmpty (LoadedModule, NonEmpty Eval.Comment)+        -> NonEmpty (Ghci.LoadedModule, NonEmpty Eval.Comment)         -> EvalCommentRunner m (NonEmpty Eval.Evaluation)     -- | Extract eval comments from provided source files. Returns a map of all     -- files that have at least 1 eval comment.     FindEvalCommentsInModules-        :: Map FilePath LoadedModule-        -> EvalCommentRunner m [(LoadedModule, NonEmpty Eval.Comment)]+        :: Map FilePath Ghci.LoadedModule+        -> EvalCommentRunner m [(Ghci.LoadedModule, NonEmpty Eval.Comment)]   makeEffect ''EvalCommentRunner@@ -121,10 +122,10 @@             | otherwise = expr         command = EvalCommand.render template [Target.Bare moduleName]     sessionResult <- trySync-        $ withGhciProcess def command projectRoot noProgress noSetup \ghci _ -> do-            _ <- execGhci ghci (":m *" <> moduleName) noProgress+        $ Ghci.Process.with def command projectRoot noProgress noSetup \ghci _ -> do+            _ <- Ghci.Process.exec ghci (":m *" <> moduleName) noProgress             for comments \comment -> do-                outputResult <- trySync $ execGhci ghci (wrapForGhci comment.expression) noProgress+                outputResult <- trySync $ Ghci.Process.exec ghci (wrapForGhci comment.expression) noProgress                 pure                     Eval.Evaluation                         { file = relPath

@@ -0,0 +1,25 @@+module Tricorder.Daemon.Ghci.Config (Config (..)) where++import Atelier.Time (Second)+import Data.Default (Default (..))+++-- | Configuration for GHCi process management.+data Config = Config+    { startupTimeout :: Second+    -- ^ How long to wait for the GHCi version banner on startup.+    , shutdownTimeout :: Second+    -- ^ How long to wait for the process to exit gracefully before force-killing.+    , extraSetupCommands :: [Text]+    -- ^ Additional GHCi commands to send after the fixed setup block.+    -- Use this to inject session-wide options such as @:set -XOverloadedStrings@.+    }+++instance Default Config where+    def =+        Config+            { startupTimeout = 60+            , shutdownTimeout = 5+            , extraSetupCommands = []+            }

@@ -0,0 +1,25 @@+module Tricorder.Daemon.Ghci.Controls+    ( Controls (..)+    , lift+    )+where++import Tricorder.Daemon.Ghci.LoadResult (LoadResult)+++data Controls m = Controls+    { reload :: m LoadResult+    , interrupt :: m ()+    , add :: FilePath -> m LoadResult+    , unadd :: Text -> m LoadResult+    }+++lift :: (forall a. m a -> n a) -> Controls m -> Controls n+lift f ctrls =+    Controls+        { reload = f ctrls.reload+        , interrupt = f ctrls.interrupt+        , add = f . ctrls.add+        , unadd = f . ctrls.unadd+        }

@@ -0,0 +1,56 @@+module Tricorder.Daemon.Ghci.Diagnostic+    ( unattributedFailure+    , headerParser+    )+where++import Data.Char (isAlpha)+import Text.Megaparsec (getInput, takeWhile1P)+import Text.Megaparsec.Char (char)+import Prelude hiding (many)++import Data.Text qualified as T++import Tricorder.Build (Diagnostic (..), Severity (..))+import Tricorder.Daemon.Ghci.Position (Position)+import Tricorder.Daemon.Ghci.TextParser (TextParser)++import Tricorder.Daemon.Ghci.Position qualified as Position+++-- | Synthetic diagnostic for a failed load with no located error. Without a+-- source span it cannot point anywhere, but it stops the build reading as+-- clean and tells the user where to look.+unattributedFailure :: Diagnostic+unattributedFailure =+    Diagnostic+        { severity = SError+        , file = "<no location info>"+        , line = 0+        , col = 0+        , endLine = 0+        , endCol = 0+        , title = "GHCi reported a failed load with no located error"+        , text =+            "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n"+        }+++-- | Parse the full diagnostic header:+--   @file:pos:@ or @drive:path:pos:@ for Windows.+-- Returns @(file, startPos, endPos, textAfterColon)@.+headerParser :: TextParser (Text, Position, Position, Text)+headerParser = do+    a <- takeWhile1P Nothing (/= ':')+    _ <- char ':'+    filePart <-+        if T.length a == 1 && isAlpha (T.head a)+            then do+                pathRest <- takeWhile1P Nothing (/= ':')+                _ <- char ':'+                pure (a <> ":" <> pathRest)+            else+                pure a+    (sp, ep) <- Position.parser+    afterPos <- getInput+    pure (filePart, sp, ep, afterPos)

@@ -0,0 +1,28 @@+module Tricorder.Daemon.Ghci.InterruptDecision+    ( InterruptDecision (..)+    , decide+    )+where++import Tricorder.Daemon.Ghci.Session.State qualified as Session (State)+import Tricorder.Daemon.Ghci.Session.State qualified as Session.State+++-- | The outcome of consulting the 'SessionState' when an interrupt arrives.+--+-- 'NoOpIdle' means the GHCi session is at the prompt — sending SIGINT and a+-- sync marker would dirty the buffers and desync the next 'execGhci'.+-- 'SendInterruptFor n' means a command was in flight (state 'Busy n') and+-- the caller should SIGINT the process group and re-write @markerFor n@ (that+-- command's own marker) to unblock the in-progress 'drainUntil'.+data InterruptDecision+    = NoOpIdle+    | SendInterruptFor Int+    deriving stock (Eq, Show)+++-- | Pure state machine for 'interruptGhci'. Returns the new 'SessionState'+-- to install along with the 'InterruptDecision' the caller should act on.+decide :: Session.State -> (Session.State, InterruptDecision)+decide s@(Session.State.Idle _) = (s, NoOpIdle)+decide (Session.State.Busy n) = (Session.State.Idle (n + 1), SendInterruptFor n)

@@ -0,0 +1,66 @@+module Tricorder.Daemon.Ghci.LineParser+    ( LineStream (..)+    , LineParser+    , satisfyStripped+    , stripAnsi+    )+where++import Text.Megaparsec (Parsec, Stream (..), token)+import Prelude hiding (many)++import Data.Char qualified as Char+import Data.Text qualified as T+++-- ---------------------------------------------------------------------------+-- LineStream: a Stream instance for [Text] where Token = Text+-- ---------------------------------------------------------------------------++-- | Wrapper so we can define Stream / VisualStream / TraversableStream for+--   a list of 'Text' lines without orphan-instance conflicts.+newtype LineStream = LineStream [Text]+++instance Stream LineStream where+    type Token LineStream = Text+    type Tokens LineStream = [Text]+    tokenToChunk Proxy = pure+    tokensToChunk Proxy = id+    chunkToTokens Proxy = id+    chunkLength Proxy = length+    chunkEmpty Proxy = null+    take1_ (LineStream []) = Nothing+    take1_ (LineStream (t : ts)) = Just (t, LineStream ts)+    takeN_ n (LineStream s)+        | n <= 0 = Just ([], LineStream s)+        | null s = Nothing+        | otherwise = let (a, b) = splitAt n s in Just (a, LineStream b)+    takeWhile_ p (LineStream s) =+        let (a, b) = span p s in (a, LineStream b)+++-- | Parser over a stream of 'Text' lines.+type LineParser = Parsec Void LineStream+++-- | Consume a line whose stripped form satisfies the predicate.+-- Returns @(originalLine, strippedLine)@.+satisfyStripped :: (Text -> Bool) -> LineParser (Text, Text)+satisfyStripped p = token testLine mempty+  where+    testLine line =+        let stripped = stripAnsi line+        in  if p stripped then Just (line, stripped) else Nothing+++-- | Strip ANSI escape sequences of the form @ESC [ \<params\> \<letter\>@.+stripAnsi :: Text -> Text+stripAnsi t = case T.uncons t of+    Nothing -> t+    Just ('\ESC', rest) -> case T.uncons rest of+        Just ('[', rest') ->+            let afterParams = T.dropWhile (not . Char.isAlpha) rest'+            in  stripAnsi (T.drop 1 afterParams)+        _ -> T.cons '\ESC' (stripAnsi rest)+    Just (c, rest) -> T.cons c (stripAnsi rest)

@@ -0,0 +1,143 @@+module Tricorder.Daemon.Ghci.Load+    ( Load (..)+    , parser+    , textParser+    )+where++import Text.Megaparsec (anySingle, choice, satisfy, takeWhile1P, takeWhileP)+import Text.Megaparsec.Char (char, string)++import Data.Char qualified as Char+import Data.Text qualified as T+import Text.Megaparsec.Char.Lexer qualified as L++import Tricorder.Daemon.Ghci.LineParser (LineParser)+import Tricorder.Daemon.Ghci.LoadOutcome (LoadOutcome)+import Tricorder.Daemon.Ghci.Position (Position (..))+import Tricorder.Daemon.Ghci.TextParser (TextParser)++import Tricorder.Daemon.Ghci.Diagnostic qualified as Diagnostic+import Tricorder.Daemon.Ghci.LineParser qualified as LineParser+import Tricorder.Daemon.Ghci.LoadOutcome qualified as LoadOutcome+import Tricorder.Daemon.Ghci.Loading qualified as Ghci (Loading (..))+import Tricorder.Daemon.Ghci.Loading qualified as Ghci.Loading+import Tricorder.Daemon.Ghci.Message qualified as Ghci+import Tricorder.Daemon.Ghci.Severity qualified as Severity+import Tricorder.Daemon.Ghci.TextParser qualified as TextParser+++-- | A structured item from GHCi's reload output.+data Load+    = Loading Ghci.Loading+    | Message Ghci.Message+    | LoadConfig FilePath+    | Summary LoadOutcome+    deriving stock (Eq, Show)+++-- | Parse one item (or skip one line) from the reload output.+parser :: LineParser (Maybe Load)+parser =+    choice+        [ -- Pattern: "Loaded GHCi configuration from <path>"+          fmap Just $ do+            (_, stripped) <- LineParser.satisfyStripped ("Loaded GHCi configuration from " `T.isPrefixOf`)+            let file = toString $ T.drop (T.length "Loaded GHCi configuration from ") stripped+            pure (LoadConfig file)+        , -- Pattern: "[N of M] Compiling ..."+          do+            (_, stripped) <- LineParser.satisfyStripped ("[" `T.isPrefixOf`)+            pure (TextParser.run textParser stripped)+        , -- Pattern: terminal summary line "Ok, ..." / "Failed, ..."+          fmap Just $ do+            (_, stripped) <-+                LineParser.satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s)+            pure+                $ Summary+                $ if "Failed, " `T.isPrefixOf` stripped+                    then LoadOutcome.LoadFailed+                    else LoadOutcome.LoadSucceeded+        , -- Pattern: "<no location info>: error:"+          fmap Just $ do+            (origLine, _) <- LineParser.satisfyStripped ("<no location info>: error:" `T.isPrefixOf`)+            body <- many (satisfy isMessageBody)+            pure+                $ Message+                    Ghci.Message+                        { severity = Severity.Error+                        , file = "<no location info>"+                        , startPos = Position 0 0+                        , endPos = Position 0 0+                        , messageLines = origLine : body+                        }+        , -- Pattern: diagnostic "file:pos:severity: ..."+          do+            (origLine, stripped) <-+                LineParser.satisfyStripped+                    ( \s ->+                        not (T.null s)+                            && not (" " `T.isPrefixOf` s)+                            && not ("\t" `T.isPrefixOf` s)+                    )+            case TextParser.run Diagnostic.headerParser stripped of+                Nothing -> pure Nothing+                Just (fileT, sp, ep, afterPos) ->+                    let lower = T.toLower (T.stripStart afterPos)+                    in  case Severity.parse lower of+                            Nothing -> pure Nothing+                            Just sev -> do+                                body <- many (satisfy isMessageBody)+                                pure+                                    $ Just+                                    $ Message+                                        Ghci.Message+                                            { severity = sev+                                            , file = toString fileT+                                            , startPos = sp+                                            , endPos = ep+                                            , messageLines = origLine : body+                                            }+        , -- Fallback: skip any other line+          fmap (const Nothing) anySingle+        ]+++-- | Parse a "[N of M] Compiling Mod ( file, ... )" loading line.+textParser :: TextParser Load+textParser = do+    _ <- char '['+    _ <- takeWhileP Nothing (== ' ')+    n <- L.decimal+    _ <- string " of "+    m <- L.decimal+    _ <- takeWhileP Nothing (== ' ')+    _ <- char ']'+    _ <- takeWhile1P Nothing (== ' ')+    _ <- string "Compiling"+    _ <- takeWhile1P Nothing (== ' ')+    modName <- takeWhile1P Nothing (not . Char.isSpace)+    _ <- takeWhileP Nothing (/= '(')+    _ <- char '('+    _ <- takeWhileP Nothing (== ' ')+    filePath <- takeWhile1P Nothing (\c -> c /= ',' && c /= ')')+    pure+        $ Loading+            Ghci.Loading+                { Ghci.Loading.index = n+                , Ghci.Loading.total = m+                , Ghci.Loading.moduleName = modName+                , Ghci.Loading.sourceFile = toString (T.stripEnd filePath)+                }+++-- | Check if a line is a continuation of a diagnostic message body.+isMessageBody :: Text -> Bool+isMessageBody line =+    " " `T.isPrefixOf` line+        || "\t" `T.isPrefixOf` line+        || case T.break (== '|') line of+            (prefix, rest)+                | not (T.null rest) ->+                    T.all (\c -> Char.isSpace c || Char.isDigit c) prefix+            _ -> False

@@ -0,0 +1,7 @@+module Tricorder.Daemon.Ghci.LoadOutcome (LoadOutcome (..)) where+++-- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@+-- on success or @Failed, …@ on failure.+data LoadOutcome = LoadSucceeded | LoadFailed+    deriving stock (Eq, Show)

@@ -0,0 +1,54 @@+module Tricorder.Daemon.Ghci.LoadResult+    ( LoadResult (..)+    , resolveKnownTargets+    )+where++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++import Tricorder.Build (Diagnostic)+import Tricorder.Daemon.Ghci.LoadedModule (LoadedModule (..))+++-- | The result of a GHCi load or reload operation.+data LoadResult = LoadResult+    { moduleCount :: Int+    , compiledFiles :: Set FilePath+    -- ^ Files compiled in this cycle (derived from 'GLoading' items).+    -- Used by the session layer to decide which files' previous diagnostics to replace vs. retain.+    , loadedModules :: Map FilePath LoadedModule+    -- ^ Map from canonical absolute path to module metadata, derived from @:show modules@ output.+    -- Lists only modules that compiled successfully this cycle — GHCi drops+    -- failed-compile modules from @:show modules@.+    , targetNames :: [Text]+    -- ^ Raw entries from @:show targets@ — typically dotted module names+    -- in @cabal repl --enable-multi-repl@. Unlike 'loadedModules' this+    -- survives failed compiles, so the Builder feeds it into+    -- @KnownTargetNames@ for the dispatcher's fallback lookup.+    , diagnostics :: [Diagnostic]+    }+    deriving stock (Eq, Show)+++-- | Path↔module-name map for the next cycle: this round's @:show modules@+-- plus carryover from @prev@ for targets that failed mid-session and so+-- dropped out. Never-compiled targets are absent here (no path↔name+-- mapping); the dispatcher recognises those via 'KnownTargetNames'.+resolveKnownTargets+    :: Map FilePath LoadedModule+    -- ^ Previous known-targets map (carryover source).+    -> LoadResult+    -> Map FilePath LoadedModule+resolveKnownTargets prev lr =+    let primary = lr.loadedModules+        primaryNames = Set.fromList [lm.moduleName | lm <- Map.elems primary]+        prevByName = Map.fromList [(lm.moduleName, (path, lm)) | (path, lm) <- Map.toList prev]+        carryover =+            Map.fromList+                [ (path, lm)+                | name <- lr.targetNames+                , not (Set.member name primaryNames)+                , Just (path, lm) <- [Map.lookup name prevByName]+                ]+    in  Map.union primary carryover

@@ -0,0 +1,13 @@+module Tricorder.Daemon.Ghci.LoadedModule+    ( LoadedModule (..)+    )+where+++-- | A module currently loaded in the GHCi session.+data LoadedModule = LoadedModule+    { relPath :: FilePath+    -- ^ Path relative to the project root (e.g. @"./src/Foo.hs"@).+    , moduleName :: Text+    }+    deriving stock (Eq, Show)

@@ -0,0 +1,13 @@+module Tricorder.Daemon.Ghci.Loading (Loading (..)) where+++-- | Payload for a @[N of M] Compiling Mod ( file, ... )@ line.+data Loading = Loading+    { index :: Int+    -- ^ N (this module's index in the compilation sequence)+    , total :: Int+    -- ^ M (total modules to compile)+    , moduleName :: Text+    , sourceFile :: FilePath+    }+    deriving stock (Eq, Show)

@@ -0,0 +1,17 @@+module Tricorder.Daemon.Ghci.Message (Message (..)) where++import Tricorder.Daemon.Ghci.Position (Position)+import Tricorder.Daemon.Ghci.Severity (Severity)+++-- | Payload for a compiler diagnostic (error or warning).+data Message = Message+    { severity :: Severity+    , file :: FilePath+    , startPos :: Position+    , endPos :: Position+    -- ^ equals 'startPos' when no span+    , messageLines :: [Text]+    -- ^ raw lines (with any ANSI), header first+    }+    deriving stock (Eq, Show)

@@ -0,0 +1,57 @@+module Tricorder.Daemon.Ghci.Output+    ( parseShowModules+    , parseShowTargets+    )+where++import Data.Char (isSpace)+import Text.Megaparsec+import Text.Megaparsec.Char (char)+import Prelude hiding (many)++import Data.Text qualified as T++import Tricorder.Daemon.Ghci.LineParser (LineParser, LineStream (..))+import Tricorder.Daemon.Ghci.TextParser (TextParser)++import Tricorder.Daemon.Ghci.LineParser qualified as LineParser+import Tricorder.Daemon.Ghci.TextParser qualified as TextParser+++-- | Parse the output of @:show modules@ into (module name, file path) pairs.+parseShowModules :: [Text] -> [(Text, FilePath)]+parseShowModules ls =+    case parse (catMaybes <$> many showModuleLine <* eof) "" (LineStream ls) of+        Right items -> items+        Left _ -> []+++-- | Parse or skip one line of @:show modules@ output.+showModuleLine :: LineParser (Maybe (Text, FilePath))+showModuleLine = do+    line <- anySingle+    pure $ TextParser.run showModuleLineP (LineParser.stripAnsi line)+++showModuleLineP :: TextParser (Text, FilePath)+showModuleLineP = do+    modName <- takeWhile1P Nothing (not . isSpace)+    _ <- takeWhileP Nothing (/= '(')+    _ <- char '('+    _ <- char ' '+    filePath <- takeWhile1P Nothing (\c -> c /= ',' && c /= ')')+    pure (modName, toString (T.stripEnd filePath))+++-- | Parse the output of @:show targets@.+--+-- Each line names one target. In @cabal repl --enable-multi-repl@ these are+-- dotted module names (e.g. @"Foo.Bar"@); in plain @ghci@ sessions they can+-- also be file paths. A leading @*@ marks the active interactive target and+-- is stripped. Blank lines are skipped.+parseShowTargets :: [Text] -> [Text]+parseShowTargets = mapMaybe parseLine+  where+    parseLine raw =+        let cleaned = T.strip $ T.dropWhile (== '*') $ T.strip $ LineParser.stripAnsi raw+        in  if T.null cleaned then Nothing else Just cleaned

@@ -0,0 +1,41 @@+module Tricorder.Daemon.Ghci.Path+    ( isLocationLess+    , pathSuffixesAsModuleName+    )+where++import System.FilePath (dropExtension, normalise, splitDirectories)++import Data.List qualified as List+import Data.Text qualified as T+++-- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully+-- @\<…\>@-bracketed marker such as @\<no location info\>@ or @\<interactive\>@+-- rather than a real source path. These carry no source span but can still+-- represent genuine build-level failures, so callers treat them specially+-- (kept rather than dropped, cleared every cycle rather than retained).+--+-- We require both the opening @\<@ and a closing @\>@ so a real (if exotic)+-- path that merely starts with @\<@, e.g. @\<generated\>/Foo.hs@, is not+-- mistaken for a marker.+isLocationLess :: FilePath -> Bool+isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f+++-- | Candidate dotted module names for a file path.+--+-- We can't convert dotted target names to paths without cabal's+-- source-dirs, so callers check the other direction: any uppercase-segment+-- suffix of the path (with @/@ → @.@, extension dropped) is a candidate.+-- E.g. @./tricorder/src/Tricorder/Version.hs@ yields candidates+-- @"Tricorder.Version"@ and @"Version"@.+pathSuffixesAsModuleName :: FilePath -> [Text]+pathSuffixesAsModuleName fp =+    let segments = filter (not . null) (splitDirectories (dropExtension (normalise fp)))+        upperSegments = dropWhile (not . startsUpper) segments+        suffixes = takeWhile (not . null) (iterate (drop 1) upperSegments)+    in  [T.intercalate "." (map toText s) | s <- suffixes]+  where+    startsUpper (c : _) = c >= 'A' && c <= 'Z'+    startsUpper _ = False

@@ -0,0 +1,56 @@+module Tricorder.Daemon.Ghci.Position+    ( Position (..)+    , parser+    )+where++import Text.Megaparsec (Parsec, choice)+import Text.Megaparsec.Char (char)+import Prelude hiding (many)++import Text.Megaparsec.Char.Lexer qualified as L+++-- | A source position (1-based line and column). @(0, 0)@ when unavailable.+data Position = Position+    { line :: Int+    , col :: Int+    }+    deriving stock (Eq, Show)+++-- | Parse a GHCi position in one of the formats:+--   @(L1,C1)-(L2,C2):@, @L:C:@, or @L:C-C2:@.+-- Consumes the trailing colon.+parser :: Parsec Void Text (Position, Position)+parser = parenForm <|> simpleForm+  where+    parenForm = do+        _ <- char '('+        l1 <- L.decimal+        _ <- char ','+        c1 <- L.decimal+        _ <- char ')'+        _ <- char '-'+        _ <- char '('+        _ <- optional (char '(') -- some GHCi versions emit "(L1,C1)-((L2,C2):"+        l2 <- L.decimal+        _ <- char ','+        c2 <- L.decimal+        _ <- char ')'+        _ <- char ':'+        pure (Position l1 c1, Position l2 c2)+    simpleForm = do+        l <- L.decimal+        _ <- char ':'+        c <- L.decimal+        choice+            [ do+                _ <- char ':'+                pure (Position l c, Position l c)+            , do+                _ <- char '-'+                c2 <- L.decimal+                _ <- char ':'+                pure (Position l c, Position l c2)+            ]

@@ -0,0 +1,547 @@+module Tricorder.Daemon.Ghci.Process+    ( Process (..)+    , Error (..)+    , UnexpectedExit (..)+    , with+    , waitForBannerOrFail+    , exec+    , drainUntil+    , interruptGhci+    , terminateProcess+    , collectResult+    , reload+    , add+    , unadd+    )+where++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.File (BufferMode (..), File, Handle)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Process+    ( RunningProcess+    , createPipe+    , getStderr+    , getStdin+    , getStdout+    , setStderr+    , setStdin+    , setStdout+    , setWorkingDir+    , shell+    )+import Atelier.Effects.Timeout (Timeout, timeout)+import Control.Concurrent.STM (TVar, modifyTVar', readTVar, retry, writeTVar)+import Data.Sequence ((|>))+import Data.Time.Units (Second)+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, newTVarIO)+import Effectful.Exception (finally, throwIO, trySync)++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.File qualified as File+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Process qualified as Atelier+import Atelier.Effects.Process qualified as Process+import Data.Text qualified as T++import Tricorder.Daemon.Ghci.Config (Config (..))+import Tricorder.Daemon.Ghci.LoadResult (LoadResult (..))+import Tricorder.Daemon.Ghci.Loading (Loading)+import Tricorder.Daemon.Ghci.Result (parseProgressLine)+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))++import Tricorder.Daemon.Ghci.Diagnostic qualified as Diagnostic+import Tricorder.Daemon.Ghci.InterruptDecision qualified as InterruptDecision+import Tricorder.Daemon.Ghci.LineParser qualified as LineParser+import Tricorder.Daemon.Ghci.Output qualified as Output+import Tricorder.Daemon.Ghci.Result qualified as Result+import Tricorder.Daemon.Ghci.Session.State qualified as Session (State)+import Tricorder.Daemon.Ghci.Session.State qualified as Session.State+++-- | A handle to a running GHCi subprocess.+data Process = Process+    { stdin :: Handle+    , stdout :: Handle+    , stderr :: Handle+    , handle :: RunningProcess Handle Handle Handle+    , stateVar :: TVar Session.State+    }+++-- | Errors that can occur during GHCi process management.+data Error+    = StartupTimeout+    | UnexpectedExit UnexpectedExit+    | -- | The build command exited (or printed nothing parseable) before GHCi+      -- produced its version banner. The 'Text' is the captured stderr+stdout+      -- output so callers can surface a useful error (e.g. cabal's dependency+      -- resolution failure).+      StartupFailed Text+    deriving stock (Eq, Show)+++instance Exception Error where+    displayException :: Error -> String+    displayException StartupTimeout = "GHCi timed out while starting"+    displayException (UnexpectedExit unexpected) =+        "Encountered error while waiting for command output from GHCi: " <> toString unexpected.errorMessage+    displayException (StartupFailed msg) = "Failed to start GHCi: " <> toString msg+++data UnexpectedExit = MkUnexpectedExit+    { marker :: Text+    , errorMessage :: Text+    }+    deriving stock (Eq, Show)+++-- | Set up the GHCi protocol on an already-started process and return its+-- handle together with the output captured during startup.+--+-- The spawn and group teardown are owned by 'withProcess'.+setupProcess+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Timeout :> es+       )+    => Config+    -> RunningProcess Handle Handle Handle+    -> (Loading -> Eff es ())+    -- ^ Called as each @[N of M] Compiling …@ line is streamed during the+    -- initial-build drain, so the UI can update the progress bar live+    -- instead of replaying everything once compilation finishes.+    -> (Process -> Eff es ())+    -- ^ @onReady@. Called once the 'Process' is constructed but before the+    -- banner wait and initial-build drain — so callers can register the process+    -- for interruption while the slow @cabal repl@ startup (dependency build+    -- and recompilation) is still in progress.+    -> Eff es (Process, [Text])+setupProcess config p onProgress onReady = do+    let inp = getStdin p+        out = getStdout p+        err = getStderr p+    File.hSetBuffering inp LineBuffering+    File.hSetBuffering out LineBuffering+    File.hSetBuffering err LineBuffering++    -- Register the process for interruption before the (possibly slow) banner+    -- wait, so an interrupt during @cabal repl@ startup can terminate it.+    stateVar <- newTVarIO (Session.State.Idle 0)+    let ghciProcess =+            Process+                { stdin = inp+                , stdout = out+                , stderr = err+                , handle = p+                , stateVar = stateVar+                }+    onReady ghciProcess++    -- Send a blank line to kick GHCi into producing output+    File.hPutTextLn inp ""+    File.hFlush inp++    -- Wait for the version banner. We concurrently capture stderr so that if+    -- the build command exits before printing a banner (e.g. cabal's+    -- dependency resolution fails) we can surface its error output.+    waitForBannerOrFail config.startupTimeout out err++    -- Send fixed setup commands (protocol requirements)+    File.hPutTextLn inp ":set prompt \"\""+    File.hPutTextLn inp ":set prompt-cont \"\""+    -- Send any caller-supplied extra setup commands+    for_ config.extraSetupCommands \c ->+        File.hPutTextLn inp c+    File.hFlush inp++    -- Sync: drain until marker 1 seen, then set counter to 2.+    -- Capture lines from both streams — the stderr output contains the initial+    -- compilation progress and any startup diagnostics. The line hook fires+    -- 'onProgress' for each "[N of M] Compiling …" line as it arrives, so the+    -- UI can update the progress bar live during the initial build.+    let marker1 = markerFor 1+        hook = progressLineHook onProgress+    sendSyncCommand inp marker1+    initialLines <- Conc.scoped do+        stdoutThread <- Conc.fork $ drainUntil out marker1 hook+        stderrThread <- Conc.fork $ drainUntil err marker1 hook+        stdoutLines <- Conc.await stdoutThread+        stderrLines <- Conc.await stderrThread+        pure (stdoutLines ++ stderrLines)+    atomically $ writeTVar stateVar (Session.State.Idle 2)++    pure (ghciProcess, initialLines)+++-- | Run a GHCi @cabal repl@ session for the duration of @action@.+--+-- The session runs in its own process group, so the whole group is torn down on+-- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The+-- action receives the process handle and the output captured during startup.+-- See 'setupProcess' for the @onProgress@ and @onReady@ callbacks.+with+    :: (Atelier.Process :> es, Conc :> es, Concurrent :> es, File :> es, Log :> es, Timeout :> es)+    => Config+    -> RenderedCommand stage+    -> FilePath+    -> (Loading -> Eff es ())+    -> (Process -> Eff es ())+    -> (Process -> [Text] -> Eff es a)+    -> Eff es a+with config cmd dir onProgress onReady action =+    Process.withProcessGroup processConfig \p -> do+        (ghciProcess, initialLines) <- setupProcess config p onProgress onReady+        action ghciProcess initialLines `finally` quitGhci config ghciProcess+  where+    processConfig =+        setStdin createPipe+            $ setStdout createPipe+            $ setStderr createPipe+            $ setWorkingDir dir+            $ shell+            $ toString cmd.getRenderedCommand+++-- | Execute a command in GHCi and return the combined stdout+stderr output+-- lines. The @onProgress@ callback fires for each @[N of M] Compiling …@ line+-- as it arrives, so reload/add/unadd progress is streamed live to the UI.+-- Pass @\\_ -> pure ()@ for commands that do not trigger compilation.+exec+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       )+    => Process -> Text -> (Loading -> Eff es ()) -> Eff es [Text]+exec ghciProcess command onProgress = do+    n <- atomically do+        readTVar ghciProcess.stateVar >>= \case+            Session.State.Idle n -> writeTVar ghciProcess.stateVar (Session.State.Busy n) $> n+            Session.State.Busy _ -> retry+    doExec n `finally` atomically (writeTVar ghciProcess.stateVar (Session.State.Idle (n + 1)))+  where+    doExec n = do+        let marker = markerFor n+            hook = progressLineHook onProgress+        File.hPutTextLn ghciProcess.stdin command+        File.hFlush ghciProcess.stdin+        sendSyncCommand ghciProcess.stdin marker+        -- Scoped so that an exception from one drain (e.g. 'UnexpectedExit'+        -- when the underlying process is terminated mid-command) is+        -- contained here, re-raised by 'await', and caught by the caller's+        -- 'trySync'. Without 'scoped', Ki propagates the exception to the+        -- \*ambient* scope — typically the builder's listener scope — which+        -- tears down the whole builder loop instead of just failing this+        -- one command.+        (stdoutLines, stderrLines) <- Conc.scoped do+            stdoutThread <- Conc.fork $ drainUntil ghciProcess.stdout marker hook+            stderrThread <- Conc.fork $ drainUntil ghciProcess.stderr marker hook+            (,) <$> Conc.await stdoutThread <*> Conc.await stderrThread+        pure (stdoutLines ++ stderrLines)+++-- | Interrupt the currently running GHCi command (if any).+--+-- If a command is in progress (state 'Busy n'), sends SIGINT to the GHCi+-- process group and re-writes /that command's own/ sync marker (@markerFor n@)+-- so the in-progress 'drainUntil', which is waiting for exactly that marker,+-- unblocks. The next command runs as @n + 1@ and waits for @markerFor (n + 1)@,+-- so any duplicate @markerFor n@ left in the buffers is skipped by 'drainUntil'+-- rather than mistaken for the next command's marker.+--+-- When GHCi is 'Idle' this is a true no-op: sending SIGINT and a sync marker to+-- an idle GHCi leaves leftover marker output in the buffers.+interruptGhci :: (Atelier.Process :> es, Concurrent :> es, File :> es) => Process -> Eff es ()+interruptGhci ghciProcess = do+    decision <- atomically do+        s <- readTVar ghciProcess.stateVar+        let (s', d) = InterruptDecision.decide s+        writeTVar ghciProcess.stateVar s'+        pure d+    case decision of+        InterruptDecision.NoOpIdle -> pure ()+        InterruptDecision.SendInterruptFor n -> do+            Process.interruptProcessGroup ghciProcess.handle+            sendSyncCommand ghciProcess.stdin (markerFor n)+++-- | Forcefully terminate a GHCi process and its whole group.+--+-- Stronger than 'interruptGhci': intended for one-shot processes (such as the+-- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is+-- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT+-- handlers that finalise the current run rather than aborting it. Safe to call+-- from another thread while the session is running.+terminateProcess :: (Atelier.Process :> es) => Process -> Eff es ()+terminateProcess ghciProcess =+    Process.terminateProcessGroup ghciProcess.handle+++-- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it+-- shut down gracefully before the enclosing 'withProcess' tears down the+-- group. Never throws.+quitGhci :: (Atelier.Process :> es, File :> es, Timeout :> es) => Config -> Process -> Eff es ()+quitGhci config ghciProcess = do+    void $ trySync $ do+        File.hPutTextLn ghciProcess.stdin ":quit"+        File.hFlush ghciProcess.stdin+    void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle)+++-- ---------------------------------------------------------------------------+-- Internal helpers++-- | Build the finish marker for counter value @n@.+markerFor :: Int -> Text+markerFor n = markerPrefix <> show n <> "~#"+++-- | The prefix shared by all finish markers.+markerPrefix :: Text+markerPrefix = "#~TRI-FINISH-"+++-- | Write the synchronisation Haskell statements to GHCi stdin.+--+-- After each user command, these cause GHCi to emit the finish marker on both+-- stdout and stderr, so 'drainUntil' knows when to stop.+--+-- The marker is emitted as two standalone, fully-qualified statements — one per+-- stream — using only 'System.IO.hPutStrLn'. This is deliberate: a+-- SIGINT-interrupted ':reload' empties GHCi's interactive scope, dropping the+-- implicit @import Prelude@, so bare names like @putStrLn@ (and even the @>>@+-- operator) fall out of scope. A marker built from those would /error/ instead+-- of printing — its marker would never appear and 'drainUntil' would block+-- forever waiting for it (the "stuck Building…" stall). Fully-qualified+-- 'System.IO.hPutStrLn' resolves via GHCi's implicit qualified imports even+-- with an emptied scope, so the marker survives an interrupt.+sendSyncCommand :: (File :> es) => Handle -> Text -> Eff es ()+sendSyncCommand h marker = do+    -- Use show to produce a valid Haskell string literal for the marker text.+    let markerLit = toText (show @String (toString marker)) -- e.g. "\"#~TRI-FINISH-3~#\""+    File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stdout " <> markerLit)+    File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stderr " <> markerLit)+    File.hFlush h+++-- | Read lines from a handle until /this command's/ finish marker is seen (or+-- EOF).+--+-- Stops only on a line containing the exact @marker@ it was given. A line+-- carrying a /different/ finish marker — a stale leftover from a prior command+-- that was interrupted mid-flight — is skipped rather than matched, so it can+-- never make a later drain return prematurely (the "0 modules"/hang desync).+-- Each ordinary line is passed to @onLine@ as it arrives, so callers can stream+-- progress without waiting for the full drain to complete. Returns accumulated+-- non-marker lines in order. Throws 'UnexpectedExit' on EOF before the marker.+drainUntil :: (File :> es, 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 ex -> do+                let accumulatedLines = T.intercalate "\n" $ toList acc+                    errorMessage =+                        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+                                        ]+                Log.err errorMessage+                throwIO+                    $ UnexpectedExit+                    $ MkUnexpectedExit {marker, errorMessage}+            Right line+                | 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 $ acc |> line+++-- | Convert a 'GhciLoading' progress callback into a per-line hook suitable+-- for 'drainUntil'. Non-progress lines are ignored.+progressLineHook :: (Loading -> Eff es ()) -> Text -> Eff es ()+progressLineHook onProgress line = traverse_ onProgress (parseProgressLine line)+++-- | Wait up to the given number of seconds for a GHCi version banner on+-- stdout, capturing stderr (and any non-banner stdout lines) in case the+-- build command fails before printing a banner.+--+-- Throws 'StartupFailed' with the captured output if stdout EOFs (the build+-- command exited) or 'StartupTimeout' if the banner never arrives.+waitForBannerOrFail+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Timeout :> es+       )+    => Second -> Handle -> Handle -> Eff es ()+waitForBannerOrFail delay out err = do+    capturedVar <- newTVarIO ([] :: [Text])+    let captureLine line = atomically $ modifyTVar' capturedVar (line :)+        drainStderr = drainUntilEof err captureLine+        watchStdout = waitForBannerStdout out captureLine++    Conc.scoped do+        stderrThread <- Conc.fork drainStderr+        result <- timeout delay $ trySync watchStdout+        case result of+            Just (Right ()) -> pure ()+            Just (Left ex) -> do+                -- stdout EOF before the banner: the build command exited. Wait+                -- for the stderr drain to reach EOF too (bounded, in case the+                -- pipe lingers) so we surface its *complete* output — e.g.+                -- cabal's dependency-resolution error — rather than whatever+                -- the drain happened to have read so far.+                _ <- timeout (1 :: Second) (Conc.await stderrThread)+                captured <- atomically $ readTVar capturedVar+                throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured)+            Nothing -> do+                captured <- atomically $ readTVar capturedVar+                throwIO $ maybe StartupTimeout StartupFailed (renderCapturedLines captured)+++waitForBannerStdout :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()+waitForBannerStdout h captureLine = go+  where+    isVersionLine :: Text -> Bool+    isVersionLine line =+        let stripped = LineParser.stripAnsi line+        in  "GHCi, version " `T.isInfixOf` stripped+                || "GHCJSi, version " `T.isInfixOf` stripped+                || "Clashi, version " `T.isInfixOf` stripped++    go = do+        result <- trySync $ File.hGetLine h+        case result of+            Left ex -> throwIO ex+            Right line ->+                if isVersionLine line+                    then+                        pure ()+                    else do+                        captureLine line+                        go+++drainUntilEof :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()+drainUntilEof h onLine = go+  where+    go = do+        result <- trySync $ File.hGetLine h+        case result of+            Left _ -> pure ()+            Right line -> onLine line >> go+++-- | Render the captured (reverse-order) output lines into an error message,+-- stripping ANSI escapes and dropping blank lines. Returns 'Nothing' when+-- nothing useful remains, so callers can fall back to a generic message.+renderCapturedLines :: [Text] -> Maybe Text+renderCapturedLines capturedRev =+    let cleaned = filter (not . T.null . T.strip) (map LineParser.stripAnsi (reverse capturedRev))+    in  if null cleaned then Nothing else Just (T.intercalate "\n" cleaned)+++-- | Fallback message when the build command exited before the banner without+-- printing anything we could capture.+startupExitedMessage :: SomeException -> Text+startupExitedMessage ex =+    "Build command exited before GHCi started: " <> toText (displayException ex)+++-- | Parse already-drained GHCi output lines into a 'LoadResult', fetching the+-- current module list via @:show modules@.+--+-- Progress is emitted live by 'drainUntil' as lines arrive, so no replay+-- callback is needed here — this function only assembles the final result.+collectResult+    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)+    => Process+    -> [Text]+    -> FilePath+    -> Eff es LoadResult+collectResult process lines' projectRoot = do+    let noProgress = \_ -> pure ()+    moduleLines <- exec process ":show modules" noProgress+    targetLines <- exec process ":show targets" noProgress+    let result =+            Result.collectResult+                projectRoot+                lines'+                (Output.parseShowModules moduleLines)+                (Output.parseShowTargets targetLines)+    -- A failed load with no located error produces only the synthetic+    -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in+    -- that case, so log the raw GHCi output — it's the only way to see what+    -- actually went wrong, and the synthetic diagnostic points here.+    when (any (== Diagnostic.unattributedFailure) result.diagnostics)+        $ Log.info+        $ "GHCi reported a failed load with no located error. Full GHCi output:\n"+            <> T.unlines lines'+    pure result+++-- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events+-- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read.+reload+    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)+    => Process+    -> FilePath+    -> (Loading -> Eff es ())+    -> Eff es LoadResult+reload process projectRoot onProgress = do+    reloadLines <- exec process ":reload" onProgress+    collectResult process reloadLines projectRoot+++-- | Execute @:add@ for the given file and return the assembled 'LoadResult'.+-- Progress events fire live via @onProgress@ as compilation proceeds.+add+    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)+    => Process+    -> FilePath -- the file to :add+    -> FilePath -- projectRoot+    -> (Loading -> Eff es ())+    -> Eff es LoadResult+add process filePath projectRoot onProgress = do+    addLines <- exec process (":add " <> T.pack filePath) onProgress+    collectResult process addLines projectRoot+++-- | Execute @:unadd@ for the given module and return the assembled+-- 'LoadResult'. Progress events fire live via @onProgress@ as compilation+-- proceeds.+unadd+    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)+    => Process+    -> Text -- the module name to :unadd+    -> FilePath -- projectRoot+    -> (Loading -> Eff es ())+    -> Eff es LoadResult+unadd process moduleName projectRoot onProgress = do+    unaddLines <- exec process (":unadd " <> moduleName) onProgress+    collectResult process unaddLines projectRoot

@@ -0,0 +1,230 @@+module Tricorder.Daemon.Ghci.Result+    ( collectResult+    , collectResultCustom+    , reloadFailed+    , parseProgressLine+    , parseReload+    , extractTitle+    , toAbsolute+    , toRelative+    )+where++import Data.Char (isDigit, isSpace, toLower)+import System.FilePath (isAbsolute, makeRelative, normalise, splitDirectories, (</>))+import Text.Megaparsec+import Prelude hiding (many)++import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T++import Tricorder.Build (Diagnostic (..), Severity (..))+import Tricorder.Daemon.Ghci.LineParser (LineStream (..))+import Tricorder.Daemon.Ghci.Load (Load)+import Tricorder.Daemon.Ghci.LoadResult (LoadResult (..))+import Tricorder.Daemon.Ghci.LoadedModule (LoadedModule (..))+import Tricorder.Daemon.Ghci.Loading (Loading)+import Tricorder.Daemon.Ghci.Message (Message (..))+import Tricorder.Daemon.Ghci.Position (Position (..))++import Tricorder.Daemon.Ghci.Diagnostic qualified as Diagnostic+import Tricorder.Daemon.Ghci.LineParser qualified as LineParser+import Tricorder.Daemon.Ghci.Load qualified as Load+import Tricorder.Daemon.Ghci.LoadOutcome qualified as LoadOutcome+import Tricorder.Daemon.Ghci.Loading qualified as Loading+import Tricorder.Daemon.Ghci.Path qualified as Path+import Tricorder.Daemon.Ghci.Severity qualified as Severity+import Tricorder.Daemon.Ghci.TextParser qualified as TextParser+++-- ---------------------------------------------------------------------------+-- Line-level helpers+-- ---------------------------------------------------------------------------++-- ---------------------------------------------------------------------------+-- parseReload+-- ---------------------------------------------------------------------------++-- | Parse the output of @:reload@ from GHCi into structured items.+parseReload :: [Text] -> [Load]+parseReload ls =+    case parse (catMaybes <$> many Load.parser <* eof) "" (LineStream ls) of+        Right items -> items+        Left _ -> []+++-- | Parse a single line as a "[N of M] Compiling …" progress event.+--+-- Returns 'Nothing' for any line that is not a loading line. Used to stream+-- progress updates as GHCi emits them, rather than parsing the whole reload+-- output after the fact.+parseProgressLine :: Text -> Maybe Loading+parseProgressLine line =+    let stripped = LineParser.stripAnsi line+    in  if "[" `T.isPrefixOf` stripped+            then case TextParser.run Load.textParser stripped of+                Just (Load.Loading l) -> Just l+                _ -> Nothing+            else+                Nothing+++-- ---------------------------------------------------------------------------+-- Pure utilities (unchanged)+-- ---------------------------------------------------------------------------++-- | Make an absolute path relative to the given base directory, prefixed with @"./"@.+-- Paths already relative, or absolute paths outside @base@, are returned unchanged.+toRelative :: FilePath -> FilePath -> FilePath+toRelative base path+    | not (isAbsolute path) = path+    | otherwise = case splitDirectories (makeRelative base path) of+        (".." : _) -> path+        rel -> "." </> List.foldr1 (</>) rel+++-- | Make a relative path absolute by prepending the given base directory.+-- Paths already absolute are returned unchanged.+toAbsolute :: FilePath -> FilePath -> FilePath+toAbsolute base path+    | isAbsolute path = path+    | otherwise = base </> path+++-- | Assemble a 'LoadResult' from a project root, parsed reload items, the+-- @:show modules@ output, and the @:show targets@ output.+collectResultCustom :: FilePath -> [Load] -> [(Text, FilePath)] -> [Text] -> LoadResult+collectResultCustom projectRoot loads modules targets =+    let rel = toRelative projectRoot+        abs' = toAbsolute projectRoot+        compiledFiles = case [l.sourceFile | Load.Loading l <- loads] of+            [] -> Set.fromList (map (rel . snd) modules)+            fs -> Set.fromList (map rel fs)+        mkEntry (mn, fp) =+            ( normalise (abs' fp)+            , LoadedModule {relPath = rel fp, moduleName = mn}+            )+    in  LoadResult+            { moduleCount = length modules+            , compiledFiles+            , loadedModules = Map.fromList (map mkEntry modules)+            , targetNames = targets+            , diagnostics = toDiagnostics rel loads+            }+++-- | Assemble a 'LoadResult' from the raw reload output plus the @:show+-- modules@ / @:show targets@ output.+--+-- This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload+-- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a+-- location-less failure we don't otherwise attribute to a file), a synthetic+-- error diagnostic is appended so the build can never be reported as clean+-- while GHCi considers it failed.+collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult+collectResult projectRoot reloadLines modules targets =+    let loads = parseReload reloadLines+        base = collectResultCustom projectRoot loads modules targets+        hasError = any (\d -> d.severity == SError) base.diagnostics+    in  if reloadFailed loads && not hasError+            then+                base {diagnostics = base.diagnostics ++ [Diagnostic.unattributedFailure]}+            else+                base+++-- | Whether GHCi's load ended in failure, decided from the 'GSummary' items+-- 'parseReload' produces — the single place that classifies GHCi's terminal+-- @Ok, …@ / @Failed, …@ summary line.+--+-- GHCi emits the real summary last, after all compilation output. Output+-- produced /during/ the load (a Template Haskell splice, top-level IO run while+-- interpreting) can contain an earlier line that looks like a summary, so only+-- the /last/ 'GSummary' reflects the true outcome.+reloadFailed :: [Load] -> Bool+reloadFailed loads =+    case [outcome | Load.Summary outcome <- loads] of+        [] -> False+        outcomes -> List.last outcomes == LoadOutcome.LoadFailed+++toDiagnostics :: (FilePath -> FilePath) -> [Load] -> [Diagnostic]+toDiagnostics rel loads = mapMaybe toMsg loads+  where+    -- Location-less messages (e.g. @<no location info>@, @<interactive>@) carry+    -- no source span. We keep the *errors* — a @<no location info>@ error is a+    -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in+    -- @--enable-multi-repl@) and must not be silently dropped — but discard+    -- location-less warnings, which are just noise without a file to attach to.+    toMsg (Load.Message m) | Path.isLocationLess m.file, m.severity /= Severity.Error = Nothing+    toMsg (Load.Message m) =+        Just+            Diagnostic+                { severity = case m.severity of+                    Severity.Warning -> SWarning+                    Severity.Error -> SError+                , file = rel m.file+                , line = m.startPos.line+                , col = m.startPos.col+                , endLine = m.endPos.line+                , endCol = m.endPos.col+                , title = extractTitle (map toString m.messageLines)+                , text = unlines (map toText m.messageLines)+                }+    toMsg _ = Nothing+++-- | Extract a short human-readable title from GHCi message lines.+--+-- The header line (@"file:line:col: severity: rest"@) is the first element.+-- The human-readable text is either:+--+--   * Inline, after @"error:"@ \/ @"warning:"@ in the header (old GHC style), or+--   * On subsequent indented lines (new GHC style, when header ends with a+--     diagnostic code such as @[GHC-83865]@ or @[-Wmissing-deriving-strategies]@).+--+-- Source-display lines (@"39 | ..."@, @"   | ^^^^"@) are skipped when+-- scanning body lines for content.+extractTitle :: [String] -> Text+extractTitle [] = ""+extractTitle (header : body) =+    fromMaybe (firstBodyLine body) $ inlineFromHeader $ toString $ LineParser.stripAnsi $ toText header+  where+    inlineFromHeader :: String -> Maybe Text+    inlineFromHeader h =+        let lower = map toLower h+        in  case headerAfter "error:" lower h <|> headerAfter "warning:" lower h of+                Nothing -> Nothing+                Just rest ->+                    let content = stripDiagCodes (dropWhile isSpace rest)+                    in  if null content then Nothing else Just (toText content)++    headerAfter :: String -> String -> String -> Maybe String+    headerAfter needle haystack original =+        fmap (\i -> drop (i + length needle) original)+            $ List.findIndex (needle `List.isPrefixOf`) (List.tails haystack)++    stripDiagCodes :: String -> String+    stripDiagCodes s = case dropWhile isSpace s of+        '[' : rest ->+            let after = dropWhile isSpace (drop 1 (dropWhile (/= ']') rest))+            in  stripDiagCodes after+        other -> other++    firstBodyLine :: [String] -> Text+    firstBodyLine xs =+        case [ t+             | x <- xs+             , let t = dropWhile isSpace (toString (LineParser.stripAnsi (toText x)))+             , not (null t)+             , not (isSourceLine t)+             ] of+            (t : _) -> toText t+            [] -> ""++    isSourceLine :: String -> Bool+    isSourceLine s = case dropWhile (\c -> isDigit c || c == ' ') s of+        ('|' : _) -> True+        _ -> not (null s) && all (\c -> c `elem` ("^~_ " :: String)) s

@@ -0,0 +1,131 @@+module Tricorder.Daemon.Ghci.Session+    ( -- * Effect+      Session+    , with++      -- * Interpreters+    , run+    , runScripted+    )+where++import Atelier.Effects.Conc (Conc)+import Atelier.Effects.File (File)+import Atelier.Effects.Log (Log)+import Atelier.Effects.Process (Process)+import Atelier.Effects.Timeout (Timeout)+import Data.Default (def)+import Effectful+    ( Effect+    , Limit (..)+    , Persistence (..)+    , UnliftStrategy (..)+    )+import Effectful.Concurrent (Concurrent)+import Effectful.Dispatch.Dynamic+    ( interpret+    , localLift+    , localSeqLift+    , localSeqUnlift+    , localUnlift+    , reinterpret+    )+import Effectful.Exception (throwIO)+import Effectful.State.Static.Shared (State, evalState, state)+import Effectful.TH (makeEffect)++import Tricorder.Build (BuildProgress (..))+import Tricorder.Daemon.Ghci.Controls (Controls (..))+import Tricorder.Daemon.Ghci.LoadResult (LoadResult)+import Tricorder.Daemon.Ghci.Loading (Loading (..))+import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command.RenderedCommand (RenderedCommand)+import Tricorder.Session.Stage (Stage (..))++import Tricorder.Daemon.Ghci.Controls qualified as Controls+import Tricorder.Daemon.Ghci.Process qualified as Ghci.Process+import Tricorder.Daemon.Ghci.Process qualified as Process+++data Session :: Effect where+    -- | Start a new GHCi session and run the handler with that session active.+    -- The handler is also provided an action to reload the GHCi session,+    -- returning new messages with module counts. The GHCi session is closed+    -- when the handler returns.+    With+        :: (BuildProgress -> m ())+        -- ^ Action to run when reporting progress+        -> RenderedCommand 'Build+        -> ProjectRoot+        -> (LoadResult -> Controls m -> m a)+        -> Session m a+++makeEffect ''Session+++-- | Scripted interpreter for testing.+--+-- Each call to 'startGhci' or 'reloadGhci' pops the next result from the+-- pre-loaded list. 'Left' results are re-thrown as exceptions, simulating+-- GHCi crashes. 'stopGhci' is always a no-op.+runScripted+    :: forall es a. [Either SomeException LoadResult] -> Eff (Session : es) a -> Eff es a+runScripted results = reinterpret (evalState results) $ \env ->+    let popResult :: Eff (State [Either SomeException LoadResult] : es) LoadResult+        popResult = do+            x <- state \case+                x : xs -> (x, xs)+                [] -> error "GhciSessionScripted: no more results in queue"+            case x of+                Left ex -> throwIO ex+                Right r -> pure r+    in  \case+            With _ _ _ handler -> do+                initial <- popResult+                localSeqLift env \liftEff ->+                    localSeqUnlift env \unlift ->+                        unlift+                            $ handler+                                initial+                                Controls+                                    { reload = liftEff popResult+                                    , interrupt = pure ()+                                    , add = \_ -> liftEff popResult+                                    , unadd = \_ -> liftEff popResult+                                    }+++-- | GHCi session manager backed by 'Tricorder.Daemon.GhciSession.GhciProcess'+-- and 'Tricorder.Daemon.GhciSession.GhciParser'.+run+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Process :> es+       , Timeout :> es+       )+    => Eff (Session : es) a -> Eff es a+run = interpret $ \env -> \case+    With onProgress cmd (ProjectRoot dir) handler -> do+        localLift env (ConcUnlift Persistent Unlimited) \liftEff ->+            localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do+                let reportProgress loading =+                        unlift+                            $ onProgress+                            $ BuildProgress+                                { compiled = loading.index+                                , total = loading.total+                                }+                Process.with def cmd dir reportProgress (\_ -> pure ()) \process startupLines -> do+                    initialResult <- Ghci.Process.collectResult process startupLines dir+                    unlift+                        $ handler initialResult+                        $ Controls.lift liftEff+                        $ Controls+                            { reload = Ghci.Process.reload process dir reportProgress+                            , interrupt = Ghci.Process.interruptGhci process+                            , add = \fp -> Ghci.Process.add process fp dir reportProgress+                            , unadd = \mn -> Ghci.Process.unadd process mn dir reportProgress+                            }

@@ -0,0 +1,5 @@+module Tricorder.Daemon.Ghci.Session.State (State (..)) where+++data State = Idle Int | Busy Int+    deriving stock (Eq, Show)

@@ -0,0 +1,20 @@+module Tricorder.Daemon.Ghci.Severity+    ( Severity (..)+    , parse+    )+where++import Data.Text qualified as T+++-- | Severity of a GHCi diagnostic message.+data Severity = Warning | Error+    deriving stock (Eq, Ord, Show)+++-- | Determine severity from the text after the position (lowercased, stripped).+parse :: Text -> Maybe Severity+parse lower+    | "warning:" `T.isPrefixOf` lower = Just Warning+    | "error:" `T.isPrefixOf` lower = Just Error+    | otherwise = Nothing

@@ -0,0 +1,19 @@+module Tricorder.Daemon.Ghci.TextParser+    ( TextParser+    , run+    )+where++import Text.Megaparsec (Parsec, parse)+import Prelude hiding (many)+++-- | Parser over a single 'Text' value.+type TextParser = Parsec Void Text+++-- | Run a 'TextParser' on a 'Text' value, returning 'Nothing' on failure.+run :: TextParser a -> Text -> Maybe a+run p t = case parse p "" t of+    Right x -> Just x+    Left _ -> Nothing

@@ -1,175 +0,0 @@-module Tricorder.Daemon.GhciSession-    ( -- * Effect-      GhciSession-    , Controls (..)-    , transformControls-    , withGhciWith-    , withGhci--      -- * Types-    , LoadResult (..)-    , LoadedModule (..)--      -- * Interpreters-    , runGhciSession-    , runGhciSessionScripted-    )-where--import Atelier.Effects.Conc (Conc)-import Atelier.Effects.File (File)-import Atelier.Effects.Log (Log)-import Atelier.Effects.Process (Process)-import Atelier.Effects.Publishing.Pub (Pub)-import Atelier.Effects.Timeout (Timeout)-import Data.Default (def)-import Effectful-    ( Effect-    , Limit (..)-    , Persistence (..)-    , UnliftStrategy (..)-    )-import Effectful.Concurrent (Concurrent)-import Effectful.Dispatch.Dynamic-    ( interpret-    , localLift-    , localSeqLift-    , localSeqUnlift-    , localUnlift-    , reinterpret-    )-import Effectful.Exception (throwIO)-import Effectful.State.Static.Shared (State, evalState, state)-import Effectful.TH (makeEffect)--import Atelier.Effects.Publishing.Pub qualified as Pub--import Tricorder.Build (BuildProgress (..))-import Tricorder.Daemon.GhciSession.GhciParser-    ( GhciLoading (..)-    , LoadResult (..)-    , LoadedModule (..)-    )-import Tricorder.Daemon.GhciSession.GhciProcess-    ( addGhci-    , collectGhciResult-    , interruptGhci-    , reloadGhci-    , unaddGhci-    , withGhciProcess-    )-import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command.RenderedCommand (RenderedCommand)-import Tricorder.Session.Stage (Stage (..))---data GhciSession :: Effect where-    -- | Start a new GHCi session and run the handler with that session active.-    -- The handler is also provided an action to reload the GHCi session,-    -- returning new messages with module counts. The GHCi session is closed-    -- when the handler returns.-    WithGhciWith-        :: (BuildProgress -> m ())-        -- ^ Action to run when reporting progress-        -> RenderedCommand 'Build-        -> ProjectRoot-        -> (LoadResult -> Controls m -> m a)-        -> GhciSession m a---data Controls m = Controls-    { reload :: m LoadResult-    , interrupt :: m ()-    , add :: FilePath -> m LoadResult-    , unadd :: Text -> m LoadResult-    }---makeEffect ''GhciSession---transformControls :: (forall a. m a -> n a) -> Controls m -> Controls n-transformControls f ctrls =-    Controls-        { reload = f ctrls.reload-        , interrupt = f ctrls.interrupt-        , add = f . ctrls.add-        , unadd = f . ctrls.unadd-        }---withGhci-    :: (GhciSession :> es, Pub BuildProgress :> es)-    => RenderedCommand 'Build-    -> ProjectRoot-    -> (LoadResult -> Controls (Eff es) -> Eff es a)-    -> Eff es a-withGhci cmd root handler = do-    withGhciWith Pub.publish cmd root handler----- | Scripted interpreter for testing.------ Each call to 'startGhci' or 'reloadGhci' pops the next result from the--- pre-loaded list. 'Left' results are re-thrown as exceptions, simulating--- GHCi crashes. 'stopGhci' is always a no-op.-runGhciSessionScripted-    :: forall es a. [Either SomeException LoadResult] -> Eff (GhciSession : es) a -> Eff es a-runGhciSessionScripted results = reinterpret (evalState results) $ \env ->-    let popResult :: Eff (State [Either SomeException LoadResult] : es) LoadResult-        popResult = do-            x <- state \case-                x : xs -> (x, xs)-                [] -> error "GhciSessionScripted: no more results in queue"-            case x of-                Left ex -> throwIO ex-                Right r -> pure r-    in  \case-            WithGhciWith _ _ _ handler -> do-                initial <- popResult-                localSeqLift env \liftEff ->-                    localSeqUnlift env \unlift ->-                        unlift-                            $ handler-                                initial-                                Controls-                                    { reload = liftEff popResult-                                    , interrupt = pure ()-                                    , add = \_ -> liftEff popResult-                                    , unadd = \_ -> liftEff popResult-                                    }----- | GHCi session manager backed by 'Tricorder.Daemon.GhciSession.GhciProcess'--- and 'Tricorder.Daemon.GhciSession.GhciParser'.-runGhciSession-    :: ( Conc :> es-       , Concurrent :> es-       , File :> es-       , Log :> es-       , Process :> es-       , Timeout :> es-       )-    => Eff (GhciSession : es) a -> Eff es a-runGhciSession = interpret $ \env -> \case-    WithGhciWith onProgress cmd (ProjectRoot dir) handler -> do-        localLift env (ConcUnlift Persistent Unlimited) \liftEff ->-            localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do-                let reportProgress loading =-                        unlift-                            $ onProgress-                            $ BuildProgress-                                { compiled = loading.index-                                , total = loading.total-                                }-                withGhciProcess def cmd dir reportProgress (\_ -> pure ()) \process startupLines -> do-                    initialResult <- collectGhciResult process startupLines dir-                    unlift-                        $ handler initialResult-                        $ transformControls liftEff-                        $ Controls-                            { reload = reloadGhci process dir reportProgress-                            , interrupt = interruptGhci process-                            , add = \fp -> addGhci process fp dir reportProgress-                            , unadd = \mn -> unaddGhci process mn dir reportProgress-                            }

@@ -1,674 +0,0 @@-module Tricorder.Daemon.GhciSession.GhciParser-    ( GhciLoad (..)-    , GhciLoading (..)-    , GhciMessage (..)-    , GhciSeverity (..)-    , LoadOutcome (..)-    , LoadResult (..)-    , LoadedModule (..)-    , Position (..)-    , collectResult-    , collectResultCustom-    , isLocationLess-    , reloadFailed-    , parseProgressLine-    , parseReload-    , parseShowModules-    , parseShowTargets-    , pathSuffixesAsModuleName-    , resolveKnownTargets-    , stripAnsi-    , extractTitle-    , toAbsolute-    , toRelative-    , unattributedFailure-    )-where--import Data.Char (isAlpha, isDigit, isSpace, toLower)-import System.FilePath (dropExtension, isAbsolute, makeRelative, normalise, splitDirectories, (</>))-import Text.Megaparsec-import Text.Megaparsec.Char (char, string)-import Prelude hiding (many)--import Data.List qualified as List-import Data.Map.Strict qualified as Map-import Data.Set qualified as Set-import Data.Text qualified as T-import Text.Megaparsec.Char.Lexer qualified as L--import Tricorder.Build (Diagnostic (..), Severity (..))----- | Severity of a GHCi diagnostic message.-data GhciSeverity = GWarning | GError-    deriving stock (Eq, Ord, Show)----- | Payload for a @[N of M] Compiling Mod ( file, ... )@ line.-data GhciLoading = GhciLoading-    { index :: Int-    -- ^ N (this module's index in the compilation sequence)-    , total :: Int-    -- ^ M (total modules to compile)-    , moduleName :: Text-    , sourceFile :: FilePath-    }-    deriving stock (Eq, Show)----- | A source position (1-based line and column). @(0, 0)@ when unavailable.-data Position = Position-    { line :: Int-    , col :: Int-    }-    deriving stock (Eq, Show)----- | Payload for a compiler diagnostic (error or warning).-data GhciMessage = GhciMessage-    { severity :: GhciSeverity-    , file :: FilePath-    , startPos :: Position-    , endPos :: Position-    -- ^ equals 'startPos' when no span-    , messageLines :: [Text]-    -- ^ raw lines (with any ANSI), header first-    }-    deriving stock (Eq, Show)----- | The terminal summary GHCi emits to close a load: @Ok, N modules loaded.@--- on success or @Failed, …@ on failure.-data LoadOutcome = LoadSucceeded | LoadFailed-    deriving stock (Eq, Show)----- | A structured item from GHCi's reload output.-data GhciLoad-    = GLoading GhciLoading-    | GMessage GhciMessage-    | GLoadConfig FilePath-    | GSummary LoadOutcome-    deriving stock (Eq, Show)----- | A module currently loaded in the GHCi session.-data LoadedModule = LoadedModule-    { relPath :: FilePath-    -- ^ Path relative to the project root (e.g. @"./src/Foo.hs"@).-    , moduleName :: Text-    }-    deriving stock (Eq, Show)----- | The result of a GHCi load or reload operation.-data LoadResult = LoadResult-    { moduleCount :: Int-    , compiledFiles :: Set FilePath-    -- ^ Files compiled in this cycle (derived from 'GLoading' items).-    -- Used by the session layer to decide which files' previous diagnostics to replace vs. retain.-    , loadedModules :: Map FilePath LoadedModule-    -- ^ Map from canonical absolute path to module metadata, derived from @:show modules@ output.-    -- Lists only modules that compiled successfully this cycle — GHCi drops-    -- failed-compile modules from @:show modules@.-    , targetNames :: [Text]-    -- ^ Raw entries from @:show targets@ — typically dotted module names-    -- in @cabal repl --enable-multi-repl@. Unlike 'loadedModules' this-    -- survives failed compiles, so the Builder feeds it into-    -- @KnownTargetNames@ for the dispatcher's fallback lookup.-    , diagnostics :: [Diagnostic]-    }-    deriving stock (Eq, Show)----- ------------------------------------------------------------------------------ LineStream: a Stream instance for [Text] where Token = Text--- ------------------------------------------------------------------------------- | Wrapper so we can define Stream / VisualStream / TraversableStream for---   a list of 'Text' lines without orphan-instance conflicts.-newtype LineStream = LineStream [Text]---instance Stream LineStream where-    type Token LineStream = Text-    type Tokens LineStream = [Text]-    tokenToChunk Proxy = pure-    tokensToChunk Proxy = id-    chunkToTokens Proxy = id-    chunkLength Proxy = length-    chunkEmpty Proxy = null-    take1_ (LineStream []) = Nothing-    take1_ (LineStream (t : ts)) = Just (t, LineStream ts)-    takeN_ n (LineStream s)-        | n <= 0 = Just ([], LineStream s)-        | null s = Nothing-        | otherwise = let (a, b) = splitAt n s in Just (a, LineStream b)-    takeWhile_ p (LineStream s) =-        let (a, b) = span p s in (a, LineStream b)----- ------------------------------------------------------------------------------ Parser type aliases--- ------------------------------------------------------------------------------- | Parser over a stream of 'Text' lines.-type LineParser = Parsec Void LineStream----- | Parser over a single 'Text' value.-type TextParser = Parsec Void Text----- ------------------------------------------------------------------------------ Text-level sub-parsers (helpers for diagnostic header parsing)--- ------------------------------------------------------------------------------- | Run a 'TextParser' on a 'Text' value, returning 'Nothing' on failure.-runTP :: TextParser a -> Text -> Maybe a-runTP p t = case parse p "" t of-    Right x -> Just x-    Left _ -> Nothing----- | Parse a GHCi position in one of the formats:---   @(L1,C1)-(L2,C2):@, @L:C:@, or @L:C-C2:@.--- Consumes the trailing colon.-positionP :: TextParser (Position, Position)-positionP = parenForm <|> simpleForm-  where-    parenForm = do-        _ <- char '('-        l1 <- L.decimal-        _ <- char ','-        c1 <- L.decimal-        _ <- char ')'-        _ <- char '-'-        _ <- char '('-        _ <- optional (char '(') -- some GHCi versions emit "(L1,C1)-((L2,C2):"-        l2 <- L.decimal-        _ <- char ','-        c2 <- L.decimal-        _ <- char ')'-        _ <- char ':'-        pure (Position l1 c1, Position l2 c2)-    simpleForm = do-        l <- L.decimal-        _ <- char ':'-        c <- L.decimal-        choice-            [ do-                _ <- char ':'-                pure (Position l c, Position l c)-            , do-                _ <- char '-'-                c2 <- L.decimal-                _ <- char ':'-                pure (Position l c, Position l c2)-            ]----- | Parse the full diagnostic header:---   @file:pos:@ or @drive:path:pos:@ for Windows.--- Returns @(file, startPos, endPos, textAfterColon)@.-diagHeaderP :: TextParser (Text, Position, Position, Text)-diagHeaderP = do-    a <- takeWhile1P Nothing (/= ':')-    _ <- char ':'-    filePart <--        if T.length a == 1 && isAlpha (T.head a)-            then do-                pathRest <- takeWhile1P Nothing (/= ':')-                _ <- char ':'-                pure (a <> ":" <> pathRest)-            else-                pure a-    (sp, ep) <- positionP-    afterPos <- getInput-    pure (filePart, sp, ep, afterPos)----- ------------------------------------------------------------------------------ Line-level helpers--- ------------------------------------------------------------------------------- | Check if a line is a continuation of a diagnostic message body.-isMessageBody :: Text -> Bool-isMessageBody line =-    " " `T.isPrefixOf` line-        || "\t" `T.isPrefixOf` line-        || case T.break (== '|') line of-            (prefix, rest)-                | not (T.null rest) ->-                    T.all (\c -> isSpace c || isDigit c) prefix-            _ -> False----- | Consume a line whose stripped form satisfies the predicate.--- Returns @(originalLine, strippedLine)@.-satisfyStripped :: (Text -> Bool) -> LineParser (Text, Text)-satisfyStripped p = token testLine mempty-  where-    testLine line =-        let stripped = stripAnsi line-        in  if p stripped then Just (line, stripped) else Nothing----- ------------------------------------------------------------------------------ parseReload--- ------------------------------------------------------------------------------- | Parse the output of @:reload@ from GHCi into structured items.-parseReload :: [Text] -> [GhciLoad]-parseReload ls =-    case parse (catMaybes <$> many reloadItem <* eof) "" (LineStream ls) of-        Right items -> items-        Left _ -> []----- | Parse one item (or skip one line) from the reload output.-reloadItem :: LineParser (Maybe GhciLoad)-reloadItem =-    choice-        [ -- Pattern: "Loaded GHCi configuration from <path>"-          fmap Just $ do-            (_, stripped) <- satisfyStripped ("Loaded GHCi configuration from " `T.isPrefixOf`)-            let file = toString $ T.drop (T.length "Loaded GHCi configuration from ") stripped-            pure (GLoadConfig file)-        , -- Pattern: "[N of M] Compiling ..."-          do-            (_, stripped) <- satisfyStripped ("[" `T.isPrefixOf`)-            pure (runTP loadingLineP stripped)-        , -- Pattern: terminal summary line "Ok, ..." / "Failed, ..."-          fmap Just $ do-            (_, stripped) <--                satisfyStripped (\s -> "Ok, " `T.isPrefixOf` s || "Failed, " `T.isPrefixOf` s)-            pure-                $ GSummary-                $ if "Failed, " `T.isPrefixOf` stripped then LoadFailed else LoadSucceeded-        , -- Pattern: "<no location info>: error:"-          fmap Just $ do-            (origLine, _) <- satisfyStripped ("<no location info>: error:" `T.isPrefixOf`)-            body <- many (satisfy isMessageBody)-            pure-                $ GMessage-                    GhciMessage-                        { severity = GError-                        , file = "<no location info>"-                        , startPos = Position 0 0-                        , endPos = Position 0 0-                        , messageLines = origLine : body-                        }-        , -- Pattern: diagnostic "file:pos:severity: ..."-          do-            (origLine, stripped) <--                satisfyStripped-                    ( \s ->-                        not (T.null s)-                            && not (" " `T.isPrefixOf` s)-                            && not ("\t" `T.isPrefixOf` s)-                    )-            case runTP diagHeaderP stripped of-                Nothing -> pure Nothing-                Just (fileT, sp, ep, afterPos) ->-                    let lower = T.toLower (T.stripStart afterPos)-                    in  case parseSeverity lower of-                            Nothing -> pure Nothing-                            Just sev -> do-                                body <- many (satisfy isMessageBody)-                                pure-                                    $ Just-                                    $ GMessage-                                        GhciMessage-                                            { severity = sev-                                            , file = toString fileT-                                            , startPos = sp-                                            , endPos = ep-                                            , messageLines = origLine : body-                                            }-        , -- Fallback: skip any other line-          fmap (const Nothing) anySingle-        ]----- | Parse a single line as a "[N of M] Compiling …" progress event.------ Returns 'Nothing' for any line that is not a loading line. Used to stream--- progress updates as GHCi emits them, rather than parsing the whole reload--- output after the fact.-parseProgressLine :: Text -> Maybe GhciLoading-parseProgressLine line =-    let stripped = stripAnsi line-    in  if "[" `T.isPrefixOf` stripped-            then case runTP loadingLineP stripped of-                Just (GLoading l) -> Just l-                _ -> Nothing-            else-                Nothing----- | Parse a "[N of M] Compiling Mod ( file, ... )" loading line.-loadingLineP :: TextParser GhciLoad-loadingLineP = do-    _ <- char '['-    _ <- takeWhileP Nothing (== ' ')-    n <- L.decimal-    _ <- string " of "-    m <- L.decimal-    _ <- takeWhileP Nothing (== ' ')-    _ <- char ']'-    _ <- takeWhile1P Nothing (== ' ')-    _ <- string "Compiling"-    _ <- takeWhile1P Nothing (== ' ')-    modName <- takeWhile1P Nothing (not . isSpace)-    _ <- takeWhileP Nothing (/= '(')-    _ <- char '('-    _ <- takeWhileP Nothing (== ' ')-    filePath <- takeWhile1P Nothing (\c -> c /= ',' && c /= ')')-    pure-        $ GLoading-            GhciLoading-                { index = n-                , total = m-                , moduleName = modName-                , sourceFile = toString (T.stripEnd filePath)-                }----- | Determine severity from the text after the position (lowercased, stripped).-parseSeverity :: Text -> Maybe GhciSeverity-parseSeverity lower-    | "warning:" `T.isPrefixOf` lower = Just GWarning-    | "error:" `T.isPrefixOf` lower = Just GError-    | otherwise = Nothing----- ------------------------------------------------------------------------------ parseShowModules--- ------------------------------------------------------------------------------- | Parse the output of @:show modules@ into (module name, file path) pairs.-parseShowModules :: [Text] -> [(Text, FilePath)]-parseShowModules ls =-    case parse (catMaybes <$> many showModuleLine <* eof) "" (LineStream ls) of-        Right items -> items-        Left _ -> []----- | Parse or skip one line of @:show modules@ output.-showModuleLine :: LineParser (Maybe (Text, FilePath))-showModuleLine = do-    line <- anySingle-    pure $ runTP showModuleLineP (stripAnsi line)---showModuleLineP :: TextParser (Text, FilePath)-showModuleLineP = do-    modName <- takeWhile1P Nothing (not . isSpace)-    _ <- takeWhileP Nothing (/= '(')-    _ <- char '('-    _ <- char ' '-    filePath <- takeWhile1P Nothing (\c -> c /= ',' && c /= ')')-    pure (modName, toString (T.stripEnd filePath))----- ------------------------------------------------------------------------------ parseShowTargets--- ------------------------------------------------------------------------------- | Parse the output of @:show targets@.------ Each line names one target. In @cabal repl --enable-multi-repl@ these are--- dotted module names (e.g. @"Foo.Bar"@); in plain @ghci@ sessions they can--- also be file paths. A leading @*@ marks the active interactive target and--- is stripped. Blank lines are skipped.-parseShowTargets :: [Text] -> [Text]-parseShowTargets = mapMaybe parseLine-  where-    parseLine raw =-        let cleaned = T.strip (T.dropWhile (== '*') (T.strip (stripAnsi raw)))-        in  if T.null cleaned then Nothing else Just cleaned----- ------------------------------------------------------------------------------ Pure utilities (unchanged)--- ------------------------------------------------------------------------------- | Make an absolute path relative to the given base directory, prefixed with @"./"@.--- Paths already relative, or absolute paths outside @base@, are returned unchanged.-toRelative :: FilePath -> FilePath -> FilePath-toRelative base path-    | not (isAbsolute path) = path-    | otherwise = case splitDirectories (makeRelative base path) of-        (".." : _) -> path-        rel -> "." </> List.foldr1 (</>) rel----- | Make a relative path absolute by prepending the given base directory.--- Paths already absolute are returned unchanged.-toAbsolute :: FilePath -> FilePath -> FilePath-toAbsolute base path-    | isAbsolute path = path-    | otherwise = base </> path----- | Candidate dotted module names for a file path.------ We can't convert dotted target names to paths without cabal's--- source-dirs, so callers check the other direction: any uppercase-segment--- suffix of the path (with @/@ → @.@, extension dropped) is a candidate.--- E.g. @./tricorder/src/Tricorder/Version.hs@ yields candidates--- @"Tricorder.Version"@ and @"Version"@.-pathSuffixesAsModuleName :: FilePath -> [Text]-pathSuffixesAsModuleName fp =-    let segments = filter (not . null) (splitDirectories (dropExtension (normalise fp)))-        upperSegments = dropWhile (not . startsUpper) segments-        suffixes = takeWhile (not . null) (iterate (drop 1) upperSegments)-    in  [T.intercalate "." (map toText s) | s <- suffixes]-  where-    startsUpper (c : _) = c >= 'A' && c <= 'Z'-    startsUpper _ = False----- | Strip ANSI escape sequences of the form @ESC [ \<params\> \<letter\>@.-stripAnsi :: Text -> Text-stripAnsi t = case T.uncons t of-    Nothing -> t-    Just ('\ESC', rest) -> case T.uncons rest of-        Just ('[', rest') ->-            let afterParams = T.dropWhile (not . isAlpha) rest'-            in  stripAnsi (T.drop 1 afterParams)-        _ -> T.cons '\ESC' (stripAnsi rest)-    Just (c, rest) -> T.cons c (stripAnsi rest)----- | Assemble a 'LoadResult' from a project root, parsed reload items, the--- @:show modules@ output, and the @:show targets@ output.-collectResultCustom :: FilePath -> [GhciLoad] -> [(Text, FilePath)] -> [Text] -> LoadResult-collectResultCustom projectRoot loads modules targets =-    let rel = toRelative projectRoot-        abs' = toAbsolute projectRoot-        compiledFiles = case [l.sourceFile | GLoading l <- loads] of-            [] -> Set.fromList (map (rel . snd) modules)-            fs -> Set.fromList (map rel fs)-        mkEntry (mn, fp) =-            ( normalise (abs' fp)-            , LoadedModule {relPath = rel fp, moduleName = mn}-            )-    in  LoadResult-            { moduleCount = length modules-            , compiledFiles-            , loadedModules = Map.fromList (map mkEntry modules)-            , targetNames = targets-            , diagnostics = toDiagnostics rel loads-            }----- | Assemble a 'LoadResult' from the raw reload output plus the @:show--- modules@ / @:show targets@ output.------ This is 'collectResultCustom' wrapped with a safety net: if GHCi's reload--- ended in a @Failed,@ summary but no error diagnostic was captured (e.g. a--- location-less failure we don't otherwise attribute to a file), a synthetic--- error diagnostic is appended so the build can never be reported as clean--- while GHCi considers it failed.-collectResult :: FilePath -> [Text] -> [(Text, FilePath)] -> [Text] -> LoadResult-collectResult projectRoot reloadLines modules targets =-    let loads = parseReload reloadLines-        base = collectResultCustom projectRoot loads modules targets-        hasError = any (\d -> d.severity == SError) base.diagnostics-    in  if reloadFailed loads && not hasError-            then-                base {diagnostics = base.diagnostics ++ [unattributedFailure]}-            else-                base----- | Synthetic diagnostic for a failed load with no located error. Without a--- source span it cannot point anywhere, but it stops the build reading as--- clean and tells the user where to look.-unattributedFailure :: Diagnostic-unattributedFailure =-    Diagnostic-        { severity = SError-        , file = "<no location info>"-        , line = 0-        , col = 0-        , endLine = 0-        , endCol = 0-        , title = "GHCi reported a failed load with no located error"-        , text =-            "GHCi reported a failed load with no located error.\nRun `tricorder log` to see the full GHCi output.\n"-        }----- | Whether GHCi's load ended in failure, decided from the 'GSummary' items--- 'parseReload' produces — the single place that classifies GHCi's terminal--- @Ok, …@ / @Failed, …@ summary line.------ GHCi emits the real summary last, after all compilation output. Output--- produced /during/ the load (a Template Haskell splice, top-level IO run while--- interpreting) can contain an earlier line that looks like a summary, so only--- the /last/ 'GSummary' reflects the true outcome.-reloadFailed :: [GhciLoad] -> Bool-reloadFailed loads =-    case [outcome | GSummary outcome <- loads] of-        [] -> False-        outcomes -> List.last outcomes == LoadFailed----- | Whether a diagnostic file is a GHCi location-less pseudo-file — a fully--- @\<…\>@-bracketed marker such as @\<no location info\>@ or @\<interactive\>@--- rather than a real source path. These carry no source span but can still--- represent genuine build-level failures, so callers treat them specially--- (kept rather than dropped, cleared every cycle rather than retained).------ We require both the opening @\<@ and a closing @\>@ so a real (if exotic)--- path that merely starts with @\<@, e.g. @\<generated\>/Foo.hs@, is not--- mistaken for a marker.-isLocationLess :: FilePath -> Bool-isLocationLess f = "<" `List.isPrefixOf` f && ">" `List.isSuffixOf` f----- | Path↔module-name map for the next cycle: this round's @:show modules@--- plus carryover from @prev@ for targets that failed mid-session and so--- dropped out. Never-compiled targets are absent here (no path↔name--- mapping); the dispatcher recognises those via 'KnownTargetNames'.-resolveKnownTargets-    :: Map FilePath LoadedModule-    -- ^ Previous known-targets map (carryover source).-    -> LoadResult-    -> Map FilePath LoadedModule-resolveKnownTargets prev lr =-    let primary = lr.loadedModules-        primaryNames = Set.fromList [lm.moduleName | lm <- Map.elems primary]-        prevByName = Map.fromList [(lm.moduleName, (path, lm)) | (path, lm) <- Map.toList prev]-        carryover =-            Map.fromList-                [ (path, lm)-                | name <- lr.targetNames-                , not (Set.member name primaryNames)-                , Just (path, lm) <- [Map.lookup name prevByName]-                ]-    in  Map.union primary carryover---toDiagnostics :: (FilePath -> FilePath) -> [GhciLoad] -> [Diagnostic]-toDiagnostics rel loads = mapMaybe toMsg loads-  where-    -- Location-less messages (e.g. @<no location info>@, @<interactive>@) carry-    -- no source span. We keep the *errors* — a @<no location info>@ error is a-    -- genuine load failure (e.g. a home-unit GHC plugin that can't be loaded in-    -- @--enable-multi-repl@) and must not be silently dropped — but discard-    -- location-less warnings, which are just noise without a file to attach to.-    toMsg (GMessage m) | isLocationLess m.file, m.severity /= GError = Nothing-    toMsg (GMessage m) =-        Just-            Diagnostic-                { severity = case m.severity of-                    GWarning -> SWarning-                    GError -> SError-                , file = rel m.file-                , line = m.startPos.line-                , col = m.startPos.col-                , endLine = m.endPos.line-                , endCol = m.endPos.col-                , title = extractTitle (map toString m.messageLines)-                , text = unlines (map toText m.messageLines)-                }-    toMsg _ = Nothing----- | Extract a short human-readable title from GHCi message lines.------ The header line (@"file:line:col: severity: rest"@) is the first element.--- The human-readable text is either:------   * Inline, after @"error:"@ \/ @"warning:"@ in the header (old GHC style), or---   * On subsequent indented lines (new GHC style, when header ends with a---     diagnostic code such as @[GHC-83865]@ or @[-Wmissing-deriving-strategies]@).------ Source-display lines (@"39 | ..."@, @"   | ^^^^"@) are skipped when--- scanning body lines for content.-extractTitle :: [String] -> Text-extractTitle [] = ""-extractTitle (header : body) =-    fromMaybe (firstBodyLine body) (inlineFromHeader (toString (stripAnsi (toText header))))-  where-    inlineFromHeader :: String -> Maybe Text-    inlineFromHeader h =-        let lower = map toLower h-        in  case headerAfter "error:" lower h <|> headerAfter "warning:" lower h of-                Nothing -> Nothing-                Just rest ->-                    let content = stripDiagCodes (dropWhile isSpace rest)-                    in  if null content then Nothing else Just (toText content)--    headerAfter :: String -> String -> String -> Maybe String-    headerAfter needle haystack original =-        fmap (\i -> drop (i + length needle) original)-            $ List.findIndex (needle `List.isPrefixOf`) (List.tails haystack)--    stripDiagCodes :: String -> String-    stripDiagCodes s = case dropWhile isSpace s of-        '[' : rest ->-            let after = dropWhile isSpace (drop 1 (dropWhile (/= ']') rest))-            in  stripDiagCodes after-        other -> other--    firstBodyLine :: [String] -> Text-    firstBodyLine xs =-        case [ t-             | x <- xs-             , let t = dropWhile isSpace (toString (stripAnsi (toText x)))-             , not (null t)-             , not (isSourceLine t)-             ] of-            (t : _) -> toText t-            [] -> ""--    isSourceLine :: String -> Bool-    isSourceLine s = case dropWhile (\c -> isDigit c || c == ' ') s of-        ('|' : _) -> True-        _ -> not (null s) && all (\c -> c `elem` ("^~_ " :: String)) s

@@ -1,590 +0,0 @@-module Tricorder.Daemon.GhciSession.GhciProcess-    ( Config (..)-    , GhciProcess (..)-    , GhciProcessError (..)-    , UnexpectedExit (..)-    , SessionState (..)-    , InterruptDecision (..)-    , decideInterrupt-    , waitForBannerOrFail-    , withGhciProcess-    , execGhci-    , drainUntil-    , interruptGhci-    , terminateGhciProcess-    , collectGhciResult-    , reloadGhci-    , addGhci-    , unaddGhci-    )-where--import Atelier.Effects.Conc (Conc)-import Atelier.Effects.File (BufferMode (..), File, Handle)-import Atelier.Effects.Log (Log)-import Atelier.Effects.Process-    ( Process-    , RunningProcess-    , createPipe-    , getStderr-    , getStdin-    , getStdout-    , setStderr-    , setStdin-    , setStdout-    , setWorkingDir-    , shell-    )-import Atelier.Effects.Timeout (Timeout, timeout)-import Control.Concurrent.STM (TVar, modifyTVar', readTVar, retry, writeTVar)-import Data.Default (Default (..))-import Data.Sequence ((|>))-import Data.Time.Units (Second)-import Effectful.Concurrent (Concurrent)-import Effectful.Concurrent.STM (atomically, newTVarIO)-import Effectful.Exception (finally, throwIO, trySync)--import Atelier.Effects.Conc qualified as Conc-import Atelier.Effects.File qualified as File-import Atelier.Effects.Log qualified as Log-import Atelier.Effects.Process qualified as Process-import Data.Text qualified as T--import Tricorder.Daemon.GhciSession.GhciParser-    ( GhciLoading (..)-    , LoadResult (..)-    , collectResult-    , parseProgressLine-    , parseShowModules-    , parseShowTargets-    , stripAnsi-    , unattributedFailure-    )-import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))----- | Configuration for GHCi process management.-data Config = Config-    { startupTimeout :: Second-    -- ^ How long to wait for the GHCi version banner on startup.-    , shutdownTimeout :: Second-    -- ^ How long to wait for the process to exit gracefully before force-killing.-    , extraSetupCommands :: [Text]-    -- ^ Additional GHCi commands to send after the fixed setup block.-    -- Use this to inject session-wide options such as @:set -XOverloadedStrings@.-    }---instance Default Config where-    def =-        Config-            { startupTimeout = 60-            , shutdownTimeout = 5-            , extraSetupCommands = []-            }---data SessionState = Idle Int | Busy Int-    deriving stock (Eq, Show)----- | The outcome of consulting the 'SessionState' when an interrupt arrives.------ 'NoOpIdle' means the GHCi session is at the prompt — sending SIGINT and a--- sync marker would dirty the buffers and desync the next 'execGhci'.--- 'SendInterruptFor n' means a command was in flight (state 'Busy n') and--- the caller should SIGINT the process group and re-write @markerFor n@ (that--- command's own marker) to unblock the in-progress 'drainUntil'.-data InterruptDecision-    = NoOpIdle-    | SendInterruptFor Int-    deriving stock (Eq, Show)----- | Pure state machine for 'interruptGhci'. Returns the new 'SessionState'--- to install along with the 'InterruptDecision' the caller should act on.-decideInterrupt :: SessionState -> (SessionState, InterruptDecision)-decideInterrupt s@(Idle _) = (s, NoOpIdle)-decideInterrupt (Busy n) = (Idle (n + 1), SendInterruptFor n)----- | A handle to a running GHCi subprocess.-data GhciProcess = GhciProcess-    { stdin :: Handle-    , stdout :: Handle-    , stderr :: Handle-    , handle :: RunningProcess Handle Handle Handle-    , stateVar :: TVar SessionState-    }----- | Errors that can occur during GHCi process management.-data GhciProcessError-    = StartupTimeout-    | UnexpectedExit UnexpectedExit-    | -- | The build command exited (or printed nothing parseable) before GHCi-      -- produced its version banner. The 'Text' is the captured stderr+stdout-      -- output so callers can surface a useful error (e.g. cabal's dependency-      -- resolution failure).-      StartupFailed Text-    deriving stock (Eq, Show)---data UnexpectedExit = MkUnexpectedExit-    { marker :: Text-    , errorMessage :: Text-    }-    deriving stock (Eq, Show)---instance Exception GhciProcessError----- | Set up the GHCi protocol on an already-started process and return its--- handle together with the output captured during startup.------ The spawn and group teardown are owned by 'withGhciProcess'.-setupGhciProcess-    :: ( Conc :> es-       , Concurrent :> es-       , File :> es-       , Log :> es-       , Timeout :> es-       )-    => Config-    -> RunningProcess Handle Handle Handle-    -> (GhciLoading -> Eff es ())-    -- ^ Called as each @[N of M] Compiling …@ line is streamed during the-    -- initial-build drain, so the UI can update the progress bar live-    -- instead of replaying everything once compilation finishes.-    -> (GhciProcess -> Eff es ())-    -- ^ @onReady@. Called once the 'GhciProcess' is constructed but before the-    -- banner wait and initial-build drain — so callers can register the process-    -- for interruption while the slow @cabal repl@ startup (dependency build-    -- and recompilation) is still in progress.-    -> Eff es (GhciProcess, [Text])-setupGhciProcess config p onProgress onReady = do-    let inp = getStdin p-        out = getStdout p-        err = getStderr p-    File.hSetBuffering inp LineBuffering-    File.hSetBuffering out LineBuffering-    File.hSetBuffering err LineBuffering--    -- Register the process for interruption before the (possibly slow) banner-    -- wait, so an interrupt during @cabal repl@ startup can terminate it.-    stateVar <- newTVarIO (Idle 0)-    let ghciProcess =-            GhciProcess-                { stdin = inp-                , stdout = out-                , stderr = err-                , handle = p-                , stateVar = stateVar-                }-    onReady ghciProcess--    -- Send a blank line to kick GHCi into producing output-    File.hPutTextLn inp ""-    File.hFlush inp--    -- Wait for the version banner. We concurrently capture stderr so that if-    -- the build command exits before printing a banner (e.g. cabal's-    -- dependency resolution fails) we can surface its error output.-    waitForBannerOrFail config.startupTimeout out err--    -- Send fixed setup commands (protocol requirements)-    File.hPutTextLn inp ":set prompt \"\""-    File.hPutTextLn inp ":set prompt-cont \"\""-    -- Send any caller-supplied extra setup commands-    for_ config.extraSetupCommands \c ->-        File.hPutTextLn inp c-    File.hFlush inp--    -- Sync: drain until marker 1 seen, then set counter to 2.-    -- Capture lines from both streams — the stderr output contains the initial-    -- compilation progress and any startup diagnostics. The line hook fires-    -- 'onProgress' for each "[N of M] Compiling …" line as it arrives, so the-    -- UI can update the progress bar live during the initial build.-    let marker1 = markerFor 1-        hook = progressLineHook onProgress-    sendSyncCommand inp marker1-    initialLines <- Conc.scoped do-        stdoutThread <- Conc.fork $ drainUntil out marker1 hook-        stderrThread <- Conc.fork $ drainUntil err marker1 hook-        stdoutLines <- Conc.await stdoutThread-        stderrLines <- Conc.await stderrThread-        pure (stdoutLines ++ stderrLines)-    atomically $ writeTVar stateVar (Idle 2)--    pure (ghciProcess, initialLines)----- | Run a GHCi @cabal repl@ session for the duration of @action@.------ The session runs in its own process group, so the whole group is torn down on--- exit; 'quitGhci' first asks GHCi to @:quit@ for a graceful shutdown. The--- action receives the process handle and the output captured during startup.--- See 'setupGhciProcess' for the @onProgress@ and @onReady@ callbacks.-withGhciProcess-    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es, Process :> es, Timeout :> es)-    => Config-    -> RenderedCommand stage-    -> FilePath-    -> (GhciLoading -> Eff es ())-    -> (GhciProcess -> Eff es ())-    -> (GhciProcess -> [Text] -> Eff es a)-    -> Eff es a-withGhciProcess config cmd dir onProgress onReady action =-    Process.withProcessGroup processConfig \p -> do-        (ghciProcess, initialLines) <- setupGhciProcess config p onProgress onReady-        action ghciProcess initialLines `finally` quitGhci config ghciProcess-  where-    processConfig =-        setStdin createPipe-            $ setStdout createPipe-            $ setStderr createPipe-            $ setWorkingDir dir-            $ shell-            $ toString cmd.getRenderedCommand----- | Execute a command in GHCi and return the combined stdout+stderr output--- lines. The @onProgress@ callback fires for each @[N of M] Compiling …@ line--- as it arrives, so reload/add/unadd progress is streamed live to the UI.--- Pass @\\_ -> pure ()@ for commands that do not trigger compilation.-execGhci-    :: ( Conc :> es-       , Concurrent :> es-       , File :> es-       , Log :> es-       )-    => GhciProcess -> Text -> (GhciLoading -> Eff es ()) -> Eff es [Text]-execGhci ghciProcess command onProgress = do-    n <- atomically do-        readTVar ghciProcess.stateVar >>= \case-            Idle n -> writeTVar ghciProcess.stateVar (Busy n) $> n-            Busy _ -> retry-    doExec n `finally` atomically (writeTVar ghciProcess.stateVar (Idle (n + 1)))-  where-    doExec n = do-        let marker = markerFor n-            hook = progressLineHook onProgress-        File.hPutTextLn ghciProcess.stdin command-        File.hFlush ghciProcess.stdin-        sendSyncCommand ghciProcess.stdin marker-        -- Scoped so that an exception from one drain (e.g. 'UnexpectedExit'-        -- when the underlying process is terminated mid-command) is-        -- contained here, re-raised by 'await', and caught by the caller's-        -- 'trySync'. Without 'scoped', Ki propagates the exception to the-        -- \*ambient* scope — typically the builder's listener scope — which-        -- tears down the whole builder loop instead of just failing this-        -- one command.-        (stdoutLines, stderrLines) <- Conc.scoped do-            stdoutThread <- Conc.fork $ drainUntil ghciProcess.stdout marker hook-            stderrThread <- Conc.fork $ drainUntil ghciProcess.stderr marker hook-            (,) <$> Conc.await stdoutThread <*> Conc.await stderrThread-        pure (stdoutLines ++ stderrLines)----- | Interrupt the currently running GHCi command (if any).------ If a command is in progress (state 'Busy n'), sends SIGINT to the GHCi--- process group and re-writes /that command's own/ sync marker (@markerFor n@)--- so the in-progress 'drainUntil', which is waiting for exactly that marker,--- unblocks. The next command runs as @n + 1@ and waits for @markerFor (n + 1)@,--- so any duplicate @markerFor n@ left in the buffers is skipped by 'drainUntil'--- rather than mistaken for the next command's marker.------ When GHCi is 'Idle' this is a true no-op: sending SIGINT and a sync marker to--- an idle GHCi leaves leftover marker output in the buffers.-interruptGhci :: (Concurrent :> es, File :> es, Process :> es) => GhciProcess -> Eff es ()-interruptGhci ghciProcess = do-    decision <- atomically do-        s <- readTVar ghciProcess.stateVar-        let (s', d) = decideInterrupt s-        writeTVar ghciProcess.stateVar s'-        pure d-    case decision of-        NoOpIdle -> pure ()-        SendInterruptFor n -> do-            Process.interruptProcessGroup ghciProcess.handle-            sendSyncCommand ghciProcess.stdin (markerFor n)----- | Forcefully terminate a GHCi process and its whole group.------ Stronger than 'interruptGhci': intended for one-shot processes (such as the--- per-suite @cabal repl test:…@ used by the test runner) where SIGINT is--- insufficient — test frameworks like @hspec@ and @tasty@ install SIGINT--- handlers that finalise the current run rather than aborting it. Safe to call--- from another thread while the session is running.-terminateGhciProcess :: (Process :> es) => GhciProcess -> Eff es ()-terminateGhciProcess ghciProcess =-    Process.terminateProcessGroup ghciProcess.handle----- | Ask GHCi to @:quit@ and wait briefly for it to exit cleanly, letting it--- shut down gracefully before the enclosing 'withGhciProcess' tears down the--- group. Never throws.-quitGhci :: (File :> es, Process :> es, Timeout :> es) => Config -> GhciProcess -> Eff es ()-quitGhci config ghciProcess = do-    void $ trySync $ do-        File.hPutTextLn ghciProcess.stdin ":quit"-        File.hFlush ghciProcess.stdin-    void $ timeout config.shutdownTimeout (Process.waitExitCode ghciProcess.handle)----- ------------------------------------------------------------------------------ Internal helpers---- | Build the finish marker for counter value @n@.-markerFor :: Int -> Text-markerFor n = markerPrefix <> show n <> "~#"----- | The prefix shared by all finish markers.-markerPrefix :: Text-markerPrefix = "#~TRI-FINISH-"----- | Write the synchronisation Haskell statements to GHCi stdin.------ After each user command, these cause GHCi to emit the finish marker on both--- stdout and stderr, so 'drainUntil' knows when to stop.------ The marker is emitted as two standalone, fully-qualified statements — one per--- stream — using only 'System.IO.hPutStrLn'. This is deliberate: a--- SIGINT-interrupted ':reload' empties GHCi's interactive scope, dropping the--- implicit @import Prelude@, so bare names like @putStrLn@ (and even the @>>@--- operator) fall out of scope. A marker built from those would /error/ instead--- of printing — its marker would never appear and 'drainUntil' would block--- forever waiting for it (the "stuck Building…" stall). Fully-qualified--- 'System.IO.hPutStrLn' resolves via GHCi's implicit qualified imports even--- with an emptied scope, so the marker survives an interrupt.-sendSyncCommand :: (File :> es) => Handle -> Text -> Eff es ()-sendSyncCommand h marker = do-    -- Use show to produce a valid Haskell string literal for the marker text.-    let markerLit = toText (show @String (toString marker)) -- e.g. "\"#~TRI-FINISH-3~#\""-    File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stdout " <> markerLit)-    File.hPutTextLn h ("System.IO.hPutStrLn System.IO.stderr " <> markerLit)-    File.hFlush h----- | Read lines from a handle until /this command's/ finish marker is seen (or--- EOF).------ Stops only on a line containing the exact @marker@ it was given. A line--- carrying a /different/ finish marker — a stale leftover from a prior command--- that was interrupted mid-flight — is skipped rather than matched, so it can--- never make a later drain return prematurely (the "0 modules"/hang desync).--- Each ordinary line is passed to @onLine@ as it arrives, so callers can stream--- progress without waiting for the full drain to complete. Returns accumulated--- non-marker lines in order. Throws 'UnexpectedExit' on EOF before the marker.-drainUntil :: (File :> es, 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 ex -> do-                let accumulatedLines = T.intercalate "\n" $ toList acc-                    errorMessage =-                        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-                                        ]-                Log.err errorMessage-                throwIO-                    $ UnexpectedExit-                    $ MkUnexpectedExit {marker, errorMessage}-            Right line-                | 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 $ acc |> line----- | Convert a 'GhciLoading' progress callback into a per-line hook suitable--- for 'drainUntil'. Non-progress lines are ignored.-progressLineHook :: (GhciLoading -> Eff es ()) -> Text -> Eff es ()-progressLineHook onProgress line = traverse_ onProgress (parseProgressLine line)----- | Wait up to the given number of seconds for a GHCi version banner on--- stdout, capturing stderr (and any non-banner stdout lines) in case the--- build command fails before printing a banner.------ Throws 'StartupFailed' with the captured output if stdout EOFs (the build--- command exited) or 'StartupTimeout' if the banner never arrives.-waitForBannerOrFail-    :: ( Conc :> es-       , Concurrent :> es-       , File :> es-       , Timeout :> es-       )-    => Second -> Handle -> Handle -> Eff es ()-waitForBannerOrFail delay out err = do-    capturedVar <- newTVarIO ([] :: [Text])-    let captureLine line = atomically $ modifyTVar' capturedVar (line :)-        drainStderr = drainUntilEof err captureLine-        watchStdout = waitForBannerStdout out captureLine--    Conc.scoped do-        stderrThread <- Conc.fork drainStderr-        result <- timeout delay $ trySync watchStdout-        case result of-            Just (Right ()) -> pure ()-            Just (Left ex) -> do-                -- stdout EOF before the banner: the build command exited. Wait-                -- for the stderr drain to reach EOF too (bounded, in case the-                -- pipe lingers) so we surface its *complete* output — e.g.-                -- cabal's dependency-resolution error — rather than whatever-                -- the drain happened to have read so far.-                _ <- timeout (1 :: Second) (Conc.await stderrThread)-                captured <- atomically $ readTVar capturedVar-                throwIO $ StartupFailed $ fromMaybe (startupExitedMessage ex) (renderCapturedLines captured)-            Nothing -> do-                captured <- atomically $ readTVar capturedVar-                throwIO $ maybe StartupTimeout StartupFailed (renderCapturedLines captured)---waitForBannerStdout :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()-waitForBannerStdout h captureLine = go-  where-    isVersionLine :: Text -> Bool-    isVersionLine line =-        let stripped = stripAnsi line-        in  "GHCi, version " `T.isInfixOf` stripped-                || "GHCJSi, version " `T.isInfixOf` stripped-                || "Clashi, version " `T.isInfixOf` stripped--    go = do-        result <- trySync $ File.hGetLine h-        case result of-            Left ex -> throwIO ex-            Right line ->-                if isVersionLine line-                    then-                        pure ()-                    else do-                        captureLine line-                        go---drainUntilEof :: (File :> es) => Handle -> (Text -> Eff es ()) -> Eff es ()-drainUntilEof h onLine = go-  where-    go = do-        result <- trySync $ File.hGetLine h-        case result of-            Left _ -> pure ()-            Right line -> onLine line >> go----- | Render the captured (reverse-order) output lines into an error message,--- stripping ANSI escapes and dropping blank lines. Returns 'Nothing' when--- nothing useful remains, so callers can fall back to a generic message.-renderCapturedLines :: [Text] -> Maybe Text-renderCapturedLines capturedRev =-    let cleaned = filter (not . T.null . T.strip) (map stripAnsi (reverse capturedRev))-    in  if null cleaned then Nothing else Just (T.intercalate "\n" cleaned)----- | Fallback message when the build command exited before the banner without--- printing anything we could capture.-startupExitedMessage :: SomeException -> Text-startupExitedMessage ex =-    "Build command exited before GHCi started: " <> toText (displayException ex)----- | Parse already-drained GHCi output lines into a 'LoadResult', fetching the--- current module list via @:show modules@.------ Progress is emitted live by 'drainUntil' as lines arrive, so no replay--- callback is needed here — this function only assembles the final result.-collectGhciResult-    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)-    => GhciProcess-    -> [Text]-    -> FilePath-    -> Eff es LoadResult-collectGhciResult process lines' projectRoot = do-    let noProgress = \_ -> pure ()-    moduleLines <- execGhci process ":show modules" noProgress-    targetLines <- execGhci process ":show targets" noProgress-    let result =-            collectResult-                projectRoot-                lines'-                (parseShowModules moduleLines)-                (parseShowTargets targetLines)-    -- A failed load with no located error produces only the synthetic-    -- 'unattributedFailure'. The parsed diagnostics tell the user nothing in-    -- that case, so log the raw GHCi output — it's the only way to see what-    -- actually went wrong, and the synthetic diagnostic points here.-    when (any (== unattributedFailure) result.diagnostics)-        $ Log.info-        $ "GHCi reported a failed load with no located error. Full GHCi output:\n"-            <> T.unlines lines'-    pure result----- | Execute @:reload@ and return the assembled 'LoadResult'. Progress events--- fire live via @onProgress@ as each @[N of M] Compiling …@ line is read.-reloadGhci-    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)-    => GhciProcess-    -> FilePath-    -> (GhciLoading -> Eff es ())-    -> Eff es LoadResult-reloadGhci process projectRoot onProgress = do-    reloadLines <- execGhci process ":reload" onProgress-    collectGhciResult process reloadLines projectRoot----- | Execute @:add@ for the given file and return the assembled 'LoadResult'.--- Progress events fire live via @onProgress@ as compilation proceeds.-addGhci-    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)-    => GhciProcess-    -> FilePath -- the file to :add-    -> FilePath -- projectRoot-    -> (GhciLoading -> Eff es ())-    -> Eff es LoadResult-addGhci process filePath projectRoot onProgress = do-    addLines <- execGhci process (":add " <> T.pack filePath) onProgress-    collectGhciResult process addLines projectRoot----- | Execute @:unadd@ for the given module and return the assembled--- 'LoadResult'. Progress events fire live via @onProgress@ as compilation--- proceeds.-unaddGhci-    :: (Conc :> es, Concurrent :> es, File :> es, Log :> es)-    => GhciProcess-    -> Text -- the module name to :unadd-    -> FilePath -- projectRoot-    -> (GhciLoading -> Eff es ())-    -> Eff es LoadResult-unaddGhci process moduleName projectRoot onProgress = do-    unaddLines <- execGhci process (":unadd " <> moduleName) onProgress-    collectGhciResult process unaddLines projectRoot

@@ -0,0 +1,34 @@+module Tricorder.Daemon.HookDispatch (main) where++import Atelier.Effects.FileWatcher (FileEvent (..))+import Atelier.Effects.Process (Process)+import Atelier.Effects.PubSub.Sub (Sub)+import Effectful.Reader.Static (Reader)++import Atelier.Effects.PubSub.Sub qualified as Sub+import System.FilePath qualified as Path++import Tricorder.Daemon.Watch (WatchedFile (..))+import Tricorder.Runtime (ProjectRoot)+import Tricorder.Session (Session (..))+import Tricorder.Session.HaskellHooks (HaskellHooks (..))+import Tricorder.Session.Hooks (Hooks (..))++import Tricorder.Session.Hook qualified as Hook+++main :: (Process :> es, Reader ProjectRoot :> es, Sub WatchedFile :> es) => Session -> Eff es Void+main session =+    Sub.listen_ \case+        (WatchedFile path event)+            | Path.takeExtension path == "hs"+            , Just hooks <- session.hooks.haskell ->+                runHsHook hooks event+            | otherwise -> pure ()+++runHsHook :: (Process :> es, Reader ProjectRoot :> es) => HaskellHooks -> FileEvent -> Eff es ()+runHsHook hooks = \case+    Added -> whenJust hooks.fileAdded Hook.run+    Modified -> whenJust hooks.fileModified Hook.run+    Removed -> whenJust hooks.fileRemoved Hook.run

@@ -6,20 +6,22 @@ import Atelier.Effects.Debounce (Debounce) import Atelier.Effects.FileWatcher (FileWatcher) import Atelier.Effects.Log (Log)-import Atelier.Effects.Publishing (runPubSub)-import Atelier.Effects.Publishing.Pub (Pub)+import Atelier.Effects.PubSub.Pub (Pub) import Effectful.Reader.Static (Reader)  import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.FileWatcher qualified as FileWatcher import Atelier.Effects.Log qualified as Log-import Atelier.Effects.Publishing.Pub qualified as Pub-import Atelier.Effects.Publishing.Sub qualified as Sub+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub+import Atelier.Effects.PubSub.Sub qualified as Sub import Data.List qualified as List import Effectful.Reader.Static qualified as Reader  import Tricorder.Daemon.Hpack.Effect (Hpack) import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session (Session (..))+import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..))  import Tricorder.Daemon.Hpack.Effect qualified as Hpack @@ -34,13 +36,14 @@        , Log :> es        , Reader ProjectRoot :> es        )-    => Eff es ()-main = runPubSub @RePack $ Conc.scoped do-    hpackInPath <- Hpack.hpackIsInPath-    when hpackInPath do-        projectRoot <- Reader.ask-        Conc.fork_ $ Sub.listen_ \(RePack path) -> runHpack path-        vacuous $ watchPackageYaml projectRoot+    => Session -> Eff es ()+main session = PubSub.run @RePack $ Conc.scoped do+    when (coerce session.generateWithHpack) do+        hpackInPath <- Hpack.hpackIsInPath+        when hpackInPath do+            projectRoot <- Reader.ask+            Conc.fork_ $ Sub.listen_ \(RePack path) -> runHpack path+            vacuous $ watchPackageYaml projectRoot   runHpack :: (Hpack :> es, Log :> es) => FilePath -> Eff es ()

@@ -1,6 +1,5 @@ module Tricorder.Daemon.Main (main) where -import Atelier.Effects.Cache (runCacheTtl) import Atelier.Effects.Chan (runChan) import Atelier.Effects.Clock (runClock) import Atelier.Effects.Conc (runConc)@@ -12,52 +11,53 @@ import Atelier.Effects.FileSystem (runFileSystemIO) import Atelier.Effects.FileWatcher (runFileWatcherIO) 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)-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 import Atelier.Effects.FileSystem.Glob qualified as Glob import Atelier.Effects.Input qualified as Input import Atelier.Effects.Log qualified as Log+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub+import Atelier.Effects.PubSub.Sub qualified as Sub+import Effectful.Reader.Static qualified as Reader+import Effectful.State.Static.Shared qualified as State  import Tricorder.Build (BuildId (..), BuildPhase)-import Tricorder.Config (inputLoadedConfig)-import Tricorder.Daemon.GhciSession (runGhciSession)+import Tricorder.Build.Changes (CabalChangeDetected, SourceChangeDetected)+import Tricorder.Config (asInput)+import Tricorder.Daemon.Watch (WatchedFile) import Tricorder.Logging (runLogging) import Tricorder.Runtime (runLogPath, runProjectRoot, runRuntimeDir, runSocketPath)-import Tricorder.Session (inputSession) import Tricorder.Session.CabalFile (inputCabalFiles)-import Tricorder.Session.IdleTimeout (IdleTimeout)-import Tricorder.Session.Repl (Repl)-import Tricorder.Socket.UnixSocket (runUnixSocketIO) import Tricorder.SourceLookup.GhcPkg (runGhcPkgIO)-import Tricorder.SourceLookup.PackageId (PackageId) +import Tricorder.Build qualified as BuildPhase+import Tricorder.Config.LoadedConfig qualified as LoadedConfig import Tricorder.Daemon.Core qualified as Core import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner+import Tricorder.Daemon.Ghci.Session qualified as Ghci.Session+import Tricorder.Daemon.HookDispatch qualified as HookDispatch+import Tricorder.Daemon.Hpack qualified as Hpack 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.Repl qualified as Repl+import Tricorder.Daemon.Watch qualified as Watch+import Tricorder.Session qualified as Session import Tricorder.Session.StackProject qualified as StackProject+import Tricorder.Session.State qualified as Session.State+import Tricorder.Session.State.Invalid qualified as Session.State.Result.Invalid+import Tricorder.Session.State.Result qualified as Session.State.Result import Tricorder.Socket.Server qualified as Server-import Tricorder.SourceLookup qualified as SourceLookup-import Tricorder.SourceLookup.Hackage qualified as Hackage-import Tricorder.SourceLookup.PackageStore qualified as PackageStore+import Tricorder.Socket.UnixSocket qualified as UnixSocket import Tricorder.Version qualified as Version import Tricorder.Waiters qualified as Waiters  --- | Run the daemon for the given project root.--- Blocks forever; all work happens inside the component system. main :: IO () main =     runEff@@ -77,36 +77,51 @@         . runSocketPath         . runLogPath         . runEnv-        . inputLoadedConfig+        . LoadedConfig.asInput         . runLogging         . runChan         . StackProject.inputWithCache         . inputCabalFiles-        . inputSession-        . runReader @CacheConfig.Config def-        . runCacheTtl @ModuleName @PackageId-        . runCacheTtl @(PackageId, SourceQuery) @SourceLookup.ModuleSourceResult         . runProcessIO         . runGhcPkgIO-        . runUnixSocketIO-        . runGhciSession-        . evalState (BuildId 1)+        . UnixSocket.runIO+        . Ghci.Session.run+        . State.evalState (BuildId 1)         . Input.fromState @BuildId-        . evalState Repl.Unknown-        . Input.fromState @Repl-        . evalState @IdleTimeout def-        . Input.fromState @IdleTimeout-        . IdleTimer.quitOnTimeout-        . runPubSub @BuildPhase         . Hpack.run-        . Hackage.run-        . PackageStore.run         . EvalCommentRunner.run         . TestRunner.run         . Waiters.run+        . PubSub.run @BuildPhase+        . PubSub.run @CabalChangeDetected+        . PubSub.run @SourceChangeDetected+        . PubSub.run @WatchedFile+        . Tricorder.Config.asInput+        . Session.State.eval+        . Input.withEff+            ( maybe def Session.idleTimeout+                . Session.State.Result.toMaybe+                <$> Session.State.currentSession+            )+        . IdleTimer.quitOnTimeout         $ do             installTerminationHandler             Log.info $ "Starting tricorder " <> Version.gitHash-            Conc.fork_ Core.main+            Conc.fork_ $ Sub.listen_ Watch.publishChange             Conc.fork_ Server.main-            Conc.awaitAll++            vacuous $ Session.State.withSession \sessionResult -> do+                case sessionResult of+                    Session.State.Result.Invalid invalid -> do+                        let msg =+                                "Unable to start builder due to invalid session: "+                                    <> Session.State.Result.Invalid.reason invalid+                        Log.err msg+                        Pub.publish $ BuildPhase.Failed msg+                    Session.State.Result.Ok session -> do+                        void $ Conc.fork $ Hpack.main session+                        Conc.fork_ $ HookDispatch.main session++                        root <- Reader.ask+                        Conc.fork_ $ Watch.files root session+                        vacuous $ Core.main session

@@ -53,13 +53,7 @@ import Data.List qualified as List import Data.Text qualified as T -import Tricorder.Daemon.GhciSession.GhciParser (GhciLoading (..), parseProgressLine)-import Tricorder.Daemon.GhciSession.GhciProcess-    ( GhciProcessError (..)-    , UnexpectedExit (..)-    , execGhci-    , withGhciProcess-    )+import Tricorder.Daemon.Ghci.Loading (Loading (..)) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..)) import Tricorder.Session.Stage (Stage (..))@@ -70,6 +64,9 @@ import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput)  import Tricorder.Build.Test qualified as Test+import Tricorder.Daemon.Ghci.Loading qualified as Ghci (Loading)+import Tricorder.Daemon.Ghci.Process qualified as Ghci.Process+import Tricorder.Daemon.Ghci.Result qualified as Ghci.Result   data TestRunner :: Effect where@@ -117,7 +114,7 @@        , Reader ProjectRoot :> es        , Timeout :> es        )-    => (GhciLoading -> Eff es ())+    => (Ghci.Loading -> Eff es ())     -> TestTimeout     -> RenderedCommand 'Test     -> Eff es Test.Suite@@ -137,7 +134,7 @@             unlessM (File.hIsEOF h) do                 line <- File.hGetLine h                 atomically $ modifyTVar' outputVar (|> line)-                traverse_ onProgress (parseProgressLine line)+                traverse_ onProgress (Ghci.Result.parseProgressLine line)                 drain h          runToCompletion p = do@@ -192,14 +189,14 @@        , Reader ProjectRoot :> es        , Timeout :> es        )-    => (GhciLoading -> Eff es ())+    => (Ghci.Loading -> Eff es ())     -> TestTimeout     -> RenderedCommand 'Test     -> Eff es Test.Suite runTestSuiteWithGHCi onProgress testTimeout cmd = do     ProjectRoot projectRoot <- ask     result <- trySync-        $ withGhciProcess+        $ Ghci.Process.with             def             cmd             projectRoot@@ -207,22 +204,22 @@             noReady             \ghci _ ->                 case testTimeout of-                    TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress+                    TestTimeout secs | secs <= 0 -> Right <$> Ghci.Process.exec ghci ":main" noProgress                     TestTimeout secs ->                         let duration = fromIntegral secs :: Second                         in  maybeToRight secs-                                <$> timeout duration (execGhci ghci ":main" noProgress)+                                <$> timeout duration (Ghci.Process.exec ghci ":main" noProgress)     case result of         Left ex -> case fromException ex of-            Just (e :: GhciProcessError) -> case e of-                UnexpectedExit (MkUnexpectedExit marker msg) ->+            Just (e :: Ghci.Process.Error) -> case e of+                Ghci.Process.UnexpectedExit (Ghci.Process.MkUnexpectedExit marker msg) ->                     pure                         $ Test.SuiteErrored                         $ Test.SuiteError                             { message = "Test suite failed while waiting for marker (" <> marker <> "):\n" <> msg                             }-                StartupTimeout -> pure $ Test.SuiteErrored $ Test.SuiteError "Test suite timed out before it could finish"-                StartupFailed msg ->+                Ghci.Process.StartupTimeout -> pure $ Test.SuiteErrored $ Test.SuiteError "Test suite timed out before it could finish"+                Ghci.Process.StartupFailed msg ->                     pure                         $ Test.SuiteErrored                         $ Test.SuiteError@@ -279,7 +276,7 @@             Right r : rest -> put rest >> pure r  -loadingToProgress :: GhciLoading -> Test.Suite+loadingToProgress :: Ghci.Loading -> Test.Suite loadingToProgress loading =     Test.SuiteRunning         $ Just

@@ -17,13 +17,13 @@     , dirWhere     , excluding     )-import Atelier.Effects.Publishing.Pub (Pub)+import Atelier.Effects.PubSub.Pub (Pub) import System.FilePath (takeExtension, takeFileName) import Text.Regex.TDFA (ExecOption (..), blankCompOpt, blankExecOpt, match) import Text.Regex.TDFA.TDFA (patternToRegex)  import Atelier.Effects.FileWatcher qualified as FileWatcher-import Atelier.Effects.Publishing.Pub qualified as Pub+import Atelier.Effects.PubSub.Pub qualified as Pub  import Tricorder.Build.Changes     ( CabalChangeDetected (..)

@@ -1,19 +1,26 @@ module Tricorder.Logging (runLogging) where -import Atelier.Config (LoadedConfig, extractNestedConfig) import Atelier.Effects.Env (Env) import Atelier.Effects.File (BufferMode (..), File)-import Atelier.Effects.Input (Input, input)-import Atelier.Effects.Log (Log, Severity (..), runLogToHandle)+import Atelier.Effects.Input (Input)+import Atelier.Effects.Log+    ( Log+    , Severity (..)+    , runLogToHandle+    ) import Effectful (IOE) import Effectful.Reader.Static (Reader, asks)  import Atelier.Effects.File qualified as File+import Atelier.Effects.Input qualified as Input import Atelier.Effects.Log qualified as Log +import Tricorder.Config.LoadedConfig (LoadedConfig) import Tricorder.Runtime (LogPath (..)) +import Tricorder.Config.LoadedConfig qualified as LoadedConfig + runLogging     :: ( Env :> es        , File :> es@@ -26,16 +33,25 @@     path <- asks @LogPath (.getLogPath)     File.withFile path AppendMode \h -> do         File.hSetBuffering h LineBuffering-        sev <- getMinimumSeverity-        runLogToHandle h sev act+        (maybeErr, sev) <- getMinimumSeverity+        runLogToHandle h sev do+            whenJust maybeErr \err -> Log.err err+            act  -getMinimumSeverity :: (Env :> es, Input LoadedConfig :> es) => Eff es Severity+getMinimumSeverity+    :: ( Env :> es+       , Input LoadedConfig :> es+       )+    => Eff es (Maybe Text, Severity) getMinimumSeverity = do     mSev <- Log.minimumSeverityFromEnv     case mSev of-        Just sev -> pure sev-        Nothing -> do-            loadedConfig <- input-            let config = extractNestedConfig @"session.logging" @Log.Config loadedConfig-            pure config.minimumSeverity+        Just sev -> pure (Nothing, sev)+        Nothing -> LoadedConfig.asNestedInput @"session.logging" @Log.Config do+            logConfigRes <- Input.input+            case logConfigRes of+                Left err -> do+                    pure (Just $ "failed to parse log config: " <> err, Log.INFO)+                Right cfg ->+                    pure (Nothing, cfg.minimumSeverity)

@@ -1,23 +1,21 @@ module Tricorder.Session     ( Session (..)-    , loadSession-    , inputSession-    , show+    , load+    , display     ) where -import Atelier.Config (LoadedConfig, extractConfig) import Atelier.Effects.FileSystem (FileSystem)-import Atelier.Effects.Input (Input, input, runInputEff)+import Atelier.Effects.Input (Input) import Atelier.Effects.Log (Log) import Data.Default (Default (..))-import Effectful.Reader.Static (Reader, ask)+import Effectful.Reader.Static (Reader) import Text.Regex.TDFA.Pattern (showPattern)-import Prelude hiding (show) +import Atelier.Effects.Input qualified as Input import Atelier.Effects.Log qualified as Log import Data.Text qualified as T-import Prelude qualified as P+import Effectful.Reader.Static qualified as Reader  import Tricorder.Build.ByteSize (ByteSize) import Tricorder.Runtime (ProjectRoot (..))@@ -40,7 +38,7 @@ import Tricorder.Session.Target (definesCustomPrelude) import Tricorder.Session.TestTarget (getTestTarget) import Tricorder.Session.TestTimeout (TestTimeout (..))-import Tricorder.Session.Util (indent, showList)+import Tricorder.Session.Util (displayList, indent) import Tricorder.Session.WatchDirs (WatchDirs (..)) import Tricorder.Session.WatchExclusionPatterns     ( WatchExclusionPatterns (..)@@ -48,6 +46,8 @@     )  import Tricorder.Build.ByteSize qualified as ByteSize+import Tricorder.Config qualified as Tricorder+import Tricorder.Session.Hooks qualified as Hooks import Tricorder.Session.Stage qualified as Stage import Tricorder.Session.Stage.Build.Session qualified as BuildSession import Tricorder.Session.Stage.Eval.Command qualified as EvalCommand@@ -89,24 +89,30 @@             }  -loadSession+load     :: ( FileSystem :> es-       , Input LoadedConfig :> es+       , Input (Either Text Tricorder.Config) :> es        , Input [CabalFile] :> es        , Log :> es        , Reader ProjectRoot :> es        )-    => Eff es Session-loadSession = do-    projectRoot <- ask @ProjectRoot-    loadedCfg <- input-    Log.debug "Got config file"-    projectFiles <- input-    Log.debug "Got project files"+    => Eff es (Either Text Session)+load = do+    cfg <- Input.input -    let cfgFile = extractConfig @"session" @Config loadedCfg-        hooks = fromMaybe def cfgFile.hooks+    case cfg of+        Left err -> do+            Log.err $ "Failed to parse config: " <> err+            pure $ Left $ "Failed to parse Tricorder config: " <> err+        Right (Tricorder.Config cfgFile) -> Right <$> mkSession (fromMaybe def cfgFile) ++mkSession+    :: (FileSystem :> es, Input [CabalFile] :> es, Log :> es, Reader ProjectRoot :> es)+    => Config -> Eff es Session+mkSession cfgFile = do+    projectRoot <- Reader.ask @ProjectRoot+    projectFiles <- Input.input     warnDeprecatedConfig cfgFile     Log.debug "Warned about deprecated config stuff" @@ -171,22 +177,11 @@             , replBuildDir = ReplBuildDir cfgFile.replBuildDir             , testTimeout = TestTimeout cfgFile.testTimeout             , generateWithHpack = GenerateWithHpack cfgFile.generateWithHpack-            , hooks+            , hooks = fromMaybe def cfgFile.hooks             , idleTimeout = IdleTimeout $ fromIntegral cfgFile.idleTimeoutSeconds             }  -inputSession-    :: ( FileSystem :> es-       , Input LoadedConfig :> es-       , Input [CabalFile] :> es-       , Log :> es-       , Reader ProjectRoot :> es-       )-    => Eff (Input Session : es) a -> Eff es a-inputSession = runInputEff loadSession-- -- | Warn once per session load for each deprecated top-level config key -- still in use, regardless of whether its replacement also takes -- precedence.@@ -236,27 +231,29 @@         _ -> pure ()  -show :: Session -> Text-show session =+display :: Session -> Text+display session =     T.intercalate         "\n"         [ "Loaded session"         , "Build configuration:"-        , indent $ BuildSession.show session.buildSession+        , indent $ BuildSession.display session.buildSession         , "Test configuration:"-        , indent $ TestSession.show session.testSession+        , indent $ TestSession.display session.testSession         , "Eval comments configuration:"-        , indent $ EvalSession.show session.evalSession+        , indent $ EvalSession.display session.evalSession         , "Watch dirs:"-        , indent $ showList toText session.watchDirs.getWatchDirs+        , indent $ displayList toText session.watchDirs.getWatchDirs         , "Watch exclusion patterns:"         , indent-            $ showList+            $ displayList                 (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: " <> P.show session.testTimeout.getTestTimeout <> " seconds"-        , "Test memory limit: " <> P.show session.testMemoryLimit-        , "Generate with hpack: " <> P.show session.generateWithHpack.getGenerateWithHpack+          "Test timeout: " <> show session.testTimeout.getTestTimeout <> " seconds"+        , "Test memory limit: " <> show session.testMemoryLimit+        , "Generate with hpack: " <> show session.generateWithHpack.getGenerateWithHpack+        , "Hooks:"+        , indent $ Hooks.display session.hooks         ]

@@ -11,24 +11,26 @@ import Atelier.Effects.Env (Env) import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory, readFileBs) import Atelier.Effects.FileSystem.Glob (Glob, globDir1)-import Atelier.Effects.Input (Input, input, runInputEff)+import Atelier.Effects.Input (Input) import Atelier.Effects.Log (Log) import Data.Traversable (for) import Distribution.Fields (Field (..), FieldLine (..), Name (..), readFields) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import Effectful.Exception (catch, throwIO)-import Effectful.Reader.Static (Reader, ask)+import Effectful.Reader.Static (Reader) import System.FilePath (normalise, takeExtension, (</>)) import System.FilePath.Glob (compile) import System.IO.Error (userError)  import Atelier.Effects.Env qualified as Env import Atelier.Effects.FileSystem qualified as FileSystem+import Atelier.Effects.Input qualified as Input import Atelier.Effects.Log qualified as Log import Data.ByteString.Char8 qualified as BC import Data.List qualified as List import Data.Text qualified as T+import Effectful.Reader.Static qualified as Reader  import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.StackProject (StackProject (..))@@ -50,7 +52,7 @@        , Reader ProjectRoot :> es        )     => Eff (Input [CabalFile] : es) a -> Eff es a-inputCabalFiles = runInputEff $ Log.withNamespace "CabalFile" do+inputCabalFiles = Input.withEff $ Log.withNamespace "CabalFile" do     packageRes <- discoverPackages     case packageRes of         Left err -> throwIO $ userError $ toString err@@ -108,7 +110,7 @@        )     => Eff es (Either Text [FilePath]) discoverPackages = do-    ProjectRoot projectRoot <- ask+    ProjectRoot projectRoot <- Reader.ask     hasStackYaml <- FileSystem.doesFileExist $ projectRoot </> "stack.yaml"     if hasStackYaml         then discoverStackPackages@@ -125,7 +127,7 @@        )     => Eff es (Either Text [FilePath]) discoverCabalPackages = do-    ProjectRoot projectRoot <- ask+    ProjectRoot projectRoot <- Reader.ask     homeCabalFiles <- maybe [] (one . (</> ".cabal/config")) <$> Env.lookupEnv "HOME"     let projectFilePaths = projectCabalFiles projectRoot <> homeCabalFiles     projectFiles <- filterM doesFileExist projectFilePaths@@ -163,8 +165,8 @@     :: (Input StackProject :> es, Reader ProjectRoot :> es)     => Eff es (Either Text [FilePath]) discoverStackPackages = do-    ProjectRoot projectRoot <- ask-    project <- input+    ProjectRoot projectRoot <- Reader.ask+    project <- Input.input     pure $ Right $ normalise . (projectRoot </>) <$> project.packages  

@@ -1,6 +1,6 @@ module Tricorder.Session.CommandConfig (CommandConfig (..)) where -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Data.Aeson (FromJSON, ToJSON) import Data.Default (Default (..)) 

@@ -5,21 +5,19 @@     , hasPlaceholder     , targetsPlaceholder     , targetPlaceholder-    , show+    , display     ) where  import Data.Default (Default (..))-import Prelude hiding (show)  import Data.List qualified as List import Data.Text qualified as T-import Prelude qualified as P  import Tricorder.Session.Repl (Repl (..)) import Tricorder.Session.Stage (Stage (..)) import Tricorder.Session.Target (Target (..))-import Tricorder.Session.Util (indent, showList)+import Tricorder.Session.Util (displayList, indent)  import Tricorder.Session.Target qualified as Target @@ -111,13 +109,13 @@ hasPlaceholder placeholderName template = ("{" <> placeholderName <> "}") `T.isInfixOf` template  -show :: CommandTemplate stage -> Text-show tmpl =+display :: CommandTemplate stage -> Text+display tmpl =     T.intercalate         "\n"         [ "Template: " <> tmpl.template-        , "Repl: " <> P.show tmpl.repl-        , "Template placeholder: " <> P.show tmpl.placeholder+        , "Repl: " <> show tmpl.repl+        , "Template placeholder: " <> show tmpl.placeholder         , "Arguments:"-        , indent $ showList id tmpl.arguments+        , indent $ displayList id tmpl.arguments         ]

@@ -1,8 +1,8 @@ module Tricorder.Session.Config (Config (..)) where -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Atelier.Types.WithDefaults (WithDefaults (..))-import Data.Aeson (FromJSON (..))+import Data.Aeson (FromJSON (..), ToJSON) import Data.Default (Default (..))  import Tricorder.Session.CommandConfig (CommandConfig)@@ -35,6 +35,7 @@     -- TODO: Remove at or after version 0.8.0.0.     }     deriving stock (Eq, Generic, Show)+    deriving (ToJSON) via QuietSnake Config     deriving (FromJSON) via WithDefaults (QuietSnake Config)  

@@ -0,0 +1,43 @@+module Tricorder.Session.HaskellHooks+    ( HaskellHooks (..)+    , display+    )+where++import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))++import Data.Text qualified as T++import Tricorder.Session.Hook (Hook)++import Tricorder.Session.Hook qualified as Hook+++data HaskellHooks = HaskellHooks+    { fileAdded :: Maybe Hook+    , fileModified :: Maybe Hook+    , fileRemoved :: Maybe Hook+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via QuietSnake HaskellHooks+++instance Default HaskellHooks where+    def =+        HaskellHooks+            { fileAdded = Nothing+            , fileModified = Nothing+            , fileRemoved = Nothing+            }+++display :: HaskellHooks -> Text+display hooks =+    T.intercalate+        "\n"+        [ "file_added: " <> maybe "<unset>" Hook.getHook hooks.fileAdded+        , "file_modified: " <> maybe "<unset>" Hook.getHook hooks.fileModified+        , "file_removed: " <> maybe "<unset>" Hook.getHook hooks.fileRemoved+        ]

@@ -0,0 +1,31 @@+module Tricorder.Session.Hook+    ( Hook (..)+    , run+    )+where++import Atelier.Effects.Process (Process)+import Data.Aeson (FromJSON, ToJSON)+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 (..))+++newtype Hook = Hook {getHook :: Text}+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Text+++run :: (Process :> es, Reader ProjectRoot :> es) => Hook -> Eff es ()+run (Hook hook) = do+    ProjectRoot root <- Reader.ask+    void+        $ trySync+        $ Process.runProcess+        $ Process.setWorkingDir root+        $ Process.shell+        $ toString hook

@@ -1,29 +1,36 @@+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-}+ module Tricorder.Session.Hooks     ( Hooks (..)-    , Hook (..)-    , runHook+    , HookPair (..)+    , display     ) where -import Atelier.Effects.Process (Process)-import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..))+import Atelier.Types.WithDefaults (WithDefaults (..)) import Data.Aeson (FromJSON, ToJSON) import Data.Default (Default (..))-import Effectful.Exception (trySync)-import Effectful.Reader.Static (Reader) -import Atelier.Effects.Process qualified as Process-import Effectful.Reader.Static qualified as Reader+import Data.Text qualified as T -import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.HaskellHooks (HaskellHooks)+import Tricorder.Session.Hook (Hook)+import Tricorder.Session.Util (indent) +import Tricorder.Session.HaskellHooks qualified as HaskellHooks+import Tricorder.Session.Hook qualified as Hook + data Hooks = Hooks-    { start :: Maybe Hook-    , reload :: Maybe Hook+    { start :: Maybe HookPair+    , reload :: Maybe HookPair+    , haskell :: Maybe HaskellHooks     }     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via QuietSnake Hooks+    deriving (ToJSON) via QuietSnake Hooks+    deriving (FromJSON) via WithDefaults (QuietSnake Hooks)   instance Default Hooks where@@ -31,31 +38,43 @@         Hooks             { start = def             , reload = def+            , haskell = def             }  -data Hook = Hook-    { before :: Maybe Text-    , after :: Maybe Text+display :: Hooks -> Text+display hooks =+    T.intercalate+        "\n"+        [ "start:" <> displayMaybeHook displayHookPair hooks.start+        , "reload:" <> displayMaybeHook displayHookPair hooks.reload+        , "haskell:" <> displayMaybeHook HaskellHooks.display hooks.haskell+        ]+  where+    displayMaybeHook f = maybe " <unset>" (("\n" <>) . indent . f)+++data HookPair = HookPair+    { before :: Maybe Hook+    , after :: Maybe Hook     }     deriving stock (Eq, Generic, Show)-    deriving (FromJSON, ToJSON) via QuietSnake Hook+    deriving (ToJSON) via QuietSnake HookPair+    deriving (FromJSON) via WithDefaults (QuietSnake HookPair)  -instance Default Hook where+instance Default HookPair where     def =-        Hook+        HookPair             { 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+displayHookPair :: HookPair -> Text+displayHookPair pair =+    T.intercalate+        "\n"+        [ "before: " <> maybe "<unset>" Hook.getHook pair.before+        , "after: " <> maybe "<unset>" Hook.getHook pair.after+        ]

@@ -5,7 +5,7 @@ where  import Atelier.Effects.FileSystem (FileSystem)-import Atelier.Effects.Input (Input, runInputEff)+import Atelier.Effects.Input (Input) import Data.Aeson (FromJSON, ToJSON) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)@@ -24,6 +24,7 @@ import System.IO.Error (userError)  import Atelier.Effects.FileSystem qualified as FileSystem+import Atelier.Effects.Input qualified as Input import Data.Yaml qualified as Yaml  import Tricorder.Runtime (ProjectRoot (..))@@ -45,7 +46,7 @@ inputWithCache act = do     cache :: TVar StackProject <- newTVarIO $ StackProject []     lastModified :: TVar UTCTime <- newTVarIO $ posixSecondsToUTCTime 0-    flip runInputEff act do+    flip Input.withEff act do         ProjectRoot projectRoot <- ask         let stackYamlPath = projectRoot </> "stack.yaml"         exists <- FileSystem.doesFileExist stackYamlPath

@@ -1,14 +1,13 @@ module Tricorder.Session.Stage.Build.Session     ( BuildSession (..)     , resolve-    , show+    , display     ) where  import Atelier.Effects.FileSystem (FileSystem) import Data.Default (Default (..)) import Effectful.Reader.Static (Reader)-import Prelude hiding (show)  import Data.Text qualified as T import Effectful.Reader.Static qualified as Reader@@ -20,7 +19,7 @@ import Tricorder.Session.Config (Config (..)) import Tricorder.Session.Repl (Repl) import Tricorder.Session.Target (Target)-import Tricorder.Session.Util (indent, showList)+import Tricorder.Session.Util (displayList, indent)  import Tricorder.Session.CommandTemplate qualified as CommandTemplate import Tricorder.Session.Stage qualified as Stage@@ -55,12 +54,12 @@     effectiveTargets = Target.resolve projectFiles rawBuildTargets  -show :: BuildSession -> Text-show cfg =+display :: BuildSession -> Text+display cfg =     T.intercalate         "\n"         [ "Command template:"-        , indent $ CommandTemplate.show cfg.commandTemplate+        , indent $ CommandTemplate.display cfg.commandTemplate         , "Targets:"-        , indent $ showList Target.render cfg.targets+        , indent $ displayList Target.render cfg.targets         ]

@@ -1,11 +1,9 @@ module Tricorder.Session.Stage.Eval.Session     ( EvalSession-    , show+    , display     ) where -import Prelude hiding (show)- import Data.Text qualified as T  import Tricorder.Session.CommandTemplate (CommandTemplate)@@ -18,10 +16,10 @@ type EvalSession = CommandTemplate 'Stage.Eval  -show :: EvalSession -> Text-show cfg =+display :: EvalSession -> Text+display cfg =     T.intercalate         "\n"         [ "Command template:"-        , indent $ CommandTemplate.show cfg+        , indent $ CommandTemplate.display cfg         ]

@@ -5,7 +5,7 @@     ) where -import Atelier.Types.QuietSnake (QuietSnake (..))+import Atelier.Types.JSON.QuietSnake (QuietSnake (..)) import Data.Aeson (FromJSON (..), ToJSON, Value (..)) import Data.Aeson.Types (ToJSON (..)) import Data.Default (Default (..))

@@ -3,15 +3,13 @@     , ResolvedTestOptions (..)     , resolve     , defaultTestTemplate-    , show+    , display     ) where  import Data.Default (Default (..))-import Prelude hiding (show)  import Data.Text qualified as T-import Prelude qualified as P  import Tricorder.Session.CommandConfig (CommandConfig (..)) import Tricorder.Session.CommandTemplate (CommandTemplate (..), targetPlaceholder)@@ -20,7 +18,7 @@ import Tricorder.Session.Stage.Test.Config (Options (..), OutputMode (..), TestConfig (..)) import Tricorder.Session.Target (Target) import Tricorder.Session.TestTarget (TestTarget (..))-import Tricorder.Session.Util (indent, showList)+import Tricorder.Session.Util (displayList, indent)  import Tricorder.Session.CommandTemplate qualified as CommandTemplate import Tricorder.Session.Stage qualified as Stage@@ -92,14 +90,14 @@     Unknown -> "cabal repl {target}"  -show :: TestSession -> Text-show cfg =+display :: TestSession -> Text+display cfg =     T.intercalate         "\n"         [ "Command template:"-        , indent $ CommandTemplate.show cfg.commandTemplate+        , indent $ CommandTemplate.display cfg.commandTemplate         , "Test targets:"-        , indent $ showList TestTarget.render cfg.targets+        , indent $ displayList TestTarget.render cfg.targets         , "Options:"         , indent $ showTestOptions cfg.options         ]@@ -107,5 +105,5 @@     showTestOptions opts =         T.intercalate             "\n"-            [ "Output mode: " <> P.show opts.outputMode+            [ "Output mode: " <> show opts.outputMode             ]

@@ -0,0 +1,173 @@+module Tricorder.Session.State+    ( State+    , currentSession+    , withSession+    , asInput+    , eval+    )+where++import Atelier.Effects.Chan (Chan)+import Atelier.Effects.Clock (Clock)+import Atelier.Effects.Conc (Conc)+import Atelier.Effects.Debounce (Debounce)+import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.FileWatcher (FileWatcher)+import Atelier.Effects.Input (Input)+import Atelier.Effects.Log (Log)+import Atelier.Effects.PubSub.Pub (Pub)+import Atelier.Effects.PubSub.Sub (Sub)+import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..), inject)+import Effectful.Concurrent.STM (Concurrent, TVar)+import Effectful.Dispatch.Dynamic (interpretWith, localUnlift)+import Effectful.Reader.Static (Reader)+import Effectful.TH (makeEffect)+import System.FilePath ((</>))++import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.FileSystem qualified as FileSystem+import Atelier.Effects.FileWatcher qualified as FileWatcher+import Atelier.Effects.Input qualified as Input+import Atelier.Effects.Log qualified as Log+import Atelier.Effects.PubSub qualified as PubSub+import Atelier.Effects.PubSub.Pub qualified as Pub+import Atelier.Effects.PubSub.Sub qualified as Sub+import Data.List qualified as List+import Data.Text qualified as T+import Effectful.Concurrent.STM qualified as STM+import Effectful.Reader.Static qualified as Reader++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.CabalFile (CabalFile)+import Tricorder.Session.State.Invalid (Invalid (..))+import Tricorder.Session.State.Result (Result)+import Tricorder.Session.Util (indent)+import Tricorder.Waiters (Waiters)++import Tricorder.Config qualified as Tricorder+import Tricorder.Config.LoadedConfig qualified as LoadedConfig+import Tricorder.Session qualified as Session+import Tricorder.Session.State.Result qualified as Result+import Tricorder.Waiters qualified as Waiters+++data State :: Effect where+    -- | Returns the current session record.+    CurrentSession :: State m Result+    -- | Cancels and reruns the passed action with a new session every time the+    -- session record changes.+    WithSession :: (Result -> m a) -> State m Void+++makeEffect ''State+++asInput :: (State :> es) => Eff (Input Result : es) a -> Eff es a+asInput = Input.withEff currentSession+++eval+    :: ( Chan :> es+       , Clock :> es+       , Conc :> es+       , Concurrent :> es+       , Debounce FilePath :> es+       , FileSystem :> es+       , FileWatcher :> es+       , Input (Either Text Tricorder.Config) :> es+       , Input [CabalFile] :> es+       , Log :> es+       , Reader ProjectRoot :> es+       , Waiters :> es+       )+    => Eff (State : es) a -> Eff es a+eval action = PubSub.run @Reloaded $ PubSub.run @Reload do+    session0 <- Result.fromEither <$> Session.load++    logSession session0+    var <- STM.newTVarIO session0+    Conc.fork_ watchConfigFile+    conditionallyWatchStackYaml+    Conc.fork_ $ Sub.listen_ @Reload $ const $ updateSession var+    interpretWith (inject action) \env -> \case+        CurrentSession -> STM.readTVarIO var+        WithSession act -> do+            localUnlift env (ConcUnlift Persistent Unlimited) \unlift ->+                Conc.restartableFork waitForReloadedSession do+                    unlift . act =<< STM.readTVarIO var+++waitForReloadedSession :: (Sub Reloaded :> es, Waiters :> es) => Eff es Reloaded+waitForReloadedSession = Waiters.wait $ Sub.listenOnce_ @Reloaded+++updateSession+    :: ( Concurrent :> es+       , FileSystem :> es+       , Input (Either Text Tricorder.Config) :> es+       , Input [CabalFile] :> es+       , Log :> es+       , Pub Reloaded :> es+       , Reader ProjectRoot :> es+       )+    => TVar Result -> Eff es ()+updateSession var = do+    oldSession <- STM.readTVarIO var+    newSession <- Result.fromEither <$> Session.load+    when (oldSession /= newSession) do+        STM.atomically $ STM.writeTVar var newSession+        logSession newSession+        Pub.publish Reloaded+++data Reload = Reload+++data Reloaded = Reloaded+++watchConfigFile+    :: ( Debounce FilePath :> es+       , FileWatcher :> es+       , Pub Reload :> es+       , Reader ProjectRoot :> es+       )+    => Eff es Void+watchConfigFile = do+    root <- Reader.ask+    FileWatcher.watchFilePathsDebounced+        [FileWatcher.dirWhere root.getProjectRoot (LoadedConfig.configFileName `List.isSuffixOf`)]+        \_ _ -> Pub.publish Reload+++conditionallyWatchStackYaml+    :: ( Conc :> es+       , Debounce FilePath :> es+       , FileSystem :> es+       , FileWatcher :> es+       , Pub Reload :> es+       , Reader ProjectRoot :> es+       )+    => Eff es ()+conditionallyWatchStackYaml = do+    root <- Reader.ask+    exists <- FileSystem.doesFileExist $ root.getProjectRoot </> "stack.yaml"+    when exists do+        Conc.fork_ $ FileWatcher.watchFilePathsDebounced+            [FileWatcher.dirWhere root.getProjectRoot ("stack.yaml" `List.isSuffixOf`)]+            \_ _ -> Pub.publish Reload+++logSession :: (Log :> es) => Result -> Eff es ()+logSession = \case+    Result.Invalid invalid ->+        Log.err+            $ T.intercalate+                "\n"+                [ "Invalid session:"+                , indent $ "reason: " <> invalid.reason+                , indent $ "fallback:"+                , indent $ indent $ Session.display invalid.fallback+                ]+    Result.Ok session ->+        Log.info . (<> "\n") $ Session.display session