tricorder 0.4.1.1 → 0.5.0.0

raw patch · 74 files changed

+4540/−3101 lines, 74 filesdep +tasty-hunitdep −hspecdep −tasty-hspecdep ~basedep ~brickPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

Dependencies removed: hspec, tasty-hspec

Dependency ranges changed: base, brick

API changes (from Hackage documentation)

Files

• CHANGELOG.md +41/−0
• src/Tricorder/Build.hs +1/−3
• src/Tricorder/CLI/App.hs +12/−18
• src/Tricorder/CLI/Arguments.hs +5/−14
• src/Tricorder/CLI/Arguments/Daemon.hs +14/−0
• src/Tricorder/CLI/Arguments/OutputFormat.hs +12/−0
• src/Tricorder/CLI/Main.hs +7/−2
• src/Tricorder/CLI/Operations.hs +33/−10
• src/Tricorder/CLI/UI/Keys.hs +4/−15
• src/Tricorder/CLI/UI/Route.hs +0/−2
• src/Tricorder/CLI/UI/View.hs +8/−82
• src/Tricorder/Daemon/Builder.hs +3/−2
• src/Tricorder/Daemon/Core.hs +117/−121
• src/Tricorder/Daemon/DaemonInfo.hs +2/−1
• src/Tricorder/Daemon/EvalCommentRunner.hs +11/−14
• src/Tricorder/Daemon/GhciSession.hs +4/−3
• src/Tricorder/Daemon/GhciSession/GhciProcess.hs +36/−32
• src/Tricorder/Daemon/Main.hs +5/−4
• src/Tricorder/Daemon/TestRunner.hs +181/−89
• src/Tricorder/Session.hs +132/−17
• src/Tricorder/Session/CabalFile.hs +89/−21
• src/Tricorder/Session/Command.hs +0/−141
• src/Tricorder/Session/Command/RenderedCommand.hs +9/−0
• src/Tricorder/Session/CommandConfig.hs +37/−0
• src/Tricorder/Session/CommandTemplate.hs +123/−0
• src/Tricorder/Session/Config.hs +22/−6
• src/Tricorder/Session/Repl.hs +45/−0
• src/Tricorder/Session/StackProject.hs +70/−0
• src/Tricorder/Session/Stage.hs +4/−0
• src/Tricorder/Session/Stage/Build/Command.hs +78/−0
• src/Tricorder/Session/Stage/Build/Session.hs +66/−0
• src/Tricorder/Session/Stage/Eval/Command.hs +34/−0
• src/Tricorder/Session/Stage/Eval/Session.hs +27/−0
• src/Tricorder/Session/Stage/Test/Command.hs +60/−0
• src/Tricorder/Session/Stage/Test/Config.hs +60/−0
• src/Tricorder/Session/Stage/Test/Session.hs +111/−0
• src/Tricorder/Session/Target.hs +27/−25
• src/Tricorder/Session/TestTarget.hs +28/−22
• src/Tricorder/Session/Util.hs +17/−0
• src/Tricorder/Session/WatchDirs.hs +3/−3
• src/Tricorder/Socket/Server.hs +2/−11
• src/Tricorder/SourceLookup.hs +1/−1
• src/Tricorder/SourceLookup/GhcPkg.hs +1/−1
• test/Driver.hs +1/−1
• test/Unit/Tricorder/Build/ByteSizeSpec.hs +52/−64
• test/Unit/Tricorder/Build/EvalCommentSpec.hs +102/−126
• test/Unit/Tricorder/CLI/RenderSpec.hs +26/−20
• test/Unit/Tricorder/Daemon/BuildStateSpec.hs +67/−72
• test/Unit/Tricorder/Daemon/BuilderSpec.hs +65/−70
• test/Unit/Tricorder/Daemon/DispatchSpec.hs +114/−119
• test/Unit/Tricorder/Daemon/GhciSession/GhciParserSpec.hs +329/−322
• test/Unit/Tricorder/Daemon/GhciSession/GhciProcessSpec.hs +114/−101
• test/Unit/Tricorder/Daemon/GhciSessionSpec.hs +44/−36
• test/Unit/Tricorder/Daemon/TestRunnerSpec.hs +110/−90
• test/Unit/Tricorder/Daemon/WatchSpec.hs +64/−59
• test/Unit/Tricorder/Session/CabalFileSpec.hs +138/−69
• test/Unit/Tricorder/Session/CommandSpec.hs +0/−123
• test/Unit/Tricorder/Session/CommandTemplateSpec.hs +58/−0
• test/Unit/Tricorder/Session/ReplSpec.hs +52/−0
• test/Unit/Tricorder/Session/Stage/Build/CommandSpec.hs +193/−0
• test/Unit/Tricorder/Session/Stage/Eval/CommandSpec.hs +62/−0
• test/Unit/Tricorder/Session/Stage/Test/CommandSpec.hs +106/−0
• test/Unit/Tricorder/Session/TargetSpec.hs +221/−191
• test/Unit/Tricorder/Session/TestTargetSpec.hs +31/−29
• test/Unit/Tricorder/Session/WatchDirsSpec.hs +137/−112
• test/Unit/Tricorder/SessionSpec.hs +83/−28
• test/Unit/Tricorder/SocketSpec.hs +36/−28
• test/Unit/Tricorder/SourceLookup/GhcPkgSpec.hs +19/−16
• test/Unit/Tricorder/SourceLookup/SliceSpec.hs +312/−312
• test/Unit/Tricorder/SourceLookup/TarballSpec.hs +62/−64
• test/Unit/Tricorder/SourceLookupSpec.hs +99/−101
• test/Unit/Tricorder/TestOutputSpec.hs +168/−181
• test/Unit/Tricorder/WaitersSpec.hs +108/−100
• tricorder.cabal +25/−7

@@ -7,6 +7,46 @@  ## [Unreleased] +## [0.5.0.0] - 2026-10-02++### Added++- Log test suite commands.+- `session.build`, `session.test`, and `session.eval` config sections, each+  independently configuring the command used to build the project, run test+  suites, and evaluate eval comments. See+  [Configuring Tricorder] for a complete,+  up-to-date description of these options.+- `tricorder daemon info` subcommand showing daemon info. This information was+  moved from `tricorder ui`.+- Tricorder now supports running tests with regular `cabal test` or+  `stack test`. Tricorder will automatically detect whether the tests are ran+  in GHCi or through a regular `cabal/stack test` by inspecting the configured+  `session.test.command_template`. You can force the output mode to use by+  setting `session.test.output_mode`. See [Configuring Tricorder] for more+  information.++### Changed++- Deprecate configuration options `session.command`, `session.targets` and+  `session.test_targets` in favor of `session.build.command_template`,+  `session.build.targets` and `session.test.targets`, respectively.+- Tricorder now uses `brick` `3.0` for its TUI.++### Fixed++- Multi-package Stack projects were being resolved as single-package Stack+  projects. (Thanks @marcosh!)+- When Tricorder detects that the project is a Stack project, it now correctly+  inspects `stack.yaml` for packages instead of assuming packages are listed in+  `cabal.project`.++### Removed++- `tricorder ui` no longer has the "Daemon info" tab. This tab contains+  information that is rarely necessary to have as accessible as in the TUI, so it+  has been moved to a separate `tricorder daemon info` subcommand.+ ## [0.4.1.1] - 2026-09-21  ### Fixed@@ -226,3 +266,4 @@   (fixes ghcid's crash-on-file-removal bug).  [Features of Tricorder - Eval Comments]: ../docs/features-of-tricorder.md#eval-comments+[Configuring Tricorder]: /docs/configuring-tricorder.md

@@ -15,7 +15,6 @@ import GHC.Generics (Generically (..))  import Tricorder.Build.Duration (Duration)-import Tricorder.Daemon.DaemonInfo (DaemonInfo) import Tricorder.Session.TestTarget (TestTarget)  import Tricorder.Build.EvalComment qualified as Eval@@ -23,8 +22,7 @@   data BuildState = BuildState-    { daemonInfo :: DaemonInfo-    , phase :: BuildPhase+    { phase :: BuildPhase     , buildId :: BuildId     }     deriving stock (Eq, Generic, Show)

@@ -8,7 +8,7 @@ import Atelier.Effects.Exit (Exit) import Atelier.Effects.File (File) import Atelier.Effects.FileSystem (FileSystem)-import Atelier.Effects.Input (Input)+import Atelier.Effects.Input (Input, input) import Atelier.Effects.Log (Log) import Atelier.Effects.Posix.Daemons (Daemons) import Atelier.Effects.Process (Process)@@ -21,8 +21,8 @@  import Atelier.Effects.Console qualified as Console import Data.Text qualified as T+import Tricorder.CLI.Command.Daemon qualified as DaemonCommand -import Tricorder.Build (BuildState (..)) import Tricorder.CLI.Arguments (Command (..), LogMode (..)) import Tricorder.CLI.Daemon     ( restartDaemon@@ -31,7 +31,8 @@     , waitForDaemon     ) import Tricorder.CLI.Operations-    ( showEvalComments+    ( showDaemonInfo+    , showEvalComments     , showLog     , showSource     , showStatus@@ -40,10 +41,10 @@ import Tricorder.CLI.UI (viewUi) import Tricorder.CLI.UI.Brick (Brick) import Tricorder.CLI.UI.BrickChan (BrickChan)-import Tricorder.Daemon.DaemonInfo (DaemonInfo (..))+import Tricorder.Daemon.DaemonInfo (DaemonInfo) import Tricorder.Runtime (LogPath (..), PidFile (..), SocketPath (..))-import Tricorder.Session.Command (Repl)-import Tricorder.Socket.Client (isDaemonRunning, queryStatus)+import Tricorder.Session.Repl (Repl)+import Tricorder.Socket.Client (isDaemonRunning) import Tricorder.Socket.UnixSocket (UnixSocket) import Tricorder.SourceLookup (ModuleSourceResult) import Tricorder.SourceLookup.GhcPkg (GhcPkg)@@ -71,6 +72,7 @@        , GhcPkg :> es        , Hackage :> es        , IOE :> es+       , Input DaemonInfo :> es        , Input Repl :> es        , Log :> es        , PackageStore :> es@@ -124,18 +126,7 @@                 else                     showTests opts         Log logMode -> do-            running <- isDaemonRunning-            logFile <--                if running-                    then do-                        SocketPath sp <- ask-                        result <- queryStatus sp-                        LogPath fallback <- ask-                        pure $ case result of-                            Right state -> state.daemonInfo.logFile-                            Left _ -> fallback-                    else-                        asks @LogPath (.getLogPath)+            logFile <- asks @LogPath (.getLogPath)             case logMode of                 ShowLog -> showLog logFile                 ShowLogPath -> Console.putTextLn (toText logFile)@@ -157,3 +148,6 @@                 startDaemon                 void waitForDaemon             showEvalComments opts+        Daemon (DaemonCommand.Info format) -> do+            daemonInfo <- input+            showDaemonInfo format daemonInfo

@@ -1,7 +1,6 @@ module Tricorder.CLI.Arguments     ( Command (..)     , LogMode (..)-    , OutputFormat (..)     , StatusOptions (..)     , TestOptions (..)     , EvalCommentsOptions (..)@@ -41,7 +40,6 @@     , EvalCommentsOptions (..)     , Force (..)     , LogMode (..)-    , OutputFormat (..)     , StatusOptions (..)     , TestOptions (..)     , Verbosity (..)@@ -49,6 +47,8 @@     ) import Tricorder.SourceLookup.SourceQuery (SourceQuery, parseSourceQuery) +import Tricorder.CLI.Arguments.Daemon qualified as Daemon+import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat import Tricorder.Version qualified as Version  @@ -92,6 +92,7 @@             <> command                 "eval-comments"                 (info evalCommentsParser (progDesc "Show eval comments from the latest build"))+            <> command "daemon" (info (Daemon <$> Daemon.parser) (progDesc "Daemon sub-commands"))         )  @@ -113,7 +114,7 @@     Status         <$> ( StatusOptions                 <$> waitParser-                <*> jsonFormatToggleParser+                <*> OutputFormat.parser                 <*> flag                     Concise                     Verbose@@ -171,7 +172,7 @@     EvalComments         <$> ( EvalCommentsOptions                 <$> waitParser-                <*> jsonFormatToggleParser+                <*> OutputFormat.parser             )  @@ -182,16 +183,6 @@         WaitForBuild         ( long "wait"             <> help "Block until the current build cycle completes"-        )---jsonFormatToggleParser :: Parser OutputFormat-jsonFormatToggleParser =-    flag-        TextOutput-        JsonOutput-        ( long "json"-            <> help "Output full build state as JSON"         )  

@@ -0,0 +1,14 @@+module Tricorder.CLI.Arguments.Daemon (parser) where++import Options.Applicative (Parser, command, hsubparser, info, progDesc)+import Tricorder.CLI.Command.Daemon (DaemonCommand (..))++import Tricorder.CLI.Arguments.OutputFormat qualified as OutputFormat+++parser :: Parser DaemonCommand+parser = hsubparser (command "info" (info infoParser (progDesc "Information about the daemon")))+++infoParser :: Parser DaemonCommand+infoParser = Info <$> OutputFormat.parser

@@ -0,0 +1,12 @@+module Tricorder.CLI.Arguments.OutputFormat (parser) where++import Options.Applicative (Parser, flag, help, long)+import Tricorder.CLI.Command.OutputFormat (OutputFormat (..))+++parser :: Parser OutputFormat+parser =+    flag+        TextOutput+        JsonOutput+        $ long "json" <> help "Output full build state as JSON"

@@ -33,12 +33,15 @@ import Tricorder.Runtime (runLogPath, runPidFile, runProjectRoot, runRuntimeDir, runSocketPath) import Tricorder.Session (Session (..), loadSession) import Tricorder.Session.CabalFile (inputCabalFiles)-import Tricorder.Session.Command (Command (..))+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.Daemon.DaemonInfo qualified as DaemonInfo+import Tricorder.Session.StackProject qualified as StackProject import Tricorder.SourceLookup qualified as SourceLookup import Tricorder.SourceLookup.GhcPkg qualified as GhcPkg import Tricorder.SourceLookup.Hackage qualified as Hackage@@ -75,15 +78,17 @@         . runEnv         . inputLoadedConfig         . runLogNoOp+        . StackProject.inputWithCache         . inputCabalFiles         . runInputEff loadSession-        . runInputEff ((.command.repl) <$> input)+        . 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         $ do             installTerminationHandler             App.run

@@ -4,6 +4,7 @@     , showStatus     , showTests     , showEvalComments+    , showDaemonInfo     ) where @@ -15,10 +16,11 @@ import Atelier.Effects.FileSystem (FileSystem, doesFileExist, readFileLbs) import Atelier.Effects.Input (Input) import Atelier.Effects.Log (Log)-import Data.Aeson (encode)+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.OutputFormat (OutputFormat (..)) import Tricorder.SourceLookup.SourceQuery (ModuleName, SourceQuery)  import Atelier.Effects.Console qualified as Console@@ -31,7 +33,6 @@ import Tricorder.Build.Test (Suites (..)) import Tricorder.CLI.Arguments     ( EvalCommentsOptions (..)-    , OutputFormat (..)     , StatusOptions (..)     , TestOptions (..)     , Verbosity (..)@@ -42,9 +43,9 @@     , formatDuration     , renderSourceResults     )+import Tricorder.Daemon.DaemonInfo (DaemonInfo (..)) import Tricorder.Runtime (SocketPath (..))-import Tricorder.Session.Command (Repl)-import Tricorder.Session.TestTarget (renderTestTarget)+import Tricorder.Session.Repl (Repl) import Tricorder.Socket.Client (queryStatus, queryStatusWait) import Tricorder.Socket.UnixSocket (UnixSocket) import Tricorder.SourceLookup (ModuleSourceResult, lookupModuleSource)@@ -58,6 +59,8 @@ import Tricorder.Build.EvalComment qualified as Eval import Tricorder.Build.Test qualified as Test import Tricorder.Build.Test qualified as Tests+import Tricorder.Session.Target qualified as Target+import Tricorder.Session.TestTarget qualified as TestTarget   -- | Print a build-command failure message and exit non-zero.@@ -147,7 +150,7 @@                 mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (T.lines c.output))             _ -> pure ()       where-        t = renderTestTarget tgt+        t = TestTarget.render tgt      buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics     buildSummary tz r =@@ -216,7 +219,7 @@         | Map.null suites = Console.putStrLn "No test results."         | Map.null filteredSuites = do             Console.putStrLn "All passed."-            mapM_ (Console.putTextLn . ("  " <>) . renderTestTarget) $ Map.keys suites+            mapM_ (Console.putTextLn . ("  " <>) . TestTarget.render) $ Map.keys suites         | otherwise = do             mapM_ (uncurry printTestOutput) $ Map.toList filteredSuites             when (any Test.isFailedRun filteredSuites) exitFailure@@ -248,7 +251,7 @@                 else                     mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (lines c.output))       where-        t = renderTestTarget tgt <> "  "+        t = TestTarget.render tgt <> "  "      printFailedCase tc = do         Console.putTextLn $ "  " <> tc.description@@ -293,6 +296,23 @@         JsonOutput -> displayJsonOutput result  +showDaemonInfo :: (Console :> es) => OutputFormat -> DaemonInfo -> Eff es ()+showDaemonInfo format daemonInfo = case format of+    TextOutput -> text+    JsonOutput -> json+  where+    text = do+        Console.putTextLn "Targets:"+        for_ daemonInfo.targets \target ->+            Console.putTextLn $ "- " <> Target.render target+        Console.putTextLn "Watch directories:"+        for_ daemonInfo.watchDirs \dir ->+            Console.putTextLn $ "- " <> toText dir+        Console.putTextLn $ "Socket file path: " <> toText daemonInfo.sockPath+        Console.putTextLn $ "Log file path: " <> toText daemonInfo.logFile+    json = putJson daemonInfo++ displayTextOutput     :: ( Console :> es        , Exit :> es@@ -302,7 +322,7 @@     Left err -> do         Console.putTextLn $ "Error: " <> err         exitFailure-    Right (BuildState _ phase _) -> case phase of+    Right (BuildState phase _) -> case phase of         Build.Starting -> Console.putStrLn "Starting..."         Build.Building _ _ -> Console.putStrLn "Building..."         Build.PostBuilding _ postBuild -> txtEvalComments postBuild@@ -357,7 +377,7 @@     Left err -> do         putJson $ Eval.Failed err         exitFailure-    Right (BuildState _ phase _) -> case phase of+    Right (BuildState phase _) -> case phase of         Build.Starting -> putJson Eval.Starting         Build.Building _ _ -> putJson Eval.Building         Build.Failed msg -> do@@ -372,7 +392,10 @@         Eval.Found comments             | Eval.anyRunningComments comments -> putJson Eval.Evaluating             | otherwise -> putJson $ Eval.Done comments-    putJson = Console.putStrLn . toStrict . encode+++putJson :: (Console :> es, ToJSON a) => a -> Eff es ()+putJson = Console.putStrLn . toStrict . encode   displayPendingBuildStatus

@@ -77,8 +77,7 @@ -- '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-    = ToggleDaemonInfoView-    | ToggleHelp+    = ToggleHelp     | CycleTestView     | ToggleEvalComments     | RestartDaemon@@ -104,8 +103,7 @@ keys :: KeyEvents KeyEvent keys =     keyEvents-        [ ("toggle daemon info", ToggleDaemonInfoView)-        , ("toggle help", ToggleHelp)+        [ ("toggle help", ToggleHelp)         , ("cycle test view", CycleTestView)         , ("toggle eval comments", ToggleEvalComments)         , ("restart daemon", RestartDaemon)@@ -118,8 +116,7 @@  bindings :: [(KeyEvent, [Binding])] bindings =-    [ (ToggleDaemonInfoView, [bind 'g'])-    , (ToggleHelp, [bind 'h'])+    [ (ToggleHelp, [bind 'h'])     , (CycleTestView, [bind 't'])     , (ToggleEvalComments, [bind 'e'])     , (RestartDaemon, [bind 'R'])@@ -181,14 +178,7 @@     either (error . ("Invalid key dispatcher config: " <>) . stringify) id         $ keyDispatcher             cfg-            [ onEvent ToggleDaemonInfoView "Toggle daemon info view" do-                modify \s ->-                    if currentRoute s == Route.DaemonInfo-                        then-                            navigate Route.Main s-                        else-                            navigate Route.DaemonInfo s-            , onEvent ToggleHelp "Toggle help" do+            [ onEvent ToggleHelp "Toggle help" do                 modify \s ->                     if currentRoute s == Route.Help                         then@@ -263,7 +253,6 @@ keybindForRoute :: KeyConfig KeyEvent -> Route -> Maybe Binding keybindForRoute kc = \case     Route.Main -> Nothing-    Route.DaemonInfo -> firstActiveBinding kc ToggleDaemonInfoView     Route.Help -> firstActiveBinding kc ToggleHelp     Route.Tests -> firstActiveBinding kc CycleTestView     Route.Evals -> firstActiveBinding kc ToggleEvalComments

@@ -8,7 +8,6 @@ data Route     = Main     | Help-    | DaemonInfo     | Tests     | Evals     deriving stock (Bounded, Enum, Eq)@@ -18,6 +17,5 @@ name = \case     Main -> "Dashboard"     Help -> "Help"-    DaemonInfo -> "Daemon info"     Tests -> "Tests"     Evals -> "Eval comments"

@@ -26,7 +26,6 @@     , withVScrollBars     ) import Data.Time (UTCTime, defaultTimeLocale, formatTime, utcToLocalTime)-import System.FilePath (isAbsolute)  import Data.Map.Strict qualified as Map import Data.Text qualified as T@@ -45,9 +44,7 @@     , Viewports (..)     , currentRoute     )-import Tricorder.Daemon.DaemonInfo (DaemonInfo (..))-import Tricorder.Session.Target (Target, renderTarget)-import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+import Tricorder.Session.TestTarget (TestTarget) import Tricorder.TestOutput (stripGhciNoise)  import Tricorder.Build qualified as Build@@ -55,7 +52,7 @@ import Tricorder.Build.Test qualified as Test import Tricorder.CLI.UI.Keys qualified as Keys import Tricorder.CLI.UI.Route qualified as Route-import Tricorder.Version qualified as Version+import Tricorder.Session.TestTarget qualified as TestTarget   mkAttrMap :: State -> AttrMap@@ -83,8 +80,6 @@         , case currentRoute ws of             Route.Help ->                 viewHelp kc-            Route.DaemonInfo ->-                viewDaemonInfo ws             Route.Tests ->                 viewTests ws             Route.Main ->@@ -111,19 +106,12 @@     keyBind = maybe "" showBinding $ keybindForRoute kc route  -viewDaemonInfo :: State -> Widget Viewports-viewDaemonInfo ws =-    withBuildState ws (viewExpandedDaemonInfo . (.daemonInfo))-- viewTests :: State -> Widget Viewports-viewTests ws =-    withBuildState ws (viewTestResultsPanel ws)+viewTests ws = withBuildState ws (viewTestResultsPanel ws)   viewEvals :: State -> Widget Viewports-viewEvals ws =-    withBuildState ws $ viewEvalCommentsPanel ws+viewEvals ws = withBuildState ws $ viewEvalCommentsPanel ws   viewMain :: State -> Widget Viewports@@ -167,7 +155,6 @@         TestFilterAll -> Just "Tests"         TestFilterFailedOnly -> Just "Tests - Failed only"     Route.Help -> Just "Help"-    Route.DaemonInfo -> Just "Daemon info"     Route.Main -> Nothing     Route.Evals -> Just "Eval comments" @@ -228,67 +215,6 @@                     ]  -viewExpandedDaemonInfo :: DaemonInfo -> Widget n-viewExpandedDaemonInfo di =-    vBox-        [ viewVersion-        , viewTargets di.targets-        , viewWatchDirs di.watchDirs-        , viewSockPath di.sockPath-        , viewLogFile di.logFile-        ]---viewVersion :: Widget n-viewVersion =-    hBoxSpaced-        1-        [ emphasis $ txt "Client version:"-        , txt Version.gitHash-        ]---viewTargets :: [Target] -> Widget n-viewTargets targets =-    hBoxSpaced-        1-        [ emphasis $ txt "Targets:"-        , if null targets-            then-                txt "(all)"-            else-                vBox $ (map (txt . renderTarget) targets)-        ]---viewLogFile :: FilePath -> Widget n-viewLogFile p = hBoxSpaced 1 [emphasis $ txt "Log:", txt $ toText p]---viewSockPath :: FilePath -> Widget n-viewSockPath sockPath =-    hBoxSpaced 1 [emphasis $ txt "Socket:", txt $ toText sockPath]---viewWatchDirs :: [FilePath] -> Widget n-viewWatchDirs watchDirs =-    vBox-        [ emphasis $ txt "Watching:"-        , padLeft (Pad 2)-            $ vBox-            $ viewWatchDir <$> watchDirs-        ]---viewWatchDir :: FilePath -> Widget n-viewWatchDir dir = hBox [txt "- ", txt $ toText displayDir]-  where-    displayDir-        | isAbsolute dir = dir-        | dir == "." = "./"-        | otherwise = "./" <> dir-- viewBuildPhase :: TimeZone -> BuildPhase -> Widget Viewports viewBuildPhase tz = \case     Build.Starting ->@@ -320,7 +246,7 @@ viewPendingTestTargets tgts =     vBox         . ([txt "Pending test suites:"] <>)-        . fmap (subtle . txt . renderTestTarget)+        . fmap (subtle . txt . TestTarget.render)         $ tgts  @@ -404,7 +330,7 @@  viewTestRun :: TestTarget -> Test.Suite -> Widget n viewTestRun tgt run =-    hBox $ [txt $ renderTestTarget tgt, txt "  "] <> status+    hBox $ [txt $ TestTarget.render tgt, txt "  "] <> status   where     status = case run of         Test.SuiteRunning Nothing ->@@ -459,7 +385,7 @@   -- | Single-line build status with no scrollable diagnostics list, used as a--- compact header when a secondary panel (test results, daemon info) is open.+-- compact header when a secondary panel (test results) is open. viewBuildPhaseLine :: TimeZone -> BuildPhase -> Widget n viewBuildPhaseLine tz = \case     Build.Starting ->@@ -541,7 +467,7 @@             , viewTestOutput tvf c             ]   where-    t = renderTestTarget tgt+    t = TestTarget.render tgt   viewTestOutput :: TestFilter -> Test.SuiteCompletion -> Widget n

@@ -47,10 +47,11 @@ import Tricorder.Daemon.GhciSession (GhciSession, LoadResult (..)) import Tricorder.Daemon.GhciSession.GhciParser (resolveKnownTargets) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command)+import Tricorder.Session.Command.RenderedCommand (RenderedCommand) import Tricorder.Session.WatchDirs (WatchDirs)  import Tricorder.Daemon.GhciSession qualified as GhciSession+import Tricorder.Session.Stage qualified as Stage   data Builder :: Effect where@@ -87,7 +88,7 @@        , Reader ProjectRoot :> es        )     => BuildId-    -> Command+    -> RenderedCommand 'Stage.Build     -> WatchDirs     -> (BuilderState -> NewLoadResult -> Eff (Builder : es) a)     -> Eff es (Either SomeException a)

@@ -19,7 +19,6 @@ import Effectful.State.Static.Shared (State) import Relude.Extra.Tuple (dup) import System.FilePath ((</>))-import Text.Regex.TDFA.Pattern (showPattern)  import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.FileSystem qualified as FileSystem@@ -28,7 +27,6 @@ import Atelier.Effects.Publishing.Pub qualified as Pub import Atelier.Effects.Publishing.Sub qualified as Sub import Data.Map.Strict qualified as Map-import Data.Text qualified as T import Effectful.Reader.Static qualified as Reader import Effectful.State.Static.Shared qualified as State @@ -42,15 +40,8 @@     , NewLoadResult     , compileBuildResults     )-import Tricorder.Daemon.Dispatch-    ( BuilderState (..)-    , DispatchAction-    , emptyBuilderState-    )-import Tricorder.Daemon.EvalCommentRunner-    ( EvalCommentRunner-    , findEvalCommentsInModules-    )+import Tricorder.Daemon.Dispatch (BuilderState (..), DispatchAction, emptyBuilderState)+import Tricorder.Daemon.EvalCommentRunner (EvalCommentRunner, findEvalCommentsInModules) import Tricorder.Daemon.GhciSession (GhciSession) import Tricorder.Daemon.GhciSession.GhciParser     ( LoadResult@@ -62,14 +53,13 @@ import Tricorder.Daemon.Watch (WatchedFile) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session (Session (..))-import Tricorder.Session.Command (Command (..), Repl) import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..)) import Tricorder.Session.IdleTimeout (IdleTimeout)-import Tricorder.Session.ReplBuildDir (ReplBuildDir (..))-import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+import Tricorder.Session.Repl (Repl)+import Tricorder.Session.Stage.Build.Session (BuildSession (..))+import Tricorder.Session.Stage.Test.Command (RenderedTestCommand (..))+import Tricorder.Session.Stage.Test.Session (TestSession (..)) import Tricorder.Session.TestTimeout (TestTimeout (..))-import Tricorder.Session.WatchDirs (WatchDirs (..))-import Tricorder.Session.WatchExclusionPatterns (WatchExclusionPatterns (..)) import Tricorder.Waiters (Waiters)  import Tricorder.Build qualified as Build@@ -81,9 +71,11 @@ import Tricorder.Daemon.Hpack qualified as Hpack import Tricorder.Daemon.TestRunner qualified as TestRunner import Tricorder.Daemon.Watch qualified as Watch-import Tricorder.Session.Command qualified as Command+import Tricorder.Session qualified as Session+import Tricorder.Session.CommandTemplate qualified as Command import Tricorder.Session.Hooks qualified as Hooks-import Tricorder.Session.Target qualified as Target+import Tricorder.Session.Stage.Build.Command qualified as BuildCommand+import Tricorder.Session.Stage.Test.Command qualified as TestCommand import Tricorder.Session.TestTarget qualified as TestTarget import Tricorder.Waiters qualified as Waiters @@ -122,44 +114,88 @@        , Waiters :> es        )     => Eff es Void-main = runPubSub @ReloadSession-    . runPubSub @WatchedFile-    . runPubSub @CabalChangeDetected-    . runPubSub @SourceChangeDetected-    . runPubSub @RestartBuilder-    . runPubSub @ReloadBuilder-    $ Conc.restartableFork waitForReloadSession do-        root <- Reader.ask-        session <- input-        logSession session+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 -        State.put session.command.repl-        State.put session.idleTimeout-        Conc.fork_ $ watchConfigFile root-        conditionallyWatchStackYaml root -        Conc.fork_ $ Watch.files root session-        Conc.fork_ $ Sub.listen_ Watch.publishChange+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 -        Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) -> do-            needsSessionReload <- shouldReloadSession session-            if needsSessionReload-                then-                    Pub.publish ReloadSession-                else-                    Pub.publish RestartBuilder+    State.put session.buildSession.commandTemplate.repl+    State.put session.idleTimeout+    Conc.fork_ $ watchConfigFile root+    conditionallyWatchStackYaml root -        Conc.fork_ $ Sub.listen_ \(SourceChangeDetected fp event) ->-            Pub.publish $ ReloadBuilder fp event+    Conc.fork_ $ Watch.files root session+    Conc.fork_ $ Sub.listen_ Watch.publishChange -        when session.generateWithHpack.getGenerateWithHpack do-            void $ Conc.fork Hpack.main+    Conc.fork_ $ Sub.listen_ \(CabalChangeDetected _ _) ->+        ifM+            (shouldReloadSession session)+            (Pub.publish ReloadSession)+            (Pub.publish RestartBuilder) -        State.evalState emptyBuilderState $ withSession session-  where-    waitForReloadSession = Waiters.wait $ Sub.listenOnce_ @ReloadSession+    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+            buildId <- State.state (\s -> (s, s + 1))+            runBuilder buildId session++ shouldReloadSession :: (Input Session :> es) => Session -> Eff es Bool shouldReloadSession oldSession = do     newSession <- input@@ -194,34 +230,8 @@             \_ _ -> Pub.publish RestartBuilder  --- | For a given session, handles controlling the build process itself,--- restarting it as necessary.-withSession-    :: ( Clock :> es-       , Conc :> es-       , Concurrent :> es-       , EvalCommentRunner :> es-       , GhciSession :> es-       , Log :> es-       , Process :> es-       , Pub BuildPhase :> es-       , Reader ProjectRoot :> es-       , State BuildId :> es-       , State BuilderState :> es-       , Sub ReloadBuilder :> es-       , Sub RestartBuilder :> es-       , TestRunner :> es-       , Waiters :> es-       )-    => Session -> Eff es Void-withSession session = do-    Conc.restartableFork (Waiters.wait $ Sub.listenOnce_ @RestartBuilder) do-        buildId <- State.state (\s -> (s, s + 1))-        runSession buildId session-- -- | Starts the initial build with GHCi, and waits for source changes.-runSession+runBuilder     :: ( Clock :> es        , Conc :> es        , Concurrent :> es@@ -237,13 +247,13 @@        , Waiters :> es        )     => BuildId -> Session -> Eff es ()-runSession buildId session = do+runBuilder buildId session = do     Log.info $ "Starting session " <> show buildId.getBuildId     Pub.publish Build.Starting     whenJust (session.hooks.start >>= (.before)) Hooks.runHook     startupError <- fmap (either id absurd)-        $ Pub.map (Build.Building session.testTargets)-        $ Builder.with buildId session.command session.watchDirs \_ initialLoad -> do+        $ Pub.map (Build.Building session.testSession.targets)+        $ Builder.with buildId buildCommand session.watchDirs \_ initialLoad -> do             whenJust (session.hooks.start >>= (.after)) Hooks.runHook             processPostBuild session $ Right initialLoad             Log.debug "Waiting for reload"@@ -263,6 +273,8 @@                     $ waitForReload session event      Pub.publish $ Build.Failed $ show startupError+  where+    buildCommand = BuildCommand.render session.buildSession.commandTemplate session.buildSession.targets   -- | Handles source changes as they come, determining whether the source change@@ -374,7 +386,7 @@             let pendingComments =                     sconcat $ (\(lm, ecs) -> toPending lm.relPath <$> ecs) <$> nonEmptyComments             Pub.publish $ Eval.Found $ Eval.Comments pendingComments-            evaluatedComments <- EvalCommentRunner.evaluateComments session.command.repl nonEmptyComments+            evaluatedComments <- EvalCommentRunner.evaluateComments session.evalSession nonEmptyComments             pure $ Eval.Found $ Eval.Comments evaluatedComments   where     toPending file comment =@@ -392,12 +404,11 @@        )     => Session -> BuildResult -> Eff es Test.Suites runTests session buildResult-    | hasTargets session.testTargets && noErrors buildResult.diagnostics =+    | hasTargets session.testSession.targets && noErrors buildResult.diagnostics =         runTestsForTargets-            session.command+            session.testSession             session.testMemoryLimit             session.testTimeout-            session.testTargets     | otherwise = pure mempty   where     hasTargets = not . null@@ -409,31 +420,37 @@        , Pub Test.Suites :> es        , TestRunner :> es        )-    => Command+    => TestSession     -> Maybe ByteSize     -> TestTimeout-    -> [TestTarget]     -> Eff es Test.Suites-runTestsForTargets command memoryLimit testTimeout testTargets = do+runTestsForTargets testSession memoryLimit testTimeout = do     Pub.publish $ Test.Suites initial-    Log.info $ "Running " <> show (length testTargets) <> " test suite(s)"-    fmap Test.Suites . State.execState initial $ traverse_ go testTargets+    Log.info $ "Running " <> show (length testSession.targets) <> " test suite(s)"+    fmap Test.Suites . State.execState initial $ traverse_ go testSession.targets   where-    initial = Map.fromList $ (,Test.SuiteRunning Nothing) <$> testTargets+    initial = Map.fromList $ (,Test.SuiteRunning Nothing) <$> testSession.targets     go target = do-        Log.info $ "Running tests: " <> renderTestTarget target-        finishedSuite <--            TestRunner.runTestSuite-                ( \suite -> do-                    updated <- State.state $ dup . Map.insert target suite-                    Pub.publish $ Test.Suites updated-                )-                memoryLimit-                command.repl-                testTimeout-                target+        Log.info $ "Running tests: " <> renderedTarget+        let testCommand = TestCommand.render testSession memoryLimit target+            publishProgress suite = do+                updated <- State.state $ dup . Map.insert target suite+                Pub.publish $ Test.Suites updated+        Log.info+            $ "Test suite "+                <> renderedTarget+                <> " command:\n"+                <> show testCommand.command+        finishedSuite <- TestRunner.runTestSuite publishProgress testTimeout testCommand+        case finishedSuite of+            Test.SuiteErrored (Test.SuiteError message) ->+                Log.warn $ "Test suite " <> renderedTarget <> "failed: " <> message+            _ ->+                pure ()         updated <- State.state $ dup . Map.insert target finishedSuite         Pub.publish $ Test.Suites updated+      where+        renderedTarget = TestTarget.render target   newLoadResultToBuildResult@@ -452,25 +469,4 @@   logSession :: (Log :> es) => Session -> Eff es ()-logSession session =-    Log.info-        $ T.intercalate-            "\n"-            [ "Loaded session"-            , "Command: " <> Command.render session.command-            , "Targets:"-            , showList Target.renderTarget session.targets-            , "Test targets:"-            , showList TestTarget.renderTestTarget session.testTargets-            , "Watch dirs:"-            , showList toText session.watchDirs.getWatchDirs-            , "Watch exclusion patterns:"-            , showList (toText . showPattern . fst) session.watchExclusionPatterns.getWatchExclusionPatterns-            , "Repl build dir: " <> toText session.replBuildDir.getReplBuildDir-            , -- TODO: Remove " seconds" when TestTimeout is converted to a proper time unit.-              "Test timeout: " <> show session.testTimeout.getTestTimeout <> " seconds"-            , "Test memory limit: " <> show session.testMemoryLimit-            , "Generate with hpack: " <> show session.generateWithHpack.getGenerateWithHpack-            ]-  where-    showList f = T.intercalate "\n" . fmap (("- " <>) . f)+logSession = Log.info . (<> "\n") . Session.show

