tricorder 0.2.0.0 → 0.2.0.1
raw patch · 25 files changed
+638/−361 lines, 25 filesdep +reqdep ~atelier-prelude
Dependencies added: req
Dependency ranges changed: atelier-prelude
Files
- CHANGELOG.md +21/−0
- src/Tricorder/CLI/UI/View.hs +1/−1
- src/Tricorder/Daemon/Core.hs +7/−4
- src/Tricorder/Daemon/EvalCommentRunner.hs +9/−8
- src/Tricorder/Daemon/GhciSession/GhciProcess.hs +5/−1
- src/Tricorder/Daemon/Main.hs +4/−2
- src/Tricorder/Daemon/TestRunner.hs +6/−5
- src/Tricorder/Module.hs +17/−1
- src/Tricorder/Session/Command.hs +107/−38
- src/Tricorder/Session/Target.hs +33/−14
- src/Tricorder/Session/TestTarget.hs +1/−0
- src/Tricorder/Session/WatchDirs.hs +8/−0
- src/Tricorder/Socket/Server.hs +17/−17
- src/Tricorder/SourceLookup.hs +9/−8
- src/Tricorder/SourceLookup/Cabal.hs +0/−99
- src/Tricorder/SourceLookup/Hackage.hs +90/−0
- src/Tricorder/SourceLookup/PackageStore.hs +139/−0
- src/Tricorder/SourceLookup/Tarball.hs +23/−71
- test/Unit/Tricorder/Daemon/GhciSessionSpec.hs +13/−9
- test/Unit/Tricorder/Daemon/TestRunnerSpec.hs +8/−7
- test/Unit/Tricorder/Session/CommandSpec.hs +44/−16
- test/Unit/Tricorder/Session/TargetSpec.hs +25/−19
- test/Unit/Tricorder/SourceLookup/TarballSpec.hs +1/−1
- test/Unit/Tricorder/SourceLookupSpec.hs +42/−34
- tricorder.cabal +8/−6
CHANGELOG.md view
@@ -7,6 +7,27 @@ ## [Unreleased] +## [0.2.0.1] - 2026-08-12++### Fixed++- `tricorder source` does not work without `cabal` in `PATH` (for `stack`+ projects, for example). Tricorder now fetches tarballs for source+ distributions manually with good old-fashioned HTTP instead of relying on+ `cabal fetch`. This means `tricorder source` works regardless whether `cabal`+ or `stack` is in `PATH`. (Still requires `ghc-pkg` to be in `PATH` though to+ resolve the module name to a package.)+- Incorrect repl command used for eval comments. This caused eval comments not+ to be able to use a module's top-level definitions in its expression.+- Auto-resolved targets are not compatible with `stack ghci` (and its alias+ `stack ghci`). Targets are now automatically resolved with package name,+ `pkg:kind:name` for multi-package repos and just `name` for single-package+ repos, instead of just with the component name and kind `kind:name`. `stack+ghci` is not compatible with the form `kind:name` (but `cabal repl` is), but+ both of them are compatible with the fully qualified `pkg:kind:name` form. If+ you manually specify a `kind:name` target in your `stack` repo's+ `.tricorder.yaml` though, you are on your own!+ ## [0.2.0.0] - 2026-08-06 ### Added
src/Tricorder/CLI/UI/View.hs view
@@ -250,7 +250,7 @@ , if null targets then txt "(all)" else- txtWrap (T.intercalate " " (map renderTarget targets))+ vBox $ (map (txt . renderTarget) targets) ]
src/Tricorder/Daemon/Core.hs view
@@ -57,6 +57,7 @@ import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.Session (Session (..), loadSession) import Tricorder.Session.CabalFile (CabalFile)+import Tricorder.Session.Command (Command (..)) import Tricorder.Session.TestTarget (TestTarget, renderTestTarget) import Tricorder.Session.TestTimeout (TestTimeout) import Tricorder.Waiters (Waiters)@@ -323,7 +324,7 @@ let pendingComments = sconcat $ (\(lm, ecs) -> toPending lm.relPath <$> ecs) <$> nonEmptyComments Pub.publish $ Eval.Found $ Eval.Comments pendingComments- evaluatedComments <- EvalCommentRunner.evaluateComments session.command nonEmptyComments+ evaluatedComments <- EvalCommentRunner.evaluateComments session.command.repl nonEmptyComments pure $ Eval.Found $ Eval.Comments evaluatedComments where toPending file comment =@@ -342,7 +343,7 @@ => Session -> BuildResult -> Eff es Test.Suites runTests session buildResult | hasTargets session.testTargets && noErrors buildResult.diagnostics =- runTestsForTargets session.testTimeout session.testTargets+ runTestsForTargets session.command session.testTimeout session.testTargets | otherwise = pure mempty where hasTargets = not . null@@ -354,10 +355,11 @@ , Pub Test.Suites :> es , TestRunner :> es )- => TestTimeout+ => Command+ -> TestTimeout -> [TestTarget] -> Eff es Test.Suites-runTestsForTargets testTimeout testTargets = do+runTestsForTargets command testTimeout testTargets = do Pub.publish $ Test.Suites initial Log.info $ "Running " <> show (length testTargets) <> " test suite(s)" fmap Test.Suites . State.execState initial $ traverse_ go testTargets@@ -371,6 +373,7 @@ updated <- State.state $ dup . Map.insert target suite Pub.publish $ Test.Suites updated )+ command.repl testTimeout target updated <- State.state $ dup . Map.insert target finishedSuite
src/Tricorder/Daemon/EvalCommentRunner.hs view
@@ -31,16 +31,17 @@ import Tricorder.Daemon.GhciSession.GhciParser (LoadedModule (..)) import Tricorder.Daemon.GhciSession.GhciProcess (execGhci, withGhciProcess) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command)+import Tricorder.Session.Command (Command (..), Repl) import Tricorder.Build.EvalComment qualified as Eval+import Tricorder.Session.Target qualified as Target data EvalCommentRunner :: Effect where -- | 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- :: Command+ :: Repl -> NonEmpty (LoadedModule, NonEmpty Eval.Comment) -> EvalCommentRunner m (NonEmpty Eval.Evaluation) -- | Extract eval comments from provided source files. Returns a map of all@@ -78,10 +79,10 @@ case Eval.findComments $ decodeUtf8Lenient bs of [] -> [] x : xs -> [(lm, x :| xs)]- EvaluateComments command moduleComments -> do+ EvaluateComments repl moduleComments -> do fmap sconcat $ for moduleComments \(lm, comments) -> do runFileEvals- command+ repl lm.relPath lm.moduleName comments@@ -106,7 +107,7 @@ , Reader ProjectRoot :> es , Timeout :> es )- => Command+ => Repl -> FilePath -- ^ Relative path to the source file (stored in results). -> Text@@ -114,7 +115,7 @@ -- in interpreted mode so that its full local scope is available. -> NonEmpty Eval.Comment -> Eff es (NonEmpty Eval.Evaluation)-runFileEvals cmd relPath moduleName comments = do+runFileEvals repl relPath moduleName comments = do ProjectRoot projectRoot <- ask let noProgress = \_ -> pure () noSetup = \_ -> pure ()@@ -122,8 +123,8 @@ | T.elem '\n' expr = ":{" <> "\n" <> expr <> "\n" <> ":}" | otherwise = expr sessionResult <- trySync- $ withGhciProcess def cmd projectRoot noProgress noSetup \ghci _ -> do- _ <- execGhci ghci (":load *" <> moduleName) noProgress+ $ withGhciProcess def (Command repl [] [Target.Bare moduleName]) projectRoot noProgress noSetup \ghci _ -> do+ _ <- execGhci ghci (":m *" <> moduleName) noProgress for comments \comment -> do outputResult <- trySync $ execGhci ghci (wrapForGhci comment.expression) noProgress pure
src/Tricorder/Daemon/GhciSession/GhciProcess.hs view
@@ -58,7 +58,9 @@ ) import Tricorder.Session.Command (Command (..)) +import Tricorder.Session.Command qualified as Command + -- | Configuration for GHCi process management. data Config = Config { startupTimeout :: Second@@ -234,7 +236,9 @@ $ setStdout createPipe $ setStderr createPipe $ setWorkingDir dir- $ shell (toString cmd.getCommand)+ $ shell+ $ toString+ $ Command.render cmd -- | Execute a command in GHCi and return the combined stdout+stderr output
src/Tricorder/Daemon/Main.hs view
@@ -35,7 +35,6 @@ import Tricorder.Session.CabalFile (inputCabalFiles) import Tricorder.Socket.UnixSocket (runUnixSocketIO) import Tricorder.SourceLookup (SourceQuery)-import Tricorder.SourceLookup.Cabal (runCabalIO) import Tricorder.SourceLookup.GhcPkg (runGhcPkgIO) import Tricorder.Daemon.Core qualified as Core@@ -44,6 +43,8 @@ import Tricorder.Daemon.TestRunner qualified as TestRunner import Tricorder.Socket.Server qualified as Server import Tricorder.SourceLookup qualified as SourceLookup+import Tricorder.SourceLookup.Hackage qualified as Hackage+import Tricorder.SourceLookup.PackageStore qualified as PackageStore import Tricorder.Version qualified as Version import Tricorder.Waiters qualified as Waiters @@ -77,7 +78,6 @@ . runCacheTtl @ModuleName @PackageId . runCacheTtl @(PackageId, SourceQuery) @SourceLookup.ModuleSourceResult . runProcessIO- . runCabalIO . runEnv . runGhcPkgIO . runUnixSocketIO@@ -85,6 +85,8 @@ . evalState (BuildId 1) . Input.fromState @BuildId . runPubSub_ @BuildPhase+ . Hackage.run+ . PackageStore.run . EvalCommentRunner.run . TestRunner.run . Waiters.run
src/Tricorder/Daemon/TestRunner.hs view
@@ -41,8 +41,8 @@ , withGhciProcess ) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..))-import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+import Tricorder.Session.Command (Command (..), Repl)+import Tricorder.Session.TestTarget (TestTarget, getTestTarget, renderTestTarget) import Tricorder.Session.TestTimeout (TestTimeout (..)) import Tricorder.TestOutput (parseHspecDuration, parseHspecOutput) @@ -55,6 +55,7 @@ RunTestSuite :: (Test.Suite -> m ()) -- ^ Handler for test run progress+ -> Repl -> TestTimeout -> TestTarget -> TestRunner m Test.Suite@@ -78,14 +79,14 @@ => Eff (TestRunner : es) a -> Eff es a run act = do interpretWith act \env -> \case- RunTestSuite progressHandler testTimeout target ->+ RunTestSuite progressHandler repl testTimeout target -> localUnlift env (ConcUnlift Persistent Unlimited) \unlift -> do let onProgress = unlift . progressHandler . loadingToProgress noProgress _ = pure () noReady _ = pure () ProjectRoot projectRoot <- ask result <- trySync- $ withGhciProcess def (Command $ "cabal repl " <> renderTestTarget target) projectRoot onProgress noReady \ghci _ ->+ $ withGhciProcess def (Command repl [] [getTestTarget target]) projectRoot onProgress noReady \ghci _ -> case testTimeout of TestTimeout secs | secs <= 0 -> Right <$> execGhci ghci ":main" noProgress TestTimeout secs ->@@ -140,7 +141,7 @@ runScripted results = reinterpret_ (evalState results)- (\(RunTestSuite _ _ _) -> popResult)+ (\(RunTestSuite _ _ _ _) -> popResult) where popResult :: Eff (State [Either SomeException Test.Suite] : es) Test.Suite popResult =
src/Tricorder/Module.hs view
@@ -1,8 +1,14 @@-module Tricorder.Module (ModuleName (..), PackageId (..)) where+module Tricorder.Module+ ( ModuleName (..)+ , PackageId (..)+ , splitPackageId+ ) where import Data.Aeson (FromJSON, ToJSON) +import Data.Text qualified as T + -- | A dotted Haskell module name, e.g. @"Data.Map.Strict"@. newtype ModuleName = ModuleName {unModuleName :: Text} deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON)@@ -11,3 +17,13 @@ -- | A @ghc-pkg@ package identifier, e.g. @"containers-0.6.8"@. newtype PackageId = PackageId {unPackageId :: Text} deriving newtype (Eq, FromJSON, Hashable, IsString, Ord, Show, ToJSON)+++-- | Split a 'PackageId' into its package name and version. The version is the+-- final hyphen-delimited component (versions are dot-, not hyphen-separated),+-- so @"list-t-1.0.5.7"@ → @("list-t", "1.0.5.7")@.+splitPackageId :: PackageId -> (Text, Text)+splitPackageId (PackageId pid) =+ case reverse (T.splitOn "-" pid) of+ (ver : nameParts@(_ : _)) -> (T.intercalate "-" (reverse nameParts), ver)+ _ -> (pid, "")
src/Tricorder/Session/Command.hs view
@@ -1,26 +1,57 @@ module Tricorder.Session.Command ( Command (..)+ , Repl (..)+ , render , resolveCommand ) where -import Atelier.Effects.FileSystem (FileSystem, doesFileExist, listDirectory)-import Data.Aeson (FromJSON (..), ToJSON (..))+import Atelier.Effects.FileSystem (FileSystem) import Data.Default (Default (..))-import System.FilePath (takeExtension, (</>))+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 (..))-import Tricorder.Session.Target (Target, renderTarget)-import Tricorder.Session.TestTarget (TestTarget, renderTestTarget)+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 -newtype Command = Command {getCommand :: Text}++data Command = Command+ { repl :: Repl+ , arguments :: [Text]+ , targets :: [Target]+ } deriving stock (Eq, Generic, Show)- deriving (FromJSON, ToJSON) via Text +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 ""+ def = Command Unknown [] [] -- | Resolve the GHCi command, using config if set or autodetecting otherwise.@@ -29,37 +60,75 @@ -- 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 cfg targets testTargets =+resolveCommand projectRoot@(ProjectRoot root) cfg targets testTargets = case cfg.command of- Just cmd -> pure $ Command cmd- Nothing -> detectCommand targets testTargets cfg.replBuildDir projectRoot+ 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 [] --- | Build the autodetected GHCi command.------ Configured @targets@ are spelled out verbatim. Otherwise we use cabal's--- catch-all @all@ plus the discovered @test:@ targets, because--- @cabal repl --enable-multi-repl all@ omits test suites unless the project sets--- @tests: True@ in @cabal.project@ — so test errors would go unnoticed.------ We keep @all@ rather than enumerating every component: @all@ lets cabal order--- the multi-repl units, and GHCi makes the /last/ unit the active one. If that--- unit imports a custom @Prelude@ from a sibling home package, GHCi reports it--- "not loaded" and the session dies — which a naive discovery-order enumeration--- triggers but @all@ avoids. Appending already-included test targets is a no-op--- (cabal deduplicates). detectCommand :: (FileSystem :> es) => [Target] -> [TestTarget] -> FilePath -> ProjectRoot -> Eff es Command-detectCommand targets testTargets replBuildDir (ProjectRoot projectRoot) = do- hasCabalProject <- doesFileExist (projectRoot </> "cabal.project")- cabalFiles <- filter (\f -> takeExtension f == ".cabal") <$> listDirectory projectRoot- hasStack <- doesFileExist (projectRoot </> "stack.yaml")- let targetStr- | not (null targets) = unwords (map renderTarget targets)- | otherwise = unwords ("all" : map renderTestTarget testTargets)- buildDirFlag = "--builddir " <> toText replBuildDir <> " "+detectCommand targets testTargets replBuildDir projectRoot = do+ cmd <-+ fmap (fromMaybe (fallback replBuildDir) . rightToMaybe)+ $ runNonDet OnEmptyKeep+ $ useStack projectRoot+ `plusEff` useMultiCabal projectRoot replBuildDir pure- if- | hasCabalProject || not (null cabalFiles) ->- Command $ "cabal repl --enable-multi-repl " <> buildDirFlag <> targetStr- | hasStack -> Command $ "stack ghci " <> targetStr- | otherwise -> Command $ "cabal repl " <> buildDirFlag <> targetStr+ $ 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]
src/Tricorder/Session/Target.hs view
@@ -3,6 +3,7 @@ , ComponentKind (..) , parseTarget , renderTarget+ , componentName , resolveTargets , definesCustomPrelude , compareTargets@@ -38,6 +39,10 @@ = -- | A @kind:name@ reference, e.g. @lib:foo@, @exe:foo@, @test:foo@. An -- empty name with 'Lib' (i.e. @lib:@) denotes the package's main library. Qualified ComponentKind Text+ | -- | A @package:kind:name@ reference, e.g. @foo:lib:foo@, @bar:exe:foo@,+ -- @baz:test:foo@. An empty name with 'Lib' (i.e. @foo:lib:@) denotes the+ -- package's main library.+ PackageQualified Text ComponentKind Text | -- | A name with no @kind:@ prefix. Refers either to a package (all of its -- components) or to a single component matched by name. Bare Text@@ -95,6 +100,7 @@ -- 'Unrecognized'. parseTarget :: Text -> Target parseTarget 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@@ -106,10 +112,19 @@ renderTarget :: Target -> Text renderTarget = \case Qualified kind name -> kindPrefix kind <> ":" <> name+ PackageQualified packageName kind name -> packageName <> ":" <> kindPrefix kind <> ":" <> name Bare name -> name Unrecognized raw -> raw +componentName :: Target -> Text+componentName = \case+ Qualified _ name -> name+ PackageQualified _ _ name -> name+ Bare name -> name+ Unrecognized raw -> raw++ -- | Infer the effective targets to build and watch. This is the boundary where -- raw target strings (from config) are parsed into structured 'Target's: the -- configured targets are parsed as-is, or all components across every@@ -153,13 +168,10 @@ relevantLibs gpd = let pkgN = unPackageName gpd.packageDescription.package.pkgName in case target of- Qualified Lib "" ->- toList $ condTreeData <$> condLibrary gpd- Qualified Lib name- | toString name == pkgN ->- toList $ condTreeData <$> condLibrary gpd- | otherwise ->- subLibsNamed gpd (toString name)+ PackageQualified _ Lib "" -> getMainLib gpd+ Qualified Lib "" -> getMainLib gpd+ PackageQualified _ Lib name -> getSubLib gpd pkgN name+ Qualified Lib name -> getSubLib gpd pkgN name Bare name | toString name == pkgN -> toList (condTreeData <$> condLibrary gpd)@@ -171,6 +183,12 @@ map (condTreeData . snd) $ filter ((== mkUnqualComponentName name) . fst) $ condSubLibraries gpd+ getMainLib gpd = toList $ condTreeData <$> condLibrary gpd+ getSubLib gpd pkgN name+ | toString name == pkgN =+ toList $ condTreeData <$> condLibrary gpd+ | otherwise =+ subLibsNamed gpd (toString name) allComponentTargets :: GenericPackageDescription -> [Target]@@ -183,10 +201,11 @@ ++ benchTargets where mainPkgName = toText $ unPackageName . pkgName . package . packageDescription $ gpd- mainLibTargets = maybe [] (const [Qualified Lib mainPkgName]) (condLibrary gpd)- subLibTargets = map (\(n, _) -> Qualified Lib (componentName n)) (condSubLibraries gpd)- flibTargets = map (\(n, _) -> Qualified FLib (componentName n)) (condForeignLibs gpd)- exeTargets = map (\(n, _) -> Qualified Exe (componentName n)) (condExecutables gpd)- testTargets = map (\(n, _) -> Qualified Test (componentName n)) (condTestSuites gpd)- benchTargets = map (\(n, _) -> Qualified Bench (componentName n)) (condBenchmarks gpd)- componentName = toText . unUnqualComponentName+ mainLibTargets = maybe [] (const [qualified Lib mainPkgName]) (condLibrary gpd)+ subLibTargets = map (\(n, _) -> qualified Lib (getComponentName n)) (condSubLibraries gpd)+ flibTargets = map (\(n, _) -> qualified FLib (getComponentName n)) (condForeignLibs gpd)+ exeTargets = map (\(n, _) -> qualified Exe (getComponentName n)) (condExecutables gpd)+ testTargets = map (\(n, _) -> qualified Test (getComponentName n)) (condTestSuites gpd)+ benchTargets = map (\(n, _) -> qualified Bench (getComponentName n)) (condBenchmarks gpd)+ getComponentName = toText . unUnqualComponentName+ qualified = PackageQualified mainPkgName
src/Tricorder/Session/TestTarget.hs view
@@ -35,6 +35,7 @@ projectTestTargets = mapMaybe mkTestTarget where mkTestTarget tgt@(Qualified Test _) = Just $ TestTarget tgt+ mkTestTarget tgt@(PackageQualified _ Test _) = Just $ TestTarget tgt mkTestTarget _ = Nothing
src/Tricorder/Session/WatchDirs.hs view
@@ -87,6 +87,14 @@ Qualified Exe name -> exeSourceDirs name Qualified Test name -> testSourceDirs name Qualified Bench name -> benchSourceDirs name+ PackageQualified _ Lib "" -> mainLibSourceDirs+ PackageQualified _ Lib name+ | toString name == mainPkgName -> mainLibSourceDirs+ | otherwise -> subLibSourceDirs name+ PackageQualified _ FLib name -> flibSourceDirs name+ PackageQualified _ Exe name -> exeSourceDirs name+ PackageQualified _ Test name -> testSourceDirs name+ PackageQualified _ Bench name -> benchSourceDirs name -- A bare target (no @kind:@ prefix) is a package name or a component -- name. A package name covers every component; otherwise match a -- single component by name across the kinds.
src/Tricorder/Socket/Server.hs view
@@ -2,7 +2,6 @@ import Atelier.Effects.Cache (Cache) import Atelier.Effects.Conc (Conc)-import Atelier.Effects.Env (Env) import Atelier.Effects.Exit (Exit, exitSuccess) import Atelier.Effects.FileSystem (FileSystem) import Atelier.Effects.Input (Input, input)@@ -41,8 +40,9 @@ , sendLine ) import Tricorder.SourceLookup (ModuleSourceResult, SourceQuery (..), lookupModuleSource)-import Tricorder.SourceLookup.Cabal (Cabal) import Tricorder.SourceLookup.GhcPkg (GhcPkg)+import Tricorder.SourceLookup.Hackage (Hackage)+import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.Version (VersionMismatch (..), checkVersion) import Tricorder.Waiters (Waiters) @@ -58,17 +58,17 @@ main- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es , Conc :> es- , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es+ , Hackage :> es , Input BuildId :> es , Input DaemonInfo :> es , Log :> es+ , PackageStore :> es , Reader SocketPath :> es , Sub BuildPhase :> es , UnixSocket :> es@@ -84,17 +84,17 @@ acceptTrigger- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es , Conc :> es- , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es+ , Hackage :> es , Input BuildId :> es , Input DaemonInfo :> es , Log :> es+ , PackageStore :> es , Reader SocketPath :> es , State BuildPhase :> es , Sub BuildPhase :> es@@ -112,17 +112,17 @@ handleConnection- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es , Conc :> es- , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es+ , Hackage :> es , Input BuildId :> es , Input DaemonInfo :> es , Log :> es+ , PackageStore :> es , State BuildPhase :> es , Sub BuildPhase :> es , UnixSocket :> es@@ -144,17 +144,17 @@ dispatch- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es , Conc :> es- , Env :> es , Exit :> es , FileSystem :> es , GhcPkg :> es+ , Hackage :> es , Input BuildId :> es , Input DaemonInfo :> es , Log :> es+ , PackageStore :> es , State BuildPhase :> es , Sub BuildPhase :> es , UnixSocket :> es@@ -265,13 +265,13 @@ -- | Look up source for each requested module and send the results as a JSON array. respondSource- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es- , Env :> es , FileSystem :> es , GhcPkg :> es+ , Hackage :> es , Log :> es+ , PackageStore :> es , UnixSocket :> es ) => [SourceQuery]
src/Tricorder/SourceLookup.hs view
@@ -8,7 +8,6 @@ ) where import Atelier.Effects.Cache (Cache, cacheInsert, cacheLookup)-import Atelier.Effects.Env (Env) import Atelier.Effects.FileSystem (FileSystem) import Atelier.Effects.Log (Log) import Data.Aeson (FromJSON, ToJSON)@@ -16,8 +15,9 @@ import Atelier.Effects.Log qualified as Log import Tricorder.Module (ModuleName (..), PackageId (..))-import Tricorder.SourceLookup.Cabal (Cabal) import Tricorder.SourceLookup.GhcPkg (GhcPkg)+import Tricorder.SourceLookup.Hackage (Hackage)+import Tricorder.SourceLookup.PackageStore (PackageStore) import Tricorder.SourceLookup.Slice (sliceSymbol) import Tricorder.SourceLookup.Tarball ( TarballOutcome (..)@@ -66,13 +66,13 @@ -- steps are cached, so the fetch + read cost is paid at most once per -- (package, query). lookupModuleSource- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , Cache ModuleName PackageId :> es- , Env :> es , FileSystem :> es , GhcPkg :> es+ , Hackage :> es , Log :> es+ , PackageStore :> es ) => SourceQuery -> Eff es ModuleSourceResult@@ -110,10 +110,11 @@ -- | Locate (or fetch) the package's tarball, read the module member, and slice -- the requested symbol if any. Caches and returns the result. serveFromTarball- :: ( Cabal :> es- , Cache (PackageId, SourceQuery) ModuleSourceResult :> es- , Env :> es+ :: ( Cache (PackageId, SourceQuery) ModuleSourceResult :> es , FileSystem :> es+ , Hackage :> es+ , Log :> es+ , PackageStore :> es ) => SourceQuery -> PackageId
− src/Tricorder/SourceLookup/Cabal.hs
@@ -1,99 +0,0 @@--- | A narrow effect for the non-interactive @cabal@ subcommands tricorder--- needs. The interpreter is the /sole/ spawner of the @cabal@ executable, and--- it only ever runs the specific, pre-validated commands modelled here —--- callers can neither pass arbitrary arguments nor choose the working--- directory (fetches are pinned to the project root). Interactive--- @cabal repl@ sessions are a separate concern, handled by--- "Tricorder.Daemon.GhciSession.GhciProcess".-module Tricorder.SourceLookup.Cabal- ( -- * Effect- Cabal- , FetchResult (..)- , fetchSource-- -- * Interpreters- , runCabalIO- , runCabalFetchWith- , CabalScript (..)- ) where--import Atelier.Effects.Log (Log)-import Atelier.Effects.Process (Process, proc, readProcess, setWorkingDir)-import Effectful (Effect)-import Effectful.Dispatch.Dynamic (interpret)-import Effectful.Exception (trySync)-import Effectful.Reader.Static (Reader, ask)-import Effectful.TH (makeEffect)-import System.Exit (ExitCode (..))--import Atelier.Effects.Log qualified as Log-import Data.Text qualified as T--import Tricorder.Module (PackageId (..))-import Tricorder.Runtime (ProjectRoot (..))----- | Whether an on-demand fetch exited cleanly. A clean exit that still leaves--- no tarball is a /deterministic/ absence (safe to cache); a failed fetch is--- /transient/ (must not be cached).-data FetchResult = Fetched | FetchFailed- deriving stock (Eq, Show)----- | The non-interactive @cabal@ subcommands tricorder drives. Each runs the--- user's /own/ @cabal@ executable inside their project — tricorder deliberately--- does not bring the @Cabal@ library along as a Haskell dependency, so--- behaviour always matches the user's toolchain and project configuration.-data Cabal :: Effect where- -- | @cabal fetch --no-dependencies \<pkgId\>@, run in the project root so it- -- honours the project's configured repositories (CHaP, constraints).- -- Reports only whether the fetch exited cleanly, so a transient failure- -- (offline, stale index, yanked) stays distinguishable from a genuine- -- absence and is not cached.- FetchSource :: PackageId -> Cabal m FetchResult---makeEffect ''Cabal----- | Production interpreter. The only code path that spawns @cabal@.-runCabalIO- :: (Log :> es, Process :> es, Reader ProjectRoot :> es)- => Eff (Cabal : es) a- -> Eff es a-runCabalIO = interpret \_ -> \case- FetchSource pkgId -> do- ProjectRoot projectRoot <- ask- Log.info $ "Source: cabal fetch " <> unPackageId pkgId- let cfg =- setWorkingDir projectRoot- $ proc "cabal" ["fetch", "--no-dependencies", toString (unPackageId pkgId)]- result <- trySync (readProcess cfg)- case result of- Right (ExitSuccess, _, _) -> pure Fetched- Right (ExitFailure _, out, err) -> do- let details = T.strip (decodeUtf8 (err <> out))- suffix = if T.null details then "" else ": " <> details- Log.warn $ "Source: cabal fetch failed for " <> unPackageId pkgId <> suffix- pure FetchFailed- Left e -> do- Log.warn $ "Source: cabal fetch failed for " <> unPackageId pkgId <> ": " <> show e- pure FetchFailed----- | Test interpreter: every 'fetchSource' yields the result of @onFetch@, which--- runs in the remaining effects so it can model the fetch's observable side--- effect — e.g. populating a fake filesystem to mimic a warmed cache.--- 'cabalVersion' is unsupported. Use this when the unit under test drives--- @cabal@ solely through 'fetchSource'.-runCabalFetchWith :: Eff es FetchResult -> Eff (Cabal : es) a -> Eff es a-runCabalFetchWith onFetch = interpret \_ -> \case- FetchSource _ -> onFetch----- | Script element for the pure test interpreter.-data CabalScript- = -- | Return this value for the next 'fetchSource' call.- NextFetch FetchResult- | -- | Return this value for the next 'cabalVersion' call.- NextVersion (Maybe Text)
+ src/Tricorder/SourceLookup/Hackage.hs view
@@ -0,0 +1,90 @@+module Tricorder.SourceLookup.Hackage+ ( Hackage (..)+ , Result (..)+ , fetchPackage+ , run+ ) where++import Atelier.Effects.Log (Log)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Exception (catch)+import Effectful.TH (makeEffect)+import Network.HTTP.Req+ ( GET (..)+ , HttpException+ , NoReqBody (..)+ , Scheme (..)+ , Url+ , bsResponse+ , defaultHttpConfig+ , https+ , renderUrl+ , req+ , responseBody+ , responseStatusCode+ , responseStatusMessage+ , runReq+ , (/:)+ )++import Atelier.Effects.Log qualified as Log++import Tricorder.Module (PackageId, unPackageId)+++data Hackage :: Effect where+ FetchPackage :: PackageId -> Hackage m Result+++data Result+ = NotFound+ | Failure Text+ | Success ByteString+++makeEffect ''Hackage+++run :: (IOE :> es, Log :> es) => Eff (Hackage : es) a -> Eff es a+run = interpret_ \case+ FetchPackage packageId -> do+ let url = packageUrl packageId+ Log.debug $ "Fetching sdist from " <> renderUrl url+ result <-+ flip catch (pure . Left @HttpException) . fmap Right+ $ liftIO+ $ runReq defaultHttpConfig+ $ req+ GET+ (url)+ NoReqBody+ bsResponse+ mempty+ case result of+ Left ex -> do+ pure+ $ Failure+ $ "Failed to fetch "+ <> unPackageId packageId+ <> " from "+ <> show url+ <> "\n"+ <> show ex+ Right response -> do+ let statusCode = responseStatusCode response+ if+ | statusCode >= 200 && statusCode < 300 ->+ pure $ Success $ responseBody response+ | statusCode == 404 ->+ pure NotFound+ | otherwise -> do+ pure $ Failure $ show (responseStatusCode response) <> ": " <> decodeUtf8 (responseStatusMessage response)+++packageUrl :: PackageId -> Url 'Https+packageUrl packageId =+ https "hackage.haskell.org"+ /: "package"+ /: unPackageId packageId+ /: unPackageId packageId <> ".tar.gz"
+ src/Tricorder/SourceLookup/PackageStore.hs view
@@ -0,0 +1,139 @@+module Tricorder.SourceLookup.PackageStore+ ( PackageStore (..)+ , add+ , getPath+ , run+ ) where++import Atelier.Effects.Env (Env, getEnvironment)+import Atelier.Effects.FileSystem (FileSystem)+import Effectful (Effect)+import Effectful.Dispatch.Dynamic (interpretWith_)+import Effectful.NonDet (NonDet, OnEmptyPolicy (..), emptyEff, plusEff, runNonDet)+import Effectful.TH (makeEffect)+import System.FilePath (takeDirectory, (</>))++import Atelier.Effects.FileSystem qualified as FileSystem+import Data.Map.Strict qualified as Map++import Tricorder.Module (PackageId, splitPackageId, unPackageId)+++data PackageStore :: Effect where+ Add :: PackageId -> ByteString -> PackageStore m FilePath+ GetPath :: PackageId -> PackageStore m (Maybe FilePath)+++makeEffect ''PackageStore+++run :: (Env :> es, FileSystem :> es) => Eff (PackageStore : es) a -> Eff es a+run act = do+ storeBaseDir <- findStoreBaseDir+ let packageDir = storeBaseDir </> "packages" </> hackageRepo+ FileSystem.createDirectoryIfMissing True packageDir+ interpretWith_ act \case+ Add packageId bytes -> do+ let path = packagePath packageDir packageId+ exists <- FileSystem.doesPathExist path+ unless exists do+ FileSystem.createDirectoryIfMissing True (takeDirectory path)+ FileSystem.writeFileBS path bytes+ pure path+ GetPath packageId -> do+ let path = packagePath packageDir packageId+ exists <- FileSystem.doesPathExist path+ if exists then+ pure $ Just path+ else+ pure Nothing+++packagePath :: FilePath -> PackageId -> FilePath+packagePath packageDir packageId =+ packageDir+ </> toString packageName+ </> toString packageVersion+ </> toString (unPackageId packageId <> ".tar.gz")+ where+ (packageName, packageVersion) = splitPackageId packageId+++hackageRepo :: FilePath+hackageRepo = "hackage.haskell.org"+++findStoreBaseDir :: (Env :> es, FileSystem :> es) => Eff es FilePath+findStoreBaseDir = do+ env <- Map.fromList <$> getEnvironment+ fmap (fromMaybe tempFallback . rightToMaybe)+ $ runNonDet OnEmptyKeep+ $ findCabalDirCandidate env+ `plusEff` findXdgCandidate env+ `plusEff` findHomeCandidate env+ `plusEff` findFallback env+++findCabalDirCandidate+ :: (FileSystem :> es, NonDet :> es)+ => Map String String -> Eff es FilePath+findCabalDirCandidate env =+ case Map.lookup "CABAL_DIR" env of+ Nothing -> emptyEff+ Just cabalDir -> getDir cabalDir+++findXdgCandidate+ :: (FileSystem :> es, NonDet :> es)+ => Map String String -> Eff es FilePath+findXdgCandidate env =+ case Map.lookup "XDG_CACHE_HOME" env of+ Nothing -> emptyEff+ Just cacheHome -> getDir $ cacheHome </> "cabal"+++findHomeCandidate+ :: (FileSystem :> es, NonDet :> es)+ => Map String String -> Eff es FilePath+findHomeCandidate env =+ case Map.lookup "HOME" env of+ Nothing -> emptyEff+ Just home -> do+ let cacheCandidate = home </> ".cache" </> "cabal"+ homeCandidate = home </> ".cabal"+ getDir cacheCandidate+ `plusEff` getDir homeCandidate+++findFallback :: (NonDet :> es) => Map String String -> Eff es FilePath+findFallback env =+ findXdgFallback env+ `plusEff` findHomeFallback env+++findXdgFallback :: (NonDet :> es) => Map String String -> Eff es FilePath+findXdgFallback env =+ case Map.lookup "XDG_CACHE_HOME" env of+ Nothing -> emptyEff+ Just cacheHome -> pure $ cacheHome </> "cabal"+++findHomeFallback :: (NonDet :> es) => Map String String -> Eff es FilePath+findHomeFallback env =+ case Map.lookup "HOME" env of+ Nothing -> emptyEff+ Just home ->+ pure $ home </> ".cabal"+++tempFallback :: FilePath+tempFallback = "/tmp/tricorder/packages"+++getDir :: (FileSystem :> es, NonDet :> es) => FilePath -> Eff es FilePath+getDir fp = do+ exists <- FileSystem.doesDirectoryExist fp+ if exists then+ pure fp+ else+ emptyEff
src/Tricorder/SourceLookup/Tarball.hs view
@@ -7,38 +7,31 @@ , readModuleMember -- * Pure helpers (exposed for testing)- , splitPackageId , tarballPath , cabalPackagesDirs , matchesModule , extractModule ) where -import Atelier.Effects.Env (Env, getEnvironment)-import Atelier.Effects.FileSystem- ( FileSystem- , doesFileExist- , doesPathExist- , listDirectory- , readFileLbs- )+import Atelier.Effects.FileSystem (FileSystem, readFileLbs)+import Atelier.Effects.Log (Log) import Data.Char (isUpper) import Effectful.Exception (trySync) import System.FilePath (splitDirectories, (</>)) +import Atelier.Effects.Log qualified as Log import Codec.Archive.Tar qualified as Tar import Codec.Compression.GZip qualified as GZip import Data.ByteString.Lazy qualified as BSL import Data.List qualified as List import Data.Text qualified as T -import Tricorder.Module (ModuleName (..), PackageId (..))-import Tricorder.SourceLookup.Cabal (Cabal, FetchResult (..), fetchSource)-+import Tricorder.Module (ModuleName (..), PackageId (..), splitPackageId)+import Tricorder.SourceLookup.Hackage (Hackage)+import Tricorder.SourceLookup.PackageStore (PackageStore) --- | The default repository subdirectory under the cabal package cache.-hackageRepo :: FilePath-hackageRepo = "hackage.haskell.org"+import Tricorder.SourceLookup.Hackage qualified as Hackage+import Tricorder.SourceLookup.PackageStore qualified as PackageStore -- ── High-level ─────────────────────────────────────────────────────────────@@ -54,30 +47,28 @@ deriving stock (Eq, Show) --- | Locate @pkgId@'s sdist tarball in the cabal cache, fetching it on demand if--- absent.------ The cache holds one @\<pkg\>-\<ver\>.tar.gz@ per resolved package at a--- predictable path. On a hit we return that path directly. On a miss we warm--- the cache with @cabal fetch --no-dependencies@ — the exact version @ghc-pkg@--- reports — and look again. The outcome distinguishes a genuine absence from a--- transient fetch failure. obtainTarball- :: (Cabal :> es, Env :> es, FileSystem :> es)+ :: (Hackage :> es, Log :> es, PackageStore :> es) => PackageId -> Eff es TarballOutcome obtainTarball pkgId = do- found <- findTarball pkgId+ found <- PackageStore.getPath pkgId case found of Just path -> pure (TarballAt path) Nothing -> do- fetched <- fetchSource pkgId- refound <- findTarball pkgId- pure $ case refound of- Just path -> TarballAt path- Nothing -> case fetched of- Fetched -> TarballAbsent- FetchFailed -> TarballFetchFailed+ res <- Hackage.fetchPackage pkgId+ case res of+ Hackage.NotFound -> do+ Log.warn $ "Package not found: " <> unPackageId pkgId+ pure TarballAbsent+ Hackage.Failure err -> do+ Log.err $ "Hackage fetch error: " <> err+ pure $ TarballFetchFailed+ Hackage.Success bytes -> do+ Log.info $ "Storing tarball for " <> unPackageId pkgId+ path <- PackageStore.add pkgId bytes+ Log.info $ "Tarball stored at " <> toText path+ pure $ TarballAt path -- | Read a single module's source from a tarball, in-process. 'Nothing' when@@ -94,35 +85,6 @@ -- ── Locate ───────────────────────────────────────────────────────────────── --- | Search every candidate cabal cache directory (and every repository subdir--- within it) for @pkgId@'s tarball, preferring @hackage.haskell.org@.-findTarball :: (Env :> es, FileSystem :> es) => PackageId -> Eff es (Maybe FilePath)-findTarball pkgId = do- env <- getEnvironment- candidates <- concat <$> traverse basePaths (cabalPackagesDirs env)- firstExisting candidates- where- basePaths base = do- repos <- listRepos base- pure [tarballPath base repo pkgId | repo <- repos]- firstExisting [] = pure Nothing- firstExisting (p : ps) = do- exists <- doesFileExist p- if exists then pure (Just p) else firstExisting ps----- | The repository subdirectories under the cache, @hackage.haskell.org@ first.--- Falls back to just @hackage.haskell.org@ when the cache directory is absent.-listRepos :: (FileSystem :> es) => FilePath -> Eff es [FilePath]-listRepos base = do- exists <- doesPathExist base- if not exists then- pure [hackageRepo]- else do- entries <- listDirectory base- pure (hackageRepo : filter (/= hackageRepo) entries)-- -- | Candidate cabal package-cache directories to search, most-preferred first. -- -- Honors @CABAL_DIR@; otherwise searches the XDG cache and both the modern@@ -151,16 +113,6 @@ -- ── Pure helpers ───────────────────────────────────────────────────────────---- | Split a 'PackageId' into its package name and version. The version is the--- final hyphen-delimited component (versions are dot-, not hyphen-separated),--- so @"list-t-1.0.5.7"@ → @("list-t", "1.0.5.7")@.-splitPackageId :: PackageId -> (Text, Text)-splitPackageId (PackageId pid) =- case reverse (T.splitOn "-" pid) of- (ver : nameParts@(_ : _)) -> (T.intercalate "-" (reverse nameParts), ver)- _ -> (pid, "")- -- | The cache path of a package's tarball under one repository subdir: -- @\<base\>\/\<repo\>\/\<pkg\>\/\<ver\>\/\<pkg\>-\<ver\>.tar.gz@.
test/Unit/Tricorder/Daemon/GhciSessionSpec.hs view
@@ -19,7 +19,7 @@ , withGhci ) import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..))+import Tricorder.Session.Command (Command (..), Repl (..)) spec_GhciSession :: Spec@@ -38,40 +38,40 @@ it "returns scripted messages" do LoadResult {diagnostics = msgs} <- runScripted [simpleResult [errMsg]]- $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial+ $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial msgs `shouldBe` [errMsg] it "returns empty list when scripted result has no messages" do LoadResult {diagnostics = msgs} <- runScripted [simpleResult []]- $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial+ $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial msgs `shouldBe` [] it "throws when scripted result is Left" do result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ withGhci (Command "cabal repl") (ProjectRoot "/") \initial _ -> pure initial+ $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial result `shouldBe` Left boom describe "reloading" do it "returns scripted messages" do LoadResult {diagnostics = msgs} <- runScripted [simpleResult [warnMsg], simpleResult [errMsg]]- $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload+ $ withGhci cmd (ProjectRoot "/") \_ controls -> controls.reload msgs `shouldBe` [errMsg] it "throws when scripted result is Left" do result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ withGhci (Command "cabal repl") (ProjectRoot "/") \_ controls -> controls.reload+ $ withGhci cmd (ProjectRoot "/") \_ controls -> controls.reload result `shouldBe` Left boom describe "sequencing" do it "consumes results in order across mixed operations" do (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do- withGhci (Command "cabal repl") (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do+ withGhci cmd (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do LoadResult {diagnostics = b} <- controls.reload pure (a, b) a `shouldBe` [errMsg]@@ -79,8 +79,8 @@ it "recover scenario: error then success" do result <- runScripted [Left (toException boom), simpleResult []] do- r1 <- try @ErrorCall $ withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i- LoadResult {diagnostics = r2} <- withGhci (Command "cabal repl") (ProjectRoot "/") \i _ -> pure i+ 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` []@@ -89,6 +89,10 @@ -------------------------------------------------------------------------------- -- Helpers --------------------------------------------------------------------------------++cmd :: Command+cmd = Command Cabal [] []+ boom :: ErrorCall boom = ErrorCall "simulated GHCi crash"
test/Unit/Tricorder/Daemon/TestRunnerSpec.hs view
@@ -12,6 +12,7 @@ , detectOutcome , runTestSuite )+import Tricorder.Session.Command (Repl (..)) import Tricorder.Session.Target (Target (..)) import Tricorder.Session.TestTarget (TestTarget (..)) import Tricorder.Session.TestTimeout (TestTimeout (..))@@ -103,14 +104,14 @@ it "returns scripted TestRun" do result <- runScripted [Right passingRun]- $ runTestSuite noProgress testTimeout+ $ runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:foo" result `shouldBe` passingRun it "ignores the target name argument" do result <- runScripted [Right failingRun]- $ runTestSuite noProgress testTimeout+ $ runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:anything" result `shouldBe` failingRun @@ -118,23 +119,23 @@ result <- runScripted [Left (toException boom)] $ try @ErrorCall- $ runTestSuite noProgress testTimeout+ $ runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:foo" result `shouldBe` Left boom describe "sequencing" do it "consumes results in order across multiple calls" do (a, b) <- runScripted [Right passingRun, Right failingRun] do- a <- runTestSuite noProgress testTimeout $ mkTestTarget "test:foo"- b <- runTestSuite noProgress testTimeout $ mkTestTarget "test:bar"+ a <- runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:foo"+ b <- runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:bar" pure (a, b) a `shouldBe` passingRun b `shouldBe` failingRun it "recover scenario: error then success" do result <- runScripted [Left (toException boom), Right passingRun] do- r1 <- try @ErrorCall $ runTestSuite noProgress testTimeout $ mkTestTarget "test:foo"- r2 <- runTestSuite noProgress testTimeout $ mkTestTarget "test:bar"+ r1 <- try @ErrorCall $ runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:foo"+ r2 <- runTestSuite noProgress Cabal testTimeout $ mkTestTarget "test:bar" pure (r1, r2) fst result `shouldBe` Left boom snd result `shouldBe` passingRun
test/Unit/Tricorder/Session/CommandSpec.hs view
@@ -9,11 +9,12 @@ import Data.Map.Strict qualified as Map import Tricorder.Runtime (ProjectRoot (..))-import Tricorder.Session.Command (Command (..), resolveCommand)+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 @@ -26,8 +27,9 @@ testResolveCommand = do describe "when config has a command" do it "should use specified command" do- let Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState mempty . runFileSystemState $ resolveCommand pr def {command = Just "foo"} [] testTargets@@ -35,8 +37,9 @@ describe "when config has explicit targets" do it "should spell them out verbatim, ignoring discovered test targets" do- let Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState (Map.singleton "/cabal.project" "") . runFileSystemState $ resolveCommand pr cfg (parseTarget <$> ["lib:foo"]) testTargets@@ -45,8 +48,9 @@ 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 Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState (Map.singleton "/cabal.project" "") . runFileSystemState $ resolveCommand pr cfg [] testTargets@@ -55,8 +59,9 @@ describe "and there is at least one *.cabal file" do it "should use cabal 'all' plus the discovered test targets" do- let Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState (Map.singleton "/foo.cabal" "") . runFileSystemState $ resolveCommand pr cfg [] testTargets@@ -65,17 +70,39 @@ describe "and there is a stack.yaml file" do it "should use stack ghci with 'all' plus test targets" do- let Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState (Map.singleton "/stack.yaml" "") . runFileSystemState $ resolveCommand pr cfg [] testTargets- actual `shouldBe` "stack ghci all test:foo"+ 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 Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState mempty . runFileSystemState $ resolveCommand pr cfg [] testTargets@@ -83,8 +110,9 @@ describe "and no test targets are discovered" do it "should fall back to plain 'all'" do- let Command actual =- runPureEff+ let actual =+ Command.render+ . runPureEff . evalState (Map.singleton "/cabal.project" "") . runFileSystemState $ resolveCommand pr cfg [] (parseTestTargets [])
test/Unit/Tricorder/Session/TargetSpec.hs view
@@ -84,17 +84,17 @@ -- alphabetically by their rendered form. let actual = resolveTargets singleCabalFile [] actual- `shouldBe` [ Qualified Bench "myapp-bench"- , Qualified Exe "myapp-exe"- , Qualified FLib "myapp-flib"- , Qualified Lib "myapp"- , Qualified Lib "myapp-utils"- , Qualified Test "myapp-test"+ `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` [Qualified Test "myapp-test"]+ actual `shouldContain` [PackageQualified "myapp" Test "myapp-test"] it "returns no targets when there are no cabal files" do let actual = resolveTargets [] []@@ -104,10 +104,10 @@ it "aggregates components across every package (regression: was 0)" do let actual = resolveTargets multiCabalFiles [] actual- `shouldMatchList` [ Qualified Test "pkg-a-test"- , Qualified Test "pkg-b-test"- , Qualified Lib "pkg-a"- , Qualified Lib "pkg-b"+ `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@@ -116,7 +116,10 @@ $ fromMaybe (error "libWithPreludeCabal failed to parse") $ parseGenericPackageDescriptionMaybe (libWithPreludeCabal "myprelude") let actual = resolveTargets [cabalFile] []- actual `shouldBe` [Qualified Exe "myprelude-exe", Qualified Lib "myprelude"]+ actual+ `shouldBe` [ PackageQualified "myprelude" Exe "myprelude-exe"+ , PackageQualified "myprelude" Lib "myprelude"+ ] testCompareTargets :: Spec@@ -177,12 +180,12 @@ testAllComponentTargets = do it "returns every component for the fixture" do allComponentTargets gpd- `shouldMatchList` [ Qualified Lib "myapp"- , Qualified Lib "myapp-utils"- , Qualified FLib "myapp-flib"- , Qualified Exe "myapp-exe"- , Qualified Test "myapp-test"- , Qualified Bench "myapp-bench"+ `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]@@ -192,7 +195,10 @@ $ fromMaybe (error "failed to parse cabal") $ parseGenericPackageDescriptionMaybe $ libTestCabal "pkg-a"- actual `shouldMatchList` [Qualified Lib "pkg-a", Qualified Test "pkg-a-test"]+ actual+ `shouldMatchList` [ PackageQualified "pkg-a" Lib "pkg-a"+ , PackageQualified "pkg-a" Test "pkg-a-test"+ ] testDefinesCustomPrelude :: Spec
test/Unit/Tricorder/SourceLookup/TarballSpec.hs view
@@ -8,11 +8,11 @@ import Codec.Compression.GZip qualified as GZip import Data.ByteString.Lazy qualified as BSL +import Tricorder.Module (splitPackageId) import Tricorder.SourceLookup.Tarball ( cabalPackagesDirs , extractModule , matchesModule- , splitPackageId , tarballPath )
test/Unit/Tricorder/SourceLookupSpec.hs view
@@ -7,7 +7,6 @@ import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Dispatch.Dynamic (interpret_)-import Effectful.Reader.Static (Reader, runReader) import Effectful.State.Static.Shared (State, evalState, gets, modify) import System.FilePath ((</>)) import Test.Hspec@@ -22,16 +21,18 @@ import Data.Text qualified as T import Tricorder.Module (ModuleName, PackageId)-import Tricorder.Runtime (ProjectRoot (..)) import Tricorder.SourceLookup ( ModuleSourceResult (..) , SourceQuery (..) , lookupModuleSource )-import Tricorder.SourceLookup.Cabal (Cabal, FetchResult (..), runCabalFetchWith) import Tricorder.SourceLookup.GhcPkg (GhcPkg, GhcPkgScript (..), runGhcPkgScripted)+import Tricorder.SourceLookup.Hackage (Hackage (..), Result (..))+import Tricorder.SourceLookup.PackageStore (PackageStore) +import Tricorder.SourceLookup.PackageStore qualified as PackageStore + spec_SourceLookup :: Spec spec_SourceLookup = describe "lookupModuleSource" do it "reads the whole module from a cached tarball" do@@ -61,13 +62,13 @@ $ lookupModuleSource (wholeModule "Data.Unknown") result `shouldBe` SourceNotFound (wholeModule "Data.Unknown") - it "fetches on a cache miss, then reads the now-present tarball" do+ it "fetches from Hackage on a cache miss, then reads the now-fetched tarball" do result <-- runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty (fetchProduces tarballPath tarballBytes)+ runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty (pure (Success (BSL.toStrict tarballBytes))) $ lookupModuleSource (wholeModule "Data.Aeson") result `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource - it "returns SourceUnavailable when the fetch produces no tarball" do+ it "returns SourceUnavailable when the package is not found on Hackage" do result <- runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty noFetch $ lookupModuleSource (wholeModule "Data.Aeson")@@ -85,9 +86,10 @@ r2 `shouldBe` SourceFound (wholeModule "Data.Aeson") moduleSource it "caches an unavailable result and does not re-fetch on a repeat lookup" do- -- The tarball is absent and every fetch fails, so the first lookup is- -- SourceUnavailable. A repeat lookup must be served from cache — no- -- second `cabal fetch` on the (network) request path.+ -- The tarball is absent and every fetch reports the package as not+ -- found, so the first lookup is SourceUnavailable. A repeat lookup must+ -- be served from cache — no second Hackage fetch on the (network)+ -- request path. fetchCount <- IORef.newIORef (0 :: Int) let countingFetch = do liftIO (IORef.modifyIORef' fetchCount (+ 1))@@ -103,14 +105,14 @@ fetches `shouldBe` 1 it "re-fetches after a failed fetch rather than caching the failure" do- -- A failed `cabal fetch` (offline, stale index) is transient, so the- -- resulting SourceUnavailable must NOT be cached: a repeat lookup has to- -- retry the fetch, or a brief network blip pins unavailability for the- -- whole cache window.+ -- A failed Hackage fetch (offline, DNS failure, 5xx) is transient, so+ -- the resulting SourceUnavailable must NOT be cached: a repeat lookup+ -- has to retry the fetch, or a brief network blip pins unavailability+ -- for the whole cache window. fetchCount <- IORef.newIORef (0 :: Int) let failingFetch = do liftIO (IORef.modifyIORef' fetchCount (+ 1))- pure FetchFailed+ pure (Failure "network unreachable") (r1, r2) <- runTest [NextFindModule (Just "aeson-2.2.5.0")] Map.empty failingFetch $ do r1 <- lookupModuleSource (wholeModule "Data.Aeson")@@ -190,32 +192,26 @@ -- Harness -------------------------------------------------------------------------------- --- | The action a faked @cabal fetch@ runs: 'noFetch' leaves the filesystem--- untouched (a clean fetch that produces no tarball); 'fetchProduces' inserts a--- file. A failed fetch is modelled by returning 'FetchFailed' directly.-noFetch :: Eff es FetchResult-noFetch = pure Fetched---fetchProduces- :: (State (Map FilePath LByteString) :> es)- => FilePath -> LByteString -> Eff es FetchResult-fetchProduces path bytes = do- modify (Map.insert path bytes)- pure Fetched+-- | The scripted response to a faked Hackage fetch: 'noFetch' reports the+-- package as a clean 404 (absent from the index, so no tarball). A successful+-- fetch is modelled by returning 'Success' with the tarball bytes directly —+-- 'PackageStore.add' is the one that persists it into the fake filesystem — and+-- a failed fetch, by returning 'Failure' directly.+noFetch :: Eff es Result+noFetch = pure NotFound runTest :: [GhcPkgScript] -> Map FilePath LByteString- -> Eff '[FileSystem, State (Map FilePath LByteString), Log, Concurrent, IOE] FetchResult+ -> Eff '[PackageStore, Env, FileSystem, State (Map FilePath LByteString), Log, Concurrent, IOE] Result -> Eff '[ Cache ModuleName PackageId , Cache (PackageId, SourceQuery) ModuleSourceResult , GhcPkg+ , Hackage+ , PackageStore , Env- , Reader ProjectRoot- , Cabal , FileSystem , State (Map FilePath LByteString) , Log@@ -230,18 +226,26 @@ . runLogNoOp . evalState initialFs . runFileSystemFake- . runCabalFetchWith onFetch- . runReader (ProjectRoot "/proj") . runEnvConst [("HOME", "/h")]+ . PackageStore.run+ . runHackageWith onFetch . runGhcPkgScripted pkgScript . runCacheForever @(PackageId, SourceQuery) @ModuleSourceResult . runCacheForever @ModuleName @PackageId $ action +-- | A scripted 'Hackage' interpreter: every 'fetchPackage' yields the given+-- action's result.+runHackageWith :: Eff es Result -> Eff (Hackage : es) a -> Eff es a+runHackageWith onFetch = interpret_ \case+ FetchPackage _ -> onFetch++ -- | A 'FileSystem' backed by an in-memory map, with directory semantics good -- enough for the cabal-cache layout: 'doesPathExist' treats a key as living--- under any of its path prefixes, and 'listDirectory' returns immediate child+-- under any of its path prefixes (or being one), 'doesDirectoryExist' requires+-- something strictly under it, and 'listDirectory' returns immediate child -- names (so a repo subdir like @hackage.haskell.org@ is discoverable). runFileSystemFake :: (State (Map FilePath LByteString) :> es)@@ -249,11 +253,15 @@ runFileSystemFake = interpret_ \case DoesFileExist p -> gets (Map.member p) DoesPathExist p -> gets (any (isUnder p) . Map.keys)+ DoesDirectoryExist p -> gets (any (isStrictlyUnder p) . Map.keys) ListDirectory p -> gets (ordNub . mapMaybe (childName p) . Map.keys) ReadFileLbsFrom p _ -> gets (fromMaybe "" . Map.lookup p)+ CreateDirectoryIfMissing _ _ -> pure ()+ WriteFileBS p bytes -> modify (Map.insert p (BSL.fromStrict bytes)) _ -> error "runFileSystemFake: unexpected operation" where- isUnder p k = p == k || (p <> "/") `List.isPrefixOf` k+ isUnder p k = p == k || isStrictlyUnder p k+ isStrictlyUnder p k = (p <> "/") `List.isPrefixOf` k childName p k = case List.stripPrefix (p <> "/") k of Just rest | not (null rest) -> Just (takeWhile (/= '/') rest) _ -> Nothing
tricorder.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder-version: 0.2.0.0+version: 0.2.0.1 synopsis: Continuous Haskell build status, diagnostics, and tests via a shared daemon description: tricorder rebuilds your Haskell project continuously and surfaces build status, diagnostics, test results, and documentation - for developers and LLM coding agents. Like ghcid and ghciwatch it reloads on every change, but builds run in a background daemon so multiple clients (an interactive TUI, a status CLI, an agent skill) share a single build state without triggering redundant rebuilds. It discovers components across multi-package cabal.project workspaces automatically and ships context-friendly output for agentic use via the CLI. category: Development@@ -75,8 +75,9 @@ Tricorder.Socket.Server Tricorder.Socket.UnixSocket Tricorder.SourceLookup- Tricorder.SourceLookup.Cabal Tricorder.SourceLookup.GhcPkg+ Tricorder.SourceLookup.Hackage+ Tricorder.SourceLookup.PackageStore Tricorder.SourceLookup.Slice Tricorder.SourceLookup.Tarball Tricorder.TestOutput@@ -112,7 +113,7 @@ , aeson ==2.2.* , ansi-terminal ==1.1.* , atelier-core ==0.3.*- , atelier-prelude ==0.1.*+ , atelier-prelude >=0.1 && <0.3 , base >=4.18 && <4.23 , brick ==2.10.* , bytestring >=0.11 && <0.13@@ -133,6 +134,7 @@ , process ==1.6.* , regex-tdfa >=1.3.2.5 && <1.4 , relude ==1.2.*+ , req >=3.13.4 && <3.14 , stm ==2.5.* , tar >=0.6 && <0.8 , template-haskell >=2.20 && <2.25@@ -176,7 +178,7 @@ TypeFamilies ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T" build-depends:- atelier-prelude ==0.1.*+ atelier-prelude >=0.1 && <0.3 , base >=4.18 && <4.23 , effectful-core ==2.6.* , effectful-plugin >=2.0 && <2.2@@ -214,7 +216,7 @@ TypeFamilies ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T" build-depends:- atelier-prelude ==0.1.*+ atelier-prelude >=0.1 && <0.3 , base >=4.18 && <4.23 , effectful-core ==2.6.* , effectful-plugin >=2.0 && <2.2@@ -282,7 +284,7 @@ Cabal-syntax >=3.12 && <3.17 , aeson ==2.2.* , atelier-core ==0.3.*- , atelier-prelude ==0.1.*+ , atelier-prelude >=0.1 && <0.3 , base >=4.18 && <4.23 , bytestring >=0.11 && <0.13 , containers >=0.6 && <0.9