@@ -13,6 +13,7 @@  import Tricorder.Runtime (LogPath (..), ProjectRoot (..), SocketPath (..)) import Tricorder.Session (Session (..))+import Tricorder.Session.Stage.Build.Session (BuildSession (..)) import Tricorder.Session.Target (Target) import Tricorder.Session.WatchDirs (WatchDirs (..)) @@ -41,7 +42,7 @@     LogPath logFile <- ask     pure         $ DaemonInfo-            { targets = session.targets+            { targets = session.buildSession.targets             , watchDirs = map (makeRelative projectRoot) session.watchDirs.getWatchDirs             , sockPath             , logFile

@@ -32,9 +32,11 @@ import Tricorder.Daemon.GhciSession.GhciParser (LoadedModule (..)) import Tricorder.Daemon.GhciSession.GhciProcess (execGhci, withGhciProcess) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..), Repl)+import Tricorder.Session.CommandTemplate (CommandTemplate)  import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Session.Stage qualified as Stage+import Tricorder.Session.Stage.Eval.Command qualified as EvalCommand import Tricorder.Session.Target qualified as Target  @@ -42,7 +44,7 @@     -- | Scan all loaded source files for eval comments and evaluate them, each     -- in a fresh GHCi session started in that file's module context.     EvaluateComments-        :: Repl+        :: CommandTemplate 'Stage.Eval         -> NonEmpty (LoadedModule, NonEmpty Eval.Comment)         -> EvalCommentRunner m (NonEmpty Eval.Evaluation)     -- | Extract eval comments from provided source files. Returns a map of all@@ -80,13 +82,9 @@                         case Eval.findComments $ decodeUtf8Lenient bs of                             [] -> []                             x : xs -> [(lm, x :| xs)]-        EvaluateComments repl moduleComments -> do-            fmap sconcat $ for moduleComments \(lm, comments) -> do-                runFileEvals-                    repl-                    lm.relPath-                    lm.moduleName-                    comments+        EvaluateComments template moduleComments -> do+            fmap sconcat $ for moduleComments \(lm, comments) ->+                runFileEvals template lm.relPath lm.moduleName comments   -- ---------------------------------------------------------------------------@@ -108,23 +106,22 @@        , Reader ProjectRoot :> es        , Timeout :> es        )-    => Repl+    => CommandTemplate 'Stage.Eval     -> FilePath     -- ^ Relative path to the source file (stored in results).     -> Text-    -- ^ Module name (e.g. @"Tricorder.Builder"@), used to load the module-    -- in interpreted mode so that its full local scope is available.     -> NonEmpty Eval.Comment     -> Eff es (NonEmpty Eval.Evaluation)-runFileEvals repl relPath moduleName comments = do+runFileEvals template relPath moduleName comments = do     ProjectRoot projectRoot <- ask     let noProgress = \_ -> pure ()         noSetup = \_ -> pure ()         wrapForGhci expr             | T.elem '\n' expr = ":{" <> "\n" <> expr <> "\n" <> ":}"             | otherwise = expr+        command = EvalCommand.render template [Target.Bare moduleName]     sessionResult <- trySync-        $ withGhciProcess def (Command repl [] [Target.Bare moduleName]) projectRoot noProgress noSetup \ghci _ -> do+        $ withGhciProcess def command projectRoot noProgress noSetup \ghci _ -> do             _ <- execGhci ghci (":m *" <> moduleName) noProgress             for comments \comment -> do                 outputResult <- trySync $ execGhci ghci (wrapForGhci comment.expression) noProgress

@@ -59,7 +59,8 @@     , withGhciProcess     ) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command)+import Tricorder.Session.Command.RenderedCommand (RenderedCommand)+import Tricorder.Session.Stage (Stage (..))   data GhciSession :: Effect where@@ -70,7 +71,7 @@     WithGhciWith         :: (BuildProgress -> m ())         -- ^ Action to run when reporting progress-        -> Command+        -> RenderedCommand 'Build         -> ProjectRoot         -> (LoadResult -> Controls m -> m a)         -> GhciSession m a@@ -99,7 +100,7 @@  withGhci     :: (GhciSession :> es, Pub BuildProgress :> es)-    => Command+    => RenderedCommand 'Build     -> ProjectRoot     -> (LoadResult -> Controls (Eff es) -> Eff es a)     -> Eff es a

@@ -2,6 +2,7 @@     ( Config (..)     , GhciProcess (..)     , GhciProcessError (..)+    , UnexpectedExit (..)     , SessionState (..)     , InterruptDecision (..)     , decideInterrupt@@ -59,9 +60,7 @@     , stripAnsi     , unattributedFailure     )-import Tricorder.Session.Command (Command (..))--import Tricorder.Session.Command qualified as Command+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))   -- | Configuration for GHCi process management.@@ -122,7 +121,7 @@ -- | Errors that can occur during GHCi process management. data GhciProcessError     = StartupTimeout-    | UnexpectedExit Text (Maybe Text)+    | 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@@ -131,6 +130,13 @@     deriving stock (Eq, Show)  +data UnexpectedExit = MkUnexpectedExit+    { marker :: Text+    , errorMessage :: Text+    }+    deriving stock (Eq, Show)++ instance Exception GhciProcessError  @@ -223,7 +229,7 @@ withGhciProcess     :: (Conc :> es, Concurrent :> es, File :> es, Log :> es, Process :> es, Timeout :> es)     => Config-    -> Command+    -> RenderedCommand stage     -> FilePath     -> (GhciLoading -> Eff es ())     -> (GhciProcess -> Eff es ())@@ -240,8 +246,7 @@             $ setStderr createPipe             $ setWorkingDir dir             $ shell-            $ toString-            $ Command.render cmd+            $ toString cmd.getRenderedCommand   -- | Execute a command in GHCi and return the combined stdout+stderr output@@ -384,32 +389,31 @@         case result of             Left ex -> do                 let accumulatedLines = T.intercalate "\n" $ toList acc-                Log.err-                    $ T.intercalate-                        "\n"-                        [ "Reached EOF before reading marker from GHCi."-                        , "Was looking for marker '" <> marker <> "', but no such marker was found."-                        , ""-                        ]-                        <> if T.null accumulatedLines-                            then-                                T.intercalate-                                    "\n"-                                    [ "GHCi returned no output before we reached what we believe is EOF."-                                    , "Got the following exception when attempting to read from GHCi:"-                                    , toText $ displayException ex-                                    ]-                            else-                                T.intercalate-                                    "\n"-                                    [ "Accumulated output from GHCi so far:"-                                    , accumulatedLines-                                    ]+                    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 marker-                    $ if T.null accumulatedLines-                        then Nothing-                        else Just accumulatedLines+                    $ UnexpectedExit+                    $ MkUnexpectedExit {marker, errorMessage}             Right line                 | marker `T.isInfixOf` line -> pure $ toList acc                 -- A stale marker from an interrupted command: drop it, keep going.

@@ -36,17 +36,18 @@ 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.Daemon.Core qualified as Core-import Tricorder.Daemon.DaemonInfo qualified as DaemonInfo import Tricorder.Daemon.EvalCommentRunner qualified as EvalCommentRunner import Tricorder.Daemon.Hpack.Effect qualified as Hpack import Tricorder.Daemon.IdleTimer qualified as IdleTimer import Tricorder.Daemon.TestRunner qualified as TestRunner-import Tricorder.Session.Command qualified as Repl+import Tricorder.Session.Repl qualified as Repl+import Tricorder.Session.StackProject qualified as StackProject import Tricorder.Socket.Server qualified as Server import Tricorder.SourceLookup qualified as SourceLookup import Tricorder.SourceLookup.Hackage qualified as Hackage@@ -79,10 +80,10 @@         . inputLoadedConfig         . runLogging         . runChan+        . StackProject.inputWithCache         . inputCabalFiles         . inputSession         . runReader @CacheConfig.Config def-        . DaemonInfo.runInput         . runCacheTtl @ModuleName @PackageId         . runCacheTtl @(PackageId, SourceQuery) @SourceLookup.ModuleSourceResult         . runProcessIO@@ -92,7 +93,7 @@         . evalState (BuildId 1)         . Input.fromState @BuildId         . evalState Repl.Unknown-        . Input.fromState @Repl.Repl+        . Input.fromState @Repl         . evalState @IdleTimeout def         . Input.fromState @IdleTimeout         . IdleTimer.quitOnTimeout

@@ -19,36 +19,56 @@ import Atelier.Effects.Conc (Conc) import Atelier.Effects.File (File) import Atelier.Effects.Log (Log)-import Atelier.Effects.Process (Process)+import Atelier.Effects.Process+    ( Process+    , createPipe+    , getStderr+    , getStdin+    , getStdout+    , setStderr+    , setStdin+    , setStdout+    , setWorkingDir+    , shell+    ) import Atelier.Effects.Timeout (Timeout, timeout)+import Control.Concurrent.STM (modifyTVar') import Control.Exception (throwIO) import Data.Default (def)+import Data.Sequence ((|>)) import Data.Time.Units (Second) import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (ConcUnlift)) import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.STM (atomically, newTVarIO, readTVarIO) import Effectful.Dispatch.Dynamic (interpretWith, localUnlift, reinterpret_) import Effectful.Exception (trySync) import Effectful.Reader.Static (Reader, ask) import Effectful.State.Static.Shared (State, evalState, get, put) import Effectful.TH (makeEffect)+import System.Exit (ExitCode (..)) -import Atelier.Effects.Log qualified as Log+import Atelier.Effects.Conc qualified as Conc+import Atelier.Effects.File qualified as File+import Atelier.Effects.Process qualified as Process import Data.List qualified as List import Data.Text qualified as T -import Tricorder.Build.ByteSize (ByteSize)-import Tricorder.Daemon.GhciSession.GhciParser (GhciLoading (..))+import Tricorder.Daemon.GhciSession.GhciParser (GhciLoading (..), parseProgressLine) import Tricorder.Daemon.GhciSession.GhciProcess-    ( execGhci+    ( GhciProcessError (..)+    , UnexpectedExit (..)+    , execGhci     , withGhciProcess     ) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..), Repl (..))-import Tricorder.Session.TestTarget (TestTarget, getTestTarget, renderTestTarget)+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Stage.Test.Command (RenderedTestCommand (..))+import Tricorder.Session.Stage.Test.Config (OutputMode (..))+import Tricorder.Session.Stage.Test.Session (ResolvedTestOptions (..)) import Tricorder.Session.TestTimeout (TestTimeout (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) -import Tricorder.Build.ByteSize qualified as ByteSize import Tricorder.Build.Test qualified as Test  @@ -58,11 +78,8 @@     RunTestSuite         :: (Test.Suite -> m ())         -- ^ Handler for test run progress-        -> Maybe ByteSize-        -- ^ Memory limit for test suite-        -> Repl         -> TestTimeout-        -> TestTarget+        -> RenderedTestCommand         -> TestRunner m Test.Suite  @@ -84,86 +101,161 @@     => Eff (TestRunner : es) a -> Eff es a run act = do     interpretWith act \env -> \case-        RunTestSuite progressHandler mMemoryLimit repl testTimeout target ->+        RunTestSuite progressHandler testTimeout cmd ->             localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do                 let onProgress = unlift . progressHandler . loadingToProgress-                    noProgress _ = pure ()-                    noReady _ = pure ()-                    memoryLimitArg =-                        maybe-                            []-                            ( \limit ->-                                let-                                    stack =-                                        [ "--ghc-options"-                                        , "+RTS -M"-                                            <> ByteSize.toRTSSize limit-                                            <> " -RTS"-                                        ]-                                    cabal =-                                        [ "--repl-options"-                                        , "+RTS -M"-                                            <> ByteSize.toRTSSize limit-                                            <> " -RTS"-                                        ]-                                in-                                    case repl of-                                        Stack -> stack-                                        StackMulti -> stack-                                        Cabal -> cabal-                                        Unknown -> cabal-                            )-                            mMemoryLimit-                ProjectRoot projectRoot <- ask-                result <- trySync-                    $ withGhciProcess-                        def-                        (Command repl memoryLimitArg [getTestTarget target])-                        projectRoot-                        onProgress-                        noReady-                        \ghci _ ->-                            case testTimeout of-                                TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress-                                TestTimeout secs ->-                                    let duration = fromIntegral secs :: Second-                                    in  maybeToRight secs-                                            <$> timeout duration (execGhci ghci ":main" noProgress)-                case result of-                    Left ex ->-                        pure-                            $ Test.SuiteErrored-                            $ Test.SuiteError {message = show ex}-                    Right (Left secs) -> do-                        Log.warn-                            $ mconcat-                                [ "Test suite "-                                , renderTestTarget target-                                , " timed out after "-                                , show secs-                                , "s"-                                ]-                        pure-                            $ Test.SuiteErrored-                            $ Test.SuiteError-                                { message = "Test suite timed out after " <> show secs <> "s"-                                }-                    Right (Right mainLines) ->-                        pure-                            $ let output = T.unlines mainLines-                              in  case detectOutcome output of-                                    GhciCrashed msg ->-                                        Test.SuiteErrored $ Test.SuiteError {message = msg}-                                    outcome ->-                                        Test.SuiteCompleted-                                            $ Test.SuiteCompletion-                                                { passed = outcome == GhciPassed-                                                , output-                                                , testCases = parseHspecOutput output-                                                , duration = parseHspecDuration output-                                                }+                case cmd.options.outputMode of+                    ReplOutput -> runTestSuiteWithGHCi onProgress testTimeout cmd.command+                    StdoutOutput -> runTestSuiteWithStdout onProgress testTimeout cmd.command  +runTestSuiteWithStdout+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Process :> es+       , Reader ProjectRoot :> es+       , Timeout :> es+       )+    => (GhciLoading -> Eff es ())+    -> TestTimeout+    -> RenderedCommand 'Test+    -> Eff es Test.Suite+runTestSuiteWithStdout onProgress testTimeout cmd = do+    ProjectRoot projectRoot <- ask+    -- Lines from both streams, in the order they arrived.+    outputVar <- newTVarIO (mempty :: Seq Text)+    let processConfig =+            setStdin createPipe+                $ setStdout createPipe+                $ setStderr createPipe+                $ setWorkingDir projectRoot+                $ shell+                $ toString cmd.getRenderedCommand++        drain h =+            unlessM (File.hIsEOF h) do+                line <- File.hGetLine h+                atomically $ modifyTVar' outputVar (|> line)+                traverse_ onProgress (parseProgressLine line)+                drain h++        runToCompletion p = do+            -- The suite gets no input; close stdin so it sees EOF if it reads.+            File.hClose (getStdin p)+            Conc.scoped do+                stdoutThread <- Conc.fork $ drain (getStdout p)+                stderrThread <- Conc.fork $ drain (getStderr p)+                Conc.await stdoutThread+                Conc.await stderrThread+            Process.waitExitCode p++    result <- trySync+        $ Process.withProcessGroup processConfig \p ->+            case testTimeout of+                TestTimeout secs | secs <= 0 -> Right <$> runToCompletion p+                TestTimeout secs ->+                    let duration = fromIntegral secs :: Second+                    in  maybeToRight secs <$> timeout duration (runToCompletion p)+    output <- T.unlines . toList <$> readTVarIO outputVar+    let completed passed =+            Test.SuiteCompleted+                $ Test.SuiteCompletion+                    { passed+                    , output+                    , testCases = parseHspecOutput output+                    , duration = parseHspecDuration output+                    }+    pure $ case result of+        Left ex ->+            Test.SuiteErrored+                $ Test.SuiteError+                    { message = "Test suite failed to run:\n" <> show ex+                    }+        Right (Left secs) ->+            Test.SuiteErrored+                $ Test.SuiteError+                    { message = "Test suite timed out after " <> show secs <> "s"+                    }+        Right (Right ExitSuccess) -> completed True+        Right (Right (ExitFailure _)) -> case detectOutcome output of+            GhciCrashed msg -> Test.SuiteErrored $ Test.SuiteError {message = msg}+            _ -> completed False+++runTestSuiteWithGHCi+    :: ( Conc :> es+       , Concurrent :> es+       , File :> es+       , Log :> es+       , Process :> es+       , Reader ProjectRoot :> es+       , Timeout :> es+       )+    => (GhciLoading -> Eff es ())+    -> TestTimeout+    -> RenderedCommand 'Test+    -> Eff es Test.Suite+runTestSuiteWithGHCi onProgress testTimeout cmd = do+    ProjectRoot projectRoot <- ask+    result <- trySync+        $ withGhciProcess+            def+            cmd+            projectRoot+            onProgress+            noReady+            \ghci _ ->+                case testTimeout of+                    TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress+                    TestTimeout secs ->+                        let duration = fromIntegral secs :: Second+                        in  maybeToRight secs+                                <$> timeout duration (execGhci ghci ":main" noProgress)+    case result of+        Left ex -> case fromException ex of+            Just (e :: GhciProcessError) -> case e of+                UnexpectedExit (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 ->+                    pure+                        $ Test.SuiteErrored+                        $ Test.SuiteError+                        $ "Test suite failed on startup, before Tricorder could start running the test suite itself:\n" <> msg+            Nothing ->+                pure+                    $ Test.SuiteErrored+                    $ Test.SuiteError {message = show ex}+        Right (Left secs) -> do+            pure+                $ Test.SuiteErrored+                $ Test.SuiteError+                    { message = "Test suite timed out after " <> show secs <> "s"+                    }+        Right (Right mainLines) ->+            pure+                $ let output = T.unlines mainLines+                  in  case detectOutcome output of+                        GhciCrashed msg ->+                            Test.SuiteErrored $ Test.SuiteError {message = msg}+                        outcome ->+                            Test.SuiteCompleted+                                $ Test.SuiteCompletion+                                    { passed = outcome == GhciPassed+                                    , output+                                    , testCases = parseHspecOutput output+                                    , duration = parseHspecDuration output+                                    }+  where+    noReady _ = pure ()+    noProgress _ = pure ()++ -- | Scripted interpreter for testing. -- -- Each call to 'runTestSuite' pops the next result from the pre-loaded list.@@ -177,7 +269,7 @@ runScripted results =     reinterpret_         (evalState results)-        (\(RunTestSuite _ _ _ _ _) -> popResult)+        (\(RunTestSuite _ _ _) -> popResult)   where     popResult :: Eff (State [Either SomeException Test.Suite] : es) Test.Suite     popResult =

@@ -2,6 +2,7 @@     ( Session (..)     , loadSession     , inputSession+    , show     ) where @@ -11,35 +12,54 @@ import Atelier.Effects.Log (Log) import Data.Default (Default (..)) import Effectful.Reader.Static (Reader, ask)+import Text.Regex.TDFA.Pattern (showPattern)+import Prelude hiding (show)  import Atelier.Effects.Log qualified as Log import Data.Text qualified as T+import Prelude qualified as P  import Tricorder.Build.ByteSize (ByteSize) import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session.CabalFile (CabalFile)-import Tricorder.Session.Command (Command (..), resolveCommand)+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate+    ( CommandTemplate (..)+    , hasPlaceholder+    , targetPlaceholder+    ) import Tricorder.Session.Config (Config (..)) import Tricorder.Session.GenerateWithHpack (GenerateWithHpack (..)) import Tricorder.Session.Hooks (Hooks) import Tricorder.Session.IdleTimeout (IdleTimeout (..))+import Tricorder.Session.Repl (resolveRepl) import Tricorder.Session.ReplBuildDir (ReplBuildDir (..))-import Tricorder.Session.Target (Target, definesCustomPrelude, resolveTargets)-import Tricorder.Session.TestTarget (TestTarget, resolveTestTargets)+import Tricorder.Session.Stage.Build.Session (BuildSession (..))+import Tricorder.Session.Stage.Test.Config (TestConfig (..))+import Tricorder.Session.Stage.Test.Session (TestSession (..))+import Tricorder.Session.Target (definesCustomPrelude)+import Tricorder.Session.TestTarget (getTestTarget) import Tricorder.Session.TestTimeout (TestTimeout (..))-import Tricorder.Session.WatchDirs (WatchDirs (..), resolveWatchDirs)+import Tricorder.Session.Util (indent, showList)+import Tricorder.Session.WatchDirs (WatchDirs (..)) import Tricorder.Session.WatchExclusionPatterns     ( WatchExclusionPatterns (..)     , resolveWatchExclusionPatterns     )  import Tricorder.Build.ByteSize qualified as ByteSize+import Tricorder.Session.Stage qualified as Stage+import Tricorder.Session.Stage.Build.Session qualified as BuildSession+import Tricorder.Session.Stage.Eval.Command qualified as EvalCommand+import Tricorder.Session.Stage.Eval.Session qualified as EvalSession+import Tricorder.Session.Stage.Test.Session qualified as TestSession+import Tricorder.Session.WatchDirs qualified as WatchDirs   data Session = Session-    { command :: Command-    , targets :: [Target]-    , testTargets :: [TestTarget]+    { buildSession :: BuildSession+    , testSession :: TestSession+    , evalSession :: CommandTemplate 'Stage.Eval     , testMemoryLimit :: Maybe ByteSize     , watchDirs :: WatchDirs     , watchExclusionPatterns :: WatchExclusionPatterns@@ -55,9 +75,9 @@ instance Default Session where     def =         Session-            { command = def-            , targets = []-            , testTargets = []+            { buildSession = def+            , testSession = def+            , evalSession = def             , testMemoryLimit = Nothing             , watchDirs = def             , watchExclusionPatterns = def@@ -80,14 +100,16 @@ loadSession = do     projectRoot <- ask @ProjectRoot     loadedCfg <- input+    Log.debug "Got config file"     projectFiles <- input+    Log.debug "Got project files"      let cfgFile = extractConfig @"session" @Config loadedCfg-        effectiveTargets = resolveTargets projectFiles cfgFile.targets-        testTargets = resolveTestTargets cfgFile effectiveTargets-        watchDirs = resolveWatchDirs projectRoot projectFiles cfgFile effectiveTargets         hooks = fromMaybe def cfgFile.hooks +    warnDeprecatedConfig cfgFile+    Log.debug "Warned about deprecated config stuff"+     testMemoryLimit <- case cfgFile.testMemoryLimit of         Nothing -> pure Nothing         Just limit -> case ByteSize.fromText limit of@@ -110,6 +132,13 @@                 pure $ WatchExclusionPatterns []             Right pts -> pure pts +    repl <- resolveRepl projectRoot+    buildSession <- BuildSession.resolve cfgFile repl projectFiles+    let testSession = TestSession.resolve repl buildSession.targets cfgFile+        evalSession = EvalCommand.resolve repl cfgFile+        effectiveTargets = buildSession.targets <> (getTestTarget <$> testSession.targets)+        watchDirs = WatchDirs.resolve projectRoot projectFiles cfgFile effectiveTargets+     when (not (null effectiveTargets) && all (definesCustomPrelude projectFiles) effectiveTargets)         $ Log.warn             "Every resolved target exposes a custom Prelude module. GHCi may \@@ -118,16 +147,27 @@             \not define its own Prelude, or set an explicit command in your \             \tricorder configuration." -    command <- resolveCommand projectRoot cfgFile effectiveTargets testTargets+    warnMissingTargetPlaceholder "test" cfgFile.test.commandConfig.commandTemplate+    warnMissingTargetPlaceholder "eval" cfgFile.eval.commandTemplate +    warnIgnoredextraAutoArguments+        "build"+        (cfgFile.build.commandTemplate <|> cfgFile.command)+        cfgFile.build.extraAutoArguments+    warnIgnoredextraAutoArguments+        "test"+        cfgFile.test.commandConfig.commandTemplate+        cfgFile.test.commandConfig.extraAutoArguments+    warnIgnoredextraAutoArguments "eval" cfgFile.eval.commandTemplate cfgFile.eval.extraAutoArguments+     pure         $ Session-            { targets = effectiveTargets-            , command+            { buildSession+            , testSession+            , evalSession             , watchDirs             , watchExclusionPatterns             , testMemoryLimit-            , testTargets             , replBuildDir = ReplBuildDir cfgFile.replBuildDir             , testTimeout = TestTimeout cfgFile.testTimeout             , generateWithHpack = GenerateWithHpack cfgFile.generateWithHpack@@ -145,3 +185,78 @@        )     => 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.+warnDeprecatedConfig :: (Log :> es) => Config -> Eff es ()+warnDeprecatedConfig cfgFile = do+    whenJust cfgFile.command+        $ const+        $ Log.warn "session.command is deprecated; use session.build.command_template instead."+    unless (null cfgFile.targets)+        $ Log.warn "session.targets is deprecated; use session.build.targets instead."+    whenJust cfgFile.testTargets+        $ const+        $ Log.warn "session.test_targets is deprecated; use session.test.targets instead."+++-- | Warn when a section's @extra_auto_arguments@ is set alongside a custom+-- @command_template@, since 'Tricorder.Session.Config.extraAutoArguments'+-- would otherwise be silently ignored.+warnIgnoredextraAutoArguments :: (Log :> es) => Text -> Maybe Text -> [Text] -> Eff es ()+warnIgnoredextraAutoArguments section customTemplate extraAutoArguments =+    when (isJust customTemplate && not (null extraAutoArguments))+        $ Log.warn+        $ "session."+            <> section+            <> ".command_template is set; session."+            <> section+            <> ".extra_auto_arguments is ignored (it only applies to Tricorder's \+               \automatically resolved command)."+++-- | Warn when a custom @test@\/@eval@ @command_template@ has no @{target}@+-- placeholder — without it, every invocation (one per test target or+-- module) silently runs the exact same command. @build@ isn't checked this+-- way: a missing @{targets}@ there mirrors past custom-@command@ behavior,+-- more likely deliberate than an oversight.+warnMissingTargetPlaceholder :: (Log :> es) => Text -> Maybe Text -> Eff es ()+warnMissingTargetPlaceholder section customTemplate =+    case customTemplate of+        Just tpl+            | not (hasPlaceholder targetPlaceholder tpl) ->+                Log.warn+                    $ "session."+                        <> section+                        <> ".command_template has no {target} placeholder — every "+                        <> section+                        <> " invocation will run the same command."+        _ -> pure ()+++show :: Session -> Text+show session =+    T.intercalate+        "\n"+        [ "Loaded session"+        , "Build configuration:"+        , indent $ BuildSession.show session.buildSession+        , "Test configuration:"+        , indent $ TestSession.show session.testSession+        , "Eval comments configuration:"+        , indent $ EvalSession.show session.evalSession+        , "Watch dirs:"+        , indent $ showList toText session.watchDirs.getWatchDirs+        , "Watch exclusion patterns:"+        , indent+            $ showList+                (toText . showPattern . fst)+                session.watchExclusionPatterns.getWatchExclusionPatterns+        , "Repl build dir: " <> toText session.replBuildDir.getReplBuildDir+        , -- TODO: Remove " seconds" when TestTimeout is converted to a proper time unit.+          "Test timeout: " <> P.show session.testTimeout.getTestTimeout <> " seconds"+        , "Test memory limit: " <> P.show session.testMemoryLimit+        , "Generate with hpack: " <> P.show session.generateWithHpack.getGenerateWithHpack+        ]

@@ -1,29 +1,37 @@ module Tricorder.Session.CabalFile     ( CabalFile (..)     , inputCabalFiles-    , discoverCabalFiles+    , discoverPackages+    , discoverCabalPackages+    , discoverStackPackages+    , readProjectFile     ) where  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, runInputEff)+import Atelier.Effects.Input (Input, input, runInputEff) 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 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.Log qualified as Log import Data.ByteString.Char8 qualified as BC+import Data.List qualified as List import Data.Text qualified as T  import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.StackProject (StackProject (..))   data CabalFile = CabalFile@@ -37,42 +45,93 @@     :: ( Env :> es        , FileSystem :> es        , Glob :> es+       , Input StackProject :> es        , Log :> es        , Reader ProjectRoot :> es        )     => Eff (Input [CabalFile] : es) a -> Eff es a-inputCabalFiles = runInputEff do-    projectFilePaths <- discoverCabalFiles-    (faileds, packageDescriptions) <--        partitionEithers <$> for projectFilePaths \p -> do-            contents <- readFileBs p-            case parseGenericPackageDescriptionMaybe contents of-                Nothing -> pure $ Left p-                Just gpd -> pure $ Right $ CabalFile p gpd-    unless (null faileds) do-        Log.warn-            $ "Failed to parse .cabal files for the following packages: "-                <> T.intercalate ", " (toText <$> faileds)-    pure $ packageDescriptions+inputCabalFiles = runInputEff $ Log.withNamespace "CabalFile" do+    packageRes <- discoverPackages+    case packageRes of+        Left err -> throwIO $ userError $ toString err+        Right projectFilePaths -> do+            (faileds, packageDescriptions) <-+                logFailure+                    $ partitionEithers <$> for projectFilePaths readProjectFile+            unless (null faileds) do+                Log.warn+                    $ "Failed to parse .cabal files for the following packages: "+                        <> T.intercalate ", " (toText <$> faileds)+            pure $ packageDescriptions+  where+    logFailure =+        ( `catch`+            \(e :: SomeException) -> do+                Log.err $ "Failed to read package descriptions"+                Log.err $ show e+                throwIO e+        )  +readProjectFile+    :: (FileSystem :> es)+    => FilePath -> Eff es (Either FilePath CabalFile)+readProjectFile projectFilePath = do+    fileExists <- FileSystem.doesFileExist projectFilePath+    if fileExists+        then readFile projectFilePath+        else do+            dirExists <- FileSystem.doesDirectoryExist projectFilePath+            if dirExists+                then do+                    files <- FileSystem.listDirectory projectFilePath+                    let mCabalFile = find (".cabal" `List.isSuffixOf`) files+                    case mCabalFile of+                        Nothing -> pure $ Left projectFilePath+                        Just cabalFile -> readFile $ projectFilePath </> cabalFile+                else+                    pure $ Left projectFilePath+  where+    readFile path = do+        contents <- readFileBs path+        case parseGenericPackageDescriptionMaybe contents of+            Nothing -> pure $ Left path+            Just gpd -> pure $ Right $ CabalFile path gpd+++discoverPackages+    :: ( Env :> es+       , FileSystem :> es+       , Glob :> es+       , Input StackProject :> es+       , Reader ProjectRoot :> es+       )+    => Eff es (Either Text [FilePath])+discoverPackages = do+    ProjectRoot projectRoot <- ask+    hasStackYaml <- FileSystem.doesFileExist $ projectRoot </> "stack.yaml"+    if hasStackYaml+        then discoverStackPackages+        else discoverCabalPackages++ -- | Discovers `.cabal` files in all locations and formats Cabal itself -- supports.-discoverCabalFiles+discoverCabalPackages     :: ( Env :> es        , FileSystem :> es        , Glob :> es        , Reader ProjectRoot :> es        )-    => Eff es [FilePath]-discoverCabalFiles = do+    => Eff es (Either Text [FilePath])+discoverCabalPackages = do     ProjectRoot projectRoot <- ask     homeCabalFiles <- maybe [] (one . (</> ".cabal/config")) <$> Env.lookupEnv "HOME"     let projectFilePaths = projectCabalFiles projectRoot <> homeCabalFiles     projectFiles <- filterM doesFileExist projectFilePaths     if null projectFiles         then-            cabalFilesIn projectRoot+            Right <$> cabalFilesIn projectRoot         else do             packages <- fmap (find (not . null))                 $ for projectFiles \projectFile -> do@@ -82,8 +141,8 @@                             (cabalFilesForEntry projectRoot)                             (projectPackageEntries contents)             case packages of-                Nothing -> cabalFilesIn projectRoot-                Just pkgs -> pure pkgs+                Nothing -> Right <$> cabalFilesIn projectRoot+                Just pkgs -> pure $ Right pkgs   where     projectCabalFiles projectRoot =         (projectRoot </>) <$> ["cabal.project.local", "cabal.project.freeze", "cabal.project"]@@ -98,6 +157,15 @@         resolveMatch path             | isCabalFile path = pure [path]             | otherwise = cabalFilesIn path+++discoverStackPackages+    :: (Input StackProject :> es, Reader ProjectRoot :> es)+    => Eff es (Either Text [FilePath])+discoverStackPackages = do+    ProjectRoot projectRoot <- ask+    project <- input+    pure $ Right $ normalise . (projectRoot </>) <$> project.packages   -- | List the @.cabal@ files directly inside a directory.

@@ -1,141 +0,0 @@-module Tricorder.Session.Command-    ( Command (..)-    , Repl (..)-    , render-    , resolveCommand-    )-where--import Atelier.Effects.FileSystem (FileSystem)-import Data.Default (Default (..))-import Effectful.NonDet (NonDet, OnEmptyPolicy (..), emptyEff, plusEff, runNonDet)-import System.FilePath ((</>))--import Atelier.Effects.FileSystem qualified as FileSystem-import Data.List qualified as List--import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Config (Config, command, replBuildDir)-import Tricorder.Session.Target (Target (..))-import Tricorder.Session.TestTarget (TestTarget, getTestTarget)--import Tricorder.Session.Target qualified as Target---data Command = Command-    { repl :: Repl-    , arguments :: [Text]-    , targets :: [Target]-    }-    deriving stock (Eq, Generic, Show)---data Repl = StackMulti | Stack | Cabal | Unknown-    deriving stock (Eq, Generic, Show)---render :: Command -> Text-render command = unwords $ renderRepl command.repl <> command.arguments <> tgts-  where-    tgts = case command.repl of-        Stack -> List.nub $ Target.componentName <$> command.targets-        StackMulti -> List.nub $ Target.renderTarget <$> command.targets-        Cabal -> Target.renderTarget <$> command.targets-        Unknown -> Target.renderTarget <$> command.targets---renderRepl :: Repl -> [Text]-renderRepl StackMulti = ["stack", "ghci"]-renderRepl Stack = ["stack", "ghci"]-renderRepl Cabal = ["cabal", "repl"]-renderRepl Unknown = []---instance Default Command where-    def = Command Unknown [] []----- | Resolve the GHCi command, using config if set or autodetecting otherwise.------ The @testTargets@ are the discovered @test:@ components; they are appended to--- the auto-detected @all@ target (see 'detectCommand'). They are ignored when--- the user has pinned an explicit @command@ or explicit @targets@ in config.-resolveCommand-    :: (FileSystem :> es) => ProjectRoot -> Config -> [Target] -> [TestTarget] -> Eff es Command-resolveCommand projectRoot@(ProjectRoot root) cfg targets testTargets =-    case cfg.command of-        Just cmd -> case words cmd of-            "stack" : "repl" : args -> detectStackKind args-            "stack" : "ghci" : args -> detectStackKind args-            "cabal" : "repl" : args -> pure $ Command Cabal args []-            args -> pure $ Command Unknown args []-        Nothing ->-            detectCommand targets testTargets cfg.replBuildDir projectRoot-  where-    detectStackKind args = do-        hasCabalFileInRoot <- any (".cabal" `List.isSuffixOf`) <$> FileSystem.listDirectory root-        let repl =-                if hasCabalFileInRoot-                    then-                        Stack-                    else-                        StackMulti-        pure $ Command repl args []---detectCommand-    :: (FileSystem :> es) => [Target] -> [TestTarget] -> FilePath -> ProjectRoot -> Eff es Command-detectCommand targets testTargets replBuildDir projectRoot = do-    cmd <--        fmap (fromMaybe (fallback replBuildDir) . rightToMaybe)-            $ runNonDet OnEmptyKeep-            $ useStack projectRoot-                `plusEff` useMultiCabal projectRoot replBuildDir-    pure-        $ cmd-            { targets =-                if not (null targets)-                    then-                        targets-                    else-                        Bare "all" : (getTestTarget <$> testTargets)-            }---useStack :: (FileSystem :> es, NonDet :> es) => ProjectRoot -> Eff es Command-useStack (ProjectRoot projectRoot) = do-    hasStack <- FileSystem.doesFileExist $ projectRoot </> "stack.yaml"-    if hasStack-        then-            pure $ Command Stack [] []-        else-            emptyEff---useMultiCabal :: (FileSystem :> es, NonDet :> es) => ProjectRoot -> FilePath -> Eff es Command-useMultiCabal (ProjectRoot projectRoot) replBuildDir = do-    hasCabalProject <- FileSystem.doesFileExist $ projectRoot </> "cabal.project"-    hasCabalFiles <- any (".cabal" `List.isSuffixOf`) <$> FileSystem.listDirectory projectRoot-    if hasCabalFiles || hasCabalProject-        then-            pure-                $ Command-                    { repl = Cabal-                    , arguments = ["--enable-multi-repl"] <> buildDirFlag replBuildDir-                    , targets = []-                    }-        else-            emptyEff---fallback :: FilePath -> Command-fallback replBuildDir =-    Command-        { repl = Cabal-        , arguments = buildDirFlag replBuildDir-        , targets = [Bare "all"]-        }---buildDirFlag :: FilePath -> [Text]-buildDirFlag replBuildDir = ["--builddir", toText replBuildDir]

@@ -0,0 +1,9 @@+module Tricorder.Session.Command.RenderedCommand (RenderedCommand (..)) where++import Tricorder.Session.Stage (Stage (..))+++-- | A fully rendered, ready-to-spawn shell command, tagged with the 'Stage'+-- it was rendered for.+newtype RenderedCommand (stage :: Stage) = RenderedCommand {getRenderedCommand :: Text}+    deriving (Eq, Show) via Text

@@ -0,0 +1,37 @@+module Tricorder.Session.CommandConfig (CommandConfig (..)) where++import Atelier.Types.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON, ToJSON)+import Data.Default (Default (..))++import Tricorder.Session.Stage (Stage)+++-- | Configuration shared by the @build@, @test@, and @eval@ sections: an+-- optional command template (falls back to Tricorder's automatically+-- resolved command per detected REPL kind when unset), an optional explicit+-- target list, and extra CLI arguments appended to that automatically+-- resolved command.+data CommandConfig (stage :: Stage) = CommandConfig+    { commandTemplate :: Maybe Text+    -- ^ User-provided template string to use for the shell command for the+    -- given stage. Takes priority over 'extraAutoArguments'. The exact+    -- template variable name depends on the stage the 'CommandConfig' is for.+    , targets :: Maybe [Text]+    -- ^ List of targets to run the stage against.+    , extraAutoArguments :: [Text]+    -- ^ Arguments to pass to the Tricorder-detected command for the given+    -- stage. Mutually exclusive with 'commandTemplate'. If both+    -- 'commandTemplate' and 'extraAutoArguments' are set, a warning is logged.+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via QuietSnake (CommandConfig stage)+++instance Default (CommandConfig stage) where+    def =+        CommandConfig+            { commandTemplate = Nothing+            , targets = Nothing+            , extraAutoArguments = []+            }

@@ -0,0 +1,123 @@+module Tricorder.Session.CommandTemplate+    ( CommandTemplate (..)+    , renderText+    , renderTargetsFor+    , hasPlaceholder+    , targetsPlaceholder+    , targetPlaceholder+    , show+    )+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.Target qualified as Target+++-- | A command string to be rendered with a provided list of targets.+data CommandTemplate (stage :: Stage) = CommandTemplate+    { repl :: Repl+    , template :: Text+    , arguments :: [Text]+    , placeholder :: Text+    -- ^ The bare placeholder name (without braces) 'template' may contain —+    -- see 'targetsPlaceholder' and 'targetPlaceholder'.+    }+    deriving stock (Eq, Generic, Show)+++-- | The @{targets}@ placeholder, used by @build@: one invocation covers+-- every target.+targetsPlaceholder :: Text+targetsPlaceholder = "targets"+++-- | The @{target}@ placeholder, used by @test@ and @eval@: one invocation+-- per target.+targetPlaceholder :: Text+targetPlaceholder = "target"+++instance Default (CommandTemplate 'Build) where+    def = CommandTemplate Unknown ("cabal repl {" <> targetsPlaceholder <> "}") [] targetsPlaceholder+++instance Default (CommandTemplate 'Test) where+    def = CommandTemplate Unknown ("cabal repl {" <> targetPlaceholder <> "}") [] targetPlaceholder+++instance Default (CommandTemplate 'Eval) where+    def = CommandTemplate Unknown ("cabal repl {" <> targetPlaceholder <> "}") [] targetPlaceholder+++-- | Substitute 'placeholder' in 'template' with the REPL-rendered target(s),+-- then append 'arguments'. Not exported — each phase renders differently (a+-- memory-limit flag for test), so use 'renderBuild'\/'renderTest'\/'renderEval'+-- instead, which return the phase-tagged+-- 'Tricorder.Session.Command.RenderedCommand.RenderedCommand'.+renderText :: CommandTemplate stage -> [Target] -> Text+renderText commandTemplate targets =+    T.unwords $ substituted <> commandTemplate.arguments+  where+    substituted =+        T.words+            $ substitutePlaceholder+                commandTemplate.placeholder+                (renderTargetsFor commandTemplate.repl targets)+                commandTemplate.template+++-- | Render targets the way each REPL kind expects on the command line.+-- Plain (single-package) @stack ghci@ only understands bare component+-- names, and needs deduplication since multiple targets can share one;+-- every other kind takes the fully qualified @[package:]kind:name@ form.+renderTargetsFor :: Repl -> [Target] -> [Text]+renderTargetsFor = \case+    Stack -> List.nub . fmap Target.componentName+    StackMulti -> List.nub . fmap Target.render+    Cabal -> fmap Target.render+    Unknown -> fmap Target.render+++-- | Substitute every unescaped @{<placeholderName>}@ in a template with the+-- (already REPL-rendered) target list, space-joined. @\\{<placeholderName>}@+-- escapes to a literal @{<placeholderName>}@, with no substitution.+substitutePlaceholder :: Text -> [Text] -> Text -> Text+substitutePlaceholder placeholderName renderedTargets =+    T.replace escapeSentinel bareholder+        . T.replace bareholder (T.unwords renderedTargets)+        . T.replace ("\\" <> bareholder) escapeSentinel+  where+    bareholder = "{" <> placeholderName <> "}"+    -- Must not itself contain the literal substring "{<placeholderName>}" —+    -- the unescaped-placeholder pass above would otherwise match inside it.+    escapeSentinel = "\NUL__escaped_" <> placeholderName <> "_placeholder__\NUL"+++-- | Whether a template contains @{<placeholderName>}@, escaped or not. Used+-- to warn when a @test@\/@eval@ @command_template@ omits it (see+-- 'Tricorder.Session.loadSession').+hasPlaceholder :: Text -> Text -> Bool+hasPlaceholder placeholderName template = ("{" <> placeholderName <> "}") `T.isInfixOf` template+++show :: CommandTemplate stage -> Text+show tmpl =+    T.intercalate+        "\n"+        [ "Template: " <> tmpl.template+        , "Repl: " <> P.show tmpl.repl+        , "Template placeholder: " <> P.show tmpl.placeholder+        , "Arguments:"+        , indent $ showList id tmpl.arguments+        ]

@@ -5,21 +5,34 @@ import Data.Aeson (FromJSON (..)) import Data.Default (Default (..)) +import Tricorder.Session.CommandConfig (CommandConfig) import Tricorder.Session.Hooks (Hooks)+import Tricorder.Session.Stage.Test.Config (TestConfig) +import Tricorder.Session.Stage qualified as Stage + data Config = Config-    { command :: Maybe Text-    , targets :: [Text]+    { build :: CommandConfig 'Stage.Build+    , test :: TestConfig+    , eval :: CommandConfig 'Stage.Eval     , watchDirs :: [FilePath]     , watchExclusionPatterns :: [Text]-    , testTargets :: Maybe [Text]     , replBuildDir :: FilePath     , testTimeout :: Int     , generateWithHpack :: Bool     , testMemoryLimit :: Maybe Text     , hooks :: Maybe Hooks     , idleTimeoutSeconds :: Int+    , command :: Maybe Text+    -- ^ DEPRECATED: use 'build'.'commandTemplate' instead.+    -- TODO: Remove at or after version 0.8.0.0.+    , targets :: [Text]+    -- ^ DEPRECATED: use 'build'.'targets' instead.+    -- TODO: Remove at or after version 0.8.0.0.+    , testTargets :: Maybe [Text]+    -- ^ DEPRECATED: use 'test'.'targets' instead.+    -- TODO: Remove at or after version 0.8.0.0.     }     deriving stock (Eq, Generic, Show)     deriving (FromJSON) via WithDefaults (QuietSnake Config)@@ -28,15 +41,18 @@ instance Default Config where     def =         Config-            { command = Nothing-            , targets = []+            { build = def+            , test = def+            , eval = def             , watchDirs = []             , watchExclusionPatterns = []-            , testTargets = Nothing             , replBuildDir = "dist-newstyle/tricorder"             , testTimeout = 10             , generateWithHpack = True             , testMemoryLimit = Nothing             , hooks = Nothing             , idleTimeoutSeconds = 300+            , command = Nothing+            , targets = []+            , testTargets = Nothing             }

@@ -0,0 +1,45 @@+module Tricorder.Session.Repl+    ( Repl (..)+    , resolveRepl+    )+where++import Atelier.Effects.FileSystem (FileSystem)+import Data.Yaml (decodeEither')+import Effectful.Exception (throwIO)+import System.FilePath ((</>))+import System.IO.Error (userError)++import Atelier.Effects.FileSystem qualified as FileSystem+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM++import Tricorder.Runtime (ProjectRoot (..))+++data Repl = StackMulti | Stack | Cabal | Unknown+    deriving stock (Eq, Generic, Show)+++-- | Resolve the project's REPL kind from the filesystem, independent of any+-- @build@\/@test@\/@eval@ command template — this decides both the+-- automatically resolved templates and how targets are rendered for all+-- three phases.+resolveRepl :: (FileSystem :> es) => ProjectRoot -> Eff es Repl+resolveRepl pr@(ProjectRoot projectRoot) = do+    hasStack <- FileSystem.doesFileExist $ projectRoot </> "stack.yaml"+    if hasStack+        then stackReplKind pr+        else pure Cabal+++stackReplKind :: (FileSystem :> es) => ProjectRoot -> Eff es Repl+stackReplKind (ProjectRoot projectRoot) = do+    stackYaml <- FileSystem.readFileBs $ projectRoot </> "stack.yaml"+    case decodeEither' stackYaml of+        Left err -> throwIO $ userError $ "Could not read and decode stack.yaml: " <> show err+        Right value -> pure $ case value of+            Aeson.Object km -> case KM.lookup "packages" km of+                Just (Aeson.Array arr) | length arr > 1 -> StackMulti+                _ -> Stack+            _ -> Stack

@@ -0,0 +1,70 @@+module Tricorder.Session.StackProject+    ( StackProject (..)+    , inputWithCache+    )+where++import Atelier.Effects.FileSystem (FileSystem)+import Atelier.Effects.Input (Input, runInputEff)+import Data.Aeson (FromJSON, ToJSON)+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Effectful.Concurrent.MVar.Strict (Concurrent)+import Effectful.Concurrent.STM+    ( TVar+    , atomically+    , newTVarIO+    , readTVar+    , writeTVar+    )+import Effectful.Exception (throwIO)+import Effectful.Reader.Static (Reader, ask)+import GHC.Generics (Generically (..))+import System.FilePath ((</>))+import System.IO.Error (userError)++import Atelier.Effects.FileSystem qualified as FileSystem+import Data.Yaml qualified as Yaml++import Tricorder.Runtime (ProjectRoot (..))+++newtype StackProject = StackProject+    { packages :: [FilePath]+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically StackProject+++inputWithCache+    :: ( Concurrent :> es+       , FileSystem :> es+       , Reader ProjectRoot :> es+       )+    => Eff (Input StackProject : es) a -> Eff es a+inputWithCache act = do+    cache :: TVar StackProject <- newTVarIO $ StackProject []+    lastModified :: TVar UTCTime <- newTVarIO $ posixSecondsToUTCTime 0+    flip runInputEff act do+        ProjectRoot projectRoot <- ask+        let stackYamlPath = projectRoot </> "stack.yaml"+        exists <- FileSystem.doesFileExist stackYamlPath+        if not exists+            then throwIO $ userError "stack.yaml does not exist"+            else do+                newLastMod <- FileSystem.getModificationTime stackYamlPath+                oldLastMod <- atomically $ readTVar lastModified+                if oldLastMod /= newLastMod+                    then do+                        contents <- FileSystem.readFileBs stackYamlPath+                        let result = Yaml.decodeEither' contents+                        case result of+                            Right x -> do+                                atomically do+                                    writeTVar cache x+                                    writeTVar lastModified newLastMod+                                pure x+                            Left err ->+                                throwIO $ userError $ "Could not parse stack.yaml: " <> show err+                    else+                        atomically $ readTVar cache

@@ -0,0 +1,4 @@+module Tricorder.Session.Stage (Stage (..)) where+++data Stage = Build | Test | Eval

@@ -0,0 +1,78 @@+module Tricorder.Session.Stage.Build.Command+    ( render+    , resolve+    )+where++import Atelier.Effects.FileSystem (FileSystem)+import System.FilePath ((</>))++import Atelier.Effects.FileSystem qualified as FileSystem+import Data.List qualified as List++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..), renderText, targetsPlaceholder)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl (..))+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Target (Target (..))+++-- | Render the @build@ command: every target goes into the one invocation+-- that covers all of them.+render :: CommandTemplate 'Build -> [Target] -> RenderedCommand 'Build+render commandTemplate targets = RenderedCommand $ renderText commandTemplate targets+++resolve+    :: (FileSystem :> es)+    => ProjectRoot+    -> Config+    -> Repl+    -> [Target]+    -> Eff es (CommandTemplate 'Build, [Target])+resolve projectRoot cfg repl effectiveTargets = do+    template <- case customTemplate of+        Just tpl -> pure tpl+        Nothing -> defaultBuildTemplate projectRoot repl cfg.replBuildDir+    pure+        ( CommandTemplate+            { repl+            , template+            , arguments = maybe cfg.build.extraAutoArguments (const []) customTemplate+            , placeholder = targetsPlaceholder+            }+        , if not (null effectiveTargets)+            then effectiveTargets+            else [Bare "all"]+        )+  where+    customTemplate = cfg.build.commandTemplate <|> cfg.command+++-- | Whether the project has a @cabal.project@ or any @*.cabal@ file. Used+-- only to pick the automatically resolved template's flags — it has no+-- bearing on 'Repl', which is 'Cabal' either way.+isCabalProject :: (FileSystem :> es) => ProjectRoot -> Eff es Bool+isCabalProject (ProjectRoot projectRoot) = do+    hasCabalProject <- FileSystem.doesFileExist $ projectRoot </> "cabal.project"+    hasCabalFiles <- any (".cabal" `List.isSuffixOf`) <$> FileSystem.listDirectory projectRoot+    pure $ hasCabalProject || hasCabalFiles+++-- | Tricorder's automatically resolved @build@ template for a resolved+-- 'Repl'. Cabal projects additionally probe the filesystem to decide whether+-- @--enable-multi-repl@ applies.+defaultBuildTemplate :: (FileSystem :> es) => ProjectRoot -> Repl -> FilePath -> Eff es Text+defaultBuildTemplate projectRoot repl replBuildDir = case repl of+    Stack -> pure "stack ghci {targets}"+    StackMulti -> pure "stack ghci {targets}"+    Unknown -> pure "cabal repl {targets}"+    Cabal -> do+        isProject <- isCabalProject projectRoot+        pure+            $ if isProject+                then "cabal repl --enable-multi-repl --builddir " <> toText replBuildDir <> " {targets}"+                else "cabal repl --builddir " <> toText replBuildDir <> " {targets}"

@@ -0,0 +1,66 @@+module Tricorder.Session.Stage.Build.Session+    ( BuildSession (..)+    , resolve+    , show+    )+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++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.CabalFile (CabalFile)+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl)+import Tricorder.Session.Target (Target)+import Tricorder.Session.Util (indent, showList)++import Tricorder.Session.CommandTemplate qualified as CommandTemplate+import Tricorder.Session.Stage qualified as Stage+import Tricorder.Session.Stage.Build.Command qualified as BuildCommand+import Tricorder.Session.Target qualified as Target+++data BuildSession = BuildSession+    { commandTemplate :: CommandTemplate 'Stage.Build+    , targets :: [Target]+    }+    deriving stock (Eq)+++instance Default BuildSession where+    def = BuildSession def []+++resolve+    :: (FileSystem :> es, Reader ProjectRoot :> es)+    => Config -> Repl -> [CabalFile] -> Eff es BuildSession+resolve config repl projectFiles = do+    projectRoot <- Reader.ask+    (commandTemplate, targets) <- BuildCommand.resolve projectRoot config repl effectiveTargets+    pure+        $ BuildSession+            { commandTemplate+            , targets+            }+  where+    rawBuildTargets = fromMaybe config.targets config.build.targets+    effectiveTargets = Target.resolve projectFiles rawBuildTargets+++show :: BuildSession -> Text+show cfg =+    T.intercalate+        "\n"+        [ "Command template:"+        , indent $ CommandTemplate.show cfg.commandTemplate+        , "Targets:"+        , indent $ showList Target.render cfg.targets+        ]

@@ -0,0 +1,34 @@+module Tricorder.Session.Stage.Eval.Command+    ( render+    , resolve+    )+where++import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..), renderText, targetPlaceholder)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl)+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Stage.Test.Session (defaultTestTemplate)+import Tricorder.Session.Target (Target)+++-- | Render the @eval@ command for a single source file's short-lived+-- session: the module being evaluated is substituted as the one target.+render :: CommandTemplate 'Eval -> [Target] -> RenderedCommand 'Eval+render commandTemplate targets = RenderedCommand $ renderText commandTemplate targets+++resolve :: Repl -> Config -> CommandTemplate 'Eval+resolve repl cfg =+    CommandTemplate+        { repl+        , template = fromMaybe (defaultEvalTemplate repl) cfg.eval.commandTemplate+        , arguments = maybe cfg.eval.extraAutoArguments (const []) cfg.eval.commandTemplate+        , placeholder = targetPlaceholder+        }+++defaultEvalTemplate :: Repl -> Text+defaultEvalTemplate = defaultTestTemplate

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

@@ -0,0 +1,60 @@+module Tricorder.Session.Stage.Test.Command+    ( RenderedTestCommand (..)+    , render+    )+where++import Tricorder.Build.ByteSize (ByteSize)+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..))+import Tricorder.Session.Repl (Repl (..))+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Stage.Test.Session (ResolvedTestOptions (..), TestSession (..))+import Tricorder.Session.TestTarget (TestTarget (..))++import Tricorder.Build.ByteSize qualified as ByteSize+import Tricorder.Session.CommandTemplate qualified as CommandTemplate+++data RenderedTestCommand = RenderedTestCommand+    { command :: RenderedCommand 'Test+    , options :: ResolvedTestOptions+    }+++render :: TestSession -> Maybe ByteSize -> TestTarget -> RenderedTestCommand+render testSession mMemoryLimit target =+    RenderedTestCommand+        { command =+            RenderedCommand+                $ CommandTemplate.renderText+                    testSession.commandTemplate {arguments = testSession.commandTemplate.arguments <> memoryLimitArg}+                    [getTestTarget target]+        , options = testSession.options+        }+  where+    memoryLimitArg =+        maybe+            []+            ( \limit ->+                let+                    stack =+                        [ "--ghc-options"+                        , "+RTS -M"+                            <> ByteSize.toRTSSize limit+                            <> " -RTS"+                        ]+                    cabal =+                        [ "--repl-options"+                        , "+RTS -M"+                            <> ByteSize.toRTSSize limit+                            <> " -RTS"+                        ]+                in+                    case testSession.commandTemplate.repl of+                        Stack -> stack+                        StackMulti -> stack+                        Cabal -> cabal+                        Unknown -> cabal+            )+            mMemoryLimit

@@ -0,0 +1,60 @@+module Tricorder.Session.Stage.Test.Config+    ( TestConfig (..)+    , Options (..)+    , OutputMode (..)+    )+where++import Atelier.Types.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON (..), ToJSON, Value (..))+import Data.Aeson.Types (ToJSON (..))+import Data.Default (Default (..))+import GHC.Generics (Generically (..))++import Tricorder.Session.CommandConfig (CommandConfig)++import Tricorder.Session.Stage qualified as Stage+++data TestConfig = TestConfig+    { commandConfig :: CommandConfig 'Stage.Test+    , options :: Options+    }+    deriving stock (Eq, Generic, Show)+++instance Default TestConfig where+    def =+        TestConfig+            { commandConfig = def+            , options = def+            }+++instance ToJSON TestConfig where+    toJSON cfg = case (toJSON cfg.commandConfig, toJSON cfg.options) of+        (Object a, Object b) -> Object (a <> b)+        (a, _) -> a+++instance FromJSON TestConfig where+    parseJSON v = TestConfig <$> parseJSON v <*> parseJSON v+++newtype Options = Options+    { outputMode :: Maybe OutputMode+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via QuietSnake Options+++instance Default Options where+    def =+        Options+            { outputMode = Nothing+            }+++data OutputMode = ReplOutput | StdoutOutput+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON, ToJSON) via Generically OutputMode

@@ -0,0 +1,111 @@+module Tricorder.Session.Stage.Test.Session+    ( TestSession (..)+    , ResolvedTestOptions (..)+    , resolve+    , defaultTestTemplate+    , show+    )+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)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl (..))+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.CommandTemplate qualified as CommandTemplate+import Tricorder.Session.Stage qualified as Stage+import Tricorder.Session.TestTarget qualified as TestTarget+++data TestSession = TestSession+    { commandTemplate :: CommandTemplate 'Stage.Test+    , targets :: [TestTarget]+    , options :: ResolvedTestOptions+    }+    deriving stock (Eq)+++instance Default TestSession where+    def =+        TestSession+            { commandTemplate = def+            , targets = []+            , options = def+            }+++data ResolvedTestOptions = ResolvedTestOptions+    { outputMode :: OutputMode+    }+    deriving stock (Eq)+++instance Default ResolvedTestOptions where+    def = ResolvedTestOptions ReplOutput+++resolve :: Repl -> [Target] -> Config -> TestSession+resolve repl buildTargets cfg =+    TestSession+        { commandTemplate =+            CommandTemplate+                { repl+                , template+                , arguments =+                    maybe+                        cfg.test.commandConfig.extraAutoArguments+                        (const [])+                        cfg.test.commandConfig.commandTemplate+                , placeholder = targetPlaceholder+                }+        , targets = TestTarget.resolve cfg buildTargets+        , options =+            ResolvedTestOptions+                { outputMode = fromMaybe detectedOutputMode cfg.test.options.outputMode+                }+        }+  where+    template = fromMaybe (defaultTestTemplate repl) cfg.test.commandConfig.commandTemplate+    detectedOutputMode+        | "stack repl" `T.isPrefixOf` template+            || "stack ghci" `T.isPrefixOf` template+            || "cabal repl" `T.isPrefixOf` template =+            ReplOutput+        | otherwise = StdoutOutput+++defaultTestTemplate :: Repl -> Text+defaultTestTemplate = \case+    Stack -> "stack ghci {target}"+    StackMulti -> "stack ghci {target}"+    Cabal -> "cabal repl {target}"+    Unknown -> "cabal repl {target}"+++show :: TestSession -> Text+show cfg =+    T.intercalate+        "\n"+        [ "Command template:"+        , indent $ CommandTemplate.show cfg.commandTemplate+        , "Test targets:"+        , indent $ showList TestTarget.render cfg.targets+        , "Options:"+        , indent $ showTestOptions cfg.options+        ]+  where+    showTestOptions opts =+        T.intercalate+            "\n"+            [ "Output mode: " <> P.show opts.outputMode+            ]

@@ -1,12 +1,12 @@ module Tricorder.Session.Target     ( Target (..)     , ComponentKind (..)-    , parseTarget-    , renderTarget+    , parse+    , render+    , resolve+    , compare     , componentName-    , resolveTargets     , definesCustomPrelude-    , compareTargets     , allComponentTargets     ) where@@ -29,9 +29,11 @@ import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnqualComponentName (mkUnqualComponentName, unUnqualComponentName)+import Prelude hiding (compare)  import Data.Text qualified as T import Distribution.Types.BuildInfo.Lens qualified as Lens+import Prelude qualified as P  import Tricorder.Session.CabalFile (CabalFile (..)) @@ -55,11 +57,11 @@   instance ToJSON Target where-    toJSON = toJSON . renderTarget+    toJSON = toJSON . render   instance FromJSON Target where-    parseJSON = fmap parseTarget . parseJSON+    parseJSON = fmap parse . parseJSON   instance ToJSONKey Target@@ -93,29 +95,29 @@     Bench -> "bench"  --- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two--- never drift apart [ref:kind_prefix_sole_source].-parseKind :: Text -> Maybe ComponentKind-parseKind = inverseMap kindPrefix-- -- | Classify a target's textual form. The grammar is @[kind:]name@ where -- @kind@ is one of @lib@, @flib@, @exe@, @test@, or @bench@; anything else (an -- unknown kind, a cabal alias such as @executable@, or extra colons) is -- 'Unrecognized'.-parseTarget :: Text -> Target-parseTarget target = case T.splitOn ":" target of+parse :: Text -> Target+parse target = case T.splitOn ":" target of     [packageName, prefix, name] | Just kind <- parseKind prefix -> PackageQualified packageName kind name     [prefix, name] | Just kind <- parseKind prefix -> Qualified kind name     [name] -> Bare name     _ -> Unrecognized target  +-- | Parse a kind prefix, derived as the inverse of 'kindPrefix' so the two+-- never drift apart [ref:kind_prefix_sole_source].+parseKind :: Text -> Maybe ComponentKind+parseKind = inverseMap kindPrefix++ -- | Render a 'Target' back to the textual form cabal understands. Inverse of -- 'parseTarget' (lossless: @parseTarget . renderTarget == id@). Builds prefixes -- via 'kindPrefix' rather than hardcoding them [ref:kind_prefix_sole_source].-renderTarget :: Target -> Text-renderTarget = \case+render :: Target -> Text+render = \case     Qualified kind name -> kindPrefix kind <> ":" <> name     PackageQualified packageName kind name -> packageName <> ":" <> kindPrefix kind <> ":" <> name     Bare name -> name@@ -134,14 +136,14 @@ -- raw target strings (from config) are parsed into structured 'Target's: the -- configured targets are parsed as-is, or all components across every -- discovered package are auto-detected when no targets are configured. Either--- way the result is sorted with 'compareTargets' so libraries exposing a custom+-- way the result is sorted with 'compare' so libraries exposing a custom -- @Prelude@ come last [ref:lib_sort_order].-resolveTargets :: [CabalFile] -> [Text] -> [Target]-resolveTargets cabalFiles = \case-    targets@(_ : _) -> sortTargets $ parseTarget <$> targets+resolve :: [CabalFile] -> [Text] -> [Target]+resolve cabalFiles = \case+    targets@(_ : _) -> sortTargets $ parse <$> targets     [] -> sortTargets $ foldMap (allComponentTargets . (.projectPackageDescription)) cabalFiles   where-    sortTargets = sortBy (compareTargets (definesCustomPrelude cabalFiles))+    sortTargets = sortBy (compare (definesCustomPrelude cabalFiles))   -- | [tag:lib_sort_order] When running @cabal repl <package defining custom@@ -154,16 +156,16 @@ -- 'definesCustomPrelude': only those that expose a @Prelude@ module are sorted -- last. This is more precise than sorting every @lib:@ target last — only the -- libraries that actually cause the failure are reordered.-compareTargets :: (Target -> Bool) -> Target -> Target -> Ordering-compareTargets definesPrelude a b+compare :: (Target -> Bool) -> Target -> Target -> Ordering+compare definesPrelude a b     | definesPrelude a && not (definesPrelude b) = GT     | not (definesPrelude a) && definesPrelude b = LT-    | otherwise = compare (renderTarget a) (renderTarget b)+    | otherwise = P.compare (render a) (render b)   -- | Check whether any of the discovered packages' libraries expose a @Prelude@ -- module for the given target. Used to build the predicate passed to--- 'compareTargets' so that only the libraries that actually cause the GHCi+-- 'compare' so that only the libraries that actually cause the GHCi -- startup failure are sorted last [ref:lib_sort_order]. definesCustomPrelude :: [CabalFile] -> Target -> Bool definesCustomPrelude cabalFiles target = any check cabalFiles

@@ -1,50 +1,56 @@ module Tricorder.Session.TestTarget     ( TestTarget (..)-    , renderTestTarget-    , parseTestTargets-    , resolveTestTargets-    , projectTestTargets+    , render+    , parse+    , resolve+    , project     ) where  import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey) +import Tricorder.Session.CommandConfig (CommandConfig (..)) import Tricorder.Session.Config (Config (..))-import Tricorder.Session.Target (ComponentKind (..), Target (..), parseTarget, renderTarget)+import Tricorder.Session.Stage.Test.Config (TestConfig (..))+import Tricorder.Session.Target (ComponentKind (..), Target (..)) +import Tricorder.Session.Target qualified as Target + newtype TestTarget = TestTarget {getTestTarget :: Target}     deriving stock (Eq, Generic, Ord, Show)     deriving (FromJSON, ToJSON) via Target     deriving (FromJSONKey, ToJSONKey) via Target  -renderTestTarget :: TestTarget -> Text-renderTestTarget = renderTarget . getTestTarget+render :: TestTarget -> Text+render = Target.render . getTestTarget   -- | Parse raw target strings (e.g. the @test_targets@ config) and project them -- onto their test suites — non-test entries are dropped.-parseTestTargets :: [Text] -> [TestTarget]-parseTestTargets = projectTestTargets . map parseTarget+parse :: [Text] -> [TestTarget]+parse = project . map Target.parse   -- | [tag:test_targets_invariant] Project a target list onto its test suites — -- the only way to build a 'TestTargets', so the @test:@-only invariant holds by -- construction.-projectTestTargets :: [Target] -> [TestTarget]-projectTestTargets = mapMaybe mkTestTarget+project :: [Target] -> [TestTarget]+project = mapMaybe mk   where-    mkTestTarget tgt@(Qualified Test _) = Just $ TestTarget tgt-    mkTestTarget tgt@(PackageQualified _ Test _) = Just $ TestTarget tgt-    mkTestTarget _ = Nothing+    mk tgt@(Qualified Test _) = Just $ TestTarget tgt+    mk tgt@(PackageQualified _ Test _) = Just $ TestTarget tgt+    mk _ = Nothing  --- | Resolve which test suites to run after a clean build. Either source — the--- explicit @test_targets@ config or the build 'targets' — is projected onto its--- @test:@ components (see 'projectTestTargets'), so non-test entries are--- dropped and the result only ever names test suites [ref:test_targets_invariant].-resolveTestTargets :: Config -> [Target] -> [TestTarget]-resolveTestTargets cfg targets = case cfg.testTargets of-    Just explicit -> parseTestTargets explicit-    Nothing -> projectTestTargets targets+-- | Resolve which test suites to run after a clean build. The explicit+-- source — @test.targets@, falling back to the deprecated top-level+-- @test_targets@ — is projected onto its @test:@ components (see+-- 'projectTestTargets'), so non-test entries are dropped and the result only+-- ever names test suites [ref:test_targets_invariant]. With neither source+-- set, falls back to deriving test targets from the build 'targets'.+resolve :: Config -> [Target] -> [TestTarget]+resolve cfg targets = case cfg.test.commandConfig.targets <|> cfg.testTargets of+    Just explicit -> parse explicit+    Nothing -> project targets

@@ -0,0 +1,17 @@+module Tricorder.Session.Util+    ( showList+    , indent+    )+where++import Data.Text qualified as T+++showList :: (a -> Text) -> [a] -> Text+showList f xs+    | null xs = "<empty list>"+    | otherwise = T.intercalate "\n" $ (("- " <>) . f) <$> xs+++indent :: Text -> Text+indent = T.unlines . fmap ("  " <>) . T.lines

@@ -1,6 +1,6 @@ module Tricorder.Session.WatchDirs     ( WatchDirs (..)-    , resolveWatchDirs+    , resolve     , sourceDirsForTarget     ) where@@ -51,8 +51,8 @@ -- 1. @watch_dirs@ from config, if non-empty (used as-is relative to project root) -- 2. @hs-source-dirs@ inferred from cabal targets, if targets are set -- 3. Falls back to @["."]@ (project root) if neither is available-resolveWatchDirs :: ProjectRoot -> [CabalFile] -> Config -> [Target] -> WatchDirs-resolveWatchDirs projectRoot projectFiles cfg targets =+resolve :: ProjectRoot -> [CabalFile] -> Config -> [Target] -> WatchDirs+resolve projectRoot projectFiles cfg targets =     case cfg.watchDirs of         dirs@(_ : _) -> WatchDirs $ map (coerce projectRoot </>) dirs         [] -> resolveWatchDirsFromTargets projectFiles targets

@@ -18,7 +18,6 @@ import Effectful.State.Static.Shared qualified as State  import Tricorder.Build (BuildId, BuildPhase, BuildState (..), Diagnostic)-import Tricorder.Daemon.DaemonInfo (DaemonInfo) import Tricorder.Daemon.IdleTimer (IdleTimer) import Tricorder.Runtime (SocketPath (..)) import Tricorder.Socket.Protocol@@ -57,7 +56,6 @@        , Exit :> es        , IdleTimer :> es        , Input BuildId :> es-       , Input DaemonInfo :> es        , Log :> es        , Reader SocketPath :> es        , Sub BuildPhase :> es@@ -78,7 +76,6 @@        , Exit :> es        , IdleTimer :> es        , Input BuildId :> es-       , Input DaemonInfo :> es        , Log :> es        , Reader SocketPath :> es        , State BuildPhase :> es@@ -101,7 +98,6 @@        , Exit :> es        , IdleTimer :> es        , Input BuildId :> es-       , Input DaemonInfo :> es        , Log :> es        , State BuildPhase :> es        , Sub BuildPhase :> es@@ -127,7 +123,6 @@     :: ( Conc :> es        , Exit :> es        , Input BuildId :> es-       , Input DaemonInfo :> es        , Log :> es        , State BuildPhase :> es        , Sub BuildPhase :> es@@ -164,7 +159,6 @@  respondOnce     :: ( Input BuildId :> es-       , Input DaemonInfo :> es        , State BuildPhase :> es        , UnixSocket :> es        )@@ -177,7 +171,6 @@ respondWhenDone     :: ( Conc :> es        , Input BuildId :> es-       , Input DaemonInfo :> es        , State BuildPhase :> es        , Sub BuildPhase :> es        , UnixSocket :> es@@ -202,7 +195,6 @@ -- | Stream a JSON object after each state change event. watchStream     :: ( Input BuildId :> es-       , Input DaemonInfo :> es        , State BuildPhase :> es        , Sub BuildPhase :> es        , UnixSocket :> es@@ -240,8 +232,7 @@ sendJson h val = sendLine h (decodeUtf8 (BSL.toStrict (encode val)))  -mkBuildState :: (Input BuildId :> es, Input DaemonInfo :> es) => BuildPhase -> Eff es BuildState+mkBuildState :: (Input BuildId :> es) => BuildPhase -> Eff es BuildState mkBuildState phase = do-    daemonInfo <- input     buildId <- input-    pure $ BuildState {daemonInfo, buildId, phase}+    pure $ BuildState {buildId, phase}

@@ -14,7 +14,7 @@  import Atelier.Effects.Log qualified as Log -import Tricorder.Session.Command (Repl)+import Tricorder.Session.Repl (Repl) import Tricorder.SourceLookup.GhcPkg (GhcPkg) import Tricorder.SourceLookup.Hackage (Hackage) import Tricorder.SourceLookup.PackageId (PackageId (..))

@@ -16,7 +16,7 @@  import Data.Text qualified as T -import Tricorder.Session.Command (Repl (..))+import Tricorder.Session.Repl (Repl (..)) import Tricorder.SourceLookup.PackageId (PackageId (..))  

@@ -1,2 +1,2 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} 

@@ -1,73 +1,61 @@-module Unit.Tricorder.Build.ByteSizeSpec (spec_ByteSize) where+module Unit.Tricorder.Build.ByteSizeSpec (test_ByteSize) where -import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))  import Tricorder.Build.ByteSize (ByteSize (..), Unit (..))  import Tricorder.Build.ByteSize qualified as ByteSize  -spec_ByteSize :: Spec-spec_ByteSize = describe "fromText" testFromText+test_ByteSize :: TestTree+test_ByteSize =+    testGroup+        "ByteSize"+        [ testGroup "fromText" testFromText+        ]  -testFromText :: Spec-testFromText = do-    it "parses no unit as bytes" do-        ByteSize.fromText "1000" `shouldBe` Just (ByteSize 1000 B)--    it "parses bytes with unit" do-        ByteSize.fromText "1000B" `shouldBe` Just (ByteSize 1000 B)--    it "parses decimal kilobytes" do-        ByteSize.fromText "10kb" `shouldBe` Just (ByteSize 10 KB)--    it "parses binary kibibytes" do-        ByteSize.fromText "10kib" `shouldBe` Just (ByteSize 10 KiB)--    it "parses decimal megabytes" do-        ByteSize.fromText "1mb" `shouldBe` Just (ByteSize 1 MB)--    it "parses binary mebibytes" do-        ByteSize.fromText "1mib" `shouldBe` Just (ByteSize 1 MiB)--    it "parses decimal gigabytes" do-        ByteSize.fromText "1gb" `shouldBe` Just (ByteSize 1 GB)--    it "parses binary gibibytes" do-        ByteSize.fromText "1gib" `shouldBe` Just (ByteSize 1 GiB)--    it "parses decimal terabytes" do-        ByteSize.fromText "1tb" `shouldBe` Just (ByteSize 1 TB)--    it "parses binary tebibytes" do-        ByteSize.fromText "1tib" `shouldBe` Just (ByteSize 1 TiB)--    it "parses decimal petabytes" do-        ByteSize.fromText "1pb" `shouldBe` Just (ByteSize 1 PB)--    it "parses binary pebibytes" do-        ByteSize.fromText "1pib" `shouldBe` Just (ByteSize 1 PiB)--    it "allows a space between the number and the unit" do-        ByteSize.fromText "10 kb" `shouldBe` Just (ByteSize 10 KB)--    it "allows multiple spaces between the number and the unit" do-        ByteSize.fromText "10   kb" `shouldBe` Just (ByteSize 10 KB)--    it "is case-insensitive on the unit" do-        ByteSize.fromText "10KB" `shouldBe` Just (ByteSize 10 KB)-        ByteSize.fromText "10Kb" `shouldBe` Just (ByteSize 10 KB)-        ByteSize.fromText "10KiB" `shouldBe` Just (ByteSize 10 KiB)--    it "fails when there is no number" do-        ByteSize.fromText "kb" `shouldBe` Nothing--    it "fails on an unrecognized unit" do-        ByteSize.fromText "10xb" `shouldBe` Nothing--    it "fails on empty text" do-        ByteSize.fromText "" `shouldBe` Nothing--    it "fails on unrelated text" do-        ByteSize.fromText "hello world" `shouldBe` Nothing+testFromText :: [TestTree]+testFromText =+    [ testCase "parses no unit as bytes" do+        ByteSize.fromText "1000" @?= Just (ByteSize 1000 B)+    , testCase "parses bytes with unit" do+        ByteSize.fromText "1000B" @?= Just (ByteSize 1000 B)+    , testCase "parses decimal kilobytes" do+        ByteSize.fromText "10kb" @?= Just (ByteSize 10 KB)+    , testCase "parses binary kibibytes" do+        ByteSize.fromText "10kib" @?= Just (ByteSize 10 KiB)+    , testCase "parses decimal megabytes" do+        ByteSize.fromText "1mb" @?= Just (ByteSize 1 MB)+    , testCase "parses binary mebibytes" do+        ByteSize.fromText "1mib" @?= Just (ByteSize 1 MiB)+    , testCase "parses decimal gigabytes" do+        ByteSize.fromText "1gb" @?= Just (ByteSize 1 GB)+    , testCase "parses binary gibibytes" do+        ByteSize.fromText "1gib" @?= Just (ByteSize 1 GiB)+    , testCase "parses decimal terabytes" do+        ByteSize.fromText "1tb" @?= Just (ByteSize 1 TB)+    , testCase "parses binary tebibytes" do+        ByteSize.fromText "1tib" @?= Just (ByteSize 1 TiB)+    , testCase "parses decimal petabytes" do+        ByteSize.fromText "1pb" @?= Just (ByteSize 1 PB)+    , testCase "parses binary pebibytes" do+        ByteSize.fromText "1pib" @?= Just (ByteSize 1 PiB)+    , testCase "allows a space between the number and the unit" do+        ByteSize.fromText "10 kb" @?= Just (ByteSize 10 KB)+    , testCase "allows multiple spaces between the number and the unit" do+        ByteSize.fromText "10   kb" @?= Just (ByteSize 10 KB)+    , testCase "is case-insensitive on the unit" do+        ByteSize.fromText "10KB" @?= Just (ByteSize 10 KB)+        ByteSize.fromText "10Kb" @?= Just (ByteSize 10 KB)+        ByteSize.fromText "10KiB" @?= Just (ByteSize 10 KiB)+    , testCase "fails when there is no number" do+        ByteSize.fromText "kb" @?= Nothing+    , testCase "fails on an unrecognized unit" do+        ByteSize.fromText "10xb" @?= Nothing+    , testCase "fails on empty text" do+        ByteSize.fromText "" @?= Nothing+    , testCase "fails on unrelated text" do+        ByteSize.fromText "hello world" @?= Nothing+    ]

@@ -1,177 +1,153 @@-module Unit.Tricorder.Build.EvalCommentSpec (spec_EvalComment) where+module Unit.Tricorder.Build.EvalCommentSpec (test_EvalComment) where -import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import Text.Megaparsec (parse)  import Tricorder.Build.EvalComment qualified as Eval  -spec_EvalComment :: Spec-spec_EvalComment = do-    describe "singleLineEvalCommentP" testSingleLine-    describe "multiLineEvalCommentP" testMultiLine-    describe "blockCommentEvalP" testBlockComment-    describe "findComments" testFindComments+test_EvalComment :: TestTree+test_EvalComment =+    testGroup+        "EvalComment"+        [ testGroup "singleLineEvalCommentP" testSingleLine+        , testGroup "multiLineEvalCommentP" testMultiLine+        , testGroup "blockCommentEvalP" testBlockComment+        , testGroup "findComments" testFindComments+        ]   -------------------------------------------------------------------------------- -- singleLineEvalCommentP -------------------------------------------------------------------------------- -testSingleLine :: Spec-testSingleLine = do-    it "parses a basic expression" do+testSingleLine :: [TestTree]+testSingleLine =+    [ testCase "parses a basic expression" do         parse Eval.singleLineEvalCommentP "" "-- $> 1 + 2"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "1 + 2"}--    it "handles no space between marker and expression" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "1 + 2"}+    , testCase "handles no space between marker and expression" do         parse Eval.singleLineEvalCommentP "" "-- $>expr"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}--    it "strips leading whitespace from the expression" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "expr"}+    , testCase "strips leading whitespace from the expression" do         parse Eval.singleLineEvalCommentP "" "-- $>   expr"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}--    it "captures the full expression including inner spaces" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "expr"}+    , testCase "captures the full expression including inner spaces" do         parse Eval.singleLineEvalCommentP "" "-- $> foo bar baz"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "foo bar baz"}--    it "stops at a newline, not consuming it" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "foo bar baz"}+    , testCase "stops at a newline, not consuming it" do         parse Eval.singleLineEvalCommentP "" "-- $> expr\nnext line"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}--    it "fails when there is no expression after the marker" do-        parse Eval.singleLineEvalCommentP "" "-- $>" `shouldSatisfy` isLeft--    it "fails on the multi-line opening marker" do-        parse Eval.singleLineEvalCommentP "" "-- $$> expr -- <$$" `shouldSatisfy` isLeft--    it "fails on other text between comment start and eval marker" do-        parse Eval.singleLineEvalCommentP "" "-- foo $> 1 + 2" `shouldSatisfy` isLeft--    it "fails on unrelated text" do-        parse Eval.singleLineEvalCommentP "" "hello world" `shouldSatisfy` isLeft+            @?= Right Eval.Comment {lineNumber = 1, expression = "expr"}+    , testCase "fails when there is no expression after the marker" do+        assertBool "expected Left" $ isLeft (parse Eval.singleLineEvalCommentP "" "-- $>")+    , testCase "fails on the multi-line opening marker" do+        assertBool "expected Left" $ isLeft (parse Eval.singleLineEvalCommentP "" "-- $$> expr -- <$$")+    , testCase "fails on other text between comment start and eval marker" do+        assertBool "expected Left" $ isLeft (parse Eval.singleLineEvalCommentP "" "-- foo $> 1 + 2")+    , testCase "fails on unrelated text" do+        assertBool "expected Left" $ isLeft (parse Eval.singleLineEvalCommentP "" "hello world")+    ]   -------------------------------------------------------------------------------- -- multiLineEvalCommentP -------------------------------------------------------------------------------- -testMultiLine :: Spec-testMultiLine = do-    it "parses a single content line, stripping the -- prefix" do+testMultiLine :: [TestTree]+testMultiLine =+    [ testCase "parses a single content line, stripping the -- prefix" do         parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr\n-- <$$"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}--    it "parses multiple content lines, stripping -- prefixes" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "expr"}+    , testCase "parses multiple content lines, stripping -- prefixes" do         parse Eval.multiLineEvalCommentP "" "-- $$>\n-- foo\n-- bar\n-- <$$"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "foo\nbar"}--    it "preserves relative indentation after stripping -- prefix" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "foo\nbar"}+    , testCase "preserves relative indentation after stripping -- prefix" do         parse Eval.multiLineEvalCommentP "" "-- $$>\n-- let x = 1\n--     y = 2\n-- in x + y\n-- <$$"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n    y = 2\nin x + y"}--    it "handles -- with no trailing space" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n    y = 2\nin x + y"}+    , testCase "handles -- with no trailing space" do         parse Eval.multiLineEvalCommentP "" "-- $$>\n--expr\n-- <$$"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}--    it "parse multi-line eval comment in a single line" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "expr"}+    , testCase "parse multi-line eval comment in a single line" do         parse Eval.multiLineEvalCommentP "" "-- $$> expr <$$"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "expr"}--    it "fails when the closing marker is absent" do-        parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr" `shouldSatisfy` isLeft--    it "fails on the single-line marker" do-        parse Eval.multiLineEvalCommentP "" "-- $> expr" `shouldSatisfy` isLeft--    it "fails on unrelated text" do-        parse Eval.multiLineEvalCommentP "" "hello world" `shouldSatisfy` isLeft+            @?= Right Eval.Comment {lineNumber = 1, expression = "expr"}+    , testCase "fails when the closing marker is absent" do+        assertBool "expected Left" $ isLeft (parse Eval.multiLineEvalCommentP "" "-- $$>\n-- expr")+    , testCase "fails on the single-line marker" do+        assertBool "expected Left" $ isLeft (parse Eval.multiLineEvalCommentP "" "-- $> expr")+    , testCase "fails on unrelated text" do+        assertBool "expected Left" $ isLeft (parse Eval.multiLineEvalCommentP "" "hello world")+    ]   -------------------------------------------------------------------------------- -- blockCommentEvalP -------------------------------------------------------------------------------- -testBlockComment :: Spec-testBlockComment = do-    it "parses a single-line expression on its own line" do+testBlockComment :: [TestTree]+testBlockComment =+    [ testCase "parses a single-line expression on its own line" do         parse Eval.blockCommentEvalP "" "{- $$>\n2 + 2\n<$$ -}"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "2 + 2"}--    it "parses an inline one-liner" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "2 + 2"}+    , testCase "parses an inline one-liner" do         parse Eval.blockCommentEvalP "" "{- $$> 2 + 2 <$$ -}"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "2 + 2"}--    it "parses a multi-line expression preserving layout" do+            @?= Right Eval.Comment {lineNumber = 1, expression = "2 + 2"}+    , testCase "parses a multi-line expression preserving layout" do         parse Eval.blockCommentEvalP "" "{- $$>\nlet x = 1\n    y = 2\nin x + y\n<$$ -}"-            `shouldBe` Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n    y = 2\nin x + y"}--    it "fails when the closing marker is absent" do-        parse Eval.blockCommentEvalP "" "{- $$>\nexpr" `shouldSatisfy` isLeft--    it "fails on the line-comment multi-line eval marker" do-        parse Eval.blockCommentEvalP "" "-- $$> expr" `shouldSatisfy` isLeft--    it "fails on the single-line eval marker" do-        parse Eval.blockCommentEvalP "" "{- $> expr -}" `shouldSatisfy` isLeft--    it "fails on unrelated text" do-        parse Eval.blockCommentEvalP "" "hello world" `shouldSatisfy` isLeft+            @?= Right Eval.Comment {lineNumber = 1, expression = "let x = 1\n    y = 2\nin x + y"}+    , testCase "fails when the closing marker is absent" do+        assertBool "expected Left" $ isLeft (parse Eval.blockCommentEvalP "" "{- $$>\nexpr")+    , testCase "fails on the line-comment multi-line eval marker" do+        assertBool "expected Left" $ isLeft (parse Eval.blockCommentEvalP "" "-- $$> expr")+    , testCase "fails on the single-line eval marker" do+        assertBool "expected Left" $ isLeft (parse Eval.blockCommentEvalP "" "{- $> expr -}")+    , testCase "fails on unrelated text" do+        assertBool "expected Left" $ isLeft (parse Eval.blockCommentEvalP "" "hello world")+    ]   -------------------------------------------------------------------------------- -- findComments -------------------------------------------------------------------------------- -testFindComments :: Spec-testFindComments = do-    it "returns empty list for empty text" do-        Eval.findComments "" `shouldMatchList` []--    it "returns empty list when there are no eval comments" do-        Eval.findComments "hello world\nno comments here" `shouldMatchList` []--    it "finds a single single-line eval comment" do+testFindComments :: [TestTree]+testFindComments =+    [ testCase "returns empty list for empty text" do+        Eval.findComments "" @?= []+    , testCase "returns empty list when there are no eval comments" do+        Eval.findComments "hello world\nno comments here" @?= []+    , testCase "finds a single single-line eval comment" do         Eval.findComments "x = 1\n-- $> x\ny = 2"-            `shouldMatchList` [Eval.Comment {lineNumber = 2, expression = "x"}]--    it "finds multiple single-line eval comments in source order" do+            @?= [Eval.Comment {lineNumber = 2, expression = "x"}]+    , testCase "finds multiple single-line eval comments in source order" do         Eval.findComments "-- $> a\n-- $> b"-            `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"}-                              , Eval.Comment {lineNumber = 2, expression = "b"}-                              ]--    it "reports correct line numbers" do+            @?= [ Eval.Comment {lineNumber = 1, expression = "a"}+                , Eval.Comment {lineNumber = 2, expression = "b"}+                ]+    , testCase "reports correct line numbers" do         Eval.findComments "line1\nline2\n-- $> expr\nline4"-            `shouldMatchList` [Eval.Comment {lineNumber = 3, expression = "expr"}]--    it "ignores lines that look like partial markers" do+            @?= [Eval.Comment {lineNumber = 3, expression = "expr"}]+    , testCase "ignores lines that look like partial markers" do         Eval.findComments "-- $\n-- $> expr"-            `shouldMatchList` [Eval.Comment {lineNumber = 2, expression = "expr"}]--    it "does not match an eval marker embedded in another comment" do-        Eval.findComments "-- foo -- $> expr" `shouldMatchList` []--    it "does not match an inline eval marker appearing after code" do-        Eval.findComments "x = 1  -- $> x" `shouldMatchList` []--    it "finds a multi-line eval comment, stripping -- prefixes" do+            @?= [Eval.Comment {lineNumber = 2, expression = "expr"}]+    , testCase "does not match an eval marker embedded in another comment" do+        Eval.findComments "-- foo -- $> expr" @?= []+    , testCase "does not match an inline eval marker appearing after code" do+        Eval.findComments "x = 1  -- $> x" @?= []+    , testCase "finds a multi-line eval comment, stripping -- prefixes" do         Eval.findComments "-- $$>\n-- expr\n-- <$$"-            `shouldMatchList` [Eval.Comment {lineNumber = 1, expression = "expr"}]--    it "finds a block comment eval" do+            @?= [Eval.Comment {lineNumber = 1, expression = "expr"}]+    , testCase "finds a block comment eval" do         Eval.findComments "{- $$>\nexpr\n<$$ -}"-            `shouldMatchList` [Eval.Comment {lineNumber = 1, expression = "expr"}]--    it "finds both single-line and multi-line eval comments" do+            @?= [Eval.Comment {lineNumber = 1, expression = "expr"}]+    , testCase "finds both single-line and multi-line eval comments" do         Eval.findComments "-- $> a\n-- $$>\n-- b\n-- <$$"-            `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"}-                              , Eval.Comment {lineNumber = 2, expression = "b"}-                              ]--    it "finds both single-line and block comment eval comments" do+            @?= [ Eval.Comment {lineNumber = 1, expression = "a"}+                , Eval.Comment {lineNumber = 2, expression = "b"}+                ]+    , testCase "finds both single-line and block comment eval comments" do         Eval.findComments "-- $> a\n{- $$>\nb\n<$$ -}"-            `shouldMatchList` [ Eval.Comment {lineNumber = 1, expression = "a"}-                              , Eval.Comment {lineNumber = 2, expression = "b"}-                              ]+            @?= [ Eval.Comment {lineNumber = 1, expression = "a"}+                , Eval.Comment {lineNumber = 2, expression = "b"}+                ]+    ]

@@ -1,30 +1,36 @@-module Unit.Tricorder.CLI.RenderSpec (spec_Render) where+module Unit.Tricorder.CLI.RenderSpec (test_Render) where -import Test.Hspec+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, testCase) +import Data.Text qualified as T+ import Tricorder.Build (Diagnostic (..), Severity (..)) import Tricorder.CLI.Render (diagnosticBlock)  -spec_Render :: Spec-spec_Render = do-    describe "diagnosticBlock" do-        it "includes the one-liner prefix for an error" do-            diagnosticBlock errMsg `shouldContainT` "E Foo.hs:10 type mismatch"--        it "includes the full text body after the first line" do-            diagnosticBlock errMsg `shouldContainT` "\ntype mismatch"--        it "uses 'W' prefix for warnings" do-            diagnosticBlock warnMsg `shouldContainT` "W Bar.hs:3 unused import"--        it "contains both title and text when they differ" do-            let d = mixedMsg-            diagnosticBlock d `shouldContainT` "short title"-            diagnosticBlock d `shouldContainT` "full body of the message"+test_Render :: TestTree+test_Render =+    testGroup+        "Render"+        [ testGroup+            "diagnosticBlock"+            [ testCase "includes the one-liner prefix for an error" do+                diagnosticBlock errMsg `shouldContainT` "E Foo.hs:10 type mismatch"+            , testCase "includes the full text body after the first line" do+                diagnosticBlock errMsg `shouldContainT` "\ntype mismatch"+            , testCase "uses 'W' prefix for warnings" do+                diagnosticBlock warnMsg `shouldContainT` "W Bar.hs:3 unused import"+            , testCase "contains both title and text when they differ" do+                let d = mixedMsg+                diagnosticBlock d `shouldContainT` "short title"+                diagnosticBlock d `shouldContainT` "full body of the message"+            ]+        ]   where-    shouldContainT :: Text -> Text -> Expectation-    shouldContainT a b = toString a `shouldContain` toString b+    shouldContainT :: Text -> Text -> Assertion+    shouldContainT a b =+        assertBool (toString a <> "\ndoes not contain\n" <> toString b) $ b `T.isInfixOf` a   --------------------------------------------------------------------------------

@@ -1,8 +1,9 @@-module Unit.Tricorder.Daemon.BuildStateSpec (spec_BuildState) where+module Unit.Tricorder.Daemon.BuildStateSpec (test_BuildState) where  import Data.Aeson (eitherDecode, encode) import Data.Time (UTCTime (..), fromGregorian)-import Test.Hspec+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))  import Tricorder.Build     ( BuildId (..)@@ -13,74 +14,75 @@     , Severity (..)     ) import Tricorder.Build.Duration (Duration (..))-import Tricorder.Daemon.DaemonInfo (DaemonInfo (..))  import Tricorder.Build qualified as Build import Tricorder.Build.EvalComment qualified as Eval  -spec_BuildState :: Spec-spec_BuildState = do-    describe "JSON round-trip" do-        it "survives Unicode smart quotes in message text" do-            let msg =-                    Diagnostic-                        { severity = SWarning-                        , file = "<interactive>"-                        , line = 2-                        , col = 8-                        , endLine = 2-                        , endCol = 8-                        , title = "Found \8216qualified\8217 in prepositive position"-                        , text =-                            "Found \8216qualified\8217 in prepositive position\n    Suggested fixes:\n      \8226 Place \8216qualified\8217 after the module name."-                        }-                bs = mkBuildState [msg]-            eitherDecode (encode bs) `shouldBe` Right bs--        it "survives control characters in message text" do-            let msg =-                    Diagnostic-                        { severity = SWarning-                        , file = "<interactive>"-                        , line = 1-                        , col = 1-                        , endLine = 1-                        , endCol = 1-                        , title = "text with \CAN control \EM chars and \ESC[1m ANSI \ESC[0m codes"-                        , text = "text with \CAN control \EM chars and \ESC[1m ANSI \ESC[0m codes"-                        }-                bs = mkBuildState [msg]-            eitherDecode (encode bs) `shouldBe` Right bs--        it "survives curly double quotes in message text" do-            let msg =-                    Diagnostic-                        { severity = SWarning-                        , file = "<interactive>"-                        , line = 1-                        , col = 1-                        , endLine = 1-                        , endCol = 1-                        , title = "\8220Place qualified after the module name.\8221"-                        , text = "\8220Place qualified after the module name.\8221"-                        }-                bs = mkBuildState [msg]-            eitherDecode (encode bs) `shouldBe` Right bs--        -- Guards the wire format for the BuildFailed phase: the captured-        -- cabal/build error (multi-line, Unicode) must round-trip intact so-        -- the CLI/UI clients can render it.-        it "survives a BuildFailed phase with a multi-line message" do-            let bs =-                    mkBuildState [] :: BuildState-                failed =-                    bs-                        { phase =-                            Build.Failed-                                "cabal: Could not resolve dependencies:\n[__0] trying: \8216base\8217\nrejecting: ..."-                        }-            eitherDecode (encode failed) `shouldBe` Right failed+test_BuildState :: TestTree+test_BuildState =+    testGroup+        "BuildState"+        [ testGroup+            "JSON round-trip"+            [ testCase "survives Unicode smart quotes in message text" do+                let msg =+                        Diagnostic+                            { severity = SWarning+                            , file = "<interactive>"+                            , line = 2+                            , col = 8+                            , endLine = 2+                            , endCol = 8+                            , title = "Found \8216qualified\8217 in prepositive position"+                            , text =+                                "Found \8216qualified\8217 in prepositive position\n    Suggested fixes:\n      \8226 Place \8216qualified\8217 after the module name."+                            }+                    bs = mkBuildState [msg]+                eitherDecode (encode bs) @?= Right bs+            , testCase "survives control characters in message text" do+                let msg =+                        Diagnostic+                            { severity = SWarning+                            , file = "<interactive>"+                            , line = 1+                            , col = 1+                            , endLine = 1+                            , endCol = 1+                            , title = "text with \CAN control \EM chars and \ESC[1m ANSI \ESC[0m codes"+                            , text = "text with \CAN control \EM chars and \ESC[1m ANSI \ESC[0m codes"+                            }+                    bs = mkBuildState [msg]+                eitherDecode (encode bs) @?= Right bs+            , testCase "survives curly double quotes in message text" do+                let msg =+                        Diagnostic+                            { severity = SWarning+                            , file = "<interactive>"+                            , line = 1+                            , col = 1+                            , endLine = 1+                            , endCol = 1+                            , title = "\8220Place qualified after the module name.\8221"+                            , text = "\8220Place qualified after the module name.\8221"+                            }+                    bs = mkBuildState [msg]+                eitherDecode (encode bs) @?= Right bs+            , -- Guards the wire format for the BuildFailed phase: the captured+              -- cabal/build error (multi-line, Unicode) must round-trip intact so+              -- the CLI/UI clients can render it.+              testCase "survives a BuildFailed phase with a multi-line message" do+                let bs =+                        mkBuildState [] :: BuildState+                    failed =+                        bs+                            { phase =+                                Build.Failed+                                    "cabal: Could not resolve dependencies:\n[__0] trying: \8216base\8217\nrejecting: ..."+                            }+                eitherDecode (encode failed) @?= Right failed+            ]+        ]   mkBuildState :: [Diagnostic] -> BuildState@@ -97,13 +99,6 @@                     }                 )                 $ PostBuild mempty Eval.NoneFound-        , daemonInfo =-            DaemonInfo-                { targets = []-                , watchDirs = []-                , sockPath = ""-                , logFile = ""-                }         }   where     epoch = UTCTime (fromGregorian 1970 1 1) 0

@@ -1,7 +1,8 @@-module Unit.Tricorder.Daemon.BuilderSpec (spec_Builder) where+module Unit.Tricorder.Daemon.BuilderSpec (test_Builder) where  import Data.Time (UTCTime (..), addUTCTime, fromGregorian)-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))  import Data.Map.Strict qualified as Map import Data.Set qualified as Set@@ -19,20 +20,23 @@ import Tricorder.Session.WatchDirs (WatchDirs (..))  -spec_Builder :: Spec-spec_Builder = do-    describe "extractTitle" testExtractTitle-    describe "compileBuildResults" testCompileBuildResults-    describe "resolveKnownTargets" testResolveKnownTargets+test_Builder :: TestTree+test_Builder =+    testGroup+        "Builder"+        [ testGroup "extractTitle" testExtractTitle+        , testGroup "compileBuildResults" testCompileBuildResults+        , testGroup "resolveKnownTargets" testResolveKnownTargets+        ]   data StopSignal = StopSignal     deriving stock (Show)  -testCompileBuildResults :: Spec-testCompileBuildResults = do-    it "uses NewLoadResult's times to calculate duration" do+testCompileBuildResults :: [TestTree]+testCompileBuildResults =+    [ testCase "uses NewLoadResult's times to calculate duration" do         let (_, r) =                 compileBuildResults                     root@@ -50,8 +54,8 @@                                 , diagnostics = []                                 }                         }-        r.duration `shouldBe` Duration 10_000-    it "merges with existing results" do+        r.duration @?= Duration 10_000+    , testCase "merges with existing results" do         let (m, _) =                 compileBuildResults root watchDirs (Map.fromList [(errMsg.file, [errMsg])])                     $ NewLoadResult@@ -67,12 +71,11 @@                                 }                         }         m-            `shouldBe` fromList+            @?= fromList                 [ (warnMsg.file, [warnMsg])                 , (errMsg.file, [errMsg])                 ]--    it "returns a BuildResult" do+    , testCase "returns a BuildResult" do         let (_, r) =                 compileBuildResults root watchDirs mempty                     $ NewLoadResult@@ -94,7 +97,8 @@                     , moduleCount = 2                     , diagnostics = [warnMsg]                     }-        r `shouldBe` expected+        r @?= expected+    ]   where     root = ProjectRoot "/"     watchDirs = WatchDirs ["/src"]@@ -104,9 +108,9 @@ -- resolveKnownTargets tests -------------------------------------------------------------------------------- -testResolveKnownTargets :: Spec-testResolveKnownTargets = do-    it "uses :show modules as the primary source for path↔name mapping" do+testResolveKnownTargets :: [TestTree]+testResolveKnownTargets =+    [ testCase "uses :show modules as the primary source for path↔name mapping" do         let result =                 emptyLr                     { loadedModules =@@ -119,19 +123,18 @@                     , targetNames = ["Foo"]                     }         resolveKnownTargets Map.empty result-            `shouldBe` Map.fromList+            @?= Map.fromList                 [                     ( "/abs/src/Foo.hs"                     , LoadedModule {relPath = "./src/Foo.hs", moduleName = "Foo"}                     )                 ]--    -- Regression test for the stale-results bug. After a failed compile, the-    -- module disappears from :show modules but stays in :show targets. The-    -- prior state's entry must be carried over so the dispatcher continues to-    -- see the file as "known" and issues :reload (not :add) when the user-    -- fixes the error.-    it "carries over prior state for targets that are no longer in :show modules" do+    , -- Regression test for the stale-results bug. After a failed compile, the+      -- module disappears from :show modules but stays in :show targets. The+      -- prior state's entry must be carried over so the dispatcher continues to+      -- see the file as "known" and issues :reload (not :add) when the user+      -- fixes the error.+      testCase "carries over prior state for targets that are no longer in :show modules" do         let prev =                 Map.fromList                     [@@ -144,9 +147,8 @@                     { loadedModules = Map.empty -- Foo failed to compile                     , targetNames = ["Foo"] -- but is still a target                     }-        resolveKnownTargets prev result `shouldBe` prev--    it "drops targets that are no longer in :show targets" do+        resolveKnownTargets prev result @?= prev+    , testCase "drops targets that are no longer in :show targets" do         let prev =                 Map.fromList                     [@@ -155,13 +157,13 @@                         )                     ]             result = emptyLr {loadedModules = Map.empty, targetNames = []}-        resolveKnownTargets prev result `shouldBe` Map.empty--    -- Dropped from the path-keyed map because we have no path↔name entry;-    -- the dispatcher still handles them via 'KnownTargetNames'.-    it "drops targets that have neither a current :show modules entry nor prior state" do+        resolveKnownTargets prev result @?= Map.empty+    , -- Dropped from the path-keyed map because we have no path↔name entry;+      -- the dispatcher still handles them via 'KnownTargetNames'.+      testCase "drops targets that have neither a current :show modules entry nor prior state" do         let result = emptyLr {loadedModules = Map.empty, targetNames = ["BrandNew"]}-        resolveKnownTargets Map.empty result `shouldBe` Map.empty+        resolveKnownTargets Map.empty result @?= Map.empty+    ]   where     emptyLr =         LoadResult@@ -177,14 +179,13 @@ -- extractTitle tests -------------------------------------------------------------------------------- -testExtractTitle :: Spec-testExtractTitle = do-    it "returns empty string for empty message" do-        extractTitle [] `shouldBe` ""--    -- New GHC style: header ends with [GHC-XXXXX], content on body lines.-    -- Captured from GHC 9.10.2 with -Weverything.-    it "extracts first body line for error with [GHC-XXXXX] code" do+testExtractTitle :: [TestTree]+testExtractTitle =+    [ testCase "returns empty string for empty message" do+        extractTitle [] @?= ""+    , -- New GHC style: header ends with [GHC-XXXXX], content on body lines.+      -- Captured from GHC 9.10.2 with -Weverything.+      testCase "extracts first body line for error with [GHC-XXXXX] code" do         extractTitle             [ "src/Tricorder/Config.hs:39:20: error: [GHC-83865]"             , "    \8226 Couldn't match expected type 'Int' with actual type 'Bool'"@@ -194,9 +195,8 @@             , "39 | _deliberateError = True"             , "   |                    ^^^^"             ]-            `shouldBe` "\8226 Couldn't match expected type 'Int' with actual type 'Bool'"--    it "extracts first body line for warning with [GHC-XXXXX] [-Wfoo] codes" do+            @?= "\8226 Couldn't match expected type 'Int' with actual type 'Bool'"+    , testCase "extracts first body line for warning with [GHC-XXXXX] [-Wfoo] codes" do         extractTitle             [ "src/Tricorder/Config.hs:38:26: warning: [GHC-55631] [-Wmissing-deriving-strategies]"             , "    No deriving strategy specified. Did you want stock, newtype, or anyclass?"@@ -204,35 +204,30 @@             , "38 | data TestWarn = TestWarn deriving (Eq)"             , "   |                          ^^^^^^^^^^^^^"             ]-            `shouldBe` "No deriving strategy specified. Did you want stock, newtype, or anyclass?"--    -- Old GHC style: message text is inline on the header line.-    it "extracts inline content for old-style single-line error" do+            @?= "No deriving strategy specified. Did you want stock, newtype, or anyclass?"+    , -- Old GHC style: message text is inline on the header line.+      testCase "extracts inline content for old-style single-line error" do         extractTitle ["GHCi.hs:70:1: error: Parse error: naked expression at top level"]-            `shouldBe` "Parse error: naked expression at top level"--    it "extracts inline content for old-style Warning (capital W)" do+            @?= "Parse error: naked expression at top level"+    , testCase "extracts inline content for old-style Warning (capital W)" do         extractTitle ["GHCi.hs:81:1: Warning: Defined but not used: \8216foo\8217"]-            `shouldBe` "Defined but not used: \8216foo\8217"--    -- Multi-line without any inline message: position-only or "Warning:" header.-    it "extracts first body line when header has position only" do+            @?= "Defined but not used: \8216foo\8217"+    , -- Multi-line without any inline message: position-only or "Warning:" header.+      testCase "extracts first body line when header has position only" do         extractTitle             [ "GHCi.hs:72:13:"             , "    No instance for (Num ([String] -> [String]))"             , "      arising from the literal '1'"             ]-            `shouldBe` "No instance for (Num ([String] -> [String]))"--    it "extracts first body line when header ends with 'Warning:'" do+            @?= "No instance for (Num ([String] -> [String]))"+    , testCase "extracts first body line when header ends with 'Warning:'" do         extractTitle             [ "/src/TrieSpec.hs:(192,7)-(193,76): Warning:"             , "    A do-notation statement discarded a result of type '[()]'"             ]-            `shouldBe` "A do-notation statement discarded a result of type '[()]'"--    -- Source display lines (pipe/caret) must be skipped.-    it "skips source display lines when scanning body" do+            @?= "A do-notation statement discarded a result of type '[()]'"+    , -- Source display lines (pipe/caret) must be skipped.+      testCase "skips source display lines when scanning body" do         extractTitle             [ "file.hs:1:1: error: [GHC-12345]"             , "   |"@@ -240,15 +235,15 @@             , "   |     ^^^"             , "    actual content here"             ]-            `shouldBe` "actual content here"--    -- ANSI-escaped header (colour output): strip escapes before searching.-    it "handles ANSI-escaped headers" do+            @?= "actual content here"+    , -- ANSI-escaped header (colour output): strip escapes before searching.+      testCase "handles ANSI-escaped headers" do         extractTitle             [ "\ESC[;1msrc/Types.hs:11:1: \ESC[35mwarning:\ESC[0m \ESC[35m[-Wunused-imports]\ESC[0m"             , "    The import of 'Data.Data' is redundant"             ]-            `shouldBe` "The import of 'Data.Data' is redundant"+            @?= "The import of 'Data.Data' is redundant"+    ]   --------------------------------------------------------------------------------

@@ -1,6 +1,7 @@-module Unit.Tricorder.Daemon.DispatchSpec (spec_Dispatch) where+module Unit.Tricorder.Daemon.DispatchSpec (test_Dispatch) where -import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))  import Data.Map.Strict qualified as Map import Data.Set qualified as Set@@ -17,77 +18,74 @@ import Tricorder.Session.WatchDirs (WatchDirs (..))  -spec_Dispatch :: Spec-spec_Dispatch = do-    describe "fileMatchesAnyTarget" testFileMatchesAnyTarget-    describe "mergeDiagnostics" testMergeDiagnostics-    describe "filterToWatchDirs" testFilterToWatchDirs+test_Dispatch :: TestTree+test_Dispatch =+    testGroup+        "Dispatch"+        [ testGroup "fileMatchesAnyTarget" testFileMatchesAnyTarget+        , testGroup "mergeDiagnostics" testMergeDiagnostics+        , testGroup "filterToWatchDirs" testFilterToWatchDirs+        ]   -------------------------------------------------------------------------------- -- fileMatchesAnyTarget tests -------------------------------------------------------------------------------- -testFileMatchesAnyTarget :: Spec-testFileMatchesAnyTarget = do-    it "matches when the path's uppercase-suffix equals a target" do+testFileMatchesAnyTarget :: [TestTree]+testFileMatchesAnyTarget =+    [ testCase "matches when the path's uppercase-suffix equals a target" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "Tricorder.Version"))             "./tricorder/src/Tricorder/Version.hs"-            `shouldBe` True--    it "matches a single-segment module" do+            @?= True+    , testCase "matches a single-segment module" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "Main"))             "./app/Main.hs"-            `shouldBe` True--    it "does not match when no uppercase-suffix equals a target" do+            @?= True+    , testCase "does not match when no uppercase-suffix equals a target" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "Other.Module"))             "./tricorder/src/Tricorder/Version.hs"-            `shouldBe` False--    it "does not match a lowercase-prefix even if textually contained" do+            @?= False+    , testCase "does not match a lowercase-prefix even if textually contained" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "src.Tricorder.Version"))             "./tricorder/src/Tricorder/Version.hs"-            `shouldBe` False--    it "handles .lhs extension" do+            @?= False+    , testCase "handles .lhs extension" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "Foo.Bar"))             "./src/Foo/Bar.lhs"-            `shouldBe` True--    -- GHCi renders a target whose module name is ambiguous across home units-    -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs".-    it "matches a path-shaped target on directory-segment boundaries" do+            @?= True+    , -- GHCi renders a target whose module name is ambiguous across home units+      -- (every executable/test 'Main') as its source path, e.g. "app/Main.hs".+      testCase "matches a path-shaped target on directory-segment boundaries" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "app/Main.hs"))             "./tricorder/app/Main.hs"-            `shouldBe` True--    it "does not match a path-shaped target on a partial segment" do+            @?= True+    , testCase "does not match a path-shaped target on a partial segment" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "pp/Main.hs"))             "./tricorder/app/Main.hs"-            `shouldBe` False--    it "does not match a path-shaped target for a different file" do+            @?= False+    , testCase "does not match a path-shaped target for a different file" do         fileMatchesAnyTarget             (KnownTargetNames (Set.singleton "daemon/Main.hs"))             "./tricorder/app/Main.hs"-            `shouldBe` False+            @?= False+    ]   -------------------------------------------------------------------------------- -- mergeDiagnostics tests -------------------------------------------------------------------------------- -testMergeDiagnostics :: Spec-testMergeDiagnostics = do-    it "retains diagnostics from files not in compiledFiles" do+testMergeDiagnostics :: [TestTree]+testMergeDiagnostics =+    [ testCase "retains diagnostics from files not in compiledFiles" do         -- Foo has an error, Bar has a warning.         -- Only Foo is recompiled (and fixed). Bar is unchanged, so Bar's         -- warning must survive.@@ -101,9 +99,8 @@                     , diagnostics = []                     }         let merged = mergeDiagnostics prev result-        Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg]--    it "clears diagnostics when a recompiled file now has no issues" do+        Map.lookup warnMsg.file merged @?= Just [warnMsg]+    , testCase "clears diagnostics when a recompiled file now has no issues" do         let prev = Map.fromList [(errMsg.file, [errMsg])]             result =                 LoadResult@@ -114,9 +111,8 @@                     , diagnostics = []                     }         let merged = mergeDiagnostics prev result-        Map.lookup errMsg.file merged `shouldBe` Nothing--    it "replaces diagnostics for recompiled files" do+        Map.lookup errMsg.file merged @?= Nothing+    , testCase "replaces diagnostics for recompiled files" do         let newErr = errMsg {title = "new error", text = "new error\n"}             prev = Map.fromList [(errMsg.file, [errMsg])]             result =@@ -128,9 +124,8 @@                     , diagnostics = [newErr]                     }         let merged = mergeDiagnostics prev result-        Map.lookup errMsg.file merged `shouldBe` Just [newErr]--    it "accumulates diagnostics for newly seen files" do+        Map.lookup errMsg.file merged @?= Just [newErr]+    , testCase "accumulates diagnostics for newly seen files" do         let result =                 LoadResult                     { moduleCount = 1@@ -140,26 +135,27 @@                     , diagnostics = [warnMsg]                     }         let merged = mergeDiagnostics Map.empty result-        Map.lookup warnMsg.file merged `shouldBe` Just [warnMsg]--    describe "when the cycle reports none" $ it "clears a stale location-less diagnostic" do-        -- <no location info> is never in compiledFiles, so without special-        -- handling it would persist forever. A cycle with no location-less-        -- diagnostic must evict it.-        let noLoc = errMsg {file = "<no location info>"}-            prev = Map.fromList [(noLoc.file, [noLoc])]-            result =-                LoadResult-                    { moduleCount = 1-                    , compiledFiles = Set.singleton errMsg.file-                    , loadedModules = Map.empty-                    , targetNames = []-                    , diagnostics = []-                    }-        let merged = mergeDiagnostics prev result-        Map.lookup noLoc.file merged `shouldBe` Nothing--    it "refreshes a location-less diagnostic that is still present" do+        Map.lookup warnMsg.file merged @?= Just [warnMsg]+    , testGroup+        "when the cycle reports none"+        [ testCase "clears a stale location-less diagnostic" do+            -- <no location info> is never in compiledFiles, so without special+            -- handling it would persist forever. A cycle with no location-less+            -- diagnostic must evict it.+            let noLoc = errMsg {file = "<no location info>"}+                prev = Map.fromList [(noLoc.file, [noLoc])]+                result =+                    LoadResult+                        { moduleCount = 1+                        , compiledFiles = Set.singleton errMsg.file+                        , loadedModules = Map.empty+                        , targetNames = []+                        , diagnostics = []+                        }+            let merged = mergeDiagnostics prev result+            Map.lookup noLoc.file merged @?= Nothing+        ]+    , testCase "refreshes a location-less diagnostic that is still present" do         let noLoc = errMsg {file = "<no location info>"}             prev = Map.fromList [(noLoc.file, [noLoc])]             result =@@ -171,83 +167,82 @@                     , diagnostics = [noLoc]                     }         let merged = mergeDiagnostics prev result-        Map.lookup noLoc.file merged `shouldBe` Just [noLoc]+        Map.lookup noLoc.file merged @?= Just [noLoc]+    ]   -------------------------------------------------------------------------------- -- filterToWatchDirs tests -------------------------------------------------------------------------------- -testFilterToWatchDirs :: Spec-testFilterToWatchDirs = do-    let root = "/project"-        watchDirs = WatchDirs ["/project/src"]--    it "keeps diagnostics under a watched directory" do+testFilterToWatchDirs :: [TestTree]+testFilterToWatchDirs =+    [ testCase "keeps diagnostics under a watched directory" do         -- ./src/Foo.hs is what toRelative produces for an absolute project file         let d = errMsg {file = "./src/Foo.hs"}-        filterToWatchDirs root watchDirs [d] `shouldBe` [d]--    it "keeps diagnostics under \".\" watched directory" do+        filterToWatchDirs root watchDirs [d] @?= [d]+    , testCase "keeps diagnostics under \".\" watched directory" do         let d = errMsg {file = "src/Foo.hs"}-        filterToWatchDirs root (WatchDirs ["."]) [d] `shouldMatchList` [d]--    it "drops diagnostics from outside the project (e.g. Nix store .h files)" do+        filterToWatchDirs root (WatchDirs ["."]) [d] @?= [d]+    , testCase "drops diagnostics from outside the project (e.g. Nix store .h files)" do         let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}-        filterToWatchDirs root watchDirs [d] `shouldBe` []--    it "drops diagnostics with mangled CPP filenames" do+        filterToWatchDirs root watchDirs [d] @?= []+    , testCase "drops diagnostics with mangled CPP filenames" do         -- The ghcid parser produces "In file included from <path>" as the file         -- field for GCC-style CPP include-chain messages.         let d = errMsg {file = "In file included from src/Foo.hs"}-        filterToWatchDirs root watchDirs [d] `shouldBe` []--    it "drops mangled CPP filenames when watchDirs is [\".\"] (project root)" do+        filterToWatchDirs root watchDirs [d] @?= []+    , testCase "drops mangled CPP filenames when watchDirs is [\".\"] (project root)" do         -- With watchDirs=["."], the watch dir resolves to projectRoot itself.         -- A mangled path joined onto projectRoot would incorrectly start with         -- projectRoot+"/", so this case requires an explicit guard.         let d = errMsg {file = "In file included from src/Foo.hs"}-        filterToWatchDirs root (WatchDirs ["."]) [d] `shouldBe` []--    it "passes everything through when watchDirs is empty" do+        filterToWatchDirs root (WatchDirs ["."]) [d] @?= []+    , testCase "passes everything through when watchDirs is empty" do         let d = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}-        filterToWatchDirs root (WatchDirs []) [d] `shouldBe` [d]--    it "works with the '.' fallback watch dir (whole project root)" do+        filterToWatchDirs root (WatchDirs []) [d] @?= [d]+    , testCase "works with the '.' fallback watch dir (whole project root)" do         let d = errMsg {file = "./src/Foo.hs"}             nixD = errMsg {file = "/nix/store/abc123/ghcautoconf.h"}-        filterToWatchDirs root (WatchDirs ["."]) [d, nixD] `shouldBe` [d]--    describe "when diagnostic has no path it" $ it "keeps location-less <no location info> errors" do-        -- A home-unit GHC plugin that can't load under --enable-multi-repl-        -- produces a <no location info> error. It has no path to test against a-        -- watch dir, but must survive or the failed build reads as clean.-        let d = errMsg {file = "<no location info>"}-        filterToWatchDirs root watchDirs [d] `shouldBe` [d]--    it "does not treat a real <-prefixed path as a location-less marker" do+        filterToWatchDirs root (WatchDirs ["."]) [d, nixD] @?= [d]+    , testGroup+        "when diagnostic has no path it"+        [ testCase "keeps location-less <no location info> errors" do+            -- A home-unit GHC plugin that can't load under --enable-multi-repl+            -- produces a <no location info> error. It has no path to test against a+            -- watch dir, but must survive or the failed build reads as clean.+            let d = errMsg {file = "<no location info>"}+            filterToWatchDirs root watchDirs [d] @?= [d]+        ]+    , testCase "does not treat a real <-prefixed path as a location-less marker" do         -- isLocationLess requires a closing '>'. A real (if exotic) path that         -- merely starts with '<' is an ordinary out-of-watch file and must be         -- dropped, not kept as a build-level marker.         let d = errMsg {file = "<generated>/Foo.hs"}-        filterToWatchDirs root watchDirs [d] `shouldBe` []--    describe "when its only error is out of watch dirs" $ it "a failed load does not read as clean" do-        -- collectResult only injects its synthetic failure when no SError is-        -- present. Here GHCi Failed with a single *located* error in a file-        -- outside the watch dirs, so collectResult adds no synthetic — and then-        -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The-        -- Builder pipeline composes preserveFailureVisibility after filtering to-        -- re-attach the failure, so a failed build never survives with zero-        -- diagnostics.-        let reloadOutput =-                [ "/other/Dep.hs:5:1: error: boom"-                , "Failed, 0 modules loaded."-                ]-            result = collectResult root reloadOutput [] []-            filtered = filterToWatchDirs root watchDirs result.diagnostics-        preserveFailureVisibility result.diagnostics filtered-            `shouldSatisfy` (not . null)+        filterToWatchDirs root watchDirs [d] @?= []+    , testGroup+        "when its only error is out of watch dirs"+        [ testCase "a failed load does not read as clean" do+            -- collectResult only injects its synthetic failure when no SError is+            -- present. Here GHCi Failed with a single *located* error in a file+            -- outside the watch dirs, so collectResult adds no synthetic — and then+            -- filterToWatchDirs drops the out-of-watch error, leaving nothing. The+            -- Builder pipeline composes preserveFailureVisibility after filtering to+            -- re-attach the failure, so a failed build never survives with zero+            -- diagnostics.+            let reloadOutput =+                    [ "/other/Dep.hs:5:1: error: boom"+                    , "Failed, 0 modules loaded."+                    ]+                result = collectResult root reloadOutput [] []+                filtered = filterToWatchDirs root watchDirs result.diagnostics+            assertBool "expected at least one diagnostic"+                $ not (null (preserveFailureVisibility result.diagnostics filtered))+        ]+    ]+  where+    root = "/project"+    watchDirs = WatchDirs ["/project/src"]   --------------------------------------------------------------------------------

@@ -1,6 +1,7 @@-module Unit.Tricorder.Daemon.GhciSession.GhciParserSpec (spec_GhciParser) where+module Unit.Tricorder.Daemon.GhciSession.GhciParserSpec (test_GhciParser) where -import Test.Hspec+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))  import Tricorder.Build (Diagnostic (..), Severity (..)) import Tricorder.Daemon.GhciSession.GhciParser@@ -19,35 +20,42 @@     )  -spec_GhciParser :: Spec-spec_GhciParser = do-    describe "parseReload" do-        describe "clean build" testCleanBuild-        describe "with errors and warnings" testErrors-        describe "with -fhide-source-paths (no Loading items)" testHideSourcePaths-        describe "with <no location info> errors" testNoLocationInfo-        describe "with Loaded GHCi configuration" testLoadedConfig--    describe "parseShowModules" do-        describe "typical output" testShowModules-        describe "empty / blank input" testShowModulesEmpty--    describe "parseShowTargets" testShowTargets--    describe "collectResultCustom" do-        describe "<no location info> plugin load failure" testPluginLoadFailure--    describe "collectResult" do-        describe "failed load with no located error" testUnattributedFailure+test_GhciParser :: TestTree+test_GhciParser =+    testGroup+        "GhciParser"+        [ testGroup+            "parseReload"+            [ testGroup "clean build" testCleanBuild+            , testGroup "with errors and warnings" testErrors+            , testGroup "with -fhide-source-paths (no Loading items)" testHideSourcePaths+            , testGroup "with <no location info> errors" testNoLocationInfo+            , testGroup "with Loaded GHCi configuration" testLoadedConfig+            ]+        , testGroup+            "parseShowModules"+            [ testGroup "typical output" testShowModules+            , testGroup "empty / blank input" testShowModulesEmpty+            ]+        , testGroup "parseShowTargets" testShowTargets+        , testGroup+            "collectResultCustom"+            [ testGroup "<no location info> plugin load failure" testPluginLoadFailure+            ]+        , testGroup+            "collectResult"+            [ testGroup "failed load with no located error" testUnattributedFailure+            ]+        ]   -------------------------------------------------------------------------------- -- parseReload: clean build -------------------------------------------------------------------------------- -testCleanBuild :: Spec-testCleanBuild = do-    it "produces GLoading items for each compiled module" do+testCleanBuild :: [TestTree]+testCleanBuild =+    [ testCase "produces GLoading items for each compiled module" do         let input =                 [ "[1 of 3] Compiling Tricorder.Build ( src/Tricorder.Build.hs, interpreted )"                 , "[2 of 3] Compiling Tricorder.Session    ( src/Tricorder/Session.hs, interpreted )"@@ -55,118 +63,115 @@                 , "Ok, 3 modules loaded."                 ]         parseReload input-            `shouldBe` [ GLoading-                            GhciLoading-                                { index = 1-                                , total = 3-                                , moduleName = "Tricorder.Build"-                                , sourceFile = "src/Tricorder.Build.hs"-                                }-                       , GLoading-                            GhciLoading-                                { index = 2-                                , total = 3-                                , moduleName = "Tricorder.Session"-                                , sourceFile = "src/Tricorder/Session.hs"-                                }-                       , GLoading GhciLoading {index = 3, total = 3, moduleName = "Main", sourceFile = "app/Main.hs"}-                       , GSummary LoadSucceeded-                       ]--    it "handles padded module index (e.g. [ 1 of 47])" do+            @?= [ GLoading+                    GhciLoading+                        { index = 1+                        , total = 3+                        , moduleName = "Tricorder.Build"+                        , sourceFile = "src/Tricorder.Build.hs"+                        }+                , GLoading+                    GhciLoading+                        { index = 2+                        , total = 3+                        , moduleName = "Tricorder.Session"+                        , sourceFile = "src/Tricorder/Session.hs"+                        }+                , GLoading GhciLoading {index = 3, total = 3, moduleName = "Main", sourceFile = "app/Main.hs"}+                , GSummary LoadSucceeded+                ]+    , testCase "handles padded module index (e.g. [ 1 of 47])" do         let input =                 [ "[ 1 of 47] Compiling Main              ( app/Main.hs, interpreted )"                 , "Ok, 1 module loaded."                 ]         parseReload input-            `shouldBe` [ GLoading GhciLoading {index = 1, total = 47, moduleName = "Main", sourceFile = "app/Main.hs"}-                       , GSummary LoadSucceeded-                       ]--    describe "when only summary line" $ it "returns the summary outcome" do-        parseReload ["Ok, 0 modules loaded."] `shouldBe` [GSummary LoadSucceeded]+            @?= [ GLoading GhciLoading {index = 1, total = 47, moduleName = "Main", sourceFile = "app/Main.hs"}+                , GSummary LoadSucceeded+                ]+    , testGroup+        "when only summary line"+        [ testCase "returns the summary outcome" do+            parseReload ["Ok, 0 modules loaded."] @?= [GSummary LoadSucceeded]+        ]+    ]   -------------------------------------------------------------------------------- -- parseReload: errors and warnings -------------------------------------------------------------------------------- -testErrors :: Spec-testErrors = do-    it "parses a single-line error" do+testErrors :: [TestTree]+testErrors =+    [ testCase "parses a single-line error" do         let input = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Foo.hs"-                                , startPos = Position 10 5-                                , endPos = Position 10 5-                                , messageLines = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]-                                }-                       ]--    it "parses a warning with continuation lines" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Foo.hs"+                        , startPos = Position 10 5+                        , endPos = Position 10 5+                        , messageLines = ["src/Foo.hs:10:5: error: Variable not in scope: foo"]+                        }+                ]+    , testCase "parses a warning with continuation lines" do         let input =                 [ "src/Bar.hs:20:3: warning: [-Wunused-imports]"                 , "    Redundant import: Data.List"                 , "    Perhaps you want to remove it."                 ]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GWarning-                                , file = "src/Bar.hs"-                                , startPos = Position 20 3-                                , endPos = Position 20 3-                                , messageLines =-                                    [ "src/Bar.hs:20:3: warning: [-Wunused-imports]"-                                    , "    Redundant import: Data.List"-                                    , "    Perhaps you want to remove it."-                                    ]-                                }-                       ]--    it "parses a span position (L:C-C2:)" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GWarning+                        , file = "src/Bar.hs"+                        , startPos = Position 20 3+                        , endPos = Position 20 3+                        , messageLines =+                            [ "src/Bar.hs:20:3: warning: [-Wunused-imports]"+                            , "    Redundant import: Data.List"+                            , "    Perhaps you want to remove it."+                            ]+                        }+                ]+    , testCase "parses a span position (L:C-C2:)" do         let input = ["src/Baz.hs:5:1-10: error: Parse error"]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Baz.hs"-                                , startPos = Position 5 1-                                , endPos = Position 5 10-                                , messageLines = ["src/Baz.hs:5:1-10: error: Parse error"]-                                }-                       ]--    it "parses a span position ((L1,C1)-(L2,C2):)" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Baz.hs"+                        , startPos = Position 5 1+                        , endPos = Position 5 10+                        , messageLines = ["src/Baz.hs:5:1-10: error: Parse error"]+                        }+                ]+    , testCase "parses a span position ((L1,C1)-(L2,C2):)" do         let input = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Qux.hs"-                                , startPos = Position 3 1-                                , endPos = Position 5 20-                                , messageLines = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]-                                }-                       ]--    it "parses a span position with double-paren end ((L1,C1)-((L2,C2):)" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Qux.hs"+                        , startPos = Position 3 1+                        , endPos = Position 5 20+                        , messageLines = ["src/Qux.hs:(3,1)-(5,20): error: Multi-line error"]+                        }+                ]+    , testCase "parses a span position with double-paren end ((L1,C1)-((L2,C2):)" do         let input = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Qux.hs"-                                , startPos = Position 3 1-                                , endPos = Position 5 20-                                , messageLines = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]-                                }-                       ]--    it "parses source-display continuation lines (pipe format)" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Qux.hs"+                        , startPos = Position 3 1+                        , endPos = Position 5 20+                        , messageLines = ["src/Qux.hs:(3,1)-((5,20): error: Multi-line error"]+                        }+                ]+    , testCase "parses source-display continuation lines (pipe format)" do         let input =                 [ "src/Foo.hs:10:5: error: Variable not in scope: foo"                 , "   |"@@ -175,49 +180,46 @@                 , "    Suggested fix: import Foo"                 ]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Foo.hs"-                                , startPos = Position 10 5-                                , endPos = Position 10 5-                                , messageLines =-                                    [ "src/Foo.hs:10:5: error: Variable not in scope: foo"-                                    , "   |"-                                    , "10 | foo bar"-                                    , "   | ^^^"-                                    , "    Suggested fix: import Foo"-                                    ]-                                }-                       ]--    it "strips ANSI codes from header for matching but stores original in glMessage" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Foo.hs"+                        , startPos = Position 10 5+                        , endPos = Position 10 5+                        , messageLines =+                            [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                            , "   |"+                            , "10 | foo bar"+                            , "   | ^^^"+                            , "    Suggested fix: import Foo"+                            ]+                        }+                ]+    , testCase "strips ANSI codes from header for matching but stores original in glMessage" do         let ansiHeader = "\ESC[1msrc/Foo.hs:10:5:\ESC[0m \ESC[91merror:\ESC[0m Variable not in scope: foo"         parseReload [ansiHeader]-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Foo.hs"-                                , startPos = Position 10 5-                                , endPos = Position 10 5-                                , messageLines = [ansiHeader]-                                }-                       ]--    it "parses a Windows drive-letter path in a diagnostic" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Foo.hs"+                        , startPos = Position 10 5+                        , endPos = Position 10 5+                        , messageLines = [ansiHeader]+                        }+                ]+    , testCase "parses a Windows drive-letter path in a diagnostic" do         let input = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "C:\\path\\file.hs"-                                , startPos = Position 10 5-                                , endPos = Position 10 5-                                , messageLines = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]-                                }-                       ]--    it "parses mixed Loading, Message, and summary items" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "C:\\path\\file.hs"+                        , startPos = Position 10 5+                        , endPos = Position 10 5+                        , messageLines = ["C:\\path\\file.hs:10:5: error: Variable not in scope: foo"]+                        }+                ]+    , testCase "parses mixed Loading, Message, and summary items" do         let input =                 [ "[1 of 2] Compiling Lib ( src/Lib.hs, interpreted )"                 , "src/Lib.hs:5:1: error: Oops"@@ -225,185 +227,185 @@                 , "Failed, 1 module loaded."                 ]         parseReload input-            `shouldBe` [ GLoading GhciLoading {index = 1, total = 2, moduleName = "Lib", sourceFile = "src/Lib.hs"}-                       , GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Lib.hs"-                                , startPos = Position 5 1-                                , endPos = Position 5 1-                                , messageLines = ["src/Lib.hs:5:1: error: Oops"]-                                }-                       , GLoading GhciLoading {index = 2, total = 2, moduleName = "Main", sourceFile = "app/Main.hs"}-                       , GSummary LoadFailed-                       ]+            @?= [ GLoading GhciLoading {index = 1, total = 2, moduleName = "Lib", sourceFile = "src/Lib.hs"}+                , GMessage+                    GhciMessage+                        { severity = GError+                        , file = "src/Lib.hs"+                        , startPos = Position 5 1+                        , endPos = Position 5 1+                        , messageLines = ["src/Lib.hs:5:1: error: Oops"]+                        }+                , GLoading GhciLoading {index = 2, total = 2, moduleName = "Main", sourceFile = "app/Main.hs"}+                , GSummary LoadFailed+                ]+    ]   -------------------------------------------------------------------------------- -- parseReload: -fhide-source-paths output -------------------------------------------------------------------------------- -testHideSourcePaths :: Spec-testHideSourcePaths = do-    describe "when source paths are hidden" $ it "produces no GLoading items" do-        let input =-                [ "src/Foo.hs:10:5: error: Variable not in scope: foo"-                , "    Perhaps you meant: 'bar'"-                , "Failed, one module failed to load."-                ]-        parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "src/Foo.hs"-                                , startPos = Position 10 5-                                , endPos = Position 10 5-                                , messageLines =-                                    [ "src/Foo.hs:10:5: error: Variable not in scope: foo"-                                    , "    Perhaps you meant: 'bar'"-                                    ]-                                }-                       , GSummary LoadFailed-                       ]--    describe "when all modules are already up to date" $ it "returns the summary outcome" do-        -- GHCi with -fhide-source-paths and nothing to recompile-        parseReload ["Ok, 5 modules loaded."] `shouldBe` [GSummary LoadSucceeded]+testHideSourcePaths :: [TestTree]+testHideSourcePaths =+    [ testGroup+        "when source paths are hidden"+        [ testCase "produces no GLoading items" do+            let input =+                    [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                    , "    Perhaps you meant: 'bar'"+                    , "Failed, one module failed to load."+                    ]+            parseReload input+                @?= [ GMessage+                        GhciMessage+                            { severity = GError+                            , file = "src/Foo.hs"+                            , startPos = Position 10 5+                            , endPos = Position 10 5+                            , messageLines =+                                [ "src/Foo.hs:10:5: error: Variable not in scope: foo"+                                , "    Perhaps you meant: 'bar'"+                                ]+                            }+                    , GSummary LoadFailed+                    ]+        ]+    , testGroup+        "when all modules are already up to date"+        [ testCase "returns the summary outcome" do+            -- GHCi with -fhide-source-paths and nothing to recompile+            parseReload ["Ok, 5 modules loaded."] @?= [GSummary LoadSucceeded]+        ]+    ]   -------------------------------------------------------------------------------- -- parseReload: <no location info> errors -------------------------------------------------------------------------------- -testNoLocationInfo :: Spec-testNoLocationInfo = do-    it "handles <no location info>: error: with continuation" do+testNoLocationInfo :: [TestTree]+testNoLocationInfo =+    [ testCase "handles <no location info>: error: with continuation" do         let input =                 [ "<no location info>: error:"                 , "    Module `Tricorder.Missing' is not loaded."                 ]         parseReload input-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "<no location info>"-                                , startPos = Position 0 0-                                , endPos = Position 0 0-                                , messageLines =-                                    [ "<no location info>: error:"-                                    , "    Module `Tricorder.Missing' is not loaded."-                                    ]-                                }-                       ]--    it "handles <no location info>: error: with no continuation" do+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "<no location info>"+                        , startPos = Position 0 0+                        , endPos = Position 0 0+                        , messageLines =+                            [ "<no location info>: error:"+                            , "    Module `Tricorder.Missing' is not loaded."+                            ]+                        }+                ]+    , testCase "handles <no location info>: error: with no continuation" do         parseReload ["<no location info>: error: some error"]-            `shouldBe` [ GMessage-                            GhciMessage-                                { severity = GError-                                , file = "<no location info>"-                                , startPos = Position 0 0-                                , endPos = Position 0 0-                                , messageLines = ["<no location info>: error: some error"]-                                }-                       ]+            @?= [ GMessage+                    GhciMessage+                        { severity = GError+                        , file = "<no location info>"+                        , startPos = Position 0 0+                        , endPos = Position 0 0+                        , messageLines = ["<no location info>: error: some error"]+                        }+                ]+    ]   -------------------------------------------------------------------------------- -- parseReload: Loaded GHCi configuration -------------------------------------------------------------------------------- -testLoadedConfig :: Spec-testLoadedConfig = do-    it "parses a GHCi configuration line" do+testLoadedConfig :: [TestTree]+testLoadedConfig =+    [ testCase "parses a GHCi configuration line" do         parseReload ["Loaded GHCi configuration from /home/user/project/.ghci"]-            `shouldBe` [GLoadConfig "/home/user/project/.ghci"]--    it "parses a Windows-style GHCi configuration path" do+            @?= [GLoadConfig "/home/user/project/.ghci"]+    , testCase "parses a Windows-style GHCi configuration path" do         parseReload ["Loaded GHCi configuration from C:\\Users\\user\\project\\.ghci"]-            `shouldBe` [GLoadConfig "C:\\Users\\user\\project\\.ghci"]--    it "handles config line mixed with other output" do+            @?= [GLoadConfig "C:\\Users\\user\\project\\.ghci"]+    , testCase "handles config line mixed with other output" do         let input =                 [ "Loaded GHCi configuration from .ghci"                 , "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"                 , "Ok, 1 module loaded."                 ]         parseReload input-            `shouldBe` [ GLoadConfig ".ghci"-                       , GLoading GhciLoading {index = 1, total = 1, moduleName = "Main", sourceFile = "app/Main.hs"}-                       , GSummary LoadSucceeded-                       ]+            @?= [ GLoadConfig ".ghci"+                , GLoading GhciLoading {index = 1, total = 1, moduleName = "Main", sourceFile = "app/Main.hs"}+                , GSummary LoadSucceeded+                ]+    ]   -------------------------------------------------------------------------------- -- parseShowModules -------------------------------------------------------------------------------- -testShowModules :: Spec-testShowModules = do-    it "parses typical :show modules output" do+testShowModules :: [TestTree]+testShowModules =+    [ testCase "parses typical :show modules output" do         let input =                 [ "Tricorder.Build     ( src/Tricorder.Build.hs, interpreted )"                 , "Tricorder.Session        ( src/Tricorder/Session.hs, interpreted )"                 , "Main                     ( app/Main.hs, interpreted )"                 ]         parseShowModules input-            `shouldBe` [ ("Tricorder.Build", "src/Tricorder.Build.hs")-                       , ("Tricorder.Session", "src/Tricorder/Session.hs")-                       , ("Main", "app/Main.hs")-                       ]--    it "parses absolute paths" do+            @?= [ ("Tricorder.Build", "src/Tricorder.Build.hs")+                , ("Tricorder.Session", "src/Tricorder/Session.hs")+                , ("Main", "app/Main.hs")+                ]+    , testCase "parses absolute paths" do         parseShowModules ["Lib ( /home/user/project/src/Lib.hs, interpreted )"]-            `shouldBe` [("Lib", "/home/user/project/src/Lib.hs")]--    it "strips ANSI codes before parsing" do+            @?= [("Lib", "/home/user/project/src/Lib.hs")]+    , testCase "strips ANSI codes before parsing" do         parseShowModules ["\ESC[1mMain\ESC[0m                     ( app/Main.hs, interpreted )"]-            `shouldBe` [("Main", "app/Main.hs")]+            @?= [("Main", "app/Main.hs")]+    ]  -testShowModulesEmpty :: Spec-testShowModulesEmpty = do-    it "returns empty list for empty input" do-        parseShowModules [] `shouldBe` []--    it "returns empty list for blank lines" do-        parseShowModules ["", "   ", "\t"] `shouldBe` []--    it "skips lines without '( '" do-        parseShowModules ["just some random text"] `shouldBe` []+testShowModulesEmpty :: [TestTree]+testShowModulesEmpty =+    [ testCase "returns empty list for empty input" do+        parseShowModules [] @?= []+    , testCase "returns empty list for blank lines" do+        parseShowModules ["", "   ", "\t"] @?= []+    , testCase "skips lines without '( '" do+        parseShowModules ["just some random text"] @?= []+    ]   -------------------------------------------------------------------------------- -- parseShowTargets -------------------------------------------------------------------------------- -testShowTargets :: Spec-testShowTargets = do-    it "parses module names emitted by cabal repl --enable-multi-repl" do+testShowTargets :: [TestTree]+testShowTargets =+    [ testCase "parses module names emitted by cabal repl --enable-multi-repl" do         parseShowTargets             [ "Atelier.Effects.Cache"             , "Atelier.Effects.Chan"             , "Paths_tricorder"             ]-            `shouldBe` ["Atelier.Effects.Cache", "Atelier.Effects.Chan", "Paths_tricorder"]--    it "parses file-path targets emitted by plain ghci" do+            @?= ["Atelier.Effects.Cache", "Atelier.Effects.Chan", "Paths_tricorder"]+    , testCase "parses file-path targets emitted by plain ghci" do         parseShowTargets ["src/Foo.hs", "test/Bar.hs"]-            `shouldBe` ["src/Foo.hs", "test/Bar.hs"]--    it "strips the leading '*' marker for the active interactive target" do-        parseShowTargets ["*Main", "Foo.Bar"] `shouldBe` ["Main", "Foo.Bar"]--    it "strips ANSI escape sequences" do-        parseShowTargets ["\ESC[1mFoo.Bar\ESC[0m"] `shouldBe` ["Foo.Bar"]--    it "skips blank and whitespace-only lines" do-        parseShowTargets ["", "   ", "\t", "Real.Target"] `shouldBe` ["Real.Target"]--    it "returns empty list for empty input" do-        parseShowTargets [] `shouldBe` []+            @?= ["src/Foo.hs", "test/Bar.hs"]+    , testCase "strips the leading '*' marker for the active interactive target" do+        parseShowTargets ["*Main", "Foo.Bar"] @?= ["Main", "Foo.Bar"]+    , testCase "strips ANSI escape sequences" do+        parseShowTargets ["\ESC[1mFoo.Bar\ESC[0m"] @?= ["Foo.Bar"]+    , testCase "skips blank and whitespace-only lines" do+        parseShowTargets ["", "   ", "\t", "Real.Target"] @?= ["Real.Target"]+    , testCase "returns empty list for empty input" do+        parseShowTargets [] @?= []+    ]   --------------------------------------------------------------------------------@@ -418,30 +420,31 @@ -- failure with @\<no location info\>@ (it has no source span), and the load -- ends with @Failed, N modules loaded@. This output must still surface as an -- error diagnostic — otherwise the build is silently reported as clean.-testPluginLoadFailure :: Spec-testPluginLoadFailure = do+testPluginLoadFailure :: [TestTree]+testPluginLoadFailure =     -- Shape of the GHCi output from `cabal repl --enable-multi-repl` when an     -- executable loads a home-unit GHC plugin: the plugin package's modules     -- compile, then the unit using the plugin fails with a location-less error.-    let reloadOutput =-            [ "[3 of 5] Compiling My.Plugin       ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]"-            , "<no location info>: error:"-            , "    Could not load module \8216My.Plugin\8217."-            , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217."-            , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file."-            , "Use -v to see a list of the files searched for."-            , ""-            , "[5 of 5] Compiling Main            ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]"-            , "Failed, 4 modules loaded."-            ]-        result = collectResultCustom "/project" (parseReload reloadOutput) [] []--    it "surfaces the plugin load failure as an error diagnostic" do-        map (.severity) result.diagnostics `shouldContain` [SError]--    it "carries the plugin error message in the diagnostic title" do-        map (.title) result.diagnostics-            `shouldContain` ["Could not load module \8216My.Plugin\8217."]+    [ testCase "surfaces the plugin load failure as an error diagnostic" do+        assertBool "expected an error diagnostic"+            $ SError `elem` map (.severity) result.diagnostics+    , testCase "carries the plugin error message in the diagnostic title" do+        assertBool "expected the plugin error message in a diagnostic title"+            $ "Could not load module \8216My.Plugin\8217." `elem` map (.title) result.diagnostics+    ]+  where+    reloadOutput =+        [ "[3 of 5] Compiling My.Plugin       ( src/My/Plugin.hs, interpreted )[plugin-pkg-1.0.0-inplace]"+        , "<no location info>: error:"+        , "    Could not load module \8216My.Plugin\8217."+        , "It is a member of the hidden package \8216plugin-pkg-1.0.0\8217."+        , "Perhaps you need to add \8216plugin-pkg\8217 to the build-depends in your .cabal file."+        , "Use -v to see a list of the files searched for."+        , ""+        , "[5 of 5] Compiling Main            ( test/Tests.hs, interpreted )[app-pkg-0.1.0.0-inplace-test]"+        , "Failed, 4 modules loaded."+        ]+    result = collectResultCustom "/project" (parseReload reloadOutput) [] []   --------------------------------------------------------------------------------@@ -451,18 +454,20 @@ -- 'collectResult' is the safety net: GHCi can end a load with @Failed, …@ -- without emitting any error that carries a source span. The build must never -- read as clean in that case, so a synthetic error diagnostic is added.-testUnattributedFailure :: Spec-testUnattributedFailure = do-    describe "when the load failed but no error was located" $ it "adds a synthetic error" do-        let reloadOutput =-                [ "[1 of 2] Compiling Lib  ( src/Lib.hs, interpreted )"-                , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )"-                , "Failed, 1 module loaded."-                ]-            result = collectResult "/project" reloadOutput [] []-        map (.severity) result.diagnostics `shouldBe` [SError]--    it "does not duplicate a failure that already produced a located error" do+testUnattributedFailure :: [TestTree]+testUnattributedFailure =+    [ testGroup+        "when the load failed but no error was located"+        [ testCase "adds a synthetic error" do+            let reloadOutput =+                    [ "[1 of 2] Compiling Lib  ( src/Lib.hs, interpreted )"+                    , "[2 of 2] Compiling Main ( app/Main.hs, interpreted )"+                    , "Failed, 1 module loaded."+                    ]+                result = collectResult "/project" reloadOutput [] []+            map (.severity) result.diagnostics @?= [SError]+        ]+    , testCase "does not duplicate a failure that already produced a located error" do         let reloadOutput =                 [ "[1 of 1] Compiling Lib ( src/Lib.hs, interpreted )"                 , "src/Lib.hs:5:1: error: Oops"@@ -470,27 +475,29 @@                 ]             result = collectResult "/project" reloadOutput [] []         -- Only the real, located diagnostic — no synthetic one appended.-        map (.file) result.diagnostics `shouldBe` ["src/Lib.hs"]--    it "adds nothing for a successful load" do+        map (.file) result.diagnostics @?= ["src/Lib.hs"]+    , testCase "adds nothing for a successful load" do         let reloadOutput =                 [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"                 , "Ok, 1 module loaded."                 ]             result = collectResult "/project" reloadOutput [] []-        result.diagnostics `shouldBe` []--    describe "when 'Failed,' appears off the summary line" $ it "does not flag a clean build" do-        -- The load outcome lives on GHCi's single summary line-        -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a-        -- Template Haskell splice or top-level IO run while interpreting — can-        -- contain a line that happens to begin with "Failed,". That must not be-        -- mistaken for a failed load: the summary here is "Ok," so no synthetic-        -- error belongs.-        let reloadOutput =-                [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"-                , "Failed, retrying with fallback" -- printed by a TH splice-                , "Ok, 1 module loaded."-                ]-            result = collectResult "/project" reloadOutput [] []-        result.diagnostics `shouldBe` []+        result.diagnostics @?= []+    , testGroup+        "when 'Failed,' appears off the summary line"+        [ testCase "does not flag a clean build" do+            -- The load outcome lives on GHCi's single summary line+            -- ("Ok, …" / "Failed, …"). Output printed *during* the load — e.g. a+            -- Template Haskell splice or top-level IO run while interpreting — can+            -- contain a line that happens to begin with "Failed,". That must not be+            -- mistaken for a failed load: the summary here is "Ok," so no synthetic+            -- error belongs.+            let reloadOutput =+                    [ "[1 of 1] Compiling Main ( app/Main.hs, interpreted )"+                    , "Failed, retrying with fallback" -- printed by a TH splice+                    , "Ok, 1 module loaded."+                    ]+                result = collectResult "/project" reloadOutput [] []+            result.diagnostics @?= []+        ]+    ]

@@ -1,4 +1,4 @@-module Unit.Tricorder.Daemon.GhciSession.GhciProcessSpec (spec_GhciProcess) where+module Unit.Tricorder.Daemon.GhciSession.GhciProcessSpec (test_GhciProcess) where  import Atelier.Effects.Conc (runConc) import Atelier.Effects.Delay (runDelay)@@ -34,7 +34,8 @@     , stopProcess     , waitExitCode     )-import Test.Hspec+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?), (@?=))  import Atelier.Effects.Conc qualified as Conc import Atelier.Effects.Delay qualified as Delay@@ -49,6 +50,7 @@     , GhciProcessError (..)     , InterruptDecision (..)     , SessionState (..)+    , UnexpectedExit (..)     , decideInterrupt     , drainUntil     , execGhci@@ -56,16 +58,19 @@     )  -spec_GhciProcess :: Spec-spec_GhciProcess = do-    describe "decideInterrupt" testDecideInterrupt-    describe "drainUntil" testDrainUntil-    describe "execGhci" testExecGhciScope-    describe "execGhci (stale marker desync)" testExecGhciStaleMarker-    describe "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent-    describe "waitForBannerOrFail" testWaitForBannerOrFail-    describe "withProcessGroup (process group)" testWithProcessGroupCleanup-    describe "terminateProcessGroup (process group)" testTerminateProcessGroup+test_GhciProcess :: TestTree+test_GhciProcess =+    testGroup+        "GhciProcess"+        [ testGroup "decideInterrupt" testDecideInterrupt+        , testGroup "drainUntil" testDrainUntil+        , testGroup "execGhci" testExecGhciScope+        , testGroup "execGhci (stale marker desync)" testExecGhciStaleMarker+        , testGroup "execGhci (sync marker scope independence)" testSyncMarkerScopeIndependent+        , testGroup "waitForBannerOrFail" testWaitForBannerOrFail+        , testGroup "withProcessGroup (process group)" testWithProcessGroupCleanup+        , testGroup "terminateProcessGroup (process group)" testTerminateProcessGroup+        ]   -- | Mirrors the private 'markerFor' helper (not exported), using the same@@ -74,9 +79,9 @@ finishMarker n = "#~TRI-FINISH-" <> show n <> "~#"  -testDrainUntil :: Spec-testDrainUntil = do-    it "returns accumulated non-marker lines in order and stops at the marker" do+testDrainUntil :: [TestTree]+testDrainUntil =+    [ testCase "returns accumulated non-marker lines in order and stops at the marker" do         (r, w) <- Process.createPipe         (result, _msgs) <-             runEff@@ -87,9 +92,8 @@                     for_ ["line1", "line2", finishMarker 1, "line3"] (File.hPutTextLn w)                     File.hClose w                     drainUntil r (finishMarker 1) (\_ -> pure ())-        result `shouldBe` ["line1", "line2"]--    it "streams each non-marker line to onLine, in order, before returning" do+        result @?= ["line1", "line2"]+    , testCase "streams each non-marker line to onLine, in order, before returning" do         (r, w) <- Process.createPipe         seenRef <- newIORef []         (result, _msgs) <-@@ -102,10 +106,9 @@                     File.hClose w                     drainUntil r (finishMarker 2) (\l -> liftIO $ modifyIORef' seenRef (l :))         seen <- reverse <$> readIORef seenRef-        seen `shouldBe` ["a", "b", "c"]-        result `shouldBe` seen--    it "skips a stale marker with a different suffix and keeps draining" do+        seen @?= ["a", "b", "c"]+        result @?= seen+    , testCase "skips a stale marker with a different suffix and keeps draining" do         (r, w) <- Process.createPipe         (result, _msgs) <-             runEff@@ -119,28 +122,29 @@                     for_ ["before", finishMarker 5, "after", finishMarker 9] (File.hPutTextLn w)                     File.hClose w                     drainUntil r (finishMarker 9) (\_ -> pure ())-        result `shouldBe` ["before", "after"]--    it "throws UnexpectedExit with ALL accumulated lines (in order) on EOF, not just the last one" do-        (r, w) <- Process.createPipe-        (outcome, _msgs) <--            runEff-                . runWriter @[Message]-                . runLogWriter-                . runFile-                $ do-                    for_ ["first", "second", "third"] (File.hPutTextLn w)-                    File.hClose w -- EOF before the marker ever arrives-                    trySync (drainUntil r (finishMarker 1) (\_ -> pure ()))-        case outcome of-            Right ls -> expectationFailure ("expected UnexpectedExit, got: " <> show ls)-            Left ex -> case fromException ex of-                Just (UnexpectedExit m ls) -> do-                    m `shouldBe` finishMarker 1-                    ls `shouldBe` Just "first\nsecond\nthird"-                other -> expectationFailure ("expected UnexpectedExit, got: " <> show other)--    it "throws UnexpectedExit with no lines when EOF is reached immediately" do+        result @?= ["before", "after"]+    , testCase+        "throws UnexpectedExit with ALL accumulated lines (in order) on EOF, not just the last one"+        do+            (r, w) <- Process.createPipe+            (outcome, _msgs) <-+                runEff+                    . runWriter @[Message]+                    . runLogWriter+                    . runFile+                    $ do+                        for_ ["first", "second", "third"] (File.hPutTextLn w)+                        File.hClose w -- EOF before the marker ever arrives+                        trySync (drainUntil r (finishMarker 1) (\_ -> pure ()))+            case outcome of+                Right ls -> assertFailure ("expected UnexpectedExit, got: " <> show ls)+                Left ex -> case fromException ex of+                    Just (UnexpectedExit (MkUnexpectedExit m ls)) -> do+                        m @?= finishMarker 1+                        ls+                            @?= "Reached EOF before reading marker from GHCi.\nWas looking for marker '#~TRI-FINISH-1~#', but no such marker was found.\nAccumulated output from GHCi so far:\nfirst\nsecond\nthird"+                    other -> assertFailure ("expected UnexpectedExit, got: " <> show other)+    , testCase "throws UnexpectedExit with no lines when EOF is reached immediately" do         (r, w) <- Process.createPipe         (outcome, _msgs) <-             runEff@@ -151,14 +155,20 @@                     File.hClose w                     trySync (drainUntil r (finishMarker 1) (\_ -> pure ()))         case outcome of-            Right ls -> expectationFailure ("expected UnexpectedExit, got: " <> show ls)+            Right ls -> assertFailure ("expected UnexpectedExit, got: " <> show ls)             Left ex -> case fromException ex of-                Just (UnexpectedExit m ls) -> do-                    m `shouldBe` finishMarker 1-                    ls `shouldBe` Nothing-                other -> expectationFailure ("expected UnexpectedExit, got: " <> show other)--    it+                Just (UnexpectedExit (MkUnexpectedExit m ls)) -> do+                    m @?= finishMarker 1+                    let expected =+                            "Reached EOF before reading marker from GHCi.\nWas looking for marker '#~TRI-FINISH-1~#', but no such marker was found.\nGHCi returned no output before we reached what we believe is EOF.\nGot the following exception when attempting to read from GHCi:\n<file descriptor:"+                    (expected `T.isPrefixOf` ls)+                        @? ( "error message does not start with expected prefix\nExpected:\n"+                                <> show expected+                                <> "\nActual:\n"+                                <> show ls+                           )+                other -> assertFailure ("expected UnexpectedExit, got: " <> show other)+    , testCase         "logs an ERROR mentioning the missing marker and the exception when EOF is reached with no output"         do             (r, w) <- Process.createPipe@@ -171,12 +181,11 @@                         File.hClose w                         trySync (drainUntil r (finishMarker 3) (\_ -> pure ()))             case filter (\m -> m.severity == ERROR) msgs of-                [] -> expectationFailure "expected an ERROR log message"+                [] -> assertFailure "expected an ERROR log message"                 (logMsg : _) -> do-                    (finishMarker 3 `T.isInfixOf` logMsg.text) `shouldBe` True-                    ("GHCi returned no output" `T.isInfixOf` logMsg.text) `shouldBe` True--    it "logs an ERROR including the accumulated output when EOF is reached mid-output" do+                    (finishMarker 3 `T.isInfixOf` logMsg.text) @?= True+                    ("GHCi returned no output" `T.isInfixOf` logMsg.text) @?= True+    , testCase "logs an ERROR including the accumulated output when EOF is reached mid-output" do         (r, w) <- Process.createPipe         (_outcome, msgs) <-             runEff@@ -188,11 +197,12 @@                     File.hClose w                     trySync (drainUntil r (finishMarker 4) (\_ -> pure ()))         case filter (\m -> m.severity == ERROR) msgs of-            [] -> expectationFailure "expected an ERROR log message"+            [] -> assertFailure "expected an ERROR log message"             (logMsg : _) -> do-                (finishMarker 4 `T.isInfixOf` logMsg.text) `shouldBe` True-                ("oops-line-1" `T.isInfixOf` logMsg.text) `shouldBe` True-                ("oops-line-2" `T.isInfixOf` logMsg.text) `shouldBe` True+                (finishMarker 4 `T.isInfixOf` logMsg.text) @?= True+                ("oops-line-1" `T.isInfixOf` logMsg.text) @?= True+                ("oops-line-2" `T.isInfixOf` logMsg.text) @?= True+    ]   -- | Regression for the touch-during-reload desync. Interrupting a *Busy* GHCi@@ -202,9 +212,9 @@ -- returned *before its command ran* — surfacing as @All good. (0 modules)@ (or, -- on the other timing, a hang). 'execGhci' must skip markers that aren't its -- own and stop only on the marker it is waiting for.-testExecGhciStaleMarker :: Spec+testExecGhciStaleMarker :: [TestTree] testExecGhciStaleMarker =-    it "skips a stale leftover marker and returns the command's real output" do+    [ testCase "skips a stale leftover marker and returns the command's real output" do         (stdinR, stdinW) <- Process.createPipe         (stdoutR, stdoutW) <- Process.createPipe         (stderrR, stderrW) <- Process.createPipe@@ -249,7 +259,8 @@                     File.hClose stdinR                     pure r         _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())-        result `shouldBe` ["out-line", "err-line"]+        result @?= ["out-line", "err-line"]+    ]   -- | Root-cause regression for the "stuck Building…" stall. A SIGINT-interrupted@@ -262,9 +273,9 @@ -- emptied scope), one per stream, with no bare names or operators. -- -- We assert on exactly what 'execGhci' writes to GHCi's stdin.-testSyncMarkerScopeIndependent :: Spec+testSyncMarkerScopeIndependent :: [TestTree] testSyncMarkerScopeIndependent =-    it "writes the finish marker using only fully-qualified names (no bare putStrLn / >>)" do+    [ testCase "writes the finish marker using only fully-qualified names (no bare putStrLn / >>)" do         (stdinR, stdinW) <- Process.createPipe         (stdoutR, stdoutW) <- Process.createPipe         (stderrR, stderrW) <- Process.createPipe@@ -309,9 +320,10 @@                     readAll []         _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())         let blob = T.intercalate "\n" written-        (" >> " `T.isInfixOf` blob) `shouldBe` False-        ("System.IO.hPutStrLn System.IO.stdout" `T.isInfixOf` blob) `shouldBe` True-        ("System.IO.hPutStrLn System.IO.stderr" `T.isInfixOf` blob) `shouldBe` True+        (" >> " `T.isInfixOf` blob) @?= False+        ("System.IO.hPutStrLn System.IO.stdout" `T.isInfixOf` blob) @?= True+        ("System.IO.hPutStrLn System.IO.stderr" `T.isInfixOf` blob) @?= True+    ]   -- | Regression: when the build command exits before printing a GHCi banner,@@ -320,9 +332,9 @@ -- lines as soon as the process exited (it waited on 'waitExitCode'), racing -- the concurrent stderr drain — so a burst of error lines still buffered in -- the pipe was truncated, and the real cabal/build failure was lost.-testWaitForBannerOrFail :: Spec+testWaitForBannerOrFail :: [TestTree] testWaitForBannerOrFail =-    it "captures the full stderr output when the command exits before the banner" do+    [ testCase "captures the full stderr output when the command exits before the banner" do         let lineCount = 200 :: Int             lastLine = "err line " <> show lineCount         -- The banner and error streams are pipes we drive ourselves, so the@@ -352,12 +364,13 @@                         File.hClose errW                     trySync (waitForBannerOrFail (5 :: Second) bannerOut errR)         case result of-            Right () -> expectationFailure "expected waitForBannerOrFail to throw a startup error"+            Right () -> assertFailure "expected waitForBannerOrFail to throw a startup error"             Left ex -> case fromException ex of                 Just (StartupFailed msg) ->-                    (lastLine `T.isInfixOf` msg) `shouldBe` True+                    (lastLine `T.isInfixOf` msg) @?= True                 other ->-                    expectationFailure ("expected StartupFailed, got: " <> show other)+                    assertFailure ("expected StartupFailed, got: " <> show other)+    ]   -- | Regression for orphaned/zombie build subprocesses on restart and shutdown.@@ -368,9 +381,9 @@ -- gone. We simulate it with a leader that forks a long-lived child sharing its -- group and exits on stdin input (mirroring @:quit@); after 'withProcessGroup' -- returns, the child must be gone.-testWithProcessGroupCleanup :: Spec+testWithProcessGroupCleanup :: [TestTree] testWithProcessGroupCleanup =-    it "terminates the whole group on exit, even after the leader has exited" do+    [ testCase "terminates the whole group on exit, even after the leader has exited" do         childPidRef <- newIORef (Nothing :: Maybe Int)         let scenario =                 runEff@@ -393,15 +406,16 @@         -- assertion, never as a hang that stalls the whole suite.         outcome <- System.Timeout.timeout (8_000_000) scenario         case outcome of-            Nothing -> expectationFailure "test timed out (process did not settle)"+            Nothing -> assertFailure "test timed out (process did not settle)"             Just () ->                 readIORef childPidRef >>= \case-                    Nothing -> expectationFailure "could not capture the child pid"+                    Nothing -> assertFailure "could not capture the child pid"                     Just childPid -> do                         died <- waitForProcessDeath childPid                         -- Never leak the child if the assertion fails.                         ignoring (signalProcess sigKILL (fromIntegral childPid))-                        died `shouldBe` True+                        died @?= True+    ]   where     procConfig =         setStdin createPipe@@ -413,9 +427,9 @@ -- | 'terminateProcessGroup' must kill the whole group when called mid-flight -- (the leader still alive) — the explicit early-termination path the test -- runner uses to abort a one-shot @cabal repl test:…@ from another thread.-testTerminateProcessGroup :: Spec+testTerminateProcessGroup :: [TestTree] testTerminateProcessGroup =-    it "kills the whole group, not just the leader, mid-flight" do+    [ testCase "kills the whole group, not just the leader, mid-flight" do         outcome <- System.Timeout.timeout (8_000_000) do             p <-                 startProcess@@ -428,15 +442,15 @@             case parsePid childLine of                 Nothing -> do                     ignoring (stopProcess p)-                    expectationFailure ("could not parse child pid from: " <> show childLine)-                    pure False+                    assertFailure ("could not parse child pid from: " <> show childLine)                 Just childPid -> do                     runEff . runProcessIO $ terminateProcessGroup (RunningProcess p)                     died <- waitForProcessDeath childPid                     -- Never leak the child if the assertion fails.                     ignoring (signalProcess sigKILL (fromIntegral childPid))                     pure died-        outcome `shouldBe` Just True+        outcome @?= Just True+    ]   -- | Parse a pid printed on its own line (tolerating surrounding whitespace).@@ -464,24 +478,22 @@             `catch` \(_ :: IOException) -> pure False  -testDecideInterrupt :: Spec-testDecideInterrupt = do+testDecideInterrupt :: [TestTree]+testDecideInterrupt =     -- Regression: an idle GHCi must not be SIGINT'd, since the matching     -- sync-marker write would leave a stale marker line in stdout/stderr     -- that the next 'execGhci' drain would match instead of the fresh one,     -- desyncing the protocol and reporting "0 modules" or hanging.-    it "is a no-op when the session is Idle" do-        decideInterrupt (Idle 7) `shouldBe` (Idle 7, NoOpIdle)--    it "preserves the counter for any Idle state" do-        decideInterrupt (Idle 0) `shouldBe` (Idle 0, NoOpIdle)-        decideInterrupt (Idle 42) `shouldBe` (Idle 42, NoOpIdle)--    it "advances to Idle (n+1) and emits SendInterruptFor n when Busy" do-        decideInterrupt (Busy 7) `shouldBe` (Idle 8, SendInterruptFor 7)--    it "advances correctly from Busy 0" do-        decideInterrupt (Busy 0) `shouldBe` (Idle 1, SendInterruptFor 0)+    [ testCase "is a no-op when the session is Idle" do+        decideInterrupt (Idle 7) @?= (Idle 7, NoOpIdle)+    , testCase "preserves the counter for any Idle state" do+        decideInterrupt (Idle 0) @?= (Idle 0, NoOpIdle)+        decideInterrupt (Idle 42) @?= (Idle 42, NoOpIdle)+    , testCase "advances to Idle (n+1) and emits SendInterruptFor n when Busy" do+        decideInterrupt (Busy 7) @?= (Idle 8, SendInterruptFor 7)+    , testCase "advances correctly from Busy 0" do+        decideInterrupt (Busy 0) @?= (Idle 1, SendInterruptFor 0)+    ]   -- | Pins down the 'Conc.scoped' fix in 'execGhci': when the drain forks@@ -496,13 +508,13 @@ -- ambient scope is torn down — siblings die, the whole builder cycle -- unwinds, and the daemon ends up in the "Restarting builder..." state -- the user observed.-testExecGhciScope :: Spec+testExecGhciScope :: [TestTree] testExecGhciScope =     -- Spawn a real subprocess that exits immediately ('true'). Its     -- stdout/stderr pipes EOF as soon as the child exits, which makes     -- 'drainUntil' inside 'execGhci' throw 'UnexpectedExit' — exactly the     -- mid-command termination path the fix exists to handle.-    it "contains drain exceptions inside its own scope so siblings survive" do+    [ testCase "contains drain exceptions inside its own scope so siblings survive" do         p <-             startProcess                 $ setStdin createPipe@@ -550,7 +562,8 @@         -- subprocess has long since exited; just swallow the cleanup error.         _ <- (Right <$> stopProcess p) `catch` \(_ :: SomeException) -> pure (Left ())         siblingDone <- readIORef siblingDoneRef-        siblingDone `shouldBe` True+        siblingDone @?= True         case result of+            Right _ -> assertFailure "expected execGhci to raise UnexpectedExit"             Left _ -> pure ()-            Right _ -> expectationFailure "expected execGhci to raise UnexpectedExit"+    ]

@@ -1,10 +1,11 @@-module Unit.Tricorder.Daemon.GhciSessionSpec (spec_GhciSession) where+module Unit.Tricorder.Daemon.GhciSessionSpec (test_GhciSession) where  import Atelier.Effects.Publishing.Pub (Pub) import Control.Exception (ErrorCall (..)) import Effectful (IOE, runEff) import Effectful.Exception (try)-import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))  import Atelier.Effects.Publishing.Pub qualified as Pub import Data.Map.Strict qualified as Map@@ -19,79 +20,86 @@     , withGhci     ) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..), Repl (..))+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.Stage (Stage (..))  -spec_GhciSession :: Spec-spec_GhciSession = do-    describe "runGhciSessionScripted" testScripted+test_GhciSession :: TestTree+test_GhciSession =+    testGroup+        "GhciSession"+        [ testGroup "runGhciSessionScripted" testScripted+        ]   -------------------------------------------------------------------------------- -- Scripted interpreter tests -------------------------------------------------------------------------------- -testScripted :: Spec-testScripted = do-    describe "withGhci" do-        describe "initial load" do-            it "returns scripted messages" do+testScripted :: [TestTree]+testScripted =+    [ testGroup+        "withGhci"+        [ testGroup+            "initial load"+            [ testCase "returns scripted messages" do                 LoadResult {diagnostics = msgs} <-                     runScripted [simpleResult [errMsg]]                         $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial-                msgs `shouldBe` [errMsg]--            it "returns empty list when scripted result has no messages" do+                msgs @?= [errMsg]+            , testCase "returns empty list when scripted result has no messages" do                 LoadResult {diagnostics = msgs} <-                     runScripted [simpleResult []]                         $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial-                msgs `shouldBe` []--            it "throws when scripted result is Left" do+                msgs @?= []+            , testCase "throws when scripted result is Left" do                 result <-                     runScripted [Left (toException boom)]                         $ try @ErrorCall                         $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial-                result `shouldBe` Left boom--        describe "reloading" do-            it "returns scripted messages" do+                result @?= Left boom+            ]+        , testGroup+            "reloading"+            [ testCase "returns scripted messages" do                 LoadResult {diagnostics = msgs} <-                     runScripted [simpleResult [warnMsg], simpleResult [errMsg]]                         $ withGhci cmd (ProjectRoot "/") \_ controls -> controls.reload-                msgs `shouldBe` [errMsg]--            it "throws when scripted result is Left" do+                msgs @?= [errMsg]+            , testCase "throws when scripted result is Left" do                 result <-                     runScripted [Left (toException boom)]                         $ try @ErrorCall                         $ withGhci cmd (ProjectRoot "/") \_ controls -> controls.reload-                result `shouldBe` Left boom--    describe "sequencing" do-        it "consumes results in order across mixed operations" do+                result @?= Left boom+            ]+        ]+    , testGroup+        "sequencing"+        [ testCase "consumes results in order across mixed operations" do             (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do                 withGhci cmd (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do                     LoadResult {diagnostics = b} <- controls.reload                     pure (a, b)-            a `shouldBe` [errMsg]-            b `shouldBe` [warnMsg]--        it "recover scenario: error then success" do+            a @?= [errMsg]+            b @?= [warnMsg]+        , testCase "recover scenario: error then success" do             result <- runScripted [Left (toException boom), simpleResult []] do                 r1 <- try @ErrorCall $ withGhci cmd (ProjectRoot "/") \i _ -> pure i                 LoadResult {diagnostics = r2} <- withGhci cmd (ProjectRoot "/") \i _ -> pure i                 pure (r1, r2)-            fst result `shouldSatisfy` isLeft-            snd result `shouldBe` []+            assertBool "expected Left" $ isLeft (fst result)+            snd result @?= []+        ]+    ]   -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- -cmd :: Command-cmd = Command Cabal [] []+cmd :: RenderedCommand 'Build+cmd = RenderedCommand "cabal repl lib:foo"   boom :: ErrorCall

@@ -1,10 +1,12 @@-module Unit.Tricorder.Daemon.TestRunnerSpec (spec_TestRunner) where+module Unit.Tricorder.Daemon.TestRunnerSpec (test_TestRunner) where  import Control.Exception (ErrorCall (..))+import Data.Default (def) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Exception (try)-import Test.Hspec+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))  import Tricorder.Daemon.TestRunner     ( GhciOutcome (..)@@ -12,138 +14,156 @@     , detectOutcome     , runTestSuite     )-import Tricorder.Session.Command (Repl (..))-import Tricorder.Session.Target (Target (..))-import Tricorder.Session.TestTarget (TestTarget (..))+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.Stage.Test.Command (RenderedTestCommand (..)) import Tricorder.Session.TestTimeout (TestTimeout (..))  import Tricorder.Build.Test qualified as Test import Tricorder.Daemon.TestRunner qualified as TestRunner+import Tricorder.Session.Stage qualified as Stage  -spec_TestRunner :: Spec-spec_TestRunner = do-    describe "detectOutcome" testDetectOutcome-    describe "runScripted" testScripted+test_TestRunner :: TestTree+test_TestRunner =+    testGroup+        "TestRunner"+        [ testGroup "detectOutcome" testDetectOutcome+        , testGroup "runScripted" testScripted+        ]   -------------------------------------------------------------------------------- -- detectOutcome tests -------------------------------------------------------------------------------- -testDetectOutcome :: Spec-testDetectOutcome = do-    describe "no exception line" do-        it "treats empty output as pass" do-            detectOutcome "" `shouldBe` GhciPassed--        it "treats output with no exception as pass" do-            detectOutcome "2 examples, 0 failures\n" `shouldBe` GhciPassed--        it "does not match 'ExitSuccess' without the exception prefix" do-            detectOutcome "ExitSuccess\n" `shouldBe` GhciPassed--    describe "ExitSuccess" do-        it "detects ExitSuccess as pass" do-            detectOutcome "*** Exception: ExitSuccess\n" `shouldBe` GhciPassed--        it "detects ExitSuccess anywhere in output" do+testDetectOutcome :: [TestTree]+testDetectOutcome =+    [ testGroup+        "no exception line"+        [ testCase "treats empty output as pass" do+            detectOutcome "" @?= GhciPassed+        , testCase "treats output with no exception as pass" do+            detectOutcome "2 examples, 0 failures\n" @?= GhciPassed+        , testCase "does not match 'ExitSuccess' without the exception prefix" do+            detectOutcome "ExitSuccess\n" @?= GhciPassed+        ]+    , testGroup+        "ExitSuccess"+        [ testCase "detects ExitSuccess as pass" do+            detectOutcome "*** Exception: ExitSuccess\n" @?= GhciPassed+        , testCase "detects ExitSuccess anywhere in output" do             detectOutcome "All tests passed\n*** Exception: ExitSuccess\n"-                `shouldBe` GhciPassed--    describe "ExitFailure" do-        it "detects ExitFailure 1 as fail" do+                @?= GhciPassed+        ]+    , testGroup+        "ExitFailure"+        [ testCase "detects ExitFailure 1 as fail" do             detectOutcome "1 failure\n*** Exception: ExitFailure 1\n"-                `shouldBe` GhciFailed--        it "detects ExitFailure with any exit code as fail" do-            detectOutcome "*** Exception: ExitFailure 42\n" `shouldBe` GhciFailed--        it "detects ExitFailure anywhere in output" do+                @?= GhciFailed+        , testCase "detects ExitFailure with any exit code as fail" do+            detectOutcome "*** Exception: ExitFailure 42\n" @?= GhciFailed+        , testCase "detects ExitFailure anywhere in output" do             detectOutcome "Some output\n*** Exception: ExitFailure 1\nMore output\n"-                `shouldBe` GhciFailed--    describe "other exception" do-        it "classifies unknown exception as error with message" do+                @?= GhciFailed+        ]+    , testGroup+        "other exception"+        [ testCase "classifies unknown exception as error with message" do             detectOutcome "*** Exception: SomeException \"oops\"\n"-                `shouldBe` GhciCrashed "SomeException \"oops\""--        it "trims trailing whitespace from the error message" do+                @?= GhciCrashed "SomeException \"oops\""+        , testCase "trims trailing whitespace from the error message" do             detectOutcome "*** Exception: Crashed  \n"-                `shouldBe` GhciCrashed "Crashed"--    describe "compile failure (no exception line, but GHC errors present)" do-        it "flags ':main not in scope' as crashed" do+                @?= GhciCrashed "Crashed"+        ]+    , testGroup+        "compile failure (no exception line, but GHC errors present)"+        [ testCase "flags ':main not in scope' as crashed" do             detectOutcome "<interactive>:1:1: error: [GHC-76037] Not in scope: 'main'\n"-                `shouldBe` GhciCrashed+                @?= GhciCrashed                     "<interactive>:1:1: error: [GHC-76037] Not in scope: 'main'"--        it "flags a source-file compile error as crashed" do+        , testCase "flags a source-file compile error as crashed" do             detectOutcome "src/Foo.hs:42:5: error: Variable not in scope: foo\n"-                `shouldBe` GhciCrashed "src/Foo.hs:42:5: error: Variable not in scope: foo"--        it "reports the first error line when multiple are present" do+                @?= GhciCrashed "src/Foo.hs:42:5: error: Variable not in scope: foo"+        , testCase "reports the first error line when multiple are present" do             detectOutcome                 "src/Foo.hs:42:5: error: Variable not in scope: foo\nsrc/Bar.hs:10:1: error: Parse error\n"-                `shouldBe` GhciCrashed "src/Foo.hs:42:5: error: Variable not in scope: foo"--        it "prefers exit exception over compile-error heuristic when both appear" do+                @?= GhciCrashed "src/Foo.hs:42:5: error: Variable not in scope: foo"+        , testCase "prefers exit exception over compile-error heuristic when both appear" do             -- A real failing run could plausibly mention 'error:' in its             -- captured output (e.g. logged messages); the ExitFailure line             -- still wins.             detectOutcome "log: error: something happened\n*** Exception: ExitFailure 1\n"-                `shouldBe` GhciFailed+                @?= GhciFailed+        ]+    ]   -------------------------------------------------------------------------------- -- Scripted interpreter tests -------------------------------------------------------------------------------- -testScripted :: Spec-testScripted = do-    it "returns scripted TestRun" do+testScripted :: [TestTree]+testScripted =+    [ testCase "returns scripted TestRun" do         result <-             runScripted [Right passingRun]-                $ runTestSuite noProgress Nothing Cabal testTimeout-                $ mkTestTarget "test:foo"-        result `shouldBe` passingRun--    it "ignores the target name argument" do+                $ runTestSuite noProgress testTimeout+                $ mkResolved+                $ RenderedCommand+                $ "cabal repl test:foo"+        result @?= passingRun+    , testCase "ignores the target name argument" do         result <-             runScripted [Right failingRun]-                $ runTestSuite noProgress Nothing Cabal testTimeout-                $ mkTestTarget "test:anything"-        result `shouldBe` failingRun--    it "throws when scripted result is Left" do+                $ runTestSuite noProgress testTimeout+                $ mkResolved+                $ RenderedCommand+                $ "cabal repl test:anything"+        result @?= failingRun+    , testCase "throws when scripted result is Left" do         result <-             runScripted [Left (toException boom)]                 $ try @ErrorCall-                $ runTestSuite noProgress Nothing Cabal testTimeout-                $ mkTestTarget "test:foo"-        result `shouldBe` Left boom--    describe "sequencing" do-        it "consumes results in order across multiple calls" do+                $ runTestSuite noProgress testTimeout+                $ mkResolved+                $ RenderedCommand+                $ "cabal repl test:foo"+        result @?= Left boom+    , testGroup+        "sequencing"+        [ testCase "consumes results in order across multiple calls" do             (a, b) <- runScripted [Right passingRun, Right failingRun] do-                a <- runTestSuite noProgress Nothing Cabal testTimeout $ mkTestTarget "test:foo"-                b <- runTestSuite noProgress Nothing Cabal testTimeout $ mkTestTarget "test:bar"+                a <-+                    runTestSuite noProgress testTimeout+                        $ mkResolved+                        $ RenderedCommand+                        $ "cabal repl test:foo"+                b <-+                    runTestSuite noProgress testTimeout+                        $ mkResolved+                        $ RenderedCommand+                        $ "cabal repl test:bar"                 pure (a, b)-            a `shouldBe` passingRun-            b `shouldBe` failingRun--        it "recover scenario: error then success" do+            a @?= passingRun+            b @?= failingRun+        , testCase "recover scenario: error then success" do             result <- runScripted [Left (toException boom), Right passingRun] do                 r1 <-                     try @ErrorCall-                        $ runTestSuite noProgress Nothing Cabal testTimeout-                        $ mkTestTarget "test:foo"+                        $ runTestSuite noProgress testTimeout+                        $ mkResolved+                        $ RenderedCommand+                        $ "cabal repl test:foo"                 r2 <--                    runTestSuite noProgress Nothing Cabal testTimeout-                        $ mkTestTarget "test:bar"+                    runTestSuite noProgress testTimeout+                        $ mkResolved+                        $ RenderedCommand+                        $ "cabal repl test:bar"                 pure (r1, r2)-            fst result `shouldBe` Left boom-            snd result `shouldBe` passingRun+            fst result @?= Left boom+            snd result @?= passingRun+        ]+    ]   --------------------------------------------------------------------------------@@ -180,8 +200,8 @@ runScripted results = runEff . runConcurrent . TestRunner.runScripted results  -mkTestTarget :: Text -> TestTarget-mkTestTarget = TestTarget . Bare+mkResolved :: RenderedCommand 'Stage.Test -> RenderedTestCommand+mkResolved cmd = RenderedTestCommand cmd def   testTimeout :: TestTimeout

@@ -1,9 +1,10 @@-module Unit.Tricorder.Daemon.WatchSpec (spec_Watch) where+module Unit.Tricorder.Daemon.WatchSpec (test_Watch) where  import Atelier.Effects.FileWatcher (FileEvent (..), matchesAny) import Effectful (runEff) import Effectful.Writer.Static.Shared (execWriter, runWriter)-import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Text.Regex.TDFA.ReadRegex (parseRegex)  import Atelier.Effects.Publishing.Pub qualified as Pub@@ -20,21 +21,30 @@ import Tricorder.Daemon.Watch qualified as Watch  -spec_Watch :: Spec-spec_Watch = do-    describe "publishChange" testPublishChange-    describe "specs" testSpecs+test_Watch :: TestTree+test_Watch =+    testGroup+        "Watch"+        [ testGroup "publishChange" testPublishChange+        , testGroup "specs" testSpecs+        ]  -testPublishChange :: Spec-testPublishChange = do-    describe "with non-cabal file change" $ it "should publish SourceChangeDetected" do-        (_, sourceChanges) <- runTest "foo"-        sourceChanges `shouldMatchList` [SourceChangeDetected "foo" Modified]--    describe "with cabal file change" $ it "should publish CabalChangeDetected" do-        (cabalChanges, _) <- runTest "foo.cabal"-        cabalChanges `shouldMatchList` [CabalChangeDetected "foo.cabal" Modified]+testPublishChange :: [TestTree]+testPublishChange =+    [ testGroup+        "with non-cabal file change"+        [ testCase "should publish SourceChangeDetected" do+            (_, sourceChanges) <- runTest "foo"+            sourceChanges @?= [SourceChangeDetected "foo" Modified]+        ]+    , testGroup+        "with cabal file change"+        [ testCase "should publish CabalChangeDetected" do+            (cabalChanges, _) <- runTest "foo.cabal"+            cabalChanges @?= [CabalChangeDetected "foo.cabal" Modified]+        ]+    ]   where     runTest =         runEff@@ -46,105 +56,100 @@             . (`WatchedFile` Modified)  -testSpecs :: Spec-testSpecs = do-    describe "source watches" do-        it "matches .hs files in configured watch dirs" do+testSpecs :: [TestTree]+testSpecs =+    [ testGroup+        "source watches"+        [ testCase "matches .hs files in configured watch dirs" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs ["/proj/src"])-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True--        it "does not match non-.hs files" do+            matchesAny watches "/proj/src/Foo.hs" @?= True+        , testCase "does not match non-.hs files" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs ["/proj/src"])-            matchesAny watches "/proj/src/Foo.txt" `shouldBe` False--        it "excludes paths containing dist-newstyle" do+            matchesAny watches "/proj/src/Foo.txt" @?= False+        , testCase "excludes paths containing dist-newstyle" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs ["/proj/src"])-            matchesAny watches "/proj/src/dist-newstyle/Foo.hs" `shouldBe` False--        it "excludes paths matching an exclusion pattern" do+            matchesAny watches "/proj/src/dist-newstyle/Foo.hs" @?= False+        , testCase "excludes paths matching an exclusion pattern" do             let pat = parsePattern "vendor"                 watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [pat])                         (WatchDirs ["/proj/src"])-            matchesAny watches "/proj/src/vendor/Foo.hs" `shouldBe` False-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True--        it "matches .hs files across multiple watch dirs" do+            matchesAny watches "/proj/src/vendor/Foo.hs" @?= False+            matchesAny watches "/proj/src/Foo.hs" @?= True+        , testCase "matches .hs files across multiple watch dirs" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs ["/proj/src", "/proj/test"])-            matchesAny watches "/proj/src/Foo.hs" `shouldBe` True-            matchesAny watches "/proj/test/FooSpec.hs" `shouldBe` True--        -- Second line of defense: 'cabalWatches' registers the whole project-        -- root, and 'deduplicateDirs' collapses the narrow source dirs into it,-        -- so the OS watches the entire repo recursively. 'matchesAny' is what-        -- re-scopes events back to the configured dirs — a .hs file in a sibling-        -- package must not match.-        it "does not match a .hs file in a sibling package outside the watch dirs" do+            matchesAny watches "/proj/src/Foo.hs" @?= True+            matchesAny watches "/proj/test/FooSpec.hs" @?= True+        , -- Second line of defense: 'cabalWatches' registers the whole project+          -- root, and 'deduplicateDirs' collapses the narrow source dirs into it,+          -- so the OS watches the entire repo recursively. 'matchesAny' is what+          -- re-scopes events back to the configured dirs — a .hs file in a sibling+          -- package must not match.+          testCase "does not match a .hs file in a sibling package outside the watch dirs" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs ["/proj/pkg-a/src"])-            matchesAny watches "/proj/pkg-a/src/Foo.hs" `shouldBe` True-            matchesAny watches "/proj/pkg-b/src/Foo.hs" `shouldBe` False--    describe "cabal watches" do-        it "matches .cabal files under project root" do+            matchesAny watches "/proj/pkg-a/src/Foo.hs" @?= True+            matchesAny watches "/proj/pkg-b/src/Foo.hs" @?= False+        ]+    , testGroup+        "cabal watches"+        [ testCase "matches .cabal files under project root" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs [])-            matchesAny watches "/proj/foo.cabal" `shouldBe` True--        it "matches cabal.project under project root" do+            matchesAny watches "/proj/foo.cabal" @?= True+        , testCase "matches cabal.project under project root" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs [])-            matchesAny watches "/proj/cabal.project" `shouldBe` True--        it "matches package.yaml under project root" do+            matchesAny watches "/proj/cabal.project" @?= True+        , testCase "matches package.yaml under project root" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs [])-            matchesAny watches "/proj/package.yaml" `shouldBe` True--        it "does not match non-cabal files" do+            matchesAny watches "/proj/package.yaml" @?= True+        , testCase "does not match non-cabal files" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs [])-            matchesAny watches "/proj/README.md" `shouldBe` False--        it "excludes cabal files under dist-newstyle" do+            matchesAny watches "/proj/README.md" @?= False+        , testCase "excludes cabal files under dist-newstyle" do             let watches =                     Watch.specs                         (ProjectRoot "/proj")                         (WatchExclusionPatterns [])                         (WatchDirs [])-            matchesAny watches "/proj/dist-newstyle/foo.cabal" `shouldBe` False+            matchesAny watches "/proj/dist-newstyle/foo.cabal" @?= False+        ]+    ]   where     parsePattern p = fromRight (error . toText $ "bad test pattern: " <> p) (parseRegex p)

@@ -1,23 +1,37 @@-module Unit.Tricorder.Session.CabalFileSpec (spec_CabalFile) where+module Unit.Tricorder.Session.CabalFileSpec (test_CabalFile) where  import Atelier.Effects.Env (runEnvConst) import Atelier.Effects.FileSystem (runFileSystemState)+import Atelier.Effects.Input (runInputConst)+import Atelier.Effects.Log (runLogNoOp) import Effectful (runPureEff) import Effectful.Reader.Static (runReader) import Effectful.State.Static.Shared (evalState)-import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))  import Atelier.Effects.FileSystem.Glob qualified as Glob import Data.Map.Strict qualified as Map  import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.CabalFile (discoverCabalFiles)+import Tricorder.Session.CabalFile+    ( CabalFile (..)+    , discoverCabalPackages+    , discoverStackPackages+    , readProjectFile+    )+import Tricorder.Session.StackProject (StackProject (..)) import Unit.Tricorder.Session.Helpers (cabalFixture, multiPackageCabalFs, multiPackageFs)  -spec_CabalFile :: Spec-spec_CabalFile = do-    describe "discoverCabalFiles" testDiscoverCabalFiles+test_CabalFile :: TestTree+test_CabalFile =+    testGroup+        "CabalFile"+        [ testGroup "discoverCabalPackages" testDiscoverCabalPackages+        , testGroup "discoverStackPackages" testDiscoverStackPackages+        , testGroup "readProjectFile" testReadProjectFile+        ]   -- | Pins the discovery contract: a @cabal.project@ (or @.local@/@.freeze@@@ -25,109 +39,118 @@ -- otherwise the @.cabal@ files in the project root are used. Falls back -- further to @$HOME/.cabal/config@'s @packages:@ stanza if none of the -- project-root files exist.-testDiscoverCabalFiles :: Spec-testDiscoverCabalFiles = do-    describe "when there is no cabal.project" do-        it "finds the .cabal files in the project root" do+testDiscoverCabalPackages :: [TestTree]+testDiscoverCabalPackages =+    [ testGroup+        "when there is no cabal.project"+        [ testCase "finds the .cabal files in the project root" do             let actual =                     runDiscovery (Map.singleton "/myapp.cabal" cabalFixture) []-                        $ discoverCabalFiles-            actual `shouldBe` ["/myapp.cabal"]--        it "returns no files when the root has no cabal file" do-            let actual = runDiscovery mempty [] discoverCabalFiles-            actual `shouldBe` []--    describe "when there is a multi-package cabal.project" do-        it "resolves each listed package to its .cabal (regression: was root-only)" do-            let actual = runDiscovery multiPackageFs [] discoverCabalFiles-            actual `shouldBe` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]--    describe "priority among cabal.project.local, cabal.project.freeze, and cabal.project" do-        it "prefers cabal.project.local over cabal.project" do+                        $ discoverCabalPackages+            actual @?= Right ["/myapp.cabal"]+        , testCase "returns no files when the root has no cabal file" do+            let actual = runDiscovery mempty [] discoverCabalPackages+            actual @?= Right []+        ]+    , testGroup+        "when there is a multi-package cabal.project"+        [ testCase "resolves each listed package to its .cabal (regression: was root-only)" do+            let actual = runDiscovery multiPackageFs [] discoverCabalPackages+            actual @?= Right ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+        ]+    , testGroup+        "priority among cabal.project.local, cabal.project.freeze, and cabal.project"+        [ testCase "prefers cabal.project.local over cabal.project" do             let fs =                     Map.fromList                         [ ("/cabal.project.local", "packages: pkg-a\n")                         , ("/cabal.project", "packages: pkg-b\n")                         ]                         `Map.union` multiPackageCabalFs-                actual = runDiscovery fs [] discoverCabalFiles-            actual `shouldBe` ["/pkg-a/pkg-a.cabal"]--        it "prefers cabal.project.freeze over cabal.project" do+                actual = runDiscovery fs [] discoverCabalPackages+            actual @?= Right ["/pkg-a/pkg-a.cabal"]+        , testCase "prefers cabal.project.freeze over cabal.project" do             let fs =                     Map.fromList                         [ ("/cabal.project.freeze", "packages: pkg-a\n")                         , ("/cabal.project", "packages: pkg-b\n")                         ]                         `Map.union` multiPackageCabalFs-                actual = runDiscovery fs [] discoverCabalFiles-            actual `shouldBe` ["/pkg-a/pkg-a.cabal"]--        describe "when a higher-priority file lists no packages" do-            it "falls through to the next file in priority order" do+                actual = runDiscovery fs [] discoverCabalPackages+            actual @?= Right ["/pkg-a/pkg-a.cabal"]+        , testGroup+            "when a higher-priority file lists no packages"+            [ testCase "falls through to the next file in priority order" do                 let fs =                         Map.fromList                             [ ("/cabal.project.local", "tests: True\n")                             , ("/cabal.project", "packages: pkg-b\n")                             ]                             `Map.union` multiPackageCabalFs-                    actual = runDiscovery fs [] discoverCabalFiles-                actual `shouldBe` ["/pkg-b/pkg-b.cabal"]--    describe "packages: entry resolution" do-        it "uses a direct .cabal path entry verbatim, without scanning a directory" do+                    actual = runDiscovery fs [] discoverCabalPackages+                actual @?= Right ["/pkg-b/pkg-b.cabal"]+            ]+        ]+    , testGroup+        "packages: entry resolution"+        [ testCase "uses a direct .cabal path entry verbatim, without scanning a directory" do             let fs = Map.singleton "/cabal.project" "packages: sub/foo.cabal\n"-                actual = runDiscovery fs [] discoverCabalFiles-            actual `shouldBe` ["/sub/foo.cabal"]--        it "expands a glob entry matching .cabal files directly" do+                actual = runDiscovery fs [] discoverCabalPackages+            actual @?= Right ["/sub/foo.cabal"]+        , testCase "expands a glob entry matching .cabal files directly" do             let fs = Map.singleton "/cabal.project" "packages: */*.cabal\n"                 script = [Glob.NextGlobDir1 ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]]-                actual = runDiscoveryGlob fs [] script discoverCabalFiles-            actual `shouldMatchList` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]--        it "expands a glob entry matching package directories" do+                actual = runDiscoveryGlob fs [] script discoverCabalPackages+            fromRight [] actual @?= ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+        , testCase "expands a glob entry matching package directories" do             let fs =                     Map.singleton "/cabal.project" "packages: */\n"                         `Map.union` multiPackageCabalFs                 script = [Glob.NextGlobDir1 ["/pkg-a", "/pkg-b"]]-                actual = runDiscoveryGlob fs [] script discoverCabalFiles-            actual `shouldMatchList` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]--        it "returns no files when a glob entry matches nothing" do+                actual = runDiscoveryGlob fs [] script discoverCabalPackages+            fromRight [] actual @?= ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+        , testCase "returns no files when a glob entry matches nothing" do             let fs = Map.singleton "/cabal.project" "packages: */*.cabal\n"                 script = [Glob.NextGlobDir1 []]-                actual = runDiscoveryGlob fs [] script discoverCabalFiles-            actual `shouldBe` []--    describe "$HOME/.cabal/config fallback" do-        describe "when no cabal.project files exist" do-            it "uses $HOME/.cabal/config as a last-resort packages source" do+                actual = runDiscoveryGlob fs [] script discoverCabalPackages+            actual @?= Right []+        ]+    , testGroup+        "$HOME/.cabal/config fallback"+        [ testGroup+            "when no cabal.project files exist"+            [ testCase "uses $HOME/.cabal/config as a last-resort packages source" do                 let fs =                         Map.singleton "/home/user/.cabal/config" "packages: pkg-a\n"                             `Map.union` multiPackageCabalFs-                    actual = runDiscovery fs [("HOME", "/home/user")] discoverCabalFiles-                actual `shouldBe` ["/pkg-a/pkg-a.cabal"]--        describe "when $HOME/.cabal/config exists but lists no packages" do-            it "falls back to scanning the project root" do+                    actual = runDiscovery fs [("HOME", "/home/user")] discoverCabalPackages+                actual @?= Right ["/pkg-a/pkg-a.cabal"]+            ]+        , testGroup+            "when $HOME/.cabal/config exists but lists no packages"+            [ testCase "falls back to scanning the project root" do                 let fs =                         Map.fromList                             [ ("/home/user/.cabal/config", "")                             , ("/myapp.cabal", cabalFixture)                             ]-                    actual = runDiscovery fs [("HOME", "/home/user")] discoverCabalFiles-                actual `shouldBe` ["/myapp.cabal"]--    describe "packages: single-line list" do-        describe "when package list is comma-separated" do-            it "parses package names correctly" do+                    actual = runDiscovery fs [("HOME", "/home/user")] discoverCabalPackages+                actual @?= Right ["/myapp.cabal"]+            ]+        ]+    , testGroup+        "packages: single-line list"+        [ testGroup+            "when package list is comma-separated"+            [ testCase "parses package names correctly" do                 let fs =                         Map.singleton "/cabal.project" "packages: pkg-a, pkg-b\n"                             `Map.union` multiPackageCabalFs-                    actual = runDiscovery fs [] discoverCabalFiles-                actual `shouldMatchList` ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+                    actual = runDiscovery fs [] discoverCabalPackages+                fromRight [] actual @?= ["/pkg-a/pkg-a.cabal", "/pkg-b/pkg-b.cabal"]+            ]+        ]+    ]   where     pr = ProjectRoot "/"     runDiscovery fs env = runDiscoveryGlob fs env []@@ -138,3 +161,49 @@             . runFileSystemState             . Glob.runScripted script             . runReader pr+++-- | Pins the discovery contract: with a @stack.yaml@, package paths come+-- straight from its @packages:@ list, resolved against the project root.+testDiscoverStackPackages :: [TestTree]+testDiscoverStackPackages =+    [ testCase "resolves each package path against the project root" do+        let actual = runStack (StackProject ["pkg-a", "pkg-b"]) discoverStackPackages+        actual @?= Right ["/pkg-a", "/pkg-b"]+    , testCase "normalises resolved paths" do+        let actual = runStack (StackProject ["./pkg-a"]) discoverStackPackages+        actual @?= Right ["/pkg-a"]+    , testCase "returns no packages when the list is empty" do+        let actual = runStack (StackProject []) discoverStackPackages+        actual @?= Right []+    ]+  where+    pr = ProjectRoot "/"+    runStack result =+        runPureEff+            . runReader pr+            . runLogNoOp+            . runInputConst result+++-- | Pins how a package path resolves to a @.cabal@ file: a directory path+-- (as listed in @stack.yaml@) reads the @.cabal@ file inside it.+testReadProjectFile :: [TestTree]+testReadProjectFile =+    [ testGroup+        "when the path is a directory"+        [ testCase "reads the .cabal file inside it" do+            let actual = runRead multiPackageCabalFs $ readProjectFile "/pkg-a"+            actual @?= Right "/pkg-a/pkg-a.cabal"+        , testCase "fails with the directory path when it contains no .cabal file" do+            let fs = Map.singleton "/pkg-a/package.yaml" "name: pkg-a\n"+                actual = runRead fs $ readProjectFile "/pkg-a"+            actual @?= Left "/pkg-a"+        ]+    ]+  where+    runRead fs =+        fmap (.projectFilePath)+            . runPureEff+            . evalState fs+            . runFileSystemState

@@ -1,123 +0,0 @@-module Unit.Tricorder.Session.CommandSpec (spec_Command) where--import Atelier.Effects.FileSystem (runFileSystemState)-import Data.Default (def)-import Effectful (runPureEff)-import Effectful.State.Static.Shared (evalState)-import Test.Hspec (Spec, describe, it, shouldBe)--import Data.Map.Strict qualified as Map--import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (resolveCommand)-import Tricorder.Session.Config (Config (..))-import Tricorder.Session.Target (parseTarget)-import Tricorder.Session.TestTarget (parseTestTargets)--import Tricorder.Session.Command qualified as Command-import Tricorder.Session.Config qualified as Config---spec_Command :: Spec-spec_Command = do-    describe "resolveCommand" testResolveCommand---testResolveCommand :: Spec-testResolveCommand = do-    describe "when config has a command" do-        it "should use specified command" do-            let actual =-                    Command.render-                        . runPureEff-                        . evalState mempty-                        . runFileSystemState-                        $ resolveCommand pr def {command = Just "foo"} [] testTargets-            actual `shouldBe` "foo"--    describe "when config has explicit targets" do-        it "should spell them out verbatim, ignoring discovered test targets" do-            let actual =-                    Command.render-                        . runPureEff-                        . evalState (Map.singleton "/cabal.project" "")-                        . runFileSystemState-                        $ resolveCommand pr cfg (parseTarget <$> ["lib:foo"]) testTargets-            actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"--    describe "when config does not have a command or targets" do-        describe "and there is a cabal.project file" do-            it "should use cabal 'all' plus the discovered test targets" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState (Map.singleton "/cabal.project" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual-                    `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"--        describe "and there is at least one *.cabal file" do-            it "should use cabal 'all' plus the discovered test targets" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState (Map.singleton "/foo.cabal" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual-                    `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all test:foo"--        describe "and there is a stack.yaml file" do-            it "should use stack ghci with 'all' plus test targets" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState (Map.singleton "/stack.yaml" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual `shouldBe` "stack ghci all foo"--        describe "and there is both a stack.yaml and a cabal.project file" do-            it "should prefer stack ghci over cabal" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState (Map.fromList [("/stack.yaml", ""), ("/cabal.project", "")])-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual `shouldBe` "stack ghci all foo"--        describe "and there is both a stack.yaml and a *.cabal file" do-            it "should prefer stack ghci over cabal" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState (Map.fromList [("/stack.yaml", ""), ("/foo.cabal", "")])-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual `shouldBe` "stack ghci all foo"--        describe "but there are no project files" do-            it "should use default cabal repl with 'all' plus test targets" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState mempty-                            . runFileSystemState-                            $ resolveCommand pr cfg [] testTargets-                actual `shouldBe` "cabal repl --builddir /replbuild all test:foo"--        describe "and no test targets are discovered" do-            it "should fall back to plain 'all'" do-                let actual =-                        Command.render-                            . runPureEff-                            . evalState (Map.singleton "/cabal.project" "")-                            . runFileSystemState-                            $ resolveCommand pr cfg [] (parseTestTargets [])-                actual `shouldBe` "cabal repl --enable-multi-repl --builddir /replbuild all"-  where-    pr = ProjectRoot "/"-    cfg = def {Config.replBuildDir = "/replbuild"}-    testTargets = parseTestTargets ["test:foo"]

@@ -0,0 +1,58 @@+module Unit.Tricorder.Session.CommandTemplateSpec (test_Command) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Tricorder.Session.CommandTemplate+    ( hasPlaceholder+    , renderTargetsFor+    , targetPlaceholder+    , targetsPlaceholder+    )+import Tricorder.Session.Repl (Repl (..))+import Tricorder.Session.Target (ComponentKind (..), Target (..))+++test_Command :: TestTree+test_Command =+    testGroup+        "Command"+        [ testGroup "renderTargetsFor" testRenderTargetsFor+        , testGroup "hasPlaceholder" testHasPlaceholder+        ]+++--------------------------------------------------------------------------------+-- renderTargetsFor+--------------------------------------------------------------------------------++testRenderTargetsFor :: [TestTree]+testRenderTargetsFor =+    [ testCase "renders bare component names for plain Stack, deduplicated" do+        renderTargetsFor Stack [Qualified Test "foo", PackageQualified "pkg" Test "foo"]+            @?= ["foo"]+    , testCase "renders fully qualified targets for StackMulti" do+        renderTargetsFor StackMulti [PackageQualified "pkg" Test "foo"]+            @?= ["pkg:test:foo"]+    , testCase "renders fully qualified targets for Cabal" do+        renderTargetsFor Cabal [Qualified Test "foo"] @?= ["test:foo"]+    ]+++--------------------------------------------------------------------------------+-- hasPlaceholder+--------------------------------------------------------------------------------++testHasPlaceholder :: [TestTree]+testHasPlaceholder =+    [ testCase "is True when {targets} is present and checking for targetsPlaceholder" do+        hasPlaceholder targetsPlaceholder "cabal repl {targets}" @?= True+    , testCase "is True when only the escaped \\{targets} is present" do+        hasPlaceholder targetsPlaceholder "echo \\{targets}" @?= True+    , testCase "is False when neither form is present" do+        hasPlaceholder targetsPlaceholder "cabal repl test:foo" @?= False+    , testCase "is True when {target} is present and checking for targetPlaceholder" do+        hasPlaceholder targetPlaceholder "cabal repl {target}" @?= True+    , testCase "is False for {targets} (plural) when checking for targetPlaceholder" do+        hasPlaceholder targetPlaceholder "cabal repl {targets}" @?= False+    ]

@@ -0,0 +1,52 @@+module Unit.Tricorder.Session.ReplSpec (test_Repl) where++import Atelier.Effects.FileSystem (FileSystem, runFileSystemState)+import Effectful (runPureEff)+import Effectful.State.Static.Shared (State, evalState)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Data.Map.Strict qualified as Map++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Repl (Repl (..), resolveRepl)+++test_Repl :: TestTree+test_Repl =+    testGroup+        "Repl"+        [ testGroup "resolveRepl" testResolveRepl+        ]+++testResolveRepl :: [TestTree]+testResolveRepl =+    [ testCase "resolves Stack for a single-package stack.yaml" do+        withFiles [("/stack.yaml", "")] (resolveRepl pr) @?= Stack+    , testCase "resolves StackMulti for a multi-package stack.yaml" do+        withFiles+            [("/stack.yaml", "packages:\n  - foo\n  - bar\n")]+            (resolveRepl pr)+            @?= StackMulti+    , testCase "resolves Cabal when there is a cabal.project file" do+        withFiles [("/cabal.project", "")] (resolveRepl pr) @?= Cabal+    , testCase "resolves Cabal when there is at least one *.cabal file" do+        withFiles [("/foo.cabal", "")] (resolveRepl pr) @?= Cabal+    , testCase "prefers Stack over Cabal when both are present" do+        withFiles [("/stack.yaml", ""), ("/cabal.project", "")] (resolveRepl pr) @?= Stack+    , testCase "falls back to Cabal when there are no project files at all" do+        withFiles [] (resolveRepl pr) @?= Cabal+    ]+++-- | Run a 'FileSystem'-using computation against a faked in-memory+-- filesystem seeded with the given files (content is irrelevant except for+-- @stack.yaml@, which is parsed for its @packages@ key).+withFiles :: [(FilePath, ByteString)] -> Eff '[FileSystem, State (Map FilePath ByteString)] a -> a+withFiles files action =+    runPureEff $ evalState (Map.fromList files) $ runFileSystemState action+++pr :: ProjectRoot+pr = ProjectRoot "/"

@@ -0,0 +1,193 @@+module Unit.Tricorder.Session.Stage.Build.CommandSpec (test_Command) where++import Atelier.Effects.FileSystem (FileSystem, runFileSystemState)+import Data.Default (def)+import Effectful (runPureEff)+import Effectful.State.Static.Shared (State, evalState)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Data.Map.Strict qualified as Map++import Tricorder.Runtime (ProjectRoot (..))+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..), targetsPlaceholder)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl (..), resolveRepl)+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Stage.Build.Command (render, resolve)+import Tricorder.Session.Target (Target)++import Tricorder.Session.Config qualified as Config+import Tricorder.Session.Target qualified as Target+++test_Command :: TestTree+test_Command =+    testGroup+        "Tricorder.Session.Stage.Build.Command"+        [ testGroup "resolveBuildCommand" testResolveBuildCommand+        , testGroup "renderBuild" testRenderBuild+        ]+++testRenderBuild :: [TestTree]+testRenderBuild =+    [ testCase "substitutes {targets} with the rendered target list" do+        build (CommandTemplate Cabal "cabal repl {targets}" [] targetsPlaceholder) [Target.parse "lib:foo"]+            @?= "cabal repl lib:foo"+    , testCase "substitutes every occurrence of {targets}" do+        build+            (CommandTemplate Cabal "echo {targets} && cabal repl {targets}" [] targetsPlaceholder)+            [Target.parse "lib:foo"]+            @?= "echo lib:foo && cabal repl lib:foo"+    , testCase "leaves a template with no placeholder untouched, but still appends arguments" do+        build+            (CommandTemplate Cabal "my-wrapper --repl" ["--flag"] targetsPlaceholder)+            [Target.parse "lib:foo"]+            @?= "my-wrapper --repl --flag"+    , testCase "renders \\{targets} as a literal {targets}, without substitution" do+        build (CommandTemplate Cabal "echo \\{targets}" [] targetsPlaceholder) [Target.parse "lib:foo"]+            @?= "echo {targets}"+    , testCase "substitutes an unescaped {targets} while leaving an escaped one literal" do+        build+            (CommandTemplate Cabal "echo \\{targets} && cabal repl {targets}" [] targetsPlaceholder)+            [Target.parse "lib:foo"]+            @?= "echo {targets} && cabal repl lib:foo"+    , testCase "substitutes {targets} with nothing when the target list is empty" do+        build (CommandTemplate Cabal "cabal repl {targets}" [] targetsPlaceholder) []+            @?= "cabal repl"+    , testCase "appends arguments after the rendered template" do+        build+            (CommandTemplate Cabal "cabal repl {targets}" ["--flag", "value"] targetsPlaceholder)+            [Target.parse "lib:foo"]+            @?= "cabal repl lib:foo --flag value"+    , testCase "does not substitute {target} (singular) when the command uses targetsPlaceholder" do+        build (CommandTemplate Cabal "cabal repl {target}" [] targetsPlaceholder) [Target.parse "lib:foo"]+            @?= "cabal repl {target}"+    ]+  where+    build template targets = (render template targets).getRenderedCommand+++testResolveBuildCommand :: [TestTree]+testResolveBuildCommand =+    [ testGroup+        "deprecated top-level command"+        [ testCase "is used as the build template when build.command_template is unset" do+            renderBuildFor [] def {command = Just "foo"} [] @?= "foo"+        ]+    , testGroup+        "build.command_template"+        [ testCase "overrides the deprecated top-level command" do+            let cfg =+                    cfg0+                        { command = Just "should be ignored"+                        , build = cfg0.build {commandTemplate = Just "cabal repl {targets}"}+                        }+            renderBuildFor [("/cabal.project", "")] cfg (Target.parse <$> ["lib:foo"])+                @?= "cabal repl lib:foo"+        ]+    , testGroup+        "explicit targets"+        [ testCase "spell them out verbatim" do+            renderBuildFor [("/cabal.project", "")] cfg0 (Target.parse <$> ["lib:foo"])+                @?= "cabal repl --enable-multi-repl --builddir /replbuild lib:foo"+        ]+    , testGroup+        "no command or targets configured"+        [ testGroup+            "and there is a cabal.project file"+            [ testCase "uses cabal 'all'" do+                renderBuildFor [("/cabal.project", "")] cfg0 []+                    @?= "cabal repl --enable-multi-repl --builddir /replbuild all"+            ]+        , testGroup+            "and there is at least one *.cabal file"+            [ testCase "uses cabal 'all'" do+                renderBuildFor [("/foo.cabal", "")] cfg0 []+                    @?= "cabal repl --enable-multi-repl --builddir /replbuild all"+            ]+        , testGroup+            "and there is a stack.yaml file"+            [ testCase "uses stack ghci with 'all'" do+                renderBuildFor [("/stack.yaml", "")] cfg0 []+                    @?= "stack ghci all"+            ]+        , testGroup+            "and there is both a stack.yaml and a cabal.project file"+            [ testCase "prefers stack ghci over cabal" do+                renderBuildFor [("/stack.yaml", ""), ("/cabal.project", "")] cfg0 []+                    @?= "stack ghci all"+            ]+        , testGroup+            "but there are no project files"+            [ testCase "uses default cabal repl with 'all'" do+                renderBuildFor [] cfg0 []+                    @?= "cabal repl --builddir /replbuild all"+            ]+        ]+    , testGroup+        "build.extra_auto_arguments"+        [ testCase "is appended after the rendered automatically resolved template" do+            let cfg = cfg0 {build = cfg0.build {extraAutoArguments = ["--extra-flag"]}}+            renderBuildFor [("/cabal.project", "")] cfg (Target.parse <$> ["lib:foo"])+                @?= "cabal repl --enable-multi-repl --builddir /replbuild lib:foo --extra-flag"+        , testCase "is ignored when build.command_template is set" do+            let cfg =+                    cfg0+                        { build =+                            cfg0.build+                                { commandTemplate = Just "cabal repl {targets}"+                                , extraAutoArguments = ["--extra-flag"]+                                }+                        }+            renderBuildFor [("/cabal.project", "")] cfg (Target.parse <$> ["lib:foo"])+                @?= "cabal repl lib:foo"+        , testCase "is ignored when the deprecated top-level command is set" do+            let cfg =+                    cfg0+                        { command = Just "cabal repl {targets}"+                        , build = cfg0.build {extraAutoArguments = ["--extra-flag"]}+                        }+            renderBuildFor [("/cabal.project", "")] cfg (Target.parse <$> ["lib:foo"])+                @?= "cabal repl lib:foo"+        ]+    ]+++-- | Resolve and fully render the build command against a faked filesystem —+-- the composition 'Tricorder.Session.loadSession' and 'Tricorder.Daemon.Core'+-- perform between them (resolve a 'CommandTemplate' plus its target list,+-- then 'renderBuild' the two together).+renderBuildFor :: [(FilePath, ByteString)] -> Config -> [Target] -> Text+renderBuildFor files cfg targets =+    (uncurry render $ withFiles files $ resolveBuild cfg targets).getRenderedCommand+++-- | Run a 'FileSystem'-using computation against a faked in-memory+-- filesystem seeded with the given files (content is irrelevant except for+-- @stack.yaml@, which is parsed for its @packages@ key).+withFiles :: [(FilePath, ByteString)] -> Eff '[FileSystem, State (Map FilePath ByteString)] a -> a+withFiles files action =+    runPureEff $ evalState (Map.fromList files) $ runFileSystemState action+++cfg0 :: Config+cfg0 = def {Config.replBuildDir = "/replbuild"}+++-- | Resolve 'Repl' from the faked filesystem, then resolve the build+-- command from it — mirrors how 'Tricorder.Session.loadSession' chains the+-- two steps.+resolveBuild+    :: (FileSystem :> es)+    => Config -> [Target] -> Eff es (CommandTemplate 'Build, [Target])+resolveBuild cfg targets = do+    repl <- resolveRepl pr+    resolve pr cfg repl targets+++pr :: ProjectRoot+pr = ProjectRoot "/"

@@ -0,0 +1,62 @@+module Unit.Tricorder.Session.Stage.Eval.CommandSpec (test_Command) where++import Data.Default (def)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..), targetPlaceholder)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl (..))+import Tricorder.Session.Stage (Stage (..))+import Tricorder.Session.Stage.Eval.Command (render, resolve)+import Tricorder.Session.Target (Target (..))+++test_Command :: TestTree+test_Command =+    testGroup+        "Tricorder.Session.Stage.Eval.Command"+        [ testGroup "resolveEvalCommand" testResolveEvalCommand+        , testGroup "renderEval" testRenderEval+        ]+++testRenderEval :: [TestTree]+testRenderEval =+    [ testCase "substitutes {target} (singular) with the module being evaluated" do+        eval (CommandTemplate Cabal "cabal repl {target}" [] targetPlaceholder) [Bare "Tricorder.Foo"]+            @?= "cabal repl Tricorder.Foo"+    , testCase "does not substitute {targets} (plural) when the command uses targetPlaceholder" do+        eval (CommandTemplate Cabal "cabal repl {targets}" [] targetPlaceholder) [Bare "Tricorder.Foo"]+            @?= "cabal repl {targets}"+    ]+  where+    eval template targets = (render template targets).getRenderedCommand+++testResolveEvalCommand :: [TestTree]+testResolveEvalCommand =+    [ testCase "uses the built-in default template for Cabal when eval.command_template is unset" do+        (resolve Cabal def).template @?= "cabal repl {target}"+    , testCase "uses eval.command_template when set" do+        let cfg =+                def+                    { eval = (def :: CommandConfig 'Eval) {commandTemplate = Just "cabal repl --builddir /tmp {target}"}+                    }+        (resolve Cabal cfg).template @?= "cabal repl --builddir /tmp {target}"+    , testCase "carries eval.extra_auto_arguments when eval.command_template is unset" do+        let cfg = def {eval = (def :: CommandConfig 'Eval) {extraAutoArguments = ["--flag"]}}+        (resolve Cabal cfg).arguments @?= ["--flag"]+    , testCase "ignores eval.extra_auto_arguments when eval.command_template is set" do+        let cfg =+                def+                    { eval =+                        (def :: CommandConfig 'Eval)+                            { commandTemplate = Just "cabal repl {target}"+                            , extraAutoArguments = ["--flag"]+                            }+                    }+        (resolve Cabal cfg).arguments @?= []+    ]

@@ -0,0 +1,106 @@+module Unit.Tricorder.Session.Stage.Test.CommandSpec (test_Command) where++import Data.Default (def)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Tricorder.Build.ByteSize (ByteSize (..), Unit (..))+import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))+import Tricorder.Session.CommandConfig (CommandConfig (..))+import Tricorder.Session.CommandTemplate (CommandTemplate (..), targetPlaceholder)+import Tricorder.Session.Config (Config (..))+import Tricorder.Session.Repl (Repl (..))+import Tricorder.Session.Stage.Test.Command+    ( RenderedTestCommand (..)+    , render+    )+import Tricorder.Session.Stage.Test.Config (TestConfig (..))+import Tricorder.Session.Stage.Test.Session (TestSession (..), resolve)+import Tricorder.Session.TestTarget (TestTarget (..))++import Tricorder.Session.CommandConfig qualified as CommandConfig+import Tricorder.Session.Stage qualified as Stage+import Tricorder.Session.Target qualified as Target+++test_Command :: TestTree+test_Command =+    testGroup+        "Tricorder.Session.Stage.Test.Command"+        [ testResolveTestSession+        , testGroup "renderTest" testRenderTest+        ]+++testRenderTest :: [TestTree]+testRenderTest =+    [ testCase "substitutes {target} (singular) with the single test target" do+        test (CommandTemplate Cabal "cabal repl {target}" [] targetPlaceholder) Nothing testTarget+            @?= "cabal repl test:foo"+    , testCase "does not substitute {targets} (plural) when the command uses targetPlaceholder" do+        test (CommandTemplate Cabal "cabal repl {targets}" [] targetPlaceholder) Nothing testTarget+            @?= "cabal repl {targets}"+    , testCase "adds no memory-limit flag when no limit is configured" do+        test (CommandTemplate Cabal "cabal repl {target}" [] targetPlaceholder) Nothing testTarget+            @?= "cabal repl test:foo"+    , testCase "appends a --repl-options memory-limit RTS flag for Cabal" do+        test (CommandTemplate Cabal "cabal repl {target}" [] targetPlaceholder) (Just oneByte) testTarget+            @?= "cabal repl test:foo --repl-options +RTS -M1 -RTS"+    , testCase "appends a --ghc-options memory-limit RTS flag for Stack" do+        -- Plain (single-package) Stack renders bare component names, not+        -- the fully qualified target — see 'testRenderTargetsFor'.+        test (CommandTemplate Stack "stack ghci {target}" [] targetPlaceholder) (Just oneByte) testTarget+            @?= "stack ghci foo --ghc-options +RTS -M1 -RTS"+    , testCase "appends the memory-limit flag after the user's configured arguments" do+        test+            (CommandTemplate Cabal "cabal repl {target}" ["--flag"] targetPlaceholder)+            (Just oneByte)+            testTarget+            @?= "cabal repl test:foo --flag --repl-options +RTS -M1 -RTS"+    ]+  where+    test :: CommandTemplate 'Stage.Test -> Maybe ByteSize -> TestTarget -> Text+    test template mMemoryLimit target =+        (render (TestSession template [] def) mMemoryLimit target).command.getRenderedCommand+    testTarget = TestTarget (Target.parse "test:foo")+    oneByte = ByteSize 1 B+++testResolveTestSession :: TestTree+testResolveTestSession =+    testGroup+        "resolveTestSession"+        [ testCase "uses the built-in default template for Cabal when test.command_template is unset" do+            (resolve Cabal [] def).commandTemplate.template @?= "cabal repl {target}"+        , testCase "uses the built-in default template for Stack when test.command_template is unset" do+            (resolve Stack [] def).commandTemplate.template @?= "stack ghci {target}"+        , testCase "uses test.command_template when set" do+            let cfg =+                    def+                        { test =+                            def+                                { commandConfig =+                                    def+                                        { CommandConfig.commandTemplate = Just "cabal repl --repl-options=-fno-code {target}"+                                        }+                                }+                        }+            (resolve Cabal [] cfg).commandTemplate.template+                @?= "cabal repl --repl-options=-fno-code {target}"+        , testCase "carries test.extra_auto_arguments when test.command_template is unset" do+            let cfg = def {test = def {commandConfig = def {extraAutoArguments = ["--flag"]}}}+            (resolve Cabal [] cfg).commandTemplate.arguments @?= ["--flag"]+        , testCase "ignores test.extra_auto_arguments when test.command_template is set" do+            let cfg =+                    def+                        { test =+                            def+                                { commandConfig =+                                    def+                                        { commandTemplate = Just "cabal repl {target}"+                                        , extraAutoArguments = ["--flag"]+                                        }+                                }+                        }+            (resolve Cabal [] cfg).commandTemplate.arguments @?= []+        ]

@@ -1,24 +1,19 @@-module Unit.Tricorder.Session.TargetSpec (spec_Target) where+module Unit.Tricorder.Session.TargetSpec (test_Target) where  import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)-import Test.Hspec-    ( Spec-    , describe-    , it-    , shouldBe-    , shouldContain-    , shouldMatchList-    )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import Prelude hiding (compare)  import Tricorder.Session.CabalFile (CabalFile (..)) import Tricorder.Session.Target     ( ComponentKind (..)     , Target (..)     , allComponentTargets-    , compareTargets+    , compare     , definesCustomPrelude-    , parseTarget-    , resolveTargets+    , parse+    , resolve     ) import Unit.Tricorder.Session.Helpers     ( gpd@@ -29,211 +24,246 @@     )  -spec_Target :: Spec-spec_Target = do-    describe "resolveTargets" testResolveTargets-    describe "parseTarget" testParseTarget-    describe "compareTargets" testCompareTargets-    describe "allComponentTargets" testAllComponentTargets-    describe "definesCustomPrelude" testDefinesCustomPrelude+test_Target :: TestTree+test_Target =+    testGroup+        "Target"+        [ testGroup "resolve" testResolveTargets+        , testGroup "parse" testParseTarget+        , testGroup "compare" testCompareTargets+        , testGroup "allComponentTargets" testAllComponentTargets+        , testGroup "definesCustomPrelude" testDefinesCustomPrelude+        ]  -testParseTarget :: Spec-testParseTarget = do-    describe "qualified targets" do-        it "parses lib: as the main library (empty name)" do-            parseTarget "lib:" `shouldBe` Qualified Lib ""--        it "parses a named lib: target" do-            parseTarget "lib:myapp-utils" `shouldBe` Qualified Lib "myapp-utils"--        it "parses an flib: target" do-            parseTarget "flib:myapp-flib" `shouldBe` Qualified FLib "myapp-flib"--        it "parses an exe: target" do-            parseTarget "exe:myapp-exe" `shouldBe` Qualified Exe "myapp-exe"--        it "parses a test: target" do-            parseTarget "test:myapp-test" `shouldBe` Qualified Test "myapp-test"--        it "parses a bench: target" do-            parseTarget "bench:myapp-bench" `shouldBe` Qualified Bench "myapp-bench"--    describe "a name with no kind prefix" do-        it "parses as bare" do-            parseTarget "myapp" `shouldBe` Bare "myapp"--    describe "unrecognized targets" do-        it "rejects an unknown kind" do-            parseTarget "bogus:myapp" `shouldBe` Unrecognized "bogus:myapp"--        it "rejects a form with extra colons" do-            parseTarget "lib:a:b" `shouldBe` Unrecognized "lib:a:b"+testParseTarget :: [TestTree]+testParseTarget =+    [ testGroup+        "qualified targets"+        [ testCase "parses lib: as the main library (empty name)" do+            parse "lib:" @?= Qualified Lib ""+        , testCase "parses a named lib: target" do+            parse "lib:myapp-utils" @?= Qualified Lib "myapp-utils"+        , testCase "parses an flib: target" do+            parse "flib:myapp-flib" @?= Qualified FLib "myapp-flib"+        , testCase "parses an exe: target" do+            parse "exe:myapp-exe" @?= Qualified Exe "myapp-exe"+        , testCase "parses a test: target" do+            parse "test:myapp-test" @?= Qualified Test "myapp-test"+        , testCase "parses a bench: target" do+            parse "bench:myapp-bench" @?= Qualified Bench "myapp-bench"+        ]+    , testGroup+        "a name with no kind prefix"+        [ testCase "parses as bare" do+            parse "myapp" @?= Bare "myapp"+        ]+    , testGroup+        "unrecognized targets"+        [ testCase "rejects an unknown kind" do+            parse "bogus:myapp" @?= Unrecognized "bogus:myapp"+        , testCase "rejects a form with extra colons" do+            parse "lib:a:b" @?= Unrecognized "lib:a:b"+        ]+    ]  -testResolveTargets :: Spec-testResolveTargets = do-    describe "when targets are configured" do-        it "parses and sorts configured targets" do-            let actual = resolveTargets [] ["lib:foo", "test:foo-test"]-            actual `shouldBe` [Qualified Lib "foo", Qualified Test "foo-test"]--    describe "when no targets are configured" do-        it "auto-detects all components from the cabal file" do+testResolveTargets :: [TestTree]+testResolveTargets =+    [ testGroup+        "when targets are configured"+        [ testCase "parses and sorts configured targets" do+            let actual = resolve [] ["lib:foo", "test:foo-test"]+            actual @?= [Qualified Lib "foo", Qualified Test "foo-test"]+        ]+    , testGroup+        "when no targets are configured"+        [ testCase "auto-detects all components from the cabal file" do             -- cabalFixture exposes no Prelude module, so all components sort             -- alphabetically by their rendered form.-            let actual = resolveTargets singleCabalFile []+            let actual = resolve singleCabalFile []             actual-                `shouldBe` [ PackageQualified "myapp" Bench "myapp-bench"-                           , PackageQualified "myapp" Exe "myapp-exe"-                           , PackageQualified "myapp" FLib "myapp-flib"-                           , PackageQualified "myapp" Lib "myapp"-                           , PackageQualified "myapp" Lib "myapp-utils"-                           , PackageQualified "myapp" Test "myapp-test"-                           ]--        it "surfaces test-suite components so they can be run after a build" do-            let actual = resolveTargets singleCabalFile []-            actual `shouldContain` [PackageQualified "myapp" Test "myapp-test"]--        it "returns no targets when there are no cabal files" do-            let actual = resolveTargets [] []-            actual `shouldBe` []--        -- [tag: test_resolve_targest_aggregate]-        it "aggregates components across every package (regression: was 0)" do-            let actual = resolveTargets multiCabalFiles []+                @?= [ PackageQualified "myapp" Bench "myapp-bench"+                    , PackageQualified "myapp" Exe "myapp-exe"+                    , PackageQualified "myapp" FLib "myapp-flib"+                    , PackageQualified "myapp" Lib "myapp"+                    , PackageQualified "myapp" Lib "myapp-utils"+                    , PackageQualified "myapp" Test "myapp-test"+                    ]+        , testCase "surfaces test-suite components so they can be run after a build" do+            let actual = resolve singleCabalFile []+            assertBool "expected myapp-test among the targets"+                $ PackageQualified "myapp" Test "myapp-test" `elem` actual+        , testCase "returns no targets when there are no cabal files" do+            let actual = resolve [] []+            actual @?= []+        , -- [tag: test_resolve_targest_aggregate]+          testCase "aggregates components across every package (regression: was 0)" do+            let actual = resolve multiCabalFiles []             actual-                `shouldMatchList` [ PackageQualified "pkg-a" Test "pkg-a-test"-                                  , PackageQualified "pkg-b" Test "pkg-b-test"-                                  , PackageQualified "pkg-a" Lib "pkg-a"-                                  , PackageQualified "pkg-b" Lib "pkg-b"-                                  ]--        it "sorts a library exposing a custom Prelude last" do+                @?= [ PackageQualified "pkg-a" Lib "pkg-a"+                    , PackageQualified "pkg-a" Test "pkg-a-test"+                    , PackageQualified "pkg-b" Lib "pkg-b"+                    , PackageQualified "pkg-b" Test "pkg-b-test"+                    ]+        , testCase "sorts a library exposing a custom Prelude last" do             let cabalFile =                     CabalFile "/myprelude.cabal"                         $ fromMaybe (error "libWithPreludeCabal failed to parse")                         $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude")-            let actual = resolveTargets [cabalFile] []+            let actual = resolve [cabalFile] []             actual-                `shouldBe` [ PackageQualified "myprelude" Exe "myprelude-exe"-                           , PackageQualified "myprelude" Lib "myprelude"-                           ]+                @?= [ PackageQualified "myprelude" Exe "myprelude-exe"+                    , PackageQualified "myprelude" Lib "myprelude"+                    ]+        ]+    ]  -testCompareTargets :: Spec-testCompareTargets = do+testCompareTargets :: [TestTree]+testCompareTargets =     -- A predicate that stands in for 'definesCustomPrelude': marks lib: targets     -- as "defines custom Prelude" so the comparison contract is exercised     -- independently of cabal-file parsing.-    let defPred (Qualified Lib _) = True-        defPred _ = False--    describe "Ord" do-        describe "only first target matches the predicate" do-            describe "first target's render normally sorts as LT" do-                it "should return GT" do-                    compareTargets defPred (Qualified Lib "a") (Qualified Exe "b") `shouldBe` GT-            describe "both targets have the same render" do-                it "should return GT" do-                    compareTargets defPred (Qualified Lib "a") (Qualified Exe "a") `shouldBe` GT-            describe "first target's render normally sorts as GT" do-                it "should return GT" do-                    compareTargets defPred (Qualified Lib "b") (Qualified Exe "a") `shouldBe` GT--        describe "only second target matches the predicate" do-            describe "first target's render normally sorts as LT" do-                it "should return LT" do-                    compareTargets defPred (Qualified Exe "a") (Qualified Lib "b") `shouldBe` LT-            describe "both targets have the same render" do-                it "should return LT" do-                    compareTargets defPred (Qualified Exe "a") (Qualified Lib "a") `shouldBe` LT-            describe "first target's render normally sorts as GT" do-                it "should return LT" do-                    compareTargets defPred (Qualified Exe "b") (Qualified Lib "a") `shouldBe` LT--        describe "both targets match the predicate" do-            describe "first target's render normally sorts as LT" do-                it "should sort normally" do-                    compareTargets defPred (Qualified Lib "a") (Qualified Lib "b") `shouldBe` LT-            describe "both targets have the same render" do-                it "should sort normally" do-                    compareTargets defPred (Qualified Lib "a") (Qualified Lib "a") `shouldBe` EQ-            describe "first target's render normally sorts as GT" do-                it "should sort normally" do-                    compareTargets defPred (Qualified Lib "b") (Qualified Lib "a") `shouldBe` GT--        describe "neither target matches the predicate" do-            describe "first target's render normally sorts as LT" do-                it "should sort normally" do-                    compareTargets defPred (Qualified Exe "a") (Qualified Exe "b") `shouldBe` LT-            describe "both targets have the same render" do-                it "should sort normally" do-                    compareTargets defPred (Qualified Exe "a") (Qualified Exe "a") `shouldBe` EQ-            describe "first target's render normally sorts as GT" do-                it "should sort normally" do-                    compareTargets defPred (Qualified Exe "b") (Qualified Exe "a") `shouldBe` GT+    [ testGroup+        "Ord"+        [ testGroup+            "only first target matches the predicate"+            [ testGroup+                "first target's render normally sorts as LT"+                [ testCase "should return GT" do+                    compare defPred (Qualified Lib "a") (Qualified Exe "b") @?= GT+                ]+            , testGroup+                "both targets have the same render"+                [ testCase "should return GT" do+                    compare defPred (Qualified Lib "a") (Qualified Exe "a") @?= GT+                ]+            , testGroup+                "first target's render normally sorts as GT"+                [ testCase "should return GT" do+                    compare defPred (Qualified Lib "b") (Qualified Exe "a") @?= GT+                ]+            ]+        , testGroup+            "only second target matches the predicate"+            [ testGroup+                "first target's render normally sorts as LT"+                [ testCase "should return LT" do+                    compare defPred (Qualified Exe "a") (Qualified Lib "b") @?= LT+                ]+            , testGroup+                "both targets have the same render"+                [ testCase "should return LT" do+                    compare defPred (Qualified Exe "a") (Qualified Lib "a") @?= LT+                ]+            , testGroup+                "first target's render normally sorts as GT"+                [ testCase "should return LT" do+                    compare defPred (Qualified Exe "b") (Qualified Lib "a") @?= LT+                ]+            ]+        , testGroup+            "both targets match the predicate"+            [ testGroup+                "first target's render normally sorts as LT"+                [ testCase "should sort normally" do+                    compare defPred (Qualified Lib "a") (Qualified Lib "b") @?= LT+                ]+            , testGroup+                "both targets have the same render"+                [ testCase "should sort normally" do+                    compare defPred (Qualified Lib "a") (Qualified Lib "a") @?= EQ+                ]+            , testGroup+                "first target's render normally sorts as GT"+                [ testCase "should sort normally" do+                    compare defPred (Qualified Lib "b") (Qualified Lib "a") @?= GT+                ]+            ]+        , testGroup+            "neither target matches the predicate"+            [ testGroup+                "first target's render normally sorts as LT"+                [ testCase "should sort normally" do+                    compare defPred (Qualified Exe "a") (Qualified Exe "b") @?= LT+                ]+            , testGroup+                "both targets have the same render"+                [ testCase "should sort normally" do+                    compare defPred (Qualified Exe "a") (Qualified Exe "a") @?= EQ+                ]+            , testGroup+                "first target's render normally sorts as GT"+                [ testCase "should sort normally" do+                    compare defPred (Qualified Exe "b") (Qualified Exe "a") @?= GT+                ]+            ]+        ]+    ]+  where+    defPred (Qualified Lib _) = True+    defPred _ = False  -testAllComponentTargets :: Spec-testAllComponentTargets = do-    it "returns every component for the fixture" do+testAllComponentTargets :: [TestTree]+testAllComponentTargets =+    [ testCase "returns every component for the fixture" do         allComponentTargets gpd-            `shouldMatchList` [ PackageQualified "myapp" Lib "myapp"-                              , PackageQualified "myapp" Lib "myapp-utils"-                              , PackageQualified "myapp" FLib "myapp-flib"-                              , PackageQualified "myapp" Exe "myapp-exe"-                              , PackageQualified "myapp" Test "myapp-test"-                              , PackageQualified "myapp" Bench "myapp-bench"-                              ]-    -- This test ensures `allComponentTargets`' part of the aggregate test.-    -- [ref:test_resolve_targest_aggregate]-    it "returns every component for test fixures" do+            @?= [ PackageQualified "myapp" Lib "myapp"+                , PackageQualified "myapp" Lib "myapp-utils"+                , PackageQualified "myapp" FLib "myapp-flib"+                , PackageQualified "myapp" Exe "myapp-exe"+                , PackageQualified "myapp" Test "myapp-test"+                , PackageQualified "myapp" Bench "myapp-bench"+                ]+    , -- This test ensures `allComponentTargets`' part of the aggregate test.+      -- [ref:test_resolve_targest_aggregate]+      testCase "returns every component for test fixures" do         let actual =                 allComponentTargets                     $ fromMaybe (error "failed to parse cabal")                     $ parseGenericPackageDescriptionMaybe                     $ libTestCabal "pkg-a"         actual-            `shouldMatchList` [ PackageQualified "pkg-a" Lib "pkg-a"-                              , PackageQualified "pkg-a" Test "pkg-a-test"-                              ]+            @?= [ PackageQualified "pkg-a" Lib "pkg-a"+                , PackageQualified "pkg-a" Test "pkg-a-test"+                ]+    ]  -testDefinesCustomPrelude :: Spec-testDefinesCustomPrelude = do-    let preludeCF =-            CabalFile "/myprelude.cabal"-                $ fromMaybe (error "libWithPreludeCabal failed to parse")-                $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude")--    describe "when the main library exposes Prelude" do-        it "returns True for Qualified Lib \"\" (unnamed main lib)" do-            definesCustomPrelude [preludeCF] (Qualified Lib "") `shouldBe` True--        it "returns True for Qualified Lib matching the package name" do-            definesCustomPrelude [preludeCF] (Qualified Lib "myprelude") `shouldBe` True--        it "returns True for Bare matching the package name" do-            definesCustomPrelude [preludeCF] (Bare "myprelude") `shouldBe` True--    describe "when no library exposes Prelude" do-        it "returns False for a lib target in a normal package" do-            definesCustomPrelude singleCabalFile (Qualified Lib "myapp") `shouldBe` False--        it "returns False for Bare matching the package name" do-            definesCustomPrelude singleCabalFile (Bare "myapp") `shouldBe` False--    describe "for non-library targets" do-        it "returns False for Qualified Exe" do-            definesCustomPrelude [preludeCF] (Qualified Exe "myprelude-exe") `shouldBe` False--        it "returns False for Qualified Test" do-            definesCustomPrelude singleCabalFile (Qualified Test "myapp-test") `shouldBe` False--        it "returns False for Unrecognized" do-            definesCustomPrelude [preludeCF] (Unrecognized "library:myprelude") `shouldBe` False--    it "returns False when the cabal file list is empty" do-        definesCustomPrelude [] (Qualified Lib "anything") `shouldBe` False+testDefinesCustomPrelude :: [TestTree]+testDefinesCustomPrelude =+    [ testGroup+        "when the main library exposes Prelude"+        [ testCase "returns True for Qualified Lib \"\" (unnamed main lib)" do+            definesCustomPrelude [preludeCF] (Qualified Lib "") @?= True+        , testCase "returns True for Qualified Lib matching the package name" do+            definesCustomPrelude [preludeCF] (Qualified Lib "myprelude") @?= True+        , testCase "returns True for Bare matching the package name" do+            definesCustomPrelude [preludeCF] (Bare "myprelude") @?= True+        ]+    , testGroup+        "when no library exposes Prelude"+        [ testCase "returns False for a lib target in a normal package" do+            definesCustomPrelude singleCabalFile (Qualified Lib "myapp") @?= False+        , testCase "returns False for Bare matching the package name" do+            definesCustomPrelude singleCabalFile (Bare "myapp") @?= False+        ]+    , testGroup+        "for non-library targets"+        [ testCase "returns False for Qualified Exe" do+            definesCustomPrelude [preludeCF] (Qualified Exe "myprelude-exe") @?= False+        , testCase "returns False for Qualified Test" do+            definesCustomPrelude singleCabalFile (Qualified Test "myapp-test") @?= False+        , testCase "returns False for Unrecognized" do+            definesCustomPrelude [preludeCF] (Unrecognized "library:myprelude") @?= False+        ]+    , testCase "returns False when the cabal file list is empty" do+        definesCustomPrelude [] (Qualified Lib "anything") @?= False+    ]+  where+    preludeCF =+        CabalFile "/myprelude.cabal"+            $ fromMaybe (error "libWithPreludeCabal failed to parse")+            $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude")