diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2026, Nadeem Bitar + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/seihou-core.cabal b/seihou-core.cabal new file mode 100644 --- /dev/null +++ b/seihou-core.cabal @@ -0,0 +1,205 @@ +cabal-version: 3.0 +name: seihou-core +version: 0.4.0.0 +synopsis: Core library for Seihou project scaffolding +description: + Core library for Seihou, a composable project scaffolding system. + It provides the types, Dhall loading, template rendering, execution + engine, manifest handling, and validation logic used by the Seihou CLI. + +homepage: https://github.com/shinzui/seihou +bug-reports: https://github.com/shinzui/seihou/issues +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: (c) 2026 Nadeem Bitar +category: Development +build-type: Simple + +source-repository head + type: git + location: https://github.com/shinzui/seihou.git + +library + default-language: GHC2024 + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + TypeFamilies + + hs-source-dirs: src + exposed-modules: + Seihou.Composition.Graph + Seihou.Composition.Instance + Seihou.Composition.Plan + Seihou.Composition.Recipe + Seihou.Composition.Resolve + Seihou.Core.AgentPrompt + Seihou.Core.Blueprint + Seihou.Core.CommandVar + Seihou.Core.Context + Seihou.Core.Expr + Seihou.Core.Install + Seihou.Core.Migration + Seihou.Core.Module + Seihou.Core.Path + Seihou.Core.Recipe + Seihou.Core.Registry + Seihou.Core.Scaffold + Seihou.Core.SchemaUpgrade + Seihou.Core.Status + Seihou.Core.Types + Seihou.Core.Variable + Seihou.Core.Version + Seihou.Dhall.Config + Seihou.Dhall.Eval + Seihou.Effect.ConfigReader + Seihou.Effect.ConfigReaderInterp + Seihou.Effect.ConfigReaderPure + Seihou.Effect.ConfigWriter + Seihou.Effect.ConfigWriterInterp + Seihou.Effect.ConfigWriterPure + Seihou.Effect.Console + Seihou.Effect.ConsoleInterp + Seihou.Effect.ConsolePure + Seihou.Effect.DhallEval + Seihou.Effect.DhallEvalInterp + Seihou.Effect.Filesystem + Seihou.Effect.FilesystemInterp + Seihou.Effect.FilesystemPure + Seihou.Effect.Logger + Seihou.Effect.LoggerInterp + Seihou.Effect.LoggerPure + Seihou.Effect.ManifestStore + Seihou.Effect.ManifestStoreInterp + Seihou.Effect.ManifestStorePure + Seihou.Effect.Process + Seihou.Effect.ProcessInterp + Seihou.Effect.ProcessPure + Seihou.Engine.Conflict + Seihou.Engine.DhallJSON + Seihou.Engine.Diff + Seihou.Engine.Execute + Seihou.Engine.Migrate + Seihou.Engine.Plan + Seihou.Engine.Preview + Seihou.Engine.Remove + Seihou.Engine.Section + Seihou.Engine.Template + Seihou.Engine.TypedDhallText + Seihou.Engine.Validate + Seihou.Interaction.Confirm + Seihou.Interaction.Prompt + Seihou.Manifest.Hash + Seihou.Manifest.Types + Seihou.Prelude + + build-depends: + aeson >=2.1 && <3, + aeson-pretty >=0.8 && <1, + base >=4.18 && <5, + base16-bytestring >=1.0 && <2, + bytestring >=0.11 && <1, + containers >=0.6 && <1, + cryptohash-sha256 >=0.11 && <1, + dhall >=1.42 && <2, + directory >=1.3 && <2, + effectful-core >=2.4 && <3, + either >=5 && <6, + filepath >=1.4 && <2, + generic-lens >=2.2 && <3, + lens >=5.2 && <6, + process >=1.6 && <2, + text >=2.0 && <3, + time >=1.12 && <2, + transformers >=0.6 && <1, + yaml >=0.11 && <1, + +test-suite seihou-core-test + type: exitcode-stdio-1.0 + default-language: GHC2024 + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + + hs-source-dirs: test + main-is: Main.hs + other-modules: + Seihou.Composition.GraphSpec + Seihou.Composition.InstanceSpec + Seihou.Composition.PlanSpec + Seihou.Composition.RecipeSpec + Seihou.Composition.ResolveSpec + Seihou.Core.AgentPromptSpec + Seihou.Core.BlueprintSpec + Seihou.Core.CommandVarSpec + Seihou.Core.ContextSpec + Seihou.Core.ExprSpec + Seihou.Core.InstallSpec + Seihou.Core.ListSpec + Seihou.Core.MigrationSpec + Seihou.Core.ModuleSpec + Seihou.Core.RecipeSpec + Seihou.Core.RegistryEmitSpec + Seihou.Core.RegistrySpec + Seihou.Core.RegistrySyncSpec + Seihou.Core.ScaffoldSpec + Seihou.Core.SchemaUpgradeSpec + Seihou.Core.StatusSpec + Seihou.Core.TypesSpec + Seihou.Core.VariableSpec + Seihou.Core.VersionSpec + Seihou.Dhall.ConfigSpec + Seihou.Dhall.EvalSpec + Seihou.Dhall.MigrationDecoderSpec + Seihou.Effect.ConfigReaderSpec + Seihou.Effect.ConfigWriterSpec + Seihou.Effect.FilesystemSpec + Seihou.Effect.LoggerSpec + Seihou.Effect.ManifestStoreSpec + Seihou.Engine.ConflictSpec + Seihou.Engine.DiffSpec + Seihou.Engine.ExecuteSpec + Seihou.Engine.MigrateSpec + Seihou.Engine.PlanSpec + Seihou.Engine.PreviewSpec + Seihou.Engine.RemoveSpec + Seihou.Engine.SectionSpec + Seihou.Engine.TemplateSpec + Seihou.Engine.ValidateSpec + Seihou.Evaluation.ConditionalTemplateSpec + Seihou.Evaluation.DhallTextFlakeSpec + Seihou.Evaluation.SplitFlakeSpec + Seihou.Evaluation.TypedDhallTextSpec + Seihou.Integration.CompositionSpec + Seihou.Integration.ExecutionSpec + Seihou.Integration.GenerationSpec + Seihou.Integration.ModuleLoadSpec + Seihou.Interaction.ConfirmSpec + Seihou.Interaction.PromptSpec + Seihou.Manifest.TypesSpec + + build-depends: + aeson >=2.1 && <3, + base >=4.18 && <5, + bytestring >=0.11 && <1, + containers >=0.6 && <1, + dhall >=1.42 && <2, + directory >=1.3 && <2, + effectful-core >=2.4 && <3, + filepath >=1.4 && <2, + hspec >=2.11 && <3, + seihou-core, + tasty >=1.4 && <2, + tasty-hspec >=1.2 && <2, + temporary >=1.3 && <2, + text >=2.0 && <3, + time >=1.12 && <2, + yaml >=0.11 && <1, diff --git a/src/Seihou/Composition/Graph.hs b/src/Seihou/Composition/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Composition/Graph.hs @@ -0,0 +1,101 @@ +module Seihou.Composition.Graph + ( CompositionGraph (..), + buildGraph, + topoSort, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Seihou.Composition.Instance (ModuleInstance (..), mkInstance) +import Seihou.Core.Types +import Seihou.Prelude + +-- | A directed acyclic graph of module instances. +-- +-- Edges point from a 'ModuleInstance' to the instances of its direct +-- dependencies: two invocations of the same module with different +-- 'ParentVars' have independent edges, so the topological sort +-- produces one node per distinct invocation. +data CompositionGraph = CompositionGraph + { cgModules :: Map ModuleInstance Module, + cgEdges :: Map ModuleInstance [ModuleInstance] + } + deriving stock (Eq, Show) + +-- | Build a composition graph from a list of module instances. +-- +-- Each module's dependencies are resolved to the corresponding +-- 'ModuleInstance' present in the input. A dependency edge with +-- @depVars@ selects the instance created with those exact bindings; +-- a bare dependency (no @depVars@) selects the 'emptyParentVars' +-- instance. If the instance set does not contain the child the edge +-- points to, the edge is silently dropped — the loader is +-- responsible for ensuring every referenced child is loaded first. +buildGraph :: [(ModuleInstance, Module)] -> CompositionGraph +buildGraph entries = + let present = Set.fromList (map fst entries) + edgesFor m = + -- Dedupe edges: if a parent lists the same @(depModule, depVars)@ + -- twice, the two edges resolve to the same child instance and + -- must count as one for the topological sort's in-degree. + Set.toAscList . Set.fromList $ + [ child + | dep <- m.dependencies, + let child = mkInstance dep.depModule (parentVarsFromDep dep), + Set.member child present + ] + in CompositionGraph + { cgModules = Map.fromList entries, + cgEdges = Map.fromList [(inst, edgesFor m) | (inst, m) <- entries] + } + +-- | Topological sort using Kahn's algorithm, operating on +-- 'ModuleInstance' nodes. +-- +-- Returns instances in execution order (dependencies first) or a +-- 'CircularDependency' error if a cycle exists. The error payload +-- lists bare module names because that is what callers expect +-- today; the set can include duplicates when two instances of the +-- same module both sit in a cycle. +topoSort :: CompositionGraph -> Either ModuleLoadError [ModuleInstance] +topoSort graph = kahn initialReady initialInDegree [] allNodes + where + allNodes :: Set ModuleInstance + allNodes = Map.keysSet graph.cgEdges + + initialInDegree :: Map ModuleInstance Int + initialInDegree = + Map.fromList + [ (n, length [d | d <- Map.findWithDefault [] n graph.cgEdges, Set.member d allNodes]) + | n <- Set.toList allNodes + ] + + initialReady :: [ModuleInstance] + initialReady = + [ n + | (n, deg) <- Map.toList initialInDegree, + deg == 0 + ] + + kahn :: [ModuleInstance] -> Map ModuleInstance Int -> [ModuleInstance] -> Set ModuleInstance -> Either ModuleLoadError [ModuleInstance] + kahn [] _ result remaining + | Set.null remaining = Right (reverse result) + | otherwise = + Left (CircularDependency (map (.instanceModule) (Set.toList remaining))) + kahn (node : rest) inDeg result remaining = + let remaining' = Set.delete node remaining + (newReady, inDeg') = foldl (decrementDep node) ([], inDeg) (Set.toList remaining') + in kahn (rest ++ newReady) inDeg' (node : result) remaining' + + decrementDep :: ModuleInstance -> ([ModuleInstance], Map ModuleInstance Int) -> ModuleInstance -> ([ModuleInstance], Map ModuleInstance Int) + decrementDep processed (ready, inDeg) candidate = + let deps = Map.findWithDefault [] candidate graph.cgEdges + in if processed `elem` deps + then + let newDeg = Map.findWithDefault 0 candidate inDeg - 1 + inDeg' = Map.insert candidate newDeg inDeg + in if newDeg == 0 + then (candidate : ready, inDeg') + else (ready, inDeg') + else (ready, inDeg) diff --git a/src/Seihou/Composition/Instance.hs b/src/Seihou/Composition/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Composition/Instance.hs @@ -0,0 +1,86 @@ +module Seihou.Composition.Instance + ( ModuleInstance (..), + mkInstance, + primaryInstance, + qualifiedName, + stableHash, + ) +where + +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.ByteString.Base16 qualified as Base16 +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Seihou.Core.Types + ( ModuleName (..), + ParentVars (..), + VarName (..), + emptyParentVars, + ) +import Seihou.Prelude + +-- | Identity of a module invocation within a composition. +-- +-- Two invocations of the same module with different parent-supplied +-- bindings are distinct instances; two with identical bindings share +-- one instance. See @docs/plans/10-parameterized-dep-multi-instantiation.md@ +-- for the full rationale. +data ModuleInstance = ModuleInstance + { instanceModule :: ModuleName, + instanceParentVars :: ParentVars + } + deriving stock (Eq, Ord, Show) + +-- | Build a 'ModuleInstance' from a module name and the parent-supplied +-- bindings along the edge that reached it. +mkInstance :: ModuleName -> ParentVars -> ModuleInstance +mkInstance n pv = ModuleInstance {instanceModule = n, instanceParentVars = pv} + +-- | The 'ModuleInstance' for a top-level (primary / CLI-additional / +-- recipe-expanded) module, which receives no parent-supplied bindings. +primaryInstance :: ModuleName -> ModuleInstance +primaryInstance n = mkInstance n emptyParentVars + +-- | Collapse a 'ModuleInstance' to a 'ModuleName' that is unique within +-- a single composition. +-- +-- When the instance has no parent-supplied bindings, the bare module +-- name is returned unchanged — single-instance compositions continue +-- to use plain names in file records, patch operations, and manifest +-- keys. When bindings are present, an @\#@-suffixed 'stableHash' of +-- those bindings is appended so two instances of the same module do +-- not collide. +-- +-- This function is only used where a 'ModuleName' must be unique +-- within a composition (e.g. 'FileRecord.moduleName', +-- 'PatchFileOp.moduleName', internal manifest grouping keys). User- +-- facing provenance such as 'VarSource.FromParent' keeps the bare +-- 'ModuleName' alongside the bindings so output stays readable. +qualifiedName :: ModuleInstance -> ModuleName +qualifiedName inst = + case Map.null inst.instanceParentVars.unParentVars of + True -> inst.instanceModule + False -> + ModuleName $ + inst.instanceModule.unModuleName + <> "#" + <> stableHash inst.instanceParentVars + +-- | Compute the disambiguating hash for a 'ParentVars' set. +-- +-- Canonicalisation: the bindings are sorted ascending by 'VarName', +-- each rendered as @name=value@, and the lines joined with @\\n@. +-- The UTF-8 bytes of that canonical string are hashed with SHA-256 +-- and the first eight hex characters of the digest are returned. +-- +-- The hash is only a within-composition disambiguator; collision +-- probability at 2^32 is acceptable for compositions of realistic +-- size. +stableHash :: ParentVars -> Text +stableHash (ParentVars m) = + let sorted = Map.toAscList m + canonical = T.intercalate "\n" [n <> "=" <> v | (VarName n, v) <- sorted] + digest = SHA256.hash (TE.encodeUtf8 canonical) + hex = TE.decodeUtf8 (Base16.encode digest) + in T.take 8 hex diff --git a/src/Seihou/Composition/Plan.hs b/src/Seihou/Composition/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Composition/Plan.hs @@ -0,0 +1,239 @@ +module Seihou.Composition.Plan + ( compileComposedPlan, + mergeOperations, + mergeStructuredContent, + deepMergeJSON, + ) +where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Encode.Pretty qualified as AesonPretty +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Yaml qualified as Yaml +import Seihou.Composition.Instance (ModuleInstance, qualifiedName) +import Seihou.Core.Types +import Seihou.Engine.Plan (compilePlan) +import Seihou.Engine.Section (applyTextPatch) +import Seihou.Prelude +import System.FilePath (takeExtension) + +-- | Compile plans for all modules in execution order and merge into a +-- single operation list. File conflicts are resolved by last-writer-wins +-- with 'CompositionWarning' entries for overwritten files. +-- +-- Each triple is a distinct 'ModuleInstance' invocation. The instance's +-- 'qualifiedName' is passed to 'compilePlan' for any field that must be +-- unique within the composition ('FileRecord.moduleName', +-- 'PatchFileOp.moduleName'), so two instances of the same module do not +-- collide on file ownership. +compileComposedPlan :: + [(ModuleInstance, Module, FilePath, Map VarName VarValue)] -> + IO (Either [Text] ([Operation], [CompositionWarning], Map FilePath ModuleName)) +compileComposedPlan modules = do + results <- mapM compileOne modules + let (errs, opsPerModule) = partitionResults results + if null errs + then pure (Right (mergeOperations opsPerModule)) + else pure (Left (concat errs)) + where + compileOne (inst, m, dir, vars) = do + let qn = qualifiedName inst + instancedModule = + Module + { name = qn, + version = m.version, + description = m.description, + vars = m.vars, + exports = m.exports, + prompts = m.prompts, + steps = m.steps, + commands = m.commands, + dependencies = m.dependencies, + removal = m.removal, + migrations = m.migrations + } + result <- compilePlan dir instancedModule vars + case result of + Left errs -> pure (Left errs) + Right ops -> pure (Right (qn, ops)) + +-- | Merge operation lists from multiple modules, handling file conflicts. +-- +-- When two modules produce a 'WriteFileOp' or 'CopyFileOp' targeting the +-- same destination path, the later module (later in execution order) wins +-- and a 'FileOverwritten' warning is recorded. +-- +-- 'CreateDirOp' operations are silently deduplicated. +-- 'RunCommandOp' operations are always included. +mergeOperations :: + [(ModuleName, [Operation])] -> + ([Operation], [CompositionWarning], Map FilePath ModuleName) +mergeOperations moduleOps = + let tagged = [(name, op) | (name, ops) <- moduleOps, op <- ops] + (result, warnings, owners) = go tagged Map.empty Set.empty [] [] + in (reverse result, warnings, owners) + where + go [] fileOwner _ opsAcc warningsAcc = (opsAcc, warningsAcc, fileOwner) + go ((name, op) : rest) fileOwner seenDirs opsAcc warningsAcc = + case op of + CreateDirOp p + | Set.member p seenDirs -> go rest fileOwner seenDirs opsAcc warningsAcc + | otherwise -> go rest fileOwner (Set.insert p seenDirs) (op : opsAcc) warningsAcc + WriteFileOp dest _ _ -> + handleFileOp name op dest rest fileOwner seenDirs opsAcc warningsAcc + CopyFileOp _ dest -> + handleFileOp name op dest rest fileOwner seenDirs opsAcc warningsAcc + RunCommandOp {} -> + go rest fileOwner seenDirs (op : opsAcc) warningsAcc + PatchFileOp dest newContent patchOp' _ patchModName -> + handlePatchOp name dest newContent patchOp' patchModName rest fileOwner seenDirs opsAcc warningsAcc + + -- \| Handle a PatchFileOp: if the target file exists in the accumulator, + -- apply the patch to the existing content. Otherwise, treat it like a + -- new file operation (the patch creates the file from empty). + handlePatchOp name dest newContent patchOp' patchModName rest fileOwner seenDirs opsAcc warningsAcc = + case findWriteOp dest opsAcc of + Just (WriteFileOp _ existingContent strat, otherOps) -> + -- Apply patch to the existing WriteFileOp's content + case applyTextPatch patchOp' patchModName "#" existingContent newContent of + Left _err -> + -- On patch failure, fall back to last-writer-wins + handleFileOp name (WriteFileOp dest newContent Template) dest rest fileOwner seenDirs opsAcc warningsAcc + Right merged -> + let baseName = case Map.lookup dest fileOwner of + Just n -> n + Nothing -> name + updatedOp = WriteFileOp dest merged strat + in go + rest + (Map.insert dest name fileOwner) + seenDirs + (updatedOp : otherOps) + (ContentMerged dest baseName name : warningsAcc) + _ -> + -- No existing file op for this dest; preserve as PatchFileOp so the + -- execution engine can merge with the on-disk file and the diff engine + -- can avoid false conflict classification. + let patchOp = PatchFileOp dest newContent patchOp' Template patchModName + in go + rest + (Map.insert dest name fileOwner) + seenDirs + (patchOp : opsAcc) + warningsAcc + + handleFileOp name op dest rest fileOwner seenDirs opsAcc warningsAcc = + case Map.lookup dest fileOwner of + Just prevName -> + -- Check for structured merge: both ops are WriteFileOp with Structured strategy + case (findWriteOp dest opsAcc, op) of + (Just (WriteFileOp _ existingContent Structured, otherOps), WriteFileOp _ newContent Structured) -> + case mergeStructuredContent dest existingContent newContent of + Right merged -> + let updatedOp = WriteFileOp dest merged Structured + in go + rest + (Map.insert dest name fileOwner) + seenDirs + (updatedOp : otherOps) + (ContentMerged dest prevName name : warningsAcc) + Left _ -> + -- On merge failure, fall back to last-writer-wins + let opsAcc' = op : filter (\old -> destOfOp old /= Just dest) opsAcc + in go + rest + (Map.insert dest name fileOwner) + seenDirs + opsAcc' + (FileOverwritten dest prevName name : warningsAcc) + _ -> + -- Default: last-writer-wins + let opsAcc' = op : filter (\old -> destOfOp old /= Just dest) opsAcc + in go + rest + (Map.insert dest name fileOwner) + seenDirs + opsAcc' + (FileOverwritten dest prevName name : warningsAcc) + Nothing -> + go + rest + (Map.insert dest name fileOwner) + seenDirs + (op : opsAcc) + warningsAcc + +-- | Find and extract a WriteFileOp targeting a given destination from the ops accumulator. +-- Returns the matching op and the remaining ops (with it removed). +findWriteOp :: FilePath -> [Operation] -> Maybe (Operation, [Operation]) +findWriteOp _ [] = Nothing +findWriteOp dest (op@(WriteFileOp d _ _) : rest) + | d == dest = Just (op, rest) +findWriteOp dest (op : rest) = + case findWriteOp dest rest of + Just (found, remaining) -> Just (found, op : remaining) + Nothing -> Nothing + +-- | Extract the destination path from a file-producing operation. +destOfOp :: Operation -> Maybe FilePath +destOfOp (WriteFileOp d _ _) = Just d +destOfOp (CopyFileOp _ d) = Just d +destOfOp (PatchFileOp d _ _ _ _) = Just d +destOfOp _ = Nothing + +-- | Merge two serialized structured files (JSON or YAML) by deep-merging +-- their contents. The file extension determines the parse/serialize format. +-- Right-biased: overlapping scalar keys take the overlay's value; nested +-- objects are merged recursively. +mergeStructuredContent :: FilePath -> Text -> Text -> Either Text Text +mergeStructuredContent dest base overlay = do + baseVal <- parseStructured dest base + overlayVal <- parseStructured dest overlay + let merged = deepMergeJSON baseVal overlayVal + serializeStructured dest merged + +-- | Parse serialized content based on file extension. +parseStructured :: FilePath -> Text -> Either Text Aeson.Value +parseStructured dest content = + case takeExtension dest of + ".json" -> + case Aeson.eitherDecodeStrict' (TE.encodeUtf8 content) of + Left err -> Left ("Failed to parse JSON in " <> T.pack dest <> ": " <> T.pack err) + Right val -> Right val + ".yaml" -> parseYaml dest content + ".yml" -> parseYaml dest content + ext -> Left ("Structured merge: unsupported format '" <> T.pack ext <> "'") + where + parseYaml d c = + case Yaml.decodeEither' (TE.encodeUtf8 c) of + Left err -> Left ("Failed to parse YAML in " <> T.pack d <> ": " <> T.pack (show err)) + Right val -> Right val + +-- | Serialize a JSON value based on file extension. +serializeStructured :: FilePath -> Aeson.Value -> Either Text Text +serializeStructured dest value = + case takeExtension dest of + ".json" -> Right (TL.toStrict (TLE.decodeUtf8 (AesonPretty.encodePretty value)) <> "\n") + ".yaml" -> Right (TE.decodeUtf8 (Yaml.encode value)) + ".yml" -> Right (TE.decodeUtf8 (Yaml.encode value)) + ext -> Left ("Structured merge: unsupported format '" <> T.pack ext <> "'") + +-- | Deep-merge two JSON values. For objects, keys are merged recursively. +-- For all other types, the right (overlay) value wins. +deepMergeJSON :: Aeson.Value -> Aeson.Value -> Aeson.Value +deepMergeJSON (Aeson.Object base) (Aeson.Object overlay) = + Aeson.Object (KM.unionWith deepMergeJSON base overlay) +deepMergeJSON _ overlay = overlay + +-- | Partition a list of Either into errors and successes. +partitionResults :: [Either e a] -> ([e], [a]) +partitionResults = foldr step ([], []) + where + step (Left e) (errs, oks) = (e : errs, oks) + step (Right a) (errs, oks) = (errs, a : oks) diff --git a/src/Seihou/Composition/Recipe.hs b/src/Seihou/Composition/Recipe.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Composition/Recipe.hs @@ -0,0 +1,30 @@ +module Seihou.Composition.Recipe + ( expandRecipe, + ) +where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Seihou.Core.Recipe (validateRecipe) +import Seihou.Core.Types + +type ExpandedRecipe = (ModuleName, [ModuleName], Map VarName Text, [VarDecl], [Prompt]) + +-- | Expand a 'Recipe' into the inputs that the existing composition pipeline +-- expects: a primary module name, additional module names, variable overrides, +-- recipe-level variable declarations, and recipe-level prompts. +-- +-- The first module in the recipe's list becomes the primary module (used for +-- config namespace derivation). All remaining modules become additional modules. +-- Variable overrides are collected from each module entry's @depVars@ bindings. +expandRecipe :: Recipe -> Either [Text] ExpandedRecipe +expandRecipe recipe = do + validated <- validateRecipe recipe + case validated.modules of + [] -> Left ["recipe must list at least one module"] + primary : additional -> + let primaryName = primary.depModule + additionalNames = map (.depModule) additional + overrides = Map.unions (map (.depVars) validated.modules) + in Right (primaryName, additionalNames, overrides, validated.vars, validated.prompts) diff --git a/src/Seihou/Composition/Resolve.hs b/src/Seihou/Composition/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Composition/Resolve.hs @@ -0,0 +1,387 @@ +module Seihou.Composition.Resolve + ( loadComposition, + resolveComposedVariables, + resolveWithPrompts, + exportedVars, + collectParentVars, + ) +where + +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Composition.Graph (buildGraph, topoSort) +import Seihou.Composition.Instance (ModuleInstance (..), mkInstance, primaryInstance) +import Seihou.Core.Module (discoverModule, validateModule) +import Seihou.Core.Types +import Seihou.Core.Variable (resolveVariables) +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Effect.Console (Console, isInteractive, putText) +import Seihou.Interaction.Prompt (runPrompts) +import Seihou.Prelude + +-- | Load all modules in a composition: primary + additional + transitive deps. +-- Additional modules are treated as implicit dependencies of the primary module. +-- Returns modules with their directories in execution order (dependencies first). +-- +-- Each entry carries a 'ModuleInstance' identifying the exact invocation. +-- Two dependency edges to the same module with different @depVars@ produce +-- two distinct entries; identical edges dedupe. +loadComposition :: + [FilePath] -> + ModuleName -> + [ModuleName] -> + IO (Either ModuleLoadError [(ModuleInstance, Module, FilePath)]) +loadComposition searchPaths primary additional = runExceptT $ do + (primaryMod, primaryDir) <- ExceptT $ loadModuleWithDir searchPaths primary + let effectiveDeps = primaryMod.dependencies ++ map simpleDep additional + effectivePrimary = primaryMod {dependencies = nubOrdBy (.depModule) effectiveDeps} + primaryInst = primaryInstance primary + loaded = Map.singleton primaryInst (effectivePrimary, primaryDir) + seeds = [(mkInstance dep.depModule (parentVarsFromDep dep)) | dep <- effectivePrimary.dependencies] + allInstances <- ExceptT $ loadTransitive searchPaths loaded seeds + let entries = [(inst, m) | (inst, (m, _)) <- Map.toList allInstances] + graph = buildGraph entries + order <- ExceptT . pure $ topoSort graph + pure [(inst, m, d) | inst <- order, Just (m, d) <- [Map.lookup inst allInstances]] + +-- | Resolve variables for all modules in a composition with export visibility. +-- +-- For each module-instance in execution order: +-- 1. Collect exported variables from its direct dependency edges (resolved +-- to the exact child instance along that edge, not just the module name). +-- 2. Inject those exports as defaults for any matching declared variables. +-- 3. Call 'resolveVariables' with the adjusted declarations. +-- 4. Record the instance's exports for downstream modules. +-- +-- Exported values override the module's own defaults but are still lower +-- priority than CLI overrides and environment variables. +resolveComposedVariables :: + [(ModuleInstance, Module, FilePath)] -> + Map VarName Text -> + Map Text Text -> + Text -> + Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Either [VarError] (Map ModuleInstance (Map VarName ResolvedVar)) +resolveComposedVariables modulesInOrder cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig = + let allParentVars = collectParentVars modulesInOrder + in go allParentVars modulesInOrder Map.empty Map.empty + where + go :: + Map ModuleInstance (Map VarName (Text, ModuleName)) -> + [(ModuleInstance, Module, FilePath)] -> + Map ModuleInstance (Map VarName ResolvedVar) -> + Map ModuleInstance (Map VarName VarValue) -> + Either [VarError] (Map ModuleInstance (Map VarName ResolvedVar)) + go _ [] perModule _ = Right perModule + go parentVarsMap ((inst, m, _dir) : rest) perModule allExports = do + let visibleExports = gatherEdgeExports m allExports + adjustedDecls = map (injectExportDefault visibleExports) m.vars + myParentVars = Map.findWithDefault Map.empty inst parentVarsMap + resolved <- resolveVariables adjustedDecls cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars + let declaredNames = Set.fromList (map (.name) m.vars) + inherited = + Map.mapWithKey + makeInheritedResolved + (Map.filterWithKey (\k _ -> not (Set.member k declaredNames)) visibleExports) + fullResolved = resolved `Map.union` inherited + let myExports = exportedVars m fullResolved + go + parentVarsMap + rest + (Map.insert inst fullResolved perModule) + (Map.insert inst myExports allExports) + +-- | Resolve variables for all modules with interactive prompt support. +-- +-- Same as 'resolveComposedVariables' but when a module has unresolved required +-- variables, prompts the user via the Console effect (if interactive). +-- In non-interactive mode, missing required variables remain as errors. +resolveWithPrompts :: + (Console :> es) => + [(ModuleInstance, Module, FilePath)] -> + Map VarName Text -> + Map Text Text -> + Text -> + Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Eff es (Either [VarError] (Map ModuleInstance (Map VarName ResolvedVar))) +resolveWithPrompts modulesInOrder cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig = do + interactive <- isInteractive + let allParentVars = collectParentVars modulesInOrder + goPrompt interactive allParentVars modulesInOrder Map.empty Map.empty + where + goPrompt :: + (Console :> es) => + Bool -> + Map ModuleInstance (Map VarName (Text, ModuleName)) -> + [(ModuleInstance, Module, FilePath)] -> + Map ModuleInstance (Map VarName ResolvedVar) -> + Map ModuleInstance (Map VarName VarValue) -> + Eff es (Either [VarError] (Map ModuleInstance (Map VarName ResolvedVar))) + goPrompt _ _ [] perModule _ = pure (Right perModule) + goPrompt interactive parentVarsMap ((inst, m, _dir) : rest) perModule allExports = do + let visibleExports = gatherEdgeExports m allExports + adjustedDecls = map (injectExportDefault visibleExports) m.vars + myParentVars = Map.findWithDefault Map.empty inst parentVarsMap + case resolveVariables adjustedDecls cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars of + Right resolved -> do + let declaredNames = Set.fromList (map (.name) m.vars) + inherited = + Map.mapWithKey + makeInheritedResolved + (Map.filterWithKey (\k _ -> not (Set.member k declaredNames)) visibleExports) + resolvedWithInherited = resolved `Map.union` inherited + let optionalDecls = + [ d + | d <- adjustedDecls, + not d.required, + not (Map.member d.name resolvedWithInherited), + any (\p -> p.var == d.name) m.prompts + ] + optionalPrompted <- + if interactive && not (null optionalDecls) + then do + let currentBindings = Map.map (.value) (Map.unions (Map.elems perModule)) + allBindings = Map.union (Map.map (.value) resolvedWithInherited) currentBindings + putText "" + putText "Optional configuration:" + runPrompts m.prompts optionalDecls allBindings + else pure Map.empty + let fullResolved = resolvedWithInherited `Map.union` optionalPrompted + myExports = exportedVars m fullResolved + goPrompt + interactive + parentVarsMap + rest + (Map.insert inst fullResolved perModule) + (Map.insert inst myExports allExports) + Left errs -> do + let (missing, fatal) = partitionErrors errs + if not (null fatal) + then pure (Left (fatal ++ missing)) + else + if not interactive || null missing + then pure (Left errs) + else do + let currentBindings = Map.map (.value) (Map.unions (Map.elems perModule)) + missingDecls = [d | d <- adjustedDecls, d.name `elem` map getMissingName missing] + prompted <- runPrompts m.prompts missingDecls currentBindings + let stillMissing = [e | e <- missing, not (Map.member (getMissingName e) prompted)] + if not (null stillMissing) + then pure (Left stillMissing) + else do + let promptedOverrides = + Map.union cliOverrides $ + Map.map (varValueToText . (.value)) prompted + case resolveVariables adjustedDecls promptedOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars of + Left errs' -> pure (Left errs') + Right resolved -> do + let resolvedWithPromptSource = + Map.mapWithKey + ( \vn rv -> + case Map.lookup vn prompted of + Just pv -> pv + Nothing -> rv + ) + resolved + declaredNames = Set.fromList (map (.name) m.vars) + inherited = + Map.mapWithKey + makeInheritedResolved + (Map.filterWithKey (\k _ -> not (Set.member k declaredNames)) visibleExports) + resolvedWithInherited' = resolvedWithPromptSource `Map.union` inherited + let optionalDecls' = + [ d + | d <- adjustedDecls, + not d.required, + not (Map.member d.name resolvedWithInherited'), + any (\p -> p.var == d.name) m.prompts + ] + optionalPrompted' <- + if not (null optionalDecls') + then do + let cb = Map.map (.value) (Map.unions (Map.elems perModule)) + ab = Map.union (Map.map (.value) resolvedWithInherited') cb + putText "" + putText "Optional configuration:" + runPrompts m.prompts optionalDecls' ab + else pure Map.empty + let fullResolved = resolvedWithInherited' `Map.union` optionalPrompted' + myExports = exportedVars m fullResolved + goPrompt + interactive + parentVarsMap + rest + (Map.insert inst fullResolved perModule) + (Map.insert inst myExports allExports) + +-- | Collect the exports visible along a module's dependency edges. +-- +-- Each dependency edge is resolved to the exact child instance +-- @(depModule, depVars)@, not just the module name, so that two +-- sibling instances of the same module contribute their own +-- per-instance exports without interference. +gatherEdgeExports :: + Module -> + Map ModuleInstance (Map VarName VarValue) -> + Map VarName VarValue +gatherEdgeExports m allExports = + Map.unions + [ Map.findWithDefault Map.empty childInst allExports + | dep <- m.dependencies, + let childInst = mkInstance dep.depModule (parentVarsFromDep dep) + ] + +-- | Extract the variable name from a MissingRequiredVar error. +getMissingName :: VarError -> VarName +getMissingName (MissingRequiredVar n) = n +getMissingName _ = VarName "" + +-- | Partition errors into MissingRequiredVar and other (fatal) errors. +partitionErrors :: [VarError] -> ([VarError], [VarError]) +partitionErrors = foldr go ([], []) + where + go e@(MissingRequiredVar _) (missing, fatal) = (e : missing, fatal) + go e (missing, fatal) = (missing, e : fatal) + +-- | Convert a VarValue to its text representation for use as an override. +varValueToText :: VarValue -> Text +varValueToText (VText t) = t +varValueToText (VBool True) = "true" +varValueToText (VBool False) = "false" +varValueToText (VInt n) = T.pack (show n) +varValueToText (VList vs) = T.intercalate "," (map varValueToText vs) + +-- | Extract exported variables from a module's resolved values. +-- Uses the alias name if provided, otherwise the original variable name. +exportedVars :: Module -> Map VarName ResolvedVar -> Map VarName VarValue +exportedVars m resolved = + Map.fromList + [ (exportName e, rv.value) + | e <- m.exports, + Just rv <- [Map.lookup e.var resolved] + ] + where + exportName e = case e.alias of + Just a -> a + Nothing -> e.var + +-- Internal helpers + +-- | Load a module and return both the module and its directory path. +loadModuleWithDir :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError (Module, FilePath)) +loadModuleWithDir searchPaths name = do + discovered <- discoverModule searchPaths name + case discovered of + Left err -> pure (Left err) + Right moduleDir -> do + let dhallFile = moduleDir "module.dhall" + decoded <- evalModuleFromFile dhallFile + case decoded of + Left err -> pure (Left err) + Right m -> do + validated <- validateModule moduleDir m + case validated of + Left err -> pure (Left err) + Right m' -> pure (Right (m', moduleDir)) + +-- | Recursively load transitive dependencies. +-- +-- Work-list entries are 'ModuleInstance' values — the caller has already +-- baked the parent-supplied bindings into each entry. An instance whose +-- @(name, parentVars)@ pair is already loaded is skipped, so two +-- dependency edges with identical parent bindings dedupe. Distinct +-- bindings produce distinct loaded entries even when the bare module +-- name is the same. +loadTransitive :: + [FilePath] -> + Map ModuleInstance (Module, FilePath) -> + [ModuleInstance] -> + IO (Either ModuleLoadError (Map ModuleInstance (Module, FilePath))) +loadTransitive _ loaded [] = pure (Right loaded) +loadTransitive searchPaths loaded (inst : rest) + | Map.member inst loaded = loadTransitive searchPaths loaded rest + | otherwise = do + result <- loadModuleWithDir searchPaths inst.instanceModule + case result of + Left err -> pure (Left err) + Right (m, dir) -> do + let loaded' = Map.insert inst (m, dir) loaded + newInstances = + [ mkInstance dep.depModule (parentVarsFromDep dep) + | dep <- m.dependencies + ] + loadTransitive searchPaths loaded' (rest ++ newInstances) + +-- | Inject an exported value as the default for a variable declaration. +-- The export replaces any existing default, giving it precedence over +-- the module author's default while still being overridable by CLI/env. +injectExportDefault :: Map VarName VarValue -> VarDecl -> VarDecl +injectExportDefault exports decl = + case Map.lookup decl.name exports of + Just val -> decl {default_ = Just val} + Nothing -> decl + +-- | Create a ResolvedVar for an inherited (non-declared) export variable. +makeInheritedResolved :: VarName -> VarValue -> ResolvedVar +makeInheritedResolved n val = + ResolvedVar + { value = val, + source = FromDefault, + decl = + VarDecl + { name = n, + type_ = inferType val, + default_ = Just val, + description = Nothing, + required = False, + validation = Nothing + } + } + +-- | Infer the VarType from a VarValue. +inferType :: VarValue -> VarType +inferType (VText _) = VTText +inferType (VBool _) = VTBool +inferType (VInt _) = VTInt +inferType (VList []) = VTList VTText +inferType (VList (v : _)) = VTList (inferType v) + +-- | Collect all parent-supplied variable bindings across the composition. +-- +-- Returns a map keyed by 'ModuleInstance' — not by bare 'ModuleName' — +-- so two sibling invocations of the same child, each supplied with +-- different bindings by different parents, carry their own edge +-- decorations independently. A child edge's @depVars@ uniquely +-- identifies the target instance, so no merging of overlapping +-- bindings is required: each @(ModuleInstance, edgeVars)@ pair is +-- distinct by construction. +collectParentVars :: + [(ModuleInstance, Module, FilePath)] -> + Map ModuleInstance (Map VarName (Text, ModuleName)) +collectParentVars modules = + Map.fromList + [ (childInst, Map.map (,m.name) dep.depVars) + | (_, m, _) <- modules, + dep <- m.dependencies, + not (Map.null dep.depVars), + let childInst = mkInstance dep.depModule (parentVarsFromDep dep) + ] + +-- | Remove duplicates from a list while preserving order, using a key function. +nubOrdBy :: (Ord k) => (a -> k) -> [a] -> [a] +nubOrdBy f = go Set.empty + where + go _ [] = [] + go seen (x : xs) + | Set.member (f x) seen = go seen xs + | otherwise = x : go (Set.insert (f x) seen) xs diff --git a/src/Seihou/Core/AgentPrompt.hs b/src/Seihou/Core/AgentPrompt.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/AgentPrompt.hs @@ -0,0 +1,179 @@ +module Seihou.Core.AgentPrompt + ( validateAgentPrompt, + checkAgentPromptNameFormat, + checkAgentPromptVersionPresent, + checkAgentPromptBodyNonEmpty, + checkAgentPromptUniqueVars, + checkAgentPromptPromptRefs, + checkAgentPromptCommandVars, + checkAgentPromptGuidance, + checkAgentPromptFiles, + checkAgentPromptTags, + checkAgentPromptAllowedTools, + ) +where + +import Data.Set qualified as Set +import Data.Text qualified as T +import Numeric.Natural (Natural) +import Seihou.Core.Expr (exprRefs) +import Seihou.Core.Module (isValidModuleName) +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Validate a decoded 'AgentPrompt' against the prompt authoring rules. +-- The 'FilePath' is the prompt's base directory (containing @prompt.dhall@). +validateAgentPrompt :: FilePath -> AgentPrompt -> IO (Either ModuleLoadError AgentPrompt) +validateAgentPrompt baseDir p = do + fileErrs <- checkAgentPromptFiles baseDir p + let pureErrs = + checkAgentPromptNameFormat p + <> checkAgentPromptVersionPresent p + <> checkAgentPromptBodyNonEmpty p + <> checkAgentPromptUniqueVars p + <> checkAgentPromptPromptRefs p + <> checkAgentPromptCommandVars p + <> checkAgentPromptGuidance p + <> checkAgentPromptTags p + <> checkAgentPromptAllowedTools p + allErrs = pureErrs <> fileErrs + pure $ + if null allErrs + then Right p + else Left (ValidationError p.name allErrs) + +checkAgentPromptNameFormat :: AgentPrompt -> [Text] +checkAgentPromptNameFormat p = + let n = p.name.unModuleName + in if T.null n || not (isValidModuleName n) + then ["prompt name must match [a-z][a-z0-9-]*, got: " <> n] + else [] + +checkAgentPromptVersionPresent :: AgentPrompt -> [Text] +checkAgentPromptVersionPresent p = case p.version of + Nothing -> [] + Just v + | T.null (T.strip v) -> ["prompt version, if specified, must not be empty"] + | otherwise -> [] + +checkAgentPromptBodyNonEmpty :: AgentPrompt -> [Text] +checkAgentPromptBodyNonEmpty p + | T.null (T.strip p.prompt) = ["prompt body must not be empty"] + | otherwise = [] + +checkAgentPromptUniqueVars :: AgentPrompt -> [Text] +checkAgentPromptUniqueVars p = + let names = map (\d -> d.name.unVarName) p.vars + in map (\n -> "duplicate variable name: " <> n) (findDupes Set.empty Set.empty names) + +checkAgentPromptPromptRefs :: AgentPrompt -> [Text] +checkAgentPromptPromptRefs p = + let varNames = Set.fromList (map (.name) p.vars) + in concatMap + ( \prompt -> + if Set.member prompt.var varNames + then [] + else ["prompt references undeclared variable: " <> prompt.var.unVarName] + ) + p.prompts + +checkAgentPromptCommandVars :: AgentPrompt -> [Text] +checkAgentPromptCommandVars p = + duplicateCommandVars <> concatMap checkCommandVar p.commandVars + where + commandNames = map (\cv -> cv.name.unVarName) p.commandVars + + duplicateCommandVars = + map + (\n -> "duplicate command variable name: " <> n) + (findDupes Set.empty Set.empty commandNames) + + checkCommandVar cv = + checkName cv <> checkRun cv <> checkWorkDir cv.workDir <> checkMaxBytes cv.maxBytes + + checkName cv + | T.null (T.strip cv.name.unVarName) = ["command variable name must not be empty"] + | otherwise = [] + + checkRun cv + | T.null (T.strip cv.run) = ["command variable '" <> cv.name.unVarName <> "' run must not be empty"] + | otherwise = [] + + checkWorkDir Nothing = [] + checkWorkDir (Just wd) = + case validateProjectRelativePath wd of + Left err -> ["command variable workDir " <> err] + Right _ -> [] + + checkMaxBytes Nothing = [] + checkMaxBytes (Just n) + | n == 0 = ["command variable maxBytes must be greater than zero"] + | n > maxReasonableBytes = ["command variable maxBytes must be <= 1048576"] + | otherwise = [] + + maxReasonableBytes :: Natural + maxReasonableBytes = 1048576 + +checkAgentPromptGuidance :: AgentPrompt -> [Text] +checkAgentPromptGuidance p = + concatMap checkGuidance p.guidance + where + knownVars = Set.fromList (map (.name) p.vars <> map (.name) p.commandVars) + + checkGuidance g = + checkTitle g <> checkBody g <> checkConditionRefs g + + checkTitle g + | T.null (T.strip g.title) = ["guidance title must not be empty"] + | otherwise = [] + + checkBody g + | T.null (T.strip g.body) = ["guidance body must not be empty"] + | otherwise = [] + + checkConditionRefs g = + case g.condition of + Nothing -> [] + Just cond -> + [ "guidance '" <> g.title <> "' references undeclared variable: " <> ref.unVarName + | (ref, _) <- exprRefs cond, + not (Set.member ref knownVars) + ] + +checkAgentPromptFiles :: FilePath -> AgentPrompt -> IO [Text] +checkAgentPromptFiles baseDir p = + concat + <$> mapM + ( \pf -> do + let path = baseDir "files" pf.src + exists <- doesFileExist path + pure $ + if exists + then [] + else ["prompt file not found: " <> T.pack pf.src] + ) + p.files + +checkAgentPromptTags :: AgentPrompt -> [Text] +checkAgentPromptTags p = + [ "tag must not be empty" + | t <- p.tags, + T.null (T.strip t) + ] + +checkAgentPromptAllowedTools :: AgentPrompt -> [Text] +checkAgentPromptAllowedTools p = case p.allowedTools of + Nothing -> [] + Just xs -> + [ "allowedTools entry must not be empty" + | t <- xs, + T.null (T.strip t) + ] + +findDupes :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] +findDupes _ _ [] = [] +findDupes seen reported (x : xs) + | Set.member x seen && not (Set.member x reported) = x : findDupes seen (Set.insert x reported) xs + | otherwise = findDupes (Set.insert x seen) reported xs diff --git a/src/Seihou/Core/Blueprint.hs b/src/Seihou/Core/Blueprint.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Blueprint.hs @@ -0,0 +1,205 @@ +module Seihou.Core.Blueprint + ( validateBlueprint, + validateBlueprintWith, + checkBlueprintNameFormat, + checkBlueprintVersionPresent, + checkBlueprintPromptNonEmpty, + checkBlueprintUniqueVars, + checkBlueprintPromptRefs, + checkBlueprintBaseModules, + checkBlueprintBaseModulesWith, + checkBlueprintFiles, + checkBlueprintTags, + checkBlueprintAllowedTools, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable, isValidModuleName) +import Seihou.Core.Types +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Validate a decoded 'Blueprint' against the documented rules. +-- The 'FilePath' is the blueprint's base directory (containing +-- @blueprint.dhall@). +-- +-- Validation rules: +-- +-- 1. Name format: matches @[a-z][a-z0-9-]*@. +-- 2. Version, when given, is non-empty (blueprints may legitimately +-- omit a version during early authoring; we only reject @Just ""@). +-- 3. Prompt body is non-empty after trimming. +-- 4. Variable names declared in @vars@ are unique. +-- 5. Every interactive prompt references a declared variable. +-- 6. Each @baseModules@ entry is well-formed (name format and var +-- binding names) and resolves to a module or recipe — not another +-- blueprint and not nothing. +-- 7. Every @files@ entry exists at @baseDir/files/SRC@. +-- 8. Every tag is non-empty. +-- 9. Every @allowedTools@ entry, when set, is non-empty. +validateBlueprint :: FilePath -> Blueprint -> IO (Either ModuleLoadError Blueprint) +validateBlueprint baseDir b = do + searchPaths <- defaultSearchPaths + validateBlueprintWith searchPaths baseDir b + +-- | Same as 'validateBlueprint' but takes the search paths used for +-- resolving base-module references explicitly. Useful for tests that +-- need to pin the lookup roots; production code should call +-- 'validateBlueprint' which pulls them from 'defaultSearchPaths'. +validateBlueprintWith :: + [FilePath] -> + FilePath -> + Blueprint -> + IO (Either ModuleLoadError Blueprint) +validateBlueprintWith searchPaths baseDir b = do + fileErrs <- checkBlueprintFiles baseDir b + baseErrs <- checkBlueprintBaseModulesWith searchPaths b + let pureErrs = + checkBlueprintNameFormat b + <> checkBlueprintVersionPresent b + <> checkBlueprintPromptNonEmpty b + <> checkBlueprintUniqueVars b + <> checkBlueprintPromptRefs b + <> checkBlueprintTags b + <> checkBlueprintAllowedTools b + allErrs = pureErrs <> fileErrs <> baseErrs + pure $ + if null allErrs + then Right b + else Left (ValidationError b.name allErrs) + +-- Rule 1: blueprint name must match [a-z][a-z0-9-]* +checkBlueprintNameFormat :: Blueprint -> [Text] +checkBlueprintNameFormat b = + let n = b.name.unModuleName + in if T.null n || not (isValidModuleName n) + then ["blueprint name must match [a-z][a-z0-9-]*, got: " <> n] + else [] + +-- Rule 2: if a version is given it must not be empty +checkBlueprintVersionPresent :: Blueprint -> [Text] +checkBlueprintVersionPresent b = case b.version of + Nothing -> [] + Just v + | T.null (T.strip v) -> ["blueprint version, if specified, must not be empty"] + | otherwise -> [] + +-- Rule 3: prompt body must not be empty after trimming +checkBlueprintPromptNonEmpty :: Blueprint -> [Text] +checkBlueprintPromptNonEmpty b + | T.null (T.strip b.prompt) = ["blueprint prompt must not be empty"] + | otherwise = [] + +-- Rule 4: declared variable names must be unique +checkBlueprintUniqueVars :: Blueprint -> [Text] +checkBlueprintUniqueVars b = + let names = map (\d -> d.name.unVarName) b.vars + in map (\n -> "duplicate variable name: " <> n) (findDupes Set.empty Set.empty names) + +findDupes :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] +findDupes _ _ [] = [] +findDupes seen reported (x : xs) + | Set.member x seen && not (Set.member x reported) = x : findDupes seen (Set.insert x reported) xs + | otherwise = findDupes (Set.insert x seen) reported xs + +-- Rule 5: every prompt references a declared variable +checkBlueprintPromptRefs :: Blueprint -> [Text] +checkBlueprintPromptRefs b = + let varNames = Set.fromList (map (.name) b.vars) + in concatMap + ( \p -> + if Set.member p.var varNames + then [] + else ["prompt references undeclared variable: " <> p.var.unVarName] + ) + b.prompts + +-- Rule 6: base modules must be well-formed and resolve to a module or +-- recipe (not another blueprint). The check uses the same default +-- search paths as @seihou run@; tests can pass custom roots via +-- 'checkBlueprintBaseModulesWith'. +checkBlueprintBaseModules :: Blueprint -> IO [Text] +checkBlueprintBaseModules b = do + searchPaths <- defaultSearchPaths + checkBlueprintBaseModulesWith searchPaths b + +checkBlueprintBaseModulesWith :: [FilePath] -> Blueprint -> IO [Text] +checkBlueprintBaseModulesWith searchPaths b = + concat <$> mapM (checkOne searchPaths) b.baseModules + where + checkOne :: [FilePath] -> Dependency -> IO [Text] + checkOne paths dep = do + let n = dep.depModule.unModuleName + nameErrs = + [ "invalid baseModule name: " <> n + | not (isValidModuleName n) + ] + bindingErrs = + [ "baseModule '" <> n <> "' has invalid var binding name: " <> vn + | (VarName vn) <- Map.keys dep.depVars, + not (isValidVarBindingName vn) + ] + resolveErrs <- + if not (isValidModuleName n) + then pure [] + else do + result <- discoverRunnable paths dep.depModule + pure $ case result of + Right (RunnableModule _ _) -> [] + Right (RunnableRecipe _ _) -> [] + Right (RunnableBlueprint _ _) -> + [ "baseModule '" + <> n + <> "' resolves to a blueprint; baseModules must be modules or recipes" + ] + Left (ModuleNotFound _ _) -> + ["baseModule '" <> n <> "' not found in any search path"] + Left _ -> + ["baseModule '" <> n <> "' failed to load"] + pure (nameErrs <> bindingErrs <> resolveErrs) + + isValidVarBindingName :: Text -> Bool + isValidVarBindingName t = case T.uncons t of + Nothing -> False + Just (c, rest) -> + (c >= 'a' && c <= 'z') + && T.all + (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-' || ch == '.') + rest + +-- Rule 7: every @files@ entry's source must exist on disk relative to +-- @baseDir/files/@ +checkBlueprintFiles :: FilePath -> Blueprint -> IO [Text] +checkBlueprintFiles baseDir b = + concat + <$> mapM + ( \bf -> do + let p = baseDir "files" bf.src + exists <- doesFileExist p + pure $ + if exists + then [] + else ["blueprint file not found: " <> T.pack bf.src] + ) + b.files + +-- Rule 8: tags must not be empty strings +checkBlueprintTags :: Blueprint -> [Text] +checkBlueprintTags b = + [ "tag must not be empty" + | t <- b.tags, + T.null (T.strip t) + ] + +-- Rule 9: @allowedTools@, when set, must contain only non-empty entries +checkBlueprintAllowedTools :: Blueprint -> [Text] +checkBlueprintAllowedTools b = case b.allowedTools of + Nothing -> [] + Just xs -> + [ "allowedTools entry must not be empty" + | t <- xs, + T.null (T.strip t) + ] diff --git a/src/Seihou/Core/CommandVar.hs b/src/Seihou/Core/CommandVar.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/CommandVar.hs @@ -0,0 +1,130 @@ +module Seihou.Core.CommandVar + ( resolveCommandVars, + planCommandVars, + commandVarDecl, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Expr (evalExpr) +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types +import Seihou.Core.Variable (coerceValue, validateVarValue) +import Seihou.Effect.Process (Process, runProcess) +import Seihou.Prelude +import System.Exit (ExitCode (..)) + +-- | Select command variables that should run. Already-resolved variables keep +-- their existing value; command variables only fill gaps. +planCommandVars :: [CommandVar] -> Map VarName ResolvedVar -> Map VarName VarValue -> [CommandVar] +planCommandVars commandVars existing bindings = + filter shouldRun commandVars + where + conditionBindings = resolvedValues existing <> bindings + + shouldRun cv = + not (Map.member cv.name existing) + && maybe True (evalExpr conditionBindings) cv.condition + +-- | Return the matching declaration for a command variable, or synthesize a +-- text declaration for prompt-only dynamic context such as @git.branch@. +commandVarDecl :: [VarDecl] -> CommandVar -> VarDecl +commandVarDecl decls cv = + case filter (\decl -> decl.name == cv.name) decls of + decl : _ -> decl + [] -> + VarDecl + { name = cv.name, + type_ = VTText, + default_ = Nothing, + description = Nothing, + required = False, + validation = Nothing + } + +-- | Resolve command-derived variables through the process effect. +-- +-- Existing resolved values have higher precedence and are never overwritten. +-- Command results are accumulated in order so later @when@ expressions can +-- depend on earlier command-derived values. +resolveCommandVars :: + (Process :> es) => + [VarDecl] -> + [CommandVar] -> + Map VarName ResolvedVar -> + Eff es (Either [VarError] (Map VarName ResolvedVar)) +resolveCommandVars decls commandVars existing = do + (errs, resolved) <- go [] existing (resolvedValues existing) commandVars + pure $ + if null errs + then Right resolved + else Left errs + where + go errs resolved _bindings [] = pure (reverse errs, resolved) + go errs resolved bindings (cv : rest) + | Map.member cv.name resolved = go errs resolved bindings rest + | maybe False (not . evalExpr bindings) cv.condition = go errs resolved bindings rest + | otherwise = do + result <- resolveOne bindings cv + case result of + Left err -> go (err : errs) resolved bindings rest + Right rv -> + let resolved' = Map.insert cv.name rv resolved + bindings' = Map.insert cv.name rv.value bindings + in go errs resolved' bindings' rest + + resolveOne _bindings cv = do + let decl = commandVarDecl decls cv + case validateWorkDir cv of + Left err -> pure (Left err) + Right workDir -> do + (exitCode, stdoutText, stderrText) <- runProcess "sh" ["-c", cv.run] workDir + pure $ case exitCode of + ExitSuccess -> coerceCommandOutput decl cv stdoutText + ExitFailure code -> + Left $ + ValidationFailed + cv.name + ( "command failed with exit code " + <> T.pack (show code) + <> ": " + <> summarizeDiagnostic stderrText + ) + + validateWorkDir :: CommandVar -> Either VarError (Maybe FilePath) + validateWorkDir cv@CommandVar {workDir = Nothing} = Right Nothing + validateWorkDir cv@CommandVar {workDir = Just wd} = + case validateProjectRelativePath wd of + Left err -> Left (ValidationFailed cv.name ("command variable workDir " <> err)) + Right _ -> Right (Just (T.unpack wd)) + +coerceCommandOutput :: VarDecl -> CommandVar -> Text -> Either VarError ResolvedVar +coerceCommandOutput decl cv stdoutText = do + let output = + if cv.trim + then T.strip stdoutText + else stdoutText + case cv.maxBytes of + Just n + | fromIntegral (T.length output) > n -> + Left (ValidationFailed cv.name ("command output exceeds maxBytes " <> T.pack (show n))) + _ -> do + value <- coerceValue decl.name decl.type_ output + validateVarValue decl value + Right + ResolvedVar + { value = value, + source = FromCommand cv.run, + decl = decl + } + +resolvedValues :: Map VarName ResolvedVar -> Map VarName VarValue +resolvedValues = Map.map (.value) + +summarizeDiagnostic :: Text -> Text +summarizeDiagnostic t = + let stripped = T.strip t + in if T.null stripped + then "no stderr" + else T.take 200 stripped diff --git a/src/Seihou/Core/Context.hs b/src/Seihou/Core/Context.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Context.hs @@ -0,0 +1,65 @@ +module Seihou.Core.Context + ( resolveContext, + validateContextName, + ) +where + +import Control.Applicative ((<|>)) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Prelude +import System.Directory (XdgDirectory (..), doesFileExist, getCurrentDirectory, getXdgDirectory) + +-- | Resolve the active context name from multiple sources in precedence order: +-- +-- 1. CLI flag (@--context@) +-- 2. @SEIHOU_CONTEXT@ environment variable +-- 3. Project file @.seihou\/context@ (plain text, single line) +-- 4. Global default @~\/.config\/seihou\/default-context@ (plain text, single line) +-- +-- Returns 'Nothing' if no context is active. +resolveContext :: + Maybe Text -> + Map Text Text -> + IO (Maybe Text) +resolveContext cliFlag envVars = + case nonEmpty cliFlag <|> nonEmpty (Map.lookup "SEIHOU_CONTEXT" envVars) of + Just ctx -> pure (Just ctx) + Nothing -> do + projectCtx <- readProjectContext + case projectCtx of + Just ctx -> pure (Just ctx) + Nothing -> readGlobalDefaultContext + where + nonEmpty (Just t) | not (T.null (T.strip t)) = Just (T.strip t) + nonEmpty _ = Nothing + +-- | Validate a context name. Returns 'Nothing' if valid, 'Just errorMsg' if invalid. +validateContextName :: Text -> Maybe Text +validateContextName ctx + | T.null ctx = Just "context name cannot be empty" + | ".." `T.isInfixOf` ctx = Just "context name must not contain '..'" + | "/" `T.isInfixOf` ctx = Just "context name must not contain '/'" + | otherwise = Nothing + +-- Internal helpers + +readTextFileMaybe :: FilePath -> IO (Maybe Text) +readTextFileMaybe path = do + exists <- doesFileExist path + if exists + then do + content <- T.strip <$> TIO.readFile path + pure $ if T.null content then Nothing else Just content + else pure Nothing + +readProjectContext :: IO (Maybe Text) +readProjectContext = do + cwd <- getCurrentDirectory + readTextFileMaybe (cwd ".seihou" "context") + +readGlobalDefaultContext :: IO (Maybe Text) +readGlobalDefaultContext = do + base <- getXdgDirectory XdgConfig "seihou" + readTextFileMaybe (base "default-context") diff --git a/src/Seihou/Core/Expr.hs b/src/Seihou/Core/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Expr.hs @@ -0,0 +1,204 @@ +module Seihou.Core.Expr + ( parseExpr, + evalExpr, + exprRefs, + ) +where + +import Data.Char (isDigit) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Prelude + +-- | Parse an expression string into an 'Expr' AST. +-- +-- Grammar: +-- +-- > expr = or_expr +-- > or_expr = and_expr ("||" and_expr)* +-- > and_expr = not_expr ("&&" not_expr)* +-- > not_expr = "!" atom | atom +-- > atom = "IsSet" varname +-- > | "Eq" varname value +-- > | "(" expr ")" +-- > | "true" | "false" +-- > varname = [a-zA-Z][a-zA-Z0-9._-]* +-- > value = quoted_string | bare_word +parseExpr :: Text -> Either Text Expr +parseExpr input = + let trimmed = T.strip input + in if T.null trimmed + then Left "empty expression" + else case runParser parseOrExpr trimmed of + Left err -> Left err + Right (expr, rest) + | T.null (T.strip rest) -> Right expr + | otherwise -> Left ("unexpected trailing input: " <> rest) + +-- | Evaluate an expression against a map of variable bindings. +evalExpr :: Map VarName VarValue -> Expr -> Bool +evalExpr vars = go + where + go (ExprEq name val) = Map.lookup name vars == Just val + go (ExprAnd l r) = go l && go r + go (ExprOr l r) = go l || go r + go (ExprNot e) = not (go e) + go (ExprIsSet name) = Map.member name vars + go (ExprLit b) = b + +-- | Collect the variables an expression references, paired with the literal +-- each is compared against via 'Eq' (if any). +-- +-- * @Eq n v@ → @[(n, Just v)]@ +-- * @IsSet n@ → @[(n, Nothing)]@ +-- * @And@\/@Or@\/@Not@ recurse into sub-expressions +-- * @Lit@ → @[]@ +-- +-- Used by authoring-time lint to flag references to undeclared variables and +-- type-inconsistent @Eq@ comparisons. Total over 'Expr'. +exprRefs :: Expr -> [(VarName, Maybe VarValue)] +exprRefs (ExprEq name val) = [(name, Just val)] +exprRefs (ExprIsSet name) = [(name, Nothing)] +exprRefs (ExprAnd l r) = exprRefs l ++ exprRefs r +exprRefs (ExprOr l r) = exprRefs l ++ exprRefs r +exprRefs (ExprNot e) = exprRefs e +exprRefs (ExprLit _) = [] + +-- Parser internals: a parser consumes text and returns the result plus unconsumed input. +type Parser a = Text -> Either Text (a, Text) + +runParser :: Parser a -> Text -> Either Text (a, Text) +runParser = id + +parseOrExpr :: Parser Expr +parseOrExpr input = do + (left, rest) <- parseAndExpr input + parseOrRest left rest + +parseOrRest :: Expr -> Parser Expr +parseOrRest left input = + let stripped = T.strip input + in if "||" `T.isPrefixOf` stripped + then do + let rest = T.strip (T.drop 2 stripped) + (right, rest') <- parseAndExpr rest + parseOrRest (ExprOr left right) rest' + else Right (left, input) + +parseAndExpr :: Parser Expr +parseAndExpr input = do + (left, rest) <- parseNotExpr input + parseAndRest left rest + +parseAndRest :: Expr -> Parser Expr +parseAndRest left input = + let stripped = T.strip input + in if "&&" `T.isPrefixOf` stripped + then do + let rest = T.strip (T.drop 2 stripped) + (right, rest') <- parseNotExpr rest + parseAndRest (ExprAnd left right) rest' + else Right (left, input) + +parseNotExpr :: Parser Expr +parseNotExpr input = + let stripped = T.strip input + in if "!" `T.isPrefixOf` stripped + then do + let rest = T.drop 1 stripped + (e, rest') <- parseNotExpr rest + Right (ExprNot e, rest') + else parseAtom stripped + +parseAtom :: Parser Expr +parseAtom input = + let stripped = T.strip input + in case () of + _ + | T.null stripped -> Left "unexpected end of input" + | "true" `T.isPrefixOf` stripped && isAtomEnd (T.drop 4 stripped) -> + Right (ExprLit True, T.drop 4 stripped) + | "false" `T.isPrefixOf` stripped && isAtomEnd (T.drop 5 stripped) -> + Right (ExprLit False, T.drop 5 stripped) + | "IsSet" `T.isPrefixOf` stripped && isWhitespace (T.drop 5 stripped) -> do + let rest = T.strip (T.drop 5 stripped) + (name, rest') <- parseVarName rest + Right (ExprIsSet (VarName name), rest') + | "Eq" `T.isPrefixOf` stripped && isWhitespace (T.drop 2 stripped) -> do + let rest = T.strip (T.drop 2 stripped) + (name, rest') <- parseVarName rest + let rest'' = T.strip rest' + (value, rest''') <- parseValue rest'' + Right (ExprEq (VarName name) value, rest''') + | T.head stripped == '(' -> do + let rest = T.strip (T.drop 1 stripped) + (e, rest') <- parseOrExpr rest + let rest'' = T.strip rest' + if not (T.null rest'') && T.head rest'' == ')' + then Right (e, T.drop 1 rest'') + else Left "expected closing parenthesis" + | otherwise -> Left ("unexpected token: " <> T.take 20 stripped) + +-- | Check if the character after a keyword is a valid separator (not a varname char). +isAtomEnd :: Text -> Bool +isAtomEnd t = T.null t || not (isVarNameChar (T.head t)) + +isWhitespace :: Text -> Bool +isWhitespace t = not (T.null t) && T.head t == ' ' + +parseVarName :: Parser Text +parseVarName input + | T.null input = Left "expected variable name" + | not (isVarNameStart (T.head input)) = Left ("expected variable name, got: " <> T.take 10 input) + | otherwise = + let (name, rest) = T.span isVarNameChar input + in Right (name, rest) + +isVarNameStart :: Char -> Bool +isVarNameStart c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + +isVarNameChar :: Char -> Bool +isVarNameChar c = + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + || c == '.' + || c == '_' + || c == '-' + +parseValue :: Parser VarValue +parseValue input + | T.null input = Left "expected value" + | T.head input == '"' = parseQuotedString (T.drop 1 input) + | otherwise = parseBareWord input + +parseQuotedString :: Parser VarValue +parseQuotedString input = + case T.breakOn "\"" input of + (content, rest) + | T.null rest -> Left "unterminated quoted string" + | otherwise -> Right (VText content, T.drop 1 rest) + +parseBareWord :: Parser VarValue +parseBareWord input = + let (word, rest) = T.break (\c -> c == ' ' || c == ')' || c == '&' || c == '|') input + in if T.null word + then Left "expected value" + else Right (classifyBareWord word, rest) + where + classifyBareWord "true" = VBool True + classifyBareWord "false" = VBool False + classifyBareWord w + | isIntLiteral w = VInt (read (T.unpack w)) + | otherwise = VText w + +-- | Whether a bareword is an integer literal: all digits, with an optional +-- leading minus sign and at least one digit. Such barewords are classified as +-- 'VInt' so an @Eq N@ comparison matches a resolved 'VInt' value +-- (there is otherwise no surface syntax that produces an integer literal). +isIntLiteral :: Text -> Bool +isIntLiteral w = + case T.uncons w of + Just ('-', rest) -> not (T.null rest) && T.all isDigit rest + _ -> not (T.null w) && T.all isDigit w diff --git a/src/Seihou/Core/Install.hs b/src/Seihou/Core/Install.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Install.hs @@ -0,0 +1,17 @@ +module Seihou.Core.Install + ( parseModuleName, + ) +where + +import Data.Text qualified as T +import Seihou.Prelude + +-- | Parse a module name from a git URL by extracting the last path segment +-- and stripping a trailing .git extension. +parseModuleName :: Text -> String +parseModuleName url = + let stripped = T.stripSuffix ".git" url + base = maybe url id stripped + segments = T.splitOn "/" base + lastSeg = if null segments then base else last segments + in T.unpack lastSeg diff --git a/src/Seihou/Core/Migration.hs b/src/Seihou/Core/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Migration.hs @@ -0,0 +1,191 @@ +module Seihou.Core.Migration + ( -- * Author-declared migrations + Migration (..), + MigrationOp (..), + + -- * Migration planning + MigrationPlan (..), + MigrationPlanError (..), + planMigrationChain, + ) +where + +import Data.List (sortOn) +import GHC.Generics (Generic) +import Seihou.Core.Version (Version, parseVersion) +import Seihou.Prelude + +-- | A single filesystem operation declared by a migration. +-- +-- The variants mirror the Dhall union @schema/MigrationOp.dhall@ exactly: +-- +-- * 'MoveFile' — rename a tracked file. The migration engine rewrites +-- the manifest's @files@ map key from @src@ to @dest@. +-- * 'MoveDir' — rename a directory. Every manifest @files@ entry whose +-- path starts with @src/@ has its key rewritten with the @dest/@ prefix. +-- * 'DeleteFile' — remove a tracked file from disk and drop it from the +-- manifest. +-- * 'DeleteDir' — remove a directory recursively and drop every manifest +-- entry under that prefix. +-- * 'RunCommand' — execute a shell command. The manifest is not rewritten +-- by this op; if the command moves files, the migration author is +-- responsible for following it with explicit move/delete ops. +data MigrationOp + = MoveFile {src :: FilePath, dest :: FilePath} + | MoveDir {src :: FilePath, dest :: FilePath} + | DeleteFile {path :: FilePath} + | DeleteDir {path :: FilePath} + | RunCommand {run :: Text, workDir :: Maybe FilePath} + deriving stock (Eq, Show, Generic) + +-- | A migration that moves a project from module version @from@ to module +-- version @to@. The 'ops' list is applied in declaration order. +data Migration = Migration + { from :: Text, + to :: Text, + ops :: [MigrationOp] + } + deriving stock (Eq, Show, Generic) + +-- ---------------------------------------------------------------------------- +-- Pure planner — gap-tolerant version-window walker +-- +-- The planner is the bridge between the unsorted list of author-declared +-- migrations on a 'Module' and the ordered sequence that the migration +-- engine actually executes. It is a pure function: no IO, no filesystem, +-- no manifest. The @moduleName@ parameter is the rendered module name +-- (a 'Text', not 'Seihou.Core.Types.ModuleName') so this module can stay +-- self-contained and avoid a circular dependency with @Types@ (which +-- imports 'Migration' for the @migrations@ field on @Module@). The CLI +-- handler unwraps the 'ModuleName' newtype before calling. +-- +-- The planner's contract is simple: given an installed manifest version +-- and a target version, apply every declared migration @m@ such that +-- @installed ≤ m.from@ and @m.to ≤ target@, in ascending @from@ order, +-- advancing a cursor as you go (skipping any edge whose @from@ has +-- fallen behind the cursor). After all applicable edges have been +-- collected, the manifest's recorded version always advances to +-- @target@, even when no migration applies (a "pure version bump"). +-- ---------------------------------------------------------------------------- + +-- | The planner result for a non-trivial @installed → target@ request. +-- +-- The plan carries the module name for rendering, the start and end +-- versions of the user-visible "X → Y" header, and the ordered list of +-- migrations that will run. A plan with @planSteps == []@ means the +-- manifest will advance from @planFrom@ to @planTo@ without running +-- any migration ops (a pure version bump). +data MigrationPlan = MigrationPlan + { planModule :: Text, + -- | Installed (manifest) version at the start. + planFrom :: Version, + -- | Target version. The manifest will land here after the plan + -- runs, regardless of whether any of the declared migrations + -- bridge every gap inside @[planFrom, planTo]@. + planTo :: Version, + -- | The migrations that actually apply, in ascending @from@ + -- order. May be empty. + planSteps :: [Migration] + } + deriving stock (Eq, Show, Generic) + +-- | All the ways planning can fail. Each carries enough information to +-- write a useful error message at the CLI layer. +data MigrationPlanError + = -- | A 'Migration' had a 'from' or 'to' string that didn't parse. + -- Carries the offending string verbatim. + MigrationVersionUnparseable Text + | -- | Refusing to plan a downgrade. @installed → target@ where @target@ + -- compares strictly less than @installed@. + MigrationDowngradeNotSupported Version Version + | -- | Two migrations declare the same 'from' version, so the planner + -- can't unambiguously pick a successor. Args: the duplicated 'from' + -- and one of the conflicting 'to' versions. + MigrationDuplicateEdge Version Version + deriving stock (Eq, Show, Generic) + +-- | Compute the migration plan that spans installed → target. +-- +-- Returns: +-- +-- * @Right Nothing@ — installed and target are equal; no work to do. +-- * @Right (Just plan)@ — the plan carries every migration whose +-- version range falls inside @[installed, target]@, plus the +-- installed and target versions for downstream rendering and +-- manifest-advance logic. The list may be empty (a pure version +-- bump where no migration applies); the manifest still advances +-- to @target@ in that case. +-- * @Left e@ — planning failed; the error variant explains why. +-- Author-side mistakes (duplicate edge, unparseable version) and +-- downgrades are still hard errors. Partial coverage is not, and +-- overshoots are silently skipped. +-- +-- Algorithm: parse every declared migration's @from@/@to@ into +-- 'Version' values, reject duplicate @from@s, sort the remaining edges +-- by @from@ ascending, then walk the sorted list with a cursor. Each +-- edge is either picked (and the cursor advances to its @to@), skipped +-- because its @from@ has fallen behind the cursor (already covered by +-- an earlier picked edge), skipped because its @to@ overshoots the +-- target (the user hasn't asked to go that far), or terminates the +-- walk because its @from@ has reached or exceeded the target (no +-- subsequent edge in the sorted list can contribute either). +planMigrationChain :: + -- | Module name (already rendered to text) + Text -> + -- | All declared migrations on the module + [Migration] -> + -- | Installed version + Version -> + -- | Target version + Version -> + Either MigrationPlanError (Maybe MigrationPlan) +planMigrationChain modName migrations installed target + | installed == target = Right Nothing + | target < installed = + Left (MigrationDowngradeNotSupported installed target) + | otherwise = do + parsed <- traverse parseEdges migrations + checkDuplicates parsed + let sorted = sortOn (\(_, f, _) -> f) parsed + steps = pickInWindow installed target sorted + Right + ( Just + MigrationPlan + { planModule = modName, + planFrom = installed, + planTo = target, + planSteps = steps + } + ) + where + -- Parse a migration's from/to fields into Version values. + parseEdges m = do + fv <- parseVersionE m.from + tv <- parseVersionE m.to + Right (m, fv, tv) + + parseVersionE t = + case parseVersion t of + Just v -> Right v + Nothing -> Left (MigrationVersionUnparseable t) + + -- Detect two migrations declaring the same `from` version. + checkDuplicates [] = Right () + checkDuplicates ((_, f, t) : rest) = + case [t' | (_, f', t') <- rest, f' == f] of + (t' : _) -> Left (MigrationDuplicateEdge f t') + [] -> checkDuplicates rest + + -- Walk the sorted edge list collecting in-window migrations. + -- The list is sorted by `from` ascending, so once an edge has + -- `from >= end` no later edge can contribute either. An edge with + -- `from < cursor` is already-covered (or precedes the manifest) + -- and is skipped. An edge with `to > end` overshoots the target + -- and is silently skipped — a future invocation with a higher + -- target will pick it up. + pickInWindow _cursor _end [] = [] + pickInWindow cursor end ((m, f, t) : rest) + | f < cursor = pickInWindow cursor end rest + | f >= end = [] + | t > end = pickInWindow cursor end rest + | otherwise = m : pickInWindow t end rest diff --git a/src/Seihou/Core/Module.hs b/src/Seihou/Core/Module.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Module.hs @@ -0,0 +1,565 @@ +module Seihou.Core.Module + ( discoverModule, + discoverBlueprint, + discoverAgentPrompt, + discoverRunnable, + defaultSearchPaths, + validateModule, + loadModule, + discoverAllModules, + discoverAllRunnables, + DiscoveredModule (..), + DiscoveredRunnable (..), + RunnableKind (..), + ModuleSource (..), + + -- * Individual check functions (for structured reports) + checkNameFormat, + checkVersionPresent, + checkUniqueVars, + checkPromptRefs, + checkFileExistence, + checkExportRefs, + checkDependencyNames, + checkDependencyVarBindings, + checkSafeDestinations, + checkDestVarRefs, + checkCommandSafety, + isValidModuleName, + extractPlaceholders, + validateProjectRelativePath, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import GHC.Generics (Generic) +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRecipeFromFile) +import Seihou.Prelude +import System.Directory (XdgDirectory (..), doesDirectoryExist, doesFileExist, getCurrentDirectory, getXdgDirectory, listDirectory) + +-- | Search for a module by name in the given directories. +-- Returns the path to the directory containing @module.dhall@, or +-- 'ModuleNotFound' listing the directories that were searched. +discoverModule :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError FilePath) +discoverModule searchPaths name = go searchPaths + where + nameStr = T.unpack name.unModuleName + go [] = pure $ Left (ModuleNotFound name searchPaths) + go (dir : rest) = do + let candidate = dir nameStr + let dhallFile = candidate "module.dhall" + exists <- doesFileExist dhallFile + if exists + then pure (Right candidate) + else go rest + +-- | Search for a runnable (module, recipe, blueprint, or prompt) by name in the +-- given directories. For each search path, checks @module.dhall@ first +-- (returning 'RunnableModule'), then @recipe.dhall@ +-- (returning 'RunnableRecipe'), then @blueprint.dhall@ +-- (returning 'RunnableBlueprint'), then @prompt.dhall@ +-- (returning 'RunnableAgentPrompt'). Within a single candidate directory +-- the priority is module > recipe > blueprint > prompt, so a stray +-- @module.dhall@ next to a @blueprint.dhall@ silently surfaces the +-- module — the more specific, deterministic artifact. Returns +-- 'ModuleNotFound' if none is found in any search path. +discoverRunnable :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError Runnable) +discoverRunnable searchPaths name = go searchPaths + where + nameStr = T.unpack name.unModuleName + go [] = pure $ Left (ModuleNotFound name searchPaths) + go (dir : rest) = do + let candidate = dir nameStr + moduleDhall = candidate "module.dhall" + recipeDhall = candidate "recipe.dhall" + blueprintDhall = candidate "blueprint.dhall" + promptDhall = candidate "prompt.dhall" + isModule <- doesFileExist moduleDhall + if isModule + then do + result <- evalModuleFromFile moduleDhall + case result of + Left err -> pure (Left err) + Right m -> pure (Right (RunnableModule m candidate)) + else do + isRecipe <- doesFileExist recipeDhall + if isRecipe + then do + result <- evalRecipeFromFile recipeDhall + case result of + Left err -> pure (Left err) + Right r -> pure (Right (RunnableRecipe r candidate)) + else do + isBlueprint <- doesFileExist blueprintDhall + if isBlueprint + then do + result <- evalBlueprintFromFile blueprintDhall + case result of + Left err -> pure (Left err) + Right b -> pure (Right (RunnableBlueprint b candidate)) + else do + isPrompt <- doesFileExist promptDhall + if isPrompt + then do + result <- evalAgentPromptFromFile promptDhall + case result of + Left err -> pure (Left err) + Right p -> pure (Right (RunnableAgentPrompt p candidate)) + else go rest + +-- | Search for a blueprint by name in the given directories. Returns +-- the path to the directory containing @blueprint.dhall@, or +-- 'ModuleNotFound' listing the directories that were searched. Mirrors +-- 'discoverModule' for callers that only care about discovering a +-- blueprint by name. +discoverBlueprint :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError FilePath) +discoverBlueprint searchPaths name = go searchPaths + where + nameStr = T.unpack name.unModuleName + go [] = pure $ Left (ModuleNotFound name searchPaths) + go (dir : rest) = do + let candidate = dir nameStr + let dhallFile = candidate "blueprint.dhall" + exists <- doesFileExist dhallFile + if exists + then pure (Right candidate) + else go rest + +-- | Search for an agent prompt by name in the given directories. Returns +-- the path to the directory containing @prompt.dhall@, or 'ModuleNotFound' +-- listing the directories that were searched. +discoverAgentPrompt :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError FilePath) +discoverAgentPrompt searchPaths name = go searchPaths + where + nameStr = T.unpack name.unModuleName + go [] = pure $ Left (ModuleNotFound name searchPaths) + go (dir : rest) = do + let candidate = dir nameStr + let dhallFile = candidate "prompt.dhall" + exists <- doesFileExist dhallFile + if exists + then pure (Right candidate) + else go rest + +-- | The three standard module search paths, in priority order: +-- 1. @.seihou/modules/@ relative to the current directory +-- 2. @~/.config/seihou/modules/@ +-- 3. @~/.config/seihou/installed/@ +defaultSearchPaths :: IO [FilePath] +defaultSearchPaths = do + cwd <- getCurrentDirectory + xdgConfig <- getXdgDirectory XdgConfig "seihou" + pure + [ cwd ".seihou" "modules", + xdgConfig "modules", + xdgConfig "installed" + ] + +-- | Validate a decoded 'Module' against the nine validation rules. +-- The 'FilePath' is the module's base directory (containing @module.dhall@). +-- Returns 'Right' with the module if all rules pass, or 'Left' with a +-- 'ValidationError' listing all violations. +validateModule :: FilePath -> Module -> IO (Either ModuleLoadError Module) +validateModule baseDir m = do + fileErrors <- checkFileExistence baseDir m + let pureErrors = + checkNameFormat m + <> checkVersionPresent m + <> checkUniqueVars m + <> checkPromptRefs m + <> checkExportRefs m + <> checkDependencyNames m + <> checkDependencyVarBindings m + <> checkSafeDestinations m + <> checkDestVarRefs m + <> checkCommandSafety m + allErrors = pureErrors <> fileErrors + pure $ + if null allErrors + then Right m + else Left (ValidationError m.name allErrors) + +-- Rule 1: Module name must be non-empty and match [a-z][a-z0-9-]* +checkNameFormat :: Module -> [Text] +checkNameFormat m = + let n = m.name.unModuleName + in if T.null n || not (isValidModuleName n) + then ["module name must match [a-z][a-z0-9-]*, got: " <> n] + else [] + +isValidModuleName :: Text -> Bool +isValidModuleName t = case T.uncons t of + Nothing -> False + Just (c, rest) -> + (c >= 'a' && c <= 'z') + && T.all (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-') rest + +-- Rule 1b: Module must declare a version +checkVersionPresent :: Module -> [Text] +checkVersionPresent m = case m.version of + Nothing -> ["module must declare a version"] + Just v + | T.null (T.strip v) -> ["module must declare a version"] + | otherwise -> [] + +-- Rule 2: All variable names must be unique +checkUniqueVars :: Module -> [Text] +checkUniqueVars m = + let names = map (\d -> d.name.unVarName) m.vars + in map (\n -> "duplicate variable name: " <> n) (findDupes Set.empty Set.empty names) + +findDupes :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] +findDupes _ _ [] = [] +findDupes seen reported (x : xs) + | Set.member x seen && not (Set.member x reported) = x : findDupes seen (Set.insert x reported) xs + | otherwise = findDupes (Set.insert x seen) reported xs + +-- Rule 3: Every prompt must reference a declared variable +checkPromptRefs :: Module -> [Text] +checkPromptRefs m = + let varNames = Set.fromList (map (.name) m.vars) + in concatMap + ( \p -> + if Set.member p.var varNames + then [] + else ["prompt references undeclared variable: " <> p.var.unVarName] + ) + m.prompts + +-- Rule 4: Every step source file must exist in the module's files/ directory +checkFileExistence :: FilePath -> Module -> IO [Text] +checkFileExistence baseDir m = + concat + <$> mapM + ( \s -> do + let p = baseDir "files" s.src + exists <- doesFileExist p + pure $ + if exists + then [] + else ["step source file not found: " <> T.pack s.src] + ) + m.steps + +-- Rule 5: Every export must reference a declared variable +checkExportRefs :: Module -> [Text] +checkExportRefs m = + let varNames = Set.fromList (map (.name) m.vars) + in concatMap + ( \e -> + if Set.member e.var varNames + then [] + else ["export references undeclared variable: " <> e.var.unVarName] + ) + m.exports + +-- Rule 6: Every dependency name must be well-formed +checkDependencyNames :: Module -> [Text] +checkDependencyNames m = + concatMap + ( \dep -> + let n = dep.depModule.unModuleName + in if isValidModuleName n + then [] + else ["invalid dependency name: " <> n] + ) + m.dependencies + +-- Rule 6b: Dependency var binding names must be non-empty +checkDependencyVarBindings :: Module -> [Text] +checkDependencyVarBindings m = + concatMap + ( \dep -> + concatMap + ( \(VarName vn) -> + if T.null vn + then ["dependency '" <> dep.depModule.unModuleName <> "' has empty var binding name"] + else [] + ) + (Map.keys dep.depVars) + ) + m.dependencies + +-- Rule 7: Every step destination must be a safe relative path +checkSafeDestinations :: Module -> [Text] +checkSafeDestinations m = concatMap checkDest m.steps + where + checkDest s = + case validateProjectRelativePath s.dest of + Left err -> ["step destination " <> err] + Right _ -> [] + +-- Rule 8: Variables referenced in step dest placeholders must be declared +checkDestVarRefs :: Module -> [Text] +checkDestVarRefs m = + let varNames = Set.fromList (map (\d -> d.name.unVarName) m.vars) + in concatMap (checkStep varNames) m.steps + where + checkStep varNames s = + [ "step destination references undeclared variable: " <> ref + | ref <- extractPlaceholders s.dest, + not (Set.member ref varNames) + ] + +-- Rule 9: Command text must be non-empty and workDir must be safe +checkCommandSafety :: Module -> [Text] +checkCommandSafety m = concatMap checkCmd m.commands + where + checkCmd c = checkEmptyRun c <> checkWorkDir c.workDir + + checkEmptyRun c + | T.null (T.strip c.run) = ["command text must not be empty"] + | otherwise = [] + + checkWorkDir Nothing = [] + checkWorkDir (Just wd) = + case validateProjectRelativePath wd of + Left err -> ["command workDir " <> err] + Right _ -> [] + +-- | Extract placeholder variable references from a text like @"src/{{project.name}}/Main.hs"@. +extractPlaceholders :: Text -> [Text] +extractPlaceholders t = case T.breakOn "{{" t of + (_, rest) + | T.null rest -> [] + | otherwise -> + let afterOpen = T.drop 2 rest + in case T.breakOn "}}" afterOpen of + (ref, rest') + | T.null rest' -> [] + | otherwise -> T.strip ref : extractPlaceholders (T.drop 2 rest') + +-- | Load a module by name: discover, evaluate, decode, and validate. +loadModule :: [FilePath] -> ModuleName -> IO (Either ModuleLoadError Module) +loadModule searchPaths name = do + discovered <- discoverModule searchPaths name + case discovered of + Left err -> pure (Left err) + Right moduleDir -> do + let dhallFile = moduleDir "module.dhall" + decoded <- evalModuleFromFile dhallFile + case decoded of + Left err -> pure (Left err) + Right m -> validateModule moduleDir m + +-- | Which search path category a module was found in. +data ModuleSource = SourceProject | SourceUser | SourceInstalled + deriving stock (Eq, Show, Generic) + +-- | A module discovered during enumeration, with its load result and source. +data DiscoveredModule = DiscoveredModule + { discoveredResult :: Either ModuleLoadError Module, + discoveredSource :: ModuleSource, + discoveredDir :: FilePath + } + deriving stock (Show) + +-- | Enumerate all modules across the given search paths. +-- The search paths must be in the same order as 'defaultSearchPaths': +-- project-local, user, installed. Each subdirectory containing a +-- @module.dhall@ file is loaded; failures are captured in 'discoveredResult'. +discoverAllModules :: [FilePath] -> IO [DiscoveredModule] +discoverAllModules searchPaths = do + let tagged = zip searchPaths (sources ++ repeat SourceInstalled) + concat <$> mapM (uncurry scanPath) tagged + where + sources = [SourceProject, SourceUser, SourceInstalled] + + scanPath :: FilePath -> ModuleSource -> IO [DiscoveredModule] + scanPath dir src = do + exists <- doesDirectoryExist dir + if not exists + then pure [] + else do + entries <- listDirectory dir + candidates <- filterM (isModuleDir dir) entries + mapM (loadOne dir src) candidates + + isModuleDir :: FilePath -> FilePath -> IO Bool + isModuleDir parent entry = do + let candidate = parent entry "module.dhall" + doesFileExist candidate + + filterM :: (a -> IO Bool) -> [a] -> IO [a] + filterM _ [] = pure [] + filterM p (x : xs) = do + keep <- p x + rest <- filterM p xs + pure (if keep then x : rest else rest) + + loadOne :: FilePath -> ModuleSource -> FilePath -> IO DiscoveredModule + loadOne dir src entry = do + let moduleDir = dir entry + dhallFile = moduleDir "module.dhall" + decoded <- evalModuleFromFile dhallFile + result <- case decoded of + Left err -> pure (Left err) + Right m -> validateModule moduleDir m + pure DiscoveredModule {discoveredResult = result, discoveredSource = src, discoveredDir = moduleDir} + +-- | Whether a discovered item is a module, recipe, blueprint, or prompt. +data RunnableKind = KindModule | KindRecipe | KindBlueprint | KindPrompt + deriving stock (Eq, Show, Generic) + +-- | A runnable discovered during enumeration, with its load result, kind, and source. +data DiscoveredRunnable = DiscoveredRunnable + { drName :: Text, + drDescription :: Maybe Text, + drKind :: RunnableKind, + drSource :: ModuleSource, + drDir :: FilePath, + drIsError :: Bool, + drError :: Maybe Text + } + deriving stock (Show) + +-- | Enumerate all modules, recipes, blueprints, and prompts across the given search paths. +-- Returns a unified list of discovered items, each tagged with its kind. +discoverAllRunnables :: [FilePath] -> IO [DiscoveredRunnable] +discoverAllRunnables searchPaths = do + let tagged = zip searchPaths (sources ++ repeat SourceInstalled) + concat <$> mapM (uncurry scanRunnablePath) tagged + where + sources = [SourceProject, SourceUser, SourceInstalled] + + scanRunnablePath :: FilePath -> ModuleSource -> IO [DiscoveredRunnable] + scanRunnablePath dir src = do + exists <- doesDirectoryExist dir + if not exists + then pure [] + else do + entries <- listDirectory dir + concat <$> mapM (loadRunnable dir src) entries + + loadRunnable :: FilePath -> ModuleSource -> FilePath -> IO [DiscoveredRunnable] + loadRunnable dir src entry = do + let entryDir = dir entry + moduleDhall = entryDir "module.dhall" + recipeDhall = entryDir "recipe.dhall" + blueprintDhall = entryDir "blueprint.dhall" + promptDhall = entryDir "prompt.dhall" + isModule <- doesFileExist moduleDhall + isRecipe <- doesFileExist recipeDhall + isBlueprint <- doesFileExist blueprintDhall + isPrompt <- doesFileExist promptDhall + if isModule + then do + decoded <- evalModuleFromFile moduleDhall + pure + [ case decoded of + Left err -> + DiscoveredRunnable + { drName = T.pack entry, + drDescription = Nothing, + drKind = KindModule, + drSource = src, + drDir = entryDir, + drIsError = True, + drError = Just (briefLoadError err) + } + Right m -> + DiscoveredRunnable + { drName = m.name.unModuleName, + drDescription = m.description, + drKind = KindModule, + drSource = src, + drDir = entryDir, + drIsError = False, + drError = Nothing + } + ] + else + if isRecipe + then do + decoded <- evalRecipeFromFile recipeDhall + pure + [ case decoded of + Left err -> + DiscoveredRunnable + { drName = T.pack entry, + drDescription = Nothing, + drKind = KindRecipe, + drSource = src, + drDir = entryDir, + drIsError = True, + drError = Just (briefLoadError err) + } + Right r -> + DiscoveredRunnable + { drName = r.name.unRecipeName, + drDescription = r.description, + drKind = KindRecipe, + drSource = src, + drDir = entryDir, + drIsError = False, + drError = Nothing + } + ] + else + if isBlueprint + then do + decoded <- evalBlueprintFromFile blueprintDhall + pure + [ case decoded of + Left err -> + DiscoveredRunnable + { drName = T.pack entry, + drDescription = Nothing, + drKind = KindBlueprint, + drSource = src, + drDir = entryDir, + drIsError = True, + drError = Just (briefLoadError err) + } + Right b -> + DiscoveredRunnable + { drName = b.name.unModuleName, + drDescription = b.description, + drKind = KindBlueprint, + drSource = src, + drDir = entryDir, + drIsError = False, + drError = Nothing + } + ] + else + if isPrompt + then do + decoded <- evalAgentPromptFromFile promptDhall + pure + [ case decoded of + Left err -> + DiscoveredRunnable + { drName = T.pack entry, + drDescription = Nothing, + drKind = KindPrompt, + drSource = src, + drDir = entryDir, + drIsError = True, + drError = Just (briefLoadError err) + } + Right p -> + DiscoveredRunnable + { drName = p.name.unModuleName, + drDescription = p.description, + drKind = KindPrompt, + drSource = src, + drDir = entryDir, + drIsError = False, + drError = Nothing + } + ] + else pure [] + + briefLoadError :: ModuleLoadError -> Text + briefLoadError (DhallEvalError _ _) = "Dhall evaluation failed" + briefLoadError (DhallDecodeError _ _) = "Dhall decode failed" + briefLoadError (ValidationError _ _) = "validation failed" + briefLoadError (ModuleNotFound _ _) = "not found" + briefLoadError (MissingSourceFile _ _) = "missing source file" + briefLoadError (CircularDependency _) = "circular dependency" + briefLoadError (RegistryEvalError _ _) = "registry eval failed" diff --git a/src/Seihou/Core/Path.hs b/src/Seihou/Core/Path.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Path.hs @@ -0,0 +1,29 @@ +module Seihou.Core.Path + ( validateProjectRelativePath, + ) +where + +import Data.Text qualified as T +import Seihou.Prelude +import System.FilePath qualified as FilePath +import System.FilePath.Windows qualified as WindowsPath + +-- | Validate that a path stays within a project root when later appended to it. +-- The path must be non-empty, relative on POSIX and Windows, and must not +-- contain a parent-directory segment. +validateProjectRelativePath :: Text -> Either Text FilePath +validateProjectRelativePath rawPath + | T.null path = Left "path must not be empty" + | FilePath.isAbsolute pathString || WindowsPath.isAbsolute pathString = + Left ("path must be relative: " <> path) + | any (== "..") (pathSegments path) = + Left ("path must not contain '..' segment: " <> path) + | otherwise = Right pathString + where + path = T.strip rawPath + pathString = T.unpack path + +pathSegments :: Text -> [Text] +pathSegments = + filter (not . T.null) + . T.split (\c -> c == '/' || c == '\\') diff --git a/src/Seihou/Core/Recipe.hs b/src/Seihou/Core/Recipe.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Recipe.hs @@ -0,0 +1,78 @@ +module Seihou.Core.Recipe + ( validateRecipe, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Seihou.Core.Module (isValidModuleName) +import Seihou.Core.Types + +-- | Validate a 'Recipe' against recipe-specific rules. +-- Returns 'Right' with the recipe if all rules pass, or 'Left' with a +-- list of all violations. +-- +-- Validation rules: +-- 1. Name matches @[a-z][a-z0-9-]*@ +-- 2. At least one module listed +-- 3. No duplicate module names in the list +-- 4. All variable binding names in module entries match @[a-z][a-z0-9.-]*@ +validateRecipe :: Recipe -> Either [Text] Recipe +validateRecipe recipe = + let errs = + checkRecipeNameFormat recipe + <> checkNonEmptyModules recipe + <> checkNoDuplicateModules recipe + <> checkVarBindingNames recipe + in if null errs + then Right recipe + else Left errs + +-- Rule 1: Recipe name must match [a-z][a-z0-9-]* +checkRecipeNameFormat :: Recipe -> [Text] +checkRecipeNameFormat recipe = + let n = recipe.name.unRecipeName + in if T.null n || not (isValidModuleName n) + then ["recipe name must match [a-z][a-z0-9-]*, got: " <> n] + else [] + +-- Rule 2: At least one module must be listed +checkNonEmptyModules :: Recipe -> [Text] +checkNonEmptyModules recipe + | null recipe.modules = ["recipe must list at least one module"] + | otherwise = [] + +-- Rule 3: No duplicate module names +checkNoDuplicateModules :: Recipe -> [Text] +checkNoDuplicateModules recipe = + let names = map (.depModule.unModuleName) recipe.modules + in map (\n -> "duplicate module in recipe: " <> n) (findDupes Set.empty Set.empty names) + +findDupes :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] +findDupes _ _ [] = [] +findDupes seen reported (x : xs) + | Set.member x seen && not (Set.member x reported) = x : findDupes seen (Set.insert x reported) xs + | otherwise = findDupes (Set.insert x seen) reported xs + +-- Rule 4: Variable binding names must match [a-z][a-z0-9.-]* +checkVarBindingNames :: Recipe -> [Text] +checkVarBindingNames recipe = + concatMap checkDep recipe.modules + where + checkDep dep = + concatMap + ( \(VarName vn) -> + if isValidVarBindingName vn + then [] + else ["invalid var binding name '" <> vn <> "' in module '" <> dep.depModule.unModuleName <> "'"] + ) + (Map.keys dep.depVars) + + isValidVarBindingName :: Text -> Bool + isValidVarBindingName t = case T.uncons t of + Nothing -> False + Just (c, rest) -> + (c >= 'a' && c <= 'z') + && T.all (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-' || ch == '.') rest diff --git a/src/Seihou/Core/Registry.hs b/src/Seihou/Core/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Registry.hs @@ -0,0 +1,538 @@ +module Seihou.Core.Registry + ( Registry (..), + RegistryEntry (..), + RepoContents (..), + discoverRepoContents, + validateRegistry, + renderRegistryDhall, + EntryKind (..), + SyncStatus (..), + SyncDiff (..), + SyncReport (..), + computeRegistrySync, + formatDriftWarning, + RegistryValidationIssue (..), + RegistryValidationReport (..), + reportHasIssues, + validateRegistryFull, + formatValidationIssue, + ) +where + +import Data.Text qualified as T +import GHC.Generics (Generic) +import Seihou.Core.Types (ModuleLoadError, ModuleName (..)) +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | A single module listing within a registry. +data RegistryEntry = RegistryEntry + { name :: ModuleName, + version :: Maybe Text, + path :: FilePath, + description :: Maybe Text, + tags :: [Text] + } + deriving stock (Eq, Show, Generic) + +-- | Registry metadata for a multi-module repository. +-- Declared in @seihou-registry.dhall@ at the repo root. +data Registry = Registry + { repoName :: Text, + repoDescription :: Maybe Text, + modules :: [RegistryEntry], + recipes :: [RegistryEntry], + blueprints :: [RegistryEntry], + prompts :: [RegistryEntry] + } + deriving stock (Eq, Show, Generic) + +-- | What a cloned repository contains. +data RepoContents + = -- | Repo root has @module.dhall@ (single module) + SingleModule FilePath + | -- | Repo root has @recipe.dhall@ (single recipe) + SingleRecipe FilePath + | -- | Repo root has @blueprint.dhall@ (single blueprint) + SingleBlueprint FilePath + | -- | Repo root has @prompt.dhall@ (single prompt) + SinglePrompt FilePath + | -- | Repo root has @seihou-registry.dhall@ + MultiModule Registry + | -- | Neither found + EmptyRepo + deriving stock (Show) + +-- | Examine a cloned repo root and determine what it contains. +-- The first argument is a function that evaluates a registry Dhall file, +-- injected to avoid a circular module dependency with @Seihou.Dhall.Eval@. +discoverRepoContents :: + (FilePath -> IO (Either ModuleLoadError Registry)) -> + FilePath -> + IO RepoContents +discoverRepoContents evalRegistry repoRoot = do + let registryFile = repoRoot "seihou-registry.dhall" + hasRegistry <- doesFileExist registryFile + if hasRegistry + then do + result <- evalRegistry registryFile + case result of + Right reg -> pure (MultiModule reg) + Left _ -> probeSingleArtifact repoRoot + else probeSingleArtifact repoRoot + +-- | Probe for a single-artifact repo at @repoRoot@. Precedence: +-- @module.dhall@ → @recipe.dhall@ → @blueprint.dhall@ → @prompt.dhall@ → 'EmptyRepo'. +-- A stray @module.dhall@ next to a @blueprint.dhall@ resolves as the +-- module: the more specific, deterministic artifact wins. +probeSingleArtifact :: FilePath -> IO RepoContents +probeSingleArtifact repoRoot = do + let moduleFile = repoRoot "module.dhall" + recipeFile = repoRoot "recipe.dhall" + blueprintFile = repoRoot "blueprint.dhall" + promptFile = repoRoot "prompt.dhall" + hasModule <- doesFileExist moduleFile + if hasModule + then pure (SingleModule repoRoot) + else do + hasRecipe <- doesFileExist recipeFile + if hasRecipe + then pure (SingleRecipe repoRoot) + else do + hasBlueprint <- doesFileExist blueprintFile + if hasBlueprint + then pure (SingleBlueprint repoRoot) + else do + hasPrompt <- doesFileExist promptFile + if hasPrompt + then pure (SinglePrompt repoRoot) + else pure EmptyRepo + +-- | Validate a registry's entries against the filesystem. +-- Returns a list of error messages (empty means valid). +-- Checks: module name format, path safety, entry file existence, +-- and no name collisions between modules, recipes, blueprints, and prompts. +validateRegistry :: FilePath -> Registry -> IO [Text] +validateRegistry repoRoot reg = do + modErrs <- concat <$> mapM (validateModuleEntry repoRoot) reg.modules + recErrs <- concat <$> mapM (validateRecipeEntry repoRoot) reg.recipes + bpErrs <- concat <$> mapM (validateBlueprintEntry repoRoot) reg.blueprints + promptErrs <- concat <$> mapM (validatePromptEntry repoRoot) reg.prompts + let collisionErrs = checkNameCollisions reg.modules reg.recipes reg.blueprints reg.prompts + pure (modErrs <> recErrs <> bpErrs <> promptErrs <> collisionErrs) + +validateModuleEntry :: FilePath -> RegistryEntry -> IO [Text] +validateModuleEntry repoRoot entry = do + let nameText = entry.name.unModuleName + nameErrors = checkName nameText + pathText = T.pack entry.path + pathErrors = checkPath pathText + let moduleDhall = repoRoot entry.path "module.dhall" + fileExists <- doesFileExist moduleDhall + let fileErrors = + if fileExists + then [] + else ["registry entry '" <> nameText <> "' points to missing module.dhall at " <> pathText] + pure (nameErrors <> pathErrors <> fileErrors) + where + checkName name + | validModuleName name = [] + | otherwise = ["registry entry name must match [a-z][a-z0-9-]*, got: " <> name] + + checkPath path + | T.isPrefixOf "/" path = ["registry entry path must be relative: " <> path] + | ".." `T.isInfixOf` path = ["registry entry path must not contain '..': " <> path] + | otherwise = [] + +validateRecipeEntry :: FilePath -> RegistryEntry -> IO [Text] +validateRecipeEntry repoRoot entry = do + let nameText = entry.name.unModuleName + nameErrors = checkRecipeName nameText + pathText = T.pack entry.path + pathErrors = checkRecipePath pathText + let recipeDhall = repoRoot entry.path "recipe.dhall" + fileExists <- doesFileExist recipeDhall + let fileErrors = + if fileExists + then [] + else ["registry recipe entry '" <> nameText <> "' points to missing recipe.dhall at " <> pathText] + pure (nameErrors <> pathErrors <> fileErrors) + where + checkRecipeName name + | validModuleName name = [] + | otherwise = ["registry recipe name must match [a-z][a-z0-9-]*, got: " <> name] + + checkRecipePath path + | T.isPrefixOf "/" path = ["registry recipe path must be relative: " <> path] + | ".." `T.isInfixOf` path = ["registry recipe path must not contain '..': " <> path] + | otherwise = [] + +validateBlueprintEntry :: FilePath -> RegistryEntry -> IO [Text] +validateBlueprintEntry repoRoot entry = do + let nameText = entry.name.unModuleName + nameErrors = checkBlueprintName nameText + pathText = T.pack entry.path + pathErrors = checkBlueprintPath pathText + let blueprintDhall = repoRoot entry.path "blueprint.dhall" + fileExists <- doesFileExist blueprintDhall + let fileErrors = + if fileExists + then [] + else ["registry blueprint entry '" <> nameText <> "' points to missing blueprint.dhall at " <> pathText] + pure (nameErrors <> pathErrors <> fileErrors) + where + checkBlueprintName name + | validModuleName name = [] + | otherwise = ["registry blueprint name must match [a-z][a-z0-9-]*, got: " <> name] + + checkBlueprintPath path + | T.isPrefixOf "/" path = ["registry blueprint path must be relative: " <> path] + | ".." `T.isInfixOf` path = ["registry blueprint path must not contain '..': " <> path] + | otherwise = [] + +validatePromptEntry :: FilePath -> RegistryEntry -> IO [Text] +validatePromptEntry repoRoot entry = do + let nameText = entry.name.unModuleName + nameErrors = checkPromptName nameText + pathText = T.pack entry.path + pathErrors = checkPromptPath pathText + let promptDhall = repoRoot entry.path "prompt.dhall" + fileExists <- doesFileExist promptDhall + let fileErrors = + if fileExists + then [] + else ["registry prompt entry '" <> nameText <> "' points to missing prompt.dhall at " <> pathText] + pure (nameErrors <> pathErrors <> fileErrors) + where + checkPromptName name + | validModuleName name = [] + | otherwise = ["registry prompt name must match [a-z][a-z0-9-]*, got: " <> name] + + checkPromptPath path + | T.isPrefixOf "/" path = ["registry prompt path must be relative: " <> path] + | ".." `T.isInfixOf` path = ["registry prompt path must not contain '..': " <> path] + | otherwise = [] + +-- | Detect name collisions across module, recipe, blueprint, and prompt entries. +-- Each cross-kind pair sharing a name produces one message; a name that +-- appears in all four kinds produces six messages (one per pair). +checkNameCollisions :: [RegistryEntry] -> [RegistryEntry] -> [RegistryEntry] -> [RegistryEntry] -> [Text] +checkNameCollisions mods recs bps prompts = + let modNames = map (\e -> e.name.unModuleName) mods + recNames = map (\e -> e.name.unModuleName) recs + bpNames = map (\e -> e.name.unModuleName) bps + promptNames = map (\e -> e.name.unModuleName) prompts + modRec = [n | n <- modNames, n `elem` recNames] + modBp = [n | n <- modNames, n `elem` bpNames] + modPrompt = [n | n <- modNames, n `elem` promptNames] + recBp = [n | n <- recNames, n `elem` bpNames] + recPrompt = [n | n <- recNames, n `elem` promptNames] + bpPrompt = [n | n <- bpNames, n `elem` promptNames] + in map (\n -> "name collision: '" <> n <> "' appears as both a module and a recipe") modRec + <> map (\n -> "name collision: '" <> n <> "' appears as both a module and a blueprint") modBp + <> map (\n -> "name collision: '" <> n <> "' appears as both a module and a prompt") modPrompt + <> map (\n -> "name collision: '" <> n <> "' appears as both a recipe and a blueprint") recBp + <> map (\n -> "name collision: '" <> n <> "' appears as both a recipe and a prompt") recPrompt + <> map (\n -> "name collision: '" <> n <> "' appears as both a blueprint and a prompt") bpPrompt + +-- | Check that a text matches @[a-z][a-z0-9-]*@. +-- Duplicated from @Seihou.Core.Module.isValidModuleName@ to avoid +-- a circular module dependency through @Seihou.Dhall.Eval@. +validModuleName :: Text -> Bool +validModuleName t = case T.uncons t of + Nothing -> False + Just (c, rest) -> + (c >= 'a' && c <= 'z') + && T.all (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-') rest + +-- | What a registry entry points at on disk. +data EntryKind = ModuleEntry | RecipeEntry | BlueprintEntry | PromptEntry + deriving stock (Eq, Show, Generic) + +-- | Classification of a single registry entry relative to the on-disk +-- @module.dhall@/@recipe.dhall@ version. +data SyncStatus + = -- | Registry @version@ is 'Nothing', on-disk version is @Just _@. + SyncMissing + | -- | Registry @version@ and on-disk version both @Just@ but differ; + -- carries the new on-disk version. + SyncStale Text + | -- | Registry and on-disk versions match (both 'Just' equal or both 'Nothing'). + SyncInSync + | -- | On-disk @module.dhall@/@recipe.dhall@ absent or unreadable. + SyncOrphan + deriving stock (Eq, Show, Generic) + +-- | One row of a sync diff, preserving registry order. +data SyncDiff = SyncDiff + { diffKind :: EntryKind, + diffName :: ModuleName, + diffOld :: Maybe Text, + diffNew :: Maybe Text, + diffStatus :: SyncStatus + } + deriving stock (Eq, Show, Generic) + +-- | Output of 'computeRegistrySync': the classifications in registry order, +-- and a 'Registry' with each entry's @version@ field updated to the on-disk +-- value (except 'SyncOrphan' entries, which are preserved as-is). +data SyncReport = SyncReport + { syncDiffs :: [SyncDiff], + syncUpdated :: Registry + } + deriving stock (Eq, Show, Generic) + +-- | Pure core of the version-sync flow. The caller resolves each entry's +-- on-disk version ('Just v', or 'Nothing' for orphaned/unreadable entries) +-- and passes them in; this function classifies and rewrites the registry +-- without performing any IO. +-- +-- The lookup list is keyed by @(kind, name)@; entries absent from the list +-- are classified as 'SyncOrphan'. +computeRegistrySync :: + Registry -> + [(EntryKind, ModuleName, Maybe Text)] -> + SyncReport +computeRegistrySync reg lookups = + SyncReport + { syncDiffs = moduleDiffs <> recipeDiffs <> blueprintDiffs <> promptDiffs, + syncUpdated = + reg + { modules = zipWith applyDiff moduleDiffs reg.modules, + recipes = zipWith applyDiff recipeDiffs reg.recipes, + blueprints = zipWith applyDiff blueprintDiffs reg.blueprints, + prompts = zipWith applyDiff promptDiffs reg.prompts + } + } + where + moduleDiffs = map (classify ModuleEntry) reg.modules + recipeDiffs = map (classify RecipeEntry) reg.recipes + blueprintDiffs = map (classify BlueprintEntry) reg.blueprints + promptDiffs = map (classify PromptEntry) reg.prompts + + classify :: EntryKind -> RegistryEntry -> SyncDiff + classify kind entry = + let onDisk = lookupOnDisk kind entry.name + status = case (entry.version, onDisk) of + (_, OnDiskMissing) -> SyncOrphan + (Nothing, OnDiskValue Nothing) -> SyncInSync + (Nothing, OnDiskValue (Just _)) -> SyncMissing + (Just _, OnDiskValue Nothing) -> SyncInSync + (Just old, OnDiskValue (Just new)) + | old == new -> SyncInSync + | otherwise -> SyncStale new + newVersion = case onDisk of + OnDiskMissing -> entry.version + OnDiskValue v -> v + in SyncDiff + { diffKind = kind, + diffName = entry.name, + diffOld = entry.version, + diffNew = newVersion, + diffStatus = status + } + + applyDiff :: SyncDiff -> RegistryEntry -> RegistryEntry + applyDiff diff entry = case diff.diffStatus of + SyncOrphan -> entry + _ -> entry {version = diff.diffNew} + + lookupOnDisk :: EntryKind -> ModuleName -> OnDiskVersion + lookupOnDisk kind name = + case [v | (k, n, v) <- lookups, k == kind, n == name] of + [] -> OnDiskMissing + (v : _) -> OnDiskValue v + +-- | Three-way state used internally by 'computeRegistrySync' to distinguish +-- \"entry absent from the lookup list\" (orphan) from \"entry present, version +-- field is @Nothing@\" (in-sync with an unversioned module.dhall). +data OnDiskVersion = OnDiskMissing | OnDiskValue (Maybe Text) + +-- | Format a single 'SyncDiff' as a human-readable drift warning, or +-- 'Nothing' if the entry is already in sync. Used by @seihou browse@ and +-- @seihou install@ to surface stale registry versions without blocking. +formatDriftWarning :: SyncDiff -> Maybe Text +formatDriftWarning diff = case diff.diffStatus of + SyncInSync -> Nothing + SyncOrphan -> Nothing + SyncMissing -> + Just $ + kindWord diff.diffKind + <> " '" + <> diff.diffName.unModuleName + <> "' registry version is missing; " + <> entryFile diff.diffKind + <> " declares " + <> renderVersion diff.diffNew + <> " — run `seihou registry sync-versions`" + SyncStale newVer -> + Just $ + kindWord diff.diffKind + <> " '" + <> diff.diffName.unModuleName + <> "' registry version " + <> renderVersion diff.diffOld + <> " differs from " + <> entryFile diff.diffKind + <> " version " + <> newVer + <> " — run `seihou registry sync-versions`" + where + renderVersion Nothing = "(none)" + renderVersion (Just v) = v + kindWord ModuleEntry = "module" + kindWord RecipeEntry = "recipe" + kindWord BlueprintEntry = "blueprint" + kindWord PromptEntry = "prompt" + entryFile ModuleEntry = "module.dhall" + entryFile RecipeEntry = "recipe.dhall" + entryFile BlueprintEntry = "blueprint.dhall" + entryFile PromptEntry = "prompt.dhall" + +-- | One row of the unified validation report. Either reuses an existing +-- structural error message (path/name/file-existence/collisions) or +-- carries a version-mismatch row classified by 'SyncStatus'. +data RegistryValidationIssue + = StructuralError Text + | VersionMismatch SyncDiff + deriving stock (Eq, Show, Generic) + +-- | Whole-registry validation outcome, carrying every issue plus the +-- entry counts used by the human-readable summary line. +data RegistryValidationReport = RegistryValidationReport + { reportIssues :: [RegistryValidationIssue], + reportModuleCount :: Int, + reportRecipeCount :: Int, + reportBlueprintCount :: Int, + reportPromptCount :: Int + } + deriving stock (Eq, Show, Generic) + +-- | True iff the report has at least one issue. +reportHasIssues :: RegistryValidationReport -> Bool +reportHasIssues r = not (null r.reportIssues) + +-- | Combine the existing structural checks with version classification. +-- The third argument is the same shape 'computeRegistrySync' takes — +-- the caller loads each entry's @module.dhall@/@recipe.dhall@ once and +-- passes a lookup list keyed by @(kind, name)@. +validateRegistryFull :: + FilePath -> + Registry -> + [(EntryKind, ModuleName, Maybe Text)] -> + IO RegistryValidationReport +validateRegistryFull repoRoot reg lookups = do + structuralErrs <- validateRegistry repoRoot reg + let report = computeRegistrySync reg lookups + versionIssues = + [ VersionMismatch d + | d <- report.syncDiffs, + isVersionDrift d.diffStatus + ] + pure + RegistryValidationReport + { reportIssues = map StructuralError structuralErrs <> versionIssues, + reportModuleCount = length reg.modules, + reportRecipeCount = length reg.recipes, + reportBlueprintCount = length reg.blueprints, + reportPromptCount = length reg.prompts + } + where + isVersionDrift SyncMissing = True + isVersionDrift (SyncStale _) = True + isVersionDrift _ = False + +-- | Render a single 'RegistryValidationIssue' as a one-line human-readable +-- string. 'VersionMismatch' rows reuse the @modules.foo@/@recipes.bar@ +-- prefix used by @sync-versions@ but omit the trailing +-- "run @seihou registry sync-versions@" suggestion — the validate handler +-- prints a single aggregated suggestion at the bottom. +formatValidationIssue :: RegistryValidationIssue -> Text +formatValidationIssue (StructuralError msg) = msg +formatValidationIssue (VersionMismatch diff) = + validationKindPrefix diff.diffKind + <> diff.diffName.unModuleName + <> ": registry version " + <> validationRenderVersion diff.diffOld + <> " does not match " + <> entryFile diff.diffKind + <> " version " + <> validationRenderVersion diff.diffNew + where + entryFile ModuleEntry = "module.dhall" + entryFile RecipeEntry = "recipe.dhall" + entryFile BlueprintEntry = "blueprint.dhall" + entryFile PromptEntry = "prompt.dhall" + +validationKindPrefix :: EntryKind -> Text +validationKindPrefix ModuleEntry = "modules." +validationKindPrefix RecipeEntry = "recipes." +validationKindPrefix BlueprintEntry = "blueprints." +validationKindPrefix PromptEntry = "prompts." + +validationRenderVersion :: Maybe Text -> Text +validationRenderVersion Nothing = "(none)" +validationRenderVersion (Just v) = v + +-- | Serialize a 'Registry' as a Dhall record literal compatible with +-- 'Seihou.Dhall.Eval.registryDecoder'. Rewrites lose hand-written comments +-- and formatting; see @docs/plans/12-sync-registry-versions.md@ for rationale. +renderRegistryDhall :: Registry -> Text +renderRegistryDhall reg = + T.unlines + [ "{ repoName = " <> renderString reg.repoName, + ", repoDescription = " <> renderOptionalText reg.repoDescription, + ", modules =", + renderEntryList reg.modules, + ", recipes =", + renderEntryList reg.recipes, + ", blueprints =", + renderEntryList reg.blueprints, + ", prompts =", + renderEntryList reg.prompts, + "}" + ] + +renderEntryList :: [RegistryEntry] -> Text +renderEntryList [] = + " [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }" +renderEntryList entries = + T.intercalate + "\n" + (zipWith renderEntry (True : repeat False) entries <> [" ]"]) + +renderEntry :: Bool -> RegistryEntry -> Text +renderEntry isFirst entry = + T.intercalate + "\n" + [ " " <> opener <> " { name = " <> renderString entry.name.unModuleName, + " , version = " <> renderOptionalText entry.version, + " , path = " <> renderString (T.pack entry.path), + " , description = " <> renderOptionalText entry.description, + " , tags = " <> renderTextList entry.tags, + " }" + ] + where + opener = if isFirst then "[" else "," + +renderOptionalText :: Maybe Text -> Text +renderOptionalText Nothing = "None Text" +renderOptionalText (Just v) = "Some " <> renderString v + +renderTextList :: [Text] -> Text +renderTextList [] = "[] : List Text" +renderTextList xs = "[ " <> T.intercalate ", " (map renderString xs) <> " ]" + +-- | Render a Dhall double-quoted string literal. +-- Escapes backslashes, double quotes, dollar signs (for interpolation), +-- and common control characters per the Dhall spec. +renderString :: Text -> Text +renderString t = "\"" <> T.concatMap escape t <> "\"" + where + escape '\\' = "\\\\" + escape '"' = "\\\"" + escape '$' = "\\$" + escape '\n' = "\\n" + escape '\r' = "\\r" + escape '\t' = "\\t" + escape c = T.singleton c diff --git a/src/Seihou/Core/Scaffold.hs b/src/Seihou/Core/Scaffold.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Scaffold.hs @@ -0,0 +1,200 @@ +module Seihou.Core.Scaffold + ( moduleDhall, + readmeTemplate, + blueprintDhall, + examplePromptMarkdown, + promptDhall, + exampleAgentPromptMarkdown, + ) +where + +import Data.Text qualified as T +import Seihou.Prelude + +-- | Generate the module.dhall content for a new module. +-- The output imports the schema via URL and uses record completion (::). +moduleDhall :: Text -> Text -> Text -> Text +moduleDhall name url hash = + T.unlines + [ "let S =", + " " <> url, + " " <> hash, + "", + "in S.Module::{", + " , name = \"" <> name <> "\"", + " , version = Some \"0.1.0\"", + " , description = Some \"A new seihou module\"", + " , vars =", + " [ S.VarDecl::{", + " , name = \"project.name\"", + " , type = \"text\"", + " , description = Some \"The name of the project\"", + " , required = True", + " }", + " ]", + " , prompts =", + " [ S.Prompt::{", + " , var = \"project.name\"", + " , text = \"What is your project name?\"", + " }", + " ]", + " , steps =", + " [ S.Step::{", + " , strategy = \"template\"", + " , src = \"README.md.tpl\"", + " , dest = \"README.md\"", + " }", + " ]", + " }" + ] + +-- | Generate the README.md.tpl template content. +readmeTemplate :: Text +readmeTemplate = "# {{project.name}}\n\nA project generated by seihou.\n" + +-- | Generate the blueprint.dhall content for a new blueprint. +-- The output imports the schema via URL and uses record completion (::). +-- The prompt body is kept in a sibling @prompt.md@ file so authors can +-- edit Markdown directly without escaping through Dhall's string literal +-- rules; the Dhall record imports it via @./prompt.md as Text@. +blueprintDhall :: Text -> Text -> Text -> Text +blueprintDhall name url hash = + T.unlines + [ "let S =", + " " <> url, + " " <> hash, + "", + "in S.Blueprint::{", + " , name = \"" <> name <> "\"", + " , version = Some \"0.1.0\"", + " , description = Some \"A new seihou blueprint\"", + " , prompt = ./prompt.md as Text", + " , vars =", + " [ S.VarDecl::{", + " , name = \"project.name\"", + " , type = \"text\"", + " , description = Some \"The name of the project\"", + " , required = True", + " }", + " ]", + " , prompts =", + " [ S.Prompt::{", + " , var = \"project.name\"", + " , text = \"What is your project name?\"", + " }", + " ]", + " , baseModules = [] : List S.Dependency.Type", + " , files = [] : List S.Blueprint.BlueprintFile.Type", + " , tags = [] : List Text", + " }" + ] + +-- | Example @prompt.md@ body emitted next to a freshly scaffolded +-- @blueprint.dhall@. The body opens with a @{{project.name}}@ +-- placeholder so authors can see prompt-time substitution working, then +-- describes the workflow the agent runner (EP-31) will follow at run +-- time. Authors are expected to edit this file freely; the Dhall record +-- imports it verbatim via @./prompt.md as Text@. +examplePromptMarkdown :: Text +examplePromptMarkdown = + T.unlines + [ "# {{project.name}}", + "", + "You are helping a user scaffold a new project from this blueprint.", + "", + "## What you have access to", + "", + "- The user's current working directory (where this blueprint is being", + " applied). Read, edit, and create files freely.", + "- The blueprint's `files/` directory, mounted read-only as reference", + " material. Copy or adapt snippets, examples, or partial templates", + " from there as needed.", + "- The full `seihou` and `git` toolsets. Use `seihou run`, `seihou", + " status`, and `seihou validate-module` to compose modules and check", + " state.", + "", + "## How to proceed", + "", + "1. Confirm with the user what they are trying to build. Ask clarifying", + " questions only when the answer would change a load-bearing decision.", + "2. Lay down the initial scaffolding. Prefer small, testable pieces over", + " one large drop.", + "3. Iterate with the user, making edits as the design takes shape.", + "4. Use Conventional Commits (`feat:`, `fix:`, `docs:`, …) when", + " committing.", + "5. Ask before destructive changes (deleting files, force-pushing,", + " rewriting history).", + "", + "Replace this body with the workflow that fits your blueprint. The", + "more specific the prompt, the more useful the agent's first pass." + ] + +-- | Generate the prompt.dhall content for a first-class agent prompt. +-- The prompt schema may be ahead of the public pinned schema import during +-- local development, so this scaffold emits a self-contained Dhall record +-- with explicit empty-list types. +promptDhall :: Text -> Text -> Text -> Text +promptDhall name _url _hash = + T.unlines + [ "let Prompt =", + " { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + "", + "let CommandVar =", + " { name : Text", + " , run : Text", + " , workDir : Optional Text", + " , when : Optional Text", + " , trim : Bool", + " , maxBytes : Optional Natural", + " }", + "", + "let PromptFile =", + " { src : Text, description : Optional Text }", + "", + "let PromptGuidance =", + " { title : Text, body : Text, when : Optional Text }", + "", + "let Launch =", + " { provider : Optional Text, mode : Optional Text, model : Optional Text }", + "", + "in { name = \"" <> name <> "\"", + " , version = Some \"0.1.0\"", + " , description = Some \"A reusable agent-session prompt\"", + " , prompt = ./prompt.md as Text", + " , vars =", + " [ { name = \"project.name\"", + " , type = \"text\"", + " , default = None Text", + " , description = Some \"The name of the project\"", + " , required = False", + " , validation = None Text", + " }", + " ]", + " , prompts = [] : List Prompt", + " , commandVars = [] : List CommandVar", + " , guidance =", + " [ { title = \"Repository workflow\"", + " , body = \"Inspect the project before editing, keep changes scoped, and run the smallest useful validation command.\"", + " , when = None Text", + " }", + " ]", + " , files = [] : List PromptFile", + " , allowedTools = None (List Text)", + " , tags = [] : List Text", + " , launch = None Launch", + " }" + ] + +-- | Example @prompt.md@ body emitted next to a freshly scaffolded +-- @prompt.dhall@. It includes one declared variable placeholder so +-- authors can verify prompt rendering through @seihou prompt run --debug@. +exampleAgentPromptMarkdown :: Text +exampleAgentPromptMarkdown = + T.unlines + [ "# {{project.name}}", + "", + "You are helping the user with a focused repository task.", + "", + "Ask before destructive changes such as deleting files, force-pushing,", + "or rewriting history." + ] diff --git a/src/Seihou/Core/SchemaUpgrade.hs b/src/Seihou/Core/SchemaUpgrade.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/SchemaUpgrade.hs @@ -0,0 +1,426 @@ +module Seihou.Core.SchemaUpgrade + ( UpgradeIssue (..), + UpgradeResult (..), + detectIssues, + upgradeModuleText, + issueMessage, + ) +where + +import Data.Char (isSpace) +import Data.Text qualified as T +import Seihou.Prelude + +-- | Describes a single schema issue found in a module.dhall file. +data UpgradeIssue + = -- | The module record is missing the @version@ field. + MissingVersion + | -- | A step record (at the given 0-based index) is missing the @patch@ field. + MissingStepPatch Int + | -- | The module record is missing the @commands@ field. + MissingCommands + | -- | A dependency is a bare text string rather than a record. + BareStringDep Text + | -- | The empty dependency list uses @List Text@ rather than the record type. + BareStringDepTypeAnnotation + | -- | The module is missing the @let S = \@ schema import. + MissingSchemaImport + | -- | The module record is missing the @migrations@ field. + MissingMigrations + deriving stock (Eq, Show) + +-- | Result of attempting to upgrade a module.dhall text. +data UpgradeResult + = -- | The module already conforms to the current schema. + AlreadyCurrent + | -- | The module was upgraded; contains the new text and issues that were fixed. + Upgraded Text [UpgradeIssue] + deriving stock (Eq, Show) + +-- | Human-readable description of an upgrade issue. +issueMessage :: UpgradeIssue -> Text +issueMessage MissingVersion = "missing field: version" +issueMessage (MissingStepPatch n) = "missing field: patch (in step " <> T.pack (show (n + 1)) <> ")" +issueMessage MissingCommands = "missing field: commands" +issueMessage (BareStringDep name) = "bare string dependency: " <> name +issueMessage BareStringDepTypeAnnotation = "dependency list uses List Text type annotation" +issueMessage MissingSchemaImport = "missing schema import (let S = ...)" +issueMessage MissingMigrations = "missing field: migrations" + +-- | Detect all schema issues in a module.dhall text without modifying it. +-- The schema URL is used to check whether the schema import is present. +detectIssues :: Text -> Text -> [UpgradeIssue] +detectIssues schemaUrl content = + let ls = T.lines content + in detectMissingVersion ls + <> detectMissingStepPatch ls + <> detectMissingCommands ls + <> detectBareStringDeps ls + <> detectDepTypeAnnotation ls + <> detectMissingSchemaImport schemaUrl ls + <> detectMissingMigrations ls + +-- | Upgrade a module.dhall text to the current canonical schema. +-- Returns 'AlreadyCurrent' if no changes are needed. +-- The schema URL and hash are used to inject the schema import if missing. +upgradeModuleText :: Text -> Text -> Text -> UpgradeResult +upgradeModuleText schemaUrl schemaHash content = + let issues = detectIssues schemaUrl content + in if null issues + then AlreadyCurrent + else + let upgraded = + content + & applyIf (MissingVersion `elem` issues) insertVersion + & applyIf (any isMissingPatch issues) (insertPatchFields issues) + & applyIf (MissingCommands `elem` issues) insertCommands + & applyIf (any isBareStringDepIssue issues) convertBareStringDeps + & applyIf (BareStringDepTypeAnnotation `elem` issues) convertDepTypeAnnotation + & applyIf (MissingSchemaImport `elem` issues) (injectSchemaImport schemaUrl schemaHash) + & applyIf (MissingMigrations `elem` issues) insertMigrations + in Upgraded upgraded issues + where + applyIf True f x = f x + applyIf False _ x = x + + isMissingPatch (MissingStepPatch _) = True + isMissingPatch _ = False + + isBareStringDepIssue (BareStringDep _) = True + isBareStringDepIssue _ = False + +-- --------------------------------------------------------------------------- +-- Detection +-- --------------------------------------------------------------------------- + +detectMissingVersion :: [Text] -> [UpgradeIssue] +detectMissingVersion ls + | any (matchesField "version") ls = [] + | otherwise = [MissingVersion] + +detectMissingCommands :: [Text] -> [UpgradeIssue] +detectMissingCommands ls + | any (matchesField "commands") ls = [] + | otherwise = [MissingCommands] + +detectMissingStepPatch :: [Text] -> [UpgradeIssue] +detectMissingStepPatch ls = + let blocks = extractStepBlocks ls + in [ MissingStepPatch i + | (i, block) <- zip [0 ..] blocks, + not (any (matchesField "patch") block) + ] + +detectBareStringDeps :: [Text] -> [UpgradeIssue] +detectBareStringDeps ls = + let depsValue = extractDepsValue ls + in map BareStringDep (extractBareStrings depsValue) + +detectDepTypeAnnotation :: [Text] -> [UpgradeIssue] +detectDepTypeAnnotation ls + | any (\l -> "List Text" `T.isInfixOf` l && matchesField "dependencies" l) ls = + [BareStringDepTypeAnnotation] + | otherwise = [] + +detectMissingSchemaImport :: Text -> [Text] -> [UpgradeIssue] +detectMissingSchemaImport schemaUrl ls + | any (\l -> "let S =" `T.isInfixOf` l || "let Schema =" `T.isInfixOf` l) ls, + any (T.isInfixOf "seihou-schema") ls = + [] + | -- Also accept if the schema URL itself appears (e.g. different binding name) + any (T.isInfixOf schemaUrl) ls = + [] + | otherwise = [MissingSchemaImport] + +detectMissingMigrations :: [Text] -> [UpgradeIssue] +detectMissingMigrations ls + | any (matchesField "migrations") ls = [] + | otherwise = [MissingMigrations] + +-- --------------------------------------------------------------------------- +-- Rewriting +-- --------------------------------------------------------------------------- + +-- | Insert @, version = None Text@ after the @{ name = ...@ line. +insertVersion :: Text -> Text +insertVersion = mapLines $ \line -> + if matchesFieldStart "name" line + then [line, ", version = None Text"] + else [line] + +-- | Insert @, patch = None Text@ into step records that are missing it. +insertPatchFields :: [UpgradeIssue] -> Text -> Text +insertPatchFields issues content = + let missingIndices = [i | MissingStepPatch i <- issues] + ls = T.lines content + in T.unlines (go ls 0 missingIndices False) + where + go [] _ _ _ = [] + go (l : rest) idx missing inStep + | not inStep && containsStepStart l = + l : go rest idx missing True + | inStep && isBlockEnd l = + if idx `elem` missing + then " , patch = None Text" : l : go rest (idx + 1) missing False + else l : go rest (idx + 1) missing False + | otherwise = l : go rest idx missing inStep + + isBlockEnd line = + let s = T.stripEnd line + stripped = T.stripStart line + in "}" `T.isSuffixOf` s + && not (containsStepStart stripped) + +-- | Insert @, commands = ...@ before @, dependencies =@. +insertCommands :: Text -> Text +insertCommands = mapLines $ \line -> + if matchesField "dependencies" line + then [", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", line] + else [line] + +-- | Convert bare string dependencies to record form. +convertBareStringDeps :: Text -> Text +convertBareStringDeps content = + let ls = T.lines content + (before, rest) = break (matchesField "dependencies") ls + in case rest of + [] -> content + _ -> + let (depsLines, after) = spanDepsRegion rest + converted = convertDepsLines depsLines + in T.unlines (before <> converted <> after) + +-- | Inject a schema import line and wrap the existing record in @S.Module::@. +-- Prepends @let S = \ \@ and replaces the opening @{@ with @in S.Module::{@. +injectSchemaImport :: Text -> Text -> Text -> Text +injectSchemaImport url hash content = + let header = + T.unlines + [ "let S =", + " " <> url, + " " <> hash, + "" + ] + ls = T.lines content + -- Find the first line that starts with '{' (the module record) + (before, recordLines) = break (T.isPrefixOf "{" . T.stripStart) ls + in case recordLines of + [] -> header <> content + (firstLine : rest) -> + let -- Replace the leading '{' with 'in S.Module::{' + stripped = T.stripStart firstLine + replaced = "in S.Module::" <> stripped + in header <> T.unlines (before <> (replaced : rest)) + +-- | Convert @[] : List Text@ to the record type annotation. +convertDepTypeAnnotation :: Text -> Text +convertDepTypeAnnotation = + T.replace + "[] : List Text" + "[] : List { module : Text, vars : List { name : Text, value : Text } }" + +-- | Insert @, migrations = [] : List S.Migration.Type@ before the closing +-- brace of the module record. Inserts after the @removal = ...@ line if +-- present (it always is on a current schema), otherwise before the closing +-- brace as a fallback. +insertMigrations :: Text -> Text +insertMigrations content = + let ls = T.lines content + -- For modules using the schema package, S.Migration.Type is the right + -- type. For legacy modules without the schema import we still emit the + -- same line — it will be a forward reference fixed up by adding the + -- schema import (MissingSchemaImport handler runs separately). + migrationsLine = " , migrations = [] : List S.Migration.Type" + legacyMigrationsLine = ", migrations = [] : List { from : Text, to : Text, ops : List < MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } > }" + hasSchemaImport = + any (\l -> "let S =" `T.isInfixOf` l || "let Schema =" `T.isInfixOf` l) ls + lineToInsert = if hasSchemaImport then migrationsLine else legacyMigrationsLine + in T.unlines (insertBeforeClose lineToInsert ls) + where + -- Insert the new line just before the line that closes the module + -- record. The closing line is the last line that is exactly @}@ or + -- @ }@ (the schema-completion-syntax close). We look for the last + -- such line so we insert into the outermost record, not nested ones. + insertBeforeClose newLine xs = + case findLastClosing xs of + Just idx -> + take idx xs ++ [newLine] ++ drop idx xs + Nothing -> xs ++ [newLine] + + findLastClosing :: [Text] -> Maybe Int + findLastClosing xs = + let indexed = zip [0 ..] xs + closes = [i | (i, l) <- indexed, isClosingBrace l] + in case closes of + [] -> Nothing + _ -> Just (last closes) + + isClosingBrace :: Text -> Bool + isClosingBrace l = + let s = T.strip l + in s == "}" || s == "} : T" + +-- --------------------------------------------------------------------------- +-- Text utilities +-- --------------------------------------------------------------------------- + +-- | Check if a line contains a field assignment like @, fieldName =@ or +-- @{ fieldName =@. +matchesField :: Text -> Text -> Bool +matchesField fieldName line = + let s = T.stripStart line + in (", " <> fieldName <> " =") `T.isPrefixOf` s + || (", " <> fieldName <> "=") `T.isPrefixOf` s + || ("{ " <> fieldName <> " =") `T.isPrefixOf` s + +-- | Like 'matchesField' but only for the first field in a record (using @{@). +matchesFieldStart :: Text -> Text -> Bool +matchesFieldStart fieldName line = + let s = T.stripStart line + in ("{ " <> fieldName <> " =") `T.isPrefixOf` s + +-- | Apply a per-line transformation and reassemble. +mapLines :: (Text -> [Text]) -> Text -> Text +mapLines f = T.unlines . concatMap f . T.lines + +-- | Check if a line contains @{ strategy =@ (possibly preceded by @[@ or @,@). +containsStepStart :: Text -> Bool +containsStepStart line = "{ strategy =" `T.isInfixOf` line || "{ strategy=" `T.isInfixOf` line + +-- | Extract step blocks from lines. A step block starts with a line containing +-- @{ strategy =@ and ends at the next line ending with @}@. +extractStepBlocks :: [Text] -> [[Text]] +extractStepBlocks [] = [] +extractStepBlocks (l : rest) + | containsStepStart l = + let (block, remaining) = spanBlock (l : rest) + in block : extractStepBlocks remaining + | otherwise = extractStepBlocks rest + where + spanBlock [] = ([], []) + spanBlock (x : xs) + | "}" `T.isSuffixOf` T.stripEnd x = ([x], xs) + | otherwise = + let (block, remaining) = spanBlock xs + in (x : block, remaining) + +-- | Extract the raw value portion of the dependencies field. +-- For @, dependencies = [ "foo", "bar" ]@ this returns @[ "foo", "bar" ]@. +-- For multi-line deps, concatenates all lines. +extractDepsValue :: [Text] -> Text +extractDepsValue ls = + let region = extractDepsRegion ls + in case region of + [] -> "" + (firstLine : rest) -> + -- Strip the field name prefix from the first line + let val = case T.breakOn "=" firstLine of + (_, after) + | T.null after -> firstLine + | otherwise -> T.drop 1 after -- drop the '=' + in T.unlines (val : rest) + +-- | Extract the lines in the dependencies region. +extractDepsRegion :: [Text] -> [Text] +extractDepsRegion ls = + let (_, rest) = break (matchesField "dependencies") ls + in case rest of + [] -> [] + _ -> fst (spanDepsRegion rest) + +-- | Split the deps region from the rest of the lines. +spanDepsRegion :: [Text] -> ([Text], [Text]) +spanDepsRegion [] = ([], []) +spanDepsRegion (l : rest) + -- Single-line: , dependencies = [ "foo" ] or , dependencies = [] : List Text + | matchesField "dependencies" l + && ("]" `T.isSuffixOf` T.stripEnd l || "List Text" `T.isSuffixOf` T.stripEnd l) = + ([l], rest) + | matchesField "dependencies" l = collectUntilClose [l] rest + | otherwise = ([], l : rest) + where + collectUntilClose acc [] = (reverse acc, []) + collectUntilClose acc (x : xs) + | "]" `T.isSuffixOf` T.stripEnd x = (reverse (x : acc), xs) + | otherwise = collectUntilClose (x : acc) xs + +-- | Extract bare string names from a deps value text. +-- Handles both single-line @[ "foo", "bar" ]@ and multi-line formats. +-- A bare string dep is a quoted string that is NOT preceded by @module =@ +-- (which would make it a record field value rather than a bare dep). +extractBareStrings :: Text -> [Text] +extractBareStrings t = + let pieces = T.splitOn "\"" t + in extractOddElements pieces + where + extractOddElements (context : name : rest) + -- Skip if the name contains '=' which would mean it's part of a record field value + | "=" `T.isInfixOf` name = extractOddElements rest + -- Skip if it looks like a type annotation (contains ':') + | ":" `T.isInfixOf` name = extractOddElements rest + | T.null name = extractOddElements rest + -- Skip if preceded by 'module =' — this is a record-form dependency value + | "module =" `T.isInfixOf` context = extractOddElements rest + | "module=" `T.isInfixOf` context = extractOddElements rest + | otherwise = name : extractOddElements rest + extractOddElements _ = [] + +-- | Convert dependency lines, handling both single-line and multi-line formats. +convertDepsLines :: [Text] -> [Text] +convertDepsLines [] = [] +convertDepsLines [singleLine] + -- Single-line deps: , dependencies = [ "foo", "bar" ] + | matchesField "dependencies" singleLine = + let indent = T.takeWhile isSpace singleLine + bareNames = extractBareStrings singleLine + in case bareNames of + [] -> [singleLine] -- no bare strings to convert, leave as-is + _ -> + let entries = + [ " { module = \"" <> name <> "\", vars = [] : List { name : Text, value : Text } }" + | name <- bareNames + ] + formatted = case entries of + [] -> [indent <> ", dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } }"] + [e] -> [indent <> ", dependencies = [ " <> T.stripStart e <> " ]"] + (first : mid) -> + let lastEntry = last mid + midEntries = init mid + in [indent <> ", dependencies ="] + <> [indent <> " [ " <> T.stripStart first] + <> [indent <> " , " <> T.stripStart e | e <- midEntries] + <> [indent <> " , " <> T.stripStart lastEntry] + <> [indent <> " ]"] + in formatted +convertDepsLines ls = + -- Multi-line: convert each line that contains a bare string + map convertMultiLineDepEntry ls + where + convertMultiLineDepEntry line + | hasBareString line = + let indent = T.takeWhile isSpace line + s = T.stripStart line + prefix + | "[ " `T.isPrefixOf` s = indent <> "[ " + | "[" `T.isPrefixOf` s = indent <> "[ " + | ", " `T.isPrefixOf` s = indent <> ", " + | otherwise = indent <> " " + name = extractSingleBareString line + trailingClose = if "]" `T.isSuffixOf` T.stripEnd line then " ]" else "" + in prefix <> "{ module = \"" <> name <> "\", vars = [] : List { name : Text, value : Text } }" <> trailingClose + | otherwise = line + + hasBareString line = + let s = T.strip line + cleaned = T.dropWhile (\c -> c == '[' || c == ',' || c == ' ') s + in case T.uncons (T.stripStart cleaned) of + Just ('"', _) -> not ("{" `T.isInfixOf` s) + _ -> False + + extractSingleBareString line = + let s = T.strip line + cleaned = T.filter (\c -> c /= '[' && c /= ']' && c /= ',') s + trimmed = T.strip cleaned + in case T.stripPrefix "\"" trimmed >>= T.stripSuffix "\"" of + Just name -> name + Nothing -> trimmed diff --git a/src/Seihou/Core/Status.hs b/src/Seihou/Core/Status.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Status.hs @@ -0,0 +1,41 @@ +module Seihou.Core.Status + ( computeTrackedFileStatuses, + ) +where + +import Data.List (sortOn) +import Data.Map.Strict qualified as Map +import Seihou.Core.Types +import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Prelude + +-- | Compare each file in the manifest against its current disk content. +-- Returns a sorted list of tracked files with their status: +-- 'TfsUnchanged' if the disk hash matches, 'TfsModified' if it differs, +-- 'TfsDeleted' if the file no longer exists on disk. +computeTrackedFileStatuses :: (Filesystem :> es) => Manifest -> Eff es [TrackedFile] +computeTrackedFileStatuses manifest = do + results <- mapM classifyFile (Map.toAscList manifest.files) + pure (sortOn (.path) results) + where + classifyFile :: (Filesystem :> es') => (FilePath, FileRecord) -> Eff es' TrackedFile + classifyFile (path, record) = do + exists <- doesFileExist path + status <- + if not exists + then pure TfsDeleted + else do + content <- readFileText path + let diskHash = hashContent content + pure + ( if diskHash == record.hash + then TfsUnchanged + else TfsModified + ) + pure + TrackedFile + { path = path, + moduleName = record.moduleName, + status = status + } diff --git a/src/Seihou/Core/Types.hs b/src/Seihou/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Types.hs @@ -0,0 +1,629 @@ +module Seihou.Core.Types + ( ModuleName (..), + VarName (..), + VarType (..), + VarValue (..), + Validation (..), + VarDecl (..), + VarExport (..), + Prompt (..), + Expr (..), + Strategy (..), + PatchOp (..), + Step (..), + Command (..), + Dependency (..), + simpleDep, + depModuleNames, + ParentVars (..), + emptyParentVars, + parentVarsFromDep, + RemovalAction (..), + RemovalStep (..), + Removal (..), + Module (..), + RecipeName (..), + Recipe (..), + BlueprintFile (..), + Blueprint (..), + CommandVar (..), + PromptGuidance (..), + AgentPromptLaunch (..), + AgentPrompt (..), + Runnable (..), + recipeNameToModuleName, + Operation (..), + ModuleLoadError (..), + Manifest (..), + AppliedModule (..), + AppliedRecipe (..), + AppliedBlueprint (..), + FileRecord (..), + SHA256 (..), + DiffResult (..), + PlannedFile (..), + ModifiedFile (..), + ConflictFile (..), + OrphanedFile (..), + ConflictResolution (..), + VarSource (..), + ResolvedVar (..), + VarError (..), + PlaceholderError (..), + CompositionWarning (..), + ConfigError (..), + ConfigScope (..), + LogLevel (..), + TrackedFileStatus (..), + TrackedFile (..), + ) +where + +import Data.Map.Strict (Map) +import Data.String (IsString) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import Seihou.Core.Migration (Migration) + +-- | A module identifier such as @"haskell-base"@. +newtype ModuleName = ModuleName {unModuleName :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString) + +-- | A variable identifier such as @"project.name"@. +newtype VarName = VarName {unVarName :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString) + +-- | The type of a variable declaration. +data VarType + = VTText + | VTBool + | VTInt + | VTList VarType + | VTChoice [Text] + deriving stock (Eq, Show, Generic) + +-- | A concrete variable value. +data VarValue + = VText Text + | VBool Bool + | VInt Int + | VList [VarValue] + deriving stock (Eq, Show, Generic) + +-- | Validation constraints on a variable. +data Validation + = ValPattern Text + | ValRange Int Int + | ValMinLength Int + | ValMaxLength Int + deriving stock (Eq, Show, Generic) + +-- | A variable declaration within a module. +data VarDecl = VarDecl + { name :: VarName, + type_ :: VarType, + default_ :: Maybe VarValue, + description :: Maybe Text, + required :: Bool, + validation :: Maybe Validation + } + deriving stock (Eq, Show, Generic) + +-- | A variable export for cross-module visibility. +data VarExport = VarExport + { var :: VarName, + alias :: Maybe VarName + } + deriving stock (Eq, Show, Generic) + +-- | An interactive prompt for a variable. +data Prompt = Prompt + { var :: VarName, + text :: Text, + condition :: Maybe Expr, + choices :: Maybe [Text] + } + deriving stock (Eq, Show, Generic) + +-- | Expression AST for conditional logic in @when@ clauses. +-- Expressions are stored as strings in Dhall (e.g., @"IsSet license && Eq license MIT"@) +-- and parsed into this AST by the expression parser in @Seihou.Core.Expr@. +data Expr + = ExprEq VarName VarValue + | ExprAnd Expr Expr + | ExprOr Expr Expr + | ExprNot Expr + | ExprIsSet VarName + | ExprLit Bool + deriving stock (Eq, Show, Generic) + +-- | The four generation strategies. +data Strategy + = Copy + | Template + | DhallText + | Structured + deriving stock (Eq, Show, Generic) + +-- | Patch operations for modifying existing files during composition. +-- A step with a 'PatchOp' contributes content to a file that another module +-- creates, rather than overwriting it. +data PatchOp + = AppendFile + | PrependFile + | AppendSection + | AppendLineIfAbsent + deriving stock (Eq, Show, Generic) + +-- | A generation step within a module. +data Step = Step + { strategy :: Strategy, + src :: FilePath, + dest :: Text, + condition :: Maybe Expr, + patch :: Maybe PatchOp + } + deriving stock (Eq, Show, Generic) + +-- | A shell command to run after file generation. +data Command = Command + { run :: Text, + workDir :: Maybe Text, + condition :: Maybe Expr + } + deriving stock (Eq, Show, Generic) + +-- | A dependency on another module, optionally supplying variable bindings. +-- When @depVars@ is non-empty, the listed variables are pre-supplied to the +-- dependency during resolution, sitting between global config and module +-- defaults in the precedence chain. +data Dependency = Dependency + { depModule :: ModuleName, + depVars :: Map VarName Text + } + deriving stock (Eq, Show, Generic) + +-- | Create a bare dependency with no variable bindings. +simpleDep :: ModuleName -> Dependency +simpleDep name = Dependency {depModule = name, depVars = mempty} + +-- | Extract module names from a list of dependencies. +depModuleNames :: [Dependency] -> [ModuleName] +depModuleNames = map (.depModule) + +-- | The variable bindings supplied by a dependent module along a specific +-- dependency edge. This is the "edge decoration" — the identity of a +-- 'ModuleInstance' is determined by the @depVars@ the parent supplied, +-- not by anything resolved downstream. +-- +-- The underlying 'Data.Map.Strict' @Ord@ instance gives structural equality: +-- two 'ParentVars' values are equal iff they contain the same name/value +-- pairs regardless of construction order. +newtype ParentVars = ParentVars {unParentVars :: Map VarName Text} + deriving stock (Eq, Ord, Show, Generic) + +-- | The identity used when a module is invoked with no parent-supplied +-- bindings (the CLI primary module, recipe-expanded additionals, or any +-- dependency declared with @vars = []@). +emptyParentVars :: ParentVars +emptyParentVars = ParentVars mempty + +-- | Build 'ParentVars' from a 'Dependency' record's @depVars@ field. +parentVarsFromDep :: Dependency -> ParentVars +parentVarsFromDep dep = ParentVars dep.depVars + +-- | The type of removal action for a removal step. +data RemovalAction + = -- | Delete the file entirely. + RemoveFileAction + | -- | Strip this module's section markers from the file. + RemoveSectionAction + | -- | Apply a Dhall text function to transform the file. + RewriteFileAction + deriving stock (Eq, Show, Generic) + +-- | A single removal step describing how to reverse one effect of a module. +data RemovalStep = RemovalStep + { action :: RemovalAction, + dest :: Text, + src :: Maybe FilePath + } + deriving stock (Eq, Show, Generic) + +-- | Removal specification for a module. +data Removal = Removal + { removalSteps :: [RemovalStep], + removalCommands :: [Command] + } + deriving stock (Eq, Show, Generic) + +-- | A module definition: the fundamental unit of composition. +data Module = Module + { name :: ModuleName, + version :: Maybe Text, + description :: Maybe Text, + vars :: [VarDecl], + exports :: [VarExport], + prompts :: [Prompt], + steps :: [Step], + commands :: [Command], + dependencies :: [Dependency], + removal :: Maybe Removal, + migrations :: [Migration] + } + deriving stock (Eq, Show, Generic) + +-- | A recipe identifier such as @"haskell-library"@. +-- Shares the same @[a-z][a-z0-9-]*@ namespace as 'ModuleName'. +newtype RecipeName = RecipeName {unRecipeName :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString) + +-- | A recipe: a named, reusable composition of modules with optional +-- pre-configured variable bindings. +data Recipe = Recipe + { name :: RecipeName, + version :: Maybe Text, + description :: Maybe Text, + modules :: [Dependency], + vars :: [VarDecl], + prompts :: [Prompt] + } + deriving stock (Eq, Show, Generic) + +-- | A reference to a file in a blueprint's @files/@ subdirectory. +-- The runner mounts the blueprint's @files/@ directory into the +-- agent's filesystem; @description@ is shown to the agent so it can +-- pick the right reference for the user's request. +data BlueprintFile = BlueprintFile + { src :: FilePath, + description :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +-- | A blueprint: an agent-driven runnable artifact bundling a base +-- prompt, optional baseline modules, and reference files. Blueprints +-- are not directly executable — running @seihou run@ on a blueprint +-- name refuses with an actionable message; the agent runner +-- @seihou agent run@ (EP-31) consumes them instead. +data Blueprint = Blueprint + { name :: ModuleName, + version :: Maybe Text, + description :: Maybe Text, + prompt :: Text, + vars :: [VarDecl], + prompts :: [Prompt], + baseModules :: [Dependency], + files :: [BlueprintFile], + allowedTools :: Maybe [Text], + tags :: [Text] + } + deriving stock (Eq, Show, Generic) + +-- | A prompt variable whose value is produced by running a local command. +-- Process execution is implemented outside the core Dhall decoder; this +-- record only captures the author-declared command and safety metadata. +data CommandVar = CommandVar + { name :: VarName, + run :: Text, + workDir :: Maybe Text, + condition :: Maybe Expr, + trim :: Bool, + maxBytes :: Maybe Natural + } + deriving stock (Eq, Show, Generic) + +-- | A Markdown instruction block attached to an agent prompt. The optional +-- condition is evaluated after normal and command-derived variables resolve. +data PromptGuidance = PromptGuidance + { title :: Text, + body :: Text, + condition :: Maybe Expr + } + deriving stock (Eq, Show, Generic) + +-- | Optional launch metadata declared by an agent prompt. The CLI runner may +-- use this as a default provider/model/mode hint, but project or CLI config +-- remains authoritative. +data AgentPromptLaunch = AgentPromptLaunch + { provider :: Maybe Text, + mode :: Maybe Text, + model :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +-- | A reusable agent-session prompt. Unlike 'Blueprint', an 'AgentPrompt' +-- does not declare baseline modules and does not imply scaffolding or +-- manifest provenance. +data AgentPrompt = AgentPrompt + { name :: ModuleName, + version :: Maybe Text, + description :: Maybe Text, + prompt :: Text, + vars :: [VarDecl], + prompts :: [Prompt], + commandVars :: [CommandVar], + guidance :: [PromptGuidance], + files :: [BlueprintFile], + allowedTools :: Maybe [Text], + tags :: [Text], + launch :: Maybe AgentPromptLaunch + } + deriving stock (Eq, Show, Generic) + +-- | The result of name-based discovery: a module, recipe, blueprint, or prompt. +data Runnable + = RunnableModule Module FilePath + | RunnableRecipe Recipe FilePath + | RunnableBlueprint Blueprint FilePath + | RunnableAgentPrompt AgentPrompt FilePath + deriving stock (Show) + +-- | Convert a 'RecipeName' to a 'ModuleName' (they share a namespace). +recipeNameToModuleName :: RecipeName -> ModuleName +recipeNameToModuleName (RecipeName t) = ModuleName t + +-- | Filesystem operations produced by the generation engine. +data Operation + = WriteFileOp + { dest :: FilePath, + content :: Text, + strategy :: Strategy + } + | CreateDirOp + { path :: FilePath + } + | CopyFileOp + { src :: FilePath, + dest :: FilePath + } + | RunCommandOp + { command :: Text, + workDir :: Maybe FilePath + } + | PatchFileOp + { dest :: FilePath, + content :: Text, + op :: PatchOp, + strategy :: Strategy, + moduleName :: ModuleName + } + deriving stock (Eq, Show, Generic) + +-- | Errors that can occur during module loading and validation. +data ModuleLoadError + = ModuleNotFound ModuleName [FilePath] + | DhallEvalError ModuleName Text + | DhallDecodeError ModuleName Text + | ValidationError ModuleName [Text] + | CircularDependency [ModuleName] + | MissingSourceFile ModuleName FilePath + | RegistryEvalError Text Text + deriving stock (Eq, Show, Generic) + +-- | Tracks where a variable's value came from (for provenance / @--explain@). +data VarSource + = FromCLI + | FromEnv Text + | FromLocalConfig + | FromNamespaceConfig Text + | FromContextConfig Text + | FromGlobalConfig + | FromParent ModuleName + | FromDefault + | FromPrompt + | FromCommand Text + deriving stock (Eq, Show, Generic) + +-- | A variable that has been resolved to a concrete value with provenance. +data ResolvedVar = ResolvedVar + { value :: VarValue, + source :: VarSource, + decl :: VarDecl + } + deriving stock (Eq, Show, Generic) + +-- | Errors that can occur during variable resolution. +data VarError + = MissingRequiredVar VarName + | TypeMismatch VarName VarType VarValue + | ValidationFailed VarName Text + | CoercionFailed VarName VarType Text + deriving stock (Eq, Show, Generic) + +-- | Errors that can occur during template placeholder substitution +-- and conditional-block expansion. +data PlaceholderError + = UnresolvedPlaceholder VarName Int + | MalformedPlaceholder Text Int + | -- | @{{#if …}}@ with no matching @{{/if}}@; line is the opener. + UnterminatedIf Int + | -- | @{{/if}}@ or @{{#else}}@ encountered outside any @{{#if}}@. + OrphanBlockToken Text Int + | -- | The expression inside a @{{#if …}}@ failed to parse; + -- fields are the raw expression, the opener's line, and the parser error. + MalformedIfExpression Text Int Text + deriving stock (Eq, Show, Generic) + +-- | Tracks the state of generated files for incremental re-generation +-- and conflict detection. Stored at @.seihou/manifest.json@. +data Manifest = Manifest + { version :: Int, + genAt :: UTCTime, + modules :: [AppliedModule], + vars :: Map VarName Text, + files :: Map FilePath FileRecord, + recipe :: Maybe AppliedRecipe, + blueprint :: Maybe AppliedBlueprint + } + deriving stock (Eq, Show, Generic) + +-- | Recipe provenance recorded in the manifest when a recipe is used. +data AppliedRecipe = AppliedRecipe + { name :: RecipeName, + recipeVersion :: Maybe Text, + appliedAt :: UTCTime + } + deriving stock (Eq, Show, Generic) + +-- | Blueprint provenance recorded in the manifest after a successful +-- @seihou agent run@ invocation. The agent owns file output, so this +-- entry describes the *invocation* (which blueprint, which baseline, the +-- user's prompt) — not the file set the agent produced. +-- +-- @baselineModules@ records the modules the runner applied as the +-- baseline. @noBaseline@ distinguishes "no baseline declared" +-- (@baselineModules = []@, @noBaseline = False@) from "baseline skipped +-- by user" (@baselineModules = []@, @noBaseline = True@). +-- @userPrompt@ captures the positional @PROMPT@ argument when supplied. +-- @agentSessionId@ is reserved for the deferred resume feature recorded +-- in @docs/masterplans/3-agent-driven-blueprints.md@; in v1 it is always +-- 'Nothing' and the encoder omits the JSON key in that case. +data AppliedBlueprint = AppliedBlueprint + { name :: ModuleName, + blueprintVersion :: Maybe Text, + appliedAt :: UTCTime, + baselineModules :: [ModuleName], + noBaseline :: Bool, + userPrompt :: Maybe Text, + agentSessionId :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +-- | A module that has been applied to generate files. +-- +-- The @parentVars@ field disambiguates multiple invocations of the same +-- module within a single composition: two 'AppliedModule' entries with +-- the same @name@ and different @parentVars@ represent two legitimate +-- instances. Manifests produced before schema version 2 decode with +-- @parentVars = 'emptyParentVars'@. +data AppliedModule = AppliedModule + { name :: ModuleName, + parentVars :: ParentVars, + source :: FilePath, + moduleVersion :: Maybe Text, + appliedAt :: UTCTime, + removal :: Maybe Removal + } + deriving stock (Eq, Show, Generic) + +-- | A record of a generated file, stored in the manifest. +data FileRecord = FileRecord + { hash :: SHA256, + moduleName :: ModuleName, + strategy :: Strategy, + generatedAt :: UTCTime + } + deriving stock (Eq, Show, Generic) + +-- | A SHA256 content hash, stored as a hex-encoded text string. +newtype SHA256 = SHA256 {unSHA256 :: Text} + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString) + +-- | Result of the three-state diff: manifest vs plan vs disk. +data DiffResult = DiffResult + { new :: [PlannedFile], + modified :: [ModifiedFile], + unchanged :: [FilePath], + conflicts :: [ConflictFile], + orphaned :: [OrphanedFile] + } + deriving stock (Eq, Show, Generic) + +-- | A file that exists in the plan but not in the manifest or on disk. +data PlannedFile = PlannedFile + { path :: FilePath, + moduleName :: ModuleName, + content :: Text + } + deriving stock (Eq, Show, Generic) + +-- | A file that has changed between the manifest and the plan, +-- but the user has not modified the disk copy. +data ModifiedFile = ModifiedFile + { path :: FilePath, + moduleName :: ModuleName, + oldHash :: SHA256, + newContent :: Text + } + deriving stock (Eq, Show, Generic) + +-- | A file where the user has modified the disk copy since it was generated. +data ConflictFile = ConflictFile + { path :: FilePath, + moduleName :: ModuleName, + manifestHash :: SHA256, + diskHash :: SHA256, + planContent :: Text + } + deriving stock (Eq, Show, Generic) + +-- | A file that exists in the manifest but not in the current plan +-- (the module that generated it was removed or no longer produces it). +data OrphanedFile = OrphanedFile + { path :: FilePath, + moduleName :: ModuleName + } + deriving stock (Eq, Show, Generic) + +-- | How to resolve a conflict when a user has modified a generated file. +data ConflictResolution + = AcceptNew + | KeepCurrent + | Skip + | Abort + deriving stock (Eq, Show, Generic) + +-- | Errors that can occur when reading config files. +data ConfigError + = ConfigParseError FilePath Text + | InvalidNamespace Text Text + deriving stock (Eq, Show, Generic) + +-- | Controls the verbosity of diagnostic output. +-- 'LogQuiet' shows only errors, 'LogNormal' shows warnings and errors, +-- 'LogVerbose' shows all messages including info and debug. +-- The derived 'Ord' instance gives @LogQuiet < LogNormal < LogVerbose@, +-- which the Logger interpreters use for filtering. +data LogLevel = LogQuiet | LogNormal | LogVerbose + deriving stock (Eq, Ord, Show, Generic) + +-- | Which config scope to read from or write to. +data ConfigScope + = ScopeLocal + | ScopeNamespace Text + | ScopeContext Text + | ScopeGlobal + deriving stock (Eq, Show, Generic) + +-- | Warnings emitted during multi-module composition. +-- 'FileOverwritten' records that a file produced by one module was +-- overwritten by a later module in execution order (last-writer-wins). +data CompositionWarning + = FileOverwritten FilePath ModuleName ModuleName + | ContentMerged FilePath ModuleName ModuleName + deriving stock (Eq, Show, Generic) + +-- | Status of a tracked file relative to its manifest hash. +-- Used by 'seihou status' to classify files by comparing manifest vs disk. +data TrackedFileStatus + = -- | Disk hash matches manifest hash + TfsUnchanged + | -- | Disk hash differs from manifest hash + TfsModified + | -- | File not present on disk + TfsDeleted + deriving stock (Eq, Show, Generic) + +-- | A tracked file with its path, originating module, and disk status. +data TrackedFile = TrackedFile + { path :: FilePath, + moduleName :: ModuleName, + status :: TrackedFileStatus + } + deriving stock (Eq, Show, Generic) diff --git a/src/Seihou/Core/Variable.hs b/src/Seihou/Core/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Variable.hs @@ -0,0 +1,342 @@ +module Seihou.Core.Variable + ( resolveVariables, + coerceValue, + coerceDefault, + validateVarValue, + formatExplain, + formatDeclarations, + envVarName, + diagnoseResolution, + ) +where + +import Data.Char (toUpper) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Prelude + +-- | Derive the environment variable name for a given variable. +-- @VarName "project.name"@ becomes @"SEIHOU_VAR_PROJECT_NAME"@. +envVarName :: VarName -> Text +envVarName (VarName name) = + "SEIHOU_VAR_" <> T.map (\c -> if c == '.' then '_' else toUpper c) name + +-- | Attempt to coerce a text value to the declared variable type. +coerceValue :: VarName -> VarType -> Text -> Either VarError VarValue +coerceValue name VTText t = Right (VText t) +coerceValue name VTBool t = + case T.toLower (T.strip t) of + "true" -> Right (VBool True) + "yes" -> Right (VBool True) + "1" -> Right (VBool True) + "false" -> Right (VBool False) + "no" -> Right (VBool False) + "0" -> Right (VBool False) + _ -> Left (CoercionFailed name VTBool t) +coerceValue name VTInt t = + case reads (T.unpack (T.strip t)) of + [(n, "")] -> Right (VInt n) + _ -> Left (CoercionFailed name VTInt t) +coerceValue name (VTList VTText) t = + Right (VList (map (VText . T.strip) (T.splitOn "," t))) +coerceValue name (VTList elemTy) t = + Left (CoercionFailed name (VTList elemTy) t) +coerceValue name (VTChoice options) t + | T.strip t `elem` options = Right (VText (T.strip t)) + | otherwise = Left (CoercionFailed name (VTChoice options) t) + +-- | Coerce a module *default* value to its declared type. +-- +-- Defaults are decoded from Dhall as raw 'VText'; this routes them through the +-- same 'coerceValue' contract as every other resolution source so a defaulted +-- variable reaches evaluation with the correct runtime type (e.g. a @bool@ +-- default of @"true"@ becomes 'VBool' 'True', not 'VText' @"true"@). +-- +-- A value that is already typed (e.g. a default synthesized during +-- composition) passes through unchanged. An unconstrained choice +-- (@VTChoice []@ — the only form the Dhall decoder currently produces, since +-- options are not yet carried in the type string) keeps its text value, as +-- there are no options to validate membership against. +coerceDefault :: VarName -> VarType -> VarValue -> Either VarError VarValue +coerceDefault _ (VTChoice []) (VText raw) = Right (VText raw) +coerceDefault name ty (VText raw) = coerceValue name ty raw +coerceDefault _ _ v = Right v + +-- | Validate a resolved value against its declaration's validation constraint. +validateVarValue :: VarDecl -> VarValue -> Either VarError () +validateVarValue decl val = + case decl.validation of + Nothing -> Right () + Just v -> checkValidation decl.name v val + +checkValidation :: VarName -> Validation -> VarValue -> Either VarError () +checkValidation name (ValPattern pat) (VText t) = + if simplePatternMatch pat t + then Right () + else Left (ValidationFailed name ("value does not match pattern: " <> pat)) +checkValidation name (ValPattern _) _ = + Left (ValidationFailed name "pattern validation requires a text value") +checkValidation name (ValRange lo hi) (VInt n) + | n >= lo && n <= hi = Right () + | otherwise = + Left + ( ValidationFailed + name + ( "value " + <> T.pack (show n) + <> " is not in range [" + <> T.pack (show lo) + <> ", " + <> T.pack (show hi) + <> "]" + ) + ) +checkValidation name (ValRange _ _) _ = + Left (ValidationFailed name "range validation requires an integer value") +checkValidation name (ValMinLength n) (VText t) + | T.length t >= n = Right () + | otherwise = + Left + ( ValidationFailed + name + ("value must be at least " <> T.pack (show n) <> " characters") + ) +checkValidation name (ValMinLength _) _ = + Left (ValidationFailed name "min-length validation requires a text value") +checkValidation name (ValMaxLength n) (VText t) + | T.length t <= n = Right () + | otherwise = + Left + ( ValidationFailed + name + ("value must be at most " <> T.pack (show n) <> " characters") + ) +checkValidation name (ValMaxLength _) _ = + Left (ValidationFailed name "max-length validation requires a text value") + +-- | Simple pattern matching for variable validation. +-- For M2, this checks whether the text matches the character class pattern +-- @[a-z][a-z0-9-]*@ style patterns. A full regex library can be added later. +simplePatternMatch :: Text -> Text -> Bool +simplePatternMatch pat t + | pat == "[a-z][a-z0-9-]*" = + case T.uncons t of + Just (c, rest) -> + isLowerAlpha c && T.all (\x -> isLowerAlpha x || isDigit x || x == '-') rest + Nothing -> False + | otherwise = True -- unknown patterns pass by default + where + isLowerAlpha c = c >= 'a' && c <= 'z' + isDigit c = c >= '0' && c <= '9' + +-- | Resolve all variables for a module given CLI overrides, environment variables, +-- four config file layers, and parent-supplied variable bindings. +-- +-- Precedence chain (highest to lowest): +-- 1. CLI overrides (@--var@ flags) +-- 2. Environment variables (@SEIHOU_VAR_@ prefix) +-- 3. Local project config (@.seihou\/config.dhall@) +-- 4. Namespace config (@~\/.config\/seihou\/namespaces\/\\/config.dhall@) +-- 5. Context config (@~\/.config\/seihou\/contexts\/\\/config.dhall@) +-- 6. Global config (@~\/.config\/seihou\/config.dhall@) +-- 7. Parent-supplied vars (from parameterized dependencies) +-- 8. Module defaults +resolveVariables :: + [VarDecl] -> + Map VarName Text -> -- CLI overrides + Map Text Text -> -- Environment variables + Text -> -- Namespace name (used in provenance tagging) + Text -> -- Context name (used in provenance tagging) + Map VarName Text -> -- Local config + Map VarName Text -> -- Namespace config + Map VarName Text -> -- Context config + Map VarName Text -> -- Global config + Map VarName (Text, ModuleName) -> -- Parent-supplied vars + Either [VarError] (Map VarName ResolvedVar) +resolveVariables decls cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig parentVars = + case partitionResults (map resolveOne decls) of + ([], resolved) -> Right (Map.fromList (catMaybes resolved)) + (errs, _) -> Left errs + where + resolveOne :: VarDecl -> Either VarError (Maybe (VarName, ResolvedVar)) + resolveOne decl = + let name = decl.name + ty = decl.type_ + in case lookupCLI name ty of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupEnv name ty of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupConfig name ty localConfig FromLocalConfig of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupConfig name ty nsConfig (FromNamespaceConfig namespace) of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupConfig name ty ctxConfig (FromContextConfig context) of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupConfig name ty globalConfig FromGlobalConfig of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupParent name ty of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case decl.default_ of + Just defVal -> + case coerceDefault name ty defVal of + Left err -> Left err + Right val -> fmap Just (validateAndWrap decl (val, FromDefault)) + Nothing + | decl.required -> Left (MissingRequiredVar name) + | otherwise -> Right Nothing + + lookupParent :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource)) + lookupParent name ty = + case Map.lookup name parentVars of + Nothing -> Nothing + Just (rawText, parentName) -> + Just $ case coerceValue name ty rawText of + Left err -> Left err + Right val -> Right (val, FromParent parentName) + + lookupCLI :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource)) + lookupCLI name ty = + case Map.lookup name cliOverrides of + Nothing -> Nothing + Just rawText -> + Just $ case coerceValue name ty rawText of + Left err -> Left err + Right val -> Right (val, FromCLI) + + lookupEnv :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource)) + lookupEnv name ty = + let envKey = envVarName name + in case Map.lookup envKey envVars of + Nothing -> Nothing + Just rawText -> + Just $ case coerceValue name ty rawText of + Left err -> Left err + Right val -> Right (val, FromEnv envKey) + + lookupConfig :: VarName -> VarType -> Map VarName Text -> VarSource -> Maybe (Either VarError (VarValue, VarSource)) + lookupConfig name ty configMap source = + case Map.lookup name configMap of + Nothing -> Nothing + Just rawText -> + Just $ case coerceValue name ty rawText of + Left err -> Left err + Right val -> Right (val, source) + + validateAndWrap :: VarDecl -> (VarValue, VarSource) -> Either VarError (VarName, ResolvedVar) + validateAndWrap decl (val, source) = + case validateVarValue decl val of + Left err -> Left err + Right () -> + Right + ( decl.name, + ResolvedVar + { value = val, + source = source, + decl = decl + } + ) + +-- | Partition a list of Either into errors and successes. +partitionResults :: [Either e a] -> ([e], [a]) +partitionResults = foldr go ([], []) + where + go (Left e) (errs, oks) = (e : errs, oks) + go (Right a) (errs, oks) = (errs, a : oks) + +-- | Format a human-readable provenance report for @--explain@ output. +-- Uses bracket notation for sources and column-aligned output with 2-space indent. +formatExplain :: Map VarName ResolvedVar -> Text +formatExplain resolved = + T.unlines (map formatOne entries) + where + entries = Map.toAscList resolved + + -- Calculate column widths for alignment + maxNameLen = maximum (0 : map (\(VarName n, _) -> T.length n) entries) + maxValueLen = maximum (0 : map (\(_, rv) -> T.length (showValue rv.value)) entries) + + formatOne :: (VarName, ResolvedVar) -> Text + formatOne (VarName n, rv) = + let valText = showValue rv.value + namePad = T.replicate (maxNameLen - T.length n) " " + valPad = T.replicate (maxValueLen - T.length valText) " " + in " " <> n <> namePad <> " = " <> valText <> valPad <> " " <> showSource rv.source + + showValue :: VarValue -> Text + showValue (VText t) = "\"" <> t <> "\"" + showValue (VBool True) = "true" + showValue (VBool False) = "false" + showValue (VInt n) = T.pack (show n) + showValue (VList vs) = "[" <> T.intercalate ", " (map showValue vs) <> "]" + + showSource :: VarSource -> Text + showSource FromCLI = "[--var]" + showSource (FromEnv envKey) = "[env " <> envKey <> "]" + showSource FromLocalConfig = "[local config]" + showSource (FromNamespaceConfig ns) = "[namespace: " <> ns <> "]" + showSource (FromContextConfig ctx) = "[context: " <> ctx <> "]" + showSource FromGlobalConfig = "[global config]" + showSource (FromParent mn) = "[parent: " <> mn.unModuleName <> "]" + showSource FromDefault = "[default]" + showSource FromPrompt = "[prompt]" + showSource (FromCommand cmd) = "[command: " <> cmd <> "]" + +-- | Format variable declarations for default mode output. +-- Produces aligned output with @=@ signs and 2-space indent. +formatDeclarations :: [VarDecl] -> Text +formatDeclarations decls = + T.unlines (map formatOne decls) + where + maxNameLen = maximum (0 : map (\d -> T.length d.name.unVarName) decls) + + formatOne :: VarDecl -> Text + formatOne d = + let VarName n = d.name + namePad = T.replicate (maxNameLen - T.length n) " " + valText = case d.default_ of + Nothing + | d.required -> "(required, no default)" + | otherwise -> "(optional, no default)" + Just v -> showDeclValue v + in " " <> n <> namePad <> " = " <> valText + + showDeclValue :: VarValue -> Text + showDeclValue (VText t) = "\"" <> t <> "\"" + showDeclValue (VBool True) = "true" + showDeclValue (VBool False) = "false" + showDeclValue (VInt n) = T.pack (show n) + showDeclValue (VList vs) = "[" <> T.intercalate ", " (map showDeclValue vs) <> "]" + +-- | Diagnose mismatches between config values and variable declarations. +-- +-- Returns two lists: +-- 1. Unused config keys: keys present in any config layer that don't match +-- any declared variable name across the composition. +-- 2. Unresolved optional variables: declared non-required variables that +-- have no resolved value. +diagnoseResolution :: + Map VarName ResolvedVar -> + [VarDecl] -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + ([VarName], [VarName]) +diagnoseResolution resolved decls localConfig nsConfig ctxConfig globalConfig = + (unusedConfigKeys, unresolvedOptional) + where + declaredNames = Set.fromList (map (.name) decls) + allConfigKeys = + Set.fromList $ + Map.keys localConfig ++ Map.keys nsConfig ++ Map.keys ctxConfig ++ Map.keys globalConfig + unusedConfigKeys = + Set.toAscList (allConfigKeys `Set.difference` declaredNames) + unresolvedOptional = + [ d.name + | d <- decls, + not d.required, + not (Map.member d.name resolved) + ] diff --git a/src/Seihou/Core/Version.hs b/src/Seihou/Core/Version.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Core/Version.hs @@ -0,0 +1,50 @@ +module Seihou.Core.Version + ( Version (..), + parseVersion, + renderVersion, + ) +where + +import Data.Text qualified as T +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import Seihou.Prelude + +-- | A parsed version consisting of numeric segments (e.g. @[1, 2, 3]@ for "1.2.3"). +newtype Version = Version {segments :: [Natural]} + deriving stock (Show, Generic) + +instance Eq Version where + Version a == Version b = + let maxLen = max (length a) (length b) + in pad maxLen a == pad maxLen b + +instance Ord Version where + compare (Version a) (Version b) = + let maxLen = max (length a) (length b) + in compare (pad maxLen a) (pad maxLen b) + +-- | Pad a list of naturals with trailing zeros to the given length. +pad :: Int -> [Natural] -> [Natural] +pad n xs = xs ++ replicate (n - length xs) 0 + +-- | Parse a dotted version string like @"1.2.3"@ into a 'Version'. +-- Returns 'Nothing' for empty strings or strings with non-numeric segments. +parseVersion :: Text -> Maybe Version +parseVersion t + | T.null t = Nothing + | otherwise = + let parts = T.splitOn "." t + in case traverse readNatural parts of + Just ns@(_ : _) -> Just (Version ns) + _ -> Nothing + +-- | Try to read a 'Natural' from a 'Text' value. +readNatural :: Text -> Maybe Natural +readNatural t = case reads (T.unpack t) of + [(n, "")] | (n :: Integer) >= 0 -> Just (fromIntegral n) + _ -> Nothing + +-- | Render a 'Version' back to dotted notation. +renderVersion :: Version -> Text +renderVersion (Version ns) = T.intercalate "." (map (T.pack . show) ns) diff --git a/src/Seihou/Dhall/Config.hs b/src/Seihou/Dhall/Config.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Dhall/Config.hs @@ -0,0 +1,99 @@ +module Seihou.Dhall.Config + ( evalConfigFile, + evalConfigFileIfExists, + serializeConfig, + escapeDhallText, + ) +where + +import Control.Exception (SomeException, try) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Dhall (input, strictText) +import Dhall.Marshal.Decode (Decoder, field, list, record) +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Evaluate a Dhall config file to a @Map Text Text@. +-- +-- Config files are plain Dhall records of text values, e.g.: +-- +-- > { license = "MIT", `project.name` = "my-app" } +-- +-- This function reads the file, wraps the content with @toMap@ to convert +-- the record to a list of key-value entries, then decodes via the Dhall +-- library. +evalConfigFile :: FilePath -> IO (Map Text Text) +evalConfigFile path = do + content <- TIO.readFile path + let stripped = stripDhallComments content + if isEmptyConfig stripped + then pure Map.empty + else input configMapDecoder ("toMap (" <> content <> ")") + +-- | Check whether a stripped Dhall config expression is empty. +isEmptyConfig :: Text -> Bool +isEmptyConfig s = s `elem` ["{=}", "{ = }"] || T.null s + +-- | Strip single-line Dhall comments (lines starting with @--@) and +-- whitespace, leaving only the meaningful Dhall expression. +stripDhallComments :: Text -> Text +stripDhallComments = + T.strip . T.unlines . filter (not . isComment) . T.lines + where + isComment line' = "--" `T.isPrefixOf` T.stripStart line' + +-- | Like 'evalConfigFile', but returns an empty map if the file does not exist. +-- Dhall parse/evaluation errors still propagate as 'Left'. +evalConfigFileIfExists :: FilePath -> IO (Either Text (Map Text Text)) +evalConfigFileIfExists path = do + exists <- doesFileExist path + if exists + then first formatError <$> try (evalConfigFile path) + else pure (Right Map.empty) + where + formatError :: SomeException -> Text + formatError e = "Error reading config " <> T.pack path <> ": " <> T.pack (show e) + +-- | Serialize a @Map Text Text@ to valid Dhall source text. +-- +-- Produces a multi-line record with backtick-escaped keys and Dhall text +-- literal values, using trailing-comma style: +-- +-- > { `key1` = "value1" +-- > , `key2` = "value2" +-- > } +-- +-- An empty map produces @{=}@. Keys are sorted alphabetically for +-- deterministic output. +serializeConfig :: Map Text Text -> Text +serializeConfig m + | Map.null m = "{=}\n" + | otherwise = + let entries = Map.toAscList m + firstLine (k, v) = "{ `" <> k <> "` = \"" <> escapeDhallText v <> "\"" + restLine (k, v) = ", `" <> k <> "` = \"" <> escapeDhallText v <> "\"" + body = case entries of + [] -> "" + (e : es) -> T.unlines (firstLine e : map restLine es <> ["}"]) + in body + +-- | Escape special characters inside a Dhall text literal. +-- +-- Dhall text literals use double-quotes. Backslash and double-quote +-- must be escaped with a preceding backslash. +escapeDhallText :: Text -> Text +escapeDhallText = T.concatMap escapeChar + where + escapeChar '\\' = "\\\\" + escapeChar '"' = "\\\"" + escapeChar c = T.singleton c + +-- | Decoder for a list of @{ mapKey : Text, mapValue : Text }@ entries, +-- which is what @toMap { k = "v" }@ produces. +configMapDecoder :: Decoder (Map Text Text) +configMapDecoder = fmap Map.fromList (list entryDecoder) + where + entryDecoder :: Decoder (Text, Text) + entryDecoder = record ((,) <$> field "mapKey" strictText <*> field "mapValue" strictText) diff --git a/src/Seihou/Dhall/Eval.hs b/src/Seihou/Dhall/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Dhall/Eval.hs @@ -0,0 +1,762 @@ +module Seihou.Dhall.Eval + ( evalDhallExpr, + evalModuleFromFile, + evalRecipeFromFile, + evalBlueprintFromFile, + evalAgentPromptFromFile, + evalRegistryFromFile, + moduleDecoder, + recipeDecoder, + blueprintDecoder, + agentPromptDecoder, + commandVarDecoder, + promptGuidanceDecoder, + agentPromptLaunchDecoder, + blueprintFileDecoder, + registryDecoder, + registryEntryDecoder, + varTypeDecoder, + varDeclDecoder, + varExportDecoder, + promptDecoder, + stepDecoder, + commandDecoder, + strategyDecoder, + patchOpDecoder, + dependencyDecoder, + removalDecoder, + removalStepDecoder, + removalActionDecoder, + migrationDecoder, + migrationOpDecoder, + ) +where + +import Control.Exception (SomeException, evaluate, throwIO, try) +import Data.Either.Validation (Validation (..)) +import Data.List (foldl') +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Void (Void) +import Dhall (defaultInputSettings, input, inputExprWithSettings, inputFile, list, record, rootDirectory, sourceName, strictText) +import Dhall.Core (Chunks (..), makeRecordField) +import Dhall.Core qualified as Dhall (Expr (..)) +import Dhall.Map qualified as DhallMap +import Dhall.Marshal.Decode (Decoder (..), Extractor, bool, constructor, field, maybe, natural, string, union) +import Dhall.Src (Src) +import Seihou.Core.Expr (parseExpr) +import Seihou.Core.Migration (Migration (..), MigrationOp (..)) +import Seihou.Core.Registry (Registry (..), RegistryEntry (..)) +import Seihou.Core.Types +import Seihou.Core.Variable (coerceDefault) +import Seihou.Prelude +import System.FilePath (takeDirectory) +import Prelude hiding (maybe) + +-- | Spike: evaluate a Dhall expression containing a record with @name@ and @version@ +-- fields. Returns them as a 'Map'. +evalDhallExpr :: Text -> IO (Map Text Text) +evalDhallExpr expr = do + (name, version) <- input simpleRecordDecoder expr + pure (Map.fromList [("name", name), ("version", version)]) + +simpleRecordDecoder :: Decoder (Text, Text) +simpleRecordDecoder = + record + ( (,) + <$> field "name" strictText + <*> field "version" strictText + ) + +-- | Evaluate a @module.dhall@ file and decode it into a 'Module' value. +-- Returns 'Left' with a 'ModuleLoadError' if evaluation or decoding fails. +-- +-- Uses 'inputExprWithSettings' to parse, resolve imports, and normalize the +-- Dhall expression, then extracts with 'moduleDecoder' directly. This +-- bypasses Dhall's type-annotation check, allowing the @dependencies@ field +-- to be either @List Text@ (bare strings) or +-- @List { module : Text, vars : ... }@ (parameterized form) — the custom +-- 'dependencyDecoder' handles both at the AST level. +-- +-- Note: Dhall 'Decoder' only supports 'Functor', so decoder helpers like +-- 'parseVarType' use 'error' for invalid input. These 'error' calls produce +-- lazy thunks inside the decoded 'Module'. We force evaluation of all +-- potentially-failing fields inside the 'try' block so that exceptions +-- are caught here rather than propagating as uncaught crashes later. +evalModuleFromFile :: FilePath -> IO (Either ModuleLoadError Module) +evalModuleFromFile path = do + result <- try $ do + text <- TIO.readFile path + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract moduleDecoder expr of + Success m -> do + -- Force lazy decoder thunks that may contain 'error' calls + mapM_ (\v -> evaluate v.type_) m.vars + mapM_ (\s -> evaluate s.strategy >> evaluate s.condition >> mapM_ evaluate s.patch) m.steps + mapM_ (\c -> mapM_ evaluate c.condition) m.commands + mapM_ (\p -> evaluate p.condition) m.prompts + pure m + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> + let name = guessModuleName path + in pure $ Left (DhallEvalError name (T.pack (show e))) + Right m -> pure (Right m) + +-- | Evaluate a @recipe.dhall@ file and decode it into a 'Recipe' value. +-- Returns 'Left' with a 'ModuleLoadError' if evaluation or decoding fails. +-- +-- Follows the same pattern as 'evalModuleFromFile': uses +-- 'inputExprWithSettings' to parse and normalize, then extracts with +-- 'recipeDecoder'. The recipe's @modules@ field reuses 'dependencyDecoder'. +evalRecipeFromFile :: FilePath -> IO (Either ModuleLoadError Recipe) +evalRecipeFromFile path = do + result <- try $ do + text <- TIO.readFile path + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract recipeDecoder expr of + Success r -> do + -- Force lazy decoder thunks that may contain 'error' calls + mapM_ (\v -> evaluate v.type_) r.vars + mapM_ (\p -> evaluate p.condition) r.prompts + pure r + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> + let name = guessModuleName path + in pure $ Left (DhallEvalError name (T.pack (show e))) + Right r -> pure (Right r) + +-- | Guess a module name from its file path by taking the parent directory name. +guessModuleName :: FilePath -> ModuleName +guessModuleName path = + let parts = T.splitOn "/" (T.pack path) + in case parts of + [] -> ModuleName "" + [_] -> ModuleName "" + _ -> + let parentDir = parts !! (length parts - 2) + in ModuleName parentDir + +-- | Wrap a decoder to inject default values for missing record fields. +-- For each @(key, defaultExpr)@, if the key is absent from a 'RecordLit', +-- it is added with the given Dhall expression before extraction. +-- This allows decoders to handle schema evolution gracefully. +withDefaults :: [(Text, Dhall.Expr Src Void)] -> Decoder a -> Decoder a +withDefaults defaults (Decoder ext exp_) = Decoder ext' exp_ + where + ext' expr@(Dhall.RecordLit fields) = + let fields' = foldl' addDefault fields defaults + in ext (Dhall.RecordLit fields') + ext' expr = ext expr + + addDefault fs (k, v) = + case DhallMap.lookup k fs of + Just _ -> fs + Nothing -> DhallMap.insert k (makeRecordField v) fs + +-- | A Dhall expression representing @None Text@. +-- Used as a placeholder default for missing @Optional@-typed fields. +noneText :: Dhall.Expr Src Void +noneText = Dhall.App Dhall.None Dhall.Text + +-- | Decoder for the top-level Module type from Dhall. +-- Uses 'withDefaults' to handle modules that predate the @removal@ and +-- @migrations@ fields. +moduleDecoder :: Decoder Module +moduleDecoder = + withDefaults + [ ("removal", noneText), + ("migrations", emptyMigrationList) + ] + $ record + ( Module + <$> field "name" moduleNameDecoder + <*> field "version" (maybe strictText) + <*> field "description" (maybe strictText) + <*> field "vars" (list varDeclDecoder) + <*> field "exports" (list varExportDecoder) + <*> field "prompts" (list promptDecoder) + <*> field "steps" (list stepDecoder) + <*> field "commands" (list commandDecoder) + <*> field "dependencies" (list dependencyDecoder) + <*> field "removal" (maybe removalDecoder) + <*> field "migrations" (list migrationDecoder) + ) + +-- | A Dhall expression representing an empty list of Migration records. +-- The list element type annotation is unused by the list extractor (which +-- ignores the annotation and reads element values), so we use a placeholder +-- type to keep the synthesized expression compact. +emptyMigrationList :: Dhall.Expr Src Void +emptyMigrationList = Dhall.ListLit (Just Dhall.Text) mempty + +-- | Decoder for a single 'Migration' record. +migrationDecoder :: Decoder Migration +migrationDecoder = + record + ( Migration + <$> field "from" strictText + <*> field "to" strictText + <*> field "ops" (list migrationOpDecoder) + ) + +-- | Decoder for a 'MigrationOp' from a Dhall union value. +-- The union variants must match @schema/MigrationOp.dhall@. +migrationOpDecoder :: Decoder MigrationOp +migrationOpDecoder = + union + ( (mkMoveFile <$> constructor "MoveFile" srcDestRecord) + <> (mkMoveDir <$> constructor "MoveDir" srcDestRecord) + <> (mkDeleteFile <$> constructor "DeleteFile" pathRecord) + <> (mkDeleteDir <$> constructor "DeleteDir" pathRecord) + <> (mkRunCommand <$> constructor "RunCommand" runCommandRecord) + ) + where + srcDestRecord :: Decoder (FilePath, FilePath) + srcDestRecord = + record ((,) <$> field "src" string <*> field "dest" string) + + pathRecord :: Decoder FilePath + pathRecord = record (field "path" string) + + runCommandRecord :: Decoder (Text, Maybe FilePath) + runCommandRecord = + record ((,) <$> field "run" strictText <*> field "workDir" (maybe string)) + + mkMoveFile (s, d) = MoveFile {src = s, dest = d} + mkMoveDir (s, d) = MoveDir {src = s, dest = d} + mkDeleteFile p = DeleteFile {path = p} + mkDeleteDir p = DeleteDir {path = p} + mkRunCommand (r, wd) = RunCommand {run = r, workDir = wd} + +-- | Decoder for the top-level Recipe type from Dhall. +recipeDecoder :: Decoder Recipe +recipeDecoder = + record + ( Recipe + <$> field "name" recipeNameDecoder + <*> field "version" (maybe strictText) + <*> field "description" (maybe strictText) + <*> field "modules" (list dependencyDecoder) + <*> field "vars" (list varDeclDecoder) + <*> field "prompts" (list promptDecoder) + ) + +recipeNameDecoder :: Decoder RecipeName +recipeNameDecoder = RecipeName <$> strictText + +-- | Decoder for a 'BlueprintFile' record. The @src@ is a path relative +-- to the blueprint's @files/@ directory; the optional @description@ is +-- shown to the agent so it can pick the right reference. +blueprintFileDecoder :: Decoder BlueprintFile +blueprintFileDecoder = + record + ( BlueprintFile + <$> field "src" string + <*> field "description" (maybe strictText) + ) + +-- | Decoder for the top-level Blueprint type from Dhall. +blueprintDecoder :: Decoder Blueprint +blueprintDecoder = + record + ( Blueprint + <$> field "name" moduleNameDecoder + <*> field "version" (maybe strictText) + <*> field "description" (maybe strictText) + <*> field "prompt" strictText + <*> field "vars" (list varDeclDecoder) + <*> field "prompts" (list promptDecoder) + <*> field "baseModules" (list dependencyDecoder) + <*> field "files" (list blueprintFileDecoder) + <*> field "allowedTools" (maybe (list strictText)) + <*> field "tags" (list strictText) + ) + +-- | Evaluate a @blueprint.dhall@ file and decode it into a 'Blueprint'. +-- Returns 'Left' with a 'ModuleLoadError' if evaluation or decoding fails. +-- +-- Follows the same pattern as 'evalModuleFromFile' / 'evalRecipeFromFile': +-- uses 'inputExprWithSettings' to parse and normalize, then extracts with +-- 'blueprintDecoder' and forces lazy decoder thunks so 'error' calls in +-- the inner decoders are caught here rather than escaping later. +evalBlueprintFromFile :: FilePath -> IO (Either ModuleLoadError Blueprint) +evalBlueprintFromFile path = do + result <- try $ do + text <- TIO.readFile path + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract blueprintDecoder expr of + Success b -> do + mapM_ (\v -> evaluate v.type_) b.vars + mapM_ (\p -> evaluate p.condition) b.prompts + pure b + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> + let nm = guessModuleName path + in pure $ Left (DhallEvalError nm (T.pack (show e))) + Right b -> pure (Right b) + +-- | Decoder for a 'CommandVar' record. +commandVarDecoder :: Decoder CommandVar +commandVarDecoder = + record + ( mkCommandVar + <$> field "name" varNameDecoder + <*> field "run" strictText + <*> field "workDir" (maybe strictText) + <*> field "when" (maybe strictText) + <*> field "trim" bool + <*> field "maxBytes" (maybe natural) + ) + where + mkCommandVar name run workDir whenText trim maxBytes = + CommandVar + { name = name, + run = run, + workDir = workDir, + condition = parseWhen whenText, + trim = trim, + maxBytes = maxBytes + } + +-- | Decoder for optional agent prompt launch metadata. +agentPromptLaunchDecoder :: Decoder AgentPromptLaunch +agentPromptLaunchDecoder = + record + ( AgentPromptLaunch + <$> field "provider" (maybe strictText) + <*> field "mode" (maybe strictText) + <*> field "model" (maybe strictText) + ) + +-- | Decoder for a prompt guidance block. +promptGuidanceDecoder :: Decoder PromptGuidance +promptGuidanceDecoder = + record + ( mkPromptGuidance + <$> field "title" strictText + <*> field "body" strictText + <*> field "when" (maybe strictText) + ) + where + mkPromptGuidance title body whenText = + PromptGuidance + { title = title, + body = body, + condition = parseWhen whenText + } + +-- | Decoder for the top-level AgentPrompt type from Dhall. +agentPromptDecoder :: Decoder AgentPrompt +agentPromptDecoder = + withDefaults [("guidance", emptyPromptGuidanceList)] $ + record + ( AgentPrompt + <$> field "name" moduleNameDecoder + <*> field "version" (maybe strictText) + <*> field "description" (maybe strictText) + <*> field "prompt" strictText + <*> field "vars" (list varDeclDecoder) + <*> field "prompts" (list promptDecoder) + <*> field "commandVars" (list commandVarDecoder) + <*> field "guidance" (list promptGuidanceDecoder) + <*> field "files" (list blueprintFileDecoder) + <*> field "allowedTools" (maybe (list strictText)) + <*> field "tags" (list strictText) + <*> field "launch" (maybe agentPromptLaunchDecoder) + ) + +emptyPromptGuidanceList :: Dhall.Expr Src Void +emptyPromptGuidanceList = Dhall.ListLit (Just Dhall.Text) mempty + +-- | Evaluate a @prompt.dhall@ file and decode it into an 'AgentPrompt'. +evalAgentPromptFromFile :: FilePath -> IO (Either ModuleLoadError AgentPrompt) +evalAgentPromptFromFile path = do + result <- try $ do + text <- TIO.readFile path + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract agentPromptDecoder expr of + Success p -> do + mapM_ (\v -> evaluate v.type_) p.vars + mapM_ (\prompt -> evaluate prompt.condition) p.prompts + mapM_ (\cv -> evaluate cv.condition) p.commandVars + mapM_ (\g -> evaluate g.condition) p.guidance + pure p + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> + let nm = guessModuleName path + in pure $ Left (DhallEvalError nm (T.pack (show e))) + Right p -> pure (Right p) + +-- | Decoder for Removal from a Dhall record. +removalDecoder :: Decoder Removal +removalDecoder = + record + ( Removal + <$> field "steps" (list removalStepDecoder) + <*> field "commands" (list commandDecoder) + ) + +-- | Decoder for RemovalStep from a Dhall record. +removalStepDecoder :: Decoder RemovalStep +removalStepDecoder = + record + ( RemovalStep + <$> field "action" removalActionDecoder + <*> field "dest" strictText + <*> field "src" (maybe string) + ) + +-- | Decoder for RemovalAction from a Dhall Text string. +-- +-- See 'varTypeDecoder' note re: 'error' safety. +removalActionDecoder :: Decoder RemovalAction +removalActionDecoder = parseRemovalAction <$> strictText + where + parseRemovalAction :: Text -> RemovalAction + parseRemovalAction t = case t of + "remove-file" -> RemoveFileAction + "remove-section" -> RemoveSectionAction + "rewrite-file" -> RewriteFileAction + -- Caught by 'try' in 'evalModuleFromFile' + other -> error ("Unknown removal action \"" <> T.unpack other <> "\"; expected one of: remove-file, remove-section, rewrite-file") + +moduleNameDecoder :: Decoder ModuleName +moduleNameDecoder = ModuleName <$> strictText + +-- | Decoder for a dependency entry. +-- Accepts two Dhall forms for backward compatibility: +-- +-- 1. A bare text string: @"base"@ decodes as @Dependency "base" mempty@. +-- 2. A record: @{ module = "base", vars = [ { name = "x", value = "y" } ] }@ +-- decodes as @Dependency "base" (fromList [("x", "y")])@. +-- +-- This is implemented as a custom decoder that pattern-matches on the Dhall +-- expression AST: 'TextLit' for bare strings, falling back to the record +-- decoder for the parameterized form. +dependencyDecoder :: Decoder Dependency +dependencyDecoder = Decoder extractDep expectedDep + where + extractDep :: Dhall.Expr Src Void -> Extractor Src Void Dependency + extractDep (Dhall.TextLit (Chunks [] t)) = + pure (simpleDep (ModuleName t)) + extractDep expr = + extract paramDepDecoder expr + + expectedDep = expected strictText + + paramDepDecoder :: Decoder Dependency + paramDepDecoder = + record + ( mkDep + <$> field "module" moduleNameDecoder + <*> field "vars" (list varBindingDecoder) + ) + + varBindingDecoder :: Decoder (VarName, Text) + varBindingDecoder = + record + ( (,) + <$> field "name" varNameDecoder + <*> field "value" strictText + ) + + mkDep :: ModuleName -> [(VarName, Text)] -> Dependency + mkDep name bindings = Dependency {depModule = name, depVars = Map.fromList bindings} + +-- | Decoder for VarType from a Dhall Text string. +-- Dhall does not support recursive types, so VarType is represented as a +-- string: @"text"@, @"bool"@, @"int"@, @"list text"@, @"list bool"@, +-- @"list int"@, @"choice"@. +-- +-- Note: 'Decoder' only has a 'Functor' instance (no 'Monad'/'MonadFail'), so +-- we cannot use @fail@ for error reporting. The 'error' call throws an +-- 'ErrorCall' exception that is caught by @try@ in 'evalModuleFromFile' and +-- wrapped as @Left (DhallEvalError ...)@. +varTypeDecoder :: Decoder VarType +varTypeDecoder = parseVarType <$> strictText + where + parseVarType :: Text -> VarType + parseVarType t = case T.toLower t of + "text" -> VTText + "bool" -> VTBool + "int" -> VTInt + "choice" -> VTChoice [] + other + | "list " `T.isPrefixOf` other -> + VTList (parseVarType (T.drop 5 other)) + | otherwise -> + -- Caught by 'try' in 'evalModuleFromFile' + error ("Unknown var type \"" <> T.unpack other <> "\"; expected one of: text, bool, int, choice, list ") + +-- | Decoder for Strategy from a Dhall Text string. +-- +-- See 'varTypeDecoder' note re: 'error' safety. +strategyDecoder :: Decoder Strategy +strategyDecoder = parseStrategy <$> strictText + where + parseStrategy :: Text -> Strategy + parseStrategy t = case t of + "copy" -> Copy + "template" -> Template + "dhall-text" -> DhallText + "structured" -> Structured + -- Caught by 'try' in 'evalModuleFromFile' + other -> error ("Unknown strategy \"" <> T.unpack other <> "\"; expected one of: copy, template, dhall-text, structured") + +-- | Decoder for VarDecl from a Dhall record. +-- +-- The @default@ field is decoded as raw text and then coerced against the +-- declared @type@ via 'coerceDeclDefault', so a defaulted variable carries the +-- correctly-typed 'VarValue' for every downstream consumer (e.g. a @bool@ +-- default of @"true"@ becomes 'VBool' 'True'). A default that cannot be coerced +-- is an authoring error and fails module load (caught by 'try' in +-- 'evalModuleFromFile'; see the 'varTypeDecoder' note re: 'error' safety). +varDeclDecoder :: Decoder VarDecl +varDeclDecoder = + fmap coerceDeclDefault $ + record + ( VarDecl + <$> field "name" varNameDecoder + <*> field "type" varTypeDecoder + <*> field "default" (fmap (fmap VText) (maybe strictText)) + <*> field "description" (maybe strictText) + <*> field "required" bool + <*> field "validation" (fmap (fmap ValPattern) (maybe strictText)) + ) + +-- | Coerce a decoded variable declaration's raw-text default against its +-- declared type. On a type mismatch we 'error' with a clear, load-time message +-- that names the variable and the offending value; this is caught by 'try' in +-- 'evalModuleFromFile' and surfaced as a 'DhallEvalError'. +coerceDeclDefault :: VarDecl -> VarDecl +coerceDeclDefault decl = + case decl.default_ of + Nothing -> decl + Just rawDefault -> + case coerceDefault decl.name decl.type_ rawDefault of + Right val -> decl {default_ = Just val} + -- Caught by 'try' in 'evalModuleFromFile' + Left err -> error (T.unpack (renderDefaultError decl.name err)) + +-- | Render a coercion failure for a module default into a load-time message. +renderDefaultError :: VarName -> VarError -> Text +renderDefaultError name (CoercionFailed _ ty raw) = + "Invalid default for variable '" + <> name.unVarName + <> "': cannot coerce " + <> T.pack (show raw) + <> " to declared type " + <> renderVarType ty +renderDefaultError name err = + "Invalid default for variable '" <> name.unVarName <> "': " <> T.pack (show err) + +-- | A short rendering of a declared variable type for error messages. +renderVarType :: VarType -> Text +renderVarType VTText = "text" +renderVarType VTBool = "bool" +renderVarType VTInt = "int" +renderVarType (VTList ty) = "list " <> renderVarType ty +renderVarType (VTChoice _) = "choice" + +varNameDecoder :: Decoder VarName +varNameDecoder = VarName <$> strictText + +-- | Decoder for VarExport from a Dhall record. +-- Note: the Dhall field is @alias@ rather than @as@ because @as@ is a +-- reserved keyword in Dhall. +varExportDecoder :: Decoder VarExport +varExportDecoder = + record + ( VarExport + <$> field "var" varNameDecoder + <*> field "alias" (fmap (fmap VarName) (maybe strictText)) + ) + +-- | Decoder for Prompt from a Dhall record. +-- The @when@ field is parsed via 'parseExpr' into an 'Expr' AST. +-- Parse failures are treated as fatal (via 'error') since they indicate a +-- malformed module definition. +promptDecoder :: Decoder Prompt +promptDecoder = + record + ( mkPrompt + <$> field "var" varNameDecoder + <*> field "text" strictText + <*> field "when" (maybe strictText) + <*> field "choices" (maybe (list strictText)) + ) + where + mkPrompt v t whenText choices = + Prompt + { var = v, + text = t, + condition = parseWhen whenText, + choices = choices + } + +-- | Decoder for PatchOp from a Dhall Text string. +-- +-- See 'varTypeDecoder' note re: 'error' safety. +patchOpDecoder :: Decoder PatchOp +patchOpDecoder = parsePatchOp <$> strictText + where + parsePatchOp :: Text -> PatchOp + parsePatchOp t = case t of + "append-file" -> AppendFile + "prepend-file" -> PrependFile + "append-section" -> AppendSection + "append-line-if-absent" -> AppendLineIfAbsent + -- Caught by 'try' in 'evalModuleFromFile' + other -> error ("Unknown patch operation \"" <> T.unpack other <> "\"; expected one of: append-file, prepend-file, append-section, append-line-if-absent") + +-- | Decoder for Step from a Dhall record. +-- The @when@ field is parsed via 'parseExpr' into an 'Expr' AST. +-- The @patch@ field is an optional patch operation string. +stepDecoder :: Decoder Step +stepDecoder = + record + ( mkStep + <$> field "strategy" strategyDecoder + <*> field "src" string + <*> field "dest" strictText + <*> field "when" (maybe strictText) + <*> field "patch" (maybe strictText) + ) + where + mkStep strat src dest whenText patchText = + Step + { strategy = strat, + src = src, + dest = dest, + condition = parseWhen whenText, + patch = fmap parsePatchOp patchText + } + parsePatchOp "append-file" = AppendFile + parsePatchOp "prepend-file" = PrependFile + parsePatchOp "append-section" = AppendSection + parsePatchOp "append-line-if-absent" = AppendLineIfAbsent + parsePatchOp other = error ("Unknown patch operation \"" <> T.unpack other <> "\"; expected one of: append-file, prepend-file, append-section, append-line-if-absent") + +-- | Decoder for Command from a Dhall record. +-- The @when@ field is parsed via 'parseExpr' into an 'Expr' AST. +commandDecoder :: Decoder Command +commandDecoder = + record + ( mkCommand + <$> field "run" strictText + <*> field "workDir" (maybe strictText) + <*> field "when" (maybe strictText) + ) + where + mkCommand run workDir whenText = + Command + { run = run, + workDir = workDir, + condition = parseWhen whenText + } + +-- | Parse an optional @when@ expression text into an 'Expr'. +-- Returns 'Nothing' for 'Nothing' input, 'Just expr' on success, or calls +-- 'error' on a malformed expression. The 'error' is caught by @try@ in +-- 'evalModuleFromFile' (see 'varTypeDecoder' note). +parseWhen :: Maybe Text -> Maybe Expr +parseWhen Nothing = Nothing +parseWhen (Just t) = case parseExpr t of + Right expr -> Just expr + -- Caught by 'try' in 'evalModuleFromFile' + Left err -> error ("Invalid when expression \"" <> T.unpack t <> "\": " <> T.unpack err) + +-- | Decoder for a single registry entry from a Dhall record. +-- Uses 'withDefaults' to handle registries that omit the @version@ field. +registryEntryDecoder :: Decoder RegistryEntry +registryEntryDecoder = + withDefaults [("version", noneText)] $ + record + ( RegistryEntry + <$> field "name" moduleNameDecoder + <*> field "version" (maybe strictText) + <*> field "path" string + <*> field "description" (maybe strictText) + <*> field "tags" (list strictText) + ) + +-- | Decoder for a registry metadata file from Dhall. +-- Uses 'withDefaults' to handle registries that omit the @recipes@ or +-- @blueprints@ or @prompts@ field (backwards compatibility with existing +-- seihou-registry.dhall files). +registryDecoder :: Decoder Registry +registryDecoder = + withDefaults + [ ("recipes", emptyRegistryEntryList), + ("blueprints", emptyRegistryEntryList), + ("prompts", emptyRegistryEntryList) + ] + $ record + ( Registry + <$> field "repoName" strictText + <*> field "repoDescription" (maybe strictText) + <*> field "modules" (list registryEntryDecoder) + <*> field "recipes" (list registryEntryDecoder) + <*> field "blueprints" (list registryEntryDecoder) + <*> field "prompts" (list registryEntryDecoder) + ) + +-- | A Dhall expression representing an empty list of registry entries. +-- Used as a default for the @recipes@ field in registries that predate recipe support. +emptyRegistryEntryList :: Dhall.Expr Src Void +emptyRegistryEntryList = + Dhall.ListLit + ( Just + ( Dhall.Record + ( DhallMap.fromList + [ ("name", makeRecordField Dhall.Text), + ("version", makeRecordField (Dhall.App Dhall.Optional Dhall.Text)), + ("path", makeRecordField Dhall.Text), + ("description", makeRecordField (Dhall.App Dhall.Optional Dhall.Text)), + ("tags", makeRecordField (Dhall.App Dhall.List Dhall.Text)) + ] + ) + ) + ) + mempty + +-- | Evaluate a @seihou-registry.dhall@ file and decode it into a 'Registry'. +-- Returns 'Left' with a 'RegistryEvalError' if evaluation or decoding fails. +-- +-- Uses 'inputExprWithSettings' to parse, resolve imports, and normalize the +-- Dhall expression, then extracts with 'registryDecoder' directly. This +-- bypasses Dhall's type-annotation check, allowing registry entries to omit +-- optional fields like @version@ — the custom 'registryEntryDecoder' handles +-- missing fields at the AST level. +evalRegistryFromFile :: FilePath -> IO (Either ModuleLoadError Registry) +evalRegistryFromFile path = do + result <- try $ do + text <- TIO.readFile path + let settings = + set rootDirectory (takeDirectory path) $ + set sourceName path defaultInputSettings + expr <- inputExprWithSettings settings text + case extract registryDecoder expr of + Success r -> pure r + Failure e -> throwIO e + case result of + Left (e :: SomeException) -> + pure $ Left (RegistryEvalError (T.pack path) (T.pack (show e))) + Right r -> pure (Right r) diff --git a/src/Seihou/Effect/ConfigReader.hs b/src/Seihou/Effect/ConfigReader.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConfigReader.hs @@ -0,0 +1,31 @@ +module Seihou.Effect.ConfigReader + ( ConfigReader (..), + readGlobalConfig, + readLocalConfig, + readNamespaceConfig, + readContextConfig, + ) +where + +import Seihou.Core.Types (ConfigError) +import Seihou.Prelude + +data ConfigReader :: Effect where + ReadGlobalConfig :: ConfigReader m (Either ConfigError (Map Text Text)) + ReadLocalConfig :: ConfigReader m (Either ConfigError (Map Text Text)) + ReadNamespaceConfig :: Text -> ConfigReader m (Either ConfigError (Map Text Text)) + ReadContextConfig :: Text -> ConfigReader m (Either ConfigError (Map Text Text)) + +type instance DispatchOf ConfigReader = Dynamic + +readGlobalConfig :: (ConfigReader :> es) => Eff es (Either ConfigError (Map Text Text)) +readGlobalConfig = send ReadGlobalConfig + +readLocalConfig :: (ConfigReader :> es) => Eff es (Either ConfigError (Map Text Text)) +readLocalConfig = send ReadLocalConfig + +readNamespaceConfig :: (ConfigReader :> es) => Text -> Eff es (Either ConfigError (Map Text Text)) +readNamespaceConfig ns = send (ReadNamespaceConfig ns) + +readContextConfig :: (ConfigReader :> es) => Text -> Eff es (Either ConfigError (Map Text Text)) +readContextConfig ctx = send (ReadContextConfig ctx) diff --git a/src/Seihou/Effect/ConfigReaderInterp.hs b/src/Seihou/Effect/ConfigReaderInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConfigReaderInterp.hs @@ -0,0 +1,48 @@ +module Seihou.Effect.ConfigReaderInterp + ( runConfigReader, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types (ConfigError (..)) +import Seihou.Dhall.Config (evalConfigFileIfExists) +import Seihou.Effect.ConfigReader (ConfigReader (..)) +import Seihou.Prelude +import System.Directory (XdgDirectory (..), getCurrentDirectory, getXdgDirectory) + +-- | Real IO interpreter for the ConfigReader effect. +-- +-- Resolves config file paths using standard locations: +-- +-- * Global: @~\/.config\/seihou\/config.dhall@ +-- * Local: @.seihou\/config.dhall@ (relative to current directory) +-- * Namespace: @~\/.config\/seihou\/namespaces\/\\/config.dhall@ +-- * Context: @~\/.config\/seihou\/contexts\/\\/config.dhall@ +-- +-- Missing files are silently treated as empty maps. Invalid Dhall +-- is reported as @Left (ConfigParseError ...)@. +runConfigReader :: (IOE :> es) => Eff (ConfigReader : es) a -> Eff es a +runConfigReader = interpret $ \_ -> \case + ReadGlobalConfig -> liftIO $ do + base <- getXdgDirectory XdgConfig "seihou" + let path = base "config.dhall" + first (ConfigParseError path) <$> evalConfigFileIfExists path + ReadLocalConfig -> liftIO $ do + cwd <- getCurrentDirectory + let path = cwd ".seihou" "config.dhall" + first (ConfigParseError path) <$> evalConfigFileIfExists path + ReadNamespaceConfig ns -> liftIO $ loadNamespacedConfig "namespaces" ns "namespace must not contain '..' or '/'" + ReadContextConfig ctx -> liftIO $ loadNamespacedConfig "contexts" ctx "context name must not contain '..' or '/'" + +-- | Load config from a named subdirectory under XDG config, with path-traversal validation. +loadNamespacedConfig :: String -> Text -> Text -> IO (Either ConfigError (Map Text Text)) +loadNamespacedConfig subdir name errMsg + | T.null name = pure (Right Map.empty) + | hasPathTraversal name = pure (Left (InvalidNamespace name errMsg)) + | otherwise = do + base <- getXdgDirectory XdgConfig "seihou" + let path = base subdir T.unpack name "config.dhall" + first (ConfigParseError path) <$> evalConfigFileIfExists path + where + hasPathTraversal t = ".." `T.isInfixOf` t || "/" `T.isInfixOf` t diff --git a/src/Seihou/Effect/ConfigReaderPure.hs b/src/Seihou/Effect/ConfigReaderPure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConfigReaderPure.hs @@ -0,0 +1,32 @@ +module Seihou.Effect.ConfigReaderPure + ( runConfigReaderPure, + ) +where + +import Data.Map.Strict qualified as Map +import Seihou.Effect.ConfigReader (ConfigReader (..)) +import Seihou.Prelude + +-- | Pure interpreter for the ConfigReader effect. +-- +-- Takes four scripted config maps: +-- +-- * @localConfig@: the local project config (.seihou\/config.dhall) +-- * @namespaceConfigs@: a map from namespace names to their configs +-- * @contextConfigs@: a map from context names to their configs +-- * @globalConfig@: the global config (~\/.config\/seihou\/config.dhall) +-- +-- This allows tests to provide exact config values without touching the filesystem. +-- All operations return 'Right' (success) since the pure interpreter has no parse errors. +runConfigReaderPure :: + Map Text Text -> + Map Text (Map Text Text) -> + Map Text (Map Text Text) -> + Map Text Text -> + Eff (ConfigReader : es) a -> + Eff es a +runConfigReaderPure localConfig namespaceConfigs contextConfigs globalConfig = interpret $ \_ -> \case + ReadGlobalConfig -> pure (Right globalConfig) + ReadLocalConfig -> pure (Right localConfig) + ReadNamespaceConfig ns -> pure (Right (Map.findWithDefault Map.empty ns namespaceConfigs)) + ReadContextConfig ctx -> pure (Right (Map.findWithDefault Map.empty ctx contextConfigs)) diff --git a/src/Seihou/Effect/ConfigWriter.hs b/src/Seihou/Effect/ConfigWriter.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConfigWriter.hs @@ -0,0 +1,26 @@ +module Seihou.Effect.ConfigWriter + ( ConfigWriter (..), + writeConfigValue, + deleteConfigValue, + listConfigValues, + ) +where + +import Seihou.Core.Types (ConfigError, ConfigScope) +import Seihou.Prelude + +data ConfigWriter :: Effect where + WriteConfigValue :: ConfigScope -> Text -> Text -> ConfigWriter m () + DeleteConfigValue :: ConfigScope -> Text -> ConfigWriter m () + ListConfigValues :: ConfigScope -> ConfigWriter m (Either ConfigError (Map Text Text)) + +type instance DispatchOf ConfigWriter = Dynamic + +writeConfigValue :: (ConfigWriter :> es) => ConfigScope -> Text -> Text -> Eff es () +writeConfigValue scope key val = send (WriteConfigValue scope key val) + +deleteConfigValue :: (ConfigWriter :> es) => ConfigScope -> Text -> Eff es () +deleteConfigValue scope key = send (DeleteConfigValue scope key) + +listConfigValues :: (ConfigWriter :> es) => ConfigScope -> Eff es (Either ConfigError (Map Text Text)) +listConfigValues scope = send (ListConfigValues scope) diff --git a/src/Seihou/Effect/ConfigWriterInterp.hs b/src/Seihou/Effect/ConfigWriterInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConfigWriterInterp.hs @@ -0,0 +1,77 @@ +module Seihou.Effect.ConfigWriterInterp + ( runConfigWriter, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Types (ConfigError (..), ConfigScope (..)) +import Seihou.Dhall.Config (evalConfigFileIfExists, serializeConfig) +import Seihou.Effect.ConfigWriter (ConfigWriter (..)) +import Seihou.Prelude +import System.Directory + ( XdgDirectory (..), + createDirectoryIfMissing, + getCurrentDirectory, + getXdgDirectory, + ) +import System.FilePath (takeDirectory) + +-- | IO interpreter for the ConfigWriter effect. +-- +-- Performs read-modify-write on Dhall config files. Creates parent +-- directories as needed. Path resolution matches 'ConfigReaderInterp': +-- +-- * 'ScopeLocal': @.seihou\/config.dhall@ relative to cwd +-- * 'ScopeNamespace' ns: @~\/.config\/seihou\/namespaces\/\\/config.dhall@ +-- * 'ScopeContext' ctx: @~\/.config\/seihou\/contexts\/\\/config.dhall@ +-- * 'ScopeGlobal': @~\/.config\/seihou\/config.dhall@ +runConfigWriter :: (IOE :> es) => Eff (ConfigWriter : es) a -> Eff es a +runConfigWriter = interpret $ \_ -> \case + WriteConfigValue scope key val -> liftIO $ do + path <- resolvePath scope + m <- readOrEmpty path + let updated = Map.insert key val m + ensureParent path + TIO.writeFile path (serializeConfig updated) + DeleteConfigValue scope key -> liftIO $ do + path <- resolvePath scope + m <- readOrEmpty path + let updated = Map.delete key m + ensureParent path + TIO.writeFile path (serializeConfig updated) + ListConfigValues scope -> liftIO $ do + path <- resolvePath scope + result <- evalConfigFileIfExists path + case result of + Left err -> pure (Left (ConfigParseError path err)) + Right m -> pure (Right m) + +-- | Resolve the config file path for a given scope. +resolvePath :: ConfigScope -> IO FilePath +resolvePath ScopeLocal = do + cwd <- getCurrentDirectory + pure (cwd ".seihou" "config.dhall") +resolvePath (ScopeNamespace ns) = do + base <- getXdgDirectory XdgConfig "seihou" + pure (base "namespaces" T.unpack ns "config.dhall") +resolvePath (ScopeContext ctx) = do + base <- getXdgDirectory XdgConfig "seihou" + pure (base "contexts" T.unpack ctx "config.dhall") +resolvePath ScopeGlobal = do + base <- getXdgDirectory XdgConfig "seihou" + pure (base "config.dhall") + +-- | Read an existing config file, returning an empty map if the file +-- does not exist. Throws on Dhall parse errors. +readOrEmpty :: FilePath -> IO (Map.Map T.Text T.Text) +readOrEmpty path = do + result <- evalConfigFileIfExists path + case result of + Left err -> fail (T.unpack err) + Right m -> pure m + +-- | Create parent directories for a file path if they don't exist. +ensureParent :: FilePath -> IO () +ensureParent path = createDirectoryIfMissing True (takeDirectory path) diff --git a/src/Seihou/Effect/ConfigWriterPure.hs b/src/Seihou/Effect/ConfigWriterPure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConfigWriterPure.hs @@ -0,0 +1,67 @@ +module Seihou.Effect.ConfigWriterPure + ( runConfigWriterPure, + ConfigWriterState (..), + emptyConfigWriterState, + ) +where + +import Data.Map.Strict qualified as Map +import Effectful.State.Static.Local (State, get, modify, runState) +import Seihou.Core.Types (ConfigScope (..)) +import Seihou.Effect.ConfigWriter (ConfigWriter (..)) +import Seihou.Prelude + +-- | In-memory state for the pure ConfigWriter interpreter. +data ConfigWriterState = ConfigWriterState + { cwLocal :: Map Text Text, + cwNamespaces :: Map Text (Map Text Text), + cwGlobal :: Map Text Text + } + deriving stock (Eq, Show) + +-- | Empty initial state with no config values in any scope. +emptyConfigWriterState :: ConfigWriterState +emptyConfigWriterState = + ConfigWriterState + { cwLocal = Map.empty, + cwNamespaces = Map.empty, + cwGlobal = Map.empty + } + +-- | Pure interpreter for the ConfigWriter effect using in-memory state. +-- +-- Returns the result along with the final state, allowing tests to +-- inspect what was written. +runConfigWriterPure :: ConfigWriterState -> Eff (ConfigWriter : es) a -> Eff es (a, ConfigWriterState) +runConfigWriterPure initial = reinterpret (runState initial) handler + where + handler :: (State ConfigWriterState :> es') => EffectHandler ConfigWriter es' + handler _ = \case + WriteConfigValue scope key val -> + modify @ConfigWriterState (writeToScope scope key val) + DeleteConfigValue scope key -> + modify @ConfigWriterState (deleteFromScope scope key) + ListConfigValues scope -> do + st <- get @ConfigWriterState + pure (Right (readScope scope st)) + +writeToScope :: ConfigScope -> Text -> Text -> ConfigWriterState -> ConfigWriterState +writeToScope ScopeLocal key val st = st {cwLocal = Map.insert key val st.cwLocal} +writeToScope (ScopeNamespace ns) key val st = + let nsMap = Map.findWithDefault Map.empty ns st.cwNamespaces + updated = Map.insert key val nsMap + in st {cwNamespaces = Map.insert ns updated st.cwNamespaces} +writeToScope ScopeGlobal key val st = st {cwGlobal = Map.insert key val st.cwGlobal} + +deleteFromScope :: ConfigScope -> Text -> ConfigWriterState -> ConfigWriterState +deleteFromScope ScopeLocal key st = st {cwLocal = Map.delete key st.cwLocal} +deleteFromScope (ScopeNamespace ns) key st = + let nsMap = Map.findWithDefault Map.empty ns st.cwNamespaces + updated = Map.delete key nsMap + in st {cwNamespaces = Map.insert ns updated st.cwNamespaces} +deleteFromScope ScopeGlobal key st = st {cwGlobal = Map.delete key st.cwGlobal} + +readScope :: ConfigScope -> ConfigWriterState -> Map Text Text +readScope ScopeLocal st = st.cwLocal +readScope (ScopeNamespace ns) st = Map.findWithDefault Map.empty ns st.cwNamespaces +readScope ScopeGlobal st = st.cwGlobal diff --git a/src/Seihou/Effect/Console.hs b/src/Seihou/Effect/Console.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/Console.hs @@ -0,0 +1,36 @@ +module Seihou.Effect.Console + ( Console (..), + putText, + putError, + getLine, + confirm, + isInteractive, + ) +where + +import Seihou.Prelude +import Prelude hiding (getLine) + +data Console :: Effect where + PutText :: Text -> Console m () + PutError :: Text -> Console m () + GetLine :: Console m Text + Confirm :: Text -> Console m Bool + IsInteractive :: Console m Bool + +type instance DispatchOf Console = Dynamic + +putText :: (Console :> es) => Text -> Eff es () +putText msg = send (PutText msg) + +putError :: (Console :> es) => Text -> Eff es () +putError msg = send (PutError msg) + +getLine :: (Console :> es) => Eff es Text +getLine = send GetLine + +confirm :: (Console :> es) => Text -> Eff es Bool +confirm prompt = send (Confirm prompt) + +isInteractive :: (Console :> es) => Eff es Bool +isInteractive = send IsInteractive diff --git a/src/Seihou/Effect/ConsoleInterp.hs b/src/Seihou/Effect/ConsoleInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConsoleInterp.hs @@ -0,0 +1,28 @@ +module Seihou.Effect.ConsoleInterp + ( runConsole, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Effect.Console (Console (..)) +import Seihou.Prelude +import System.IO (hFlush, hIsTerminalDevice, hPutStrLn, stderr, stdin, stdout) +import Prelude hiding (getLine) + +-- | Real IO interpreter for the Console effect. +-- Writes output to stdout, errors to stderr, reads from stdin. +-- TTY detection uses 'hIsTerminalDevice' on stdin. +runConsole :: (IOE :> es) => Eff (Console : es) a -> Eff es a +runConsole = interpret $ \_ -> \case + PutText msg -> liftIO $ TIO.putStrLn msg + PutError msg -> liftIO $ hPutStrLn stderr (T.unpack msg) + GetLine -> liftIO $ do + hFlush stdout + TIO.getLine + Confirm prompt -> liftIO $ do + TIO.putStr (prompt <> " [y/n] ") + hFlush stdout + answer <- TIO.getLine + pure (T.toLower (T.strip answer) `elem` ["y", "yes"]) + IsInteractive -> liftIO $ hIsTerminalDevice stdin diff --git a/src/Seihou/Effect/ConsolePure.hs b/src/Seihou/Effect/ConsolePure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ConsolePure.hs @@ -0,0 +1,58 @@ +module Seihou.Effect.ConsolePure + ( runConsolePure, + runConsolePureNonInteractive, + ConsoleState (..), + emptyConsoleState, + ) +where + +import Effectful.State.Static.Local (State, get, modify, runState) +import Seihou.Effect.Console (Console (..)) +import Seihou.Prelude +import Prelude hiding (getLine) + +-- | State for the pure Console interpreter. +data ConsoleState = ConsoleState + { consoleInputs :: [Text], + consoleOutputs :: [Text], + consoleErrors :: [Text] + } + deriving stock (Eq, Show) + +-- | Empty console state with no inputs or outputs. +emptyConsoleState :: ConsoleState +emptyConsoleState = ConsoleState [] [] [] + +-- | Pure interpreter for the Console effect (interactive mode). +-- Takes a list of scripted input lines. IsInteractive returns True. +runConsolePure :: [Text] -> Eff (Console : es) a -> Eff es (a, ConsoleState) +runConsolePure inputs = reinterpret (runState (ConsoleState inputs [] [])) handler + where + handler :: (State ConsoleState :> es') => EffectHandler Console es' + handler _ = \case + PutText msg -> modify @ConsoleState (\s -> s {consoleOutputs = s.consoleOutputs ++ [msg]}) + PutError msg -> modify @ConsoleState (\s -> s {consoleErrors = s.consoleErrors ++ [msg]}) + GetLine -> popInput + Confirm _prompt -> (`elem` ["y", "yes"]) <$> popInput + IsInteractive -> pure True + + popInput :: (State ConsoleState :> es') => Eff es' Text + popInput = do + s <- get @ConsoleState + case s.consoleInputs of + [] -> pure "" + (x : xs) -> do + modify @ConsoleState (\st -> st {consoleInputs = xs}) + pure x + +-- | Pure interpreter for non-interactive mode. IsInteractive returns False. +runConsolePureNonInteractive :: Eff (Console : es) a -> Eff es (a, ConsoleState) +runConsolePureNonInteractive = reinterpret (runState emptyConsoleState) handler + where + handler :: (State ConsoleState :> es') => EffectHandler Console es' + handler _ = \case + PutText msg -> modify @ConsoleState (\s -> s {consoleOutputs = s.consoleOutputs ++ [msg]}) + PutError msg -> modify @ConsoleState (\s -> s {consoleErrors = s.consoleErrors ++ [msg]}) + GetLine -> pure "" + Confirm _prompt -> pure False + IsInteractive -> pure False diff --git a/src/Seihou/Effect/DhallEval.hs b/src/Seihou/Effect/DhallEval.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/DhallEval.hs @@ -0,0 +1,16 @@ +module Seihou.Effect.DhallEval + ( DhallEval (..), + evalModuleFile, + ) +where + +import Seihou.Core.Types (Module, ModuleLoadError) +import Seihou.Prelude + +data DhallEval :: Effect where + EvalModuleFile :: FilePath -> DhallEval m (Either ModuleLoadError Module) + +type instance DispatchOf DhallEval = Dynamic + +evalModuleFile :: (DhallEval :> es) => FilePath -> Eff es (Either ModuleLoadError Module) +evalModuleFile path = send (EvalModuleFile path) diff --git a/src/Seihou/Effect/DhallEvalInterp.hs b/src/Seihou/Effect/DhallEvalInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/DhallEvalInterp.hs @@ -0,0 +1,25 @@ +module Seihou.Effect.DhallEvalInterp + ( runDhallEval, + runDhallEvalPure, + ) +where + +import Data.Map.Strict qualified as Map +import Seihou.Core.Types (Module, ModuleLoadError (..)) +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Effect.DhallEval (DhallEval (..)) +import Seihou.Prelude + +-- | Real interpreter that evaluates Dhall files from disk. +runDhallEval :: (IOE :> es) => Eff (DhallEval : es) a -> Eff es a +runDhallEval = interpret $ \_ -> \case + EvalModuleFile path -> liftIO (evalModuleFromFile path) + +-- | Pure test interpreter that looks up modules from an in-memory map. +-- The map keys are file paths; if a path is not found, an error is raised. +runDhallEvalPure :: Map FilePath Module -> Eff (DhallEval : es) a -> Eff es a +runDhallEvalPure modules = interpret $ \_ -> \case + EvalModuleFile path -> + case Map.lookup path modules of + Just m -> pure (Right m) + Nothing -> error ("runDhallEvalPure: no module at path: " <> path) diff --git a/src/Seihou/Effect/Filesystem.hs b/src/Seihou/Effect/Filesystem.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/Filesystem.hs @@ -0,0 +1,75 @@ +module Seihou.Effect.Filesystem + ( Filesystem (..), + readFileText, + writeFileText, + copyFile, + listDirectory, + createDirectoryIfMissing, + doesFileExist, + doesDirectoryExist, + getCurrentDirectory, + removeFile, + removeDirectoryIfEmpty, + renamePath, + removeDirectoryRecursive, + ) +where + +import Seihou.Prelude + +data Filesystem :: Effect where + ReadFileText :: FilePath -> Filesystem m Text + WriteFileText :: FilePath -> Text -> Filesystem m () + CopyFile :: FilePath -> FilePath -> Filesystem m () + ListDirectory :: FilePath -> Filesystem m [FilePath] + CreateDirectoryIfMissing :: Bool -> FilePath -> Filesystem m () + DoesFileExist :: FilePath -> Filesystem m Bool + DoesDirectoryExist :: FilePath -> Filesystem m Bool + GetCurrentDirectory :: Filesystem m FilePath + RemoveFile :: FilePath -> Filesystem m () + RemoveDirectoryIfEmpty :: FilePath -> Filesystem m () + -- | Rename a file or directory atomically (within a filesystem). + -- Backed by 'System.Directory.renamePath' in IO. + RenamePath :: FilePath -> FilePath -> Filesystem m () + -- | Recursively delete a directory and all its contents. Backed by + -- 'System.Directory.removeDirectoryRecursive' in IO. The pure + -- interpreter drops every map entry under the prefix. + RemoveDirectoryRecursive :: FilePath -> Filesystem m () + +type instance DispatchOf Filesystem = Dynamic + +readFileText :: (Filesystem :> es) => FilePath -> Eff es Text +readFileText path = send (ReadFileText path) + +writeFileText :: (Filesystem :> es) => FilePath -> Text -> Eff es () +writeFileText path content = send (WriteFileText path content) + +copyFile :: (Filesystem :> es) => FilePath -> FilePath -> Eff es () +copyFile src dest = send (CopyFile src dest) + +listDirectory :: (Filesystem :> es) => FilePath -> Eff es [FilePath] +listDirectory path = send (ListDirectory path) + +createDirectoryIfMissing :: (Filesystem :> es) => Bool -> FilePath -> Eff es () +createDirectoryIfMissing parents path = send (CreateDirectoryIfMissing parents path) + +doesFileExist :: (Filesystem :> es) => FilePath -> Eff es Bool +doesFileExist path = send (DoesFileExist path) + +doesDirectoryExist :: (Filesystem :> es) => FilePath -> Eff es Bool +doesDirectoryExist path = send (DoesDirectoryExist path) + +getCurrentDirectory :: (Filesystem :> es) => Eff es FilePath +getCurrentDirectory = send GetCurrentDirectory + +removeFile :: (Filesystem :> es) => FilePath -> Eff es () +removeFile path = send (RemoveFile path) + +removeDirectoryIfEmpty :: (Filesystem :> es) => FilePath -> Eff es () +removeDirectoryIfEmpty path = send (RemoveDirectoryIfEmpty path) + +renamePath :: (Filesystem :> es) => FilePath -> FilePath -> Eff es () +renamePath src dest = send (RenamePath src dest) + +removeDirectoryRecursive :: (Filesystem :> es) => FilePath -> Eff es () +removeDirectoryRecursive path = send (RemoveDirectoryRecursive path) diff --git a/src/Seihou/Effect/FilesystemInterp.hs b/src/Seihou/Effect/FilesystemInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/FilesystemInterp.hs @@ -0,0 +1,38 @@ +module Seihou.Effect.FilesystemInterp + ( runFilesystem, + ) +where + +import Control.Monad (when) +import Data.Text.IO qualified as TIO +import Seihou.Effect.Filesystem (Filesystem (..)) +import Seihou.Prelude +import System.Directory qualified as Dir + +-- | Real IO interpreter for the Filesystem effect. +-- Delegates to System.Directory and Data.Text.IO. +runFilesystem :: (IOE :> es) => Eff (Filesystem : es) a -> Eff es a +runFilesystem = interpret $ \_ -> \case + ReadFileText path -> liftIO (TIO.readFile path) + WriteFileText path content -> liftIO (TIO.writeFile path content) + CopyFile src dest -> liftIO (Dir.copyFile src dest) + ListDirectory path -> liftIO (Dir.listDirectory path) + CreateDirectoryIfMissing parents path -> + liftIO (Dir.createDirectoryIfMissing parents path) + DoesFileExist path -> liftIO (Dir.doesFileExist path) + DoesDirectoryExist path -> liftIO (Dir.doesDirectoryExist path) + GetCurrentDirectory -> liftIO Dir.getCurrentDirectory + RemoveFile path -> liftIO (Dir.removeFile path) + RemoveDirectoryIfEmpty path -> liftIO $ do + -- Treat a missing directory as a no-op so this matches the pure + -- interpreter's semantics. Without this guard, callers that walk + -- a list of "maybe-now-empty" parents (e.g. cleanupEmptyDirs in + -- Engine.Migrate / Engine.Remove) crash whenever a sibling + -- operation — typically a user-authored 'rm -rf' RunCommand step + -- in a migration chain — has already removed the directory. + exists <- Dir.doesDirectoryExist path + when exists $ do + entries <- Dir.listDirectory path + when (null entries) (Dir.removeDirectory path) + RenamePath src dest -> liftIO (Dir.renamePath src dest) + RemoveDirectoryRecursive path -> liftIO (Dir.removeDirectoryRecursive path) diff --git a/src/Seihou/Effect/FilesystemPure.hs b/src/Seihou/Effect/FilesystemPure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/FilesystemPure.hs @@ -0,0 +1,128 @@ +module Seihou.Effect.FilesystemPure + ( runFilesystemPure, + PureFS (..), + emptyFS, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Effectful.State.Static.Local (State, get, modify, put, runState) +import Seihou.Effect.Filesystem (Filesystem (..)) +import Seihou.Prelude + +-- | In-memory filesystem state for testing. +data PureFS = PureFS + { files :: Map FilePath Text, + dirs :: Set FilePath + } + deriving stock (Eq, Show) + +-- | An empty in-memory filesystem. +emptyFS :: PureFS +emptyFS = PureFS Map.empty Set.empty + +-- | Pure in-memory interpreter for the Filesystem effect. +-- Useful for testing without touching the real filesystem. +runFilesystemPure :: PureFS -> Eff (Filesystem : es) a -> Eff es (a, PureFS) +runFilesystemPure initial = reinterpret (runState initial) handler + where + handler :: (State PureFS :> es') => EffectHandler Filesystem es' + handler _ = \case + ReadFileText path -> do + fs <- get @PureFS + case Map.lookup path fs.files of + Just content -> pure content + Nothing -> error ("runFilesystemPure: file not found: " <> path) + WriteFileText path content -> do + modify @PureFS (\fs -> fs {files = Map.insert path content fs.files}) + CopyFile src dest -> do + fs <- get @PureFS + case Map.lookup src fs.files of + Just content -> + put fs {files = Map.insert dest content fs.files} + Nothing -> error ("runFilesystemPure: source file not found: " <> src) + ListDirectory path -> do + fs <- get @PureFS + let prefix = if null path then "" else path <> "/" + filesInDir = + [ drop (length prefix) fp + | fp <- Map.keys fs.files, + isDirectChild prefix fp + ] + dirsInDir = + [ drop (length prefix) d + | d <- Set.toList fs.dirs, + isDirectChild prefix d + ] + pure (filesInDir <> dirsInDir) + CreateDirectoryIfMissing _parents path -> do + modify @PureFS (\fs -> fs {dirs = Set.insert path fs.dirs}) + DoesFileExist path -> do + fs <- get @PureFS + pure (Map.member path fs.files) + DoesDirectoryExist path -> do + fs <- get @PureFS + pure (Set.member path fs.dirs) + GetCurrentDirectory -> pure "/pure-fs" + RemoveFile path -> do + modify @PureFS (\fs -> fs {files = Map.delete path fs.files}) + RemoveDirectoryIfEmpty path -> do + fs <- get @PureFS + let hasChildren = + any (\fp -> (path <> "/") `isPrefixOfPath` fp) (Map.keys fs.files) + || any (\d -> (path <> "/") `isPrefixOfPath` d) (Set.toList fs.dirs) + if hasChildren + then pure () + else modify @PureFS (\fs' -> fs' {dirs = Set.delete path fs'.dirs}) + RenamePath src dest -> do + modify @PureFS (renameInPureFS src dest) + RemoveDirectoryRecursive path -> do + modify @PureFS (removeRecursivelyFromPureFS path) + +-- | Check if a path is a direct child of a prefix directory. +isDirectChild :: String -> String -> Bool +isDirectChild "" fp = '/' `notElem` fp +isDirectChild prefix fp = + prefix `isPrefixOfPath` fp + && '/' `notElem` drop (length prefix) fp + +isPrefixOfPath :: String -> String -> Bool +isPrefixOfPath [] _ = True +isPrefixOfPath _ [] = False +isPrefixOfPath (x : xs) (y : ys) + | x == y = isPrefixOfPath xs ys + | otherwise = False + +-- | Rename @src@ to @dest@ in the pure filesystem. Handles two cases: +-- +-- * A single file at exactly @src@ (rename the entry). +-- * A directory at @src@ (rewrite every key under @src/@ to @dest/@, +-- and rewrite the @dirs@ set similarly). +-- +-- If @src@ does not exist as either a file or a directory prefix, this +-- is a no-op (mirrors the in-memory model; the IO interpreter would +-- raise an exception, which is expected behavior at the engine layer +-- when callers have already validated existence). +renameInPureFS :: FilePath -> FilePath -> PureFS -> PureFS +renameInPureFS src dest fs = + let renamedFiles = Map.mapKeys (renameKey src dest) fs.files + renamedDirs = Set.map (renameKey src dest) fs.dirs + in fs {files = renamedFiles, dirs = renamedDirs} + where + renameKey s d k + | k == s = d + | (s <> "/") `isPrefixOfPath` k = d <> drop (length s) k + | otherwise = k + +-- | Recursively delete every entry under @path@ (and @path@ itself, +-- treated as a directory). +removeRecursivelyFromPureFS :: FilePath -> PureFS -> PureFS +removeRecursivelyFromPureFS path fs = + let prefix = path <> "/" + keepFile k = k /= path && not (prefix `isPrefixOfPath` k) + keepDir d = d /= path && not (prefix `isPrefixOfPath` d) + in fs + { files = Map.filterWithKey (\k _ -> keepFile k) fs.files, + dirs = Set.filter keepDir fs.dirs + } diff --git a/src/Seihou/Effect/Logger.hs b/src/Seihou/Effect/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/Logger.hs @@ -0,0 +1,30 @@ +module Seihou.Effect.Logger + ( Logger (..), + logDebug, + logInfo, + logWarn, + logError, + ) +where + +import Seihou.Prelude + +data Logger :: Effect where + LogDebug :: Text -> Logger m () + LogInfo :: Text -> Logger m () + LogWarn :: Text -> Logger m () + LogError :: Text -> Logger m () + +type instance DispatchOf Logger = Dynamic + +logDebug :: (Logger :> es) => Text -> Eff es () +logDebug msg = send (LogDebug msg) + +logInfo :: (Logger :> es) => Text -> Eff es () +logInfo msg = send (LogInfo msg) + +logWarn :: (Logger :> es) => Text -> Eff es () +logWarn msg = send (LogWarn msg) + +logError :: (Logger :> es) => Text -> Eff es () +logError msg = send (LogError msg) diff --git a/src/Seihou/Effect/LoggerInterp.hs b/src/Seihou/Effect/LoggerInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/LoggerInterp.hs @@ -0,0 +1,38 @@ +module Seihou.Effect.LoggerInterp + ( runLoggerIO, + shouldLog, + ) +where + +import Control.Monad (when) +import Data.Text qualified as T +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (Logger (..)) +import Seihou.Prelude +import System.IO (hPutStrLn, stderr) + +-- | IO interpreter for the Logger effect. +-- Messages are written to stderr, filtered by the given 'LogLevel'. +-- At 'LogQuiet', only errors are shown. At 'LogNormal', warnings and errors. +-- At 'LogVerbose', all messages including info and debug. +runLoggerIO :: (IOE :> es) => LogLevel -> Eff (Logger : es) a -> Eff es a +runLoggerIO level = interpret $ \_ -> \case + LogDebug msg -> whenLevel LogVerbose $ emit "[debug] " msg + LogInfo msg -> whenLevel LogVerbose $ emit "[info] " msg + LogWarn msg -> whenLevel LogNormal $ emit "[warn] " msg + LogError msg -> whenLevel LogQuiet $ emit "[error] " msg + where + whenLevel minLevel action = + when (shouldLog level minLevel) action + emit prefix msg = + liftIO $ hPutStrLn stderr (T.unpack (prefix <> msg)) + +-- | Pure filtering predicate: does the configured level permit a message +-- that requires @minLevel@? +-- +-- >>> shouldLog LogVerbose LogVerbose +-- True +-- >>> shouldLog LogNormal LogVerbose +-- False +shouldLog :: LogLevel -> LogLevel -> Bool +shouldLog configured minLevel = configured >= minLevel diff --git a/src/Seihou/Effect/LoggerPure.hs b/src/Seihou/Effect/LoggerPure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/LoggerPure.hs @@ -0,0 +1,37 @@ +module Seihou.Effect.LoggerPure + ( runLoggerPure, + LoggerState (..), + emptyLoggerState, + ) +where + +import Effectful.State.Static.Local (State, modify, runState) +import Seihou.Effect.Logger (Logger (..)) +import Seihou.Prelude + +-- | State capturing all log messages by severity. +-- Messages are appended in order within each field. +data LoggerState = LoggerState + { logDebugMsgs :: [Text], + logInfoMsgs :: [Text], + logWarnMsgs :: [Text], + logErrorMsgs :: [Text] + } + deriving stock (Eq, Show) + +-- | Empty logger state with no captured messages. +emptyLoggerState :: LoggerState +emptyLoggerState = LoggerState [] [] [] [] + +-- | Pure interpreter for the Logger effect. +-- Captures all messages regardless of level, organized by severity. +-- Use this for testing code that emits log messages. +runLoggerPure :: Eff (Logger : es) a -> Eff es (a, LoggerState) +runLoggerPure = reinterpret (runState emptyLoggerState) handler + where + handler :: (State LoggerState :> es') => EffectHandler Logger es' + handler _ = \case + LogDebug msg -> modify @LoggerState (\s -> s {logDebugMsgs = s.logDebugMsgs ++ [msg]}) + LogInfo msg -> modify @LoggerState (\s -> s {logInfoMsgs = s.logInfoMsgs ++ [msg]}) + LogWarn msg -> modify @LoggerState (\s -> s {logWarnMsgs = s.logWarnMsgs ++ [msg]}) + LogError msg -> modify @LoggerState (\s -> s {logErrorMsgs = s.logErrorMsgs ++ [msg]}) diff --git a/src/Seihou/Effect/ManifestStore.hs b/src/Seihou/Effect/ManifestStore.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ManifestStore.hs @@ -0,0 +1,21 @@ +module Seihou.Effect.ManifestStore + ( ManifestStore (..), + readManifest, + writeManifest, + ) +where + +import Seihou.Core.Types (Manifest) +import Seihou.Prelude + +data ManifestStore :: Effect where + ReadManifest :: ManifestStore m (Either Text (Maybe Manifest)) + WriteManifest :: Manifest -> ManifestStore m () + +type instance DispatchOf ManifestStore = Dynamic + +readManifest :: (ManifestStore :> es) => Eff es (Either Text (Maybe Manifest)) +readManifest = send ReadManifest + +writeManifest :: (ManifestStore :> es) => Manifest -> Eff es () +writeManifest m = send (WriteManifest m) diff --git a/src/Seihou/Effect/ManifestStoreInterp.hs b/src/Seihou/Effect/ManifestStoreInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ManifestStoreInterp.hs @@ -0,0 +1,44 @@ +module Seihou.Effect.ManifestStoreInterp + ( runManifestStore, + ) +where + +import Control.Monad (unless) +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Seihou.Effect.Filesystem (Filesystem, createDirectoryIfMissing, doesFileExist, readFileText, renamePath, writeFileText) +import Seihou.Effect.ManifestStore (ManifestStore (..)) +import Seihou.Manifest.Types (manifestFromJSON, manifestToJSON) +import Seihou.Prelude +import System.FilePath (takeDirectory) + +-- | Real interpreter for the ManifestStore effect. +-- Reads and writes manifest JSON via the Filesystem effect. +-- Write is atomic within one filesystem: writes to a temp path in the +-- manifest directory, then renames that complete file over the final path. +runManifestStore :: + (Filesystem :> es) => + FilePath -> + Eff (ManifestStore : es) a -> + Eff es a +runManifestStore manifestPath = interpret $ \_ -> \case + ReadManifest -> do + exists <- doesFileExist manifestPath + if not exists + then pure (Right Nothing) + else do + content <- readFileText manifestPath + let bs = LBS.fromStrict (TE.encodeUtf8 content) + case manifestFromJSON bs of + Left err -> pure (Left (T.pack err)) + Right manifest -> pure (Right (Just manifest)) + WriteManifest manifest -> do + let bs = manifestToJSON manifest + content = TE.decodeUtf8 (LBS.toStrict bs) + tmpPath = manifestPath <> ".tmp" + parentDir = takeDirectory manifestPath + unless (parentDir == "." || null parentDir) $ + createDirectoryIfMissing True parentDir + writeFileText tmpPath content + renamePath tmpPath manifestPath diff --git a/src/Seihou/Effect/ManifestStorePure.hs b/src/Seihou/Effect/ManifestStorePure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ManifestStorePure.hs @@ -0,0 +1,22 @@ +module Seihou.Effect.ManifestStorePure + ( runManifestStorePure, + ) +where + +import Effectful.State.Static.Local (State, get, put, runState) +import Seihou.Core.Types (Manifest) +import Seihou.Effect.ManifestStore (ManifestStore (..)) +import Seihou.Prelude + +-- | Pure in-memory interpreter for the ManifestStore effect. +-- Stores the manifest in effectful State. +runManifestStorePure :: + Maybe Manifest -> + Eff (ManifestStore : es) a -> + Eff es (a, Maybe Manifest) +runManifestStorePure initial = reinterpret (runState initial) handler + where + handler :: (State (Maybe Manifest) :> es') => EffectHandler ManifestStore es' + handler _ = \case + ReadManifest -> Right <$> get @(Maybe Manifest) + WriteManifest manifest -> put (Just manifest) diff --git a/src/Seihou/Effect/Process.hs b/src/Seihou/Effect/Process.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/Process.hs @@ -0,0 +1,16 @@ +module Seihou.Effect.Process + ( Process (..), + runProcess, + ) +where + +import Seihou.Prelude +import System.Exit (ExitCode) + +data Process :: Effect where + RunProcess :: Text -> [Text] -> Maybe FilePath -> Process m (ExitCode, Text, Text) + +type instance DispatchOf Process = Dynamic + +runProcess :: (Process :> es) => Text -> [Text] -> Maybe FilePath -> Eff es (ExitCode, Text, Text) +runProcess cmd args workDir = send (RunProcess cmd args workDir) diff --git a/src/Seihou/Effect/ProcessInterp.hs b/src/Seihou/Effect/ProcessInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ProcessInterp.hs @@ -0,0 +1,20 @@ +module Seihou.Effect.ProcessInterp + ( runProcessIO, + ) +where + +import Data.Text qualified as T +import Seihou.Effect.Process (Process (..)) +import Seihou.Prelude +import System.Exit (ExitCode) +import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode) + +runProcessIO :: (IOE :> es) => Eff (Process : es) a -> Eff es a +runProcessIO = interpret $ \_ -> \case + RunProcess cmd args workDir -> liftIO $ do + let cp = + (proc (T.unpack cmd) (map T.unpack args)) + { cwd = workDir + } + (exitCode, stdout, stderr) <- readCreateProcessWithExitCode cp "" + pure (exitCode, T.pack stdout, T.pack stderr) diff --git a/src/Seihou/Effect/ProcessPure.hs b/src/Seihou/Effect/ProcessPure.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/ProcessPure.hs @@ -0,0 +1,29 @@ +module Seihou.Effect.ProcessPure + ( runProcessPure, + ProcessMock (..), + ) +where + +import Seihou.Effect.Process (Process (..)) +import Seihou.Prelude +import System.Exit (ExitCode (..)) + +data ProcessMock = ProcessMock + { mockCommand :: Text, + mockArgs :: [Text], + mockResult :: (ExitCode, Text, Text) + } + deriving stock (Eq, Show) + +runProcessPure :: [ProcessMock] -> Eff (Process : es) a -> Eff es a +runProcessPure mocks = interpret $ \_ -> \case + RunProcess cmd args _workDir -> + case findMock cmd args mocks of + Just result -> pure result + Nothing -> pure (ExitFailure 127, "", "command not found: " <> cmd) + +findMock :: Text -> [Text] -> [ProcessMock] -> Maybe (ExitCode, Text, Text) +findMock _ _ [] = Nothing +findMock cmd args (m : ms) + | m.mockCommand == cmd && m.mockArgs == args = Just m.mockResult + | otherwise = findMock cmd args ms diff --git a/src/Seihou/Engine/Conflict.hs b/src/Seihou/Engine/Conflict.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Conflict.hs @@ -0,0 +1,86 @@ +module Seihou.Engine.Conflict + ( resolveConflicts, + resolveConflictsInteractive, + ) +where + +import Data.Text qualified as T +import Seihou.Core.Types (ConflictFile (..), ConflictResolution (..)) +import Seihou.Effect.Console (Console, getLine, isInteractive, putText) +import Seihou.Prelude +import Prelude hiding (getLine) + +-- | Resolve a list of conflicts, returning per-file resolutions. +-- +-- Returns 'Just' with the list of resolutions when all conflicts are handled, +-- or 'Nothing' when the run should abort (non-interactive without force, or +-- user chose Abort). +-- +-- Behavior: +-- * Empty conflict list → @Just []@. +-- * @force = True@ → all conflicts resolved as 'AcceptNew'. +-- * Non-interactive terminal → 'Nothing' (caller should print errors and exit). +-- * Interactive terminal → prompts user for each file via 'resolveConflictsInteractive'. +resolveConflicts :: + (Console :> es) => + Bool -> + [ConflictFile] -> + Eff es (Maybe [(ConflictFile, ConflictResolution)]) +resolveConflicts _ [] = pure (Just []) +resolveConflicts force conflicts + | force = pure (Just (map (\c -> (c, AcceptNew)) conflicts)) + | otherwise = do + interactive <- isInteractive + if interactive + then resolveConflictsInteractive conflicts + else pure Nothing + +-- | Interactively prompt for each conflicted file. +-- +-- For each conflict, displays the file path and offers four choices: +-- accept (overwrite), keep (preserve disk copy), skip (leave untouched), +-- or abort (stop the entire run). +-- +-- Returns 'Nothing' if the user chooses Abort on any file. +resolveConflictsInteractive :: + (Console :> es) => + [ConflictFile] -> + Eff es (Maybe [(ConflictFile, ConflictResolution)]) +resolveConflictsInteractive = go [] + where + go acc [] = pure (Just (reverse acc)) + go acc (c : cs) = do + resolution <- promptConflict c + case resolution of + Abort -> pure Nothing + _ -> go ((c, resolution) : acc) cs + +-- | Prompt the user for a single conflict, re-prompting on invalid input. +promptConflict :: + (Console :> es) => + ConflictFile -> + Eff es ConflictResolution +promptConflict c = do + putText $ "Conflict: " <> T.pack c.path <> " (modified since last generation)" + promptChoice + where + promptChoice = do + putText " [a]ccept new [k]eep current [s]kip [A]bort all" + input <- getLine + case parseChoice (T.strip input) of + Just res -> pure res + Nothing -> do + putText "Invalid choice, try again." + promptChoice + +-- | Parse user input into a ConflictResolution. +parseChoice :: T.Text -> Maybe ConflictResolution +parseChoice "a" = Just AcceptNew +parseChoice "accept" = Just AcceptNew +parseChoice "k" = Just KeepCurrent +parseChoice "keep" = Just KeepCurrent +parseChoice "s" = Just Skip +parseChoice "skip" = Just Skip +parseChoice "A" = Just Abort +parseChoice "abort" = Just Abort +parseChoice _ = Nothing diff --git a/src/Seihou/Engine/DhallJSON.hs b/src/Seihou/Engine/DhallJSON.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/DhallJSON.hs @@ -0,0 +1,46 @@ +module Seihou.Engine.DhallJSON + ( dhallExprToJSON, + ) +where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Foldable (toList) +import Data.Void (Void) +import Dhall.Core qualified as Dhall +import Dhall.Map qualified as DhallMap +import Dhall.Src (Src) +import Seihou.Prelude + +-- | Convert a normalized Dhall expression to an aeson Value. +-- Supports records, text, naturals, integers, doubles, bools, lists, and optionals. +-- Returns Left with an error message for unsupported expression types. +dhallExprToJSON :: Dhall.Expr Src Void -> Either Text Aeson.Value +dhallExprToJSON = go + where + go (Dhall.RecordLit fields) = do + pairs <- mapM convertField (DhallMap.toList fields) + pure (Aeson.object pairs) + where + convertField (k, rf) = (Key.fromText k,) <$> go (Dhall.recordFieldValue rf) + go (Dhall.TextLit (Dhall.Chunks [] t)) = + pure (Aeson.String t) + go (Dhall.NaturalLit n) = + pure (Aeson.toJSON n) + go (Dhall.IntegerLit n) = + pure (Aeson.toJSON n) + go (Dhall.DoubleLit (Dhall.DhallDouble d)) = + pure (Aeson.toJSON d) + go (Dhall.BoolLit b) = + pure (Aeson.Bool b) + go (Dhall.ListLit _ xs) = do + items <- mapM go (toList xs) + pure (Aeson.toJSON items) + go (Dhall.Some e) = + go e + go (Dhall.App Dhall.None _) = + pure Aeson.Null + go (Dhall.Note _ e) = + go e + go expr = + Left ("Cannot convert Dhall expression to JSON: " <> Dhall.pretty expr) diff --git a/src/Seihou/Engine/Diff.hs b/src/Seihou/Engine/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Diff.hs @@ -0,0 +1,174 @@ +module Seihou.Engine.Diff + ( computeDiff, + planToFileMap, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Seihou.Core.Types +import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Prelude + +-- | Extract a map of (path, content) from planned operations. +-- Only WriteFileOp and CopyFileOp produce file entries; directories and +-- commands are ignored. +planToFileMap :: [Operation] -> Map FilePath Text +planToFileMap = Map.fromList . concatMap extract + where + extract (WriteFileOp dest content _) = [(dest, content)] + extract (PatchFileOp dest content _ _ _) = [(dest, content)] + extract _ = [] + +-- | Compute a three-state diff: manifest vs plan vs disk. +-- Classifies each file into one of: New, Modified, Unchanged, Conflict, Orphaned. +-- Patch operations (append-section, append-file, prepend-file) are never +-- classified as conflicts because they are designed to merge with existing files. +-- +-- The @activeModules@ parameter scopes orphan detection: only manifest files +-- owned by a module in this set can be classified as Orphaned. Files from +-- other modules are invisible to the diff, preserving them across independent +-- module runs. +computeDiff :: + (Filesystem :> es) => + Manifest -> + Set ModuleName -> + [(FilePath, Text, ModuleName, Maybe PatchOp)] -> + Eff es DiffResult +computeDiff manifest activeModules planned = do + let manifestFiles' = manifest.files + activeManifestFiles = + Map.filter (\r -> r.moduleName `Set.member` activeModules) manifestFiles' + planMap = Map.fromList [(p, (content, modName, patchOp)) | (p, content, modName, patchOp) <- planned] + allPaths = + Set.toList $ + Set.union + (Map.keysSet activeManifestFiles) + (Map.keysSet planMap) + + results <- mapM (classifyFile activeManifestFiles planMap) allPaths + + let newFiles = [f | ClassNew f <- results] + modifiedFiles = [f | ClassModified f <- results] + unchangedFiles = [f | ClassUnchanged f <- results] + conflictFiles = [f | ClassConflict f <- results] + orphanedFiles = [f | ClassOrphaned f <- results] + + pure + DiffResult + { new = newFiles, + modified = modifiedFiles, + unchanged = unchangedFiles, + conflicts = conflictFiles, + orphaned = orphanedFiles + } + +data Classification + = ClassNew PlannedFile + | ClassModified ModifiedFile + | ClassUnchanged FilePath + | ClassConflict ConflictFile + | ClassOrphaned OrphanedFile + +classifyFile :: + (Filesystem :> es) => + Map FilePath FileRecord -> + Map FilePath (Text, ModuleName, Maybe PatchOp) -> + FilePath -> + Eff es Classification +classifyFile manifestFiles' planMap path = do + let inManifest = Map.lookup path manifestFiles' + inPlan = Map.lookup path planMap + isPatch = case inPlan of + Just (_, _, Just _) -> True + _ -> False + onDisk <- doesFileExist path + + case (inManifest, inPlan, onDisk) of + -- In plan, not in manifest, not on disk → New + (Nothing, Just (content, modName, _), False) -> + pure $ ClassNew (PlannedFile {path = path, moduleName = modName, content = content}) + -- In plan, not in manifest, on disk → Patch ops merge with existing files (New); + -- non-patch ops conflict (file exists but wasn't generated by us) + (Nothing, Just (content, modName, _), True) + | isPatch -> + pure $ ClassNew (PlannedFile {path = path, moduleName = modName, content = content}) + | otherwise -> do + diskContent <- readFileText path + let diskHash = hashContent diskContent + pure $ + ClassConflict + ( ConflictFile + { path = path, + moduleName = modName, + manifestHash = SHA256 "", + diskHash = diskHash, + planContent = content + } + ) + -- In manifest + plan + disk + (Just record, Just (content, modName, _), True) -> do + diskContent <- readFileText path + let diskHash = hashContent diskContent + manifestHash = record.hash + planHash = hashContent content + if diskHash /= manifestHash + then + -- Patch ops always merge, even if the user modified the file + if isPatch + then + pure $ + ClassModified + ( ModifiedFile + { path = path, + moduleName = modName, + oldHash = manifestHash, + newContent = content + } + ) + else -- User modified the file → Conflict + pure $ + ClassConflict + ( ConflictFile + { path = path, + moduleName = modName, + manifestHash = manifestHash, + diskHash = diskHash, + planContent = content + } + ) + else + if planHash == manifestHash + then pure $ ClassUnchanged path + else + pure $ + ClassModified + ( ModifiedFile + { path = path, + moduleName = modName, + oldHash = manifestHash, + newContent = content + } + ) + -- In manifest + plan, not on disk → treat as Modified (file was deleted by user, re-create) + (Just record, Just (content, modName, _), False) -> + pure $ + ClassModified + ( ModifiedFile + { path = path, + moduleName = modName, + oldHash = record.hash, + newContent = content + } + ) + -- In manifest, not in plan, on disk → Orphaned + (Just record, Nothing, True) -> + pure $ ClassOrphaned (OrphanedFile {path = path, moduleName = record.moduleName}) + -- In manifest, not in plan, not on disk → Orphaned (already deleted) + (Just record, Nothing, False) -> + pure $ ClassOrphaned (OrphanedFile {path = path, moduleName = record.moduleName}) + -- Not in manifest, not in plan → shouldn't happen (we only iterate known paths) + (Nothing, Nothing, _) -> + pure $ ClassUnchanged path -- unreachable in practice diff --git a/src/Seihou/Engine/Execute.hs b/src/Seihou/Engine/Execute.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Execute.hs @@ -0,0 +1,114 @@ +module Seihou.Engine.Execute + ( executePlan, + dryRunPlan, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Time (UTCTime) +import Seihou.Core.Types +import Seihou.Effect.Filesystem +import Seihou.Engine.Section (applyTextPatch) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Prelude + +-- | Execute a list of operations against the filesystem. +-- Returns a map of file paths to FileRecord entries for the manifest. +-- +-- The @ownerMap@ attributes each generated file to the module instance +-- (by its qualified name) that produced it. Paths not present in the +-- map fall back to the default @moduleName'@ — this preserves single- +-- module call-sites and test usage that do not build an ownership map. +executePlan :: + (Filesystem :> es) => + FilePath -> + [Operation] -> + Map FilePath ModuleName -> + ModuleName -> + UTCTime -> + Eff es (Map FilePath FileRecord) +executePlan targetDir ops ownerMap moduleName' now = do + let ownerFor dest = Map.findWithDefault moduleName' dest ownerMap + records <- mapM (executeOp targetDir ownerFor now) ops + pure (Map.fromList [(k, v) | Just (k, v) <- records]) + +-- | Execute a single operation and return a FileRecord if a file was written. +executeOp :: + (Filesystem :> es) => + FilePath -> + (FilePath -> ModuleName) -> + UTCTime -> + Operation -> + Eff es (Maybe (FilePath, FileRecord)) +executeOp targetDir ownerFor now op = case op of + WriteFileOp dest content strat -> do + let fullPath = targetDir dest + writeFileText fullPath content + let record = + FileRecord + { hash = hashContent content, + moduleName = ownerFor dest, + strategy = strat, + generatedAt = now + } + pure (Just (dest, record)) + CreateDirOp path -> do + let fullPath = targetDir path + createDirectoryIfMissing True fullPath + pure Nothing + CopyFileOp src dest -> do + let fullDest = targetDir dest + content <- readFileText src + writeFileText fullDest content + let record = + FileRecord + { hash = hashContent content, + moduleName = ownerFor dest, + strategy = Copy, + generatedAt = now + } + pure (Just (dest, record)) + RunCommandOp _ _ -> do + -- Command execution is deferred to the CLI layer. + pure Nothing + PatchFileOp dest newContent patchOp' strat modName -> do + let fullPath = targetDir dest + -- Read existing content if the file exists, otherwise start empty + exists <- doesFileExist fullPath + existing <- + if exists + then readFileText fullPath + else pure "" + -- Apply the patch with "#" as default comment prefix + case applyTextPatch patchOp' modName "#" existing newContent of + Left err -> error ("Patch failed: " <> T.unpack err) + Right merged -> do + writeFileText fullPath merged + let record = + FileRecord + { hash = hashContent merged, + moduleName = ownerFor dest, + strategy = strat, + generatedAt = now + } + pure (Just (dest, record)) + +-- | Format a human-readable description of the plan without executing anything. +dryRunPlan :: [Operation] -> Text +dryRunPlan ops = + if null ops + then "No operations to perform." + else T.unlines (map formatOp ops) + where + formatOp :: Operation -> Text + formatOp (WriteFileOp dest _ _) = " write " <> T.pack dest + formatOp (CreateDirOp path) = " mkdir " <> T.pack path + formatOp (CopyFileOp src dest) = " copy " <> T.pack src <> " -> " <> T.pack dest + formatOp (RunCommandOp cmd _) = " run " <> cmd + formatOp (PatchFileOp dest _ patchOp' _ modName) = + " patch " <> T.pack dest <> " (" <> formatPatchOp patchOp' <> " from " <> modName.unModuleName <> ")" + formatPatchOp AppendFile = "append-file" + formatPatchOp PrependFile = "prepend-file" + formatPatchOp AppendSection = "append-section" + formatPatchOp AppendLineIfAbsent = "append-line-if-absent" diff --git a/src/Seihou/Engine/Migrate.hs b/src/Seihou/Engine/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Migrate.hs @@ -0,0 +1,367 @@ +module Seihou.Engine.Migrate + ( -- * Engine types + MigrationFileStatus (..), + MigrationOpInstance (..), + ExecutedMigrationPlan (..), + MigrationExecError (..), + + -- * Engine entry points + classifyMigration, + executeMigration, + ) +where + +import Data.List (nub, sortBy) +import Data.Map.Strict qualified as Map +import Data.Ord (Down (..)) +import Data.Text qualified as T +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Seihou.Core.Migration + ( Migration (..), + MigrationOp (..), + MigrationPlan (..), + ) +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types + ( AppliedModule (..), + FileRecord (..), + Manifest (..), + ModuleName (..), + ) +import Seihou.Core.Version (renderVersion) +import Seihou.Effect.Filesystem + ( Filesystem, + createDirectoryIfMissing, + doesFileExist, + readFileText, + removeDirectoryIfEmpty, + removeDirectoryRecursive, + removeFile, + renamePath, + ) +import Seihou.Effect.Process (Process, runProcess) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Prelude +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory) + +-- ---------------------------------------------------------------------------- +-- Types +-- ---------------------------------------------------------------------------- + +-- | Per-file safety classification, mirroring 'Seihou.Engine.Remove'. +-- +-- * 'MFSafe' — disk hash matches the manifest's recorded hash; safe +-- to move or delete without losing user edits. +-- * 'MFConflict' — disk hash differs from the manifest's recorded hash; +-- the user has modified the file since generation and the engine +-- refuses to clobber it unless the caller passes @force = True@. +-- * 'MFGone' — file is absent on disk. The op is a no-op (target +-- of a delete already gone, source of a move already gone). +data MigrationFileStatus = MFSafe | MFConflict | MFGone + deriving stock (Eq, Show, Generic) + +-- | A 'MigrationOp' lifted to a concrete, classified instance ready to +-- execute or render. Move/delete *file* ops carry the file's status (so +-- the CLI can render conflicts up front); directory and command ops do +-- not — directories imply many files, and a command's effect is opaque. +data MigrationOpInstance + = MoveFileInst FilePath FilePath MigrationFileStatus + | MoveDirInst FilePath FilePath + | DeleteFileInst FilePath MigrationFileStatus + | DeleteDirInst FilePath + | RunCommandInst Text (Maybe FilePath) + deriving stock (Eq, Show, Generic) + +-- | The complete plan that 'classifyMigration' returns: the planner's +-- 'MigrationPlan' it was built from, and the linearized list of +-- concrete op instances in execution order. +data ExecutedMigrationPlan = ExecutedMigrationPlan + { planModule :: ModuleName, + planSource :: MigrationPlan, + planOps :: [MigrationOpInstance] + } + deriving stock (Eq, Show, Generic) + +-- | Reasons the engine refuses to execute. 'MigrationConflict' carries +-- every disk path whose hash diverged from the manifest, so the CLI can +-- list them and tell the user what to inspect. +data MigrationExecError + = MigrationConflict [FilePath] + | MigrationCommandFailed Text Int + | MigrationUnsafePath Text FilePath Text + deriving stock (Eq, Show, Generic) + +-- ---------------------------------------------------------------------------- +-- classifyMigration +-- ---------------------------------------------------------------------------- + +-- | Walk a 'MigrationPlan' and produce a fully classified +-- 'ExecutedMigrationPlan'. The classification reads files from the +-- filesystem (for hash comparisons against the manifest) but does not +-- modify anything. +classifyMigration :: + (Filesystem :> es) => + Manifest -> + MigrationPlan -> + Eff es (Either MigrationExecError ExecutedMigrationPlan) +classifyMigration manifest plan = do + opsResult <- traverse (classifyOp manifest) (concatMap (.ops) plan.planSteps) + pure $ do + ops <- sequence opsResult + Right + ExecutedMigrationPlan + { planModule = ModuleName plan.planModule, + planSource = plan, + planOps = ops + } + +-- | Classify a single 'MigrationOp' against the manifest and disk. +classifyOp :: + (Filesystem :> es) => + Manifest -> + MigrationOp -> + Eff es (Either MigrationExecError MigrationOpInstance) +classifyOp manifest op = case op of + MoveFile {src, dest} -> + case (validateMigrationPath "move-file source" src, validateMigrationPath "move-file destination" dest) of + (Left err, _) -> pure (Left err) + (_, Left err) -> pure (Left err) + (Right safeSrc, Right safeDest) -> do + status <- classifyFile manifest safeSrc + pure (Right (MoveFileInst safeSrc safeDest status)) + MoveDir {src, dest} -> + pure $ + case (validateMigrationPath "move-dir source" src, validateMigrationPath "move-dir destination" dest) of + (Left err, _) -> Left err + (_, Left err) -> Left err + (Right safeSrc, Right safeDest) -> Right (MoveDirInst safeSrc safeDest) + DeleteFile {path} -> + case validateMigrationPath "delete-file path" path of + Left err -> pure (Left err) + Right safePath -> do + status <- classifyFile manifest safePath + pure (Right (DeleteFileInst safePath status)) + DeleteDir {path} -> + pure $ + case validateMigrationPath "delete-dir path" path of + Left err -> Left err + Right safePath -> Right (DeleteDirInst safePath) + RunCommand {run, workDir} -> + pure $ + case traverse (validateMigrationPath "run-command workDir") workDir of + Left err -> Left err + Right safeWorkDir -> Right (RunCommandInst run safeWorkDir) + +validateMigrationPath :: Text -> FilePath -> Either MigrationExecError FilePath +validateMigrationPath label path = + case validateProjectRelativePath (T.pack path) of + Left reason -> Left (MigrationUnsafePath label path reason) + Right safePath -> Right safePath + +-- | Compare the disk copy of a file to the manifest's recorded hash. +-- Returns 'MFGone' if the file is missing, 'MFSafe' if the manifest has +-- no record (the migration is targeting a file the engine isn't tracking +-- — treat as safe), 'MFSafe' if hashes match, 'MFConflict' otherwise. +classifyFile :: + (Filesystem :> es) => + Manifest -> + FilePath -> + Eff es MigrationFileStatus +classifyFile manifest path = do + exists <- doesFileExist path + if not exists + then pure MFGone + else case Map.lookup path (manifest.files :: Map FilePath FileRecord) of + Nothing -> pure MFSafe + Just rec -> do + content <- readFileText path + let diskHash = hashContent content + if diskHash == rec.hash + then pure MFSafe + else pure MFConflict + +-- ---------------------------------------------------------------------------- +-- executeMigration +-- ---------------------------------------------------------------------------- + +-- | Execute a previously classified plan. On a conflict that isn't +-- forced, returns 'Left (MigrationConflict ...)' without touching disk. +-- Otherwise runs every op in declaration order, rewrites the manifest's +-- @files@ map to reflect new paths, bumps @genAt@ to the supplied +-- timestamp, and updates the named 'AppliedModule''s @moduleVersion@ to +-- @planTo@ (the user's supplied target). When the source plan has an +-- empty 'planSteps' list, no file ops run but the manifest still +-- advances to @planTo@ — this is the "pure version bump" path. +executeMigration :: + (Filesystem :> es, Process :> es) => + -- | If 'True', proceed even when files are 'MFConflict'. Mirrors the + -- @--force@ flag on @seihou remove@. + Bool -> + ExecutedMigrationPlan -> + Manifest -> + -- | New @genAt@ timestamp to stamp on the rewritten manifest. + UTCTime -> + Eff es (Either MigrationExecError Manifest) +executeMigration force plan manifest now = do + let conflicts = + [ p + | inst <- plan.planOps, + (p, MFConflict) <- toFileStatus inst + ] + if not force && not (null conflicts) + then pure (Left (MigrationConflict conflicts)) + else do + result <- runOps plan.planOps manifest [] + case result of + Left err -> pure (Left err) + Right (man', removedDirs) -> do + cleanupEmptyDirs removedDirs + let bumped = + man' + { genAt = now, + modules = map (bumpVersion plan.planModule plan.planSource) man'.modules + } + pure (Right bumped) + +-- | Pull (path, status) pairs out of an op for conflict detection. Only +-- file-targeted ops (MoveFile, DeleteFile) contribute; directory ops are +-- not classified per-file at this layer. +toFileStatus :: MigrationOpInstance -> [(FilePath, MigrationFileStatus)] +toFileStatus (MoveFileInst p _ s) = [(p, s)] +toFileStatus (DeleteFileInst p s) = [(p, s)] +toFileStatus _ = [] + +-- | Apply each op in order. Returns the updated manifest and the list +-- of paths whose parent directories may now be empty (so the caller can +-- prune them, mirroring 'Seihou.Engine.Remove'). +runOps :: + (Filesystem :> es, Process :> es) => + [MigrationOpInstance] -> + Manifest -> + -- | Accumulated removed paths (reverse order; reversed by caller as needed) + [FilePath] -> + Eff es (Either MigrationExecError (Manifest, [FilePath])) +runOps [] manifest acc = pure (Right (manifest, acc)) +runOps (op : rest) manifest acc = case op of + -- For move/delete, re-check disk existence at execute time. The + -- classified status is computed before any chain ops run, so a + -- previous step in the chain may have created or removed files + -- since then. The classified status is still authoritative for the + -- up-front conflict check (we never silently overwrite a + -- user-edited file without --force), but the disk action itself + -- must be defensive. + MoveFileInst src dest _status -> do + exists <- doesFileExist src + if exists + then do + ensureParentDir dest + renamePath src dest + runOps rest (renameInManifest src dest manifest) (src : acc) + else runOps rest (renameInManifest src dest manifest) acc + MoveDirInst src dest -> do + ensureParentDir dest + renamePath src dest + runOps rest (renameDirInManifest src dest manifest) (src : acc) + DeleteFileInst p _status -> do + exists <- doesFileExist p + if exists + then do + removeFile p + runOps rest (dropFromManifest p manifest) (p : acc) + else runOps rest (dropFromManifest p manifest) acc + DeleteDirInst p -> do + removeDirectoryRecursive p + runOps rest (dropDirFromManifest p manifest) (p : acc) + RunCommandInst run mWorkDir -> do + (code, _stdout, stderr) <- runProcess "/bin/sh" ["-c", run] mWorkDir + case code of + ExitSuccess -> runOps rest manifest acc + ExitFailure n -> + let msg = if T.null stderr then run else stderr + in pure (Left (MigrationCommandFailed msg n)) + +-- ---------------------------------------------------------------------------- +-- Manifest rewrites +-- ---------------------------------------------------------------------------- + +-- | Rewrite a single key from @src@ to @dest@ in the manifest's @files@ +-- map. If the key isn't present, the manifest is returned unchanged. +renameInManifest :: FilePath -> FilePath -> Manifest -> Manifest +renameInManifest src dest manifest = + case Map.lookup src manifest.files of + Nothing -> manifest + Just rec -> + manifest + { files = Map.insert dest rec (Map.delete src manifest.files) + } + +-- | Rewrite every @files@ key whose path is @src@ or under @src/@ to +-- replace the prefix with @dest@. +renameDirInManifest :: FilePath -> FilePath -> Manifest -> Manifest +renameDirInManifest src dest manifest = + let prefix = src <> "/" + rewriteKey k + | k == src = dest + | prefix `isPrefixOfPath` k = dest <> "/" <> drop (length prefix) k + | otherwise = k + in manifest {files = Map.mapKeys rewriteKey manifest.files} + +-- | Drop a single file entry from the manifest. +dropFromManifest :: FilePath -> Manifest -> Manifest +dropFromManifest p manifest = + manifest {files = Map.delete p manifest.files} + +-- | Drop every file entry whose path is @path@ or under @path/@. +dropDirFromManifest :: FilePath -> Manifest -> Manifest +dropDirFromManifest path manifest = + let prefix = path <> "/" + keep k = k /= path && not (prefix `isPrefixOfPath` k) + in manifest {files = Map.filterWithKey (\k _ -> keep k) manifest.files} + +-- | Update the named applied module's @moduleVersion@ to the plan's +-- target. Other applied modules are untouched. +bumpVersion :: ModuleName -> MigrationPlan -> AppliedModule -> AppliedModule +bumpVersion modName plan am + | am.name == modName = + am {moduleVersion = Just (renderVersion plan.planTo)} + | otherwise = am + +-- ---------------------------------------------------------------------------- +-- Helpers (shared with Engine.Remove patterns) +-- ---------------------------------------------------------------------------- + +-- | Try to remove now-empty parent directories of the given paths. +cleanupEmptyDirs :: (Filesystem :> es) => [FilePath] -> Eff es () +cleanupEmptyDirs paths = do + let parentDirs = nub $ concatMap allParents paths + sorted = sortBy (\a b -> compare (Down (length a)) (Down (length b))) parentDirs + mapM_ removeDirectoryIfEmpty sorted + +allParents :: FilePath -> [FilePath] +allParents p = go (takeDirectory p) + where + go "." = [] + go "" = [] + go "/" = [] + go d = d : go (takeDirectory d) + +-- | Ensure the parent directory of a destination path exists. Used +-- before 'renamePath' so callers don't have to author moves that +-- happen to land where the engine has already created an intermediate +-- directory. Skips the call when the parent is the project root +-- itself (@.@) — 'createDirectoryIfMissing' on @.@ is a no-op anyway. +ensureParentDir :: (Filesystem :> es) => FilePath -> Eff es () +ensureParentDir dest = + let parent = takeDirectory dest + in case parent of + "" -> pure () + "." -> pure () + d -> createDirectoryIfMissing True d + +-- | Local copy of the prefix predicate used in 'Seihou.Effect.FilesystemPure'. +isPrefixOfPath :: String -> String -> Bool +isPrefixOfPath [] _ = True +isPrefixOfPath _ [] = False +isPrefixOfPath (x : xs) (y : ys) = x == y && isPrefixOfPath xs ys diff --git a/src/Seihou/Engine/Plan.hs b/src/Seihou/Engine/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Plan.hs @@ -0,0 +1,369 @@ +module Seihou.Engine.Plan + ( compilePlan, + parentDirs, + ) +where + +import Control.Exception (IOException, SomeException, catch, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.Encode.Pretty qualified as AesonPretty +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Void (Void) +import Data.Yaml qualified as Yaml +import Dhall qualified +import Dhall.Core qualified as DhallCore +import Dhall.Src (Src) +import Seihou.Core.Expr (evalExpr) +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types +import Seihou.Engine.DhallJSON (dhallExprToJSON) +import Seihou.Engine.Template (renderCommand, renderDestPath, renderTemplate, renderTemplateText) +import Seihou.Prelude +import System.FilePath (takeDirectory, takeExtension) + +-- | Compile a module's steps into a list of filesystem operations. +-- Evaluates @when@ conditions, dispatches by strategy, reads source files, +-- renders templates, and expands destination paths. +compilePlan :: + FilePath -> -- Module base directory (containing @files/@) + Module -> + Map VarName VarValue -> -- Resolved variable values + IO (Either [Text] [Operation]) +compilePlan baseDir modul vars = do + let modName = modul.name + results <- mapM (compileStep baseDir modName vars) modul.steps + let (allErrors, allOps) = partitionResults results + if null allErrors + then case compileCommands vars modul.commands of + Left cmdErrs -> pure (Left cmdErrs) + Right cmdOps -> pure (Right (deduplicateDirs (concat allOps) ++ cmdOps)) + else pure (Left (concat allErrors)) + +-- | Compile commands into 'RunCommandOp' operations, interpolating +-- @{{var}}@ placeholders in the @run@ and @workDir@ fields. +-- Commands whose @when@ condition evaluates to False are skipped. +compileCommands :: Map VarName VarValue -> [Command] -> Either [Text] [Operation] +compileCommands vars = foldl' go (Right []) + where + go (Left errs) cmd = Left (errs ++ compileErrors cmd) + go (Right ops) cmd = + let shouldRun = case cmd.condition of + Nothing -> True + Just expr -> evalExpr vars expr + in if shouldRun + then case compileOneCommand vars cmd of + Left cmdErrs -> Left cmdErrs + Right op -> Right (ops ++ [op]) + else Right ops + + compileErrors cmd = case compileOneCommand vars cmd of + Left es -> es + Right _ -> [] + +-- | Compile a single command, interpolating placeholders in @run@ and @workDir@. +compileOneCommand :: Map VarName VarValue -> Command -> Either [Text] Operation +compileOneCommand vars cmd = + case renderCommand cmd.run vars of + Left placeholderErrors -> Left (map formatPlaceholderError placeholderErrors) + Right runText -> + case cmd.workDir of + Nothing -> Right (RunCommandOp runText Nothing) + Just wd -> + case renderCommand wd vars of + Left placeholderErrors -> Left (map formatPlaceholderError placeholderErrors) + Right renderedWd -> + case validateRenderedCommandWorkDir renderedWd of + Left err -> Left [err] + Right safeWd -> Right (RunCommandOp runText (Just (T.unpack safeWd))) + +-- | Compile a single step into operations (or skip it). +-- If the step has a patch operation, it produces a 'PatchFileOp'; otherwise +-- dispatches by strategy to produce a 'WriteFileOp'. +compileStep :: + FilePath -> + ModuleName -> + Map VarName VarValue -> + Step -> + IO (Either [Text] [Operation]) +compileStep baseDir modName vars step = do + -- Evaluate the when condition + let shouldRun = case step.condition of + Nothing -> True + Just expr -> evalExpr vars expr + if not shouldRun + then pure (Right []) + else case step.patch of + Just _ -> compilePatchStep baseDir vars modName step + Nothing -> case step.strategy of + Copy -> compileCopyStep baseDir vars step + Template -> compileTemplateStep baseDir vars step + DhallText -> compileDhallTextStep baseDir vars step + Structured -> compileStructuredStep baseDir vars step + +-- | Compile a Copy step: read the source file and write it to the destination. +compileCopyStep :: + FilePath -> + Map VarName VarValue -> + Step -> + IO (Either [Text] [Operation]) +compileCopyStep baseDir vars step = do + let srcPath = baseDir "files" step.src + result <- tryReadFile srcPath + case result of + Left err -> pure (Left [err]) + Right content -> + case renderDestPath step.dest vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right dest -> + pure (writeFileOps dest content Copy) + +-- | Compile a Template step: read, render placeholders, write. +compileTemplateStep :: + FilePath -> + Map VarName VarValue -> + Step -> + IO (Either [Text] [Operation]) +compileTemplateStep baseDir vars step = do + let srcPath = baseDir "files" step.src + result <- tryReadFile srcPath + case result of + Left err -> pure (Left [err]) + Right content -> + case renderTemplateText content vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right rendered -> + case renderDestPath step.dest vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right dest -> + pure (writeFileOps dest rendered Template) + +-- | Compile a DhallText step: read source, substitute placeholders, evaluate as Dhall. +compileDhallTextStep :: + FilePath -> + Map VarName VarValue -> + Step -> + IO (Either [Text] [Operation]) +compileDhallTextStep baseDir vars step = do + let srcPath = baseDir "files" step.src + result <- tryReadFile srcPath + case result of + Left err -> pure (Left [err]) + Right content -> + case renderTemplate content vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right substituted -> do + dhallResult <- renderDhallText substituted + case dhallResult of + Left err -> pure (Left [err]) + Right evaluated -> + case renderDestPath step.dest vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right dest -> + pure (writeFileOps dest evaluated DhallText) + +-- | Compile a Structured step: read source, substitute placeholders, evaluate as Dhall, +-- then serialize to JSON or YAML based on the destination file extension. +compileStructuredStep :: + FilePath -> + Map VarName VarValue -> + Step -> + IO (Either [Text] [Operation]) +compileStructuredStep baseDir vars step = do + let srcPath = baseDir "files" step.src + result <- tryReadFile srcPath + case result of + Left err -> pure (Left [err]) + Right content -> + case renderTemplate content vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right substituted -> do + dhallResult <- evaluateDhallExpr substituted + case dhallResult of + Left err -> pure (Left [err]) + Right dhallExpr -> + case dhallExprToJSON dhallExpr of + Left err -> pure (Left [err]) + Right jsonValue -> + case renderDestPath step.dest vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right dest -> + case validateRenderedDestination dest of + Left err -> pure (Left [err]) + Right safeDest -> + case serializeByExtension (T.unpack safeDest) jsonValue of + Left err -> pure (Left [err]) + Right serialized -> pure (Right (writeFileOpsUnchecked safeDest serialized Structured)) + +-- | Compile a patch step: read source, render template, produce PatchFileOp. +-- The content rendering follows the step's strategy (Template renders placeholders, +-- Copy uses raw content, DhallText evaluates as Dhall). +compilePatchStep :: + FilePath -> + Map VarName VarValue -> + ModuleName -> + Step -> + IO (Either [Text] [Operation]) +compilePatchStep baseDir vars modName step = do + let srcPath = baseDir "files" step.src + patchOp' = case step.patch of + Just p -> p + Nothing -> error "compilePatchStep called without patch op" + result <- tryReadFile srcPath + case result of + Left err -> pure (Left [err]) + Right rawContent -> do + -- Render content based on strategy + contentResult <- case step.strategy of + Copy -> pure (Right rawContent) + Template -> + pure $ case renderTemplateText rawContent vars of + Left placeholderErrors -> Left (map formatPlaceholderError placeholderErrors) + Right rendered -> Right rendered + DhallText -> do + case renderTemplate rawContent vars of + Left placeholderErrors -> pure (Left (map formatPlaceholderError placeholderErrors)) + Right substituted -> do + dhallResult <- renderDhallText substituted + case dhallResult of + Left err -> pure (Left [err]) + Right evaluated -> pure (Right evaluated) + Structured -> + pure (Left ["Structured strategy cannot be used with patch operations"]) + case contentResult of + Left errs -> pure (Left errs) + Right content -> + case renderDestPath step.dest vars of + Left placeholderErrors -> + pure (Left (map formatPlaceholderError placeholderErrors)) + Right dest -> + pure (patchFileOps dest content patchOp' step.strategy modName) + +-- | Evaluate a Dhall expression and return the normalized AST. +evaluateDhallExpr :: Text -> IO (Either Text (DhallCore.Expr Src Void)) +evaluateDhallExpr dhallSource = do + result <- try (Dhall.inputExpr dhallSource) + case result of + Left (e :: SomeException) -> + pure (Left ("Dhall evaluation failed: " <> T.pack (show e))) + Right expr -> pure (Right expr) + +-- | Serialize a JSON Value to Text based on the destination file extension. +-- .json → pretty-printed JSON; .yaml or .yml → YAML; other → error. +serializeByExtension :: FilePath -> Aeson.Value -> Either Text Text +serializeByExtension dest value = + case takeExtension dest of + ".json" -> Right (TL.toStrict (TLE.decodeUtf8 (AesonPretty.encodePretty value)) <> "\n") + ".yaml" -> Right (TE.decodeUtf8 (Yaml.encode value)) + ".yml" -> Right (TE.decodeUtf8 (Yaml.encode value)) + ext -> Left ("Structured strategy: unsupported output format '" <> T.pack ext <> "' (expected .json, .yaml, or .yml)") + +-- | Evaluate a Dhall expression that produces Text. +renderDhallText :: Text -> IO (Either Text Text) +renderDhallText dhallSource = do + result <- try (Dhall.input Dhall.strictText dhallSource) + case result of + Left (e :: SomeException) -> + pure (Left ("Dhall evaluation failed: " <> T.pack (show e))) + Right t -> pure (Right t) + +validateRenderedDestination :: Text -> Either Text Text +validateRenderedDestination dest = + case validateProjectRelativePath dest of + Left err -> Left ("rendered destination " <> err) + Right safePath -> Right (T.pack safePath) + +validateRenderedCommandWorkDir :: Text -> Either Text Text +validateRenderedCommandWorkDir workDir = + case validateProjectRelativePath workDir of + Left err -> Left ("rendered command workDir " <> err) + Right safePath -> Right (T.pack safePath) + +writeFileOps :: Text -> Text -> Strategy -> Either [Text] [Operation] +writeFileOps dest content strategy = + case validateRenderedDestination dest of + Left err -> Left [err] + Right safeDest -> Right (writeFileOpsUnchecked safeDest content strategy) + +writeFileOpsUnchecked :: Text -> Text -> Strategy -> [Operation] +writeFileOpsUnchecked dest content strategy = + let destStr = T.unpack dest + dirOps = map (CreateDirOp . T.unpack) (parentDirs dest) + in dirOps ++ [WriteFileOp destStr content strategy] + +patchFileOps :: Text -> Text -> PatchOp -> Strategy -> ModuleName -> Either [Text] [Operation] +patchFileOps dest content patchOp' strategy modName = + case validateRenderedDestination dest of + Left err -> Left [err] + Right safeDest -> + let destStr = T.unpack safeDest + dirOps = map (CreateDirOp . T.unpack) (parentDirs safeDest) + in Right (dirOps ++ [PatchFileOp destStr content patchOp' strategy modName]) + +-- | Extract parent directories from a path. +-- @"src/Lib.hs"@ produces @["src"]@. +-- @"a/b/c.txt"@ produces @["a", "a/b"]@. +parentDirs :: Text -> [Text] +parentDirs path = + let dir = T.pack (takeDirectory (T.unpack path)) + in if dir == "." || T.null dir + then [] + else buildChain dir + +-- | Build the chain of parent directories. +-- @"a/b"@ produces @["a", "a/b"]@. +buildChain :: Text -> [Text] +buildChain dir = + let parts = T.splitOn "/" dir + prefixes = drop 1 (scanl (\acc p -> acc <> "/" <> p) "" parts) + trimmed = map (T.drop 1) prefixes -- remove leading / + in trimmed + +-- | Try to read a file, returning an error message on failure. +tryReadFile :: FilePath -> IO (Either Text Text) +tryReadFile path = + (Right <$> TIO.readFile path) `catch` handler + where + handler :: IOException -> IO (Either Text Text) + handler e = pure (Left ("failed to read file: " <> T.pack path <> ": " <> T.pack (show e))) + +-- | Format a placeholder error as a human-readable text message. +formatPlaceholderError :: PlaceholderError -> Text +formatPlaceholderError (UnresolvedPlaceholder (VarName name) lineNum) = + "unresolved placeholder '{{" <> name <> "}}' at line " <> T.pack (show lineNum) +formatPlaceholderError (MalformedPlaceholder raw lineNum) = + "malformed placeholder '" <> raw <> "' at line " <> T.pack (show lineNum) +formatPlaceholderError (UnterminatedIf lineNum) = + "unterminated {{#if}} opened at line " <> T.pack (show lineNum) +formatPlaceholderError (OrphanBlockToken tok lineNum) = + "stray " <> tok <> " at line " <> T.pack (show lineNum) +formatPlaceholderError (MalformedIfExpression expr lineNum parseErr) = + "malformed {{#if}} expression '" <> expr <> "' at line " <> T.pack (show lineNum) <> ": " <> parseErr + +-- | Deduplicate CreateDirOp operations while preserving order. +deduplicateDirs :: [Operation] -> [Operation] +deduplicateDirs = go Set.empty + where + go _ [] = [] + go seen (op@(CreateDirOp p) : rest) + | p `Set.member` seen = go seen rest + | otherwise = op : go (Set.insert p seen) rest + go seen (op : rest) = op : go seen rest + +-- | Partition a list of Either into errors and successes. +partitionResults :: [Either e a] -> ([e], [a]) +partitionResults = foldr step ([], []) + where + step (Left e) (errs, oks) = (e : errs, oks) + step (Right a) (errs, oks) = (errs, a : oks) diff --git a/src/Seihou/Engine/Preview.hs b/src/Seihou/Engine/Preview.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Preview.hs @@ -0,0 +1,192 @@ +module Seihou.Engine.Preview + ( FileStatus (..), + PreviewLine (..), + buildPreview, + renderPreviewPlain, + formatPlanView, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Prelude + +-- | Status of a file relative to the manifest and disk. +data FileStatus + = FsNew + | FsModified + | FsUnchanged + | FsConflict + | FsOrphaned + | FsUnknown + deriving stock (Eq, Show) + +-- | One line in the dry-run preview. +data PreviewLine + = FilePreview + { previewStatus :: FileStatus, + previewPath :: FilePath, + previewAnnotation :: Text, + previewModule :: Maybe ModuleName + } + | DirPreview FilePath + | CommandPreview Text + | OrphanPreview FilePath ModuleName + deriving stock (Eq, Show) + +-- | Build a structured preview from operations and an optional diff result. +-- The ownership map tracks which module produced each file path. +-- When no DiffResult is provided (first run, no manifest), all file +-- operations are treated as new. +buildPreview :: [Operation] -> Maybe DiffResult -> Map FilePath ModuleName -> [PreviewLine] +buildPreview ops mDiff ownerMap = + let opLines = map (opToPreview mDiff ownerMap) ops + orphanLines = case mDiff of + Nothing -> [] + Just diff -> + -- Only include orphans whose path is NOT produced by any operation + let producedPaths = Set.fromList [p | op <- ops, Just p <- [destOfOp op]] + in [ OrphanPreview o.path o.moduleName + | o <- diff.orphaned, + not (Set.member o.path producedPaths) + ] + in opLines ++ orphanLines + +-- | Convert a single operation to a preview line. +opToPreview :: Maybe DiffResult -> Map FilePath ModuleName -> Operation -> PreviewLine +opToPreview mDiff ownerMap (WriteFileOp dest _ strat) = + FilePreview + { previewStatus = lookupStatus dest mDiff, + previewPath = dest, + previewAnnotation = strategyName strat, + previewModule = Map.lookup dest ownerMap + } +opToPreview _ _ (CreateDirOp path) = DirPreview path +opToPreview mDiff ownerMap (CopyFileOp _ dest) = + FilePreview + { previewStatus = lookupStatus dest mDiff, + previewPath = dest, + previewAnnotation = "copy", + previewModule = Map.lookup dest ownerMap + } +opToPreview _ _ (RunCommandOp cmd _) = CommandPreview cmd +opToPreview mDiff ownerMap (PatchFileOp dest _ _patchOp' _ modName') = + FilePreview + { previewStatus = lookupStatus dest mDiff, + previewPath = dest, + previewAnnotation = "patch", + previewModule = Just modName' + } + +-- | Look up a file's status in the diff result. +lookupStatus :: FilePath -> Maybe DiffResult -> FileStatus +lookupStatus _ Nothing = FsNew +lookupStatus path (Just diff) + | any (\f -> f.path == path) diff.new = FsNew + | any (\f -> f.path == path) diff.modified = FsModified + | path `elem` diff.unchanged = FsUnchanged + | any (\f -> f.path == path) diff.conflicts = FsConflict + | any (\f -> f.path == path) diff.orphaned = FsOrphaned + | otherwise = FsUnknown + +-- | Render preview lines as plain text (no ANSI codes). +renderPreviewPlain :: [PreviewLine] -> Text +renderPreviewPlain lines' = + if null lines' + then "No operations to perform.\n" + else T.unlines (map (renderPlainLine maxPathLen) fileLines ++ map renderNonFileLine nonFileLines) + where + fileLines = [l | l@(FilePreview {}) <- lines'] + nonFileLines = [l | l <- lines', not (isFileLine l)] + maxPathLen = maximum (0 : map (T.length . T.pack . (.previewPath)) fileLines) + +renderPlainLine :: Int -> PreviewLine -> Text +renderPlainLine maxPath (FilePreview status path annotation mMod) = + let pathText = T.pack path + pathPad = T.replicate (maxPath - T.length pathText) " " + modSuffix = case mMod of + Just mn -> ", " <> mn.unModuleName + Nothing -> "" + in " " <> statusTag status <> " " <> pathText <> pathPad <> " (" <> annotation <> modSuffix <> ")" +renderPlainLine _ other = renderNonFileLine other + +renderNonFileLine :: PreviewLine -> Text +renderNonFileLine (DirPreview path) = + " mkdir " <> T.pack path +renderNonFileLine (CommandPreview cmd) = + " run " <> cmd +renderNonFileLine (OrphanPreview path modName') = + " [orphaned] " <> T.pack path <> " (orphaned from " <> modName'.unModuleName <> ")" +renderNonFileLine _ = "" + +isFileLine :: PreviewLine -> Bool +isFileLine (FilePreview {}) = True +isFileLine _ = False + +statusTag :: FileStatus -> Text +statusTag FsNew = "[new]" +statusTag FsModified = "[modified]" +statusTag FsUnchanged = "[unchanged]" +statusTag FsConflict = "[conflict]" +statusTag FsOrphaned = "[orphaned]" +statusTag FsUnknown = "[unknown]" + +strategyName :: Strategy -> Text +strategyName Copy = "copy" +strategyName Template = "template" +strategyName DhallText = "dhall-text" +strategyName Structured = "structured" + +-- | Format a complete plan view with header, variables, operations, and summary. +formatPlanView :: [ModuleName] -> Map VarName VarValue -> [PreviewLine] -> DiffResult -> Text +formatPlanView moduleNames vars preview diff = + T.unlines $ + [header, ""] + ++ varsSection + ++ [" Operations:"] + ++ map (" " <>) (T.lines (renderPreviewPlain preview)) + ++ [""] + ++ [summaryText] + where + header = + "Generation Plan (" + <> T.intercalate " + " (map (.unModuleName) moduleNames) + <> "):" + + varsSection = + if Map.null vars + then [] + else + " Variables:" + : map formatVar (Map.toAscList vars) + ++ [""] + + maxVarLen = maximum (0 : map (\(VarName n, _) -> T.length n) (Map.toAscList vars)) + + formatVar (VarName name, val) = + let namePad = T.replicate (maxVarLen - T.length name) " " + in " " <> name <> namePad <> " = " <> showVarValue val + + showVarValue (VText t) = "\"" <> t <> "\"" + showVarValue (VBool True) = "true" + showVarValue (VBool False) = "false" + showVarValue (VInt n) = T.pack (show n) + showVarValue (VList vs) = "[" <> T.intercalate ", " (map showVarValue vs) <> "]" + + nFiles = length diff.new + length diff.modified + nConflicts = length diff.conflicts + summaryText = + " " + <> T.pack (show nFiles) + <> " files to write, " + <> T.pack (show nConflicts) + <> " conflicts" + +-- | Extract the destination path from a file-producing operation. +destOfOp :: Operation -> Maybe FilePath +destOfOp (WriteFileOp d _ _) = Just d +destOfOp (CopyFileOp _ d) = Just d +destOfOp (PatchFileOp d _ _ _ _) = Just d +destOfOp _ = Nothing diff --git a/src/Seihou/Engine/Remove.hs b/src/Seihou/Engine/Remove.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Remove.hs @@ -0,0 +1,356 @@ +module Seihou.Engine.Remove + ( RemovalFile (..), + RemovalPlan (..), + RemovalError (..), + RemovalOp (..), + RemovalFileStatus (..), + ExecutedRemovalPlan (..), + computeRemovalPlan, + executeRemoval, + buildRemovalOps, + executeRemovalOps, + ) +where + +import Control.Monad (foldM) +import Data.List (nub, sortBy) +import Data.Map.Strict qualified as Map +import Data.Ord (Down (..)) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Time (UTCTime) +import Seihou.Core.Path (validateProjectRelativePath) +import Seihou.Core.Types +import Seihou.Effect.Filesystem (Filesystem, doesFileExist, readFileText, removeDirectoryIfEmpty, removeFile, writeFileText) +import Seihou.Engine.Section (removeSection) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Prelude +import System.FilePath (takeDirectory) + +-- ============================================================ +-- Legacy types (used by current CLI handler, Milestone 4 replaces) +-- ============================================================ + +-- | Classification of a file during removal planning. +data RemovalFile + = -- | Disk hash matches manifest hash — safe to delete. + RemovalSafe FilePath + | -- | User modified the file since generation — needs confirmation. + RemovalConflict FilePath + | -- | File was already deleted from disk. + RemovalGone FilePath + deriving stock (Eq, Show) + +-- | A plan describing what files to remove for a given module. +data RemovalPlan = RemovalPlan + { targetModule :: ModuleName, + files :: [RemovalFile] + } + deriving stock (Eq, Show) + +-- ============================================================ +-- New step-based removal types +-- ============================================================ + +-- | A concrete removal operation ready to execute. +data RemovalOp + = -- | Delete a file, with its current status. + DeleteFileOp FilePath RemovalFileStatus + | -- | Strip this module's section markers from a file. + StripSectionOp FilePath + | -- | Apply a Dhall text function to rewrite a file. + RewriteOp FilePath FilePath + | -- | Run a shell command during removal. + RemovalCommandOp Text (Maybe Text) + deriving stock (Eq, Show) + +-- | Status of a file targeted for deletion. +data RemovalFileStatus + = -- | Disk hash matches manifest — safe to delete. + RFSafe + | -- | User modified the file since generation. + RFConflict + | -- | File already deleted from disk. + RFGone + deriving stock (Eq, Show) + +-- | A removal plan built from declared removal steps. +data ExecutedRemovalPlan = ExecutedRemovalPlan + { targetModule :: ModuleName, + ops :: [RemovalOp] + } + deriving stock (Eq, Show) + +-- | Errors that prevent removal. +data RemovalError + = -- | The module is not in the manifest's applied modules list. + ModuleNotApplied ModuleName + | -- | The module has no removal specification. + ModuleNotRemovable ModuleName + | -- | A module-declared removal path would escape the project root. + RemovalUnsafePath Text Text Text + deriving stock (Eq, Show) + +-- ============================================================ +-- Legacy compute/execute (preserves current CLI behavior) +-- ============================================================ + +-- | Compute a removal plan for the given module. +-- Checks that the module is applied and has a removal spec, then classifies +-- each file it owns as safe, conflicted, or already gone. +computeRemovalPlan :: + (Filesystem :> es) => + Manifest -> + ModuleName -> + Eff es (Either RemovalError RemovalPlan) +computeRemovalPlan manifest modName = do + case findApplied manifest modName of + Nothing -> pure (Left (ModuleNotApplied modName)) + Just am + | Nothing <- am.removal -> pure (Left (ModuleNotRemovable modName)) + | otherwise -> do + let ownedFiles = moduleFiles manifest modName + classified <- mapM classifyForRemoval ownedFiles + pure (Right (RemovalPlan {targetModule = modName, files = classified})) + +-- | Execute a removal plan: delete files, clean up empty directories, +-- and return the updated manifest. +executeRemoval :: + (Filesystem :> es) => + Manifest -> + RemovalPlan -> + Set FilePath -> + UTCTime -> + Eff es Manifest +executeRemoval manifest plan keepSet now = do + let toDelete = filesToDelete plan keepSet + mapM_ removeFile toDelete + cleanupEmptyDirs toDelete + pure (removeFromManifest manifest plan.targetModule now) + +-- ============================================================ +-- New step-based removal engine +-- ============================================================ + +-- | Build a list of removal operations from declared removal steps. +-- Classifies remove-file targets by checking the manifest and disk state. +buildRemovalOps :: + (Filesystem :> es) => + Manifest -> + ModuleName -> + Removal -> + Eff es (Either RemovalError ExecutedRemovalPlan) +buildRemovalOps manifest modName removal = do + case findApplied manifest modName of + Nothing -> pure (Left (ModuleNotApplied modName)) + Just _ -> do + stepResults <- mapM (buildStepOp manifest modName) removal.removalSteps + let cmdResults = map buildCommandOp removal.removalCommands + pure $ do + stepOps <- sequence stepResults + cmdOps <- sequence cmdResults + Right + ExecutedRemovalPlan + { targetModule = modName, + ops = stepOps ++ cmdOps + } + +-- | Build a single removal operation from a removal step. +buildStepOp :: + (Filesystem :> es) => + Manifest -> + ModuleName -> + RemovalStep -> + Eff es (Either RemovalError RemovalOp) +buildStepOp manifest _modName step = case step.action of + RemoveFileAction -> + case validateRemovalPath "remove-file destination" step.dest of + Left err -> pure (Left err) + Right path -> do + status <- classifyFileStatus manifest path + pure (Right (DeleteFileOp path status)) + RemoveSectionAction -> + pure $ + case validateRemovalPath "remove-section destination" step.dest of + Left err -> Left err + Right path -> Right (StripSectionOp path) + RewriteFileAction -> + pure $ do + dest <- validateRemovalPath "rewrite-file destination" step.dest + src <- case step.src of + Just s -> validateRemovalPath "rewrite-file source" (T.pack s) + Nothing -> Left (RemovalUnsafePath "rewrite-file source" "" "path must not be empty") + Right (RewriteOp dest src) + +buildCommandOp :: Command -> Either RemovalError RemovalOp +buildCommandOp command = + case traverse (validateRemovalPath "remove-command workDir") command.workDir of + Left err -> Left err + Right safeWorkDir -> Right (RemovalCommandOp command.run (fmap T.pack safeWorkDir)) + +validateRemovalPath :: Text -> Text -> Either RemovalError FilePath +validateRemovalPath label path = + case validateProjectRelativePath path of + Left reason -> Left (RemovalUnsafePath label path reason) + Right safePath -> Right safePath + +-- | Classify a file's status for removal by comparing disk to manifest. +classifyFileStatus :: + (Filesystem :> es) => + Manifest -> + FilePath -> + Eff es RemovalFileStatus +classifyFileStatus manifest path = do + exists <- doesFileExist path + if not exists + then pure RFGone + else case Map.lookup path manifest.files of + Nothing -> pure RFSafe -- Not in manifest, treat as safe to delete + Just rec -> do + content <- readFileText path + let diskHash = hashContent content + if diskHash == rec.hash + then pure RFSafe + else pure RFConflict + +-- | Execute a list of removal operations and return the updated manifest. +executeRemovalOps :: + (Filesystem :> es) => + Manifest -> + ExecutedRemovalPlan -> + Set FilePath -> + UTCTime -> + Eff es Manifest +executeRemovalOps manifest plan keepSet now = do + let modName = plan.targetModule + deletedPaths <- foldM (execOp modName keepSet) [] plan.ops + cleanupEmptyDirs deletedPaths + pure (removeFromManifest manifest modName now) + +-- | Execute a single removal operation. Returns accumulated deleted paths. +execOp :: + (Filesystem :> es) => + ModuleName -> + Set FilePath -> + [FilePath] -> + RemovalOp -> + Eff es [FilePath] +execOp _ keepSet acc (DeleteFileOp path status) = + if Set.member path keepSet + then pure acc + else case status of + RFSafe -> do + removeFile path + pure (path : acc) + RFConflict -> do + -- Conflicts are deleted unless in keepSet (handled by CLI) + removeFile path + pure (path : acc) + RFGone -> pure acc +execOp modName _ acc (StripSectionOp path) = do + exists <- doesFileExist path + if exists + then do + content <- readFileText path + let prefix = guessCommentPrefix path + cleaned = removeSection modName prefix content + writeFileText path cleaned + pure acc + else pure acc +execOp _ _ acc (RewriteOp _ _) = do + -- RewriteFileAction is deferred to a future milestone (requires Dhall eval) + pure acc +execOp _ _ acc (RemovalCommandOp _ _) = do + -- Commands are executed by the CLI handler, not the engine + pure acc + +-- | Guess the comment prefix for a file based on its extension. +guessCommentPrefix :: FilePath -> Text +guessCommentPrefix path + | ".hs" `T.isSuffixOf` T.pack path = "--" + | ".cabal" `T.isSuffixOf` T.pack path = "--" + | ".yaml" `T.isSuffixOf` T.pack path = "#" + | ".yml" `T.isSuffixOf` T.pack path = "#" + | ".toml" `T.isSuffixOf` T.pack path = "#" + | ".nix" `T.isSuffixOf` T.pack path = "#" + | otherwise = "#" + +-- ============================================================ +-- Shared helpers +-- ============================================================ + +-- | Find an applied module by name. +findApplied :: Manifest -> ModuleName -> Maybe AppliedModule +findApplied manifest modName = + case filter (\am -> am.name == modName) manifest.modules of + (am : _) -> Just am + [] -> Nothing + +-- | Get the file paths owned by a module in the manifest. +moduleFiles :: Manifest -> ModuleName -> [(FilePath, FileRecord)] +moduleFiles manifest modName = + [ (path, rec) + | (path, rec) <- Map.toList manifest.files, + rec.moduleName == modName + ] + +-- | Classify a single file for removal (legacy). +classifyForRemoval :: (Filesystem :> es) => (FilePath, FileRecord) -> Eff es RemovalFile +classifyForRemoval (path, rec) = do + exists <- doesFileExist path + if not exists + then pure (RemovalGone path) + else do + content <- readFileText path + let diskHash = hashContent content + if diskHash == rec.hash + then pure (RemovalSafe path) + else pure (RemovalConflict path) + +-- | Determine which files should actually be deleted. +filesToDelete :: RemovalPlan -> Set FilePath -> [FilePath] +filesToDelete plan keepSet = + [ path + | rf <- plan.files, + let path = removalFilePath rf, + shouldDelete rf, + not (Set.member path keepSet) + ] + where + shouldDelete (RemovalSafe _) = True + shouldDelete (RemovalConflict _) = True + shouldDelete (RemovalGone _) = False + +-- | Extract the path from a RemovalFile. +removalFilePath :: RemovalFile -> FilePath +removalFilePath (RemovalSafe p) = p +removalFilePath (RemovalConflict p) = p +removalFilePath (RemovalGone p) = p + +-- | After deleting files, try to remove their now-empty parent directories. +-- Walks parents bottom-up (deepest first) to correctly cascade. +cleanupEmptyDirs :: (Filesystem :> es) => [FilePath] -> Eff es () +cleanupEmptyDirs paths = do + let parentDirs = nub $ concatMap allParents paths + -- Sort deepest-first so children are removed before parents + sorted = sortBy (\a b -> compare (Down (length a)) (Down (length b))) parentDirs + mapM_ removeDirectoryIfEmpty sorted + +-- | Get all parent directories of a path, excluding "." and "". +allParents :: FilePath -> [FilePath] +allParents path = go (takeDirectory path) + where + go "." = [] + go "" = [] + go "/" = [] + go dir = dir : go (takeDirectory dir) + +-- | Remove a module and its files from the manifest. +removeFromManifest :: Manifest -> ModuleName -> UTCTime -> Manifest +removeFromManifest manifest modName now = + manifest + { modules = filter (\am -> am.name /= modName) manifest.modules, + files = Map.filter (\rec -> rec.moduleName /= modName) manifest.files, + genAt = now + } diff --git a/src/Seihou/Engine/Section.hs b/src/Seihou/Engine/Section.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Section.hs @@ -0,0 +1,104 @@ +module Seihou.Engine.Section + ( SectionMarker (..), + renderSectionOpen, + renderSectionClose, + wrapInSection, + removeSection, + applyTextPatch, + ) +where + +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Prelude + +-- | A section marker identifies content contributed by a module. +data SectionMarker = SectionMarker + { sectionPrefix :: Text, + sectionModule :: ModuleName + } + deriving stock (Eq, Show) + +-- | Render an opening section marker line. +-- Result: @"# --- seihou:haskell-base ---\\n"@ +renderSectionOpen :: SectionMarker -> Text +renderSectionOpen marker = + marker.sectionPrefix <> " --- seihou:" <> marker.sectionModule.unModuleName <> " ---\n" + +-- | Render a closing section marker line. +-- Result: @"# --- /seihou:haskell-base ---\\n"@ +renderSectionClose :: SectionMarker -> Text +renderSectionClose marker = + marker.sectionPrefix <> " --- /seihou:" <> marker.sectionModule.unModuleName <> " ---\n" + +-- | Wrap content in section markers. +wrapInSection :: SectionMarker -> Text -> Text +wrapInSection marker content = + renderSectionOpen marker <> content <> ensureTrailingNewline content <> renderSectionClose marker + where + ensureTrailingNewline t + | T.null t = "" + | T.last t == '\n' = "" + | otherwise = "\n" + +-- | Remove a module's section from file content. +-- +-- Strips all lines between the opening and closing section markers (inclusive) +-- for the given module name. The comment prefix (e.g., @"#"@) determines +-- the marker format. If no matching markers are found, the content is returned +-- unchanged. Cleans up resulting double blank lines. +removeSection :: ModuleName -> Text -> Text -> Text +removeSection modName prefix content = + let marker = SectionMarker {sectionPrefix = prefix, sectionModule = modName} + openTag = T.stripEnd (renderSectionOpen marker) + closeTag = T.stripEnd (renderSectionClose marker) + ls = T.lines content + filtered = dropSection openTag closeTag ls + cleaned = collapseBlankLines filtered + in if null cleaned + then "" + else T.unlines cleaned + where + dropSection _ _ [] = [] + dropSection open close (l : rest) + | T.stripEnd l == open = + -- Skip until we find the close tag + case dropWhile (\x -> T.stripEnd x /= close) rest of + [] -> [] -- Close tag not found, drop remaining + (_ : after) -> dropSection open close after + | otherwise = l : dropSection open close rest + + collapseBlankLines [] = [] + collapseBlankLines [x] = [x] + collapseBlankLines (x : y : rest) + | T.null (T.strip x) && T.null (T.strip y) = collapseBlankLines (y : rest) + | otherwise = x : collapseBlankLines (y : rest) + +-- | Apply a patch operation to existing content. +-- +-- @applyTextPatch patchOp moduleName commentPrefix existingContent newContent@ +-- +-- Returns the merged content or an error. +applyTextPatch :: PatchOp -> ModuleName -> Text -> Text -> Text -> Either Text Text +applyTextPatch AppendFile _ _ existing new = + Right (ensureTrailingNewline existing <> new) +applyTextPatch PrependFile _ _ existing new = + Right (ensureTrailingNewline new <> existing) +applyTextPatch AppendSection modName prefix existing new = + let marker = SectionMarker {sectionPrefix = prefix, sectionModule = modName} + in Right (ensureTrailingNewline existing <> wrapInSection marker new) +applyTextPatch AppendLineIfAbsent _ _ existing new = + let existingLines = map T.stripEnd (T.lines existing) + newLines = filter (not . T.null . T.strip) (T.lines (T.stripEnd new)) + missing = filter (\l -> T.stripEnd l `notElem` existingLines) newLines + in if null missing + then Right existing + else Right (ensureTrailingNewline existing <> T.unlines missing) + +-- | Ensure text ends with a newline. Returns the text unchanged if it already +-- ends with one, or with an appended newline if not. Returns empty text unchanged. +ensureTrailingNewline :: Text -> Text +ensureTrailingNewline t + | T.null t = t + | T.last t == '\n' = t + | otherwise = t <> "\n" diff --git a/src/Seihou/Engine/Template.hs b/src/Seihou/Engine/Template.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Template.hs @@ -0,0 +1,373 @@ +module Seihou.Engine.Template + ( renderTemplate, + renderTemplateText, + expandConditionals, + extractIfExprs, + valueToText, + renderDestPath, + renderCommand, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Expr (evalExpr, parseExpr) +import Seihou.Core.Types +import Seihou.Prelude + +-- | Convert a variable value to its text representation for template output. +valueToText :: VarValue -> Text +valueToText (VText t) = t +valueToText (VBool True) = "true" +valueToText (VBool False) = "false" +valueToText (VInt n) = T.pack (show n) +valueToText (VList vs) = T.intercalate "," (map valueToText vs) + +-- | Render a template by substituting @{{placeholder}}@ occurrences. +-- The escape sequence @\\{{@ produces a literal @{{@ in the output. +-- Returns either a list of errors or the rendered text. +renderTemplate :: Text -> Map VarName VarValue -> Either [PlaceholderError] Text +renderTemplate template vars = + let lns = T.splitOn "\n" template + results = zipWith (renderLine vars) [1 ..] lns + (allErrors, renderedLines) = partitionResults results + in if null allErrors + then Right (T.intercalate "\n" renderedLines) + else Left (concat allErrors) + +-- | Render a template body supporting both @{{placeholder}}@ substitution +-- and @{{#if}}\/{{#else}}\/{{\/if}}@ conditional blocks with unbounded +-- nesting. Expression syntax inside @{{#if …}}@ is the same grammar used +-- by a step's @when@ clause ('Seihou.Core.Expr.parseExpr'). +-- +-- Runs in two passes: 'expandConditionals' consumes block tokens and +-- emits plain template text, then 'renderTemplate' performs @{{var}}@ +-- substitution on the expanded text. +-- +-- Intended for template bodies only. Destination paths and shell +-- commands stay on 'renderDestPath' \/ 'renderCommand'. +renderTemplateText :: Text -> Map VarName VarValue -> Either [PlaceholderError] Text +renderTemplateText template vars = + case expandConditionals vars template of + Left errs -> Left errs + Right expanded -> renderTemplate expanded vars + +-- | Extract the raw expression text from every @{{#if …}}@ opener in a +-- template body, in document order. Used by authoring-time lint to scan +-- template conditionals without expanding them; each returned string is +-- intended to be fed to 'parseExpr'. Nesting is irrelevant here — every +-- opener is reported, regardless of depth. A malformed (unterminated) +-- opener stops the scan, mirroring 'splitNextBlock'. +extractIfExprs :: Text -> [Text] +extractIfExprs = go + where + go t = case T.breakOn "{{#if " t of + (_, "") -> [] + (_, match) -> + let afterOpen = T.drop 6 match -- skip "{{#if " + in case T.breakOn "}}" afterOpen of + (_, "") -> [] -- unterminated opener; stop + (exprRaw, rest) -> T.strip exprRaw : go (T.drop 2 rest) + +-- | Render destination path placeholders (same substitution logic). +renderDestPath :: Text -> Map VarName VarValue -> Either [PlaceholderError] Text +renderDestPath = renderTemplate + +-- | Render placeholders in a shell command string. +-- Same substitution as 'renderTemplate' but named for clarity at call sites. +renderCommand :: Text -> Map VarName VarValue -> Either [PlaceholderError] Text +renderCommand = renderTemplate + +-- | Render a single line, returning errors or the rendered text. +renderLine :: Map VarName VarValue -> Int -> Text -> Either [PlaceholderError] Text +renderLine vars lineNum line = + case scanLine vars lineNum line of + ([], rendered) -> Right rendered + (errs, _) -> Left errs + +-- | Scan a line for placeholders and substitute them. +-- Returns accumulated errors and the rendered text. +scanLine :: Map VarName VarValue -> Int -> Text -> ([PlaceholderError], Text) +scanLine vars lineNum = go + where + go :: Text -> ([PlaceholderError], Text) + go txt + | T.null txt = ([], "") + | "\\{{" `T.isPrefixOf` txt = + -- Escape sequence: produce literal {{ + let (errs, rest) = go (T.drop 3 txt) + in (errs, "{{" <> rest) + | "{{" `T.isPrefixOf` txt = + -- Placeholder: find the closing }} + let after = T.drop 2 txt + in case T.breakOn "}}" after of + (_, "") -> + -- No closing }}, treat as malformed + let raw = T.take 20 txt + (errs, rest) = go (T.drop 2 txt) + in (MalformedPlaceholder raw lineNum : errs, rest) + (varNameText, remaining) -> + let trimmed = T.strip varNameText + name = VarName trimmed + restAfter = T.drop 2 remaining -- skip the }} + in case Map.lookup name vars of + Just val -> + let (errs, rest) = go restAfter + in (errs, valueToText val <> rest) + Nothing -> + let (errs, rest) = go restAfter + in (UnresolvedPlaceholder name lineNum : errs, rest) + | otherwise = + -- Find the next {{ or \{{ occurrence + case findNextPlaceholder txt of + Nothing -> ([], txt) + Just idx -> + let (before, after) = T.splitAt idx txt + (errs, rest) = go after + in (errs, before <> rest) + +-- | Find the index of the next placeholder start (@{{@ or @\\{{@). +findNextPlaceholder :: Text -> Maybe Int +findNextPlaceholder txt = go 0 txt + where + go :: Int -> Text -> Maybe Int + go idx t + | T.null t = Nothing + | "\\{{" `T.isPrefixOf` t = Just idx + | "{{" `T.isPrefixOf` t = Just idx + | otherwise = go (idx + 1) (T.drop 1 t) + +-- | Partition a list of Either into errors and successes. +partitionResults :: [Either e a] -> ([e], [a]) +partitionResults = foldr step ([], []) + where + step (Left e) (errs, oks) = (e : errs, oks) + step (Right a) (errs, oks) = (errs, a : oks) + +-- | First-pass expander: consume @{{#if}}\/{{#else}}\/{{\/if}}@ block +-- tokens and emit plain template text with only the selected branches +-- retained. Supports arbitrary nesting depth. +-- +-- Exported for test access; in production code the recommended entry +-- point is 'renderTemplateText'. +expandConditionals :: Map VarName VarValue -> Text -> Either [PlaceholderError] Text +expandConditionals vars = expandAtTopLevel vars 1 + +-- | Expand at the top level: produce text until we hit @{{\/if}}@ or +-- @{{#else}}@ (which at top level are orphans). Only the selected +-- branch is expanded; the untaken branch is discarded, so errors +-- inside it do not surface. +-- +-- When a block tag is the only non-whitespace on its line (a +-- \"standalone block\" in the Mustache/Handlebars sense), the +-- surrounding indentation and the line\'s terminating newline are +-- consumed as part of the tag so the expanded text does not leave a +-- blank line behind. This is what lets module authors format a +-- template with tags on their own lines and still get clean output. +expandAtTopLevel :: Map VarName VarValue -> Int -> Text -> Either [PlaceholderError] Text +expandAtTopLevel vars startLine input = + case splitNextBlock input of + NoBlockLeft -> Right input + FoundIf before0 afterBlockOpen0 exprText -> + let beforeLines = T.count "\n" before0 + openAt = startLine + beforeLines + (before, afterBlockOpen, openerSkipped) = + trimStandaloneAround before0 afterBlockOpen0 + bodyStart = openAt + openerSkipped + in case parseExpr exprText of + Left parseErr -> + Left [MalformedIfExpression exprText openAt parseErr] + Right expr -> do + (thenText, elseText, afterBlock, consumedLines, closerSkipped) <- + splitBranches openAt afterBlockOpen + let selectedRaw = + if evalExpr vars expr then thenText else elseText + selectedExpanded <- expandAtTopLevel vars bodyStart selectedRaw + let afterLine = openAt + openerSkipped + consumedLines + closerSkipped + rest <- expandAtTopLevel vars afterLine afterBlock + pure (before <> selectedExpanded <> rest) + FoundOrphan tok beforeLines -> + Left [OrphanBlockToken tok (startLine + beforeLines)] + +-- | Raw tokenisation result for the top-level scan. +data NextBlock + = -- | No block tokens in the remaining input. + NoBlockLeft + | -- | An @{{#if …}}@ block. @before@ is text preceding the opener; + -- @after@ is everything after the closing @}}@ of the opener + -- (i.e. the body plus whatever follows the matching @{{/if}}@); + -- @expr@ is the raw expression text. + FoundIf + { foundBefore :: Text, + foundAfter :: Text, + foundExpr :: Text + } + | -- | A @{{#else}}@ or @{{/if}}@ encountered before any matching + -- @{{#if}}@ at the current depth. The 'Int' is the line offset + -- (0-based) from the start of the scanned region. + FoundOrphan Text Int + +-- | Scan @input@ for the next block token at the outer level (i.e. for +-- the purpose of locating the next @{{#if}}@ opener, or an orphan if +-- one occurs first). +splitNextBlock :: Text -> NextBlock +splitNextBlock input = scan 0 input + where + scan :: Int -> Text -> NextBlock + scan pos t + | T.null t = NoBlockLeft + | "{{#if " `T.isPrefixOf` t = + let before = T.take pos input + afterOpen = T.drop 6 t -- skip "{{#if " + in case T.breakOn "}}" afterOpen of + (_, "") -> NoBlockLeft -- malformed; let higher-level handle + (exprRaw, rest) -> + let expr = T.strip exprRaw + afterCloseTag = T.drop 2 rest -- skip "}}" + in FoundIf + { foundBefore = before, + foundAfter = afterCloseTag, + foundExpr = expr + } + | "{{/if}}" `T.isPrefixOf` t = + FoundOrphan "{{/if}}" (lineOffset (T.take pos input)) + | "{{#else}}" `T.isPrefixOf` t = + FoundOrphan "{{#else}}" (lineOffset (T.take pos input)) + | otherwise = + let headChar = T.take 1 t + rest = T.drop 1 t + in scan (pos + T.length headChar) rest + +-- | Given the text immediately after an @{{#if …}}@ opener, find the +-- matching @{{\/if}}@ (honouring nested @{{#if}}@\/@{{\/if}}@ pairs) and +-- split the body at a top-level @{{#else}}@ if one is present. +-- +-- Returns @(thenBranch, elseBranch, afterCloseBlock, linesConsumedUpToAndIncludingClose, closerSkipped)@. +-- The @openLine@ parameter is the absolute source-line number of the +-- opener, used only when reporting 'UnterminatedIf'. +-- +-- Standalone-block trim is applied to the top-level @{{#else}}@ (if +-- present) and to the matching @{{\/if}}@. @closerSkipped@ is 1 when +-- the closer\'s trailing newline was absorbed by standalone trim and +-- 0 otherwise; callers add it to their own post-block line counter +-- so chained blocks at the same level report accurate line numbers. +splitBranches :: + Int -> + Text -> + Either [PlaceholderError] (Text, Text, Text, Int, Int) +splitBranches openLine bodyPlusTail = go 0 0 Nothing bodyPlusTail + where + -- depth: how many extra {{#if}} openers we've seen since the outer opener. + -- accLen: how much of @bodyPlusTail@ we've consumed (character count). + -- mElseAt: @Just accLen@ at the first top-level {{#else}}, if any. + go :: Int -> Int -> Maybe Int -> Text -> Either [PlaceholderError] (Text, Text, Text, Int, Int) + go _ _ _ t + | T.null t = Left [UnterminatedIf openLine] + go depth accLen mElseAt t + | "{{/if}}" `T.isPrefixOf` t && depth == 0 = + let (thenText0, elseText0) = case mElseAt of + Nothing -> (T.take accLen bodyPlusTail, "") + Just elseAt -> + ( T.take elseAt bodyPlusTail, + T.take (accLen - elseAt - elseTokenLen) (T.drop (elseAt + elseTokenLen) bodyPlusTail) + ) + afterClose0 = T.drop (accLen + ifCloseLen) bodyPlusTail + consumedLines = lineOffset (T.take (accLen + ifCloseLen) bodyPlusTail) + -- Trim standalone closer: the line's whitespace-before + -- lives at the tail of whichever branch ended at it + -- (elseText0 if present, otherwise thenText0), and the + -- whitespace+newline-after lives at the head of afterClose0. + (thenText, elseText, afterClose, closerSkipped) = + case mElseAt of + Nothing -> + let (tt, ac, n) = trimStandaloneAround thenText0 afterClose0 + in (tt, "", ac, n) + Just _ -> + -- First try to trim standalone {{#else}} between + -- thenText and elseText, then trim the closer. + let (tt, et0, _elseSkipped) = trimStandaloneAround thenText0 elseText0 + (et, ac, n) = trimStandaloneAround et0 afterClose0 + in (tt, et, ac, n) + in Right (thenText, elseText, afterClose, consumedLines, closerSkipped) + | "{{/if}}" `T.isPrefixOf` t = + advance (depth - 1) accLen mElseAt t ifCloseLen + | "{{#if " `T.isPrefixOf` t = + advance (depth + 1) accLen mElseAt t ifOpenPrefixLen + | "{{#else}}" `T.isPrefixOf` t && depth == 0 = + let newElseAt = case mElseAt of + Just existing -> Just existing + Nothing -> Just accLen + in advance depth accLen newElseAt t elseTokenLen + | "{{#else}}" `T.isPrefixOf` t = + advance depth accLen mElseAt t elseTokenLen + | otherwise = + advance depth accLen mElseAt t 1 + + advance :: + Int -> + Int -> + Maybe Int -> + Text -> + Int -> + Either [PlaceholderError] (Text, Text, Text, Int, Int) + advance depth accLen mElseAt t n = + let step = T.take n t + rest = T.drop n t + in go depth (accLen + T.length step) mElseAt rest + + ifOpenPrefixLen = T.length ("{{#if " :: Text) + ifCloseLen = T.length ("{{/if}}" :: Text) + elseTokenLen = T.length ("{{#else}}" :: Text) + +-- | Number of newlines in @t@; used to compute line offsets from +-- byte positions. +lineOffset :: Text -> Int +lineOffset = T.count "\n" + +-- | Standalone-block trim: if the tag sitting between @before@ and +-- @after@ is the only non-whitespace content on its line, strip the +-- surrounding indentation and the trailing newline. Returns the +-- trimmed pair and the number of newlines the trim absorbed (0 or 1) +-- so the caller can keep source-line tracking accurate. +-- +-- A tag qualifies as standalone iff: +-- +-- * the tail of @before@ since the last newline (or since the start +-- of @before@ when there is no prior newline) consists only of +-- spaces and tabs, AND +-- * the head of @after@ up to and including the next newline consists +-- only of spaces and tabs followed by a newline — OR @after@ ends +-- before any newline appears and contains only spaces and tabs +-- (i.e. EOF with trailing whitespace). +trimStandaloneAround :: Text -> Text -> (Text, Text, Int) +trimStandaloneAround before after = + case (stripTailWhitespace before, stripHeadWhitespaceNewline after) of + (Just b', Just (a', consumed)) -> (b', a', consumed) + _ -> (before, after, 0) + +-- | Strip trailing spaces and tabs at the end of @t@ if the suffix +-- since the last newline (or from the start of @t@) contains only +-- whitespace. Returns 'Nothing' otherwise, so the caller can fall +-- back to the untrimmed text. +stripTailWhitespace :: Text -> Maybe Text +stripTailWhitespace t = + let (beforeLastLine, lastLine) = T.breakOnEnd "\n" t + in if T.all isSpaceOrTab lastLine + then Just beforeLastLine + else Nothing + +-- | Strip leading spaces and tabs at the start of @t@ followed by a +-- single newline. Returns the remainder paired with the number of +-- newlines consumed (always 0 or 1). EOF after trailing whitespace +-- counts as a standalone match with 0 newlines consumed. +stripHeadWhitespaceNewline :: Text -> Maybe (Text, Int) +stripHeadWhitespaceNewline t = + let (_ws, rest) = T.span isSpaceOrTab t + in if T.null rest + then Just ("", 0) + else case T.uncons rest of + Just ('\n', after) -> Just (after, 1) + _ -> Nothing + +isSpaceOrTab :: Char -> Bool +isSpaceOrTab c = c == ' ' || c == '\t' diff --git a/src/Seihou/Engine/TypedDhallText.hs b/src/Seihou/Engine/TypedDhallText.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/TypedDhallText.hs @@ -0,0 +1,121 @@ +-- | Experimental "Prototype B" renderer for the Dhall-as-templating +-- evaluation in @docs/plans/8-evaluate-dhall-as-templating-language.md@. +-- +-- Unlike the production 'Seihou.Engine.Plan.compileDhallTextStep', +-- this renderer does __not__ perform Seihou @{{var}}@ placeholder +-- substitution against the raw Dhall source. Instead it treats the +-- source as a typed Dhall function @\(vars : RecordType) -> Text@ +-- and applies it to a record literal built from the resolved +-- variable map. +-- +-- This module is reachable only from tests — it is intentionally not +-- wired into 'Seihou.Engine.Plan.compileStep' or the 'Strategy' enum. +module Seihou.Engine.TypedDhallText + ( renderTypedDhallText, + fieldNameFor, + ) +where + +import Control.Exception (SomeException, try) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Dhall qualified +import Seihou.Core.Types +import Seihou.Prelude + +-- | Render a Dhall source file that exports a +-- @\\(vars : RecordType) -> Text@ function by applying it to a typed +-- record built from the resolved variable map. +-- +-- The caller is responsible for building @Map VarName VarValue@ from +-- variable resolution. The returned 'Text' is the evaluated output of +-- the function. +renderTypedDhallText :: + -- | Path to the @.dhall@ source file. + FilePath -> + -- | Resolved variables to pass to the function. + Map VarName VarValue -> + IO (Either Text Text) +renderTypedDhallText srcPath vars = do + sourceResult <- try (TIO.readFile srcPath) + case sourceResult of + Left (e :: SomeException) -> + pure (Left ("failed to read source: " <> T.pack (show e))) + Right source -> do + let record = buildRecordLiteral vars + -- @(\(vars : ...) -> ...) { field1 = ..., ... }@ + applied = "(" <> source <> ") " <> record + evalResult <- try (Dhall.input Dhall.strictText applied) + case evalResult of + Left (e :: SomeException) -> + pure (Left ("Dhall evaluation failed: " <> T.pack (show e))) + Right txt -> pure (Right txt) + +-- | Build a Dhall record literal expression (as 'Text') from a variable map. +-- +-- Field names are derived from variable names by replacing @.@ with @_@ +-- via 'fieldNameFor'. Values are emitted with their natural Dhall syntax: +-- +-- * 'VText' -> quoted Dhall @Text@ literal with characters escaped. +-- * 'VBool' -> @True@ or @False@. +-- * 'VInt' -> Dhall @Integer@ literal (with sign prefix). +-- * 'VList' -> Dhall @List@ with element type inferred from the first +-- element. Empty lists fall back to @List Text@. +buildRecordLiteral :: Map VarName VarValue -> Text +buildRecordLiteral vars + | Map.null vars = "{=}" + | otherwise = + "{ " + <> T.intercalate + ", " + [fieldNameFor name <> " = " <> renderVarValue v | (name, v) <- Map.toList vars] + <> " }" + +-- | Deterministic mapping from 'VarName' to a valid Dhall identifier. +-- Replaces @.@ and @-@ with @_@ to produce a bare identifier usable +-- without backtick quoting. +fieldNameFor :: VarName -> Text +fieldNameFor (VarName n) = T.map fixChar n + where + fixChar '.' = '_' + fixChar '-' = '_' + fixChar c = c + +-- | Render a single 'VarValue' as Dhall source. +renderVarValue :: VarValue -> Text +renderVarValue = \case + VText t -> renderText t + VBool True -> "True" + VBool False -> "False" + VInt n + | n >= 0 -> "+" <> T.pack (show n) + | otherwise -> T.pack (show n) + VList [] -> "[] : List Text" + VList vs@(v : _) -> + "[ " <> T.intercalate ", " (map renderVarValue vs) <> " ] : List " <> dhallTypeOf v + +-- | Render a text value as a Dhall double-quoted string literal, escaping +-- @\\@, @"@, and the Dhall interpolation trigger @${@. +renderText :: Text -> Text +renderText t = + "\"" + <> T.concatMap escapeChar t + <> "\"" + where + escapeChar '\\' = "\\\\" + escapeChar '"' = "\\\"" + escapeChar '\n' = "\\n" + escapeChar '\t' = "\\t" + escapeChar '\r' = "\\r" + escapeChar '$' = "\\$" -- Dhall escape for literal '$' so "${" never forms. + escapeChar c = T.singleton c + +-- | Dhall type name for a single 'VarValue', used when emitting a typed +-- empty list or annotating a non-empty list. Nested lists are not +-- supported by this prototype. +dhallTypeOf :: VarValue -> Text +dhallTypeOf (VText _) = "Text" +dhallTypeOf (VBool _) = "Bool" +dhallTypeOf (VInt _) = "Integer" +dhallTypeOf (VList _) = "Text" -- nested-list fallback; flagged in the evaluation doc. diff --git a/src/Seihou/Engine/Validate.hs b/src/Seihou/Engine/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Engine/Validate.hs @@ -0,0 +1,371 @@ +module Seihou.Engine.Validate + ( DiagSeverity (..), + DiagCheck (..), + ValidateReport (..), + buildReport, + renderReportPlain, + reportHasErrors, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Maybe (isNothing, mapMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Expr (exprRefs, parseExpr) +import Seihou.Core.Module + ( checkCommandSafety, + checkDependencyNames, + checkDestVarRefs, + checkExportRefs, + checkFileExistence, + checkNameFormat, + checkPromptRefs, + checkSafeDestinations, + checkUniqueVars, + checkVersionPresent, + extractPlaceholders, + ) +import Seihou.Core.Types +import Seihou.Engine.Template (extractIfExprs) +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Severity of a diagnostic check result. +data DiagSeverity + = DiagError + | DiagWarning + deriving stock (Eq, Show) + +-- | A single diagnostic check with its result. +data DiagCheck = DiagCheck + { diagLabel :: Text, + diagSeverity :: DiagSeverity, + diagDetails :: [Text] + } + deriving stock (Eq, Show) + +-- | A complete validation report for a module. +data ValidateReport = ValidateReport + { reportModule :: Module, + reportPath :: FilePath, + reportDhallOk :: Bool, + reportDhallError :: Maybe Text, + reportChecks :: [DiagCheck] + } + deriving stock (Eq, Show) + +-- | Build a structured validation report. When the first argument is True, +-- lint warnings are included after the core checks. +buildReport :: Bool -> FilePath -> Module -> IO ValidateReport +buildReport lint baseDir m = do + fileErrors <- checkFileExistence baseDir m + -- The conditional lint reads template file contents, so it runs in IO and + -- only when --lint is requested. + (undeclaredRefs, typeMismatches) <- + if lint then lintConditionals baseDir m else pure ([], []) + let coreChecks = + [ DiagCheck "Module name format" DiagError (checkNameFormat m), + DiagCheck "Module version declared" DiagError (checkVersionPresent m), + DiagCheck "Unique variable names" DiagError (checkUniqueVars m), + DiagCheck "Prompt references" DiagError (checkPromptRefs m), + DiagCheck "Export references" DiagError (checkExportRefs m), + DiagCheck "Source file existence" DiagError fileErrors, + DiagCheck "Dependency names" DiagError (checkDependencyNames m), + DiagCheck "Safe step destinations" DiagError (checkSafeDestinations m), + DiagCheck "Destination variable references" DiagError (checkDestVarRefs m), + DiagCheck "Command safety" DiagError (checkCommandSafety m) + ] + lintChecks = + if lint + then + [ -- Conditional findings are genuine correctness bugs (the class + -- that silently dropped guarded output), so they gate exit + -- status as DiagError, while remaining gated behind --lint. + DiagCheck "Conditional variable references" DiagError undeclaredRefs, + DiagCheck "Conditional comparison types" DiagError typeMismatches, + DiagCheck "Unused variables" DiagWarning (lintUnusedVars m), + DiagCheck "Required variables without prompts" DiagWarning (lintRequiredWithoutPrompt m), + DiagCheck "Duplicate step destinations" DiagWarning (lintDuplicateDestinations m), + DiagCheck "Empty choice lists" DiagWarning (lintEmptyChoices m), + DiagCheck "Missing variable descriptions" DiagWarning (lintMissingDescriptions m) + ] + else [] + pure + ValidateReport + { reportModule = m, + reportPath = baseDir, + reportDhallOk = True, + reportDhallError = Nothing, + reportChecks = coreChecks ++ lintChecks + } + +-- | Whether the report contains any errors (DiagError with non-empty details). +reportHasErrors :: ValidateReport -> Bool +reportHasErrors report = + not report.reportDhallOk + || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) report.reportChecks + +-- | Render the report as plain text (no ANSI codes). +renderReportPlain :: ValidateReport -> Text +renderReportPlain report = + T.unlines $ + [ "Validating module at " <> T.pack report.reportPath <> "...", + "" + ] + ++ dhallLine + ++ summaryLines + ++ checkLines + ++ [""] + ++ [resultLine] + where + m = report.reportModule + + dhallLine = + if report.reportDhallOk + then [" \x2713 module.dhall evaluates successfully"] + else + [" \x2717 module.dhall failed to evaluate"] + ++ case report.reportDhallError of + Just errText -> [" " <> errText] + Nothing -> [] + + summaryLines = + if report.reportDhallOk + then + [ " \x2713 Module name: " <> m.name.unModuleName, + " \x2713 " <> T.pack (show (length m.vars)) <> " variables declared", + " \x2713 " <> T.pack (show (length m.prompts)) <> " prompts defined", + " \x2713 " <> T.pack (show (length m.steps)) <> " steps defined" + ] + else [] + + checkLines = concatMap renderCheck report.reportChecks + + renderCheck c + | null c.diagDetails = + [" \x2713 " <> c.diagLabel] + | c.diagSeverity == DiagWarning = + (" \x26A0 " <> c.diagLabel) : map (\d -> " " <> d) c.diagDetails + | otherwise = + (" \x2717 " <> c.diagLabel) : map (\d -> " " <> d) c.diagDetails + + errorCount = + length + [ () + | c <- report.reportChecks, + c.diagSeverity == DiagError, + not (null c.diagDetails) + ] + + dhallFailed = not report.reportDhallOk + + totalErrors = errorCount + (if dhallFailed then 1 else 0) + + resultLine + | totalErrors > 0 = + T.pack (show totalErrors) <> " error(s) found. Module is invalid." + | otherwise = + "Module '" <> m.name.unModuleName <> "' is valid." + +-- Lint checks + +-- | Variables declared but never referenced in step destinations, exports, or prompts. +lintUnusedVars :: Module -> [Text] +lintUnusedVars m = + let destRefs = + Set.fromList $ + concatMap (extractPlaceholders . (.dest)) m.steps + exportRefs = + Set.fromList $ + map (.var.unVarName) m.exports + promptRefs = + Set.fromList $ + map (.var.unVarName) m.prompts + allRefs = Set.unions [destRefs, exportRefs, promptRefs] + in mapMaybe + ( \v -> + let name' = v.name.unVarName + in if Set.member name' allRefs + then Nothing + else Just ("variable '" <> name' <> "' is declared but never referenced") + ) + m.vars + +-- | Required variables that have no corresponding prompt. +lintRequiredWithoutPrompt :: Module -> [Text] +lintRequiredWithoutPrompt m = + let promptedVars = Set.fromList $ map (.var.unVarName) m.prompts + in mapMaybe + ( \v -> + let name' = v.name.unVarName + in if v.required && not (Set.member name' promptedVars) + then Just ("required variable '" <> name' <> "' has no prompt") + else Nothing + ) + m.vars + +-- | Steps that write to the same destination (excluding patch ops). +lintDuplicateDestinations :: Module -> [Text] +lintDuplicateDestinations m = + let nonPatchDests = [s.dest | s <- m.steps, isNothing s.patch] + dupes = findDuplicates Set.empty Set.empty nonPatchDests + in map (\d -> "multiple steps write to '" <> d <> "'") dupes + +findDuplicates :: Set.Set Text -> Set.Set Text -> [Text] -> [Text] +findDuplicates _ _ [] = [] +findDuplicates seen reported (x : xs) + | Set.member x seen && not (Set.member x reported) = + x : findDuplicates seen (Set.insert x reported) xs + | otherwise = findDuplicates (Set.insert x seen) reported xs + +-- | Choice variables with an empty option list. +lintEmptyChoices :: Module -> [Text] +lintEmptyChoices m = + mapMaybe + ( \v -> case v.type_ of + VTChoice [] -> Just ("variable '" <> v.name.unVarName <> "' has an empty choice list") + _ -> Nothing + ) + m.vars + +-- | Variables without a description. +lintMissingDescriptions :: Module -> [Text] +lintMissingDescriptions m = + mapMaybe + ( \v -> + if isNothing v.description + then Just ("variable '" <> v.name.unVarName <> "' has no description") + else Nothing + ) + m.vars + +-- Conditional-expression lint (when clauses + template {{#if}} conditionals) + +-- | A finding about a conditional expression, tagged by kind so 'buildReport' +-- can render undeclared-reference and type-mismatch findings under separate +-- check labels. +data CondFinding + = CondUndeclared Text + | CondTypeMismatch Text + +-- | Lint every conditional expression in the module: step, command, and prompt +-- @when@ clauses (already parsed to 'Expr') plus @{{#if …}}@ conditionals in +-- text-bearing template files. Returns @(undeclaredReferences, typeMismatches)@. +-- +-- Each referenced variable is checked against the module's declarations: a +-- reference to an undeclared variable, or an @Eq@ comparison whose literal type +-- cannot match the variable's declared type (e.g. a @bool@ variable compared +-- against the quoted string @"true"@), becomes a finding. +lintConditionals :: FilePath -> Module -> IO ([Text], [Text]) +lintConditionals baseDir m = do + templateExprs <- collectTemplateExprs baseDir m + let declaredTypes = Map.fromList [(d.name, d.type_) | d <- m.vars] + stepExprs = + [("step '" <> s.dest <> "' when clause", c) | s <- m.steps, Just c <- [s.condition]] + commandExprs = + [("command when clause", c) | c0 <- m.commands, Just c <- [c0.condition]] + promptExprs = + [ ("prompt for '" <> p.var.unVarName <> "' when clause", c) + | p <- m.prompts, + Just c <- [p.condition] + ] + allExprs = stepExprs ++ commandExprs ++ promptExprs ++ templateExprs + findings = concatMap (uncurry (lintExpr declaredTypes)) allExprs + pure + ( [t | CondUndeclared t <- findings], + [t | CondTypeMismatch t <- findings] + ) + +-- | Read text-bearing template files (@Template@ / @DhallText@ strategies) and +-- extract their @{{#if …}}@ conditionals, parsed to 'Expr'. Files that do not +-- exist are skipped (their absence is already reported by the core +-- source-file-existence check); expressions that fail to parse are skipped here +-- (they surface at render time, outside this lint's scope). +collectTemplateExprs :: FilePath -> Module -> IO [(Text, Expr)] +collectTemplateExprs baseDir m = + concat <$> mapM readStep textBearingSteps + where + textBearingSteps = filter (isTextBearing . (.strategy)) m.steps + + isTextBearing Template = True + isTextBearing DhallText = True + isTextBearing _ = False + + readStep s = do + let path = baseDir "files" s.src + exists <- doesFileExist path + if not exists + then pure [] + else do + contents <- TIO.readFile path + let label = "template '" <> T.pack s.src <> "' {{#if}} condition" + pure [(label, expr) | raw <- extractIfExprs contents, Right expr <- [parseExpr raw]] + +-- | Lint a single expression from the given source against the declared types. +lintExpr :: Map.Map VarName VarType -> Text -> Expr -> [CondFinding] +lintExpr declaredTypes srcLabel expr = + concatMap checkRef (exprRefs expr) + where + checkRef (name, mLit) = + case Map.lookup name declaredTypes of + Nothing -> + [CondUndeclared (srcLabel <> " references undeclared variable: " <> name.unVarName)] + Just ty -> case mLit of + Just lit + | not (literalMatchesType ty lit) -> + [CondTypeMismatch (describeMismatch srcLabel name ty lit)] + _ -> [] + +-- | Whether an @Eq@ literal's constructor can match a value of the declared +-- type. Bool→'VBool', int→'VInt', text→'VText', choice→'VText' (choice values +-- resolve to text), list→'VList'. +literalMatchesType :: VarType -> VarValue -> Bool +literalMatchesType VTBool (VBool _) = True +literalMatchesType VTInt (VInt _) = True +literalMatchesType VTText (VText _) = True +literalMatchesType (VTChoice _) (VText _) = True +literalMatchesType (VTList _) (VList _) = True +literalMatchesType _ _ = False + +-- | Build a human-readable message for a type-inconsistent @Eq@ comparison, +-- with an actionable hint where one applies (the original bug: a @bool@ +-- variable compared against the quoted string @"true"@ instead of the +-- bareword @true@). +describeMismatch :: Text -> VarName -> VarType -> VarValue -> Text +describeMismatch srcLabel name ty lit = + srcLabel + <> " compares variable '" + <> name.unVarName + <> "' (declared type " + <> renderVarType ty + <> ") against " + <> describeLiteral lit + <> "; the comparison can never match." + <> mismatchHint ty lit + +-- | A short hint steering the author to the correct literal form. +mismatchHint :: VarType -> VarValue -> Text +mismatchHint VTBool (VText t) + | T.toLower (T.strip t) `elem` ["true", "false"] = + " Use the bareword " <> T.toLower (T.strip t) <> " instead of the quoted \"" <> t <> "\"." +mismatchHint VTInt (VText t) = " Use the unquoted number " <> t <> " instead of the quoted \"" <> t <> "\"." +mismatchHint VTText (VBool b) = + " Use the quoted string \"" <> (if b then "true" else "false") <> "\" instead of the bareword." +mismatchHint _ _ = "" + +-- | Render an @Eq@ literal for a diagnostic message. +describeLiteral :: VarValue -> Text +describeLiteral (VText t) = "string literal \"" <> t <> "\"" +describeLiteral (VBool b) = "bareword " <> (if b then "true" else "false") +describeLiteral (VInt n) = "integer literal " <> T.pack (show n) +describeLiteral (VList _) = "a list literal" + +-- | A short rendering of a declared variable type for diagnostic messages. +renderVarType :: VarType -> Text +renderVarType VTText = "text" +renderVarType VTBool = "bool" +renderVarType VTInt = "int" +renderVarType (VTList ty) = "list " <> renderVarType ty +renderVarType (VTChoice _) = "choice" diff --git a/src/Seihou/Interaction/Confirm.hs b/src/Seihou/Interaction/Confirm.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Interaction/Confirm.hs @@ -0,0 +1,94 @@ +module Seihou.Interaction.Confirm + ( confirmDefaults, + ) +where + +import Control.Monad (foldM) +import Data.Map.Strict qualified as Map +import Seihou.Composition.Instance (ModuleInstance (..)) +import Seihou.Core.Types +import Seihou.Effect.Console (Console, isInteractive, putText) +import Seihou.Interaction.Prompt (promptForVar) +import Seihou.Prelude + +-- | Walk the resolved variable map and prompt the user to confirm or +-- override each variable whose source is 'FromDefault' or 'FromParent'. +-- +-- Variables whose new value matches the original are left unchanged +-- (preserving their original source). Variables whose new value differs +-- are recorded with 'FromPrompt' as their source, so the downstream +-- save-prompted flow picks them up. +-- +-- A no-op in non-interactive mode, and a no-op when no variable is +-- resolved from a default. +-- +-- Operates per 'ModuleInstance': two invocations of the same module +-- are confirmed independently, so the user can approve different +-- defaults for each. +confirmDefaults :: + (Console :> es) => + [(ModuleInstance, Module, FilePath)] -> + Map ModuleInstance (Map VarName ResolvedVar) -> + Eff es (Map ModuleInstance (Map VarName ResolvedVar)) +confirmDefaults modulesInOrder resolved = do + interactive <- isInteractive + if not interactive || not (anyNeedsConfirm resolved) + then pure resolved + else do + putText "" + putText "Confirm default values:" + foldM processInstance resolved modulesInOrder + +anyNeedsConfirm :: Map ModuleInstance (Map VarName ResolvedVar) -> Bool +anyNeedsConfirm = any (any isDefaultOrParent) . Map.elems + +isDefaultOrParent :: ResolvedVar -> Bool +isDefaultOrParent rv = case rv.source of + FromDefault -> True + FromParent _ -> True + _ -> False + +processInstance :: + (Console :> es) => + Map ModuleInstance (Map VarName ResolvedVar) -> + (ModuleInstance, Module, FilePath) -> + Eff es (Map ModuleInstance (Map VarName ResolvedVar)) +processInstance acc (inst, m, _dir) = do + let modResolved = Map.findWithDefault Map.empty inst acc + newModResolved <- foldM (processVar m acc) modResolved m.vars + pure (Map.insert inst newModResolved acc) + +processVar :: + (Console :> es) => + Module -> + Map ModuleInstance (Map VarName ResolvedVar) -> + Map VarName ResolvedVar -> + VarDecl -> + Eff es (Map VarName ResolvedVar) +processVar m allResolved modResolved decl = + case Map.lookup decl.name modResolved of + Just rv | isDefaultOrParent rv -> do + let prompt = findOrSynthesize m decl + currentBindings = + Map.map (.value) (Map.unions (Map.elems allResolved)) + result <- promptForVar prompt decl currentBindings + case result of + Left _err -> pure modResolved + Right newRv + | newRv.value == rv.value -> pure modResolved + | otherwise -> pure (Map.insert decl.name newRv modResolved) + _ -> pure modResolved + +-- | Find the authored 'Prompt' for a variable, or build a minimal one +-- from the declaration. +findOrSynthesize :: Module -> VarDecl -> Prompt +findOrSynthesize m decl = + case filter (\p -> p.var == decl.name) m.prompts of + (p : _) -> p + [] -> + Prompt + { var = decl.name, + text = decl.name.unVarName, + condition = Nothing, + choices = Nothing + } diff --git a/src/Seihou/Interaction/Prompt.hs b/src/Seihou/Interaction/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Interaction/Prompt.hs @@ -0,0 +1,200 @@ +module Seihou.Interaction.Prompt + ( runPrompts, + promptForVar, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Expr (evalExpr) +import Seihou.Core.Types +import Seihou.Core.Variable (coerceValue, validateVarValue) +import Seihou.Effect.Console (Console, getLine, putText) +import Seihou.Prelude +import Prelude hiding (getLine) + +-- | Run prompts for unresolved variables. +-- +-- For each prompt whose variable is in the unresolved set: +-- 1. Evaluate the prompt's @condition@ against current bindings. +-- 2. If the condition is false, skip. +-- 3. Display the prompt text and read input (or show choice menu). +-- 4. Coerce and validate the input. +-- 5. On failure, retry up to 3 times. +-- +-- Returns a map of newly resolved variables with 'FromPrompt' source. +runPrompts :: + (Console :> es) => + [Prompt] -> + [VarDecl] -> + Map VarName VarValue -> + Eff es (Map VarName ResolvedVar) +runPrompts prompts unresolvedDecls currentBindings = + go prompts Map.empty + where + declMap = Map.fromList [(d.name, d) | d <- unresolvedDecls] + + go :: (Console :> es) => [Prompt] -> Map VarName ResolvedVar -> Eff es (Map VarName ResolvedVar) + go [] acc = pure acc + go (p : ps) acc = do + let vn = p.var + -- Skip if variable is not in the unresolved set + case Map.lookup vn declMap of + Nothing -> go ps acc + Just decl -> do + -- Skip if already resolved by an earlier prompt + if Map.member vn acc + then go ps acc + else do + -- Evaluate when condition + let allBindings = Map.union (Map.map (.value) acc) currentBindings + if shouldPrompt p allBindings + then do + result <- promptForVar p decl allBindings + case result of + Left _err -> go ps acc + Right rv -> go ps (Map.insert vn rv acc) + else go ps acc + +-- | Check if a prompt should be displayed based on its @when@ condition. +shouldPrompt :: Prompt -> Map VarName VarValue -> Bool +shouldPrompt p bindings = + case p.condition of + Nothing -> True + Just expr -> evalExpr bindings expr + +-- | Prompt for a single variable value. +-- Displays the prompt text, reads input, coerces to the declared type, +-- and validates. Retries up to 3 times on failure. +promptForVar :: + (Console :> es) => + Prompt -> + VarDecl -> + Map VarName VarValue -> + Eff es (Either VarError ResolvedVar) +promptForVar prompt decl _bindings = + case prompt.choices of + Just choices -> promptWithChoices prompt decl choices + Nothing -> promptFreeText prompt decl 3 + +-- | Prompt with free text input. Retries up to @maxRetries@ times. +-- +-- When the variable has a default value, it is shown in brackets after the +-- prompt text (e.g., @Project version [0.1.0.0]:@). Empty input accepts the +-- default. For optional variables without a default, empty input skips. +promptFreeText :: + (Console :> es) => + Prompt -> + VarDecl -> + Int -> + Eff es (Either VarError ResolvedVar) +promptFreeText prompt decl retriesLeft = do + putText (formatPromptText prompt decl) + raw <- getLine + if T.null (T.strip raw) + then case decl.default_ of + Just defVal -> + -- Accept the default value + pure + ( Right + ResolvedVar + { value = defVal, + source = FromPrompt, + decl = decl + } + ) + Nothing + | not decl.required -> + -- Optional variable with no default — skip + pure (Left (MissingRequiredVar decl.name)) + | retriesLeft > 1 -> do + putText "Value cannot be empty. Please try again." + promptFreeText prompt decl (retriesLeft - 1) + | otherwise -> + pure (Left (MissingRequiredVar decl.name)) + else case coerceAndValidate decl raw of + Left err -> + if retriesLeft > 1 + then do + putText ("Invalid input: " <> formatCoercionError err <> ". Please try again.") + promptFreeText prompt decl (retriesLeft - 1) + else pure (Left err) + Right rv -> pure (Right rv) + +-- | Prompt with a numbered choice menu. +promptWithChoices :: + (Console :> es) => + Prompt -> + VarDecl -> + [Text] -> + Eff es (Either VarError ResolvedVar) +promptWithChoices prompt decl choices = do + putText prompt.text + mapM_ (\(i, c) -> putText (" " <> T.pack (show i) <> ") " <> c)) (zip [1 :: Int ..] choices) + putText "Enter selection number:" + raw <- getLine + case reads (T.unpack (T.strip raw)) of + [(n, "")] + | n >= 1 && n <= length choices -> + let chosen = choices !! (n - 1) + in case coerceAndValidate decl chosen of + Left err -> pure (Left err) + Right rv -> pure (Right rv) + _ -> do + putText ("Please enter a number between 1 and " <> T.pack (show (length choices)) <> ".") + -- Retry once + raw2 <- getLine + case reads (T.unpack (T.strip raw2)) of + [(n, "")] + | n >= 1 && n <= length choices -> + let chosen = choices !! (n - 1) + in case coerceAndValidate decl chosen of + Left err -> pure (Left err) + Right rv -> pure (Right rv) + _ -> pure (Left (MissingRequiredVar decl.name)) + +-- | Coerce raw text to the variable's type and validate. +coerceAndValidate :: VarDecl -> Text -> Either VarError ResolvedVar +coerceAndValidate decl raw = do + val <- coerceValue decl.name decl.type_ raw + validateVarValue decl val + pure + ResolvedVar + { value = val, + source = FromPrompt, + decl = decl + } + +-- | Format a VarError for display during retry prompts. +formatCoercionError :: VarError -> Text +formatCoercionError (CoercionFailed _ ty raw) = + "cannot convert '" <> raw <> "' to " <> showType ty +formatCoercionError (ValidationFailed _ msg) = msg +formatCoercionError (MissingRequiredVar (VarName n)) = "missing value for " <> n +formatCoercionError (TypeMismatch (VarName n) _ _) = "type mismatch for " <> n + +showType :: VarType -> Text +showType VTText = "text" +showType VTBool = "bool" +showType VTInt = "int" +showType (VTList _) = "list" +showType (VTChoice _) = "choice" + +-- | Format the prompt text, appending a default value hint in brackets +-- when the variable has one (e.g., @"Project version [0.1.0.0]:"@). +-- For optional variables without a default, appends @[skip]@. +formatPromptText :: Prompt -> VarDecl -> Text +formatPromptText prompt decl = + case decl.default_ of + Just defVal -> prompt.text <> " [" <> showDefaultValue defVal <> "]:" + Nothing + | not decl.required -> prompt.text <> " [skip]:" + | otherwise -> prompt.text + +-- | Render a VarValue for display in a prompt's default hint. +showDefaultValue :: VarValue -> Text +showDefaultValue (VText t) = t +showDefaultValue (VBool True) = "yes" +showDefaultValue (VBool False) = "no" +showDefaultValue (VInt n) = T.pack (show n) +showDefaultValue (VList vs) = T.intercalate ", " (map showDefaultValue vs) diff --git a/src/Seihou/Manifest/Hash.hs b/src/Seihou/Manifest/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Manifest/Hash.hs @@ -0,0 +1,20 @@ +module Seihou.Manifest.Hash + ( hashContent, + ) +where + +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as Base16 +import Data.Text.Encoding qualified as TE +import Seihou.Core.Types (SHA256 (..)) +import Seihou.Prelude + +-- | Compute the SHA256 hash of text content, returning a hex-encoded digest. +-- The text is UTF-8 encoded before hashing. +hashContent :: Text -> SHA256 +hashContent t = + let bytes = TE.encodeUtf8 t + digest = SHA256.hash bytes + hex = Base16.encode digest + in SHA256 (TE.decodeUtf8 hex) diff --git a/src/Seihou/Manifest/Types.hs b/src/Seihou/Manifest/Types.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Manifest/Types.hs @@ -0,0 +1,294 @@ +module Seihou.Manifest.Types + ( emptyManifest, + currentManifestVersion, + manifestToJSON, + manifestFromJSON, + writeAppliedBlueprint, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Time (UTCTime) +import Seihou.Core.Types +import Seihou.Prelude hiding ((.=)) + +-- | Current manifest schema version. +-- +-- Bumped from 1 to 2 when 'AppliedModule' gained the @parentVars@ field +-- (see docs/plans/10-parameterized-dep-multi-instantiation.md). Version-1 +-- manifests remain readable because the decoder treats a missing +-- @parentVars@ key as 'emptyParentVars'. +-- +-- Bumped from 2 to 3 when 'Manifest' gained the optional @blueprint@ +-- field (see docs/plans/32-blueprint-manifest-and-status.md). +-- Schema-2 manifests remain readable because the decoder treats a +-- missing @blueprint@ key as 'Nothing'. +currentManifestVersion :: Int +currentManifestVersion = 3 + +-- | Create an empty manifest with the given timestamp. +emptyManifest :: UTCTime -> Manifest +emptyManifest now = + Manifest + { version = currentManifestVersion, + genAt = now, + modules = [], + vars = Map.empty, + files = Map.empty, + recipe = Nothing, + blueprint = Nothing + } + +-- | Record an applied-blueprint provenance on a manifest, replacing any +-- prior entry. Re-running @seihou agent run@ overwrites the recorded +-- blueprint, mirroring the way 'Manifest.recipe' is overwritten when a +-- recipe is re-applied. +writeAppliedBlueprint :: AppliedBlueprint -> Manifest -> Manifest +writeAppliedBlueprint ab m = + Manifest + { version = m.version, + genAt = m.genAt, + modules = m.modules, + vars = m.vars, + files = m.files, + recipe = m.recipe, + blueprint = Just ab + } + +-- | Encode a manifest to JSON bytes. +manifestToJSON :: Manifest -> LBS.ByteString +manifestToJSON = Aeson.encode + +-- | Decode a manifest from JSON bytes. +manifestFromJSON :: LBS.ByteString -> Either String Manifest +manifestFromJSON = Aeson.eitherDecode + +-- JSON instances + +instance ToJSON Manifest where + toJSON m = + Aeson.object $ + [ "version" .= m.version, + "generatedAt" .= m.genAt, + "modules" .= m.modules, + "variables" .= varsToJSON m.vars, + "files" .= filesToJSON m.files + ] + ++ maybe [] (\r -> ["recipe" .= r]) m.recipe + ++ maybe [] (\b -> ["blueprint" .= b]) m.blueprint + +instance FromJSON Manifest where + parseJSON = Aeson.withObject "Manifest" $ \o -> do + v <- o .: "version" + if v > currentManifestVersion + then fail "manifest was created by a newer version of seihou" + else + Manifest v + <$> o .: "generatedAt" + <*> o .: "modules" + <*> (varsFromJSON =<< o .: "variables") + <*> (filesFromJSON =<< o .: "files") + <*> o Aeson..:? "recipe" + <*> o Aeson..:? "blueprint" + +instance ToJSON AppliedRecipe where + toJSON ar = + Aeson.object $ + [ "name" .= ar.name.unRecipeName, + "appliedAt" .= ar.appliedAt + ] + ++ maybe [] (\v -> ["version" .= v]) ar.recipeVersion + +instance FromJSON AppliedRecipe where + parseJSON = Aeson.withObject "AppliedRecipe" $ \o -> + AppliedRecipe + <$> (RecipeName <$> o .: "name") + <*> o Aeson..:? "version" + <*> o .: "appliedAt" + +instance ToJSON AppliedBlueprint where + toJSON ab = + Aeson.object $ + [ "name" .= ab.name.unModuleName, + "appliedAt" .= ab.appliedAt, + "baselineModules" .= map (.unModuleName) ab.baselineModules, + "noBaseline" .= ab.noBaseline + ] + ++ maybe [] (\v -> ["version" .= v]) ab.blueprintVersion + ++ maybe [] (\p -> ["userPrompt" .= p]) ab.userPrompt + ++ maybe [] (\s -> ["agentSessionId" .= s]) ab.agentSessionId + +instance FromJSON AppliedBlueprint where + parseJSON = Aeson.withObject "AppliedBlueprint" $ \o -> + AppliedBlueprint + <$> (ModuleName <$> o .: "name") + <*> o Aeson..:? "version" + <*> o .: "appliedAt" + <*> (map ModuleName <$> o Aeson..:? "baselineModules" Aeson..!= []) + <*> o Aeson..:? "noBaseline" Aeson..!= False + <*> o Aeson..:? "userPrompt" + <*> o Aeson..:? "agentSessionId" + +instance ToJSON AppliedModule where + toJSON am = + Aeson.object $ + [ "name" .= am.name.unModuleName, + "source" .= am.source, + "appliedAt" .= am.appliedAt + ] + ++ parentVarsField am.parentVars + ++ maybe [] (\v -> ["version" .= v]) am.moduleVersion + ++ maybe [] (\r -> ["removal" .= removalToJSON r]) am.removal + where + parentVarsField (ParentVars m) + | Map.null m = [] + | otherwise = ["parentVars" .= parentVarsMapToJSON m] + +instance FromJSON AppliedModule where + parseJSON = Aeson.withObject "AppliedModule" $ \o -> do + -- Backwards compatibility: old manifests have "removable" :: Bool. + -- "removable": true -> Just (Removal [] []) + -- "removable": false or absent, and no "removal" -> Nothing + mRemoval <- o Aeson..:? "removal" + removal <- case mRemoval of + Just v -> Just <$> parseRemovalJSON v + Nothing -> do + oldRemovable <- o Aeson..:? "removable" Aeson..!= False + pure (if oldRemovable then Just (Removal [] []) else Nothing) + -- Schema v1 manifests omit parentVars entirely; decode those as empty. + mParentVars <- o Aeson..:? "parentVars" + pv <- case mParentVars of + Nothing -> pure emptyParentVars + Just v -> ParentVars <$> parentVarsMapFromJSON v + AppliedModule + <$> (ModuleName <$> o .: "name") + <*> pure pv + <*> o .: "source" + <*> o Aeson..:? "version" + <*> o .: "appliedAt" + <*> pure removal + +parentVarsMapToJSON :: Map VarName Text -> Aeson.Value +parentVarsMapToJSON = toJSON . Map.mapKeys (.unVarName) + +parentVarsMapFromJSON :: Aeson.Value -> Aeson.Parser (Map VarName Text) +parentVarsMapFromJSON v = do + m <- parseJSON v :: Aeson.Parser (Map Text Text) + pure (Map.mapKeys VarName m) + +-- | Encode a Removal to JSON. +removalToJSON :: Removal -> Aeson.Value +removalToJSON r = + Aeson.object + [ "steps" .= map removalStepToJSON r.removalSteps, + "commands" .= map removalCommandToJSON r.removalCommands + ] + +removalStepToJSON :: RemovalStep -> Aeson.Value +removalStepToJSON s = + Aeson.object $ + [ "action" .= removalActionToText s.action, + "dest" .= s.dest + ] + ++ maybe [] (\p -> ["src" .= p]) s.src + +removalActionToText :: RemovalAction -> Text +removalActionToText RemoveFileAction = "remove-file" +removalActionToText RemoveSectionAction = "remove-section" +removalActionToText RewriteFileAction = "rewrite-file" + +removalCommandToJSON :: Command -> Aeson.Value +removalCommandToJSON c = + Aeson.object $ + ["run" .= c.run] + ++ maybe [] (\w -> ["workDir" .= w]) c.workDir + +-- | Parse a Removal from JSON. +parseRemovalJSON :: Aeson.Value -> Aeson.Parser Removal +parseRemovalJSON = Aeson.withObject "Removal" $ \o -> + Removal + <$> (o Aeson..:? "steps" Aeson..!= [] >>= mapM parseRemovalStepJSON) + <*> (o Aeson..:? "commands" Aeson..!= [] >>= mapM parseRemovalCommandJSON) + +parseRemovalStepJSON :: Aeson.Value -> Aeson.Parser RemovalStep +parseRemovalStepJSON = Aeson.withObject "RemovalStep" $ \o -> + RemovalStep + <$> (parseRemovalActionText =<< o .: "action") + <*> o .: "dest" + <*> o Aeson..:? "src" + +parseRemovalActionText :: Text -> Aeson.Parser RemovalAction +parseRemovalActionText "remove-file" = pure RemoveFileAction +parseRemovalActionText "remove-section" = pure RemoveSectionAction +parseRemovalActionText "rewrite-file" = pure RewriteFileAction +parseRemovalActionText other = fail ("unknown removal action: " <> T.unpack other) + +parseRemovalCommandJSON :: Aeson.Value -> Aeson.Parser Command +parseRemovalCommandJSON = Aeson.withObject "RemovalCommand" $ \o -> + Command + <$> o .: "run" + <*> o Aeson..:? "workDir" + <*> pure Nothing + +instance ToJSON FileRecord where + toJSON fr = + Aeson.object + [ "hash" .= fr.hash.unSHA256, + "module" .= fr.moduleName.unModuleName, + "strategy" .= strategyToText fr.strategy, + "generatedAt" .= fr.generatedAt + ] + +instance FromJSON FileRecord where + parseJSON = Aeson.withObject "FileRecord" $ \o -> + FileRecord + <$> (SHA256 <$> o .: "hash") + <*> (ModuleName <$> o .: "module") + <*> (strategyFromText =<< o .: "strategy") + <*> o .: "generatedAt" + +instance ToJSON SHA256 where + toJSON (SHA256 t) = toJSON t + +instance FromJSON SHA256 where + parseJSON v = SHA256 <$> parseJSON v + +-- Helpers for VarName-keyed maps + +varsToJSON :: Map VarName Text -> Aeson.Value +varsToJSON = toJSON . Map.mapKeys (.unVarName) + +varsFromJSON :: Aeson.Value -> Aeson.Parser (Map VarName Text) +varsFromJSON v = do + m <- parseJSON v :: Aeson.Parser (Map Text Text) + pure (Map.mapKeys VarName m) + +-- Helpers for FilePath-keyed maps + +filesToJSON :: Map FilePath FileRecord -> Aeson.Value +filesToJSON = toJSON . Map.mapKeys T.pack + +filesFromJSON :: Aeson.Value -> Aeson.Parser (Map FilePath FileRecord) +filesFromJSON v = do + m <- parseJSON v :: Aeson.Parser (Map Text FileRecord) + pure (Map.mapKeys T.unpack m) + +-- Strategy serialization + +strategyToText :: Strategy -> Text +strategyToText Copy = "copy" +strategyToText Template = "template" +strategyToText DhallText = "dhall-text" +strategyToText Structured = "structured" + +strategyFromText :: Text -> Aeson.Parser Strategy +strategyFromText "copy" = pure Copy +strategyFromText "template" = pure Template +strategyFromText "dhall-text" = pure DhallText +strategyFromText "structured" = pure Structured +strategyFromText other = fail ("unknown strategy: " <> T.unpack other) diff --git a/src/Seihou/Prelude.hs b/src/Seihou/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Prelude.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE PackageImports #-} + +module Seihou.Prelude + ( -- * Text + Text, + + -- * Containers + Map, + Set, + + -- * Effectful core + Eff, + runEff, + type (:>), + type (:>>), + IOE, + Effect, + Dispatch (Dynamic), + type DispatchOf, + MonadIO, + liftIO, + + -- * Effectful dynamic dispatch + send, + interpret, + reinterpret, + HasCallStack, + EffectHandler, + + -- * Lens + view, + over, + set, + (^.), + (.~), + (%~), + (&), + lens, + Lens', + Getting, + ASetter, + + -- * Bifunctor + first, + + -- * FilePath + FilePath, + (), + ) +where + +import "base" Data.Bifunctor (first) +import "containers" Data.Map.Strict (Map) +import "containers" Data.Set (Set) +import "effectful-core" Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, MonadIO, liftIO, runEff, type (:>), type (:>>)) +import "effectful-core" Effectful.Dispatch.Dynamic (EffectHandler, HasCallStack, interpret, reinterpret, send) +import "filepath" System.FilePath (()) +import "generic-lens" Data.Generics.Labels () +import "lens" Control.Lens (ASetter, Getting, Lens', lens, over, set, view, (%~), (&), (.~), (^.)) +import "text" Data.Text (Text) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,113 @@ +module Main (main) where + +import Seihou.Composition.GraphSpec qualified as GraphSpec +import Seihou.Composition.InstanceSpec qualified as InstanceSpec +import Seihou.Composition.PlanSpec qualified as CompositionPlanSpec +import Seihou.Composition.RecipeSpec qualified as CompositionRecipeSpec +import Seihou.Composition.ResolveSpec qualified as ResolveSpec +import Seihou.Core.AgentPromptSpec qualified as AgentPromptSpec +import Seihou.Core.BlueprintSpec qualified as BlueprintSpec +import Seihou.Core.CommandVarSpec qualified as CommandVarSpec +import Seihou.Core.ContextSpec qualified as ContextSpec +import Seihou.Core.ExprSpec qualified as ExprSpec +import Seihou.Core.InstallSpec qualified as InstallSpec +import Seihou.Core.ListSpec qualified as ListSpec +import Seihou.Core.MigrationSpec qualified as MigrationSpec +import Seihou.Core.ModuleSpec qualified as ModuleSpec +import Seihou.Core.RecipeSpec qualified as RecipeSpec +import Seihou.Core.RegistryEmitSpec qualified as RegistryEmitSpec +import Seihou.Core.RegistrySpec qualified as RegistrySpec +import Seihou.Core.RegistrySyncSpec qualified as RegistrySyncSpec +import Seihou.Core.ScaffoldSpec qualified as ScaffoldSpec +import Seihou.Core.SchemaUpgradeSpec qualified as SchemaUpgradeSpec +import Seihou.Core.StatusSpec qualified as StatusSpec +import Seihou.Core.TypesSpec qualified as TypesSpec +import Seihou.Core.VariableSpec qualified as VariableSpec +import Seihou.Core.VersionSpec qualified as VersionSpec +import Seihou.Dhall.ConfigSpec qualified as ConfigSpec +import Seihou.Dhall.EvalSpec qualified as DhallEvalSpec +import Seihou.Dhall.MigrationDecoderSpec qualified as MigrationDecoderSpec +import Seihou.Effect.ConfigReaderSpec qualified as ConfigReaderSpec +import Seihou.Effect.ConfigWriterSpec qualified as ConfigWriterSpec +import Seihou.Effect.FilesystemSpec qualified as FilesystemSpec +import Seihou.Effect.LoggerSpec qualified as LoggerSpec +import Seihou.Effect.ManifestStoreSpec qualified as ManifestStoreSpec +import Seihou.Engine.ConflictSpec qualified as ConflictSpec +import Seihou.Engine.DiffSpec qualified as DiffSpec +import Seihou.Engine.ExecuteSpec qualified as ExecuteSpec +import Seihou.Engine.MigrateSpec qualified as EngineMigrateSpec +import Seihou.Engine.PlanSpec qualified as PlanSpec +import Seihou.Engine.PreviewSpec qualified as PreviewSpec +import Seihou.Engine.RemoveSpec qualified as RemoveSpec +import Seihou.Engine.SectionSpec qualified as SectionSpec +import Seihou.Engine.TemplateSpec qualified as TemplateSpec +import Seihou.Engine.ValidateSpec qualified as ValidateSpec +import Seihou.Evaluation.ConditionalTemplateSpec qualified as ConditionalTemplateSpec +import Seihou.Evaluation.DhallTextFlakeSpec qualified as DhallTextFlakeSpec +import Seihou.Evaluation.SplitFlakeSpec qualified as SplitFlakeSpec +import Seihou.Evaluation.TypedDhallTextSpec qualified as TypedDhallTextSpec +import Seihou.Integration.CompositionSpec qualified as CompositionSpec +import Seihou.Integration.ExecutionSpec qualified as ExecutionSpec +import Seihou.Integration.GenerationSpec qualified as GenerationSpec +import Seihou.Integration.ModuleLoadSpec qualified as IntegrationSpec +import Seihou.Interaction.ConfirmSpec qualified as ConfirmSpec +import Seihou.Interaction.PromptSpec qualified as PromptSpec +import Seihou.Manifest.TypesSpec qualified as ManifestTypesSpec +import Test.Tasty + +main :: IO () +main = do + graphTests <- GraphSpec.tests + instanceTests <- InstanceSpec.tests + compositionPlanTests <- CompositionPlanSpec.tests + compositionRecipeTests <- CompositionRecipeSpec.tests + resolveTests <- ResolveSpec.tests + agentPromptTests <- AgentPromptSpec.tests + blueprintTests <- BlueprintSpec.tests + commandVarTests <- CommandVarSpec.tests + typesTests <- TypesSpec.tests + contextTests <- ContextSpec.tests + exprTests <- ExprSpec.tests + installTests <- InstallSpec.tests + listTests <- ListSpec.tests + migrationTests <- MigrationSpec.tests + moduleTests <- ModuleSpec.tests + recipeTests <- RecipeSpec.tests + registryTests <- RegistrySpec.tests + registryEmitTests <- RegistryEmitSpec.tests + registrySyncTests <- RegistrySyncSpec.tests + scaffoldTests <- ScaffoldSpec.tests + schemaUpgradeTests <- SchemaUpgradeSpec.tests + statusTests <- StatusSpec.tests + variableTests <- VariableSpec.tests + versionTests <- VersionSpec.tests + templateTests <- TemplateSpec.tests + planTests <- PlanSpec.tests + previewTests <- PreviewSpec.tests + sectionTests <- SectionSpec.tests + validateTests <- ValidateSpec.tests + splitFlakeTests <- SplitFlakeSpec.tests + dhallTextFlakeTests <- DhallTextFlakeSpec.tests + typedDhallTextTests <- TypedDhallTextSpec.tests + conditionalTemplateTests <- ConditionalTemplateSpec.tests + configTests <- ConfigSpec.tests + dhallEvalTests <- DhallEvalSpec.tests + migrationDecoderTests <- MigrationDecoderSpec.tests + configReaderTests <- ConfigReaderSpec.tests + configWriterTests <- ConfigWriterSpec.tests + filesystemTests <- FilesystemSpec.tests + loggerTests <- LoggerSpec.tests + manifestStoreTests <- ManifestStoreSpec.tests + conflictTests <- ConflictSpec.tests + diffTests <- DiffSpec.tests + executeTests <- ExecuteSpec.tests + engineMigrateTests <- EngineMigrateSpec.tests + removeTests <- RemoveSpec.tests + compositionTests <- CompositionSpec.tests + executionTests <- ExecutionSpec.tests + integrationTests <- IntegrationSpec.tests + generationTests <- GenerationSpec.tests + manifestTypesTests <- ManifestTypesSpec.tests + promptTests <- PromptSpec.tests + confirmTests <- ConfirmSpec.tests + defaultMain (testGroup "seihou-core" [graphTests, instanceTests, compositionPlanTests, compositionRecipeTests, resolveTests, agentPromptTests, blueprintTests, commandVarTests, typesTests, contextTests, exprTests, installTests, listTests, migrationTests, moduleTests, recipeTests, registryTests, registryEmitTests, registrySyncTests, scaffoldTests, schemaUpgradeTests, statusTests, variableTests, versionTests, templateTests, planTests, previewTests, sectionTests, validateTests, splitFlakeTests, dhallTextFlakeTests, typedDhallTextTests, conditionalTemplateTests, configTests, dhallEvalTests, migrationDecoderTests, configReaderTests, configWriterTests, filesystemTests, loggerTests, manifestStoreTests, conflictTests, diffTests, executeTests, engineMigrateTests, removeTests, compositionTests, executionTests, integrationTests, generationTests, manifestTypesTests, promptTests, confirmTests]) diff --git a/test/Seihou/Composition/GraphSpec.hs b/test/Seihou/Composition/GraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Composition/GraphSpec.hs @@ -0,0 +1,194 @@ +module Seihou.Composition.GraphSpec (tests) where + +import Data.Either (isLeft) +import Data.Map.Strict qualified as Map +import Seihou.Composition.Graph +import Seihou.Composition.Instance (ModuleInstance (..), mkInstance, primaryInstance) +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Composition.Graph" spec + +-- | Helper to create a minimal module with given name and dependencies. +mkModule :: ModuleName -> [ModuleName] -> Module +mkModule name deps = + Module + { name = name, + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = map simpleDep deps, + removal = Nothing, + migrations = [] + } + +-- | Helper to build a graph from a list of modules, wrapping each in a +-- primary 'ModuleInstance' (no parent bindings). Works for all the +-- bare-name test scenarios below. +fromModules :: [Module] -> CompositionGraph +fromModules ms = buildGraph [(primaryInstance m.name, m) | m <- ms] + +spec :: Spec +spec = do + describe "buildGraph" $ do + it "builds a graph from a single module with no dependencies" $ do + let m = mkModule "base" [] + g = fromModules [m] + length g.cgModules `shouldBe` 1 + length g.cgEdges `shouldBe` 1 + + it "builds a graph preserving dependency edges" $ do + let a = mkModule "a" ["b", "c"] + b = mkModule "b" [] + c = mkModule "c" [] + g = fromModules [a, b, c] + length g.cgModules `shouldBe` 3 + length g.cgEdges `shouldBe` 3 + + describe "topoSort" $ do + it "returns a single module with no dependencies" $ do + let g = fromModules [mkModule "base" []] + fmap (map (.instanceModule)) (topoSort g) `shouldBe` Right ["base"] + + it "orders a linear chain: A -> B -> C" $ do + let a = mkModule "a" ["b"] + b = mkModule "b" ["c"] + c = mkModule "c" [] + g = fromModules [a, b, c] + case topoSort g of + Right order -> do + let names = map (.instanceModule) order + indexOf "c" names `shouldSatisfy` (< indexOf "b" names) + indexOf "b" names `shouldSatisfy` (< indexOf "a" names) + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + + it "handles a diamond: A -> [B,C], B -> D, C -> D" $ do + let a = mkModule "a" ["b", "c"] + b = mkModule "b" ["d"] + c = mkModule "c" ["d"] + d = mkModule "d" [] + g = fromModules [a, b, c, d] + case topoSort g of + Right order -> do + let names = map (.instanceModule) order + length names `shouldBe` 4 + indexOf "d" names `shouldSatisfy` (< indexOf "b" names) + indexOf "d" names `shouldSatisfy` (< indexOf "c" names) + indexOf "b" names `shouldSatisfy` (< indexOf "a" names) + indexOf "c" names `shouldSatisfy` (< indexOf "a" names) + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + + it "detects a self-loop" $ do + let a = mkModule "a" ["a"] + g = fromModules [a] + topoSort g `shouldSatisfy` isLeft + + it "detects a cycle: A -> B -> C -> A" $ do + let a = mkModule "a" ["b"] + b = mkModule "b" ["c"] + c = mkModule "c" ["a"] + g = fromModules [a, b, c] + topoSort g `shouldSatisfy` isLeft + + it "handles disconnected components" $ do + let a = mkModule "a" [] + b = mkModule "b" [] + c = mkModule "c" [] + g = fromModules [a, b, c] + case topoSort g of + Right order -> length order `shouldBe` 3 + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + + it "handles a larger graph with multiple dependencies" $ do + let e = mkModule "e" [] + d = mkModule "d" ["e"] + c = mkModule "c" ["e"] + b = mkModule "b" ["c", "d"] + a = mkModule "a" ["b"] + g = fromModules [a, b, c, d, e] + case topoSort g of + Right order -> do + let names = map (.instanceModule) order + length names `shouldBe` 5 + indexOf "e" names `shouldSatisfy` (< indexOf "d" names) + indexOf "e" names `shouldSatisfy` (< indexOf "c" names) + indexOf "c" names `shouldSatisfy` (< indexOf "b" names) + indexOf "d" names `shouldSatisfy` (< indexOf "b" names) + indexOf "b" names `shouldSatisfy` (< indexOf "a" names) + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + + describe "multi-instantiation" $ do + it "treats two dependency edges with different depVars as distinct instances" $ do + let helper = mkModule "helper" [] + -- Parent depends on 'helper' twice with different bindings. + parent' = + Module + { name = "parent", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = + [ Dependency "helper" (Map.singleton "skill.name" "exec-plan"), + Dependency "helper" (Map.singleton "skill.name" "master-plan") + ], + removal = Nothing, + migrations = [] + } + parentInst = primaryInstance "parent" + helperA = mkInstance "helper" (ParentVars (Map.singleton "skill.name" "exec-plan")) + helperB = mkInstance "helper" (ParentVars (Map.singleton "skill.name" "master-plan")) + g = buildGraph [(parentInst, parent'), (helperA, helper), (helperB, helper)] + case topoSort g of + Right order -> do + length order `shouldBe` 3 + helperA `elem` order `shouldBe` True + helperB `elem` order `shouldBe` True + parentInst `elem` order `shouldBe` True + -- Both helper invocations must precede the parent. + let idx x = length (takeWhile (/= x) order) + idx helperA `shouldSatisfy` (< idx parentInst) + idx helperB `shouldSatisfy` (< idx parentInst) + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + + it "dedupes two identical dependency edges into one instance" $ do + let child = mkModule "child" [] + parent' = + Module + { name = "parent", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = + [ Dependency "child" (Map.singleton "x" "1"), + Dependency "child" (Map.singleton "x" "1") + ], + removal = Nothing, + migrations = [] + } + parentInst = primaryInstance "parent" + childInst = mkInstance "child" (ParentVars (Map.singleton "x" "1")) + g = buildGraph [(parentInst, parent'), (childInst, child)] + case topoSort g of + Right order -> length order `shouldBe` 2 + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + +-- | Get the index of a ModuleName in a list, or fail. +indexOf :: ModuleName -> [ModuleName] -> Int +indexOf name xs = case lookup name (zip xs [0 ..]) of + Just i -> i + Nothing -> error $ "Module not found in order: " ++ show name diff --git a/test/Seihou/Composition/InstanceSpec.hs b/test/Seihou/Composition/InstanceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Composition/InstanceSpec.hs @@ -0,0 +1,56 @@ +module Seihou.Composition.InstanceSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Composition.Instance +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Composition.Instance" spec + +spec :: Spec +spec = do + describe "qualifiedName" $ do + it "returns the plain module name when no parent bindings are present" $ do + qualifiedName (primaryInstance "claude-skill-link") + `shouldBe` ModuleName "claude-skill-link" + + it "appends a stable hash suffix when parent bindings are present" $ do + let inst = mkInstance "claude-skill-link" (ParentVars (Map.singleton "skill.name" "exec-plan")) + qn = qualifiedName inst + T.isPrefixOf "claude-skill-link#" (qn.unModuleName) `shouldBe` True + T.length (qn.unModuleName) `shouldBe` T.length "claude-skill-link#" + 8 + + it "produces a distinct qualified name for each distinct binding" $ do + let a = mkInstance "claude-skill-link" (ParentVars (Map.singleton "skill.name" "exec-plan")) + b = mkInstance "claude-skill-link" (ParentVars (Map.singleton "skill.name" "master-plan")) + qualifiedName a `shouldNotBe` qualifiedName b + + it "is stable across equal but differently constructed binding maps" $ do + let vs1 = Map.fromList [("a", "1"), ("b", "2")] + vs2 = Map.fromList [("b", "2"), ("a", "1")] + ia = mkInstance "m" (ParentVars vs1) + ib = mkInstance "m" (ParentVars vs2) + qualifiedName ia `shouldBe` qualifiedName ib + + describe "stableHash" $ do + it "returns 8 hex characters for any binding set" $ do + let h = stableHash (ParentVars (Map.singleton "x" "1")) + T.length h `shouldBe` 8 + + it "ignores construction order" $ do + stableHash (ParentVars (Map.fromList [("a", "1"), ("b", "2")])) + `shouldBe` stableHash (ParentVars (Map.fromList [("b", "2"), ("a", "1")])) + + it "differs when binding values differ" $ do + stableHash (ParentVars (Map.singleton "skill.name" "exec-plan")) + `shouldNotBe` stableHash (ParentVars (Map.singleton "skill.name" "master-plan")) + + describe "ParentVars Eq/Ord" $ do + it "two ParentVars with identical maps compare equal" $ do + let a = ParentVars (Map.fromList [("a", "1"), ("b", "2")]) + b = ParentVars (Map.fromList [("b", "2"), ("a", "1")]) + a `shouldBe` b diff --git a/test/Seihou/Composition/PlanSpec.hs b/test/Seihou/Composition/PlanSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Composition/PlanSpec.hs @@ -0,0 +1,249 @@ +module Seihou.Composition.PlanSpec (tests) where + +import Data.Text qualified as T +import Seihou.Composition.Plan +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Composition.Plan" spec + +spec :: Spec +spec = do + describe "mergeOperations" $ do + it "preserves all operations when no files overlap" $ do + let aOps = [CreateDirOp "src", WriteFileOp "src/A.hs" "module A" Template] + bOps = [CreateDirOp "lib", WriteFileOp "lib/B.hs" "module B" Template] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + length ops `shouldBe` 4 + warnings `shouldBe` [] + + it "last-writer-wins when two modules write same file" $ do + let aOps = [WriteFileOp "README.md" "from A" Template] + bOps = [WriteFileOp "README.md" "from B" Template] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + -- Only B's version should remain + length (filter isWriteOp ops) `shouldBe` 1 + case filter isWriteOp ops of + [WriteFileOp _ content _] -> content `shouldBe` "from B" + _ -> expectationFailure "Expected exactly one WriteFileOp" + -- Warning should indicate A was overwritten by B + length warnings `shouldBe` 1 + case warnings of + [FileOverwritten path overwritten overwriter] -> do + path `shouldBe` "README.md" + overwritten `shouldBe` "mod-a" + overwriter `shouldBe` "mod-b" + _ -> expectationFailure "Expected one FileOverwritten warning" + + it "deduplicates CreateDirOp silently" $ do + let aOps = [CreateDirOp "src"] + bOps = [CreateDirOp "src"] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + length ops `shouldBe` 1 + warnings `shouldBe` [] + + it "keeps all RunCommandOp operations" $ do + let aOps = [RunCommandOp "echo hello" Nothing] + bOps = [RunCommandOp "echo world" Nothing] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + length ops `shouldBe` 2 + warnings `shouldBe` [] + + it "handles CopyFileOp overlapping with WriteFileOp" $ do + let aOps = [WriteFileOp "config.yaml" "generated" Template] + bOps = [CopyFileOp "files/config.yaml" "config.yaml"] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + length warnings `shouldBe` 1 + -- B's CopyFileOp should be the winner + case filter (\op -> destOfOp' op == Just "config.yaml") ops of + [CopyFileOp {}] -> pure () + other -> expectationFailure $ "Expected CopyFileOp, got: " ++ show other + + it "handles three modules with cascading overwrites" $ do + let aOps = [WriteFileOp "README.md" "from A" Template] + bOps = [WriteFileOp "README.md" "from B" Template] + cOps = [WriteFileOp "README.md" "from C" Template] + (ops, warnings, _) = mergeOperations [("a", aOps), ("b", bOps), ("c", cOps)] + -- Only C's version should remain + case filter isWriteOp ops of + [WriteFileOp _ content _] -> content `shouldBe` "from C" + _ -> expectationFailure "Expected exactly one WriteFileOp" + -- Two warnings: A overwritten by B, B overwritten by C + length warnings `shouldBe` 2 + + it "handles empty module operations" $ do + let (ops, warnings, _) = mergeOperations [("a", []), ("b", [])] + ops `shouldBe` [] + warnings `shouldBe` [] + + describe "mergeOperations (text patching)" $ do + it "PatchFileOp AppendFile merges with existing WriteFileOp" $ do + let aOps = [WriteFileOp "README.md" "# Title\n" Template] + bOps = [PatchFileOp "README.md" "extra line\n" AppendFile Template "mod-b"] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + -- Should be a single merged WriteFileOp + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "# Title" content `shouldBe` True + T.isInfixOf "extra line" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + -- Should produce ContentMerged warning, not FileOverwritten + case filter isContentMerged warnings of + [ContentMerged path base contributor] -> do + path `shouldBe` "README.md" + base `shouldBe` "mod-a" + contributor `shouldBe` "mod-b" + other -> expectationFailure $ "Expected one ContentMerged, got: " ++ show other + + it "PatchFileOp AppendSection adds section markers and merges" $ do + let aOps = [WriteFileOp "README.md" "# Title\n" Template] + bOps = [PatchFileOp "README.md" "section content\n" AppendSection Template "mod-b"] + (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "# Title" content `shouldBe` True + T.isInfixOf "seihou:mod-b" content `shouldBe` True + T.isInfixOf "section content" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + + it "PatchFileOp PrependFile prepends content" $ do + let aOps = [WriteFileOp "README.md" "# Title\n" Template] + bOps = [PatchFileOp "README.md" "header\n" PrependFile Template "mod-b"] + (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + -- header should appear before Title + let headerIdx = T.length (fst (T.breakOn "header" content)) + titleIdx = T.length (fst (T.breakOn "# Title" content)) + (headerIdx < titleIdx) `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + + it "PatchFileOp targeting nonexistent file is preserved as PatchFileOp" $ do + let bOps = [PatchFileOp "new.txt" "content\n" AppendFile Template "mod-b"] + (ops, _, _) = mergeOperations [("mod-b", bOps)] + -- PatchFileOp with no existing target is preserved so the execution + -- engine can merge with the on-disk file and the diff engine avoids + -- false conflict classification. + length (filter isPatchOp ops) `shouldBe` 1 + + it "multiple patches from different modules accumulate" $ do + let aOps = [WriteFileOp "README.md" "# Title\n" Template] + bOps = [PatchFileOp "README.md" "from B\n" AppendSection Template "mod-b"] + cOps = [PatchFileOp "README.md" "from C\n" AppendSection Template "mod-c"] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps), ("mod-c", cOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "# Title" content `shouldBe` True + T.isInfixOf "from B" content `shouldBe` True + T.isInfixOf "from C" content `shouldBe` True + T.isInfixOf "seihou:mod-b" content `shouldBe` True + T.isInfixOf "seihou:mod-c" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + -- Two ContentMerged warnings (one for B, one for C) + length (filter isContentMerged warnings) `shouldBe` 2 + + it "ContentMerged warning is generated for patch merge" $ do + let aOps = [WriteFileOp "f.txt" "base\n" Template] + bOps = [PatchFileOp "f.txt" "added\n" AppendFile Template "mod-b"] + (_, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + any isContentMerged warnings `shouldBe` True + any isFileOverwritten warnings `shouldBe` False + + it "PatchFileOp AppendLineIfAbsent deduplicates lines during merge" $ do + let aOps = [WriteFileOp ".gitignore" "node_modules/\n.env\n" Template] + bOps = [PatchFileOp ".gitignore" ".env\n.claude/\n" AppendLineIfAbsent Template "mod-b"] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + content `shouldBe` "node_modules/\n.env\n.claude/\n" + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + any isContentMerged warnings `shouldBe` True + + describe "mergeOperations (structured merge)" $ do + it "two Structured WriteFileOps for same JSON dest get deep-merged" $ do + let aOps = [WriteFileOp "config.json" "{\"name\": \"foo\"}\n" Structured] + bOps = [WriteFileOp "config.json" "{\"extra\": true}\n" Structured] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "name" content `shouldBe` True + T.isInfixOf "foo" content `shouldBe` True + T.isInfixOf "extra" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + any isContentMerged warnings `shouldBe` True + any isFileOverwritten warnings `shouldBe` False + + it "disjoint JSON keys are combined" $ do + let aOps = [WriteFileOp "out.json" "{\"a\": 1}\n" Structured] + bOps = [WriteFileOp "out.json" "{\"b\": 2}\n" Structured] + (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "\"a\"" content `shouldBe` True + T.isInfixOf "\"b\"" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + + it "overlapping scalar keys use right-biased merge" $ do + let aOps = [WriteFileOp "out.json" "{\"x\": 1}\n" Structured] + bOps = [WriteFileOp "out.json" "{\"x\": 2}\n" Structured] + (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> + -- Right-biased: B's value wins + T.isInfixOf "2" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + + it "nested objects are merged recursively" $ do + let aOps = [WriteFileOp "out.json" "{\"obj\": {\"a\": 1}}\n" Structured] + bOps = [WriteFileOp "out.json" "{\"obj\": {\"b\": 2}}\n" Structured] + (ops, _, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "\"a\"" content `shouldBe` True + T.isInfixOf "\"b\"" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + + it "non-Structured WriteFileOps still use last-writer-wins" $ do + let aOps = [WriteFileOp "README.md" "from A" Template] + bOps = [WriteFileOp "README.md" "from B" Template] + (_, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + any isFileOverwritten warnings `shouldBe` True + any isContentMerged warnings `shouldBe` False + + it "YAML structured merge works" $ do + let aOps = [WriteFileOp "config.yaml" "name: foo\n" Structured] + bOps = [WriteFileOp "config.yaml" "extra: true\n" Structured] + (ops, warnings, _) = mergeOperations [("mod-a", aOps), ("mod-b", bOps)] + case filter isWriteOp ops of + [WriteFileOp _ content _] -> do + T.isInfixOf "name" content `shouldBe` True + T.isInfixOf "extra" content `shouldBe` True + other -> expectationFailure $ "Expected one WriteFileOp, got: " ++ show other + any isContentMerged warnings `shouldBe` True + +-- Helpers + +isWriteOp :: Operation -> Bool +isWriteOp (WriteFileOp {}) = True +isWriteOp _ = False + +isPatchOp :: Operation -> Bool +isPatchOp (PatchFileOp {}) = True +isPatchOp _ = False + +destOfOp' :: Operation -> Maybe FilePath +destOfOp' (WriteFileOp d _ _) = Just d +destOfOp' (CopyFileOp _ d) = Just d +destOfOp' (PatchFileOp d _ _ _ _) = Just d +destOfOp' _ = Nothing + +isContentMerged :: CompositionWarning -> Bool +isContentMerged (ContentMerged {}) = True +isContentMerged _ = False + +isFileOverwritten :: CompositionWarning -> Bool +isFileOverwritten (FileOverwritten {}) = True +isFileOverwritten _ = False diff --git a/test/Seihou/Composition/RecipeSpec.hs b/test/Seihou/Composition/RecipeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Composition/RecipeSpec.hs @@ -0,0 +1,113 @@ +module Seihou.Composition.RecipeSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Seihou.Composition.Recipe (expandRecipe) +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Composition.Recipe" spec + +expectExpanded :: Recipe -> (ModuleName, [ModuleName], Map.Map VarName Text, [VarDecl], [Prompt]) +expectExpanded recipe = + case expandRecipe recipe of + Right expanded -> expanded + Left errs -> error ("expected recipe expansion, got errors: " <> show errs) + +spec :: Spec +spec = do + describe "expandRecipe" $ do + it "returns correct primary and additional module names" $ do + let recipe = + Recipe + { name = "combo", + version = Just "1.0.0", + description = Nothing, + modules = + [ simpleDep "mod-a", + simpleDep "mod-b", + simpleDep "mod-c" + ], + vars = [], + prompts = [] + } + (primary, additional, _, _, _) = expectExpanded recipe + primary `shouldBe` ModuleName "mod-a" + additional `shouldBe` [ModuleName "mod-b", ModuleName "mod-c"] + + it "collects variable overrides from module entries" $ do + let recipe = + Recipe + { name = "pinned", + version = Nothing, + description = Nothing, + modules = + [ Dependency (ModuleName "base") (Map.singleton "project.name" "my-app"), + Dependency (ModuleName "nix") (Map.singleton "nix.system" "aarch64-darwin") + ], + vars = [], + prompts = [] + } + (_, _, overrides, _, _) = expectExpanded recipe + Map.lookup (VarName "project.name") overrides `shouldBe` Just "my-app" + Map.lookup (VarName "nix.system") overrides `shouldBe` Just "aarch64-darwin" + + it "passes through recipe-level vars and prompts" $ do + let recipeVar = + VarDecl + { name = "project.name", + type_ = VTText, + default_ = Nothing, + description = Just "Project name", + required = True, + validation = Nothing + } + recipePrompt = + Prompt + { var = "project.name", + text = "Enter name:", + condition = Nothing, + choices = Nothing + } + recipe = + Recipe + { name = "prompted", + version = Nothing, + description = Nothing, + modules = [simpleDep "base"], + vars = [recipeVar], + prompts = [recipePrompt] + } + (_, _, _, vars, prompts) = expectExpanded recipe + vars `shouldBe` [recipeVar] + prompts `shouldBe` [recipePrompt] + + it "handles a single-module recipe (alias)" $ do + let recipe = + Recipe + { name = "alias", + version = Nothing, + description = Nothing, + modules = [simpleDep "the-module"], + vars = [], + prompts = [] + } + (primary, additional, overrides, _, _) = expectExpanded recipe + primary `shouldBe` ModuleName "the-module" + additional `shouldBe` [] + Map.null overrides `shouldBe` True + + it "returns validation errors for an empty recipe" $ do + let recipe = + Recipe + { name = "empty", + version = Nothing, + description = Nothing, + modules = [], + vars = [], + prompts = [] + } + expandRecipe recipe `shouldBe` Left ["recipe must list at least one module"] diff --git a/test/Seihou/Composition/ResolveSpec.hs b/test/Seihou/Composition/ResolveSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Composition/ResolveSpec.hs @@ -0,0 +1,448 @@ +module Seihou.Composition.ResolveSpec (tests) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Seihou.Composition.Instance (ModuleInstance (..), mkInstance, primaryInstance) +import Seihou.Composition.Resolve +import Seihou.Core.Types +import Seihou.Core.Variable (diagnoseResolution) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Composition.Resolve" spec + +-- | Helper to create a minimal module. +mkModule :: ModuleName -> [ModuleName] -> [VarDecl] -> [VarExport] -> Module +mkModule name deps vars exports = + Module + { name = name, + version = Nothing, + description = Nothing, + vars = vars, + exports = exports, + prompts = [], + steps = [], + commands = [], + dependencies = map simpleDep deps, + removal = Nothing, + migrations = [] + } + +-- | Helper to create a module with parameterized dependencies. +mkModuleWithDeps :: ModuleName -> [Dependency] -> [VarDecl] -> [VarExport] -> Module +mkModuleWithDeps name deps vars exports = + Module + { name = name, + version = Nothing, + description = Nothing, + vars = vars, + exports = exports, + prompts = [], + steps = [], + commands = [], + dependencies = deps, + removal = Nothing, + migrations = [] + } + +-- | Helper to create a text variable declaration. +mkTextVar :: VarName -> Maybe VarValue -> Bool -> VarDecl +mkTextVar name defVal required = + VarDecl + { name = name, + type_ = VTText, + default_ = defVal, + description = Nothing, + required = required, + validation = Nothing + } + +-- | Helper to create an export without alias. +mkExport :: VarName -> VarExport +mkExport name = VarExport {var = name, alias = Nothing} + +-- | Helper to create an export with alias. +mkExportAs :: VarName -> VarName -> VarExport +mkExportAs name alias' = VarExport {var = name, alias = Just alias'} + +-- | Wrap a list of @(Module, FilePath)@ into instance-keyed triples, +-- using 'emptyParentVars' for every module. Existing single-instance +-- tests use this to migrate onto the new API without churn. +asInstances :: [(Module, FilePath)] -> [(ModuleInstance, Module, FilePath)] +asInstances pairs = [(primaryInstance m.name, m, dir) | (m, dir) <- pairs] + +-- | Look up the resolved variables for a module by its bare name, +-- assuming the composition contains a single primary instance of it. +byName :: ModuleName -> Map ModuleInstance (Map VarName a) -> Map VarName a +byName n = Map.findWithDefault Map.empty (primaryInstance n) + +spec :: Spec +spec = do + describe "exportedVars" $ do + it "exports a variable under its original name" $ do + let m = mkModule "base" [] [mkTextVar "project.name" (Just (VText "test")) False] [mkExport "project.name"] + resolved = Map.singleton "project.name" (ResolvedVar (VText "my-app") FromDefault (mkTextVar "project.name" (Just (VText "test")) False)) + result = exportedVars m resolved + Map.lookup "project.name" result `shouldBe` Just (VText "my-app") + + it "exports a variable under its alias" $ do + let m = mkModule "base" [] [mkTextVar "project.name" (Just (VText "test")) False] [mkExportAs "project.name" "app.name"] + resolved = Map.singleton "project.name" (ResolvedVar (VText "my-app") FromDefault (mkTextVar "project.name" (Just (VText "test")) False)) + result = exportedVars m resolved + Map.lookup "app.name" result `shouldBe` Just (VText "my-app") + Map.lookup "project.name" result `shouldBe` Nothing + + it "skips exports for unresolved variables" $ do + let m = mkModule "base" [] [] [mkExport "missing.var"] + resolved = Map.empty + result = exportedVars m resolved + Map.null result `shouldBe` True + + describe "resolveComposedVariables" $ do + it "resolves a single module with no dependencies" $ do + let m = mkModule "base" [] [mkTextVar "project.name" (Just (VText "default")) False] [] + modules = asInstances [(m, "/fake/base")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let baseVars = byName "base" result + (.value) (baseVars Map.! "project.name") `shouldBe` VText "default" + + it "flows exported variable from dependency to dependent" $ do + let base = mkModule "base" [] [mkTextVar "project.name" (Just (VText "my-app")) False] [mkExport "project.name"] + app = mkModule "app" ["base"] [mkTextVar "project.name" Nothing True] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let appVars = byName "app" result + (.value) (appVars Map.! "project.name") `shouldBe` VText "my-app" + + it "export overrides module's own default" $ do + let base = mkModule "base" [] [mkTextVar "project.name" (Just (VText "from-base")) False] [mkExport "project.name"] + app = mkModule "app" ["base"] [mkTextVar "project.name" (Just (VText "from-app")) False] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let appVars = byName "app" result + (.value) (appVars Map.! "project.name") `shouldBe` VText "from-base" + + it "CLI override beats exported value" $ do + let base = mkModule "base" [] [mkTextVar "project.name" (Just (VText "from-base")) False] [mkExport "project.name"] + app = mkModule "app" ["base"] [mkTextVar "project.name" Nothing True] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + cliOverrides = Map.singleton "project.name" "from-cli" + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let appVars = byName "app" result + (.value) (appVars Map.! "project.name") `shouldBe` VText "from-cli" + + it "inherits non-declared exports from dependency" $ do + let base = mkModule "base" [] [mkTextVar "project.name" (Just (VText "my-app")) False] [mkExport "project.name"] + -- app does NOT declare project.name but depends on base + app = mkModule "app" ["base"] [mkTextVar "app.version" (Just (VText "1.0")) False] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let appVars = byName "app" result + -- app inherits project.name even though it doesn't declare it + (.value) (appVars Map.! "project.name") `shouldBe` VText "my-app" + -- app also has its own variable + (.value) (appVars Map.! "app.version") `shouldBe` VText "1.0" + + it "handles aliased exports" $ do + let base = mkModule "base" [] [mkTextVar "project.name" (Just (VText "my-app")) False] [mkExportAs "project.name" "app.name"] + app = mkModule "app" ["base"] [mkTextVar "app.name" Nothing True] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let appVars = byName "app" result + (.value) (appVars Map.! "app.name") `shouldBe` VText "my-app" + + it "handles diamond dependency with shared export" $ do + let d = mkModule "d" [] [mkTextVar "sys.arch" (Just (VText "x86_64")) False] [mkExport "sys.arch"] + b = mkModule "b" ["d"] [mkTextVar "sys.arch" Nothing True] [mkExport "sys.arch"] + c = mkModule "c" ["d"] [mkTextVar "sys.arch" Nothing True] [] + a = mkModule "a" ["b", "c"] [mkTextVar "sys.arch" Nothing True] [] + modules = asInstances [(d, "/d"), (b, "/b"), (c, "/c"), (a, "/a")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + -- All modules should see sys.arch from d + (.value) (byName "d" result Map.! "sys.arch") `shouldBe` VText "x86_64" + (.value) (byName "b" result Map.! "sys.arch") `shouldBe` VText "x86_64" + (.value) (byName "c" result Map.! "sys.arch") `shouldBe` VText "x86_64" + (.value) (byName "a" result Map.! "sys.arch") `shouldBe` VText "x86_64" + + describe "resolveComposedVariables (with config layers)" $ do + it "resolves from global config when no other source provides value" $ do + let m = mkModule "base" [] [mkTextVar "license" Nothing True] [] + modules = asInstances [(m, "/fake/base")] + globalCfg = Map.fromList [("license", "MIT")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let baseVars = byName "base" result + (.value) (baseVars Map.! "license") `shouldBe` VText "MIT" + (.source) (baseVars Map.! "license") `shouldBe` FromGlobalConfig + + it "local config overrides global config in composed resolution" $ do + let m = mkModule "base" [] [mkTextVar "license" Nothing True] [] + modules = asInstances [(m, "/fake/base")] + localCfg = Map.fromList [("license", "BSD3")] + globalCfg = Map.fromList [("license", "MIT")] + case resolveComposedVariables modules Map.empty Map.empty "" "" localCfg Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let baseVars = byName "base" result + (.value) (baseVars Map.! "license") `shouldBe` VText "BSD3" + (.source) (baseVars Map.! "license") `shouldBe` FromLocalConfig + + it "CLI override beats config layers in composed resolution" $ do + let m = mkModule "base" [] [mkTextVar "license" Nothing True] [] + modules = asInstances [(m, "/fake/base")] + cliOverrides = Map.singleton "license" "cli-license" + localCfg = Map.fromList [("license", "local-license")] + globalCfg = Map.fromList [("license", "global-license")] + case resolveComposedVariables modules cliOverrides Map.empty "" "" localCfg Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let baseVars = byName "base" result + (.value) (baseVars Map.! "license") `shouldBe` VText "cli-license" + (.source) (baseVars Map.! "license") `shouldBe` FromCLI + + it "config layers flow through multi-module composition" $ do + let base = mkModule "base" [] [mkTextVar "license" Nothing True] [mkExport "license"] + app = mkModule "app" ["base"] [mkTextVar "license" Nothing True] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + globalCfg = Map.fromList [("license", "MIT")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + -- base gets license from global config + let baseVars = byName "base" result + (.value) (baseVars Map.! "license") `shouldBe` VText "MIT" + (.source) (baseVars Map.! "license") `shouldBe` FromGlobalConfig + -- app also gets license from global config (it declares the var) + let appVars = byName "app" result + (.value) (appVars Map.! "license") `shouldBe` VText "MIT" + + describe "end-to-end config hierarchy auto-resolution" $ do + it "resolves all variables from different config layers with correct precedence" $ do + -- Scenario: A module with 4 variables, each resolved from a different layer + let decls = + [ mkTextVar "project.name" Nothing True, + mkTextVar "license" Nothing False, + mkTextVar "haskell.ghc" Nothing False, + mkTextVar "author.name" Nothing False + ] + m = mkModule "haskell-app" [] decls [mkExport "project.name"] + modules = asInstances [(m, "/fake/haskell-app")] + cliOverrides = Map.singleton "project.name" "my-app" + envVars = Map.singleton "SEIHOU_VAR_LICENSE" "Apache" + localCfg = Map.fromList [("haskell.ghc", "9.12.2")] + globalCfg = Map.fromList [("author.name", "Jane Doe"), ("license", "MIT")] + case resolveComposedVariables modules cliOverrides envVars "haskell" "" localCfg Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let vars = byName "haskell-app" result + -- CLI wins for project.name + (.value) (vars Map.! "project.name") `shouldBe` VText "my-app" + (.source) (vars Map.! "project.name") `shouldBe` FromCLI + -- Env wins over global config for license + (.value) (vars Map.! "license") `shouldBe` VText "Apache" + (.source) (vars Map.! "license") `shouldBe` FromEnv "SEIHOU_VAR_LICENSE" + -- Local config provides haskell.ghc + (.value) (vars Map.! "haskell.ghc") `shouldBe` VText "9.12.2" + (.source) (vars Map.! "haskell.ghc") `shouldBe` FromLocalConfig + -- Global config provides author.name + (.value) (vars Map.! "author.name") `shouldBe` VText "Jane Doe" + (.source) (vars Map.! "author.name") `shouldBe` FromGlobalConfig + + it "optional variables without values are omitted, not errors" $ do + let decls = + [ mkTextVar "project.name" Nothing True, + mkTextVar "optional.missing" Nothing False + ] + m = mkModule "test" [] decls [] + modules = asInstances [(m, "/fake/test")] + cliOverrides = Map.singleton "project.name" "app" + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let vars = byName "test" result + (.value) (vars Map.! "project.name") `shouldBe` VText "app" + Map.member "optional.missing" vars `shouldBe` False + + it "diagnostics detect unused config keys and unresolved optional vars" $ do + let decls = + [ mkTextVar "project.name" Nothing True, + mkTextVar "optional.unset" Nothing False + ] + m = mkModule "test" [] decls [] + modules = asInstances [(m, "/fake/test")] + cliOverrides = Map.singleton "project.name" "app" + globalCfg = Map.fromList [("typo.key", "oops")] + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let allResolved = Map.unions (Map.elems result) + allDecls = concatMap (\(_, mm, _) -> mm.vars) modules + (unusedKeys, unresolvedOpt) = diagnoseResolution allResolved allDecls Map.empty Map.empty Map.empty globalCfg + unusedKeys `shouldBe` [VarName "typo.key"] + unresolvedOpt `shouldBe` [VarName "optional.unset"] + + it "context config overrides global config in composed resolution" $ do + let m = mkModule "base" [] [mkTextVar "user.email" Nothing True] [] + modules = asInstances [(m, "/fake/base")] + ctxCfg = Map.fromList [("user.email", "work@example.com")] + globalCfg = Map.fromList [("user.email", "default@example.com")] + case resolveComposedVariables modules Map.empty Map.empty "" "work" Map.empty Map.empty ctxCfg globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let baseVars = byName "base" result + (.value) (baseVars Map.! "user.email") `shouldBe` VText "work@example.com" + (.source) (baseVars Map.! "user.email") `shouldBe` FromContextConfig "work" + + it "context flows through multi-module composition" $ do + let base = mkModule "base" [] [mkTextVar "user.email" Nothing True] [mkExport "user.email"] + app = mkModule "app" ["base"] [mkTextVar "user.email" Nothing True] [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + ctxCfg = Map.fromList [("user.email", "work@example.com")] + case resolveComposedVariables modules Map.empty Map.empty "" "work" Map.empty Map.empty ctxCfg Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let baseVars = byName "base" result + (.value) (baseVars Map.! "user.email") `shouldBe` VText "work@example.com" + let appVars = byName "app" result + (.value) (appVars Map.! "user.email") `shouldBe` VText "work@example.com" + + it "multi-module composition: config values flow through exports" $ do + let baseDecls = + [ mkTextVar "project.name" Nothing True, + mkTextVar "license" Nothing False + ] + base = mkModule "base" [] baseDecls [mkExport "project.name", mkExport "license"] + appDecls = + [ mkTextVar "project.name" Nothing True, + mkTextVar "license" Nothing False + ] + app = mkModule "app" ["base"] appDecls [] + modules = asInstances [(base, "/fake/base"), (app, "/fake/app")] + globalCfg = Map.fromList [("project.name", "global-app"), ("license", "MIT")] + localCfg = Map.fromList [("project.name", "local-app")] + case resolveComposedVariables modules Map.empty Map.empty "" "" localCfg Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + -- base: local overrides global for project.name + let baseVars = byName "base" result + (.value) (baseVars Map.! "project.name") `shouldBe` VText "local-app" + (.source) (baseVars Map.! "project.name") `shouldBe` FromLocalConfig + (.value) (baseVars Map.! "license") `shouldBe` VText "MIT" + (.source) (baseVars Map.! "license") `shouldBe` FromGlobalConfig + -- app: same values, same precedence (declares its own vars, config wins) + let appVars = byName "app" result + (.value) (appVars Map.! "project.name") `shouldBe` VText "local-app" + (.value) (appVars Map.! "license") `shouldBe` VText "MIT" + + describe "resolveComposedVariables (parameterized dependencies)" $ do + it "parent-supplied var resolves in dependency" $ do + let child = mkModule "child" [] [mkTextVar "skill.name" Nothing True] [] + parent' = mkModuleWithDeps "parent" [Dependency "child" (Map.singleton "skill.name" "exec-plan")] [] [] + childInst = mkInstance "child" (ParentVars (Map.singleton "skill.name" "exec-plan")) + parentInst = primaryInstance "parent" + modules = [(childInst, child, "/fake/child"), (parentInst, parent', "/fake/parent")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let childVars = Map.findWithDefault Map.empty childInst result + (.value) (childVars Map.! "skill.name") `shouldBe` VText "exec-plan" + (.source) (childVars Map.! "skill.name") `shouldBe` FromParent "parent" + + it "parent-supplied var overrides dependency's default" $ do + let child = mkModule "child" [] [mkTextVar "skill.name" (Just (VText "old")) False] [] + parent' = mkModuleWithDeps "parent" [Dependency "child" (Map.singleton "skill.name" "new")] [] [] + childInst = mkInstance "child" (ParentVars (Map.singleton "skill.name" "new")) + parentInst = primaryInstance "parent" + modules = [(childInst, child, "/fake/child"), (parentInst, parent', "/fake/parent")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let childVars = Map.findWithDefault Map.empty childInst result + (.value) (childVars Map.! "skill.name") `shouldBe` VText "new" + (.source) (childVars Map.! "skill.name") `shouldBe` FromParent "parent" + + it "CLI override beats parent-supplied var" $ do + let child = mkModule "child" [] [mkTextVar "skill.name" Nothing True] [] + parent' = mkModuleWithDeps "parent" [Dependency "child" (Map.singleton "skill.name" "from-parent")] [] [] + childInst = mkInstance "child" (ParentVars (Map.singleton "skill.name" "from-parent")) + parentInst = primaryInstance "parent" + modules = [(childInst, child, "/fake/child"), (parentInst, parent', "/fake/parent")] + cliOverrides = Map.singleton "skill.name" "from-cli" + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let childVars = Map.findWithDefault Map.empty childInst result + (.value) (childVars Map.! "skill.name") `shouldBe` VText "from-cli" + (.source) (childVars Map.! "skill.name") `shouldBe` FromCLI + + it "config beats parent-supplied var" $ do + let child = mkModule "child" [] [mkTextVar "skill.name" (Just (VText "default")) False] [] + parent' = mkModuleWithDeps "parent" [Dependency "child" (Map.singleton "skill.name" "parent-val")] [] [] + childInst = mkInstance "child" (ParentVars (Map.singleton "skill.name" "parent-val")) + parentInst = primaryInstance "parent" + modules = [(childInst, child, "/fake/child"), (parentInst, parent', "/fake/parent")] + globalCfg = Map.fromList [("skill.name", "global-val")] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty globalCfg of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + let childVars = Map.findWithDefault Map.empty childInst result + (.value) (childVars Map.! "skill.name") `shouldBe` VText "global-val" + (.source) (childVars Map.! "skill.name") `shouldBe` FromGlobalConfig + + it "two parents supplying different bindings produce two distinct child instances" $ do + -- The regression case from ExecPlan 10: master-plan and exec-plan both + -- depend on claude-skill-link with different skill.name bindings. Both + -- invocations must resolve independently. + let helper = + mkModule + "helper" + [] + [mkTextVar "skill.name" Nothing True] + [mkExport "skill.name"] + parentA = + mkModuleWithDeps + "parent-a" + [Dependency "helper" (Map.singleton "skill.name" "exec-plan")] + [] + [] + parentB = + mkModuleWithDeps + "parent-b" + [Dependency "helper" (Map.singleton "skill.name" "master-plan")] + [] + [] + instA = mkInstance "helper" (ParentVars (Map.singleton "skill.name" "exec-plan")) + instB = mkInstance "helper" (ParentVars (Map.singleton "skill.name" "master-plan")) + parentAInst = primaryInstance "parent-a" + parentBInst = primaryInstance "parent-b" + modules = + [ (instA, helper, "/fake/helper"), + (instB, helper, "/fake/helper"), + (parentAInst, parentA, "/fake/parent-a"), + (parentBInst, parentB, "/fake/parent-b") + ] + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right result -> do + Map.size result `shouldBe` 4 + let varsA = Map.findWithDefault Map.empty instA result + varsB = Map.findWithDefault Map.empty instB result + (.value) (varsA Map.! "skill.name") `shouldBe` VText "exec-plan" + (.value) (varsB Map.! "skill.name") `shouldBe` VText "master-plan" diff --git a/test/Seihou/Core/AgentPromptSpec.hs b/test/Seihou/Core/AgentPromptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/AgentPromptSpec.hs @@ -0,0 +1,365 @@ +module Seihou.Core.AgentPromptSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.AgentPrompt (validateAgentPrompt) +import Seihou.Core.Module (DiscoveredRunnable (..), RunnableKind (..), discoverAllRunnables, discoverRunnable) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalAgentPromptFromFile) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.AgentPrompt" spec + +goodAgentPrompt :: AgentPrompt +goodAgentPrompt = + AgentPrompt + "review-changes" + (Just "0.1.0") + (Just "Review local changes") + "Review the current repository." + [VarDecl "project.name" VTText Nothing Nothing True Nothing] + [Prompt {var = "project.name", text = "Project?", condition = Nothing, choices = Nothing}] + [CommandVar "git.branch" "git branch --show-current" Nothing Nothing True (Just 4096)] + [PromptGuidance "Repository workflow" "Inspect first." Nothing] + [] + Nothing + ["review"] + Nothing + +withAgentPromptName :: ModuleName -> AgentPrompt -> AgentPrompt +withAgentPromptName n p = + AgentPrompt n p.version p.description p.prompt p.vars p.prompts p.commandVars p.guidance p.files p.allowedTools p.tags p.launch + +withAgentPromptPrompt :: T.Text -> AgentPrompt -> AgentPrompt +withAgentPromptPrompt body p = + AgentPrompt p.name p.version p.description body p.vars p.prompts p.commandVars p.guidance p.files p.allowedTools p.tags p.launch + +withAgentPromptVars :: [VarDecl] -> AgentPrompt -> AgentPrompt +withAgentPromptVars vars p = + AgentPrompt p.name p.version p.description p.prompt vars p.prompts p.commandVars p.guidance p.files p.allowedTools p.tags p.launch + +withAgentPromptPrompts :: [Prompt] -> AgentPrompt -> AgentPrompt +withAgentPromptPrompts prompts p = + AgentPrompt p.name p.version p.description p.prompt p.vars prompts p.commandVars p.guidance p.files p.allowedTools p.tags p.launch + +withAgentPromptCommandVars :: [CommandVar] -> AgentPrompt -> AgentPrompt +withAgentPromptCommandVars commandVars p = + AgentPrompt p.name p.version p.description p.prompt p.vars p.prompts commandVars p.guidance p.files p.allowedTools p.tags p.launch + +withAgentPromptGuidance :: [PromptGuidance] -> AgentPrompt -> AgentPrompt +withAgentPromptGuidance guidance p = + AgentPrompt p.name p.version p.description p.prompt p.vars p.prompts p.commandVars guidance p.files p.allowedTools p.tags p.launch + +withAgentPromptFiles :: [BlueprintFile] -> AgentPrompt -> AgentPrompt +withAgentPromptFiles files p = + AgentPrompt p.name p.version p.description p.prompt p.vars p.prompts p.commandVars p.guidance files p.allowedTools p.tags p.launch + +hasError :: T.Text -> [T.Text] -> Bool +hasError needle = any (T.isInfixOf needle) + +spec :: Spec +spec = do + describe "evalAgentPromptFromFile" $ do + it "decodes prompt.dhall with command variables, guidance, and launch metadata" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + createDirectoryIfMissing True promptDir + writeFile (promptDir "prompt.dhall") (samplePromptDhall "review-changes") + result <- evalAgentPromptFromFile (promptDir "prompt.dhall") + case result of + Right p -> do + p.name `shouldBe` "review-changes" + p.description `shouldBe` Just "Review local changes" + length p.commandVars `shouldBe` 1 + p.guidance + `shouldBe` [ PromptGuidance + "Repository workflow" + "Prefer focused validation commands." + (Just (ExprEq "git.branch" (VText "main"))) + ] + fmap (.provider) p.launch `shouldBe` Just (Just "codex-cli") + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes prompt.dhall without guidance as an empty list" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + createDirectoryIfMissing True promptDir + writeFile (promptDir "prompt.dhall") (samplePromptDhallWithoutGuidance "review-changes") + result <- evalAgentPromptFromFile (promptDir "prompt.dhall") + case result of + Right p -> p.guidance `shouldBe` [] + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + describe "validateAgentPrompt" $ do + it "accepts a well-formed prompt" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + result <- validateAgentPrompt tmpDir goodAgentPrompt + case result of + Right p -> p.name `shouldBe` "review-changes" + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "rejects an invalid prompt name" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + result <- validateAgentPrompt tmpDir (withAgentPromptName "Bad_Name" goodAgentPrompt) + case result of + Left (ValidationError _ errs) -> + hasError "prompt name must match" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects an empty prompt body" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + result <- validateAgentPrompt tmpDir (withAgentPromptPrompt " \n " goodAgentPrompt) + case result of + Left (ValidationError _ errs) -> + hasError "prompt body must not be empty" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects duplicate typed variables" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let bad = + withAgentPromptVars + [ VarDecl "x" VTText Nothing Nothing True Nothing, + VarDecl "x" VTBool Nothing Nothing False Nothing + ] + goodAgentPrompt + result <- validateAgentPrompt tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "duplicate variable name" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects prompts that reference undeclared variables" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let bad = + withAgentPromptPrompts + [Prompt {var = "missing", text = "?", condition = Nothing, choices = Nothing}] + goodAgentPrompt + result <- validateAgentPrompt tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "prompt references undeclared variable" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects unsafe command variables" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let bad = + withAgentPromptCommandVars + [ CommandVar "git.branch" "" (Just "../outside") Nothing True (Just 0), + CommandVar "git.branch" "git status" Nothing Nothing True Nothing + ] + goodAgentPrompt + result <- validateAgentPrompt tmpDir bad + case result of + Left (ValidationError _ errs) -> do + hasError "duplicate command variable name" errs `shouldBe` True + hasError "run must not be empty" errs `shouldBe` True + hasError "must not contain '..'" errs `shouldBe` True + hasError "maxBytes must be greater than zero" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "accepts guidance that references declared typed and command variables" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let guided = + withAgentPromptGuidance + [ PromptGuidance "Project" "Use the declared project name." (Just (ExprIsSet "project.name")), + PromptGuidance "Branch" "Account for branch-specific workflow." (Just (ExprIsSet "git.branch")) + ] + goodAgentPrompt + result <- validateAgentPrompt tmpDir guided + case result of + Right p -> length p.guidance `shouldBe` 2 + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "rejects guidance with blank titles or bodies" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let bad = + withAgentPromptGuidance + [ PromptGuidance " " "Body" Nothing, + PromptGuidance "Title" " \n " Nothing + ] + goodAgentPrompt + result <- validateAgentPrompt tmpDir bad + case result of + Left (ValidationError _ errs) -> do + hasError "guidance title must not be empty" errs `shouldBe` True + hasError "guidance body must not be empty" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects guidance conditions that reference undeclared variables" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let bad = + withAgentPromptGuidance + [PromptGuidance "Missing" "This references an unknown value." (Just (ExprIsSet "repo.kind"))] + goodAgentPrompt + result <- validateAgentPrompt tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "guidance 'Missing' references undeclared variable: repo.kind" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "checks referenced prompt files under files/" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let bad = + withAgentPromptFiles + [BlueprintFile {src = "missing.md", description = Nothing}] + goodAgentPrompt + result <- validateAgentPrompt tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "prompt file not found" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + describe "prompt discovery" $ do + it "finds a prompt when only prompt.dhall is present" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + createDirectoryIfMissing True promptDir + writeFile (promptDir "prompt.dhall") (samplePromptDhall "review-changes") + result <- discoverRunnable [tmpDir] "review-changes" + case result of + Right (RunnableAgentPrompt p dir) -> do + p.name `shouldBe` "review-changes" + dir `shouldBe` promptDir + other -> expectationFailure ("Expected RunnableAgentPrompt, got: " <> show other) + + it "tags prompts as KindPrompt during enumeration" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + createDirectoryIfMissing True promptDir + writeFile (promptDir "prompt.dhall") (samplePromptDhall "review-changes") + found <- discoverAllRunnables [tmpDir] + case found of + [DiscoveredRunnable {drKind = kind}] -> kind `shouldBe` KindPrompt + other -> expectationFailure ("Expected one discovered prompt, got: " <> show other) + + it "prefers blueprint.dhall over prompt.dhall in the same directory" $ do + withSystemTempDirectory "seihou-prompt" $ \tmpDir -> do + let entryDir = tmpDir "ambiguous" + createDirectoryIfMissing True entryDir + writeFile (entryDir "blueprint.dhall") (sampleBlueprintDhall "ambiguous") + writeFile (entryDir "prompt.dhall") (samplePromptDhall "ambiguous") + result <- discoverRunnable [tmpDir] "ambiguous" + case result of + Right (RunnableBlueprint _ _) -> pure () + other -> expectationFailure ("Expected RunnableBlueprint, got: " <> show other) + +samplePromptDhall :: T.Text -> String +samplePromptDhall n = + unlines + [ "{ name = \"" ++ T.unpack n ++ "\"", + ", version = Some \"0.1.0\"", + ", description = Some \"Review local changes\"", + ", prompt = \"Review the current repository.\"", + ", vars =", + " [] : List", + " { name : Text", + " , type : Text", + " , default : Optional Text", + " , description : Optional Text", + " , required : Bool", + " , validation : Optional Text", + " }", + ", prompts =", + " [] : List", + " { var : Text", + " , text : Text", + " , when : Optional Text", + " , choices : Optional (List Text)", + " }", + ", commandVars =", + " [ { name = \"git.branch\"", + " , run = \"git branch --show-current\"", + " , workDir = None Text", + " , when = None Text", + " , trim = True", + " , maxBytes = Some 4096", + " }", + " ]", + ", guidance =", + " [ { title = \"Repository workflow\"", + " , body = \"Prefer focused validation commands.\"", + " , when = Some \"Eq git.branch main\"", + " }", + " ]", + ", files = [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [ \"review\" ]", + ", launch = Some { provider = Some \"codex-cli\", mode = None Text, model = None Text }", + "}" + ] + +samplePromptDhallWithoutGuidance :: T.Text -> String +samplePromptDhallWithoutGuidance n = + unlines + [ "{ name = \"" ++ T.unpack n ++ "\"", + ", version = Some \"0.1.0\"", + ", description = Some \"Review local changes\"", + ", prompt = \"Review the current repository.\"", + ", vars =", + " [] : List", + " { name : Text", + " , type : Text", + " , default : Optional Text", + " , description : Optional Text", + " , required : Bool", + " , validation : Optional Text", + " }", + ", prompts =", + " [] : List", + " { var : Text", + " , text : Text", + " , when : Optional Text", + " , choices : Optional (List Text)", + " }", + ", commandVars =", + " [] : List", + " { name : Text", + " , run : Text", + " , workDir : Optional Text", + " , when : Optional Text", + " , trim : Bool", + " , maxBytes : Optional Natural", + " }", + ", files = [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [ \"review\" ]", + ", launch = None { provider : Optional Text, mode : Optional Text, model : Optional Text }", + "}" + ] + +sampleBlueprintDhall :: T.Text -> String +sampleBlueprintDhall n = + unlines + [ "{ name = \"" ++ T.unpack n ++ "\"", + ", version = Some \"0.1.0\"", + ", description = None Text", + ", prompt = \"hello\"", + ", vars =", + " [] : List", + " { name : Text", + " , type : Text", + " , default : Optional Text", + " , description : Optional Text", + " , required : Bool", + " , validation : Optional Text", + " }", + ", prompts =", + " [] : List", + " { var : Text", + " , text : Text", + " , when : Optional Text", + " , choices : Optional (List Text)", + " }", + ", baseModules =", + " [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", files =", + " [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [] : List Text", + "}" + ] diff --git a/test/Seihou/Core/BlueprintSpec.hs b/test/Seihou/Core/BlueprintSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/BlueprintSpec.hs @@ -0,0 +1,344 @@ +module Seihou.Core.BlueprintSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Blueprint (validateBlueprintWith) +import Seihou.Core.Module (discoverRunnable) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalBlueprintFromFile) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Blueprint" spec + +fixtureDir :: FilePath +fixtureDir = "test/fixtures" + +hasError :: T.Text -> [T.Text] -> Bool +hasError needle = any (T.isInfixOf needle) + +-- | A well-formed blueprint used as the seed for negative-case tests. +goodBlueprint :: Blueprint +goodBlueprint = + Blueprint + "valid-bp" + (Just "0.1.0") + (Just "A valid blueprint") + "Scaffold something for the user." + [ VarDecl + { name = "project.name", + type_ = VTText, + default_ = Nothing, + description = Nothing, + required = True, + validation = Nothing + } + ] + [] + [] + [] + Nothing + [] + +-- | Helpers to update individual 'Blueprint' fields without ambiguous +-- record updates. Several @Blueprint@ fields collide by name with +-- @Module@, @Recipe@, and @Manifest@; positional construction sidesteps +-- the ambiguity once and for all. +withBlueprintName :: ModuleName -> Blueprint -> Blueprint +withBlueprintName n b = + Blueprint n b.version b.description b.prompt b.vars b.prompts b.baseModules b.files b.allowedTools b.tags + +withBlueprintVersion :: Maybe T.Text -> Blueprint -> Blueprint +withBlueprintVersion v b = + Blueprint b.name v b.description b.prompt b.vars b.prompts b.baseModules b.files b.allowedTools b.tags + +withBlueprintPrompt :: T.Text -> Blueprint -> Blueprint +withBlueprintPrompt p b = + Blueprint b.name b.version b.description p b.vars b.prompts b.baseModules b.files b.allowedTools b.tags + +withBlueprintVars :: [VarDecl] -> Blueprint -> Blueprint +withBlueprintVars vs b = + Blueprint b.name b.version b.description b.prompt vs b.prompts b.baseModules b.files b.allowedTools b.tags + +withBlueprintPrompts :: [Prompt] -> Blueprint -> Blueprint +withBlueprintPrompts ps b = + Blueprint b.name b.version b.description b.prompt b.vars ps b.baseModules b.files b.allowedTools b.tags + +withBlueprintBaseModules :: [Dependency] -> Blueprint -> Blueprint +withBlueprintBaseModules ds b = + Blueprint b.name b.version b.description b.prompt b.vars b.prompts ds b.files b.allowedTools b.tags + +withBlueprintFiles :: [BlueprintFile] -> Blueprint -> Blueprint +withBlueprintFiles fs b = + Blueprint b.name b.version b.description b.prompt b.vars b.prompts b.baseModules fs b.allowedTools b.tags + +withBlueprintAllowedTools :: Maybe [T.Text] -> Blueprint -> Blueprint +withBlueprintAllowedTools at b = + Blueprint b.name b.version b.description b.prompt b.vars b.prompts b.baseModules b.files at b.tags + +withBlueprintTags :: [T.Text] -> Blueprint -> Blueprint +withBlueprintTags ts b = + Blueprint b.name b.version b.description b.prompt b.vars b.prompts b.baseModules b.files b.allowedTools ts + +spec :: Spec +spec = do + describe "evalBlueprintFromFile (sample fixture)" $ do + it "decodes the sample-blueprint fixture" $ do + result <- evalBlueprintFromFile (fixtureDir "sample-blueprint" "blueprint.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right b -> do + b.name `shouldBe` ModuleName "sample-blueprint" + b.version `shouldBe` Just "0.1.0" + b.description `shouldBe` Just "Fixture blueprint for EP-29 tests" + T.isInfixOf "{{project.name}}" b.prompt `shouldBe` True + length b.vars `shouldBe` 2 + b.tags `shouldBe` ["demo"] + b.baseModules `shouldBe` [] + length b.files `shouldBe` 1 + + describe "validateBlueprintWith (sample fixture)" $ do + it "accepts the sample-blueprint fixture" $ do + cwd <- getCurrentDirectory + let baseDir = cwd "test" "fixtures" "sample-blueprint" + Right b <- evalBlueprintFromFile (baseDir "blueprint.dhall") + result <- validateBlueprintWith [] baseDir b + case result of + Right b' -> b'.name `shouldBe` "sample-blueprint" + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + describe "validateBlueprintWith (rule-by-rule)" $ do + it "rejects an invalid blueprint name" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = withBlueprintName "Bad_Name" goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "blueprint name must match" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects an empty version string" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = withBlueprintVersion (Just " ") goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "version, if specified, must not be empty" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "accepts a missing version" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bp = withBlueprintVersion Nothing goodBlueprint + result <- validateBlueprintWith [] tmpDir bp + case result of + Right _ -> pure () + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "rejects an empty prompt" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = withBlueprintPrompt " \n " goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "prompt must not be empty" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects duplicate variable names" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let dup = + VarDecl + { name = "project.name", + type_ = VTBool, + default_ = Nothing, + description = Nothing, + required = False, + validation = Nothing + } + bad = withBlueprintVars (goodBlueprint.vars ++ [dup]) goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "duplicate variable name" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects a prompt referencing an undeclared variable" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = + withBlueprintPrompts + [Prompt {var = "undeclared", text = "?", condition = Nothing, choices = Nothing}] + goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "prompt references undeclared" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects an empty tag" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = withBlueprintTags ["ok", " "] goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "tag must not be empty" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects an empty allowedTools entry" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = withBlueprintAllowedTools (Just ["Read", ""]) goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "allowedTools entry must not be empty" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects a missing referenced file" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = + withBlueprintFiles + [BlueprintFile {src = "missing.md", description = Nothing}] + goodBlueprint + result <- validateBlueprintWith [] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "blueprint file not found" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "accepts a referenced file when present on disk" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "snippet.md") "stub" + let bp = + withBlueprintFiles + [BlueprintFile {src = "snippet.md", description = Nothing}] + goodBlueprint + result <- validateBlueprintWith [] tmpDir bp + case result of + Right _ -> pure () + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "rejects a baseModule that does not resolve" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = + withBlueprintBaseModules + [Dependency {depModule = "nope-not-here", depVars = Map.empty}] + goodBlueprint + result <- validateBlueprintWith [tmpDir] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "not found in any search path" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + it "rejects a baseModule that resolves to another blueprint" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let nestedDir = tmpDir "nested-bp" + createDirectoryIfMissing True nestedDir + writeFile (nestedDir "blueprint.dhall") (sampleBlueprintDhall "nested-bp") + let bad = + withBlueprintBaseModules + [Dependency {depModule = "nested-bp", depVars = Map.empty}] + goodBlueprint + result <- validateBlueprintWith [tmpDir] tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "resolves to a blueprint" errs `shouldBe` True + other -> expectationFailure ("Expected ValidationError, got: " <> show other) + + describe "discoverRunnable for blueprints" $ do + it "finds a blueprint when only blueprint.dhall is present" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bpDir = tmpDir "only-bp" + createDirectoryIfMissing True bpDir + writeFile (bpDir "blueprint.dhall") (sampleBlueprintDhall "only-bp") + result <- discoverRunnable [tmpDir] "only-bp" + case result of + Right (RunnableBlueprint b dir) -> do + b.name `shouldBe` "only-bp" + dir `shouldBe` bpDir + other -> expectationFailure ("Expected RunnableBlueprint, got: " <> show other) + + it "prefers module.dhall over blueprint.dhall in the same directory" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let entryDir = tmpDir "ambiguous" + createDirectoryIfMissing True entryDir + writeFile (entryDir "module.dhall") minimalModuleDhall + writeFile (entryDir "blueprint.dhall") (sampleBlueprintDhall "ambiguous") + result <- discoverRunnable [tmpDir] "ambiguous" + case result of + Right (RunnableModule _ _) -> pure () + other -> expectationFailure ("Expected RunnableModule (module wins over blueprint), got: " <> show other) + +-- | A minimal module Dhall body for the priority-conflict test. +minimalModuleDhall :: String +minimalModuleDhall = + unlines + [ "{ name = \"ambiguous\"", + ", version = Some \"1.0.0\"", + ", description = None Text", + ", vars =", + " [] : List", + " { name : Text", + " , type : Text", + " , default : Optional Text", + " , description : Optional Text", + " , required : Bool", + " , validation : Optional Text", + " }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts =", + " [] : List", + " { var : Text", + " , text : Text", + " , when : Optional Text", + " , choices : Optional (List Text)", + " }", + ", steps =", + " [] : List", + " { strategy : Text", + " , src : Text", + " , dest : Text", + " , when : Optional Text", + " , patch : Optional Text", + " }", + ", commands =", + " [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List Text", + "}" + ] + +-- | A minimal blueprint Dhall body parameterised by name. +sampleBlueprintDhall :: T.Text -> String +sampleBlueprintDhall n = + unlines + [ "{ name = \"" ++ T.unpack n ++ "\"", + ", version = Some \"0.1.0\"", + ", description = None Text", + ", prompt = \"hello\"", + ", vars =", + " [] : List", + " { name : Text", + " , type : Text", + " , default : Optional Text", + " , description : Optional Text", + " , required : Bool", + " , validation : Optional Text", + " }", + ", prompts =", + " [] : List", + " { var : Text", + " , text : Text", + " , when : Optional Text", + " , choices : Optional (List Text)", + " }", + ", baseModules =", + " [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", files =", + " [] : List { src : Text, description : Optional Text }", + ", allowedTools = None (List Text)", + ", tags = [] : List Text", + "}" + ] diff --git a/test/Seihou/Core/CommandVarSpec.hs b/test/Seihou/Core/CommandVarSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/CommandVarSpec.hs @@ -0,0 +1,211 @@ +module Seihou.Core.CommandVarSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Effectful (runPureEff) +import Numeric.Natural (Natural) +import Seihou.Core.CommandVar (planCommandVars, resolveCommandVars) +import Seihou.Core.Types +import Seihou.Effect.ProcessPure (ProcessMock (..), runProcessPure) +import System.Exit (ExitCode (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.CommandVar" spec + +textDecl :: VarName -> VarDecl +textDecl name = VarDecl name VTText Nothing Nothing False Nothing + +boolDecl :: VarName -> VarDecl +boolDecl name = VarDecl name VTBool Nothing Nothing False Nothing + +intDecl :: VarName -> VarDecl +intDecl name = VarDecl name VTInt Nothing Nothing False Nothing + +patternDecl :: VarName -> VarDecl +patternDecl name = VarDecl name VTText Nothing Nothing False (Just (ValPattern "[a-z][a-z0-9-]*")) + +cmdVar :: VarName -> T.Text -> CommandVar +cmdVar name run = + CommandVar + { name = name, + run = run, + workDir = Nothing, + condition = Nothing, + trim = True, + maxBytes = Just 4096 + } + +withCondition :: Maybe Expr -> CommandVar -> CommandVar +withCondition condition cv = + CommandVar cv.name cv.run cv.workDir condition cv.trim cv.maxBytes + +withTrim :: Bool -> CommandVar -> CommandVar +withTrim trim cv = + CommandVar cv.name cv.run cv.workDir cv.condition trim cv.maxBytes + +withMaxBytes :: Maybe Natural -> CommandVar -> CommandVar +withMaxBytes maxBytes cv = + CommandVar cv.name cv.run cv.workDir cv.condition cv.trim maxBytes + +commandVarName :: CommandVar -> VarName +commandVarName cv = cv.name + +commandVarRun :: CommandVar -> T.Text +commandVarRun cv = cv.run + +mock :: T.Text -> ExitCode -> T.Text -> T.Text -> ProcessMock +mock run exitCode stdoutText stderrText = + ProcessMock + { mockCommand = "sh", + mockArgs = ["-c", run], + mockResult = (exitCode, stdoutText, stderrText) + } + +runResolve :: + [VarDecl] -> + [CommandVar] -> + Map.Map VarName ResolvedVar -> + [ProcessMock] -> + Either [VarError] (Map.Map VarName ResolvedVar) +runResolve decls commandVars existing mocks = + runPureEff $ + runProcessPure mocks $ + resolveCommandVars decls commandVars existing + +resolved :: VarDecl -> VarValue -> VarSource -> ResolvedVar +resolved decl value source = ResolvedVar {value = value, source = source, decl = decl} + +spec :: Spec +spec = do + describe "planCommandVars" $ do + it "skips already-resolved variables and false conditions" $ do + let branchDecl = textDecl "git.branch" + readyDecl = boolDecl "release.ready" + existing = Map.singleton "git.branch" (resolved branchDecl (VText "configured") FromLocalConfig) + bindings = Map.singleton "release.ready" (VBool False) + planned = + planCommandVars + [ cmdVar "git.branch" "git branch --show-current", + withCondition (Just (ExprIsSet "git.branch")) (cmdVar "release.notes" "git log"), + withCondition (Just (ExprEq "release.ready" (VBool True))) (cmdVar "release.ready" "echo true") + ] + existing + bindings + map commandVarName planned `shouldBe` ["release.notes"] + + describe "resolveCommandVars" $ do + it "resolves text and bool values from command output" $ do + let branch = cmdVar "git.branch" "git branch --show-current" + ready = cmdVar "release.ready" "printf true" + result = + runResolve + [textDecl "git.branch", boolDecl "release.ready"] + [branch, ready] + Map.empty + [ mock (commandVarRun branch) ExitSuccess "main\n" "", + mock (commandVarRun ready) ExitSuccess "true\n" "" + ] + case result of + Right m -> do + fmap (.value) (Map.lookup "git.branch" m) `shouldBe` Just (VText "main") + fmap (.value) (Map.lookup "release.ready" m) `shouldBe` Just (VBool True) + fmap (.source) (Map.lookup "git.branch" m) `shouldBe` Just (FromCommand "git branch --show-current") + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "does not override already-resolved config values" $ do + let decl = textDecl "git.branch" + existing = Map.singleton "git.branch" (resolved decl (VText "configured") FromLocalConfig) + branch = cmdVar "git.branch" "git branch --show-current" + result = + runResolve + [decl] + [branch] + existing + [mock (commandVarRun branch) ExitSuccess "main\n" ""] + result `shouldBe` Right existing + + it "coerces int output using the matching declaration" $ do + let count = cmdVar "change.count" "git diff --numstat" + result = + runResolve + [intDecl "change.count"] + [count] + Map.empty + [mock (commandVarRun count) ExitSuccess "42\n" ""] + fmap (fmap (.value) . Map.lookup "change.count") result `shouldBe` Right (Just (VInt 42)) + + it "uses a text declaration for command-only prompt variables" $ do + let branch = cmdVar "git.branch" "git branch --show-current" + result = + runResolve + [] + [branch] + Map.empty + [mock (commandVarRun branch) ExitSuccess "main\n" ""] + fmap (fmap (.value) . Map.lookup "git.branch") result `shouldBe` Right (Just (VText "main")) + + it "preserves untrimmed output when trim is false" $ do + let branch = withTrim False (cmdVar "git.branch" "git branch --show-current") + result = + runResolve + [textDecl "git.branch"] + [branch] + Map.empty + [mock (commandVarRun branch) ExitSuccess "main\n" ""] + fmap (fmap (.value) . Map.lookup "git.branch") result `shouldBe` Right (Just (VText "main\n")) + + it "rejects output that exceeds maxBytes" $ do + let branch = withMaxBytes (Just 3) (cmdVar "git.branch" "git branch --show-current") + result = + runResolve + [textDecl "git.branch"] + [branch] + Map.empty + [mock (commandVarRun branch) ExitSuccess "main\n" ""] + case result of + Left [ValidationFailed "git.branch" msg] -> + msg `shouldSatisfy` T.isInfixOf "exceeds maxBytes" + other -> expectationFailure ("Expected maxBytes failure, got: " <> show other) + + it "reports non-zero command exits with stderr" $ do + let branch = cmdVar "git.branch" "git branch --show-current" + result = + runResolve + [textDecl "git.branch"] + [branch] + Map.empty + [mock (commandVarRun branch) (ExitFailure 2) "" "not a git repo\n"] + case result of + Left [ValidationFailed "git.branch" msg] -> do + msg `shouldSatisfy` T.isInfixOf "exit code 2" + msg `shouldSatisfy` T.isInfixOf "not a git repo" + other -> expectationFailure ("Expected command failure, got: " <> show other) + + it "skips commands with false conditions" $ do + let branch = + withCondition + (Just (ExprEq "release.ready" (VBool True))) + (cmdVar "git.branch" "git branch --show-current") + result = + runResolve + [textDecl "git.branch"] + [branch] + (Map.singleton "release.ready" (resolved (boolDecl "release.ready") (VBool False) FromDefault)) + [mock (commandVarRun branch) ExitSuccess "main\n" ""] + fmap (Map.member "git.branch") result `shouldBe` Right False + + it "validates coerced values against declaration validation" $ do + let branch = cmdVar "git.branch" "git branch --show-current" + result = + runResolve + [patternDecl "git.branch"] + [branch] + Map.empty + [mock (commandVarRun branch) ExitSuccess "Bad_Branch\n" ""] + case result of + Left [ValidationFailed "git.branch" msg] -> + msg `shouldSatisfy` T.isInfixOf "value does not match pattern" + other -> expectationFailure ("Expected validation failure, got: " <> show other) diff --git a/test/Seihou/Core/ContextSpec.hs b/test/Seihou/Core/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/ContextSpec.hs @@ -0,0 +1,60 @@ +module Seihou.Core.ContextSpec (tests) where + +import Data.Map.Strict qualified as Map +import Seihou.Core.Context +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Context" spec + +spec :: Spec +spec = do + describe "resolveContext" $ do + it "returns CLI flag when provided" $ do + result <- resolveContext (Just "work") Map.empty + result `shouldBe` Just "work" + + it "strips whitespace from CLI flag" $ do + result <- resolveContext (Just " work ") Map.empty + result `shouldBe` Just "work" + + it "ignores empty CLI flag and falls through" $ do + result <- resolveContext (Just "") Map.empty + result `shouldBe` Nothing + + it "returns SEIHOU_CONTEXT env var when CLI flag is absent" $ do + let envVars = Map.singleton "SEIHOU_CONTEXT" "personal" + result <- resolveContext Nothing envVars + result `shouldBe` Just "personal" + + it "CLI flag takes precedence over env var" $ do + let envVars = Map.singleton "SEIHOU_CONTEXT" "personal" + result <- resolveContext (Just "work") envVars + result `shouldBe` Just "work" + + it "ignores empty SEIHOU_CONTEXT env var" $ do + let envVars = Map.singleton "SEIHOU_CONTEXT" "" + result <- resolveContext Nothing envVars + result `shouldBe` Nothing + + it "returns Nothing when no source provides a context" $ do + result <- resolveContext Nothing Map.empty + result `shouldBe` Nothing + + describe "validateContextName" $ do + it "accepts a normal context name" $ do + validateContextName "work" `shouldBe` Nothing + + it "accepts a hyphenated context name" $ do + validateContextName "my-work" `shouldBe` Nothing + + it "rejects empty context name" $ do + validateContextName "" `shouldSatisfy` (/= Nothing) + + it "rejects context name containing '..'" $ do + validateContextName "foo..bar" `shouldSatisfy` (/= Nothing) + + it "rejects context name containing '/'" $ do + validateContextName "foo/bar" `shouldSatisfy` (/= Nothing) diff --git a/test/Seihou/Core/ExprSpec.hs b/test/Seihou/Core/ExprSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/ExprSpec.hs @@ -0,0 +1,177 @@ +module Seihou.Core.ExprSpec (tests) where + +import Data.Map.Strict qualified as Map +import Seihou.Core.Expr (evalExpr, exprRefs, parseExpr) +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Expr" spec + +spec :: Spec +spec = do + describe "parseExpr" $ do + it "parses true literal" $ do + parseExpr "true" `shouldBe` Right (ExprLit True) + + it "parses false literal" $ do + parseExpr "false" `shouldBe` Right (ExprLit False) + + it "parses IsSet atom" $ do + parseExpr "IsSet license" `shouldBe` Right (ExprIsSet "license") + + it "parses IsSet with dotted var name" $ do + parseExpr "IsSet project.name" `shouldBe` Right (ExprIsSet "project.name") + + it "parses Eq with quoted value" $ do + parseExpr "Eq license \"MIT\"" + `shouldBe` Right (ExprEq "license" (VText "MIT")) + + it "parses Eq with bare word value" $ do + parseExpr "Eq license MIT" + `shouldBe` Right (ExprEq "license" (VText "MIT")) + + it "parses Eq with bare word true as VBool" $ do + parseExpr "Eq enabled true" + `shouldBe` Right (ExprEq "enabled" (VBool True)) + + it "parses Eq with bare word false as VBool" $ do + parseExpr "Eq enabled false" + `shouldBe` Right (ExprEq "enabled" (VBool False)) + + it "parses Eq with all-digit bare word as VInt" $ do + parseExpr "Eq count 3" + `shouldBe` Right (ExprEq "count" (VInt 3)) + + it "parses Eq with negative integer bare word as VInt" $ do + parseExpr "Eq offset -5" + `shouldBe` Right (ExprEq "offset" (VInt (-5))) + + it "parses Eq with quoted digits as VText (not VInt)" $ do + parseExpr "Eq count \"3\"" + `shouldBe` Right (ExprEq "count" (VText "3")) + + it "parses && expression" $ do + parseExpr "IsSet a && IsSet b" + `shouldBe` Right (ExprAnd (ExprIsSet "a") (ExprIsSet "b")) + + it "parses || expression" $ do + parseExpr "IsSet a || IsSet b" + `shouldBe` Right (ExprOr (ExprIsSet "a") (ExprIsSet "b")) + + it "parses ! negation" $ do + parseExpr "!true" + `shouldBe` Right (ExprNot (ExprLit True)) + + it "parses negation with space" $ do + parseExpr "! false" + `shouldBe` Right (ExprNot (ExprLit False)) + + it "parses parenthesized expression" $ do + parseExpr "(true)" + `shouldBe` Right (ExprLit True) + + it "respects operator precedence: && binds tighter than ||" $ do + parseExpr "IsSet a && IsSet b || IsSet c" + `shouldBe` Right (ExprOr (ExprAnd (ExprIsSet "a") (ExprIsSet "b")) (ExprIsSet "c")) + + it "parentheses override precedence" $ do + parseExpr "IsSet a && (IsSet b || IsSet c)" + `shouldBe` Right (ExprAnd (ExprIsSet "a") (ExprOr (ExprIsSet "b") (ExprIsSet "c"))) + + it "parses compound expression from design doc" $ do + parseExpr "IsSet license && Eq license \"MIT\"" + `shouldBe` Right + ( ExprAnd + (ExprIsSet "license") + (ExprEq "license" (VText "MIT")) + ) + + it "rejects empty expression" $ do + parseExpr "" `shouldBe` Left "empty expression" + + it "rejects malformed expression" $ do + case parseExpr "@#$" of + Left _ -> pure () + Right r -> expectationFailure ("Expected parse error, got: " <> show r) + + it "handles whitespace" $ do + parseExpr " true " `shouldBe` Right (ExprLit True) + + describe "evalExpr" $ do + let vars = + Map.fromList + [ (VarName "license", VText "MIT"), + (VarName "project.name", VText "my-app"), + (VarName "enabled", VBool True) + ] + + it "evaluates ExprLit True" $ do + evalExpr vars (ExprLit True) `shouldBe` True + + it "evaluates ExprLit False" $ do + evalExpr vars (ExprLit False) `shouldBe` False + + it "evaluates ExprIsSet for present variable" $ do + evalExpr vars (ExprIsSet "license") `shouldBe` True + + it "evaluates ExprIsSet for absent variable" $ do + evalExpr vars (ExprIsSet "missing") `shouldBe` False + + it "evaluates ExprEq when values match" $ do + evalExpr vars (ExprEq "license" (VText "MIT")) `shouldBe` True + + it "evaluates ExprEq when values differ" $ do + evalExpr vars (ExprEq "license" (VText "BSD")) `shouldBe` False + + it "evaluates ExprEq with VBool True" $ do + evalExpr vars (ExprEq "enabled" (VBool True)) `shouldBe` True + + it "evaluates ExprEq with VBool False against VBool True" $ do + evalExpr vars (ExprEq "enabled" (VBool False)) `shouldBe` False + + it "evaluates a parsed int Eq against a VInt binding" $ do + let intVars = Map.fromList [(VarName "count", VInt 3)] + case parseExpr "Eq count 3" of + Right expr -> evalExpr intVars expr `shouldBe` True + Left err -> expectationFailure ("Expected parse, got: " <> show err) + + it "evaluates ExprNot" $ do + evalExpr vars (ExprNot (ExprLit True)) `shouldBe` False + evalExpr vars (ExprNot (ExprLit False)) `shouldBe` True + + it "evaluates ExprAnd" $ do + evalExpr vars (ExprAnd (ExprLit True) (ExprLit True)) `shouldBe` True + evalExpr vars (ExprAnd (ExprLit True) (ExprLit False)) `shouldBe` False + + it "evaluates ExprOr" $ do + evalExpr vars (ExprOr (ExprLit True) (ExprLit False)) `shouldBe` True + evalExpr vars (ExprOr (ExprLit False) (ExprLit False)) `shouldBe` False + + it "evaluates compound expression from design doc" $ do + let expr = ExprAnd (ExprIsSet "license") (ExprEq "license" (VText "MIT")) + evalExpr vars expr `shouldBe` True + evalExpr Map.empty expr `shouldBe` False + + describe "exprRefs" $ do + it "returns the compared literal for Eq with a bareword bool" $ do + exprRefs (ExprEq "x" (VBool True)) `shouldBe` [("x", Just (VBool True))] + + it "returns the compared literal for Eq with a quoted string" $ do + exprRefs (ExprEq "x" (VText "true")) `shouldBe` [("x", Just (VText "true"))] + + it "returns a Nothing literal for IsSet" $ do + exprRefs (ExprIsSet "y") `shouldBe` [("y", Nothing)] + + it "collects refs across && with mixed atoms" $ do + exprRefs (ExprAnd (ExprIsSet "y") (ExprEq "z" (VInt 1))) + `shouldBe` [("y", Nothing), ("z", Just (VInt 1))] + + it "recurses through Or and Not" $ do + exprRefs (ExprOr (ExprNot (ExprIsSet "a")) (ExprEq "b" (VBool False))) + `shouldBe` [("a", Nothing), ("b", Just (VBool False))] + + it "returns nothing for a literal" $ do + exprRefs (ExprLit True) `shouldBe` [] diff --git a/test/Seihou/Core/InstallSpec.hs b/test/Seihou/Core/InstallSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/InstallSpec.hs @@ -0,0 +1,31 @@ +module Seihou.Core.InstallSpec (tests) where + +import Seihou.Core.Install (parseModuleName) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Install" spec + +spec :: Spec +spec = do + describe "parseModuleName" $ do + it "extracts repo name from HTTPS URL with .git suffix" $ + parseModuleName "https://github.com/user/my-module.git" `shouldBe` "my-module" + + it "extracts repo name from HTTPS URL without .git suffix" $ + parseModuleName "https://github.com/user/my-module" `shouldBe` "my-module" + + it "returns a bare name unchanged" $ + parseModuleName "my-local-module" `shouldBe` "my-local-module" + + it "extracts repo name from SSH-style URL" $ + -- SSH URLs use : before user, so splitOn "/" takes "user:repo" or similar. + -- The current implementation splits on "/" so "git@github.com:user/repo.git" + -- splits to ["git@github.com:user", "repo.git"] and last segment is "repo". + parseModuleName "git@github.com:user/repo.git" `shouldBe` "repo" + + it "handles URL with trailing slash" $ + -- Trailing slash produces an empty last segment; last returns "" + parseModuleName "https://github.com/user/my-module/" `shouldBe` "" diff --git a/test/Seihou/Core/ListSpec.hs b/test/Seihou/Core/ListSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/ListSpec.hs @@ -0,0 +1,85 @@ +module Seihou.Core.ListSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.Module (DiscoveredModule (..), ModuleSource (..), discoverAllModules) +import Seihou.Core.Types (ModuleLoadError (..)) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Module.discoverAllModules" spec + +-- | Write a minimal valid module.dhall that the Dhall evaluator can parse. +writeMinimalModule :: FilePath -> String -> String -> IO () +writeMinimalModule baseDir name desc = do + let modDir = baseDir name + createDirectoryIfMissing True (modDir "files") + writeFile + (modDir "module.dhall") + ( "{ name = \"" + ++ name + ++ "\", version = None Text, description = Some \"" + ++ desc + ++ "\", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }, exports = [] : List { var : Text, as : Optional Text }, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }, steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }, commands = [] : List { run : Text, workDir : Optional Text }, dependencies = [] : List Text, removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } } }" + ) + +spec :: Spec +spec = do + describe "discoverAllModules" $ do + it "returns empty list when no search paths have modules" $ do + withSystemTempDirectory "seihou-list-test" $ \tmp -> do + let paths = [tmp "project", tmp "user", tmp "installed"] + result <- discoverAllModules paths + length result `shouldBe` 0 + + it "discovers modules in a search path" $ do + withSystemTempDirectory "seihou-list-test" $ \tmp -> do + let userDir = tmp "user" + createDirectoryIfMissing True userDir + writeMinimalModule userDir "my-mod" "A test module" + let paths = [tmp "project", userDir, tmp "installed"] + result <- discoverAllModules paths + length result `shouldBe` 1 + (head result).discoveredSource `shouldBe` SourceUser + + it "tags sources correctly across paths" $ do + withSystemTempDirectory "seihou-list-test" $ \tmp -> do + let projectDir = tmp "project" + installedDir = tmp "installed" + createDirectoryIfMissing True projectDir + createDirectoryIfMissing True installedDir + writeMinimalModule projectDir "mod-a" "Project module" + writeMinimalModule installedDir "mod-b" "Installed module" + let paths = [projectDir, tmp "user", installedDir] + result <- discoverAllModules paths + length result `shouldBe` 2 + let srcs = map (.discoveredSource) result + SourceProject `elem` srcs `shouldBe` True + SourceInstalled `elem` srcs `shouldBe` True + + it "captures load errors for broken modules" $ do + withSystemTempDirectory "seihou-list-test" $ \tmp -> do + let userDir = tmp "user" + brokenDir = userDir "broken" + createDirectoryIfMissing True brokenDir + writeFile (brokenDir "module.dhall") "this is not valid dhall" + let paths = [tmp "project", userDir, tmp "installed"] + result <- discoverAllModules paths + length result `shouldBe` 1 + case (head result).discoveredResult of + Left _ -> pure () + Right _ -> expectationFailure "Expected Left for broken module" + + it "skips directories without module.dhall" $ do + withSystemTempDirectory "seihou-list-test" $ \tmp -> do + let userDir = tmp "user" + emptyDir = userDir "not-a-module" + createDirectoryIfMissing True emptyDir + writeMinimalModule userDir "real-mod" "Real module" + let paths = [tmp "project", userDir, tmp "installed"] + result <- discoverAllModules paths + length result `shouldBe` 1 diff --git a/test/Seihou/Core/MigrationSpec.hs b/test/Seihou/Core/MigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/MigrationSpec.hs @@ -0,0 +1,165 @@ +module Seihou.Core.MigrationSpec (tests) where + +import Data.Text (Text) +import Seihou.Core.Migration + ( Migration (..), + MigrationOp (..), + MigrationPlan (..), + MigrationPlanError (..), + planMigrationChain, + ) +import Seihou.Core.Version (Version, parseVersion) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Migration" spec + +spec :: Spec +spec = do + describe "planMigrationChain (window walker)" $ do + it "returns Nothing when installed equals target" $ do + let r = planMigrationChain "demo" [] (mkV "1.0.0") (mkV "1.0.0") + r `shouldBe` Right Nothing + + it "rejects a downgrade with MigrationDowngradeNotSupported" $ do + let r = planMigrationChain "demo" [] (mkV "2.0.0") (mkV "1.0.0") + r `shouldBe` Left (MigrationDowngradeNotSupported (mkV "2.0.0") (mkV "1.0.0")) + + it "builds a single-edge plan whose target equals the edge's `to`" $ do + let m = Migration {from = "1.0.0", to = "2.0.0", ops = [DeleteFile {path = "a"}]} + r = planMigrationChain "demo" [m] (mkV "1.0.0") (mkV "2.0.0") + case r of + Right (Just plan) -> do + plan.planModule `shouldBe` "demo" + plan.planFrom `shouldBe` mkV "1.0.0" + plan.planTo `shouldBe` mkV "2.0.0" + plan.planSteps `shouldBe` [m] + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "builds a two-edge plan in order regardless of declaration order" $ do + let m1 = Migration "1.0.0" "2.0.0" [DeleteFile "a"] + m2 = Migration "2.0.0" "3.0.0" [DeleteFile "b"] + r = planMigrationChain "demo" [m2, m1] (mkV "1.0.0") (mkV "3.0.0") + case r of + Right (Just plan) -> do + plan.planSteps `shouldBe` [m1, m2] + plan.planTo `shouldBe` mkV "3.0.0" + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + -- Live-tree master-plan fixture (manifest=0.1.0, target=0.3.0, + -- declared [0.1.0 -> 0.2.0]). The chain reaches 0.2.0 via ops; the + -- manifest still advances to the supplied target 0.3.0. + it "yields a partial-cover plan for the EP-5 master-plan fixture" $ do + let m = Migration "0.1.0" "0.2.0" [] + r = planMigrationChain "demo" [m] (mkV "0.1.0") (mkV "0.3.0") + case r of + Right (Just plan) -> do + plan.planSteps `shouldBe` [m] + plan.planFrom `shouldBe` mkV "0.1.0" + plan.planTo `shouldBe` mkV "0.3.0" + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "yields an empty-steps plan when no declared migration falls in the window" $ do + let r = planMigrationChain "demo" [] (mkV "0.1.3") (mkV "0.3.0") + case r of + Right (Just plan) -> do + plan.planSteps `shouldBe` [] + plan.planFrom `shouldBe` mkV "0.1.3" + plan.planTo `shouldBe` mkV "0.3.0" + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "reports MigrationVersionUnparseable when a from string is malformed" $ do + let m = Migration "not-a-version" "2.0.0" [] + r = planMigrationChain "demo" [m] (mkV "1.0.0") (mkV "2.0.0") + r `shouldBe` Left (MigrationVersionUnparseable "not-a-version") + + it "reports MigrationVersionUnparseable when a to string is malformed" $ do + let m = Migration "1.0.0" "" [] + r = planMigrationChain "demo" [m] (mkV "1.0.0") (mkV "2.0.0") + r `shouldBe` Left (MigrationVersionUnparseable "") + + it "rejects two edges sharing the same from with MigrationDuplicateEdge" $ do + let m1 = Migration "1.0.0" "2.0.0" [] + m2 = Migration "1.0.0" "1.5.0" [] + r = planMigrationChain "demo" [m1, m2] (mkV "1.0.0") (mkV "2.0.0") + case r of + Left (MigrationDuplicateEdge fromV _) -> fromV `shouldBe` mkV "1.0.0" + other -> expectationFailure ("Expected MigrationDuplicateEdge, got: " <> show other) + + it "ignores migrations whose from precedes the installed version" $ do + -- An old 0.5.0 → 1.0.0 migration is irrelevant when installed is 1.0.0. + let stale = Migration "0.5.0" "1.0.0" [] + live = Migration "1.0.0" "2.0.0" [DeleteFile "x"] + r = planMigrationChain "demo" [stale, live] (mkV "1.0.0") (mkV "2.0.0") + case r of + Right (Just plan) -> do + plan.planSteps `shouldBe` [live] + plan.planTo `shouldBe` mkV "2.0.0" + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "treats version equality with trailing zeros consistently" $ do + -- `mkV "1.0"` and `mkV "1.0.0"` compare equal; planner should treat + -- them as no-op. + let r = planMigrationChain "demo" [] (mkV "1.0") (mkV "1.0.0") + r `shouldBe` Right Nothing + + -- ---------------------------------------------------------------- + -- New EP-35 contract pins + -- ---------------------------------------------------------------- + + it "user's two-component fixture: 0.2 / 0.6 with [{0.2→0.3}, {0.5→0.6}] yields both edges" $ do + let early = Migration "0.2" "0.3" [DeleteFile "v2"] + late = Migration "0.5" "0.6" [DeleteFile "v5"] + r = planMigrationChain "foo" [early, late] (mkV "0.2") (mkV "0.6") + case r of + Right (Just plan) -> do + plan.planFrom `shouldBe` mkV "0.2" + plan.planTo `shouldBe` mkV "0.6" + plan.planSteps `shouldBe` [early, late] + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "skips migrations that overshoot the supplied target" $ do + let m = Migration "0.5" "1.0" [] + r = planMigrationChain "demo" [m] (mkV "0.4") (mkV "0.6") + case r of + Right (Just plan) -> do + plan.planSteps `shouldBe` [] + plan.planTo `shouldBe` mkV "0.6" + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "skips overlapping migrations once the cursor has advanced past them" $ do + let big = Migration "0.2" "0.5" [DeleteFile "a"] + small = Migration "0.3" "0.4" [DeleteFile "b"] + r = planMigrationChain "demo" [big, small] (mkV "0.2") (mkV "0.5") + case r of + Right (Just plan) -> + plan.planSteps `shouldBe` [big] + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "empty migrations list with installed != target yields empty-steps plan with target" $ do + let r = planMigrationChain "demo" [] (mkV "0.1") (mkV "0.3") + case r of + Right (Just plan) -> do + plan.planSteps `shouldBe` [] + plan.planFrom `shouldBe` mkV "0.1" + plan.planTo `shouldBe` mkV "0.3" + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + + it "edges with `to == target` are picked" $ do + let m = Migration "0.2" "0.3" [DeleteFile "x"] + r = planMigrationChain "demo" [m] (mkV "0.2") (mkV "0.3") + case r of + Right (Just plan) -> + plan.planSteps `shouldBe` [m] + other -> expectationFailure ("Expected Right (Just ...), got: " <> show other) + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +mkV :: Text -> Version +mkV t = case parseVersion t of + Just ver -> ver + Nothing -> error ("MigrationSpec.mkV: bad version literal " <> show t) diff --git a/test/Seihou/Core/ModuleSpec.hs b/test/Seihou/Core/ModuleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/ModuleSpec.hs @@ -0,0 +1,276 @@ +module Seihou.Core.ModuleSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.Module (discoverModule, loadModule, validateModule) +import Seihou.Core.Types +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Module" spec + +-- | A well-formed module for pure validation tests. +goodModule :: Module +goodModule = + Module + { name = "test-module", + version = Just "1.0.0", + description = Just "A test module", + vars = + [ VarDecl + { name = "project.name", + type_ = VTText, + default_ = Nothing, + description = Just "Project name", + required = True, + validation = Nothing + } + ], + exports = [VarExport {var = "project.name", alias = Nothing}], + prompts = [Prompt {var = "project.name", text = "Name?", condition = Nothing, choices = Nothing}], + steps = + [ Step + { strategy = Template, + src = "README.md.tpl", + dest = "README.md", + condition = Nothing, + patch = Nothing + } + ], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + +-- | Helpers to update Module fields without ambiguous record updates. +withModuleName :: ModuleName -> Module -> Module +withModuleName n m = Module n m.version m.description m.vars m.exports m.prompts m.steps m.commands m.dependencies m.removal m.migrations + +withModuleVars :: [VarDecl] -> Module -> Module +withModuleVars v m = Module m.name m.version m.description v m.exports m.prompts m.steps m.commands m.dependencies m.removal m.migrations + +withModulePrompts :: [Prompt] -> Module -> Module +withModulePrompts p m = Module m.name m.version m.description m.vars m.exports p m.steps m.commands m.dependencies m.removal m.migrations + +hasError :: T.Text -> [T.Text] -> Bool +hasError needle = any (T.isInfixOf needle) + +spec :: Spec +spec = do + describe "discoverModule" $ do + it "finds a module in the search path" $ do + cwd <- getCurrentDirectory + let searchPaths = [cwd "test" "fixtures"] + result <- discoverModule searchPaths "haskell-base" + case result of + Right path -> path `shouldBe` (cwd "test" "fixtures" "haskell-base") + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + + it "returns ModuleNotFound when module does not exist" $ do + result <- discoverModule ["/nonexistent/path"] "no-such-module" + case result of + Left (ModuleNotFound name paths) -> do + name.unModuleName `shouldBe` "no-such-module" + paths `shouldBe` ["/nonexistent/path"] + Left other -> expectationFailure ("Expected ModuleNotFound, got: " <> show other) + Right _ -> expectationFailure "Expected Left, got Right" + + it "searches paths in order and returns the first match" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let dir1 = tmpDir "first" + let dir2 = tmpDir "second" + createDirectoryIfMissing True (dir1 "my-mod") + createDirectoryIfMissing True (dir2 "my-mod") + writeFile (dir1 "my-mod" "module.dhall") "{ name = \"my-mod\" }" + writeFile (dir2 "my-mod" "module.dhall") "{ name = \"my-mod\" }" + result <- discoverModule [dir1, dir2] "my-mod" + case result of + Right path -> path `shouldBe` (dir1 "my-mod") + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + describe "validateModule" $ do + it "passes a well-formed module" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + result <- validateModule tmpDir goodModule + case result of + Right m -> m.name `shouldBe` "test-module" + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "rejects a bad module name" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = withModuleName "BadName" goodModule + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "module name must match" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "rejects duplicate variable names" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let dup = + withModuleVars + [ VarDecl "x" VTText Nothing Nothing True Nothing, + VarDecl "x" VTBool Nothing Nothing False Nothing + ] + goodModule + result <- validateModule tmpDir dup + case result of + Left (ValidationError _ errs) -> + hasError "duplicate variable name" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "rejects prompt referencing undeclared variable" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = + withModulePrompts + [Prompt {var = "nonexistent", text = "?", condition = Nothing, choices = Nothing}] + goodModule + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "prompt references undeclared" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "rejects missing source file" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + result <- validateModule tmpDir goodModule + case result of + Left (ValidationError _ errs) -> + hasError "step source file not found" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "rejects export referencing undeclared variable" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = + goodModule + { exports = [VarExport {var = "nonexistent", alias = Nothing}] + } + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "export references undeclared" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "rejects unsafe destination path with .." $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = + goodModule + { steps = + [Step Template "README.md.tpl" "../etc/passwd" Nothing Nothing] + } + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "must not contain '..'" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "rejects absolute destination path" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = + goodModule + { steps = + [Step Template "README.md.tpl" "/etc/passwd" Nothing Nothing] + } + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "must be relative" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "allows dots inside destination filenames" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let dotted = + goodModule + { steps = + [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing] + } + result <- validateModule tmpDir dotted + case result of + Right m -> m.name `shouldBe` "test-module" + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "rejects destination referencing undeclared variable" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let bad = + goodModule + { steps = + [Step Template "README.md.tpl" "src/{{unknown}}/Main.hs" Nothing Nothing] + } + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + hasError "destination references undeclared" errs `shouldBe` True + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + it "collects multiple errors at once" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let bad = + Module + { name = "BadName", + version = Nothing, + description = Nothing, + vars = [], + exports = [VarExport {var = "missing", alias = Nothing}], + prompts = [Prompt {var = "missing", text = "?", condition = Nothing, choices = Nothing}], + steps = [Step Template "nonexistent.tpl" "/bad/dest" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + result <- validateModule tmpDir bad + case result of + Left (ValidationError _ errs) -> + length errs `shouldSatisfy` (>= 4) + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + describe "loadModule" $ do + it "loads the haskell-base fixture end-to-end" $ do + cwd <- getCurrentDirectory + let searchPaths = [cwd "test" "fixtures"] + result <- loadModule searchPaths "haskell-base" + case result of + Right m -> do + m.name `shouldBe` "haskell-base" + length (m.vars) `shouldBe` 3 + length (m.steps) `shouldBe` 5 + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + + it "returns ModuleNotFound for nonexistent module" $ do + result <- loadModule ["/nonexistent"] "no-such-module" + case result of + Left (ModuleNotFound _ _) -> pure () + Left other -> expectationFailure ("Expected ModuleNotFound, got: " <> show other) + Right _ -> expectationFailure "Expected Left, got Right" diff --git a/test/Seihou/Core/RecipeSpec.hs b/test/Seihou/Core/RecipeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/RecipeSpec.hs @@ -0,0 +1,116 @@ +module Seihou.Core.RecipeSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Recipe (validateRecipe) +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Recipe" spec + +hasError :: T.Text -> [T.Text] -> Bool +hasError needle = any (T.isInfixOf needle) + +spec :: Spec +spec = do + describe "validateRecipe" $ do + it "passes a valid recipe" $ do + let recipe = + Recipe + { name = "valid-recipe", + version = Just "1.0.0", + description = Just "A valid recipe", + modules = [simpleDep "mod-a", simpleDep "mod-b"], + vars = [], + prompts = [] + } + validateRecipe recipe `shouldBe` Right recipe + + it "rejects an empty modules list" $ do + let recipe = + Recipe + { name = "empty-recipe", + version = Nothing, + description = Nothing, + modules = [], + vars = [], + prompts = [] + } + case validateRecipe recipe of + Left errs -> hasError "at least one module" errs `shouldBe` True + Right _ -> expectationFailure "Expected validation failure" + + it "rejects an invalid recipe name" $ do + let recipe = + Recipe + { name = "BadName", + version = Nothing, + description = Nothing, + modules = [simpleDep "mod-a"], + vars = [], + prompts = [] + } + case validateRecipe recipe of + Left errs -> hasError "recipe name must match" errs `shouldBe` True + Right _ -> expectationFailure "Expected validation failure" + + it "rejects duplicate module names" $ do + let recipe = + Recipe + { name = "dup-recipe", + version = Nothing, + description = Nothing, + modules = [simpleDep "mod-a", simpleDep "mod-b", simpleDep "mod-a"], + vars = [], + prompts = [] + } + case validateRecipe recipe of + Left errs -> hasError "duplicate module" errs `shouldBe` True + Right _ -> expectationFailure "Expected validation failure" + + it "rejects invalid variable binding name" $ do + let recipe = + Recipe + { name = "bad-var-recipe", + version = Nothing, + description = Nothing, + modules = + [ Dependency (ModuleName "mod-a") (Map.singleton (VarName "INVALID") "val") + ], + vars = [], + prompts = [] + } + case validateRecipe recipe of + Left errs -> hasError "invalid var binding name" errs `shouldBe` True + Right _ -> expectationFailure "Expected validation failure" + + it "accepts valid variable binding names with dots" $ do + let recipe = + Recipe + { name = "dotted-vars", + version = Nothing, + description = Nothing, + modules = + [ Dependency (ModuleName "mod-a") (Map.singleton (VarName "nix.system") "aarch64-darwin") + ], + vars = [], + prompts = [] + } + validateRecipe recipe `shouldBe` Right recipe + + it "collects multiple errors at once" $ do + let recipe = + Recipe + { name = "BadName", + version = Nothing, + description = Nothing, + modules = [], + vars = [], + prompts = [] + } + case validateRecipe recipe of + Left errs -> length errs `shouldSatisfy` (>= 2) + Right _ -> expectationFailure "Expected validation failure" diff --git a/test/Seihou/Core/RegistryEmitSpec.hs b/test/Seihou/Core/RegistryEmitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/RegistryEmitSpec.hs @@ -0,0 +1,191 @@ +module Seihou.Core.RegistryEmitSpec (tests) where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Registry (Registry (..), RegistryEntry (..), renderRegistryDhall) +import Seihou.Core.Types (ModuleName (..)) +import Seihou.Dhall.Eval (evalRegistryFromFile) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.RegistryEmit" spec + +spec :: Spec +spec = describe "renderRegistryDhall" $ do + it "round-trips a registry with two modules and one recipe" $ do + let reg = + Registry + { repoName = "Sample", + repoDescription = Just "A sample registry", + modules = + [ RegistryEntry + { name = ModuleName "alpha", + version = Just "1.0.0", + path = "modules/alpha", + description = Just "Alpha module", + tags = ["starter", "haskell"] + }, + RegistryEntry + { name = ModuleName "beta", + version = Nothing, + path = "modules/beta", + description = Nothing, + tags = [] + } + ], + recipes = + [ RegistryEntry + { name = ModuleName "library-recipe", + version = Just "0.1.0", + path = "recipes/library-recipe", + description = Just "Library recipe", + tags = ["lib"] + } + ], + blueprints = [], + prompts = [] + } + roundTrip reg + + it "round-trips a registry with no recipes" $ do + let reg = + Registry + { repoName = "Modules Only", + repoDescription = Nothing, + modules = + [ RegistryEntry + { name = ModuleName "solo", + version = Just "2.1.3", + path = "solo", + description = Nothing, + tags = [] + } + ], + recipes = [], + blueprints = [], + prompts = [] + } + roundTrip reg + + it "round-trips an entry with version = Nothing" $ do + let reg = + Registry + { repoName = "Unversioned", + repoDescription = Nothing, + modules = + [ RegistryEntry + { name = ModuleName "nover", + version = Nothing, + path = "nover", + description = Nothing, + tags = [] + } + ], + recipes = [], + blueprints = [], + prompts = [] + } + roundTrip reg + + it "escapes quotes and backslashes in description" $ do + let reg = + Registry + { repoName = "Escape \"test\"", + repoDescription = Just "has \"quotes\" and \\ backslashes", + modules = + [ RegistryEntry + { name = ModuleName "escaped", + version = Just "0.1.0", + path = "escaped", + description = Just "weird: \"quoted\" \\ and $var", + tags = ["has \"quote\""] + } + ], + recipes = [], + blueprints = [], + prompts = [] + } + roundTrip reg + + it "round-trips an empty registry" $ do + let reg = + Registry + { repoName = "Empty", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [], + prompts = [] + } + roundTrip reg + + it "round-trips a registry with all four entry kinds" $ do + let reg = + Registry + { repoName = "All Four", + repoDescription = Just "Modules, recipes, blueprints, and prompts", + modules = + [ RegistryEntry + { name = ModuleName "mod-one", + version = Just "1.0.0", + path = "modules/mod-one", + description = Just "Module entry", + tags = ["m"] + } + ], + recipes = + [ RegistryEntry + { name = ModuleName "rec-one", + version = Just "0.2.0", + path = "recipes/rec-one", + description = Just "Recipe entry", + tags = ["r"] + } + ], + blueprints = + [ RegistryEntry + { name = ModuleName "bp-one", + version = Just "0.3.0", + path = "blueprints/bp-one", + description = Just "Blueprint entry", + tags = ["agent", "service"] + }, + RegistryEntry + { name = ModuleName "bp-two", + version = Nothing, + path = "blueprints/bp-two", + description = Nothing, + tags = [] + } + ], + prompts = + [ RegistryEntry + { name = ModuleName "prompt-one", + version = Just "0.4.0", + path = "prompts/prompt-one", + description = Just "Prompt entry", + tags = ["agent"] + } + ] + } + roundTrip reg + +roundTrip :: Registry -> Expectation +roundTrip reg = + withSystemTempDirectory "seihou-registry-emit" $ \tmpDir -> do + let path = tmpDir "seihou-registry.dhall" + TIO.writeFile path (renderRegistryDhall reg) + result <- evalRegistryFromFile path + case result of + Left err -> + expectationFailure + ( "expected round-trip success, got Left: " + <> show err + <> "\nrendered:\n" + <> T.unpack (renderRegistryDhall reg) + ) + Right decoded -> decoded `shouldBe` reg diff --git a/test/Seihou/Core/RegistrySpec.hs b/test/Seihou/Core/RegistrySpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/RegistrySpec.hs @@ -0,0 +1,874 @@ +module Seihou.Core.RegistrySpec (tests) where + +import Data.List (isInfixOf) +import Data.Text (Text) +import Seihou.Core.Registry + ( EntryKind (..), + Registry (..), + RegistryEntry (..), + RegistryValidationIssue (..), + RegistryValidationReport (..), + RepoContents (..), + SyncDiff (..), + SyncReport (..), + SyncStatus (..), + computeRegistrySync, + discoverRepoContents, + validateRegistry, + validateRegistryFull, + ) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalRegistryFromFile) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Registry" spec + +spec :: Spec +spec = do + describe "evalRegistryFromFile" $ do + it "decodes a valid registry with two modules" $ do + withSystemTempDirectory "seihou-registry-test" $ \tmpDir -> do + let dhall = + "{ repoName = \"Haskell Templates\"\n\ + \, repoDescription = Some \"A collection of Haskell project templates\"\n\ + \, modules =\n\ + \ [ { name = \"haskell-base\"\n\ + \ , version = None Text\n\ + \ , path = \"modules/haskell-base\"\n\ + \ , description = Some \"Minimal Haskell project with cabal\"\n\ + \ , tags = [ \"haskell\", \"starter\" ]\n\ + \ }\n\ + \ , { name = \"nix-flake\"\n\ + \ , version = None Text\n\ + \ , path = \"modules/nix-flake\"\n\ + \ , description = Some \"Nix flake overlay\"\n\ + \ , tags = [ \"nix\" ]\n\ + \ }\n\ + \ ]\n\ + \}" + writeFile (tmpDir "seihou-registry.dhall") dhall + result <- evalRegistryFromFile (tmpDir "seihou-registry.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right reg -> do + reg.repoName `shouldBe` "Haskell Templates" + reg.repoDescription `shouldBe` Just "A collection of Haskell project templates" + length reg.modules `shouldBe` 2 + let (e1 : e2 : _) = reg.modules + e1.name `shouldBe` ModuleName "haskell-base" + e1.path `shouldBe` "modules/haskell-base" + e1.description `shouldBe` Just "Minimal Haskell project with cabal" + e1.tags `shouldBe` ["haskell", "starter"] + e2.name `shouldBe` ModuleName "nix-flake" + e2.tags `shouldBe` ["nix"] + + it "decodes a registry with an empty module list" $ do + withSystemTempDirectory "seihou-registry-test" $ \tmpDir -> do + let dhall = + "{ repoName = \"Empty Collection\"\n\ + \, repoDescription = None Text\n\ + \, modules = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }\n\ + \}" + writeFile (tmpDir "seihou-registry.dhall") dhall + result <- evalRegistryFromFile (tmpDir "seihou-registry.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right reg -> do + reg.repoName `shouldBe` "Empty Collection" + reg.repoDescription `shouldBe` Nothing + reg.modules `shouldBe` [] + + it "decodes a registry with no description" $ do + withSystemTempDirectory "seihou-registry-test" $ \tmpDir -> do + let dhall = + "{ repoName = \"Minimal\"\n\ + \, repoDescription = None Text\n\ + \, modules =\n\ + \ [ { name = \"one\"\n\ + \ , version = None Text\n\ + \ , path = \"one\"\n\ + \ , description = None Text\n\ + \ , tags = [] : List Text\n\ + \ }\n\ + \ ]\n\ + \}" + writeFile (tmpDir "seihou-registry.dhall") dhall + result <- evalRegistryFromFile (tmpDir "seihou-registry.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right reg -> do + reg.repoDescription `shouldBe` Nothing + let (e1 : _) = reg.modules + e1.description `shouldBe` Nothing + e1.tags `shouldBe` [] + + it "returns RegistryEvalError for malformed registry (missing required field)" $ do + withSystemTempDirectory "seihou-registry-test" $ \tmpDir -> do + let dhall = + "{ repoName = \"Bad\"\n\ + \, modules = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }\n\ + \}" + writeFile (tmpDir "seihou-registry.dhall") dhall + result <- evalRegistryFromFile (tmpDir "seihou-registry.dhall") + case result of + Left (RegistryEvalError _ _) -> pure () + Left other -> expectationFailure ("Expected RegistryEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left for malformed registry" + + it "returns RegistryEvalError for nonexistent file" $ do + result <- evalRegistryFromFile "/nonexistent/path/seihou-registry.dhall" + case result of + Left (RegistryEvalError _ _) -> pure () + Left other -> expectationFailure ("Expected RegistryEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left for nonexistent file" + + describe "discoverRepoContents" $ do + it "returns MultiModule when seihou-registry.dhall exists" $ do + withSystemTempDirectory "seihou-discover-test" $ \tmpDir -> do + writeRegistryFile tmpDir + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + MultiModule reg -> reg.repoName `shouldBe` "Test Registry" + other -> expectationFailure ("Expected MultiModule, got: " <> show other) + + it "returns SingleModule when only module.dhall exists" $ do + withSystemTempDirectory "seihou-discover-test" $ \tmpDir -> do + writeMinimalModuleDhall (tmpDir "module.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleModule p -> p `shouldBe` tmpDir + other -> expectationFailure ("Expected SingleModule, got: " <> show other) + + it "returns MultiModule when both registry and module.dhall exist" $ do + withSystemTempDirectory "seihou-discover-test" $ \tmpDir -> do + writeRegistryFile tmpDir + writeMinimalModuleDhall (tmpDir "module.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + MultiModule reg -> reg.repoName `shouldBe` "Test Registry" + other -> expectationFailure ("Expected MultiModule (registry takes precedence), got: " <> show other) + + it "returns EmptyRepo when neither file exists" $ do + withSystemTempDirectory "seihou-discover-test" $ \tmpDir -> do + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + EmptyRepo -> pure () + other -> expectationFailure ("Expected EmptyRepo, got: " <> show other) + + it "falls back to SingleModule when registry is malformed and module.dhall exists" $ do + withSystemTempDirectory "seihou-discover-test" $ \tmpDir -> do + writeFile (tmpDir "seihou-registry.dhall") "{ broken = True }" + writeMinimalModuleDhall (tmpDir "module.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleModule _ -> pure () + other -> expectationFailure ("Expected SingleModule fallback, got: " <> show other) + + describe "validateRegistry" $ do + it "returns no errors for a valid registry" $ do + withSystemTempDirectory "seihou-validate-reg" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "mod-a") + writeMinimalModuleDhall (tmpDir "mod-a" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "mod-a") Nothing "mod-a" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + errs <- validateRegistry tmpDir reg + errs `shouldBe` [] + + it "reports invalid module name" $ do + withSystemTempDirectory "seihou-validate-reg" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "Bad_Name") + writeMinimalModuleDhall (tmpDir "Bad_Name" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "Bad_Name") Nothing "Bad_Name" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + errs <- validateRegistry tmpDir reg + length errs `shouldSatisfy` (> 0) + any ("must match" `isInfixOf`) (map show errs) `shouldBe` True + + it "reports missing module.dhall at entry path" $ do + withSystemTempDirectory "seihou-validate-reg" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "missing") Nothing "nonexistent" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + errs <- validateRegistry tmpDir reg + length errs `shouldSatisfy` (> 0) + any ("missing module.dhall" `isInfixOf`) (map show errs) `shouldBe` True + + it "reports unsafe path with .." $ do + withSystemTempDirectory "seihou-validate-reg" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "bad-path") Nothing "../escape" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + errs <- validateRegistry tmpDir reg + any ("must not contain" `isInfixOf`) (map show errs) `shouldBe` True + + describe "validateRegistryFull" $ do + it "returns no issues for a fully clean registry" $ do + withSystemTempDirectory "seihou-validate-full" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "mod-a") + writeMinimalModuleDhall (tmpDir "mod-a" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "mod-a") (Just "1.0.0") "mod-a" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + lookups = [(ModuleEntry, ModuleName "mod-a", Just "1.0.0")] + report <- validateRegistryFull tmpDir reg lookups + report.reportIssues `shouldBe` [] + report.reportModuleCount `shouldBe` 1 + report.reportRecipeCount `shouldBe` 0 + report.reportBlueprintCount `shouldBe` 0 + report.reportPromptCount `shouldBe` 0 + + it "flags a SyncMissing entry as a single VersionMismatch" $ do + withSystemTempDirectory "seihou-validate-full" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "mod-a") + writeMinimalModuleDhall (tmpDir "mod-a" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "mod-a") Nothing "mod-a" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + lookups = [(ModuleEntry, ModuleName "mod-a", Just "1.0.0")] + report <- validateRegistryFull tmpDir reg lookups + case report.reportIssues of + [VersionMismatch d] -> d.diffStatus `shouldBe` SyncMissing + other -> expectationFailure ("expected one VersionMismatch SyncMissing, got: " <> show other) + + it "flags a SyncStale entry as a single VersionMismatch carrying the new version" $ do + withSystemTempDirectory "seihou-validate-full" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "mod-a") + writeMinimalModuleDhall (tmpDir "mod-a" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "mod-a") (Just "1.0.0") "mod-a" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + lookups = [(ModuleEntry, ModuleName "mod-a", Just "2.0.0")] + report <- validateRegistryFull tmpDir reg lookups + case report.reportIssues of + [VersionMismatch d] -> d.diffStatus `shouldBe` SyncStale "2.0.0" + other -> expectationFailure ("expected one VersionMismatch SyncStale, got: " <> show other) + + it "flags an invalid module name as a StructuralError" $ do + withSystemTempDirectory "seihou-validate-full" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "Bad_Name") + writeMinimalModuleDhall (tmpDir "Bad_Name" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "Bad_Name") Nothing "Bad_Name" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + lookups = [(ModuleEntry, ModuleName "Bad_Name", Nothing)] + report <- validateRegistryFull tmpDir reg lookups + let structurals = [msg | StructuralError msg <- report.reportIssues] + any ("must match" `isInfixOf`) (map show structurals) `shouldBe` True + + it "flags an unsafe path with .. as a StructuralError" $ do + withSystemTempDirectory "seihou-validate-full" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []], + recipes = [], + blueprints = [], + prompts = [] + } + report <- validateRegistryFull tmpDir reg [] + let structurals = [msg | StructuralError msg <- report.reportIssues] + any ("must not contain" `isInfixOf`) (map show structurals) `shouldBe` True + + it "lists structural issues before version issues when both are present" $ do + withSystemTempDirectory "seihou-validate-full" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "good") + writeMinimalModuleDhall (tmpDir "good" "module.dhall") + createDirectoryIfMissing True (tmpDir "stale") + writeMinimalModuleDhall (tmpDir "stale" "module.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = + [ RegistryEntry (ModuleName "good") (Just "1.0.0") "good" Nothing [], + RegistryEntry (ModuleName "missing-mod") Nothing "no-such-dir" Nothing [], + RegistryEntry (ModuleName "stale") (Just "1.0.0") "stale" Nothing [] + ], + recipes = [], + blueprints = [], + prompts = [] + } + lookups = + [ (ModuleEntry, ModuleName "good", Just "1.0.0"), + (ModuleEntry, ModuleName "stale", Just "2.0.0") + ] + report <- validateRegistryFull tmpDir reg lookups + length report.reportIssues `shouldBe` 2 + case report.reportIssues of + [StructuralError msg, VersionMismatch d] -> do + ("missing module.dhall" `isInfixOf` show msg) `shouldBe` True + d.diffStatus `shouldBe` SyncStale "2.0.0" + other -> + expectationFailure + ("expected [StructuralError, VersionMismatch], got: " <> show other) + + describe "blueprints in registries" $ do + it "decodes a registry with all four entry kinds" $ do + withSystemTempDirectory "seihou-registry-bp" $ \tmpDir -> do + let dhall = + "{ repoName = \"Four Kinds\"\n\ + \, repoDescription = None Text\n\ + \, modules =\n\ + \ [ { name = \"mod-one\"\n\ + \ , version = None Text\n\ + \ , path = \"modules/mod-one\"\n\ + \ , description = None Text\n\ + \ , tags = [] : List Text\n\ + \ }\n\ + \ ]\n\ + \, recipes =\n\ + \ [ { name = \"rec-one\"\n\ + \ , version = None Text\n\ + \ , path = \"recipes/rec-one\"\n\ + \ , description = None Text\n\ + \ , tags = [] : List Text\n\ + \ }\n\ + \ ]\n\ + \, blueprints =\n\ + \ [ { name = \"bp-one\"\n\ + \ , version = Some \"0.1.0\"\n\ + \ , path = \"blueprints/bp-one\"\n\ + \ , description = Some \"A blueprint\"\n\ + \ , tags = [ \"agent\" ]\n\ + \ }\n\ + \ ]\n\ + \, prompts =\n\ + \ [ { name = \"prompt-one\"\n\ + \ , version = Some \"0.2.0\"\n\ + \ , path = \"prompts/prompt-one\"\n\ + \ , description = Some \"A prompt\"\n\ + \ , tags = [ \"review\" ]\n\ + \ }\n\ + \ ]\n\ + \}" + writeFile (tmpDir "seihou-registry.dhall") dhall + result <- evalRegistryFromFile (tmpDir "seihou-registry.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right reg -> do + length reg.modules `shouldBe` 1 + length reg.recipes `shouldBe` 1 + length reg.blueprints `shouldBe` 1 + length reg.prompts `shouldBe` 1 + let (bp : _) = reg.blueprints + bp.name `shouldBe` ModuleName "bp-one" + bp.version `shouldBe` Just "0.1.0" + bp.tags `shouldBe` ["agent"] + let (prompt : _) = reg.prompts + prompt.name `shouldBe` ModuleName "prompt-one" + prompt.version `shouldBe` Just "0.2.0" + prompt.tags `shouldBe` ["review"] + + it "decodes a pre-EP-33 registry (no blueprints or prompts fields) with empty lists" $ do + withSystemTempDirectory "seihou-registry-bp-compat" $ \tmpDir -> do + let dhall = + "{ repoName = \"Old Registry\"\n\ + \, repoDescription = None Text\n\ + \, modules =\n\ + \ [ { name = \"mod-a\"\n\ + \ , version = None Text\n\ + \ , path = \"mod-a\"\n\ + \ , description = None Text\n\ + \ , tags = [] : List Text\n\ + \ }\n\ + \ ]\n\ + \}" + writeFile (tmpDir "seihou-registry.dhall") dhall + result <- evalRegistryFromFile (tmpDir "seihou-registry.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right reg -> do + reg.recipes `shouldBe` [] + reg.blueprints `shouldBe` [] + reg.prompts `shouldBe` [] + + it "rejects an invalid blueprint name" $ do + withSystemTempDirectory "seihou-validate-bp" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "Bad_Bp") + writeMinimalBlueprintDhall (tmpDir "Bad_Bp" "blueprint.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [RegistryEntry (ModuleName "Bad_Bp") Nothing "Bad_Bp" Nothing []], + prompts = [] + } + errs <- validateRegistry tmpDir reg + any ("blueprint name must match" `isInfixOf`) (map show errs) `shouldBe` True + + it "reports a missing blueprint.dhall at the entry path" $ do + withSystemTempDirectory "seihou-validate-bp-missing" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [RegistryEntry (ModuleName "ghost") Nothing "ghost" Nothing []], + prompts = [] + } + errs <- validateRegistry tmpDir reg + any ("missing blueprint.dhall" `isInfixOf`) (map show errs) `shouldBe` True + + it "rejects an unsafe blueprint path with .." $ do + withSystemTempDirectory "seihou-validate-bp-path" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []], + prompts = [] + } + errs <- validateRegistry tmpDir reg + any ("blueprint path must not contain" `isInfixOf`) (map show errs) `shouldBe` True + + it "detects module-blueprint and recipe-blueprint cross-kind name collisions" $ do + withSystemTempDirectory "seihou-collision-bp" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "shared-mod") + writeMinimalModuleDhall (tmpDir "shared-mod" "module.dhall") + createDirectoryIfMissing True (tmpDir "shared-rec") + writeMinimalRecipeDhall (tmpDir "shared-rec" "recipe.dhall") + createDirectoryIfMissing True (tmpDir "shared-bp1") + writeMinimalBlueprintDhall (tmpDir "shared-bp1" "blueprint.dhall") + createDirectoryIfMissing True (tmpDir "shared-bp2") + writeMinimalBlueprintDhall (tmpDir "shared-bp2" "blueprint.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "duped") Nothing "shared-mod" Nothing []], + recipes = [RegistryEntry (ModuleName "other") Nothing "shared-rec" Nothing []], + blueprints = + [ RegistryEntry (ModuleName "duped") Nothing "shared-bp1" Nothing [], + RegistryEntry (ModuleName "other") Nothing "shared-bp2" Nothing [] + ], + prompts = [] + } + errs <- validateRegistry tmpDir reg + any ("appears as both a module and a blueprint" `isInfixOf`) (map show errs) + `shouldBe` True + any ("appears as both a recipe and a blueprint" `isInfixOf`) (map show errs) + `shouldBe` True + + it "detects a three-way name collision (module, recipe, and blueprint)" $ do + withSystemTempDirectory "seihou-collision-three" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "trip-m") + writeMinimalModuleDhall (tmpDir "trip-m" "module.dhall") + createDirectoryIfMissing True (tmpDir "trip-r") + writeMinimalRecipeDhall (tmpDir "trip-r" "recipe.dhall") + createDirectoryIfMissing True (tmpDir "trip-b") + writeMinimalBlueprintDhall (tmpDir "trip-b" "blueprint.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "tripled") Nothing "trip-m" Nothing []], + recipes = [RegistryEntry (ModuleName "tripled") Nothing "trip-r" Nothing []], + blueprints = [RegistryEntry (ModuleName "tripled") Nothing "trip-b" Nothing []], + prompts = [] + } + errs <- validateRegistry tmpDir reg + let messages = map show errs + any ("appears as both a module and a recipe" `isInfixOf`) messages `shouldBe` True + any ("appears as both a module and a blueprint" `isInfixOf`) messages `shouldBe` True + any ("appears as both a recipe and a blueprint" `isInfixOf`) messages `shouldBe` True + + it "computeRegistrySync classifies blueprint entries with diffKind = BlueprintEntry" $ do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = + [ RegistryEntry (ModuleName "bp-stale") (Just "0.1.0") "blueprints/bp-stale" Nothing [] + ], + prompts = [] + } + lookups = [(BlueprintEntry, ModuleName "bp-stale", Just "0.2.0")] + SyncReport diffs updated = computeRegistrySync reg lookups + kinds = [diff_ | SyncDiff {diffKind = diff_} <- diffs] + statuses = [s | SyncDiff {diffStatus = s} <- diffs] + kinds `shouldBe` [BlueprintEntry] + statuses `shouldBe` [SyncStale "0.2.0"] + let updatedVersion = case updated.blueprints of + (RegistryEntry _ v _ _ _ : _) -> v + _ -> Nothing + updatedVersion `shouldBe` Just ("0.2.0" :: Text) + + it "validateRegistryFull populates reportBlueprintCount" $ do + withSystemTempDirectory "seihou-validate-bp-count" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "bp-a") + writeMinimalBlueprintDhall (tmpDir "bp-a" "blueprint.dhall") + createDirectoryIfMissing True (tmpDir "bp-b") + writeMinimalBlueprintDhall (tmpDir "bp-b" "blueprint.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = + [ RegistryEntry (ModuleName "bp-a") (Just "1.0.0") "bp-a" Nothing [], + RegistryEntry (ModuleName "bp-b") (Just "1.0.0") "bp-b" Nothing [] + ], + prompts = [] + } + lookups = + [ (BlueprintEntry, ModuleName "bp-a", Just "1.0.0"), + (BlueprintEntry, ModuleName "bp-b", Just "1.0.0") + ] + report <- validateRegistryFull tmpDir reg lookups + report.reportBlueprintCount `shouldBe` 2 + report.reportIssues `shouldBe` [] + + describe "prompts in registries" $ do + it "rejects an invalid prompt name" $ do + withSystemTempDirectory "seihou-validate-prompt" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "Bad_Prompt") + writeMinimalPromptDhall (tmpDir "Bad_Prompt" "prompt.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [], + prompts = [RegistryEntry (ModuleName "Bad_Prompt") Nothing "Bad_Prompt" Nothing []] + } + errs <- validateRegistry tmpDir reg + any ("prompt name must match" `isInfixOf`) (map show errs) `shouldBe` True + + it "reports a missing prompt.dhall at the entry path" $ do + withSystemTempDirectory "seihou-validate-prompt-missing" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [], + prompts = [RegistryEntry (ModuleName "ghost") Nothing "ghost" Nothing []] + } + errs <- validateRegistry tmpDir reg + any ("missing prompt.dhall" `isInfixOf`) (map show errs) `shouldBe` True + + it "rejects an unsafe prompt path with .." $ do + withSystemTempDirectory "seihou-validate-prompt-path" $ \tmpDir -> do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [], + prompts = [RegistryEntry (ModuleName "escape") Nothing "../escape" Nothing []] + } + errs <- validateRegistry tmpDir reg + any ("prompt path must not contain" `isInfixOf`) (map show errs) `shouldBe` True + + it "detects cross-kind name collisions involving prompts" $ do + withSystemTempDirectory "seihou-collision-prompt" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "shared-mod") + writeMinimalModuleDhall (tmpDir "shared-mod" "module.dhall") + createDirectoryIfMissing True (tmpDir "shared-rec") + writeMinimalRecipeDhall (tmpDir "shared-rec" "recipe.dhall") + createDirectoryIfMissing True (tmpDir "shared-bp") + writeMinimalBlueprintDhall (tmpDir "shared-bp" "blueprint.dhall") + createDirectoryIfMissing True (tmpDir "shared-prompt1") + writeMinimalPromptDhall (tmpDir "shared-prompt1" "prompt.dhall") + createDirectoryIfMissing True (tmpDir "shared-prompt2") + writeMinimalPromptDhall (tmpDir "shared-prompt2" "prompt.dhall") + createDirectoryIfMissing True (tmpDir "shared-prompt3") + writeMinimalPromptDhall (tmpDir "shared-prompt3" "prompt.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [RegistryEntry (ModuleName "as-module") Nothing "shared-mod" Nothing []], + recipes = [RegistryEntry (ModuleName "as-recipe") Nothing "shared-rec" Nothing []], + blueprints = [RegistryEntry (ModuleName "as-blueprint") Nothing "shared-bp" Nothing []], + prompts = + [ RegistryEntry (ModuleName "as-module") Nothing "shared-prompt1" Nothing [], + RegistryEntry (ModuleName "as-recipe") Nothing "shared-prompt2" Nothing [], + RegistryEntry (ModuleName "as-blueprint") Nothing "shared-prompt3" Nothing [] + ] + } + errs <- validateRegistry tmpDir reg + let messages = map show errs + any ("appears as both a module and a prompt" `isInfixOf`) messages `shouldBe` True + any ("appears as both a recipe and a prompt" `isInfixOf`) messages `shouldBe` True + any ("appears as both a blueprint and a prompt" `isInfixOf`) messages `shouldBe` True + + it "computeRegistrySync classifies prompt entries with diffKind = PromptEntry" $ do + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [], + prompts = + [ RegistryEntry (ModuleName "prompt-stale") (Just "0.1.0") "prompts/prompt-stale" Nothing [] + ] + } + lookups = [(PromptEntry, ModuleName "prompt-stale", Just "0.2.0")] + SyncReport diffs updated = computeRegistrySync reg lookups + kinds = [diff_ | SyncDiff {diffKind = diff_} <- diffs] + statuses = [s | SyncDiff {diffStatus = s} <- diffs] + kinds `shouldBe` [PromptEntry] + statuses `shouldBe` [SyncStale "0.2.0"] + let updatedVersion = case updated.prompts of + (RegistryEntry _ v _ _ _ : _) -> v + _ -> Nothing + updatedVersion `shouldBe` Just ("0.2.0" :: Text) + + it "validateRegistryFull populates reportPromptCount" $ do + withSystemTempDirectory "seihou-validate-prompt-count" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "prompt-a") + writeMinimalPromptDhall (tmpDir "prompt-a" "prompt.dhall") + createDirectoryIfMissing True (tmpDir "prompt-b") + writeMinimalPromptDhall (tmpDir "prompt-b" "prompt.dhall") + let reg = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = [], + recipes = [], + blueprints = [], + prompts = + [ RegistryEntry (ModuleName "prompt-a") (Just "1.0.0") "prompt-a" Nothing [], + RegistryEntry (ModuleName "prompt-b") (Just "1.0.0") "prompt-b" Nothing [] + ] + } + lookups = + [ (PromptEntry, ModuleName "prompt-a", Just "1.0.0"), + (PromptEntry, ModuleName "prompt-b", Just "1.0.0") + ] + report <- validateRegistryFull tmpDir reg lookups + report.reportPromptCount `shouldBe` 2 + report.reportIssues `shouldBe` [] + + describe "discoverRepoContents and blueprints" $ do + it "returns SingleBlueprint when only blueprint.dhall is present" $ do + withSystemTempDirectory "seihou-discover-bp" $ \tmpDir -> do + writeMinimalBlueprintDhall (tmpDir "blueprint.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleBlueprint p -> p `shouldBe` tmpDir + other -> expectationFailure ("Expected SingleBlueprint, got: " <> show other) + + it "prefers SingleModule over SingleBlueprint when both are present" $ do + withSystemTempDirectory "seihou-discover-bp-mod" $ \tmpDir -> do + writeMinimalModuleDhall (tmpDir "module.dhall") + writeMinimalBlueprintDhall (tmpDir "blueprint.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleModule _ -> pure () + other -> expectationFailure ("Expected SingleModule (module beats blueprint), got: " <> show other) + + it "prefers SingleRecipe over SingleBlueprint when both are present" $ do + withSystemTempDirectory "seihou-discover-bp-rec" $ \tmpDir -> do + writeMinimalRecipeDhall (tmpDir "recipe.dhall") + writeMinimalBlueprintDhall (tmpDir "blueprint.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleRecipe _ -> pure () + other -> expectationFailure ("Expected SingleRecipe (recipe beats blueprint), got: " <> show other) + + it "prefers MultiModule over SingleBlueprint when both registry and blueprint exist" $ do + withSystemTempDirectory "seihou-discover-reg-bp" $ \tmpDir -> do + writeRegistryFile tmpDir + writeMinimalBlueprintDhall (tmpDir "blueprint.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + MultiModule _ -> pure () + other -> expectationFailure ("Expected MultiModule (registry beats blueprint), got: " <> show other) + + describe "discoverRepoContents and prompts" $ do + it "returns SinglePrompt when only prompt.dhall is present" $ do + withSystemTempDirectory "seihou-discover-prompt" $ \tmpDir -> do + writeMinimalPromptDhall (tmpDir "prompt.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SinglePrompt p -> p `shouldBe` tmpDir + other -> expectationFailure ("Expected SinglePrompt, got: " <> show other) + + it "prefers SingleModule over SinglePrompt when both are present" $ do + withSystemTempDirectory "seihou-discover-prompt-mod" $ \tmpDir -> do + writeMinimalModuleDhall (tmpDir "module.dhall") + writeMinimalPromptDhall (tmpDir "prompt.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleModule _ -> pure () + other -> expectationFailure ("Expected SingleModule (module beats prompt), got: " <> show other) + + it "prefers SingleRecipe over SinglePrompt when both are present" $ do + withSystemTempDirectory "seihou-discover-prompt-rec" $ \tmpDir -> do + writeMinimalRecipeDhall (tmpDir "recipe.dhall") + writeMinimalPromptDhall (tmpDir "prompt.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleRecipe _ -> pure () + other -> expectationFailure ("Expected SingleRecipe (recipe beats prompt), got: " <> show other) + + it "prefers SingleBlueprint over SinglePrompt when both are present" $ do + withSystemTempDirectory "seihou-discover-prompt-bp" $ \tmpDir -> do + writeMinimalBlueprintDhall (tmpDir "blueprint.dhall") + writeMinimalPromptDhall (tmpDir "prompt.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + SingleBlueprint _ -> pure () + other -> expectationFailure ("Expected SingleBlueprint (blueprint beats prompt), got: " <> show other) + + it "prefers MultiModule over SinglePrompt when both registry and prompt exist" $ do + withSystemTempDirectory "seihou-discover-reg-prompt" $ \tmpDir -> do + writeRegistryFile tmpDir + writeMinimalPromptDhall (tmpDir "prompt.dhall") + result <- discoverRepoContents evalRegistryFromFile tmpDir + case result of + MultiModule _ -> pure () + other -> expectationFailure ("Expected MultiModule (registry beats prompt), got: " <> show other) + +-- Helper: write a minimal valid seihou-registry.dhall +writeRegistryFile :: FilePath -> IO () +writeRegistryFile dir = do + let dhall = + "{ repoName = \"Test Registry\"\n\ + \, repoDescription = Some \"A test registry\"\n\ + \, modules =\n\ + \ [ { name = \"mod-a\"\n\ + \ , version = None Text\n\ + \ , path = \"mod-a\"\n\ + \ , description = Some \"Module A\"\n\ + \ , tags = [ \"test\" ]\n\ + \ }\n\ + \ ]\n\ + \}" + writeFile (dir "seihou-registry.dhall") dhall + +-- Helper: write a minimal valid module.dhall +writeMinimalModuleDhall :: FilePath -> IO () +writeMinimalModuleDhall path = do + let dhall = + "{ name = \"minimal\"\n\ + \, version = None Text\n\ + \, description = None Text\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, exports = [] : List { var : Text, alias : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }\n\ + \, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }\n\ + \, dependencies = [] : List Text\n\ + \, removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }\n\ + \}" + writeFile path dhall + +-- Helper: write a minimal valid recipe.dhall +writeMinimalRecipeDhall :: FilePath -> IO () +writeMinimalRecipeDhall path = do + let dhall = + "{ name = \"minimal\"\n\ + \, version = None Text\n\ + \, description = None Text\n\ + \, modules = [] : List Text\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \}" + writeFile path dhall + +-- Helper: write a minimal valid blueprint.dhall +writeMinimalBlueprintDhall :: FilePath -> IO () +writeMinimalBlueprintDhall path = do + let dhall = + "{ name = \"minimal-bp\"\n\ + \, version = Some \"0.1.0\"\n\ + \, description = None Text\n\ + \, prompt = \"hello\"\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }\n\ + \, files = [] : List { src : Text, description : Optional Text }\n\ + \, allowedTools = None (List Text)\n\ + \, tags = [] : List Text\n\ + \}" + writeFile path dhall + +-- Helper: write a minimal valid prompt.dhall +writeMinimalPromptDhall :: FilePath -> IO () +writeMinimalPromptDhall path = do + let dhall = + "{ name = \"minimal-prompt\"\n\ + \, version = Some \"0.1.0\"\n\ + \, description = None Text\n\ + \, prompt = \"hello\"\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, commandVars = [] : List { name : Text, run : Text, workDir : Optional Text, when : Optional Text, trim : Bool, maxBytes : Optional Natural }\n\ + \, files = [] : List { src : Text, description : Optional Text }\n\ + \, allowedTools = None (List Text)\n\ + \, tags = [] : List Text\n\ + \, launch = None { provider : Optional Text, mode : Optional Text, model : Optional Text }\n\ + \}" + writeFile path dhall diff --git a/test/Seihou/Core/RegistrySyncSpec.hs b/test/Seihou/Core/RegistrySyncSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/RegistrySyncSpec.hs @@ -0,0 +1,166 @@ +module Seihou.Core.RegistrySyncSpec (tests) where + +import Data.Maybe (isJust, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Seihou.Core.Registry + ( EntryKind (..), + Registry (..), + RegistryEntry (..), + SyncDiff (..), + SyncReport (..), + SyncStatus (..), + computeRegistrySync, + formatDriftWarning, + ) +import Seihou.Core.Types (ModuleName (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.RegistrySync" spec + +spec :: Spec +spec = describe "computeRegistrySync" $ do + it "classifies SyncMissing when registry version is Nothing and disk has a version" $ do + let entry = mkEntry "alpha" Nothing + reg = mkReg [entry] [] + report = computeRegistrySync reg [(ModuleEntry, ModuleName "alpha", Just "1.0.0")] + map (.diffStatus) report.syncDiffs `shouldBe` [SyncMissing] + map (.diffNew) report.syncDiffs `shouldBe` [Just "1.0.0"] + (head report.syncUpdated.modules).version `shouldBe` Just "1.0.0" + + it "classifies SyncStale when registry and disk versions differ" $ do + let entry = mkEntry "alpha" (Just "0.1.0") + reg = mkReg [entry] [] + report = computeRegistrySync reg [(ModuleEntry, ModuleName "alpha", Just "1.0.0")] + map (.diffStatus) report.syncDiffs `shouldBe` [SyncStale "1.0.0"] + map (.diffOld) report.syncDiffs `shouldBe` [Just "0.1.0"] + map (.diffNew) report.syncDiffs `shouldBe` [Just "1.0.0"] + (head report.syncUpdated.modules).version `shouldBe` Just "1.0.0" + + it "classifies SyncInSync when registry and disk versions match" $ do + let entry = mkEntry "alpha" (Just "1.0.0") + reg = mkReg [entry] [] + report = computeRegistrySync reg [(ModuleEntry, ModuleName "alpha", Just "1.0.0")] + map (.diffStatus) report.syncDiffs `shouldBe` [SyncInSync] + (head report.syncUpdated.modules).version `shouldBe` Just "1.0.0" + + it "classifies SyncInSync when registry and disk are both Nothing" $ do + let entry = mkEntry "alpha" Nothing + reg = mkReg [entry] [] + report = computeRegistrySync reg [(ModuleEntry, ModuleName "alpha", Nothing)] + map (.diffStatus) report.syncDiffs `shouldBe` [SyncInSync] + (head report.syncUpdated.modules).version `shouldBe` Nothing + + it "classifies SyncOrphan when the entry has no lookup (module.dhall absent/unreadable)" $ do + let entry = mkEntry "alpha" (Just "1.0.0") + reg = mkReg [entry] [] + report = computeRegistrySync reg [] + map (.diffStatus) report.syncDiffs `shouldBe` [SyncOrphan] + -- Orphan: version left as-is + (head report.syncUpdated.modules).version `shouldBe` Just "1.0.0" + + it "preserves registry order in the diff output" $ do + let reg = + ( mkReg + [ mkEntry "alpha" Nothing, + mkEntry "beta" (Just "0.1.0"), + mkEntry "gamma" (Just "2.0.0") + ] + [mkEntry "lib-one" Nothing] + ) + { prompts = [mkEntry "review" Nothing] + } + lookups = + [ (ModuleEntry, ModuleName "alpha", Just "1.0.0"), + (ModuleEntry, ModuleName "beta", Just "0.2.0"), + (ModuleEntry, ModuleName "gamma", Just "2.0.0"), + (RecipeEntry, ModuleName "lib-one", Just "0.3.0"), + (PromptEntry, ModuleName "review", Just "0.4.0") + ] + report = computeRegistrySync reg lookups + map (.diffName) report.syncDiffs + `shouldBe` [ ModuleName "alpha", + ModuleName "beta", + ModuleName "gamma", + ModuleName "lib-one", + ModuleName "review" + ] + map (.diffKind) report.syncDiffs + `shouldBe` [ModuleEntry, ModuleEntry, ModuleEntry, RecipeEntry, PromptEntry] + map (.diffStatus) report.syncDiffs + `shouldBe` [SyncMissing, SyncStale "0.2.0", SyncInSync, SyncMissing, SyncMissing] + + it "returns an empty report for an empty registry" $ do + let reg = mkReg [] [] + report = computeRegistrySync reg [] + report.syncDiffs `shouldBe` [] + report.syncUpdated `shouldBe` reg + + it "distinguishes module and recipe entries with the same name in lookups" $ do + -- Module and recipe namespaces share a validation check, + -- but the sync lookup must distinguish them by kind. + let reg = + mkReg + [mkEntry "alpha" Nothing] + [mkEntry "beta" Nothing] + lookups = + [ (ModuleEntry, ModuleName "alpha", Just "1.0.0"), + (RecipeEntry, ModuleName "beta", Just "2.0.0") + ] + report = computeRegistrySync reg lookups + map (.diffNew) report.syncDiffs `shouldBe` [Just "1.0.0", Just "2.0.0"] + + describe "formatDriftWarning" $ do + it "produces a warning for a stale entry" $ do + let reg = mkReg [mkEntry "alpha" (Just "0.1.0")] [] + lookups = [(ModuleEntry, ModuleName "alpha", Just "1.0.0")] + report = computeRegistrySync reg lookups + warnings = mapMaybe formatDriftWarning report.syncDiffs + length warnings `shouldBe` 1 + isJust (formatDriftWarning (head report.syncDiffs)) `shouldBe` True + + it "produces no warnings when all entries are in sync" $ do + let reg = mkReg [mkEntry "alpha" (Just "1.0.0")] [] + lookups = [(ModuleEntry, ModuleName "alpha", Just "1.0.0")] + report = computeRegistrySync reg lookups + warnings = mapMaybe formatDriftWarning report.syncDiffs + warnings `shouldBe` [] + + it "produces no warnings for orphan entries (handled by validateRegistry)" $ do + let reg = mkReg [mkEntry "alpha" (Just "1.0.0")] [] + report = computeRegistrySync reg [] + warnings = mapMaybe formatDriftWarning report.syncDiffs + warnings `shouldBe` [] + + it "mentions prompt.dhall in stale prompt warnings" $ do + let reg = (mkReg [] []) {prompts = [mkEntry "review" (Just "0.1.0")]} + lookups = [(PromptEntry, ModuleName "review", Just "0.2.0")] + report = computeRegistrySync reg lookups + warnings = mapMaybe formatDriftWarning report.syncDiffs + warnings + `shouldBe` [ "prompt 'review' registry version 0.1.0 differs from prompt.dhall version 0.2.0 — run `seihou registry sync-versions`" + ] + +mkEntry :: Text -> Maybe Text -> RegistryEntry +mkEntry n v = + RegistryEntry + { name = ModuleName n, + version = v, + path = "modules/" <> T.unpack n, + description = Nothing, + tags = [] + } + +mkReg :: [RegistryEntry] -> [RegistryEntry] -> Registry +mkReg mods recs = + Registry + { repoName = "Test", + repoDescription = Nothing, + modules = mods, + recipes = recs, + blueprints = [], + prompts = [] + } diff --git a/test/Seihou/Core/ScaffoldSpec.hs b/test/Seihou/Core/ScaffoldSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/ScaffoldSpec.hs @@ -0,0 +1,240 @@ +module Seihou.Core.ScaffoldSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.AgentPrompt (validateAgentPrompt) +import Seihou.Core.Blueprint (validateBlueprint) +import Seihou.Core.Module (validateModule) +import Seihou.Core.Scaffold (blueprintDhall, exampleAgentPromptMarkdown, examplePromptMarkdown, moduleDhall, promptDhall, readmeTemplate) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, makeAbsolute) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Scaffold" spec + +-- | Resolve the local schema path for tests, trying both package-relative and +-- project root-relative locations (like mori's fixturePath pattern). +-- Uses an absolute path since generated Dhall is written to a temp directory. +resolveSchemaPath :: IO T.Text +resolveSchemaPath = do + let pkgRelative = "../schema/package.dhall" + rootRelative = "schema/package.dhall" + pkgExists <- doesDirectoryExist "../schema" + path <- + if pkgExists + then makeAbsolute pkgRelative + else makeAbsolute rootRelative + pure (T.pack path) + +spec :: Spec +spec = do + describe "moduleDhall" $ do + it "generates Dhall that includes schema import" $ do + schemaPath <- resolveSchemaPath + let content = moduleDhall "test-mod" schemaPath "" + T.isInfixOf "let S =" content `shouldBe` True + T.isInfixOf "S.Module::" content `shouldBe` True + + it "generates Dhall that loads via evalModuleFromFile" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-scaffold-test" $ \tmpDir -> do + let modDir = tmpDir "test-mod" + dhallFile = modDir "module.dhall" + filesDir = modDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (moduleDhall "test-mod" schemaPath "")) + writeFile (filesDir "README.md.tpl") (T.unpack readmeTemplate) + result <- evalModuleFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load generated module: " ++ show err + Right m -> m.name `shouldBe` "test-mod" + + it "generates a module that passes validateModule" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-scaffold-test" $ \tmpDir -> do + let modDir = tmpDir "test-mod" + dhallFile = modDir "module.dhall" + filesDir = modDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (moduleDhall "test-mod" schemaPath "")) + writeFile (filesDir "README.md.tpl") (T.unpack readmeTemplate) + result <- evalModuleFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load: " ++ show err + Right m -> do + validated <- validateModule modDir m + case validated of + Left err -> expectationFailure $ "Validation failed: " ++ show err + Right _ -> pure () + + it "generates expected module structure" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-scaffold-test" $ \tmpDir -> do + let modDir = tmpDir "test-mod" + dhallFile = modDir "module.dhall" + filesDir = modDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (moduleDhall "test-mod" schemaPath "")) + writeFile (filesDir "README.md.tpl") (T.unpack readmeTemplate) + result <- evalModuleFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load: " ++ show err + Right m -> do + length (m.vars) `shouldBe` 1 + map (.name) m.vars `shouldBe` ["project.name"] + length (m.steps) `shouldBe` 1 + length (m.prompts) `shouldBe` 1 + length (m.commands) `shouldBe` 0 + length (m.exports) `shouldBe` 0 + length (m.dependencies) `shouldBe` 0 + + describe "readmeTemplate" $ do + it "contains the project.name placeholder" $ do + T.isInfixOf "{{project.name}}" readmeTemplate `shouldBe` True + + describe "blueprintDhall" $ do + it "generates Dhall that imports the schema and uses Blueprint::" $ do + schemaPath <- resolveSchemaPath + let content = blueprintDhall "test-bp" schemaPath "" + T.isInfixOf "let S =" content `shouldBe` True + T.isInfixOf "S.Blueprint::" content `shouldBe` True + + it "imports prompt.md as Text rather than inlining the body" $ do + schemaPath <- resolveSchemaPath + let content = blueprintDhall "test-bp" schemaPath "" + T.isInfixOf "./prompt.md as Text" content `shouldBe` True + + it "decodes via evalBlueprintFromFile when prompt.md is present" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-blueprint-scaffold-test" $ \tmpDir -> do + let bpDir = tmpDir "test-bp" + dhallFile = bpDir "blueprint.dhall" + filesDir = bpDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (blueprintDhall "test-bp" schemaPath "")) + writeFile (bpDir "prompt.md") (T.unpack examplePromptMarkdown) + result <- evalBlueprintFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load generated blueprint: " ++ show err + Right b -> b.name `shouldBe` "test-bp" + + it "produces a blueprint that passes validateBlueprint" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-blueprint-scaffold-test" $ \tmpDir -> do + let bpDir = tmpDir "test-bp" + dhallFile = bpDir "blueprint.dhall" + filesDir = bpDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (blueprintDhall "test-bp" schemaPath "")) + writeFile (bpDir "prompt.md") (T.unpack examplePromptMarkdown) + result <- evalBlueprintFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load: " ++ show err + Right b -> do + validated <- validateBlueprint bpDir b + case validated of + Left err -> expectationFailure $ "Validation failed: " ++ show err + Right _ -> pure () + + it "produces the expected blueprint structure (1 var, 1 prompt, 0 base modules, 0 files)" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-blueprint-scaffold-test" $ \tmpDir -> do + let bpDir = tmpDir "test-bp" + dhallFile = bpDir "blueprint.dhall" + filesDir = bpDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (blueprintDhall "test-bp" schemaPath "")) + writeFile (bpDir "prompt.md") (T.unpack examplePromptMarkdown) + result <- evalBlueprintFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load: " ++ show err + Right b -> do + length (b.vars) `shouldBe` 1 + map (.name) b.vars `shouldBe` ["project.name"] + length (b.prompts) `shouldBe` 1 + length (b.baseModules) `shouldBe` 0 + length (b.files) `shouldBe` 0 + length (b.tags) `shouldBe` 0 + + describe "examplePromptMarkdown" $ do + it "contains the {{project.name}} placeholder so authors see substitution" $ do + T.isInfixOf "{{project.name}}" examplePromptMarkdown `shouldBe` True + + it "is non-empty after trimming (would otherwise fail prompt-non-empty validation)" $ do + T.null (T.strip examplePromptMarkdown) `shouldBe` False + + describe "promptDhall" $ do + it "generates self-contained Dhall with prompt-specific type aliases" $ do + schemaPath <- resolveSchemaPath + let content = promptDhall "review-changes" schemaPath "" + T.isInfixOf "let Prompt =" content `shouldBe` True + T.isInfixOf "let CommandVar =" content `shouldBe` True + + it "imports prompt.md as Text rather than inlining the body" $ do + schemaPath <- resolveSchemaPath + let content = promptDhall "review-changes" schemaPath "" + T.isInfixOf "./prompt.md as Text" content `shouldBe` True + + it "decodes via evalAgentPromptFromFile when prompt.md is present" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-prompt-scaffold-test" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + dhallFile = promptDir "prompt.dhall" + filesDir = promptDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (promptDhall "review-changes" schemaPath "")) + writeFile (promptDir "prompt.md") (T.unpack exampleAgentPromptMarkdown) + result <- evalAgentPromptFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load generated prompt: " ++ show err + Right p -> p.name `shouldBe` "review-changes" + + it "produces a prompt that passes validateAgentPrompt" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-prompt-scaffold-test" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + dhallFile = promptDir "prompt.dhall" + filesDir = promptDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (promptDhall "review-changes" schemaPath "")) + writeFile (promptDir "prompt.md") (T.unpack exampleAgentPromptMarkdown) + result <- evalAgentPromptFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load: " ++ show err + Right p -> do + validated <- validateAgentPrompt promptDir p + case validated of + Left err -> expectationFailure $ "Validation failed: " ++ show err + Right _ -> pure () + + it "produces the expected prompt structure" $ do + schemaPath <- resolveSchemaPath + withSystemTempDirectory "seihou-prompt-scaffold-test" $ \tmpDir -> do + let promptDir = tmpDir "review-changes" + dhallFile = promptDir "prompt.dhall" + filesDir = promptDir "files" + createDirectoryIfMissing True filesDir + writeFile dhallFile (T.unpack (promptDhall "review-changes" schemaPath "")) + writeFile (promptDir "prompt.md") (T.unpack exampleAgentPromptMarkdown) + result <- evalAgentPromptFromFile dhallFile + case result of + Left err -> expectationFailure $ "Failed to load: " ++ show err + Right p -> do + length (p.vars) `shouldBe` 1 + map (.name) p.vars `shouldBe` ["project.name"] + length (p.prompts) `shouldBe` 0 + length (p.commandVars) `shouldBe` 0 + length (p.files) `shouldBe` 0 + length (p.tags) `shouldBe` 0 + + describe "exampleAgentPromptMarkdown" $ do + it "contains the {{project.name}} placeholder so debug rendering shows substitution" $ do + T.isInfixOf "{{project.name}}" exampleAgentPromptMarkdown `shouldBe` True + + it "is non-empty after trimming" $ do + T.null (T.strip exampleAgentPromptMarkdown) `shouldBe` False diff --git a/test/Seihou/Core/SchemaUpgradeSpec.hs b/test/Seihou/Core/SchemaUpgradeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/SchemaUpgradeSpec.hs @@ -0,0 +1,247 @@ +module Seihou.Core.SchemaUpgradeSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.SchemaUpgrade +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +-- Test schema URL and hash for upgrade tests +testUrl :: T.Text +testUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/abc123/package.dhall" + +testHash :: T.Text +testHash = "sha256:0000000000000000000000000000000000000000000000000000000000000000" + +tests :: IO TestTree +tests = testSpec "Seihou.Core.SchemaUpgrade" spec + +-- | A module.dhall missing version, patch, and commands (pre-schema-evolution). +oldModuleText :: T.Text +oldModuleText = + T.unlines + [ "{ name = \"old-module\"", + ", description = Some \"Pre-commands era module\"", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps =", + " [ { strategy = \"copy\"", + " , src = \"foo\"", + " , dest = \"foo\"", + " , when = None Text", + " }", + " ]", + ", dependencies = [] : List Text", + "}" + ] + +-- | A module with bare string dependencies. +bareStringDepsText :: T.Text +bareStringDepsText = + T.unlines + [ "{ name = \"with-deps\"", + ", version = None Text", + ", description = Some \"Has bare string deps\"", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [ \"haskell-base\", \"nix-flake\" ]", + "}" + ] + +-- | A fully current module (with schema import). +currentModuleText :: T.Text +currentModuleText = + T.unlines + [ "let S =", + " https://raw.githubusercontent.com/shinzui/seihou-schema/abc123/package.dhall", + " sha256:0000000000000000000000000000000000000000000000000000000000000000", + "", + "in S.Module::{", + " , name = \"current-module\"", + " , version = None Text", + " , description = Some \"Fully current module\"", + " , vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + " , exports = [] : List { var : Text, alias : Optional Text }", + " , prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + " , steps =", + " [ { strategy = \"template\"", + " , src = \"foo.tpl\"", + " , dest = \"foo\"", + " , when = None Text", + " , patch = None Text", + " }", + " ]", + " , commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + " , dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } }", + " , migrations = [] : List S.Migration.Type", + " }" + ] + +-- | A module missing only version (has patch and commands). +missingVersionOnlyText :: T.Text +missingVersionOnlyText = + T.unlines + [ "{ name = \"no-version\"", + ", description = Some \"Missing version only\"", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } }", + "}" + ] + +-- | A module with multiple steps, some missing patch. +multiStepText :: T.Text +multiStepText = + T.unlines + [ "{ name = \"multi-step\"", + ", version = None Text", + ", description = None Text", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps =", + " [ { strategy = \"copy\"", + " , src = \"a\"", + " , dest = \"a\"", + " , when = None Text", + " }", + " , { strategy = \"template\"", + " , src = \"b.tpl\"", + " , dest = \"b\"", + " , when = None Text", + " , patch = None Text", + " }", + " , { strategy = \"copy\"", + " , src = \"c\"", + " , dest = \"c\"", + " , when = None Text", + " }", + " ]", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } }", + "}" + ] + +spec :: Spec +spec = do + describe "detectIssues" $ do + it "detects all issues in an old module" $ do + let issues = detectIssues testUrl oldModuleText + issues `shouldContain` [MissingVersion] + issues `shouldContain` [MissingCommands] + issues `shouldContain` [MissingStepPatch 0] + issues `shouldContain` [BareStringDepTypeAnnotation] + issues `shouldContain` [MissingSchemaImport] + issues `shouldContain` [MissingMigrations] + + it "returns empty list for a current module" $ do + detectIssues testUrl currentModuleText `shouldBe` [] + + it "detects missing version, schema import, and migrations when other fields present" $ do + detectIssues testUrl missingVersionOnlyText + `shouldBe` [MissingVersion, MissingSchemaImport, MissingMigrations] + + it "detects bare string dependencies" $ do + let issues = detectIssues testUrl bareStringDepsText + issues `shouldContain` [BareStringDep "haskell-base"] + issues `shouldContain` [BareStringDep "nix-flake"] + + it "detects missing patch only on steps that lack it" $ do + let issues = detectIssues testUrl multiStepText + issues `shouldContain` [MissingStepPatch 0] + issues `shouldContain` [MissingStepPatch 2] + issues `shouldNotContain` [MissingStepPatch 1] + + describe "upgradeModuleText" $ do + it "returns AlreadyCurrent for a current module" $ do + upgradeModuleText testUrl testHash currentModuleText `shouldBe` AlreadyCurrent + + it "inserts version field after name" $ do + case upgradeModuleText testUrl testHash missingVersionOnlyText of + Upgraded text _ -> do + T.isInfixOf ", version = None Text" text `shouldBe` True + -- version should appear after name and before description + let ls = T.lines text + nameIdx = findIndex (T.isInfixOf "{ name =") ls + versionIdx = findIndex (T.isInfixOf ", version =") ls + descIdx = findIndex (T.isInfixOf ", description =") ls + case (nameIdx, versionIdx, descIdx) of + (Just n, Just v, Just d) -> do + v `shouldBe` n + 1 + d `shouldSatisfy` (> v) + _ -> expectationFailure "could not find expected fields" + AlreadyCurrent -> expectationFailure "expected Upgraded" + + it "inserts commands field" $ do + case upgradeModuleText testUrl testHash oldModuleText of + Upgraded text _ -> + T.isInfixOf ", commands =" text `shouldBe` True + AlreadyCurrent -> expectationFailure "expected Upgraded" + + it "inserts patch in steps that lack it" $ do + case upgradeModuleText testUrl testHash multiStepText of + Upgraded text _ -> do + -- Should have 3 occurrences of patch now (step 1 already had it) + let patchCount = length (filter (T.isInfixOf ", patch =") (T.lines text)) + patchCount `shouldBe` 3 + AlreadyCurrent -> expectationFailure "expected Upgraded" + + it "converts bare string deps to record form" $ do + case upgradeModuleText testUrl testHash bareStringDepsText of + Upgraded text _ -> do + T.isInfixOf "{ module = \"haskell-base\"" text `shouldBe` True + T.isInfixOf "{ module = \"nix-flake\"" text `shouldBe` True + -- The old bare format "haskell-base", "nix-flake" should be gone + T.isInfixOf "\"haskell-base\", \"nix-flake\"" text `shouldBe` False + AlreadyCurrent -> expectationFailure "expected Upgraded" + + it "converts List Text annotation to record type" $ do + case upgradeModuleText testUrl testHash oldModuleText of + Upgraded text _ -> do + -- The dependencies line should no longer use "[] : List Text" + T.isInfixOf "[] : List Text" text `shouldBe` False + -- It should use the record type annotation instead + T.isInfixOf "List { module : Text" text `shouldBe` True + AlreadyCurrent -> expectationFailure "expected Upgraded" + + it "is idempotent" $ do + case upgradeModuleText testUrl testHash oldModuleText of + Upgraded text _ -> + upgradeModuleText testUrl testHash text `shouldBe` AlreadyCurrent + AlreadyCurrent -> expectationFailure "expected first upgrade to produce changes" + + it "injects schema import into legacy module" $ do + case upgradeModuleText testUrl testHash oldModuleText of + Upgraded text _ -> do + T.isInfixOf "let S =" text `shouldBe` True + T.isInfixOf "seihou-schema" text `shouldBe` True + T.isInfixOf "S.Module::" text `shouldBe` True + AlreadyCurrent -> expectationFailure "expected Upgraded" + + it "inserts migrations field" $ do + case upgradeModuleText testUrl testHash missingVersionOnlyText of + Upgraded text _ -> + T.isInfixOf ", migrations =" text `shouldBe` True + AlreadyCurrent -> expectationFailure "expected Upgraded" + + describe "issueMessage" $ do + it "produces human-readable messages" $ do + issueMessage MissingVersion `shouldBe` "missing field: version" + issueMessage (MissingStepPatch 0) `shouldBe` "missing field: patch (in step 1)" + issueMessage MissingCommands `shouldBe` "missing field: commands" + issueMessage (BareStringDep "foo") `shouldBe` "bare string dependency: foo" + issueMessage MissingMigrations `shouldBe` "missing field: migrations" + where + findIndex p xs = go 0 xs + where + go _ [] = Nothing + go i (x : rest') + | p x = Just i + | otherwise = go (i + 1) rest' diff --git a/test/Seihou/Core/StatusSpec.hs b/test/Seihou/Core/StatusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/StatusSpec.hs @@ -0,0 +1,111 @@ +module Seihou.Core.StatusSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Status (computeTrackedFileStatuses) +import Seihou.Core.Types +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (emptyManifest) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Status" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +modName :: ModuleName +modName = ModuleName "test-module" + +mkRecord :: Text -> FileRecord +mkRecord content = + FileRecord + { hash = hashContent content, + moduleName = modName, + strategy = Template, + generatedAt = fixedTime + } + +runStatus :: PureFS -> Manifest -> [TrackedFile] +runStatus fs manifest = + fst $ runPureEff $ runFilesystemPure fs $ computeTrackedFileStatuses manifest + +spec :: Spec +spec = do + describe "computeTrackedFileStatuses" $ do + it "classifies a file matching its manifest hash as TfsUnchanged" $ do + let content = "# Hello World" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = Map.singleton "README.md" (mkRecord content) + } + fs = PureFS (Map.singleton "README.md" content) mempty + result = runStatus fs manifest + length result `shouldBe` 1 + (head result).path `shouldBe` "README.md" + (head result).moduleName `shouldBe` modName + (head result).status `shouldBe` TfsUnchanged + + it "classifies a file with different disk content as TfsModified" $ do + let originalContent = "# Hello" + modifiedContent = "# Hello - edited" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = Map.singleton "README.md" (mkRecord originalContent) + } + fs = PureFS (Map.singleton "README.md" modifiedContent) mempty + result = runStatus fs manifest + length result `shouldBe` 1 + (head result).status `shouldBe` TfsModified + + it "classifies a file missing from disk as TfsDeleted" $ do + let content = "# Hello" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = Map.singleton "README.md" (mkRecord content) + } + result = runStatus emptyFS manifest + length result `shouldBe` 1 + (head result).status `shouldBe` TfsDeleted + + it "handles mixed statuses across multiple files" $ do + let unchangedContent = "unchanged" + modifiedOriginal = "original" + modifiedCurrent = "edited" + deletedContent = "deleted" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = + Map.fromList + [ ("a.txt", mkRecord unchangedContent), + ("b.txt", mkRecord modifiedOriginal), + ("c.txt", mkRecord deletedContent) + ] + } + fs = + PureFS + ( Map.fromList + [ ("a.txt", unchangedContent), + ("b.txt", modifiedCurrent) + ] + ) + mempty + result = runStatus fs manifest + length result `shouldBe` 3 + -- Results are sorted by path + (result !! 0).path `shouldBe` "a.txt" + (result !! 0).status `shouldBe` TfsUnchanged + (result !! 1).path `shouldBe` "b.txt" + (result !! 1).status `shouldBe` TfsModified + (result !! 2).path `shouldBe` "c.txt" + (result !! 2).status `shouldBe` TfsDeleted + + it "returns empty list for empty manifest" $ do + let manifest = emptyManifest fixedTime + result = runStatus emptyFS manifest + result `shouldBe` [] diff --git a/test/Seihou/Core/TypesSpec.hs b/test/Seihou/Core/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/TypesSpec.hs @@ -0,0 +1,153 @@ +module Seihou.Core.TypesSpec (tests) where + +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Types" spec + +spec :: Spec +spec = do + describe "ModuleName" $ do + it "supports OverloadedStrings" $ do + let name = "my-module" :: ModuleName + name.unModuleName `shouldBe` "my-module" + + it "supports Eq" $ do + ("a" :: ModuleName) `shouldBe` ("a" :: ModuleName) + ("a" :: ModuleName) `shouldNotBe` ("b" :: ModuleName) + + it "supports Show" $ do + show ("test" :: ModuleName) `shouldNotBe` "" + + describe "VarName" $ do + it "supports OverloadedStrings" $ do + let name = "project.name" :: VarName + name.unVarName `shouldBe` "project.name" + + describe "VarType" $ do + it "has five distinct constructors" $ do + VTText `shouldNotBe` VTBool + VTBool `shouldNotBe` VTInt + VTInt `shouldNotBe` VTList VTText + VTList VTText `shouldNotBe` VTChoice ["a"] + + describe "VarValue" $ do + it "supports Text values" $ do + VText "hello" `shouldBe` VText "hello" + + it "supports Bool values" $ do + VBool True `shouldNotBe` VBool False + + it "supports Int values" $ do + VInt 42 `shouldBe` VInt 42 + + it "supports List values" $ do + VList [VText "a", VText "b"] `shouldBe` VList [VText "a", VText "b"] + + describe "VarDecl" $ do + it "can be constructed with all fields" $ do + let decl = + VarDecl + { name = "project.name", + type_ = VTText, + default_ = Just (VText "my-app"), + description = Just "Name of the project", + required = True, + validation = Just (ValPattern "[a-z][a-z0-9-]*") + } + decl.required `shouldBe` True + + describe "Strategy" $ do + it "has four distinct constructors" $ do + Copy `shouldNotBe` Template + Template `shouldNotBe` DhallText + DhallText `shouldNotBe` Structured + + describe "Module" $ do + it "can be constructed with all fields" $ do + let m = + Module + { name = "haskell-base", + version = Nothing, + description = Just "A Haskell project template", + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + m.name `shouldBe` "haskell-base" + + it "supports Eq for identical values" $ do + let m = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + m `shouldBe` m + + it "supports Show" $ do + let m = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + show m `shouldNotBe` "" + + describe "Operation" $ do + it "supports WriteFileOp" $ do + let op = WriteFileOp {dest = "README.md", content = "# Hello", strategy = Template} + op.dest `shouldBe` "README.md" + + it "supports CreateDirOp" $ do + let op = CreateDirOp {path = "src"} + op.path `shouldBe` "src" + + it "supports CopyFileOp" $ do + let op = CopyFileOp {src = "a.txt", dest = "b.txt"} + op.src `shouldBe` "a.txt" + + it "supports RunCommandOp" $ do + let op = RunCommandOp {command = "git init", workDir = Nothing} + op.command `shouldBe` "git init" + + describe "Expr" $ do + it "supports ExprIsSet" $ do + ExprIsSet "x" `shouldBe` ExprIsSet "x" + + it "supports logical operations" $ do + let expr = ExprAnd (ExprIsSet "a") (ExprNot (ExprLit False)) + expr `shouldBe` expr + + it "supports ExprEq" $ do + ExprEq "x" (VText "hello") `shouldBe` ExprEq "x" (VText "hello") + + describe "Manifest" $ do + it "has a version field" $ do + -- Verify the Manifest type is a record with expected fields + let hash = SHA256 "abc" + hash.unSHA256 `shouldBe` "abc" diff --git a/test/Seihou/Core/VariableSpec.hs b/test/Seihou/Core/VariableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/VariableSpec.hs @@ -0,0 +1,779 @@ +module Seihou.Core.VariableSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Expr (evalExpr, parseExpr) +import Seihou.Core.Types +import Seihou.Core.Variable +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Variable" spec + +-- | Helper to build a simple text var declaration. +textVar :: VarName -> Bool -> Maybe VarValue -> Maybe Validation -> VarDecl +textVar name req def val = + VarDecl + { name = name, + type_ = VTText, + default_ = def, + description = Nothing, + required = req, + validation = val + } + +-- | Helper to build a bool var declaration. +boolVar :: VarName -> Bool -> Maybe VarValue -> VarDecl +boolVar name req def = + VarDecl + { name = name, + type_ = VTBool, + default_ = def, + description = Nothing, + required = req, + validation = Nothing + } + +-- | Helper to build an int var declaration. +intVar :: VarName -> Bool -> Maybe VarValue -> Maybe Validation -> VarDecl +intVar name req def val = + VarDecl + { name = name, + type_ = VTInt, + default_ = def, + description = Nothing, + required = req, + validation = val + } + +-- | Helper to build a choice var declaration. +choiceVar :: VarName -> Bool -> [T.Text] -> Maybe VarValue -> VarDecl +choiceVar name req options def = + VarDecl + { name = name, + type_ = VTChoice options, + default_ = def, + description = Nothing, + required = req, + validation = Nothing + } + +spec :: Spec +spec = do + describe "envVarName" $ do + it "converts project.name to SEIHOU_VAR_PROJECT_NAME" $ do + envVarName "project.name" `shouldBe` "SEIHOU_VAR_PROJECT_NAME" + + it "converts license to SEIHOU_VAR_LICENSE" $ do + envVarName "license" `shouldBe` "SEIHOU_VAR_LICENSE" + + it "converts project.version to SEIHOU_VAR_PROJECT_VERSION" $ do + envVarName "project.version" `shouldBe` "SEIHOU_VAR_PROJECT_VERSION" + + describe "coerceValue" $ do + it "coerces text as-is" $ do + coerceValue "x" VTText "hello" `shouldBe` Right (VText "hello") + + it "coerces true string to VBool True" $ do + coerceValue "x" VTBool "true" `shouldBe` Right (VBool True) + + it "coerces yes string to VBool True" $ do + coerceValue "x" VTBool "yes" `shouldBe` Right (VBool True) + + it "coerces 1 string to VBool True" $ do + coerceValue "x" VTBool "1" `shouldBe` Right (VBool True) + + it "coerces false string to VBool False" $ do + coerceValue "x" VTBool "false" `shouldBe` Right (VBool False) + + it "coerces no string to VBool False" $ do + coerceValue "x" VTBool "no" `shouldBe` Right (VBool False) + + it "rejects invalid bool string" $ do + coerceValue "x" VTBool "maybe" `shouldBe` Left (CoercionFailed "x" VTBool "maybe") + + it "coerces integer string" $ do + coerceValue "x" VTInt "42" `shouldBe` Right (VInt 42) + + it "coerces negative integer" $ do + coerceValue "x" VTInt "-5" `shouldBe` Right (VInt (-5)) + + it "rejects non-integer string" $ do + coerceValue "x" VTInt "abc" `shouldBe` Left (CoercionFailed "x" VTInt "abc") + + it "coerces comma-separated list" $ do + coerceValue "x" (VTList VTText) "a,b,c" + `shouldBe` Right (VList [VText "a", VText "b", VText "c"]) + + it "strips whitespace in list elements" $ do + coerceValue "x" (VTList VTText) "a , b , c" + `shouldBe` Right (VList [VText "a", VText "b", VText "c"]) + + it "coerces valid choice" $ do + coerceValue "x" (VTChoice ["MIT", "BSD3", "Apache"]) "MIT" + `shouldBe` Right (VText "MIT") + + it "rejects invalid choice" $ do + coerceValue "x" (VTChoice ["MIT", "BSD3"]) "GPL" + `shouldBe` Left (CoercionFailed "x" (VTChoice ["MIT", "BSD3"]) "GPL") + + describe "coerceDefault" $ do + it "coerces a raw-text bool default to VBool" $ do + coerceDefault "x" VTBool (VText "true") `shouldBe` Right (VBool True) + + it "coerces a raw-text int default to VInt" $ do + coerceDefault "x" VTInt (VText "42") `shouldBe` Right (VInt 42) + + it "keeps a text default as VText" $ do + coerceDefault "x" VTText (VText "hello") `shouldBe` Right (VText "hello") + + it "validates a constrained choice default" $ do + coerceDefault "x" (VTChoice ["MIT", "BSD3"]) (VText "MIT") + `shouldBe` Right (VText "MIT") + + it "keeps an unconstrained (empty) choice default as VText" $ do + coerceDefault "x" (VTChoice []) (VText "MIT") `shouldBe` Right (VText "MIT") + + it "passes an already-typed default through unchanged" $ do + coerceDefault "x" VTBool (VBool True) `shouldBe` Right (VBool True) + + it "fails on a malformed bool default" $ do + coerceDefault "x" VTBool (VText "treu") + `shouldBe` Left (CoercionFailed "x" VTBool "treu") + + describe "validateVarValue" $ do + it "passes when no validation is set" $ do + let decl = textVar "x" True Nothing Nothing + validateVarValue decl (VText "anything") `shouldBe` Right () + + it "passes pattern validation" $ do + let decl = textVar "x" True Nothing (Just (ValPattern "[a-z][a-z0-9-]*")) + validateVarValue decl (VText "my-app") `shouldBe` Right () + + it "rejects pattern validation" $ do + let decl = textVar "x" True Nothing (Just (ValPattern "[a-z][a-z0-9-]*")) + case validateVarValue decl (VText "MyApp") of + Left (ValidationFailed _ _) -> pure () + other -> expectationFailure ("Expected ValidationFailed, got: " <> show other) + + it "passes range validation" $ do + let decl = intVar "x" True Nothing (Just (ValRange 1 100)) + validateVarValue decl (VInt 50) `shouldBe` Right () + + it "rejects out-of-range value" $ do + let decl = intVar "x" True Nothing (Just (ValRange 1 100)) + case validateVarValue decl (VInt 200) of + Left (ValidationFailed _ _) -> pure () + other -> expectationFailure ("Expected ValidationFailed, got: " <> show other) + + it "passes min-length validation" $ do + let decl = textVar "x" True Nothing (Just (ValMinLength 3)) + validateVarValue decl (VText "hello") `shouldBe` Right () + + it "rejects too-short value" $ do + let decl = textVar "x" True Nothing (Just (ValMinLength 3)) + case validateVarValue decl (VText "ab") of + Left (ValidationFailed _ _) -> pure () + other -> expectationFailure ("Expected ValidationFailed, got: " <> show other) + + it "passes max-length validation" $ do + let decl = textVar "x" True Nothing (Just (ValMaxLength 5)) + validateVarValue decl (VText "hello") `shouldBe` Right () + + it "rejects too-long value" $ do + let decl = textVar "x" True Nothing (Just (ValMaxLength 3)) + case validateVarValue decl (VText "hello") of + Left (ValidationFailed _ _) -> pure () + other -> expectationFailure ("Expected ValidationFailed, got: " <> show other) + + describe "resolveVariables" $ do + it "resolves from CLI overrides" $ do + let decls = [textVar "project.name" True Nothing Nothing] + cli = Map.fromList [("project.name", "my-app")] + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + let rv = resolved Map.! "project.name" + rv.value `shouldBe` VText "my-app" + rv.source `shouldBe` FromCLI + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves from environment variables" $ do + let decls = [textVar "project.name" True Nothing Nothing] + cli = Map.empty + env = Map.fromList [("SEIHOU_VAR_PROJECT_NAME", "env-app")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + let rv = resolved Map.! "project.name" + rv.value `shouldBe` VText "env-app" + rv.source `shouldBe` FromEnv "SEIHOU_VAR_PROJECT_NAME" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves from module defaults" $ do + let decls = [textVar "project.version" False (Just (VText "0.1.0.0")) Nothing] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + let rv = resolved Map.! "project.version" + rv.value `shouldBe` VText "0.1.0.0" + rv.source `shouldBe` FromDefault + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "rejects missing required variable" $ do + let decls = [textVar "project.name" True Nothing Nothing] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> errs `shouldBe` [MissingRequiredVar "project.name"] + Right _ -> expectationFailure "Expected Left" + + it "CLI override beats environment variable" $ do + let decls = [textVar "project.name" True Nothing Nothing] + cli = Map.fromList [("project.name", "cli-app")] + env = Map.fromList [("SEIHOU_VAR_PROJECT_NAME", "env-app")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "project.name") `shouldBe` VText "cli-app" + (.source) (resolved Map.! "project.name") `shouldBe` FromCLI + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "environment variable beats module default" $ do + let decls = [textVar "project.name" True (Just (VText "default-app")) Nothing] + cli = Map.empty + env = Map.fromList [("SEIHOU_VAR_PROJECT_NAME", "env-app")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "project.name") `shouldBe` VText "env-app" + (.source) (resolved Map.! "project.name") `shouldBe` FromEnv "SEIHOU_VAR_PROJECT_NAME" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "CLI override beats module default" $ do + let decls = [textVar "project.name" True (Just (VText "default-app")) Nothing] + cli = Map.fromList [("project.name", "cli-app")] + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "project.name") `shouldBe` VText "cli-app" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves multiple variables with mixed sources" $ do + let decls = + [ textVar "project.name" True Nothing Nothing, + textVar "project.version" False (Just (VText "0.1.0.0")) Nothing, + textVar "license" False (Just (VText "MIT")) Nothing + ] + cli = Map.fromList [("project.name", "my-app")] + env = Map.fromList [("SEIHOU_VAR_LICENSE", "BSD3")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "project.name") `shouldBe` VText "my-app" + (.source) (resolved Map.! "project.name") `shouldBe` FromCLI + (.value) (resolved Map.! "project.version") `shouldBe` VText "0.1.0.0" + (.source) (resolved Map.! "project.version") `shouldBe` FromDefault + (.value) (resolved Map.! "license") `shouldBe` VText "BSD3" + (.source) (resolved Map.! "license") `shouldBe` FromEnv "SEIHOU_VAR_LICENSE" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "coerces CLI bool override" $ do + let decls = [boolVar "enable.tests" True Nothing] + cli = Map.fromList [("enable.tests", "true")] + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "enable.tests") `shouldBe` VBool True + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "coerces env int override" $ do + let decls = [intVar "port" True Nothing Nothing] + cli = Map.empty + env = Map.fromList [("SEIHOU_VAR_PORT", "8080")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "port") `shouldBe` VInt 8080 + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "returns coercion error for bad int" $ do + let decls = [intVar "port" True Nothing Nothing] + cli = Map.fromList [("port", "abc")] + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> errs `shouldBe` [CoercionFailed "port" VTInt "abc"] + Right _ -> expectationFailure "Expected Left" + + it "validates after coercion" $ do + let decls = [textVar "project.name" True Nothing (Just (ValPattern "[a-z][a-z0-9-]*"))] + cli = Map.fromList [("project.name", "MyBad")] + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left (err : _) -> case err of + ValidationFailed _ _ -> pure () + other -> expectationFailure ("Expected ValidationFailed, got: " <> show other) + Left [] -> expectationFailure "Expected non-empty error list" + Right _ -> expectationFailure "Expected Left" + + it "resolves choice variable from CLI" $ do + let decls = [choiceVar "license" True ["MIT", "BSD3", "Apache"] Nothing] + cli = Map.fromList [("license", "MIT")] + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "license") `shouldBe` VText "MIT" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "coerces a raw-text bool default to VBool when falling through to default" $ do + -- Mirrors the Dhall decode of @default = Some "true"@ on a @bool@ var: + -- the default reaches resolution as 'VText' and must arrive typed. + let decls = [boolVar "feature.on" False (Just (VText "true"))] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "feature.on") `shouldBe` VBool True + (.source) (resolved Map.! "feature.on") `shouldBe` FromDefault + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "coerces a raw-text int default to VInt when falling through to default" $ do + let decls = [intVar "retries" False (Just (VText "3")) Nothing] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "retries") `shouldBe` VInt 3 + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "errors when a bool default cannot be coerced" $ do + let decls = [boolVar "feature.on" False (Just (VText "treu"))] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> errs `shouldBe` [CoercionFailed "feature.on" VTBool "treu"] + Right _ -> expectationFailure "Expected Left" + + it "re-coerces a manifest-round-tripped bool value to VBool" $ do + -- The manifest stores resolved variables as raw text (a 'VBool' is + -- serialized to "true"). On a re-run such a value can only re-enter + -- resolution through a config-style 'Map VarName Text' source, which + -- routes through 'coerceValue' — so a stored bool round-trips back to + -- 'VBool', never reaching evaluation as 'VText "true"'. + let manifestStoredText = "true" -- i.e. varValueToText (VBool True) + decls = [boolVar "feature.on" True Nothing] + cli = Map.empty + env = Map.empty + local = Map.fromList [("feature.on", manifestStoredText)] + case resolveVariables decls cli env "" "" local Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "feature.on") `shouldBe` VBool True + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "Eq true evaluates True for a defaulted bool" $ do + -- The end-to-end bug: a bool default must make @Eq feature.on true@ match. + let decls = [boolVar "feature.on" False (Just (VText "true"))] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + let varMap = Map.map (.value) resolved + case parseExpr "Eq feature.on true" of + Right expr -> evalExpr varMap expr `shouldBe` True + Left err -> expectationFailure ("Expected parse, got: " <> show err) + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + describe "formatExplain" $ do + it "formats a provenance report with bracket notation" $ do + let decl1 = textVar "project.name" True Nothing Nothing + decl2 = textVar "project.version" False (Just (VText "0.1.0.0")) Nothing + resolved = + Map.fromList + [ ("project.name", ResolvedVar (VText "my-app") FromCLI decl1), + ("project.version", ResolvedVar (VText "0.1.0.0") FromDefault decl2) + ] + output = formatExplain resolved + T.isInfixOf "project.name" output `shouldBe` True + T.isInfixOf "\"my-app\"" output `shouldBe` True + T.isInfixOf "[--var]" output `shouldBe` True + T.isInfixOf "project.version" output `shouldBe` True + T.isInfixOf "\"0.1.0.0\"" output `shouldBe` True + T.isInfixOf "[default]" output `shouldBe` True + + it "formats env source with bracket notation" $ do + let decl = textVar "license" True Nothing Nothing + resolved = + Map.fromList + [("license", ResolvedVar (VText "MIT") (FromEnv "SEIHOU_VAR_LICENSE") decl)] + output = formatExplain resolved + T.isInfixOf "[env SEIHOU_VAR_LICENSE]" output `shouldBe` True + + it "formats local config source with bracket notation" $ do + let decl = textVar "license" True Nothing Nothing + resolved = + Map.fromList + [("license", ResolvedVar (VText "MIT") FromLocalConfig decl)] + output = formatExplain resolved + T.isInfixOf "[local config]" output `shouldBe` True + + it "formats namespace config source with bracket notation" $ do + let decl = textVar "haskell.ghc" True Nothing Nothing + resolved = + Map.fromList + [("haskell.ghc", ResolvedVar (VText "9.12.2") (FromNamespaceConfig "haskell") decl)] + output = formatExplain resolved + T.isInfixOf "[namespace: haskell]" output `shouldBe` True + + it "formats context config source with bracket notation" $ do + let decl = textVar "user.email" True Nothing Nothing + resolved = + Map.fromList + [("user.email", ResolvedVar (VText "me@work.com") (FromContextConfig "work") decl)] + output = formatExplain resolved + T.isInfixOf "[context: work]" output `shouldBe` True + + it "formats global config source with bracket notation" $ do + let decl = textVar "license" True Nothing Nothing + resolved = + Map.fromList + [("license", ResolvedVar (VText "MIT") FromGlobalConfig decl)] + output = formatExplain resolved + T.isInfixOf "[global config]" output `shouldBe` True + + it "formats parent source with bracket notation" $ do + let decl = textVar "skill.name" True Nothing Nothing + resolved = + Map.fromList + [("skill.name", ResolvedVar (VText "exec-plan") (FromParent "exec-plan") decl)] + output = formatExplain resolved + T.isInfixOf "[parent: exec-plan]" output `shouldBe` True + + it "uses 2-space indentation" $ do + let decl = textVar "license" True Nothing Nothing + resolved = + Map.fromList + [("license", ResolvedVar (VText "MIT") FromCLI decl)] + output = formatExplain resolved + T.isInfixOf " license" output `shouldBe` True + + describe "formatDeclarations" $ do + it "formats required variables without defaults" $ do + let decls = [VarDecl "project.name" VTText Nothing (Just "Name") True Nothing] + output = formatDeclarations decls + T.isInfixOf "project.name" output `shouldBe` True + T.isInfixOf "(required, no default)" output `shouldBe` True + + it "formats variables with default values" $ do + let decls = [VarDecl "project.version" VTText (Just (VText "0.1.0.0")) Nothing False Nothing] + output = formatDeclarations decls + T.isInfixOf "\"0.1.0.0\"" output `shouldBe` True + T.isInfixOf "(required, no default)" output `shouldBe` False + + it "formats variables with defaults using = sign" $ do + let decls = + [ VarDecl + { name = "project.version", + type_ = VTText, + default_ = Just (VText "0.1.0.0"), + description = Nothing, + required = False, + validation = Nothing + } + ] + output = formatDeclarations decls + T.isInfixOf "project.version" output `shouldBe` True + T.isInfixOf "= \"0.1.0.0\"" output `shouldBe` True + + it "aligns columns for multiple variables" $ do + let decls = + [ VarDecl "project.name" VTText Nothing (Just "Name") True Nothing, + VarDecl "project.version" VTText (Just (VText "0.1.0.0")) Nothing False Nothing + ] + output = formatDeclarations decls + outputLines = T.lines output + -- Both lines should have the same position for "=" + length (filter (T.isInfixOf "=") outputLines) `shouldBe` 2 + + it "uses 2-space indentation" $ do + let decls = [VarDecl "x" VTText Nothing Nothing True Nothing] + output = formatDeclarations decls + T.isInfixOf " x" output `shouldBe` True + + describe "resolveVariables (six-layer precedence)" $ do + it "resolves from local config" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.empty + env = Map.empty + local = Map.fromList [("license", "MIT")] + case resolveVariables decls cli env "" "" local Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "MIT" + (.source) (resolved Map.! "license") `shouldBe` FromLocalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves from namespace config" $ do + let decls = [textVar "haskell.ghc" True Nothing Nothing] + cli = Map.empty + env = Map.empty + nsCfg = Map.fromList [("haskell.ghc", "9.12.2")] + case resolveVariables decls cli env "haskell" "" Map.empty nsCfg Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "haskell.ghc") `shouldBe` VText "9.12.2" + (.source) (resolved Map.! "haskell.ghc") `shouldBe` FromNamespaceConfig "haskell" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves from global config" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.empty + env = Map.empty + global = Map.fromList [("license", "MIT")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "MIT" + (.source) (resolved Map.! "license") `shouldBe` FromGlobalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "local config overrides global config" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.empty + env = Map.empty + local = Map.fromList [("license", "BSD3")] + global = Map.fromList [("license", "MIT")] + case resolveVariables decls cli env "" "" local Map.empty Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "BSD3" + (.source) (resolved Map.! "license") `shouldBe` FromLocalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "namespace config overrides global config" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.empty + env = Map.empty + nsCfg = Map.fromList [("license", "Apache")] + global = Map.fromList [("license", "MIT")] + case resolveVariables decls cli env "haskell" "" Map.empty nsCfg Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "Apache" + (.source) (resolved Map.! "license") `shouldBe` FromNamespaceConfig "haskell" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "context config resolves when namespace and local don't have variable" $ do + let decls = [textVar "user.email" True Nothing Nothing] + cli = Map.empty + env = Map.empty + ctxCfg = Map.fromList [("user.email", "me@work.com")] + case resolveVariables decls cli env "" "work" Map.empty Map.empty ctxCfg Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "user.email") `shouldBe` VText "me@work.com" + (.source) (resolved Map.! "user.email") `shouldBe` FromContextConfig "work" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "context config is lower priority than namespace config" $ do + let decls = [textVar "user.email" True Nothing Nothing] + cli = Map.empty + env = Map.empty + nsCfg = Map.fromList [("user.email", "ns@example.com")] + ctxCfg = Map.fromList [("user.email", "ctx@example.com")] + case resolveVariables decls cli env "haskell" "work" Map.empty nsCfg ctxCfg Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "user.email") `shouldBe` VText "ns@example.com" + (.source) (resolved Map.! "user.email") `shouldBe` FromNamespaceConfig "haskell" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "context config is higher priority than global config" $ do + let decls = [textVar "user.email" True Nothing Nothing] + cli = Map.empty + env = Map.empty + ctxCfg = Map.fromList [("user.email", "ctx@example.com")] + global = Map.fromList [("user.email", "global@example.com")] + case resolveVariables decls cli env "" "work" Map.empty Map.empty ctxCfg global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "user.email") `shouldBe` VText "ctx@example.com" + (.source) (resolved Map.! "user.email") `shouldBe` FromContextConfig "work" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "local config overrides namespace config" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.empty + env = Map.empty + local = Map.fromList [("license", "GPL")] + nsCfg = Map.fromList [("license", "Apache")] + case resolveVariables decls cli env "haskell" "" local nsCfg Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "GPL" + (.source) (resolved Map.! "license") `shouldBe` FromLocalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "env overrides local config" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.empty + env = Map.fromList [("SEIHOU_VAR_LICENSE", "env-license")] + local = Map.fromList [("license", "local-license")] + case resolveVariables decls cli env "" "" local Map.empty Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "env-license" + (.source) (resolved Map.! "license") `shouldBe` FromEnv "SEIHOU_VAR_LICENSE" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "CLI overrides all config layers" $ do + let decls = [textVar "license" True Nothing Nothing] + cli = Map.fromList [("license", "cli-license")] + env = Map.fromList [("SEIHOU_VAR_LICENSE", "env-license")] + local = Map.fromList [("license", "local-license")] + nsCfg = Map.fromList [("license", "ns-license")] + global = Map.fromList [("license", "global-license")] + case resolveVariables decls cli env "haskell" "" local nsCfg Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "cli-license" + (.source) (resolved Map.! "license") `shouldBe` FromCLI + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "global config overrides module default" $ do + let decls = [textVar "license" False (Just (VText "default-license")) Nothing] + cli = Map.empty + env = Map.empty + global = Map.fromList [("license", "global-license")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "license") `shouldBe` VText "global-license" + (.source) (resolved Map.! "license") `shouldBe` FromGlobalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves mixed sources across multiple variables" $ do + let decls = + [ textVar "project.name" True Nothing Nothing, + textVar "license" False (Just (VText "MIT")) Nothing, + textVar "haskell.ghc" False (Just (VText "9.8.1")) Nothing + ] + cli = Map.fromList [("project.name", "cli-app")] + env = Map.empty + local = Map.fromList [("license", "BSD3")] + nsCfg = Map.fromList [("haskell.ghc", "9.12.2")] + case resolveVariables decls cli env "haskell" "" local nsCfg Map.empty Map.empty Map.empty of + Right resolved -> do + (.value) (resolved Map.! "project.name") `shouldBe` VText "cli-app" + (.source) (resolved Map.! "project.name") `shouldBe` FromCLI + (.value) (resolved Map.! "license") `shouldBe` VText "BSD3" + (.source) (resolved Map.! "license") `shouldBe` FromLocalConfig + (.value) (resolved Map.! "haskell.ghc") `shouldBe` VText "9.12.2" + (.source) (resolved Map.! "haskell.ghc") `shouldBe` FromNamespaceConfig "haskell" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "omits non-required variable with no value from any source" $ do + let decls = [textVar "optional.var" False Nothing Nothing] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Right resolved -> Map.member "optional.var" resolved `shouldBe` False + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "still errors on missing required variable with no value" $ do + let decls = [textVar "required.var" True Nothing Nothing] + cli = Map.empty + env = Map.empty + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> errs `shouldBe` [MissingRequiredVar "required.var"] + Right _ -> expectationFailure "Expected Left" + + it "resolves non-required variable when value is provided" $ do + let decls = [textVar "optional.var" False Nothing Nothing] + cli = Map.empty + env = Map.empty + global = Map.fromList [("optional.var", "from-global")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "optional.var") `shouldBe` VText "from-global" + (.source) (resolved Map.! "optional.var") `shouldBe` FromGlobalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves mix of required, optional-with-value, and optional-without-value" $ do + let decls = + [ textVar "project.name" True Nothing Nothing, + textVar "optional.missing" False Nothing Nothing, + textVar "optional.present" False Nothing Nothing + ] + cli = Map.fromList [("project.name", "my-app")] + env = Map.empty + global = Map.fromList [("optional.present", "found")] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty global Map.empty of + Right resolved -> do + (.value) (resolved Map.! "project.name") `shouldBe` VText "my-app" + Map.member "optional.missing" resolved `shouldBe` False + (.value) (resolved Map.! "optional.present") `shouldBe` VText "found" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "coerces config values through type system" $ do + let decls = [boolVar "enable.tests" True Nothing] + cli = Map.empty + env = Map.empty + local = Map.fromList [("enable.tests", "true")] + case resolveVariables decls cli env "" "" local Map.empty Map.empty Map.empty Map.empty of + Right resolved -> + (.value) (resolved Map.! "enable.tests") `shouldBe` VBool True + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "resolves from parent-supplied vars" $ do + let decls = [textVar "skill.name" True Nothing Nothing] + cli = Map.empty + env = Map.empty + parentVars = Map.fromList [("skill.name", ("exec-plan", "parent-mod"))] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty parentVars of + Right resolved -> do + (.value) (resolved Map.! "skill.name") `shouldBe` VText "exec-plan" + (.source) (resolved Map.! "skill.name") `shouldBe` FromParent "parent-mod" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "parent-supplied var overrides module default" $ do + let decls = [textVar "skill.name" False (Just (VText "default-val")) Nothing] + cli = Map.empty + env = Map.empty + parentVars = Map.fromList [("skill.name", ("parent-val", "parent-mod"))] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty Map.empty parentVars of + Right resolved -> do + (.value) (resolved Map.! "skill.name") `shouldBe` VText "parent-val" + (.source) (resolved Map.! "skill.name") `shouldBe` FromParent "parent-mod" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "global config overrides parent-supplied var" $ do + let decls = [textVar "skill.name" True Nothing Nothing] + cli = Map.empty + env = Map.empty + global = Map.fromList [("skill.name", "global-val")] + parentVars = Map.fromList [("skill.name", ("parent-val", "parent-mod"))] + case resolveVariables decls cli env "" "" Map.empty Map.empty Map.empty global parentVars of + Right resolved -> do + (.value) (resolved Map.! "skill.name") `shouldBe` VText "global-val" + (.source) (resolved Map.! "skill.name") `shouldBe` FromGlobalConfig + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + describe "diagnoseResolution" $ do + it "reports unused config keys" $ do + let decl = textVar "project.name" True Nothing Nothing + resolved = Map.fromList [("project.name", ResolvedVar (VText "app") FromCLI decl)] + global = Map.fromList [("project.name", "app"), ("auther.name", "typo")] + (unused, _) = diagnoseResolution resolved [decl] Map.empty Map.empty Map.empty global + unused `shouldBe` [VarName "auther.name"] + + it "reports unresolved optional variables" $ do + let decls = + [ textVar "project.name" True Nothing Nothing, + textVar "optional.var" False Nothing Nothing + ] + resolved = Map.fromList [("project.name", ResolvedVar (VText "app") FromCLI (head decls))] + (_, unresolved) = diagnoseResolution resolved decls Map.empty Map.empty Map.empty Map.empty + unresolved `shouldBe` [VarName "optional.var"] + + it "returns empty lists when everything matches" $ do + let decl = textVar "license" True Nothing Nothing + resolved = Map.fromList [("license", ResolvedVar (VText "MIT") FromGlobalConfig decl)] + global = Map.fromList [("license", "MIT")] + (unused, unresolved) = diagnoseResolution resolved [decl] Map.empty Map.empty Map.empty global + unused `shouldBe` [] + unresolved `shouldBe` [] + + it "detects unused keys across all config layers" $ do + let decl = textVar "project.name" True Nothing Nothing + resolved = Map.fromList [("project.name", ResolvedVar (VText "app") FromCLI decl)] + local = Map.fromList [("local.extra", "x")] + nsCfg = Map.fromList [("ns.extra", "y")] + global = Map.fromList [("global.extra", "z")] + (unused, _) = diagnoseResolution resolved [decl] local nsCfg Map.empty global + unused `shouldBe` [VarName "global.extra", VarName "local.extra", VarName "ns.extra"] diff --git a/test/Seihou/Core/VersionSpec.hs b/test/Seihou/Core/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Core/VersionSpec.hs @@ -0,0 +1,70 @@ +module Seihou.Core.VersionSpec (tests) where + +import Seihou.Core.Version (Version (..), parseVersion, renderVersion) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Core.Version" spec + +spec :: Spec +spec = do + describe "parseVersion" $ do + it "parses a three-segment version" $ do + parseVersion "1.0.0" `shouldBe` Just (Version [1, 0, 0]) + + it "parses a two-segment version" $ do + parseVersion "1.2" `shouldBe` Just (Version [1, 2]) + + it "parses a four-segment version" $ do + parseVersion "1.2.3.4" `shouldBe` Just (Version [1, 2, 3, 4]) + + it "parses a single-segment version" $ do + parseVersion "5" `shouldBe` Just (Version [5]) + + it "returns Nothing for empty string" $ do + parseVersion "" `shouldBe` Nothing + + it "returns Nothing for non-numeric input" $ do + parseVersion "abc" `shouldBe` Nothing + + it "returns Nothing for mixed input" $ do + parseVersion "1.2.abc" `shouldBe` Nothing + + it "returns Nothing for negative segments" $ do + parseVersion "1.-2.3" `shouldBe` Nothing + + describe "Eq instance" $ do + it "considers equal versions with trailing zeros" $ do + Version [1, 2, 0] == Version [1, 2] `shouldBe` True + + it "considers 1.0.0 equal to 1" $ do + Version [1, 0, 0] == Version [1] `shouldBe` True + + it "distinguishes different versions" $ do + Version [1, 2] == Version [1, 3] `shouldBe` False + + describe "Ord instance" $ do + it "orders 1.2 < 1.10 (numeric, not lexicographic)" $ do + Version [1, 2] < Version [1, 10] `shouldBe` True + + it "orders 2.0 > 1.99.99" $ do + Version [2, 0] > Version [1, 99, 99] `shouldBe` True + + it "orders equal versions as EQ" $ do + compare (Version [1, 2, 0]) (Version [1, 2]) `shouldBe` EQ + + it "orders 0.1 < 1.0" $ do + Version [0, 1] < Version [1, 0] `shouldBe` True + + describe "renderVersion" $ do + it "renders a three-segment version" $ do + renderVersion (Version [1, 2, 3]) `shouldBe` "1.2.3" + + it "renders a single-segment version" $ do + renderVersion (Version [5]) `shouldBe` "5" + + it "roundtrips with parseVersion" $ do + let v = Version [1, 2, 3] + parseVersion (renderVersion v) `shouldBe` Just v diff --git a/test/Seihou/Dhall/ConfigSpec.hs b/test/Seihou/Dhall/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Dhall/ConfigSpec.hs @@ -0,0 +1,110 @@ +module Seihou.Dhall.ConfigSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Dhall.Config (escapeDhallText, evalConfigFile, evalConfigFileIfExists, serializeConfig) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Dhall.Config" spec + +spec :: Spec +spec = do + describe "evalConfigFile" $ do + it "evaluates a simple Dhall config to Map Text Text" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let path = tmpDir "config.dhall" + writeFile path "{ license = \"MIT\", `project.name` = \"my-app\" }" + result <- evalConfigFile path + Map.lookup "license" result `shouldBe` Just "MIT" + Map.lookup "project.name" result `shouldBe` Just "my-app" + + it "evaluates an empty record" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let path = tmpDir "config.dhall" + writeFile path "{=}" + result <- evalConfigFile path + Map.null result `shouldBe` True + + describe "evalConfigFileIfExists" $ do + it "returns empty map for nonexistent file" $ do + result <- evalConfigFileIfExists "/nonexistent/path/config.dhall" + result `shouldBe` Right Map.empty + + it "returns Right map for valid config file" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let path = tmpDir "config.dhall" + writeFile path "{ license = \"BSD3\" }" + result <- evalConfigFileIfExists path + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> Map.lookup "license" m `shouldBe` Just "BSD3" + + it "returns Left for invalid Dhall" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let path = tmpDir "config.dhall" + writeFile path "this is not valid dhall @@##" + result <- evalConfigFileIfExists path + case result of + Left _ -> pure () + Right _ -> expectationFailure "Expected Left for invalid Dhall" + + describe "serializeConfig" $ do + it "serializes an empty map to {=}" $ do + serializeConfig Map.empty `shouldBe` "{=}\n" + + it "serializes a single entry" $ do + let m = Map.fromList [("license", "MIT")] + result = serializeConfig m + result `shouldSatisfy` T.isInfixOf "`license`" + result `shouldSatisfy` T.isInfixOf "\"MIT\"" + + it "serializes multiple entries in sorted order" $ do + let m = Map.fromList [("z-key", "last"), ("a-key", "first")] + result = serializeConfig m + aPos = T.findIndex (== 'a') result + zPos = T.findIndex (== 'z') result + -- a-key should appear before z-key (sorted) + case (aPos, zPos) of + (Just a, Just z) -> a `shouldSatisfy` (< z) + _ -> expectationFailure "Expected both keys in output" + + it "round-trips through evalConfigFile" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let original = Map.fromList [("project.name", "my-app"), ("license", "MIT")] + path = tmpDir "config.dhall" + TIO.writeFile path (serializeConfig original) + result <- evalConfigFile path + result `shouldBe` original + + it "round-trips dotted keys" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let original = Map.fromList [("haskell.ghc", "9.12.2"), ("project.name", "test")] + path = tmpDir "config.dhall" + TIO.writeFile path (serializeConfig original) + result <- evalConfigFile path + result `shouldBe` original + + it "round-trips values with special characters" $ do + withSystemTempDirectory "seihou-config-test" $ \tmpDir -> do + let original = Map.fromList [("path", "C:\\Users\\me"), ("quote", "say \"hello\"")] + path = tmpDir "config.dhall" + TIO.writeFile path (serializeConfig original) + result <- evalConfigFile path + result `shouldBe` original + + describe "escapeDhallText" $ do + it "passes through plain text unchanged" $ do + escapeDhallText "hello world" `shouldBe` "hello world" + + it "escapes backslashes" $ do + escapeDhallText "a\\b" `shouldBe` "a\\\\b" + + it "escapes double-quotes" $ do + escapeDhallText "say \"hi\"" `shouldBe` "say \\\"hi\\\"" diff --git a/test/Seihou/Dhall/EvalSpec.hs b/test/Seihou/Dhall/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Dhall/EvalSpec.hs @@ -0,0 +1,406 @@ +module Seihou.Dhall.EvalSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalDhallExpr, evalModuleFromFile, evalRecipeFromFile) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Dhall.Eval" spec + +fixtureDir :: FilePath +fixtureDir = "test/fixtures" + +-- | Build a minimal @module.dhall@ source containing a single variable with the +-- given name, declared type string, and @default@ Dhall expression (e.g. +-- @"Some \"true\""@ or @"None Text"@). +moduleWithVar :: String -> String -> String -> String +moduleWithVar varName varType defaultExpr = + "{ name = \"var-test\"\n\ + \, version = None Text\n\ + \, description = None Text\n\ + \, vars =\n\ + \ [ { name = \"" + ++ varName + ++ "\"\n\ + \ , type = \"" + ++ varType + ++ "\"\n\ + \ , default = " + ++ defaultExpr + ++ "\n\ + \ , description = None Text\n\ + \ , required = False\n\ + \ , validation = None Text\n\ + \ }\n\ + \ ]\n\ + \, exports = [] : List { var : Text, alias : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }\n\ + \, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }\n\ + \, dependencies = [] : List Text\n\ + \, removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }\n\ + \}" + +spec :: Spec +spec = do + describe "evalDhallExpr (spike)" $ do + it "decodes a simple Dhall record with name and version" $ do + result <- evalDhallExpr "{ name = \"my-project\", version = \"0.1.0\" }" + Map.lookup "name" result `shouldBe` Just "my-project" + Map.lookup "version" result `shouldBe` Just "0.1.0" + + describe "evalModuleFromFile" $ do + it "decodes the haskell-base fixture module" $ do + result <- evalModuleFromFile (fixtureDir "haskell-base" "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + m.name `shouldBe` ModuleName "haskell-base" + m.description `shouldBe` Just "A Haskell project template" + length (m.vars) `shouldBe` 3 + length (m.prompts) `shouldBe` 1 + length (m.steps) `shouldBe` 5 + length (m.exports) `shouldBe` 1 + m.dependencies `shouldBe` [] + + it "decodes variable declarations correctly" $ do + result <- evalModuleFromFile (fixtureDir "haskell-base" "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let (projectName : projectVersion : _) = m.vars + projectName.name `shouldBe` VarName "project.name" + projectName.type_ `shouldBe` VTText + projectName.default_ `shouldBe` Nothing + projectName.required `shouldBe` True + projectName.validation `shouldBe` Just (ValPattern "[a-z][a-z0-9-]*") + + projectVersion.name `shouldBe` VarName "project.version" + projectVersion.default_ `shouldBe` Just (VText "0.1.0.0") + projectVersion.required `shouldBe` False + + it "decodes steps with correct strategy" $ do + result <- evalModuleFromFile (fixtureDir "haskell-base" "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let (readme : libStep : licenseStep : _) = m.steps + readme.strategy `shouldBe` Template + readme.src `shouldBe` "README.md.tpl" + readme.dest `shouldBe` "README.md" + readme.condition `shouldBe` Nothing + readme.patch `shouldBe` Nothing + + libStep.strategy `shouldBe` Template + libStep.src `shouldBe` "src/Lib.hs.tpl" + libStep.dest `shouldBe` "src/Lib.hs" + libStep.patch `shouldBe` Nothing + + licenseStep.strategy `shouldBe` Copy + licenseStep.src `shouldBe` "LICENSE" + licenseStep.dest `shouldBe` "LICENSE" + licenseStep.condition `shouldBe` Just (ExprIsSet "license") + licenseStep.patch `shouldBe` Nothing + + it "decodes exports correctly" $ do + result <- evalModuleFromFile (fixtureDir "haskell-base" "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let (export1 : _) = m.exports + export1.var `shouldBe` VarName "project.name" + export1.alias `shouldBe` Nothing + + it "returns DhallEvalError for nonexistent file" $ do + result <- evalModuleFromFile "/nonexistent/path/module.dhall" + case result of + Left (DhallEvalError _ _) -> pure () + Left other -> expectationFailure ("Expected DhallEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left, got Right" + + it "returns Left for unknown var type (not a crash)" $ do + result <- evalModuleFromFile (fixtureDir "bad-vartype" "module.dhall") + case result of + Left (DhallEvalError _ msg) -> + T.isInfixOf "strng" msg `shouldBe` True + Left other -> expectationFailure ("Expected DhallEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left for bad var type" + + it "returns Left for unknown strategy (not a crash)" $ do + result <- evalModuleFromFile (fixtureDir "bad-strategy" "module.dhall") + case result of + Left (DhallEvalError _ msg) -> + T.isInfixOf "coppy" msg `shouldBe` True + Left other -> expectationFailure ("Expected DhallEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left for bad strategy" + + it "decodes prompts correctly" $ do + result <- evalModuleFromFile (fixtureDir "haskell-base" "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let (prompt1 : _) = m.prompts + prompt1.var `shouldBe` VarName "project.name" + prompt1.text `shouldBe` "What is the project name?" + prompt1.condition `shouldBe` Nothing + prompt1.choices `shouldBe` Nothing + + it "decodes step with patch = Some \"append-file\"" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "section.tpl") "section content" + let dhall = + "{ name = \"patch-test\"\n\ + \, version = None Text\n\ + \, description = None Text\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, exports = [] : List { var : Text, alias : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, steps =\n\ + \ [ { strategy = \"template\"\n\ + \ , src = \"section.tpl\"\n\ + \ , dest = \"README.md\"\n\ + \ , when = None Text\n\ + \ , patch = Some \"append-file\"\n\ + \ }\n\ + \ , { strategy = \"template\"\n\ + \ , src = \"section.tpl\"\n\ + \ , dest = \"README.md\"\n\ + \ , when = None Text\n\ + \ , patch = Some \"prepend-file\"\n\ + \ }\n\ + \ , { strategy = \"template\"\n\ + \ , src = \"section.tpl\"\n\ + \ , dest = \"README.md\"\n\ + \ , when = None Text\n\ + \ , patch = Some \"append-section\"\n\ + \ }\n\ + \ ]\n\ + \, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }\n\ + \, dependencies = [] : List Text\n\ + \, removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }\n\ + \}" + writeFile (tmpDir "module.dhall") dhall + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let (s1 : s2 : s3 : _) = m.steps + s1.patch `shouldBe` Just AppendFile + s2.patch `shouldBe` Just PrependFile + s3.patch `shouldBe` Just AppendSection + + it "returns Left for unknown patch operation (not a crash)" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "section.tpl") "content" + let dhall = + "{ name = \"bad-patch\"\n\ + \, version = None Text\n\ + \, description = None Text\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, exports = [] : List { var : Text, alias : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, steps =\n\ + \ [ { strategy = \"template\"\n\ + \ , src = \"section.tpl\"\n\ + \ , dest = \"README.md\"\n\ + \ , when = None Text\n\ + \ , patch = Some \"invalid-op\"\n\ + \ }\n\ + \ ]\n\ + \, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }\n\ + \, dependencies = [] : List Text\n\ + \, removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }\n\ + \}" + writeFile (tmpDir "module.dhall") dhall + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left (DhallEvalError _ msg) -> + T.isInfixOf "invalid-op" msg `shouldBe` True + Left other -> expectationFailure ("Expected DhallEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left for bad patch operation" + + it "coerces a bool default to VBool at decode time" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (moduleWithVar "feature.on" "bool" "Some \"true\"") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let v = head m.vars + v.type_ `shouldBe` VTBool + v.default_ `shouldBe` Just (VBool True) + + it "coerces an int default to VInt at decode time" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (moduleWithVar "retries" "int" "Some \"3\"") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + let v = head m.vars + v.type_ `shouldBe` VTInt + v.default_ `shouldBe` Just (VInt 3) + + it "fails module load on a malformed bool default" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (moduleWithVar "feature.on" "bool" "Some \"treu\"") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left (DhallEvalError _ msg) -> do + T.isInfixOf "feature.on" msg `shouldBe` True + T.isInfixOf "treu" msg `shouldBe` True + Left other -> expectationFailure ("Expected DhallEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left for malformed bool default" + + describe "dependencyDecoder" $ do + let emptyModuleWithDeps depsStr = + "{ name = \"test-mod\"\n\ + \, version = None Text\n\ + \, description = None Text\n\ + \, vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }\n\ + \, exports = [] : List { var : Text, alias : Optional Text }\n\ + \, prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }\n\ + \, steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }\n\ + \, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }\n\ + \, dependencies = " + ++ depsStr + ++ "\n\ + \, removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }\n\ + \}" + + it "decodes a bare string dependency" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (emptyModuleWithDeps "[\"base\"]") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + length m.dependencies `shouldBe` 1 + let dep = head m.dependencies + dep.depModule `shouldBe` ModuleName "base" + Map.null dep.depVars `shouldBe` True + + it "decodes a parameterized record dependency" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (emptyModuleWithDeps "[{ module = \"base\", vars = [{ name = \"x\", value = \"y\" }] }]") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + length m.dependencies `shouldBe` 1 + let dep = head m.dependencies + dep.depModule `shouldBe` ModuleName "base" + Map.lookup (VarName "x") dep.depVars `shouldBe` Just "y" + + it "decodes a parameterized dependency with empty vars" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (emptyModuleWithDeps "[{ module = \"base\", vars = [] : List { name : Text, value : Text } }]") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + length m.dependencies `shouldBe` 1 + let dep = head m.dependencies + dep.depModule `shouldBe` ModuleName "base" + Map.null dep.depVars `shouldBe` True + + it "decodes a module.dhall with parameterized dependencies" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + writeFile (tmpDir "module.dhall") (emptyModuleWithDeps "[{ module = \"child-mod\", vars = [{ name = \"skill.name\", value = \"exec-plan\" }] }]") + result <- evalModuleFromFile (tmpDir "module.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right m -> do + length m.dependencies `shouldBe` 1 + let dep = head m.dependencies + dep.depModule `shouldBe` ModuleName "child-mod" + Map.lookup (VarName "skill.name") dep.depVars `shouldBe` Just "exec-plan" + + describe "evalRecipeFromFile" $ do + it "decodes the haskell-with-nix-recipe fixture" $ do + result <- evalRecipeFromFile (fixtureDir "haskell-with-nix-recipe" "recipe.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right r -> do + r.name `shouldBe` RecipeName "haskell-with-nix" + r.version `shouldBe` Just "1.0.0" + r.description `shouldBe` Just "Haskell project with Nix integration" + length r.modules `shouldBe` 2 + let (m1 : m2 : _) = r.modules + m1.depModule `shouldBe` ModuleName "haskell-base" + Map.null m1.depVars `shouldBe` True + m2.depModule `shouldBe` ModuleName "nix-flake" + Map.null m2.depVars `shouldBe` True + r.vars `shouldBe` [] + r.prompts `shouldBe` [] + + it "decodes the haskell-pinned-recipe fixture with variable bindings" $ do + result <- evalRecipeFromFile (fixtureDir "haskell-pinned-recipe" "recipe.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right r -> do + r.name `shouldBe` RecipeName "haskell-pinned" + length r.modules `shouldBe` 2 + let (m1 : m2 : _) = r.modules + m1.depModule `shouldBe` ModuleName "haskell-base" + Map.null m1.depVars `shouldBe` True + m2.depModule `shouldBe` ModuleName "nix-flake" + Map.lookup (VarName "nix.system") m2.depVars `shouldBe` Just "aarch64-darwin" + + it "returns DhallEvalError for nonexistent recipe file" $ do + result <- evalRecipeFromFile "/nonexistent/path/recipe.dhall" + case result of + Left (DhallEvalError _ _) -> pure () + Left other -> expectationFailure ("Expected DhallEvalError, got: " <> show other) + Right _ -> expectationFailure "Expected Left, got Right" + + it "decodes a recipe with recipe-level vars and prompts" $ do + withSystemTempDirectory "seihou-eval-test" $ \tmpDir -> do + let dhall = + "{ name = \"prompted-recipe\"\n\ + \, version = Some \"1.0.0\"\n\ + \, description = Some \"Recipe with prompts\"\n\ + \, modules =\n\ + \ [ { module = \"base\", vars = [] : List { name : Text, value : Text } }\n\ + \ ]\n\ + \, vars =\n\ + \ [ { name = \"project.name\"\n\ + \ , type = \"text\"\n\ + \ , default = None Text\n\ + \ , description = Some \"Project name\"\n\ + \ , required = True\n\ + \ , validation = None Text\n\ + \ }\n\ + \ ]\n\ + \, prompts =\n\ + \ [ { var = \"project.name\"\n\ + \ , text = \"What is the project name?\"\n\ + \ , when = None Text\n\ + \ , choices = None (List Text)\n\ + \ }\n\ + \ ]\n\ + \}" + writeFile (tmpDir "recipe.dhall") dhall + result <- evalRecipeFromFile (tmpDir "recipe.dhall") + case result of + Left err -> expectationFailure ("Expected Right, got Left: " <> show err) + Right r -> do + r.name `shouldBe` RecipeName "prompted-recipe" + length r.vars `shouldBe` 1 + let v = head r.vars + v.name `shouldBe` VarName "project.name" + v.type_ `shouldBe` VTText + v.required `shouldBe` True + length r.prompts `shouldBe` 1 + let p = head r.prompts + p.var `shouldBe` VarName "project.name" + p.text `shouldBe` "What is the project name?" diff --git a/test/Seihou/Dhall/MigrationDecoderSpec.hs b/test/Seihou/Dhall/MigrationDecoderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Dhall/MigrationDecoderSpec.hs @@ -0,0 +1,248 @@ +module Seihou.Dhall.MigrationDecoderSpec (tests) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Migration (Migration (..), MigrationOp (..)) +import Seihou.Core.Types (Module (..), ModuleLoadError) +import Seihou.Dhall.Eval (evalModuleFromFile) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Dhall.MigrationDecoder" spec + +spec :: Spec +spec = do + describe "moduleDecoder migrations field" $ do + it "decodes a module with no migrations field as []" $ + withModuleDhall noMigrationsField $ \result -> + case result of + Right m -> m.migrations `shouldBe` [] + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a module with an empty migrations list" $ + withModuleDhall emptyMigrations $ \result -> + case result of + Right m -> m.migrations `shouldBe` [] + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a single MoveFile migration" $ + withModuleDhall (oneMigration moveFileOp) $ \result -> + case result of + Right m -> case m.migrations of + [Migration {from = "1.0.0", to = "2.0.0", ops = [op]}] -> + op `shouldBe` MoveFile {src = "old/Path.hs", dest = "new/Path.hs"} + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a MoveDir migration" $ + withModuleDhall (oneMigration moveDirOp) $ \result -> + case result of + Right m -> case m.migrations of + [Migration {ops = [op]}] -> + op `shouldBe` MoveDir {src = "app", dest = "src"} + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a DeleteFile migration" $ + withModuleDhall (oneMigration deleteFileOp) $ \result -> + case result of + Right m -> case m.migrations of + [Migration {ops = [op]}] -> + op `shouldBe` DeleteFile {path = "Setup.hs"} + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a DeleteDir migration" $ + withModuleDhall (oneMigration deleteDirOp) $ \result -> + case result of + Right m -> case m.migrations of + [Migration {ops = [op]}] -> + op `shouldBe` DeleteDir {path = "obsolete"} + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a RunCommand migration without workDir" $ + withModuleDhall (oneMigration runCommandNoWorkDir) $ \result -> + case result of + Right m -> case m.migrations of + [Migration {ops = [op]}] -> + op `shouldBe` RunCommand {run = "echo hi", workDir = Nothing} + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes a RunCommand migration with workDir" $ + withModuleDhall (oneMigration runCommandWithWorkDir) $ \result -> + case result of + Right m -> case m.migrations of + [Migration {ops = [op]}] -> + op `shouldBe` RunCommand {run = "make clean", workDir = Just "build"} + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes multiple ops in a single migration in declaration order" $ + withModuleDhall multiOpMigration $ \result -> + case result of + Right m -> case m.migrations of + [Migration {ops}] -> + ops + `shouldBe` [ MoveDir {src = "app", dest = "src"}, + DeleteFile {path = "Setup.hs"}, + RunCommand {run = "echo hi", workDir = Nothing} + ] + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + + it "decodes multiple migrations in declaration order" $ + withModuleDhall twoChainedMigrations $ \result -> + case result of + Right m -> case m.migrations of + [m1, m2] -> do + m1.from `shouldBe` "1.0.0" + m1.to `shouldBe` "2.0.0" + m2.from `shouldBe` "2.0.0" + m2.to `shouldBe` "3.0.0" + other -> expectationFailure ("Unexpected migrations: " <> show other) + Left err -> expectationFailure ("Expected Right, got: " <> show err) + +-- ---------------------------------------------------------------------------- +-- Helper: write a tmp module.dhall and run the file evaluator on it. +-- ---------------------------------------------------------------------------- + +withModuleDhall :: + Text -> + (Either ModuleLoadError Module -> IO ()) -> + IO () +withModuleDhall body action = + withSystemTempDirectory "seihou-migration-decoder" $ \dir -> do + createDirectoryIfMissing True (dir "files") + let path = dir "module.dhall" + TIO.writeFile path body + result <- evalModuleFromFile path + action result + +-- ---------------------------------------------------------------------------- +-- Module fixtures expressed inline as Dhall text. +-- ---------------------------------------------------------------------------- + +-- Bare-record skeleton for a module without the migrations field. The +-- decoder's withDefaults injects an empty list when the field is absent. +noMigrationsField :: Text +noMigrationsField = + T.unlines + [ "{ name = \"sample\"", + ", version = Some \"1.0.0\"", + ", description = None Text", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + +migrationFieldType :: Text +migrationFieldType = + "List { from : Text, to : Text, ops : List < MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } > }" + +emptyMigrations :: Text +emptyMigrations = withMigrations ("[] : " <> migrationFieldType) + +oneMigration :: Text -> Text +oneMigration opLit = + withMigrations $ + T.intercalate + "\n" + [ "[ { from = \"1.0.0\"", + " , to = \"2.0.0\"", + " , ops = [ " <> opLit <> " ]", + " }", + "]" + ] + +multiOpMigration :: Text +multiOpMigration = + withMigrations $ + T.intercalate + "\n" + [ "[ { from = \"1.0.0\"", + " , to = \"2.0.0\"", + " , ops =", + " [ " <> moveDirOp, + " , " <> deleteFileOp, + " , " <> runCommandNoWorkDir, + " ]", + " }", + "]" + ] + +twoChainedMigrations :: Text +twoChainedMigrations = + withMigrations $ + T.intercalate + "\n" + [ "[ { from = \"1.0.0\"", + " , to = \"2.0.0\"", + " , ops = [ " <> moveDirOp <> " ]", + " }", + ", { from = \"2.0.0\"", + " , to = \"3.0.0\"", + " , ops = [ " <> deleteFileOp <> " ]", + " }", + "]" + ] + +-- | Splice an explicit migrations literal into the bare-record skeleton. +withMigrations :: Text -> Text +withMigrations migrationsLit = + T.unlines + [ "{ name = \"sample\"", + ", version = Some \"1.0.0\"", + ", description = None Text", + ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }", + ", exports = [] : List { var : Text, alias : Optional Text }", + ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }", + ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }", + ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }", + ", dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } }", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + ", migrations = " <> migrationsLit, + "}" + ] + +-- Dhall union literals for each MigrationOp variant. Each is a fully +-- qualified, type-annotated expression so it can be embedded in a list +-- without an enclosing type annotation on the list elements. + +migrationOpType :: Text +migrationOpType = + "< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >" + +opLit :: Text -> Text -> Text +opLit ctor body = + "(" <> migrationOpType <> ").\n " <> ctor <> " " <> body + +moveFileOp :: Text +moveFileOp = opLit "MoveFile" "{ src = \"old/Path.hs\", dest = \"new/Path.hs\" }" + +moveDirOp :: Text +moveDirOp = opLit "MoveDir" "{ src = \"app\", dest = \"src\" }" + +deleteFileOp :: Text +deleteFileOp = opLit "DeleteFile" "{ path = \"Setup.hs\" }" + +deleteDirOp :: Text +deleteDirOp = opLit "DeleteDir" "{ path = \"obsolete\" }" + +runCommandNoWorkDir :: Text +runCommandNoWorkDir = opLit "RunCommand" "{ run = \"echo hi\", workDir = None Text }" + +runCommandWithWorkDir :: Text +runCommandWithWorkDir = opLit "RunCommand" "{ run = \"make clean\", workDir = Some \"build\" }" diff --git a/test/Seihou/Effect/ConfigReaderSpec.hs b/test/Seihou/Effect/ConfigReaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Effect/ConfigReaderSpec.hs @@ -0,0 +1,125 @@ +module Seihou.Effect.ConfigReaderSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Effectful +import Seihou.Core.Types (ConfigError (..)) +import Seihou.Dhall.Config (evalConfigFileIfExists) +import Seihou.Effect.ConfigReader (readContextConfig, readGlobalConfig, readLocalConfig, readNamespaceConfig) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConfigReaderPure (runConfigReaderPure) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Effect.ConfigReader" spec + +spec :: Spec +spec = do + describe "pure interpreter" $ do + it "ReadGlobalConfig returns the scripted global map" $ do + let globalCfg = Map.fromList [("license", "MIT"), ("author", "Test")] + result = runPureEff $ runConfigReaderPure Map.empty Map.empty Map.empty globalCfg readGlobalConfig + result `shouldBe` Right globalCfg + + it "ReadLocalConfig returns the scripted local map" $ do + let localCfg = Map.fromList [("project.name", "local-app")] + result = runPureEff $ runConfigReaderPure localCfg Map.empty Map.empty Map.empty readLocalConfig + result `shouldBe` Right localCfg + + it "ReadNamespaceConfig returns the scripted namespace map" $ do + let nsCfgs = Map.fromList [("haskell", Map.fromList [("haskell.ghc", "9.12.2")])] + result = runPureEff $ runConfigReaderPure Map.empty nsCfgs Map.empty Map.empty (readNamespaceConfig "haskell") + result `shouldBe` Right (Map.fromList [("haskell.ghc", "9.12.2")]) + + it "ReadNamespaceConfig returns empty for unknown namespace" $ do + let nsCfgs = Map.fromList [("haskell", Map.fromList [("haskell.ghc", "9.12.2")])] + result = runPureEff $ runConfigReaderPure Map.empty nsCfgs Map.empty Map.empty (readNamespaceConfig "nix") + result `shouldBe` Right Map.empty + + it "ReadContextConfig returns the scripted context map" $ do + let ctxCfgs = Map.fromList [("work", Map.fromList [("user.email", "work@example.com")])] + result = runPureEff $ runConfigReaderPure Map.empty Map.empty ctxCfgs Map.empty (readContextConfig "work") + result `shouldBe` Right (Map.fromList [("user.email", "work@example.com")]) + + it "ReadContextConfig returns empty for unknown context" $ do + let ctxCfgs = Map.fromList [("work", Map.fromList [("user.email", "work@example.com")])] + result = runPureEff $ runConfigReaderPure Map.empty Map.empty ctxCfgs Map.empty (readContextConfig "personal") + result `shouldBe` Right Map.empty + + it "returns independent values from each config layer" $ do + let localCfg = Map.fromList [("project.name", "local-app")] + nsCfgs = Map.fromList [("haskell", Map.fromList [("haskell.ghc", "9.12.2")])] + ctxCfgs = Map.fromList [("work", Map.fromList [("user.email", "work@example.com")])] + globalCfg = Map.fromList [("license", "MIT")] + (local, ns, ctx, global) = runPureEff $ runConfigReaderPure localCfg nsCfgs ctxCfgs globalCfg $ do + l <- readLocalConfig + n <- readNamespaceConfig "haskell" + c <- readContextConfig "work" + g <- readGlobalConfig + pure (l, n, c, g) + local `shouldBe` Right localCfg + ns `shouldBe` Right (Map.fromList [("haskell.ghc", "9.12.2")]) + ctx `shouldBe` Right (Map.fromList [("user.email", "work@example.com")]) + global `shouldBe` Right globalCfg + + describe "namespace validation (IO interpreter)" $ do + it "rejects namespace containing '..'" $ do + result <- runEff $ runConfigReader $ readNamespaceConfig "../etc" + case result of + Left (InvalidNamespace ns _) -> ns `shouldBe` "../etc" + Left other -> expectationFailure ("Expected InvalidNamespace, got: " <> show other) + Right _ -> expectationFailure "Expected Left for path traversal namespace" + + it "rejects namespace containing '/'" $ do + result <- runEff $ runConfigReader $ readNamespaceConfig "foo/bar" + case result of + Left (InvalidNamespace ns _) -> ns `shouldBe` "foo/bar" + Left other -> expectationFailure ("Expected InvalidNamespace, got: " <> show other) + Right _ -> expectationFailure "Expected Left for namespace with slash" + + it "accepts a normal namespace" $ do + result <- runEff $ runConfigReader $ readNamespaceConfig "haskell" + case result of + Left (InvalidNamespace _ _) -> expectationFailure "Did not expect InvalidNamespace for 'haskell'" + _ -> pure () -- Right or ConfigParseError (missing file) are both OK + it "returns Right empty for empty namespace" $ do + result <- runEff $ runConfigReader $ readNamespaceConfig "" + result `shouldBe` Right Map.empty + + describe "context validation (IO interpreter)" $ do + it "rejects context containing '..'" $ do + result <- runEff $ runConfigReader $ readContextConfig "../etc" + case result of + Left (InvalidNamespace ctx _) -> ctx `shouldBe` "../etc" + Left other -> expectationFailure ("Expected InvalidNamespace, got: " <> show other) + Right _ -> expectationFailure "Expected Left for path traversal context" + + it "rejects context containing '/'" $ do + result <- runEff $ runConfigReader $ readContextConfig "foo/bar" + case result of + Left (InvalidNamespace ctx _) -> ctx `shouldBe` "foo/bar" + Left other -> expectationFailure ("Expected InvalidNamespace, got: " <> show other) + Right _ -> expectationFailure "Expected Left for context with slash" + + it "accepts a normal context" $ do + result <- runEff $ runConfigReader $ readContextConfig "work" + case result of + Left (InvalidNamespace _ _) -> expectationFailure "Did not expect InvalidNamespace for 'work'" + _ -> pure () + + it "returns Right empty for empty context" $ do + result <- runEff $ runConfigReader $ readContextConfig "" + result `shouldBe` Right Map.empty + + describe "config parse error propagation" $ do + it "evalConfigFileIfExists returns Left for malformed Dhall" $ do + withSystemTempDirectory "seihou-test" $ \tmpDir -> do + let path = tmpDir <> "/bad.dhall" + writeFile path "{ this is not valid dhall" + result <- evalConfigFileIfExists path + case result of + Left err -> T.isInfixOf "Error reading config" err `shouldBe` True + Right _ -> expectationFailure "Expected Left for malformed Dhall" diff --git a/test/Seihou/Effect/ConfigWriterSpec.hs b/test/Seihou/Effect/ConfigWriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Effect/ConfigWriterSpec.hs @@ -0,0 +1,99 @@ +module Seihou.Effect.ConfigWriterSpec (tests) where + +import Data.Map.Strict qualified as Map +import Effectful +import Seihou.Core.Types (ConfigScope (..)) +import Seihou.Effect.ConfigWriter (ConfigWriter, deleteConfigValue, listConfigValues, writeConfigValue) +import Seihou.Effect.ConfigWriterPure (ConfigWriterState (..), emptyConfigWriterState, runConfigWriterPure) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Effect.ConfigWriter" spec + +run :: ConfigWriterState -> Eff '[ConfigWriter] a -> (a, ConfigWriterState) +run st action = runPureEff $ runConfigWriterPure st action + +spec :: Spec +spec = do + describe "writeConfigValue + listConfigValues" $ do + it "writes a value and lists it back" $ do + let (result, _) = run emptyConfigWriterState $ do + writeConfigValue ScopeLocal "project.name" "my-app" + listConfigValues ScopeLocal + result `shouldBe` Right (Map.fromList [("project.name", "my-app")]) + + it "overwrites an existing value" $ do + let initial = emptyConfigWriterState {cwLocal = Map.fromList [("key", "old")]} + (result, _) = run initial $ do + writeConfigValue ScopeLocal "key" "new" + listConfigValues ScopeLocal + result `shouldBe` Right (Map.fromList [("key", "new")]) + + it "preserves other keys when writing" $ do + let initial = emptyConfigWriterState {cwLocal = Map.fromList [("existing", "keep")]} + (result, _) = run initial $ do + writeConfigValue ScopeLocal "new-key" "added" + listConfigValues ScopeLocal + result `shouldBe` Right (Map.fromList [("existing", "keep"), ("new-key", "added")]) + + it "writes to global scope independently of local" $ do + let (resultLocal, _) = run emptyConfigWriterState $ do + writeConfigValue ScopeGlobal "license" "MIT" + listConfigValues ScopeLocal + (resultGlobal, _) = run emptyConfigWriterState $ do + writeConfigValue ScopeGlobal "license" "MIT" + listConfigValues ScopeGlobal + resultLocal `shouldBe` Right Map.empty + resultGlobal `shouldBe` Right (Map.fromList [("license", "MIT")]) + + it "writes to namespace scope" $ do + let (result, _) = run emptyConfigWriterState $ do + writeConfigValue (ScopeNamespace "haskell") "haskell.ghc" "9.12.2" + listConfigValues (ScopeNamespace "haskell") + result `shouldBe` Right (Map.fromList [("haskell.ghc", "9.12.2")]) + + it "keeps namespace scopes independent" $ do + let (r1, _) = run emptyConfigWriterState $ do + writeConfigValue (ScopeNamespace "haskell") "key" "h-val" + writeConfigValue (ScopeNamespace "nix") "key" "n-val" + listConfigValues (ScopeNamespace "haskell") + (r2, _) = run emptyConfigWriterState $ do + writeConfigValue (ScopeNamespace "haskell") "key" "h-val" + writeConfigValue (ScopeNamespace "nix") "key" "n-val" + listConfigValues (ScopeNamespace "nix") + r1 `shouldBe` Right (Map.fromList [("key", "h-val")]) + r2 `shouldBe` Right (Map.fromList [("key", "n-val")]) + + describe "deleteConfigValue" $ do + it "removes an existing value" $ do + let initial = emptyConfigWriterState {cwLocal = Map.fromList [("key", "val")]} + (result, _) = run initial $ do + deleteConfigValue ScopeLocal "key" + listConfigValues ScopeLocal + result `shouldBe` Right Map.empty + + it "is a no-op for nonexistent key" $ do + let initial = emptyConfigWriterState {cwLocal = Map.fromList [("keep", "me")]} + (result, _) = run initial $ do + deleteConfigValue ScopeLocal "nonexistent" + listConfigValues ScopeLocal + result `shouldBe` Right (Map.fromList [("keep", "me")]) + + it "deletes from global scope" $ do + let initial = emptyConfigWriterState {cwGlobal = Map.fromList [("license", "MIT")]} + (result, _) = run initial $ do + deleteConfigValue ScopeGlobal "license" + listConfigValues ScopeGlobal + result `shouldBe` Right Map.empty + + describe "state inspection" $ do + it "returns final state with all changes" $ do + let (_, finalState) = run emptyConfigWriterState $ do + writeConfigValue ScopeLocal "local.key" "l" + writeConfigValue ScopeGlobal "global.key" "g" + writeConfigValue (ScopeNamespace "ns") "ns.key" "n" + finalState.cwLocal `shouldBe` Map.fromList [("local.key", "l")] + finalState.cwGlobal `shouldBe` Map.fromList [("global.key", "g")] + Map.lookup "ns" (finalState.cwNamespaces) `shouldBe` Just (Map.fromList [("ns.key", "n")]) diff --git a/test/Seihou/Effect/FilesystemSpec.hs b/test/Seihou/Effect/FilesystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Effect/FilesystemSpec.hs @@ -0,0 +1,147 @@ +module Seihou.Effect.FilesystemSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Effectful +import Seihou.Effect.Filesystem +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import System.Directory (removeDirectoryRecursive) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Effect.Filesystem" spec + +-- | Run an action with the pure filesystem interpreter. +runPure :: PureFS -> Eff '[Filesystem] a -> (a, PureFS) +runPure fs action = runPureEff $ runFilesystemPure fs action + +-- | Run an action with the real filesystem interpreter in a temp directory. +runReal :: (FilePath -> Eff '[Filesystem, IOE] a) -> IO a +runReal action = + withSystemTempDirectory "seihou-fs-test" $ \tmpDir -> + runEff $ runFilesystem (action tmpDir) + +spec :: Spec +spec = do + describe "pure interpreter" $ do + it "writes and reads a file" $ do + let (content, _) = runPure emptyFS $ do + writeFileText "hello.txt" "hello world" + readFileText "hello.txt" + content `shouldBe` "hello world" + + it "doesFileExist returns False before write" $ do + let (exists, _) = runPure emptyFS $ doesFileExist "missing.txt" + exists `shouldBe` False + + it "doesFileExist returns True after write" $ do + let (exists, _) = runPure emptyFS $ do + writeFileText "test.txt" "data" + doesFileExist "test.txt" + exists `shouldBe` True + + it "copyFile copies content" $ do + let initial = PureFS (Map.singleton "src.txt" "source content") Set.empty + (content, _) = runPure initial $ do + copyFile "src.txt" "dest.txt" + readFileText "dest.txt" + content `shouldBe` "source content" + + it "createDirectoryIfMissing creates a directory" $ do + let (exists, _) = runPure emptyFS $ do + createDirectoryIfMissing True "my/dir" + doesDirectoryExist "my/dir" + exists `shouldBe` True + + it "createDirectoryIfMissing is idempotent" $ do + let (exists, _) = runPure emptyFS $ do + createDirectoryIfMissing True "my/dir" + createDirectoryIfMissing True "my/dir" + doesDirectoryExist "my/dir" + exists `shouldBe` True + + it "overwrite replaces content" $ do + let (content, _) = runPure emptyFS $ do + writeFileText "file.txt" "first" + writeFileText "file.txt" "second" + readFileText "file.txt" + content `shouldBe` "second" + + it "returns final filesystem state" $ do + let (_, fs) = runPure emptyFS $ do + writeFileText "a.txt" "aaa" + writeFileText "b.txt" "bbb" + Map.size fs.files `shouldBe` 2 + + it "getCurrentDirectory returns /pure-fs" $ do + let (cwd, _) = runPure emptyFS getCurrentDirectory + cwd `shouldBe` "/pure-fs" + + describe "real interpreter" $ do + it "writes and reads a file" $ do + content <- runReal $ \tmpDir -> do + let path = tmpDir "hello.txt" + writeFileText path "hello world" + readFileText path + content `shouldBe` "hello world" + + it "doesFileExist returns True after write" $ do + exists <- runReal $ \tmpDir -> do + let path = tmpDir "test.txt" + writeFileText path "data" + doesFileExist path + exists `shouldBe` True + + it "doesFileExist returns False for nonexistent file" $ do + exists <- runReal $ \tmpDir -> do + doesFileExist (tmpDir "nope.txt") + exists `shouldBe` False + + it "createDirectoryIfMissing creates nested directories" $ do + exists <- runReal $ \tmpDir -> do + let dirPath = tmpDir "a" "b" "c" + createDirectoryIfMissing True dirPath + doesDirectoryExist dirPath + exists `shouldBe` True + + it "copyFile copies content" $ do + content <- runReal $ \tmpDir -> do + let src = tmpDir "src.txt" + dest = tmpDir "dest.txt" + writeFileText src "copy me" + copyFile src dest + readFileText dest + content `shouldBe` "copy me" + + it "removeDirectoryIfEmpty removes an empty directory" $ do + exists <- runReal $ \tmpDir -> do + let dir = tmpDir "empty" + createDirectoryIfMissing True dir + removeDirectoryIfEmpty dir + doesDirectoryExist dir + exists `shouldBe` False + + it "removeDirectoryIfEmpty leaves a non-empty directory alone" $ do + exists <- runReal $ \tmpDir -> do + let dir = tmpDir "non-empty" + createDirectoryIfMissing True dir + writeFileText (dir "keep.txt") "." + removeDirectoryIfEmpty dir + doesDirectoryExist dir + exists `shouldBe` True + + it "removeDirectoryIfEmpty is a no-op when the directory is missing" $ do + -- Regression test: a migration chain that mixes MoveFile with a + -- RunCommand 'rm -rf ' previously crashed here because + -- cleanupEmptyDirs revisits the source's parents after the + -- shell step has already removed them. + exists <- runReal $ \tmpDir -> do + let dir = tmpDir "never-existed" + removeDirectoryIfEmpty dir + doesDirectoryExist dir + exists `shouldBe` False diff --git a/test/Seihou/Effect/LoggerSpec.hs b/test/Seihou/Effect/LoggerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Effect/LoggerSpec.hs @@ -0,0 +1,67 @@ +module Seihou.Effect.LoggerSpec (tests) where + +import Effectful +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (logDebug, logError, logInfo, logWarn) +import Seihou.Effect.LoggerInterp (shouldLog) +import Seihou.Effect.LoggerPure (LoggerState (..), runLoggerPure) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Effect.Logger" spec + +spec :: Spec +spec = do + describe "runLoggerPure" $ do + it "captures all four log levels in separate fields" $ do + let ((), st) = runPureEff $ runLoggerPure $ do + logDebug "d1" + logInfo "i1" + logWarn "w1" + logError "e1" + st.logDebugMsgs `shouldBe` ["d1"] + st.logInfoMsgs `shouldBe` ["i1"] + st.logWarnMsgs `shouldBe` ["w1"] + st.logErrorMsgs `shouldBe` ["e1"] + + it "preserves message order within each field" $ do + let ((), st) = runPureEff $ runLoggerPure $ do + logInfo "first" + logInfo "second" + logInfo "third" + logDebug "a" + logDebug "b" + st.logInfoMsgs `shouldBe` ["first", "second", "third"] + st.logDebugMsgs `shouldBe` ["a", "b"] + + it "produces empty state when no messages are logged" $ do + let ((), st) = runPureEff $ runLoggerPure $ pure () + st.logDebugMsgs `shouldBe` [] + st.logInfoMsgs `shouldBe` [] + st.logWarnMsgs `shouldBe` [] + st.logErrorMsgs `shouldBe` [] + + it "returns the computation result alongside state" $ do + let (result, st) = runPureEff $ runLoggerPure $ do + logInfo "hello" + pure (42 :: Int) + result `shouldBe` 42 + st.logInfoMsgs `shouldBe` ["hello"] + + describe "shouldLog" $ do + it "LogVerbose configured shows all levels" $ do + shouldLog LogVerbose LogVerbose `shouldBe` True + shouldLog LogVerbose LogNormal `shouldBe` True + shouldLog LogVerbose LogQuiet `shouldBe` True + + it "LogNormal configured shows Normal and Quiet" $ do + shouldLog LogNormal LogVerbose `shouldBe` False + shouldLog LogNormal LogNormal `shouldBe` True + shouldLog LogNormal LogQuiet `shouldBe` True + + it "LogQuiet configured shows only Quiet" $ do + shouldLog LogQuiet LogVerbose `shouldBe` False + shouldLog LogQuiet LogNormal `shouldBe` False + shouldLog LogQuiet LogQuiet `shouldBe` True diff --git a/test/Seihou/Effect/ManifestStoreSpec.hs b/test/Seihou/Effect/ManifestStoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Effect/ManifestStoreSpec.hs @@ -0,0 +1,138 @@ +module Seihou.Effect.ManifestStoreSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Types +import Seihou.Effect.Filesystem (readFileText) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Effect.ManifestStorePure (runManifestStorePure) +import Seihou.Manifest.Types (emptyManifest) +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Effect.ManifestStore" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +sampleManifest :: Manifest +sampleManifest = + (emptyManifest fixedTime) + { modules = + [ AppliedModule (ModuleName "haskell-base") emptyParentVars "/path/to/mod" Nothing fixedTime Nothing + ], + vars = Map.fromList [(VarName "project.name", "my-app")], + files = + Map.fromList + [ ( "README.md", + FileRecord (SHA256 "abc123") (ModuleName "haskell-base") Template fixedTime + ) + ] + } + +spec :: Spec +spec = do + describe "pure interpreter" $ do + it "returns Right Nothing when no manifest stored" $ do + let (result, _) = runPureEff $ runManifestStorePure Nothing readManifest + result `shouldBe` Right Nothing + + it "returns Right (Just manifest) after write" $ do + let (result, _) = runPureEff $ runManifestStorePure Nothing $ do + writeManifest sampleManifest + readManifest + result `shouldBe` Right (Just sampleManifest) + + it "overwrites previous manifest" $ do + let m2 = emptyManifest fixedTime + (result, _) = runPureEff $ runManifestStorePure Nothing $ do + writeManifest sampleManifest + writeManifest m2 + readManifest + result `shouldBe` Right (Just m2) + + it "returns final state" $ do + let (_, finalState) = runPureEff $ runManifestStorePure Nothing $ do + writeManifest sampleManifest + finalState `shouldBe` Just sampleManifest + + describe "real interpreter (via pure filesystem)" $ do + it "returns Right Nothing when manifest file does not exist" $ do + let manifestPath = ".seihou/manifest.json" + (result, _) = + runPureEff $ + runFilesystemPure emptyFS $ + runManifestStore manifestPath readManifest + result `shouldBe` Right Nothing + + it "roundtrips a manifest through filesystem" $ do + let manifestPath = ".seihou/manifest.json" + (result, _) = + runPureEff $ + runFilesystemPure emptyFS $ + runManifestStore manifestPath $ do + writeManifest sampleManifest + readManifest + result `shouldBe` Right (Just sampleManifest) + + it "writes valid JSON to the filesystem" $ do + let manifestPath = ".seihou/manifest.json" + (((), content), _) = + runPureEff $ + runFilesystemPure emptyFS $ do + runManifestStore manifestPath (writeManifest sampleManifest) + c <- readFileText manifestPath + pure ((), c) + T.isInfixOf "\"version\":3" content `shouldBe` True + T.isInfixOf "haskell-base" content `shouldBe` True + T.isInfixOf "my-app" content `shouldBe` True + + it "renames the temp manifest away after a successful write" $ do + let manifestPath = ".seihou/manifest.json" + (_, finalFS) = + runPureEff $ + runFilesystemPure emptyFS $ + runManifestStore manifestPath (writeManifest sampleManifest) + Map.member manifestPath finalFS.files `shouldBe` True + Map.member (manifestPath <> ".tmp") finalFS.files `shouldBe` False + Set.member ".seihou" finalFS.dirs `shouldBe` True + + it "returns Left for corrupt JSON" $ do + let manifestPath = ".seihou/manifest.json" + corruptFS = PureFS (Map.fromList [(manifestPath, "{ this is not json }")]) Set.empty + (result, _) = + runPureEff $ + runFilesystemPure corruptFS $ + runManifestStore manifestPath readManifest + case result of + Left _err -> pure () -- Any Left is correct for corrupt JSON + Right _ -> expectationFailure "Expected Left for corrupt JSON" + + describe "real filesystem interpreter" $ do + it "writes valid JSON atomically and leaves no temp file" $ do + withSystemTempDirectory "seihou-manifest-store" $ \tmpDir -> do + let manifestPath = tmpDir ".seihou" "manifest.json" + tmpPath = manifestPath <> ".tmp" + runEff $ + runFilesystem $ + runManifestStore manifestPath (writeManifest sampleManifest) + finalExists <- doesFileExist manifestPath + tempExists <- doesFileExist tmpPath + finalExists `shouldBe` True + tempExists `shouldBe` False + result <- + runEff $ + runFilesystem $ + runManifestStore manifestPath readManifest + result `shouldBe` Right (Just sampleManifest) diff --git a/test/Seihou/Engine/ConflictSpec.hs b/test/Seihou/Engine/ConflictSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/ConflictSpec.hs @@ -0,0 +1,167 @@ +module Seihou.Engine.ConflictSpec (tests) where + +import Data.Text qualified as T +import Effectful +import Seihou.Core.Types +import Seihou.Effect.ConsolePure (ConsoleState (..), runConsolePure, runConsolePureNonInteractive) +import Seihou.Engine.Conflict (resolveConflicts, resolveConflictsInteractive) +import Seihou.Manifest.Hash (hashContent) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Conflict" spec + +-- | Helper to make a ConflictFile with realistic hashes. +mkConflict :: FilePath -> ConflictFile +mkConflict path = + ConflictFile + { path = path, + moduleName = ModuleName "test-module", + manifestHash = hashContent "original content", + diskHash = hashContent "user edited content", + planContent = "new generated content" + } + +spec :: Spec +spec = do + describe "resolveConflicts" $ do + it "returns Just [] for empty conflict list" $ do + let (result, _st) = runPureEff $ runConsolePure [] $ resolveConflicts False [] + result `shouldBe` Just [] + + it "returns Just [] for empty conflict list with force" $ do + let (result, _st) = runPureEff $ runConsolePure [] $ resolveConflicts True [] + result `shouldBe` Just [] + + it "returns all AcceptNew when force is True" $ do + let conflicts = [mkConflict "a.txt", mkConflict "b.txt", mkConflict "c.txt"] + (result, _st) = runPureEff $ runConsolePure [] $ resolveConflicts True conflicts + case result of + Just resolved -> do + length resolved `shouldBe` 3 + all (\(_, r) -> r == AcceptNew) resolved `shouldBe` True + Nothing -> expectationFailure "Expected Just, got Nothing" + + it "returns Nothing in non-interactive mode without force" $ do + let conflicts = [mkConflict "a.txt"] + (result, _st) = runPureEff $ runConsolePureNonInteractive $ resolveConflicts False conflicts + result `shouldBe` Nothing + + it "does not produce console output when force is True" $ do + let conflicts = [mkConflict "a.txt"] + (_result, st) = runPureEff $ runConsolePure [] $ resolveConflicts True conflicts + st.consoleOutputs `shouldBe` [] + + describe "resolveConflictsInteractive" $ do + it "resolves accept with 'a'" $ do + let conflict = mkConflict "readme.md" + (result, _st) = runPureEff $ runConsolePure ["a"] $ resolveConflictsInteractive [conflict] + case result of + Just [(_, res)] -> res `shouldBe` AcceptNew + _ -> expectationFailure "Expected Just with one AcceptNew resolution" + + it "resolves keep with 'k'" $ do + let conflict = mkConflict "readme.md" + (result, _st) = runPureEff $ runConsolePure ["k"] $ resolveConflictsInteractive [conflict] + case result of + Just [(_, res)] -> res `shouldBe` KeepCurrent + _ -> expectationFailure "Expected Just with one KeepCurrent resolution" + + it "resolves skip with 's'" $ do + let conflict = mkConflict "readme.md" + (result, _st) = runPureEff $ runConsolePure ["s"] $ resolveConflictsInteractive [conflict] + case result of + Just [(_, res)] -> res `shouldBe` Skip + _ -> expectationFailure "Expected Just with one Skip resolution" + + it "returns Nothing on abort with 'A'" $ do + let conflicts = [mkConflict "a.txt", mkConflict "b.txt"] + (result, _st) = runPureEff $ runConsolePure ["A"] $ resolveConflictsInteractive conflicts + result `shouldBe` Nothing + + it "re-prompts on invalid input then accepts valid input" $ do + let conflict = mkConflict "readme.md" + (result, st) = runPureEff $ runConsolePure ["x", "a"] $ resolveConflictsInteractive [conflict] + case result of + Just [(_, res)] -> res `shouldBe` AcceptNew + _ -> expectationFailure "Expected Just with one AcceptNew resolution" + any (T.isInfixOf "Invalid choice") (st.consoleOutputs) `shouldBe` True + + it "resolves multiple files in order" $ do + let conflicts = [mkConflict "a.txt", mkConflict "b.txt", mkConflict "c.txt"] + (result, _st) = runPureEff $ runConsolePure ["a", "k", "s"] $ resolveConflictsInteractive conflicts + case result of + Just resolved -> do + length resolved `shouldBe` 3 + map snd resolved `shouldBe` [AcceptNew, KeepCurrent, Skip] + map ((.path) . fst) resolved `shouldBe` ["a.txt", "b.txt", "c.txt"] + Nothing -> expectationFailure "Expected Just, got Nothing" + + it "abort on second file stops prompting" $ do + let conflicts = [mkConflict "a.txt", mkConflict "b.txt", mkConflict "c.txt"] + (result, st) = runPureEff $ runConsolePure ["a", "A"] $ resolveConflictsInteractive conflicts + result `shouldBe` Nothing + -- Should have prompted for a.txt and b.txt, but not c.txt + let outputs = T.unlines (st.consoleOutputs) + T.isInfixOf "a.txt" outputs `shouldBe` True + T.isInfixOf "b.txt" outputs `shouldBe` True + T.isInfixOf "c.txt" outputs `shouldBe` False + + it "outputs file paths in prompt messages" $ do + let conflict = mkConflict "src/Main.hs" + (_result, st) = runPureEff $ runConsolePure ["a"] $ resolveConflictsInteractive [conflict] + outputs = T.unlines (st.consoleOutputs) + T.isInfixOf "src/Main.hs" outputs `shouldBe` True + T.isInfixOf "modified since last generation" outputs `shouldBe` True + + it "accepts full word inputs" $ do + let conflicts = [mkConflict "a.txt", mkConflict "b.txt", mkConflict "c.txt", mkConflict "d.txt"] + (result, _st) = runPureEff $ runConsolePure ["accept", "keep", "skip", "abort"] $ resolveConflictsInteractive conflicts + -- abort on d.txt → Nothing + result `shouldBe` Nothing + + describe "resolveConflicts integration" $ do + it "dispatches to interactive prompts when interactive and not force" $ do + let conflicts = [mkConflict "config.yaml", mkConflict "Makefile"] + (result, st) = runPureEff $ runConsolePure ["k", "a"] $ resolveConflicts False conflicts + case result of + Just resolved -> do + map snd resolved `shouldBe` [KeepCurrent, AcceptNew] + Nothing -> expectationFailure "Expected Just, got Nothing" + -- Verify prompt output was produced + let outputs = T.unlines (st.consoleOutputs) + T.isInfixOf "config.yaml" outputs `shouldBe` True + T.isInfixOf "Makefile" outputs `shouldBe` True + + it "non-interactive mode produces no console output" $ do + let conflicts = [mkConflict "a.txt"] + (_result, st) = runPureEff $ runConsolePureNonInteractive $ resolveConflicts False conflicts + st.consoleOutputs `shouldBe` [] + + it "force mode preserves conflict file references in resolution" $ do + let c = mkConflict "important.txt" + (result, _st) = runPureEff $ runConsolePure [] $ resolveConflicts True [c] + case result of + Just [(resolved_c, AcceptNew)] -> + resolved_c.path `shouldBe` "important.txt" + _ -> expectationFailure "Expected Just with AcceptNew for important.txt" + + it "interactive abort via resolveConflicts returns Nothing" $ do + let conflicts = [mkConflict "first.txt", mkConflict "second.txt"] + (result, st) = runPureEff $ runConsolePure ["A"] $ resolveConflicts False conflicts + result `shouldBe` Nothing + -- Only first.txt was prompted before abort + let outputs = T.unlines (st.consoleOutputs) + T.isInfixOf "first.txt" outputs `shouldBe` True + T.isInfixOf "second.txt" outputs `shouldBe` False + + it "choice prompt text includes all four options" $ do + let conflict = mkConflict "test.txt" + (_result, st) = runPureEff $ runConsolePure ["s"] $ resolveConflicts False [conflict] + outputs = T.unlines (st.consoleOutputs) + T.isInfixOf "[a]ccept" outputs `shouldBe` True + T.isInfixOf "[k]eep" outputs `shouldBe` True + T.isInfixOf "[s]kip" outputs `shouldBe` True + T.isInfixOf "[A]bort" outputs `shouldBe` True diff --git a/test/Seihou/Engine/DiffSpec.hs b/test/Seihou/Engine/DiffSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/DiffSpec.hs @@ -0,0 +1,314 @@ +module Seihou.Engine.DiffSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Types +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import Seihou.Engine.Diff (computeDiff) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (emptyManifest) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Diff" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +modName :: ModuleName +modName = ModuleName "test-module" + +-- | Run diff computation in pure filesystem. +runDiff :: PureFS -> Manifest -> Set ModuleName -> [(FilePath, Text, ModuleName, Maybe PatchOp)] -> DiffResult +runDiff fs manifest activeModules planned = + fst $ runPureEff $ runFilesystemPure fs $ computeDiff manifest activeModules planned + +-- | Helper to make a FileRecord from content. +mkRecord :: Text -> FileRecord +mkRecord content = + FileRecord + { hash = hashContent content, + moduleName = modName, + strategy = Template, + generatedAt = fixedTime + } + +-- | Helper to create a manifest with file records (avoids ambiguous record update). +manifestWithFiles :: Map.Map FilePath FileRecord -> Manifest +manifestWithFiles recs = + let base = emptyManifest fixedTime + in Manifest + { version = base.version, + genAt = base.genAt, + modules = base.modules, + vars = base.vars, + files = recs + } + +spec :: Spec +spec = do + let active = Set.singleton modName + + describe "computeDiff" $ do + it "classifies file in plan only (not on disk) as New" $ do + let manifest = emptyManifest fixedTime + planned = [("README.md", "# Hello", modName, Nothing)] + result = runDiff emptyFS manifest active planned + length (result.new) `shouldBe` 1 + (head result.new).path `shouldBe` "README.md" + + it "classifies file in plan + on disk (not in manifest) as Conflict" $ do + let manifest = emptyManifest fixedTime + planned = [("README.md", "# Hello", modName, Nothing)] + fs = PureFS (Map.singleton "README.md" "existing content") mempty + result = runDiff fs manifest active planned + length (result.conflicts) `shouldBe` 1 + (head result.conflicts).path `shouldBe` "README.md" + + it "classifies patch op on existing file (not in manifest) as New, not Conflict" $ do + let manifest = emptyManifest fixedTime + planned = [(".gitignore", ".claude/\n", modName, Just AppendSection)] + fs = PureFS (Map.singleton ".gitignore" ".seihou/\n") mempty + result = runDiff fs manifest active planned + length (result.conflicts) `shouldBe` 0 + length (result.new) `shouldBe` 1 + (head result.new).path `shouldBe` ".gitignore" + + it "classifies patch op on user-modified file (in manifest) as Modified, not Conflict" $ do + let originalContent = "original" + userContent = "user edited" + patchContent = "new section" + manifest = manifestWithFiles (Map.singleton "config.txt" (mkRecord originalContent)) + planned = [("config.txt", patchContent, modName, Just AppendSection)] + fs = PureFS (Map.singleton "config.txt" userContent) mempty + result = runDiff fs manifest active planned + length (result.conflicts) `shouldBe` 0 + length (result.modified) `shouldBe` 1 + (head result.modified).path `shouldBe` "config.txt" + + it "classifies file in manifest + plan + disk (unchanged) as Unchanged" $ do + let content = "# Hello World" + manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord content)) + planned = [("README.md", content, modName, Nothing)] + fs = PureFS (Map.singleton "README.md" content) mempty + result = runDiff fs manifest active planned + length (result.unchanged) `shouldBe` 1 + head (result.unchanged) `shouldBe` "README.md" + + it "classifies file in manifest + plan + disk (plan changed) as Modified" $ do + let oldContent = "# Hello" + newContent = "# Hello World" + manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord oldContent)) + planned = [("README.md", newContent, modName, Nothing)] + -- Disk matches manifest (user didn't touch it) + fs = PureFS (Map.singleton "README.md" oldContent) mempty + result = runDiff fs manifest active planned + length (result.modified) `shouldBe` 1 + (head result.modified).path `shouldBe` "README.md" + (head result.modified).newContent `shouldBe` newContent + + it "classifies file in manifest + plan + disk (user modified) as Conflict" $ do + let originalContent = "# Hello" + userContent = "# Hello - edited by user" + planContent = "# Hello World" + manifest = manifestWithFiles (Map.singleton "README.md" (mkRecord originalContent)) + planned = [("README.md", planContent, modName, Nothing)] + -- Disk was modified by user (doesn't match manifest) + fs = PureFS (Map.singleton "README.md" userContent) mempty + result = runDiff fs manifest active planned + length (result.conflicts) `shouldBe` 1 + (head result.conflicts).path `shouldBe` "README.md" + (head result.conflicts).planContent `shouldBe` planContent + + it "classifies file in manifest only (on disk) as Orphaned" $ do + let content = "orphaned content" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = Map.singleton "old-file.txt" (mkRecord content) + } + planned = [] :: [(FilePath, Text, ModuleName, Maybe PatchOp)] -- module no longer produces this file + fs = PureFS (Map.singleton "old-file.txt" content) mempty + result = runDiff fs manifest active planned + length (result.orphaned) `shouldBe` 1 + (head result.orphaned).path `shouldBe` "old-file.txt" + + it "classifies file in manifest only (not on disk) as Orphaned" $ do + let content = "deleted content" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = Map.singleton "deleted.txt" (mkRecord content) + } + planned = [] :: [(FilePath, Text, ModuleName, Maybe PatchOp)] + result = runDiff emptyFS manifest active planned + length (result.orphaned) `shouldBe` 1 + (head result.orphaned).path `shouldBe` "deleted.txt" + + it "classifies file in manifest + plan (deleted from disk) as Modified" $ do + let content = "recreate me" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = Map.singleton "gone.txt" (mkRecord content) + } + planned = [("gone.txt", "new version", modName, Nothing)] + result = runDiff emptyFS manifest active planned + length (result.modified) `shouldBe` 1 + (head result.modified).path `shouldBe` "gone.txt" + + it "handles mixed classifications" $ do + let existingContent = "existing" + manifest = + (emptyManifest fixedTime :: Manifest) + { files = + Map.fromList + [ ("unchanged.txt", mkRecord existingContent), + ("orphaned.txt", mkRecord "orphan") + ] + } + planned = + [ ("unchanged.txt", existingContent, modName, Nothing), + ("new-file.txt", "brand new", modName, Nothing) + ] + fs = + PureFS + (Map.fromList [("unchanged.txt", existingContent), ("orphaned.txt", "orphan")]) + mempty + result = runDiff fs manifest active planned + length (result.new) `shouldBe` 1 + length (result.unchanged) `shouldBe` 1 + length (result.orphaned) `shouldBe` 1 + length (result.modified) `shouldBe` 0 + length (result.conflicts) `shouldBe` 0 + + it "handles empty manifest and empty plan" $ do + let manifest = emptyManifest fixedTime + result = runDiff emptyFS manifest Set.empty ([] :: [(FilePath, Text, ModuleName, Maybe PatchOp)]) + result.new `shouldBe` [] + result.modified `shouldBe` [] + result.unchanged `shouldBe` [] + result.conflicts `shouldBe` [] + result.orphaned `shouldBe` [] + + it "does not classify files from inactive modules as orphaned" $ do + let otherMod = ModuleName "other-module" + content = "from other module" + record = + FileRecord + { hash = hashContent content, + moduleName = otherMod, + strategy = Template, + generatedAt = fixedTime + } + manifest = manifestWithFiles (Map.singleton "other.txt" record) + planned = [("new.txt", "new content", modName, Nothing)] + activeModules = Set.singleton modName -- "test-module", NOT "other-module" + fs = PureFS (Map.singleton "other.txt" content) mempty + result = runDiff fs manifest activeModules planned + length (result.orphaned) `shouldBe` 0 + length (result.new) `shouldBe` 1 + + it "classifies files from active modules as orphaned" $ do + let content = "active module content" + manifest = manifestWithFiles (Map.singleton "old.txt" (mkRecord content)) + planned = [("new.txt", "new content", modName, Nothing)] + activeModules = Set.singleton modName -- file belongs to active module + fs = PureFS (Map.singleton "old.txt" content) mempty + result = runDiff fs manifest activeModules planned + length (result.orphaned) `shouldBe` 1 + (head result.orphaned).path `shouldBe` "old.txt" + + it "mixed active/inactive: only orphans active module's missing files" $ do + let otherMod = ModuleName "other-module" + otherRecord = + FileRecord + { hash = hashContent "other content", + moduleName = otherMod, + strategy = Copy, + generatedAt = fixedTime + } + manifest = + manifestWithFiles + ( Map.fromList + [ ("active-old.txt", mkRecord "active old"), + ("other.txt", otherRecord) + ] + ) + -- active module now produces a different file, dropping active-old.txt + planned = [("active-new.txt", "active new", modName, Nothing)] + activeModules = Set.singleton modName + fs = + PureFS + (Map.fromList [("active-old.txt", "active old"), ("other.txt", "other content")]) + mempty + result = runDiff fs manifest activeModules planned + -- active-old.txt is orphaned (active module no longer produces it) + length (result.orphaned) `shouldBe` 1 + (head result.orphaned).path `shouldBe` "active-old.txt" + -- other.txt is invisible (inactive module), not orphaned + length (result.new) `shouldBe` 1 + (head result.new).path `shouldBe` "active-new.txt" + + it "plan targeting inactive module's file on disk is classified as Conflict" $ do + let otherMod = ModuleName "other-module" + otherRecord = + FileRecord + { hash = hashContent "other content", + moduleName = otherMod, + strategy = Template, + generatedAt = fixedTime + } + manifest = manifestWithFiles (Map.singleton "shared.txt" otherRecord) + -- active module wants to write to same path owned by inactive module + planned = [("shared.txt", "new content from active", modName, Nothing)] + activeModules = Set.singleton modName + fs = PureFS (Map.singleton "shared.txt" "other content") mempty + result = runDiff fs manifest activeModules planned + -- File exists on disk but not in active manifest → Conflict + length (result.conflicts) `shouldBe` 1 + (head result.conflicts).path `shouldBe` "shared.txt" + + it "handles multiple active modules scoping independently" $ do + let modA = ModuleName "module-a" + modB = ModuleName "module-b" + modC = ModuleName "module-c" + mkRec m content = + FileRecord + { hash = hashContent content, + moduleName = m, + strategy = Template, + generatedAt = fixedTime + } + manifest = + manifestWithFiles + ( Map.fromList + [ ("from-a.txt", mkRec modA "a content"), + ("from-b.txt", mkRec modB "b content"), + ("from-c.txt", mkRec modC "c content") + ] + ) + -- Running modules A and B (not C); A still produces its file, B drops its file + planned = [("from-a.txt", "a content", modA, Nothing)] + activeModules = Set.fromList [modA, modB] + fs = + PureFS + ( Map.fromList + [ ("from-a.txt", "a content"), + ("from-b.txt", "b content"), + ("from-c.txt", "c content") + ] + ) + mempty + result = runDiff fs manifest activeModules planned + -- from-a.txt unchanged (active, still produced) + length (result.unchanged) `shouldBe` 1 + -- from-b.txt orphaned (active module B no longer produces it) + length (result.orphaned) `shouldBe` 1 + (head result.orphaned).path `shouldBe` "from-b.txt" + -- from-c.txt invisible (inactive module C) + length (result.new) `shouldBe` 0 + length (result.conflicts) `shouldBe` 0 diff --git a/test/Seihou/Engine/ExecuteSpec.hs b/test/Seihou/Engine/ExecuteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/ExecuteSpec.hs @@ -0,0 +1,208 @@ +module Seihou.Engine.ExecuteSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Types +import Seihou.Effect.Filesystem (doesDirectoryExist, doesFileExist, readFileText) +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import Seihou.Engine.Execute (dryRunPlan, executePlan) +import Seihou.Manifest.Hash (hashContent) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Execute" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +modName :: ModuleName +modName = ModuleName "test-module" + +-- | Run execution in pure filesystem and return results + final FS state. +runExec :: [Operation] -> ((Map.Map FilePath FileRecord, PureFS), PureFS) +runExec ops = + runPureEff $ + runFilesystemPure emptyFS $ do + records <- executePlan "/project" ops Map.empty modName fixedTime + fs <- pure () -- just to get the final state via the tuple + pure (records, emptyFS) -- placeholder; actual FS state is in the outer tuple + +-- | More useful helper: run and return records + the pure FS state. +runExecFS :: PureFS -> [Operation] -> (Map.Map FilePath FileRecord, PureFS) +runExecFS initial ops = + runPureEff $ + runFilesystemPure initial $ + executePlan "/project" ops Map.empty modName fixedTime + +spec :: Spec +spec = do + describe "executePlan" $ do + it "writes a file via WriteFileOp" $ do + let ops = [WriteFileOp "hello.txt" "hello world" Template] + (records, fs) = runExecFS emptyFS ops + Map.member "hello.txt" records `shouldBe` True + Map.lookup "/project/hello.txt" (fs.files) `shouldBe` Just "hello world" + + it "creates a directory via CreateDirOp" $ do + let ops = [CreateDirOp "src"] + ((exists, _), _) = + runPureEff $ + runFilesystemPure emptyFS $ do + _ <- executePlan "/project" ops Map.empty modName fixedTime + e <- doesDirectoryExist "/project/src" + pure (e, ()) + exists `shouldBe` True + + it "produces FileRecord with correct hash" $ do + let content = "test content" + ops = [WriteFileOp "test.txt" content Template] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.txt" + record.hash `shouldBe` hashContent content + + it "produces FileRecord with correct module name" $ do + let ops = [WriteFileOp "test.txt" "data" Template] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.txt" + record.moduleName `shouldBe` modName + + it "produces FileRecord with correct timestamp" $ do + let ops = [WriteFileOp "test.txt" "data" Template] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.txt" + record.generatedAt `shouldBe` fixedTime + + it "handles multiple operations" $ do + let ops = + [ CreateDirOp "src", + WriteFileOp "README.md" "# Hello" Template, + WriteFileOp "src/Main.hs" "module Main where" Template + ] + (records, fs) = runExecFS emptyFS ops + Map.size records `shouldBe` 2 + Map.lookup "/project/README.md" (fs.files) `shouldBe` Just "# Hello" + Map.lookup "/project/src/Main.hs" (fs.files) `shouldBe` Just "module Main where" + + it "skips RunCommandOp" $ do + let ops = [RunCommandOp "echo hello" Nothing] + (records, _) = runExecFS emptyFS ops + Map.size records `shouldBe` 0 + + it "handles CopyFileOp by reading source and writing dest" $ do + let initial = PureFS (Map.singleton "/source/file.txt" "copied content") mempty + ops = [CopyFileOp "/source/file.txt" "dest.txt"] + (records, fs) = runExecFS initial ops + Map.member "dest.txt" records `shouldBe` True + Map.lookup "/project/dest.txt" (fs.files) `shouldBe` Just "copied content" + + it "records Template strategy in FileRecord" $ do + let ops = [WriteFileOp "test.txt" "content" Template] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.txt" + record.strategy `shouldBe` Template + + it "records Copy strategy in FileRecord" $ do + let ops = [WriteFileOp "test.txt" "content" Copy] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.txt" + record.strategy `shouldBe` Copy + + it "records DhallText strategy in FileRecord" $ do + let ops = [WriteFileOp "test.txt" "content" DhallText] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.txt" + record.strategy `shouldBe` DhallText + + it "records Structured strategy in FileRecord" $ do + let ops = [WriteFileOp "test.json" "{}" Structured] + (records, _) = runExecFS emptyFS ops + record = records Map.! "test.json" + record.strategy `shouldBe` Structured + + it "executes PatchFileOp AppendFile on existing file" $ do + let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty + ops = [PatchFileOp "README.md" "extra line\n" AppendFile Template modName] + (records, fs) = runExecFS initial ops + Map.member "README.md" records `shouldBe` True + let content = fs.files Map.! "/project/README.md" + T.isInfixOf "# Title" content `shouldBe` True + T.isInfixOf "extra line" content `shouldBe` True + + it "executes PatchFileOp PrependFile on existing file" $ do + let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty + ops = [PatchFileOp "README.md" "header\n" PrependFile Template modName] + (records, fs) = runExecFS initial ops + Map.member "README.md" records `shouldBe` True + let content = fs.files Map.! "/project/README.md" + T.isInfixOf "header" content `shouldBe` True + T.isInfixOf "# Title" content `shouldBe` True + + it "executes PatchFileOp AppendSection with section markers" $ do + let initial = PureFS (Map.singleton "/project/README.md" "# Title\n") mempty + ops = [PatchFileOp "README.md" "section content\n" AppendSection Template modName] + (records, fs) = runExecFS initial ops + Map.member "README.md" records `shouldBe` True + let content = fs.files Map.! "/project/README.md" + T.isInfixOf "# Title" content `shouldBe` True + T.isInfixOf "seihou:test-module" content `shouldBe` True + T.isInfixOf "section content" content `shouldBe` True + + it "executes PatchFileOp on nonexistent file (creates from empty)" $ do + let ops = [PatchFileOp "new.txt" "new content\n" AppendFile Template modName] + (records, fs) = runExecFS emptyFS ops + Map.member "new.txt" records `shouldBe` True + let content = fs.files Map.! "/project/new.txt" + T.isInfixOf "new content" content `shouldBe` True + + it "executes PatchFileOp AppendLineIfAbsent, skipping existing lines" $ do + let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.env\n") mempty + ops = [PatchFileOp ".gitignore" ".env\n.claude/\n" AppendLineIfAbsent Template modName] + (records, fs) = runExecFS initial ops + Map.member ".gitignore" records `shouldBe` True + let content = fs.files Map.! "/project/.gitignore" + content `shouldBe` "node_modules/\n.env\n.claude/\n" + + it "executes PatchFileOp AppendLineIfAbsent idempotently" $ do + let initial = PureFS (Map.singleton "/project/.gitignore" "node_modules/\n.claude/\n") mempty + ops = [PatchFileOp ".gitignore" ".claude/\n" AppendLineIfAbsent Template modName] + (records, fs) = runExecFS initial ops + Map.member ".gitignore" records `shouldBe` True + let content = fs.files Map.! "/project/.gitignore" + content `shouldBe` "node_modules/\n.claude/\n" + + describe "dryRunPlan" $ do + it "formats WriteFileOp" $ do + let result = dryRunPlan [WriteFileOp "README.md" "content" Template] + T.isInfixOf "write" result `shouldBe` True + T.isInfixOf "README.md" result `shouldBe` True + + it "formats CreateDirOp" $ do + let result = dryRunPlan [CreateDirOp "src"] + T.isInfixOf "mkdir" result `shouldBe` True + T.isInfixOf "src" result `shouldBe` True + + it "formats CopyFileOp" $ do + let result = dryRunPlan [CopyFileOp "src.txt" "dest.txt"] + T.isInfixOf "copy" result `shouldBe` True + + it "formats RunCommandOp" $ do + let result = dryRunPlan [RunCommandOp "echo hello" Nothing] + T.isInfixOf "run" result `shouldBe` True + + it "returns message for empty plan" $ do + let result = dryRunPlan [] + T.isInfixOf "No operations" result `shouldBe` True + + it "formats PatchFileOp" $ do + let result = dryRunPlan [PatchFileOp "README.md" "content" AppendSection Template (ModuleName "nix-flake")] + T.isInfixOf "patch" result `shouldBe` True + T.isInfixOf "README.md" result `shouldBe` True + T.isInfixOf "nix-flake" result `shouldBe` True + + it "does not include file content" $ do + let result = dryRunPlan [WriteFileOp "secret.txt" "super secret" Template] + T.isInfixOf "super secret" result `shouldBe` False diff --git a/test/Seihou/Engine/MigrateSpec.hs b/test/Seihou/Engine/MigrateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/MigrateSpec.hs @@ -0,0 +1,286 @@ +module Seihou.Engine.MigrateSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Migration + ( Migration (..), + MigrationOp (..), + MigrationPlan (..), + ) +import Seihou.Core.Types +import Seihou.Core.Version (Version, parseVersion) +import Seihou.Effect.FilesystemPure (PureFS (..), runFilesystemPure) +import Seihou.Effect.ProcessPure (runProcessPure) +import Seihou.Engine.Migrate + ( ExecutedMigrationPlan (..), + MigrationExecError (..), + MigrationFileStatus (..), + MigrationOpInstance (..), + classifyMigration, + executeMigration, + ) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (emptyManifest) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Migrate" spec + +-- ---------------------------------------------------------------------------- +-- Fixtures and helpers +-- ---------------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-04-01T10:00:00Z" + +migrateTime :: UTCTime +migrateTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-04-25T11:00:00Z" + +modName :: ModuleName +modName = ModuleName "demo" + +mkV :: Text -> Version +mkV t = case parseVersion t of + Just v -> v + Nothing -> error ("MigrateSpec.mkV: bad version " <> show t) + +-- | Build a manifest with the given files (path, content) all owned by +-- the demo module. The manifest hash is the SHA256 of the content, so +-- safe-vs-conflict can be exercised by mutating the on-disk content. +mkManifest :: [(FilePath, Text)] -> Manifest +mkManifest entries = + (emptyManifest fixedTime) + { modules = + [ AppliedModule + { name = modName, + parentVars = emptyParentVars, + source = "/installed/demo", + moduleVersion = Just "1.0.0", + appliedAt = fixedTime, + removal = Nothing + } + ], + files = + Map.fromList + [ ( path, + FileRecord + { hash = hashContent content, + moduleName = modName, + strategy = Template, + generatedAt = fixedTime + } + ) + | (path, content) <- entries + ] + } + +-- | Build an in-memory filesystem from (path, content) pairs. +mkFS :: [(FilePath, Text)] -> PureFS +mkFS entries = PureFS (Map.fromList entries) Set.empty + +-- | Single-step plan wrapping the supplied ops. +chain1 :: Text -> Text -> [MigrationOp] -> MigrationPlan +chain1 fromV toV ops = + MigrationPlan + { planModule = "demo", + planFrom = mkV fromV, + planTo = mkV toV, + planSteps = [Migration {from = fromV, to = toV, ops}] + } + +runClassifyResult :: PureFS -> Manifest -> MigrationPlan -> Either MigrationExecError ExecutedMigrationPlan +runClassifyResult fs manifest c = + fst $ + runPureEff $ + runFilesystemPure fs $ + classifyMigration manifest c + +runClassify :: PureFS -> Manifest -> MigrationPlan -> ExecutedMigrationPlan +runClassify fs manifest c = + case runClassifyResult fs manifest c of + Right plan -> plan + Left err -> error ("MigrateSpec.runClassify: unexpected error " <> show err) + +runExecute :: + PureFS -> + Manifest -> + ExecutedMigrationPlan -> + Bool -> + (Either MigrationExecError Manifest, PureFS) +runExecute fs manifest plan force = + runPureEff $ + runFilesystemPure fs $ + runProcessPure [] $ + executeMigration force plan manifest migrateTime + +-- ---------------------------------------------------------------------------- +-- Spec +-- ---------------------------------------------------------------------------- + +spec :: Spec +spec = do + describe "classifyMigration" $ do + it "marks a move-file safe when disk hash matches manifest" $ do + let manifest = mkManifest [("app/Main.hs", "module Main where")] + fs = mkFS [("app/Main.hs", "module Main where")] + c = chain1 "1.0.0" "2.0.0" [MoveFile "app/Main.hs" "src/Main.hs"] + plan = runClassify fs manifest c + plan.planOps `shouldBe` [MoveFileInst "app/Main.hs" "src/Main.hs" MFSafe] + + it "marks a move-file as conflict when disk content differs" $ do + let manifest = mkManifest [("app/Main.hs", "original")] + fs = mkFS [("app/Main.hs", "user-edited")] + c = chain1 "1.0.0" "2.0.0" [MoveFile "app/Main.hs" "src/Main.hs"] + plan = runClassify fs manifest c + plan.planOps `shouldBe` [MoveFileInst "app/Main.hs" "src/Main.hs" MFConflict] + + it "marks a delete-file as gone when the file is absent" $ do + let manifest = mkManifest [("Setup.hs", "boring")] + fs = mkFS [] -- file already deleted on disk + c = chain1 "1.0.0" "2.0.0" [DeleteFile "Setup.hs"] + plan = runClassify fs manifest c + plan.planOps `shouldBe` [DeleteFileInst "Setup.hs" MFGone] + + it "rejects a delete-dir path with a parent directory segment" $ do + let manifest = mkManifest [] + fs = mkFS [] + c = chain1 "1.0.0" "2.0.0" [DeleteDir "../outside"] + result = runClassifyResult fs manifest c + result `shouldBe` Left (MigrationUnsafePath "delete-dir path" "../outside" "path must not contain '..' segment: ../outside") + + it "rejects a move-file destination with a parent directory segment" $ do + let manifest = mkManifest [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + c = chain1 "1.0.0" "2.0.0" [MoveFile "README.md" "../outside"] + result = runClassifyResult fs manifest c + result `shouldBe` Left (MigrationUnsafePath "move-file destination" "../outside" "path must not contain '..' segment: ../outside") + + it "rejects a run-command workDir with a parent directory segment" $ do + let manifest = mkManifest [] + fs = mkFS [] + c = chain1 "1.0.0" "2.0.0" [RunCommand "echo unsafe" (Just "../outside")] + result = runClassifyResult fs manifest c + result `shouldBe` Left (MigrationUnsafePath "run-command workDir" "../outside" "path must not contain '..' segment: ../outside") + + describe "executeMigration" $ do + it "renames a single safe file and rewrites the manifest" $ do + let manifest = mkManifest [("app/Main.hs", "x")] + fs = mkFS [("app/Main.hs", "x")] + c = chain1 "1.0.0" "2.0.0" [MoveFile "app/Main.hs" "src/Main.hs"] + plan = runClassify fs manifest c + (result, fs') = runExecute fs manifest plan False + case result of + Right m -> do + Map.member "src/Main.hs" m.files `shouldBe` True + Map.member "app/Main.hs" m.files `shouldBe` False + (head m.modules).moduleVersion `shouldBe` Just "2.0.0" + Left err -> expectationFailure ("expected Right, got: " <> show err) + Map.member "src/Main.hs" fs'.files `shouldBe` True + Map.member "app/Main.hs" fs'.files `shouldBe` False + + it "refuses on conflict without --force and leaves disk untouched" $ do + let manifest = mkManifest [("app/Main.hs", "original")] + fs = mkFS [("app/Main.hs", "user-edited")] + c = chain1 "1.0.0" "2.0.0" [MoveFile "app/Main.hs" "src/Main.hs"] + plan = runClassify fs manifest c + (result, fs') = runExecute fs manifest plan False + result `shouldBe` Left (MigrationConflict ["app/Main.hs"]) + -- Disk untouched: original src still there, dest absent. + Map.member "app/Main.hs" fs'.files `shouldBe` True + Map.member "src/Main.hs" fs'.files `shouldBe` False + + it "executes through a conflict when force is set" $ do + let manifest = mkManifest [("app/Main.hs", "original")] + fs = mkFS [("app/Main.hs", "user-edited")] + c = chain1 "1.0.0" "2.0.0" [MoveFile "app/Main.hs" "src/Main.hs"] + plan = runClassify fs manifest c + (result, fs') = runExecute fs manifest plan True + case result of + Right m -> do + Map.member "src/Main.hs" m.files `shouldBe` True + Map.member "app/Main.hs" m.files `shouldBe` False + Left err -> expectationFailure ("expected Right, got: " <> show err) + -- The user-edited content rode along: the move is a key rename in + -- the pure FS, so the bytes follow the rename. + Map.lookup "src/Main.hs" fs'.files `shouldBe` Just "user-edited" + + it "moves a directory, rewriting all contained manifest entries" $ do + let manifest = + mkManifest + [ ("app/Main.hs", "main"), + ("app/Lib.hs", "lib") + ] + fs = + mkFS + [ ("app/Main.hs", "main"), + ("app/Lib.hs", "lib") + ] + c = chain1 "1.0.0" "2.0.0" [MoveDir "app" "src"] + plan = runClassify fs manifest c + (result, fs') = runExecute fs manifest plan False + case result of + Right m -> do + Map.keys m.files `shouldMatchList` ["src/Main.hs", "src/Lib.hs"] + Left err -> expectationFailure ("expected Right, got: " <> show err) + Map.keys fs'.files `shouldMatchList` ["src/Main.hs", "src/Lib.hs"] + + it "is a no-op for a delete-file whose target is already gone" $ do + let manifest = mkManifest [("Setup.hs", "boring")] + fs = mkFS [] -- absent on disk + c = chain1 "1.0.0" "2.0.0" [DeleteFile "Setup.hs"] + plan = runClassify fs manifest c + (result, fs') = runExecute fs manifest plan False + case result of + Right m -> Map.member "Setup.hs" m.files `shouldBe` False + Left err -> expectationFailure ("expected Right, got: " <> show err) + Map.null fs'.files `shouldBe` True + + it "deletes a directory and drops every manifest entry under it" $ do + let manifest = + mkManifest + [ ("legacy/a.hs", "a"), + ("legacy/sub/b.hs", "b"), + ("keep.hs", "k") + ] + fs = + mkFS + [ ("legacy/a.hs", "a"), + ("legacy/sub/b.hs", "b"), + ("keep.hs", "k") + ] + c = chain1 "1.0.0" "2.0.0" [DeleteDir "legacy"] + plan = runClassify fs manifest c + (result, fs') = runExecute fs manifest plan False + case result of + Right m -> Map.keys m.files `shouldBe` ["keep.hs"] + Left err -> expectationFailure ("expected Right, got: " <> show err) + Map.keys fs'.files `shouldBe` ["keep.hs"] + + it "applies a chain of two migrations in declaration order" $ do + -- 1.0.0 → 2.0.0: move app → src + -- 2.0.0 → 3.0.0: delete src/Main.hs + let manifest = mkManifest [("app/Main.hs", "x")] + fs = mkFS [("app/Main.hs", "x")] + chain = + MigrationPlan + { planModule = "demo", + planFrom = mkV "1.0.0", + planTo = mkV "3.0.0", + planSteps = + [ Migration "1.0.0" "2.0.0" [MoveDir "app" "src"], + Migration "2.0.0" "3.0.0" [DeleteFile "src/Main.hs"] + ] + } + plan = runClassify fs manifest chain + (result, fs') = runExecute fs manifest plan False + case result of + Right m -> do + Map.null m.files `shouldBe` True + (head m.modules).moduleVersion `shouldBe` Just "3.0.0" + Left err -> expectationFailure ("expected Right, got: " <> show err) + Map.null fs'.files `shouldBe` True diff --git a/test/Seihou/Engine/PlanSpec.hs b/test/Seihou/Engine/PlanSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/PlanSpec.hs @@ -0,0 +1,959 @@ +module Seihou.Engine.PlanSpec (tests) where + +import Data.Aeson qualified as Aeson +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Yaml qualified as Yaml +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Engine.Plan +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Plan" spec + +-- | Helper to create a temp fixture with files in a @files/@ subdirectory. +withFixture :: [(FilePath, String)] -> (FilePath -> IO a) -> IO a +withFixture files action = do + withSystemTempDirectory "seihou-plan-test" $ \tmpDir -> do + mapM_ (createFile tmpDir) files + action tmpDir + where + createFile base (path, content) = do + let full = base "files" path + dir = takeDir full + createDirectoryIfMissing True dir + writeFile full content + + takeDir = reverse . dropWhile (/= '/') . reverse + +spec :: Spec +spec = do + describe "parentDirs" $ do + it "returns empty for a file in the root" $ do + parentDirs "README.md" `shouldBe` [] + + it "returns one directory for a file one level deep" $ do + parentDirs "src/Lib.hs" `shouldBe` ["src"] + + it "returns two directories for a file two levels deep" $ do + parentDirs "a/b/c.txt" `shouldBe` ["a", "a/b"] + + it "returns three directories for a file three levels deep" $ do + parentDirs "a/b/c/d.txt" `shouldBe` ["a", "a/b", "a/b/c"] + + describe "compilePlan" $ do + it "compiles a Copy step" $ do + withFixture [("data.txt", "raw content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [WriteFileOp "data.txt" "raw content" Copy] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Template step with rendering" $ do + withFixture [("hello.tpl", "Hello, {{name}}!")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "world")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [WriteFileOp "hello.txt" "Hello, world!" Template] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "skips step when condition is false" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit False)) Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "includes step when condition is true" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" (Just (ExprLit True)) Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [WriteFileOp "data.txt" "content" Copy] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "evaluates IsSet condition correctly" $ do + withFixture [("LICENSE", "MIT License")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + -- Variable IS set + let vars1 = Map.fromList [("license", VText "MIT")] + result1 <- compilePlan baseDir modul vars1 + case result1 of + Right ops -> ops `shouldBe` [WriteFileOp "LICENSE" "MIT License" Copy] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + -- Variable is NOT set + let vars2 = Map.empty + result2 <- compilePlan baseDir modul vars2 + case result2 of + Right ops -> ops `shouldBe` [] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "expands destination path with placeholders" $ do + withFixture [("pkg.cabal.tpl", "name: {{name}}\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "pkg.cabal.tpl" "{{name}}.cabal" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "my-app")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [WriteFileOp "my-app.cabal" "name: my-app\n" Template] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "rejects a rendered destination with a parent directory segment" $ do + withFixture [("README.md.tpl", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("project.name", VText "..")] + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldBe` 1 + T.isInfixOf "rendered destination" (errs !! 0) `shouldBe` True + T.isInfixOf "must not contain '..' segment" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "rejects a rendered absolute destination" $ do + withFixture [("README.md.tpl", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "README.md.tpl" "{{project.name}}/README.md" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("project.name", VText "/tmp/outside")] + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldBe` 1 + T.isInfixOf "rendered destination" (errs !! 0) `shouldBe` True + T.isInfixOf "must be relative" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "allows dots inside a rendered destination filename" $ do + withFixture [("README.md.tpl", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "README.md.tpl" "docs/README.v2.md" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [CreateDirOp "docs", WriteFileOp "docs/README.v2.md" "content" Template] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "creates parent directories" $ do + withFixture [("Lib.hs.tpl", "module Lib where\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "Lib.hs.tpl" "src/Lib.hs" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops `shouldBe` [CreateDirOp "src", WriteFileOp "src/Lib.hs" "module Lib where\n" Template] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "deduplicates parent directory operations" $ do + withFixture [("A.hs.tpl", "module A\n"), ("B.hs.tpl", "module B\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = + [ Step Template "A.hs.tpl" "src/A.hs" Nothing Nothing, + Step Template "B.hs.tpl" "src/B.hs" Nothing Nothing + ], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops + `shouldBe` [ CreateDirOp "src", + WriteFileOp "src/A.hs" "module A\n" Template, + WriteFileOp "src/B.hs" "module B\n" Template + ] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "propagates template error for unresolved placeholder" $ do + withFixture [("hello.tpl", "Hello, {{missing}}!")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "hello.tpl" "hello.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldBe` 1 + T.isInfixOf "missing" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "compiles a DhallText step" $ do + withFixture [("greeting.dhall", "\"Hello, {{name}}!\"")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step DhallText "greeting.dhall" "greeting.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "world")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [WriteFileOp "greeting.txt" "Hello, world!" DhallText] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a DhallText step with Dhall string interpolation" $ do + let dhallContent = + "let name = \"{{project.name}}\"\n\ + \let version = \"{{project.version}}\"\n\ + \in \"name: ${name}\\nversion: ${version}\\n\"" + withFixture [("pkg.dhall", T.unpack dhallContent)] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step DhallText "pkg.dhall" "pkg.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("project.name", VText "my-app"), ("project.version", VText "0.1.0.0")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> ops `shouldBe` [WriteFileOp "pkg.txt" "name: my-app\nversion: 0.1.0.0\n" DhallText] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "reports error for invalid Dhall in DhallText step" $ do + withFixture [("bad.dhall", "this is not valid dhall {")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step DhallText "bad.dhall" "out.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldSatisfy` (>= 1) + T.isInfixOf "Dhall" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "compiles a Structured step to JSON" $ do + withFixture [("data.json.gen", "{ name = \"{{name}}\", version = \"1.0.0\" }\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Structured "data.json.gen" "data.json" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "my-app")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + length ops `shouldBe` 1 + let (WriteFileOp dest content strat) = ops !! 0 + dest `shouldBe` "data.json" + strat `shouldBe` Structured + -- Parse the JSON to verify it's valid + case Aeson.eitherDecodeStrict (T.encodeUtf8 content) of + Left err -> expectationFailure ("Invalid JSON: " <> err) + Right (val :: Aeson.Value) -> do + val `shouldBe` Aeson.object [("name", Aeson.String "my-app"), ("version", Aeson.String "1.0.0")] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Structured step to YAML" $ do + withFixture [("config.yaml.gen", "{ name = \"{{name}}\", debug = False }\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Structured "config.yaml.gen" "config.yaml" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "my-app")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + length ops `shouldBe` 1 + let (WriteFileOp dest content strat) = ops !! 0 + dest `shouldBe` "config.yaml" + strat `shouldBe` Structured + -- Parse the YAML to verify it's valid + case Yaml.decodeEither' (T.encodeUtf8 content) of + Left err -> expectationFailure ("Invalid YAML: " <> show err) + Right (val :: Aeson.Value) -> do + val `shouldBe` Aeson.object [("debug", Aeson.Bool False), ("name", Aeson.String "my-app")] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "reports error for Structured step with unconvertible Dhall expression" $ do + -- A lambda cannot be converted to JSON + withFixture [("bad.gen", "\\(x : Text) -> x\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Structured "bad.gen" "out.json" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldSatisfy` (>= 1) + T.isInfixOf "Cannot convert" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "reports error for unknown output format in Structured step" $ do + withFixture [("data.gen", "{ name = \"test\" }\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Structured "data.gen" "output.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldSatisfy` (>= 1) + T.isInfixOf "unsupported output format" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "compiles haskell-base fixture end-to-end" $ do + cwd <- getCurrentDirectory + let fixtures = cwd "test" "fixtures" + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + let vars = + Map.fromList + [ ("project.name", VText "my-app"), + ("project.version", VText "0.1.0.0"), + ("license", VText "MIT") + ] + planResult <- compilePlan (fixtures "haskell-base") modul vars + case planResult of + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + Right ops -> do + -- Should have operations for README, src/Lib.hs, LICENSE, my-app.cabal, and cabal.project + let writeOps = [op | op@(WriteFileOp _ _ _) <- ops] + dirOps = [op | op@(CreateDirOp _) <- ops] + length writeOps `shouldBe` 5 + -- README.md with rendered content + (writeOps !! 0).dest `shouldBe` "README.md" + T.isInfixOf "my-app" ((writeOps !! 0).content) `shouldBe` True + -- src/Lib.hs + (writeOps !! 1).dest `shouldBe` "src/Lib.hs" + -- LICENSE (copy) + (writeOps !! 2).dest `shouldBe` "LICENSE" + -- my-app.cabal (dest expanded from {{project.name}}.cabal) + (writeOps !! 3).dest `shouldBe` "my-app.cabal" + T.isInfixOf "my-app" ((writeOps !! 3).content) `shouldBe` True + -- cabal.project (DhallText) + (writeOps !! 4).dest `shouldBe` "cabal.project" + T.isInfixOf "my-app" ((writeOps !! 4).content) `shouldBe` True + -- Should have CreateDirOp for src/ + dirOps `shouldSatisfy` any (\op -> op.path == "src") + -- Should have RunCommandOp for the command + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 1 + (cmdOps !! 0).command `shouldBe` "echo 'Project generated'" + + it "compiles a Template step with patch = AppendFile to PatchFileOp" $ do + withFixture [("section.tpl", "appended content")] $ \baseDir -> do + let modul = + Module + { name = "patch-mod", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendFile)], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops `shouldBe` [PatchFileOp "README.md" "appended content" AppendFile Template "patch-mod"] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Template step with patch = AppendSection to PatchFileOp" $ do + withFixture [("section.tpl", "section {{name}}")] $ \baseDir -> do + let modul = + Module + { name = "section-mod", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "section.tpl" "README.md" Nothing (Just AppendSection)], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "test")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops `shouldBe` [PatchFileOp "README.md" "section test" AppendSection Template "section-mod"] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Template step containing {{#if}} and selects the then-branch" $ do + let tpl = "prefix\n{{#if Eq flag true}}hot\n{{/if}}suffix\n" + withFixture [("conditional.tpl", tpl)] $ \baseDir -> do + let modul = + Module + { name = "cond-mod", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("flag", VBool True)] + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops `shouldBe` [WriteFileOp "out.txt" "prefix\nhot\nsuffix\n" Template] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Template step containing {{#if}} and drops the untaken branch" $ do + let tpl = "prefix\n{{#if Eq flag true}}hot\n{{/if}}suffix\n" + withFixture [("conditional.tpl", tpl)] $ \baseDir -> do + let modul = + Module + { name = "cond-mod", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "conditional.tpl" "out.txt" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("flag", VBool False)] + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops `shouldBe` [WriteFileOp "out.txt" "prefix\nsuffix\n" Template] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Template patch step whose body uses {{#if}}" $ do + let tpl = "base{{#if Eq flag true}} extra{{/if}}\n" + withFixture [("patch.tpl", tpl)] $ \baseDir -> do + let modul = + Module + { name = "patch-cond-mod", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Template "patch.tpl" "README.md" Nothing (Just AppendFile)], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("flag", VBool True)] + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops + `shouldBe` [PatchFileOp "README.md" "base extra\n" AppendFile Template "patch-cond-mod"] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles a Copy step with patch = PrependFile to PatchFileOp" $ do + withFixture [("header.txt", "header line\n")] $ \baseDir -> do + let modul = + Module + { name = "header-mod", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "header.txt" "out.txt" Nothing (Just PrependFile)], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> + ops `shouldBe` [PatchFileOp "out.txt" "header line\n" PrependFile Copy "header-mod"] + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "rejects Structured strategy with patch operation" $ do + withFixture [("data.gen", "{ name = \"test\" }\n")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Structured "data.gen" "data.json" Nothing (Just AppendFile)], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldSatisfy` (>= 1) + T.isInfixOf "Structured" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "compiles unconditional command to RunCommandOp" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "echo hello" Nothing Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 1 + (cmdOps !! 0).command `shouldBe` "echo hello" + (cmdOps !! 0).workDir `shouldBe` Nothing + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "skips command when condition is false" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "echo skip" Nothing (Just (ExprLit False))], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 0 + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "includes command when condition is true" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "echo yes" Nothing (Just (ExprIsSet "name"))], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "test")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 1 + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "places commands after file operations in compiled plan" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "echo post" Nothing Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let isFileOp (WriteFileOp {}) = True + isFileOp (CreateDirOp {}) = True + isFileOp (CopyFileOp {}) = True + isFileOp (PatchFileOp {}) = True + isFileOp _ = False + isCmdOp (RunCommandOp {}) = True + isCmdOp _ = False + fileOps = filter isFileOp ops + cmdOps = filter isCmdOp ops + -- Commands should come after all file ops + ops `shouldBe` (fileOps ++ cmdOps) + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "compiles command with workDir" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "npm install" (Just "subdir") Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 1 + (cmdOps !! 0).workDir `shouldBe` Just "subdir" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "interpolates {{var}} in command run field" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "echo {{name}}" Nothing Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "my-app")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 1 + (cmdOps !! 0).command `shouldBe` "echo my-app" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "interpolates {{var}} in command workDir field" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "cabal build" (Just "{{name}}") Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("name", VText "my-app")] + result <- compilePlan baseDir modul vars + case result of + Right ops -> do + let cmdOps = [op | op@(RunCommandOp _ _) <- ops] + length cmdOps `shouldBe` 1 + (cmdOps !! 0).workDir `shouldBe` Just "my-app" + Left errs -> expectationFailure ("Expected Right, got: " <> show errs) + + it "rejects a rendered command workDir with a parent directory segment" $ do + withFixture [] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [Command "cabal build" (Just "{{project.name}}") Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.fromList [("project.name", VText "..")] + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldBe` 1 + T.isInfixOf "rendered command workDir" (errs !! 0) `shouldBe` True + T.isInfixOf "must not contain '..' segment" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" + + it "fails compilation when command has unresolved placeholder" $ do + withFixture [("data.txt", "content")] $ \baseDir -> do + let modul = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [Step Copy "data.txt" "data.txt" Nothing Nothing], + commands = [Command "echo {{missing}}" Nothing Nothing], + dependencies = [], + removal = Nothing, + migrations = [] + } + vars = Map.empty + result <- compilePlan baseDir modul vars + case result of + Left errs -> do + length errs `shouldSatisfy` (>= 1) + T.isInfixOf "missing" (errs !! 0) `shouldBe` True + Right _ -> expectationFailure "Expected Left" diff --git a/test/Seihou/Engine/PreviewSpec.hs b/test/Seihou/Engine/PreviewSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/PreviewSpec.hs @@ -0,0 +1,237 @@ +module Seihou.Engine.PreviewSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Engine.Preview +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Preview" spec + +modName :: ModuleName +modName = ModuleName "test-module" + +modName2 :: ModuleName +modName2 = ModuleName "other-module" + +-- | A DiffResult with all fields empty. +emptyDiff :: DiffResult +emptyDiff = + DiffResult + { new = [], + modified = [], + unchanged = [], + conflicts = [], + orphaned = [] + } + +spec :: Spec +spec = do + describe "buildPreview" $ do + it "treats all file ops as FsNew when no DiffResult is provided" $ do + let ops = + [ WriteFileOp "README.md" "# Hello" Template, + WriteFileOp "src/Lib.hs" "module Lib" Template, + CopyFileOp "templates/LICENSE" "LICENSE" + ] + result = buildPreview ops Nothing Map.empty + length result `shouldBe` 3 + (result !! 0).previewStatus `shouldBe` FsNew + (result !! 1).previewStatus `shouldBe` FsNew + (result !! 2).previewStatus `shouldBe` FsNew + + it "classifies a new file as FsNew" $ do + let ops = [WriteFileOp "README.md" "# Hello" Template] + diff = emptyDiff {new = [PlannedFile "README.md" modName "# Hello"]} + result = buildPreview ops (Just diff) Map.empty + length result `shouldBe` 1 + (head result).previewStatus `shouldBe` FsNew + + it "classifies a modified file as FsModified" $ do + let ops = [WriteFileOp "README.md" "# Updated" Template] + diff = emptyDiff {modified = [ModifiedFile "README.md" modName (SHA256 "old") "# Updated"]} + result = buildPreview ops (Just diff) Map.empty + length result `shouldBe` 1 + (head result).previewStatus `shouldBe` FsModified + + it "classifies an unchanged file as FsUnchanged" $ do + let ops = [WriteFileOp "README.md" "# Same" Template] + diff = emptyDiff {unchanged = ["README.md"]} + result = buildPreview ops (Just diff) Map.empty + length result `shouldBe` 1 + (head result).previewStatus `shouldBe` FsUnchanged + + it "classifies a conflicting file as FsConflict" $ do + let ops = [WriteFileOp "README.md" "# New" Template] + diff = + emptyDiff + { conflicts = + [ ConflictFile + { path = "README.md", + moduleName = modName, + manifestHash = SHA256 "man", + diskHash = SHA256 "disk", + planContent = "# New" + } + ] + } + result = buildPreview ops (Just diff) Map.empty + length result `shouldBe` 1 + (head result).previewStatus `shouldBe` FsConflict + + it "classifies an orphaned file as FsOrphaned" $ do + let ops = [WriteFileOp "other.txt" "content" Template] + diff = + emptyDiff + { new = [PlannedFile "other.txt" modName "content"], + orphaned = [OrphanedFile "old.txt" modName] + } + result = buildPreview ops (Just diff) Map.empty + -- One file preview + one orphan preview + length result `shouldBe` 2 + let orphan = result !! 1 + case orphan of + OrphanPreview path mn -> do + path `shouldBe` "old.txt" + mn `shouldBe` modName + _ -> expectationFailure "Expected OrphanPreview" + + it "does not include orphaned files that are produced by an operation" $ do + let ops = [WriteFileOp "reused.txt" "content" Template] + diff = + emptyDiff + { new = [PlannedFile "reused.txt" modName "content"], + orphaned = [OrphanedFile "reused.txt" modName2] + } + result = buildPreview ops (Just diff) Map.empty + -- Only the file preview, orphan is suppressed because path matches an operation + length result `shouldBe` 1 + case head result of + FilePreview {} -> pure () + _ -> expectationFailure "Expected FilePreview" + + it "produces DirPreview for CreateDirOp" $ do + let ops = [CreateDirOp "src"] + result = buildPreview ops Nothing Map.empty + length result `shouldBe` 1 + case head result of + DirPreview path -> path `shouldBe` "src" + _ -> expectationFailure "Expected DirPreview" + + it "produces CommandPreview for RunCommandOp" $ do + let ops = [RunCommandOp "cabal build" Nothing] + result = buildPreview ops Nothing Map.empty + length result `shouldBe` 1 + case head result of + CommandPreview cmd -> cmd `shouldBe` "cabal build" + _ -> expectationFailure "Expected CommandPreview" + + it "maps PatchFileOp to FilePreview with patch annotation" $ do + let ops = [PatchFileOp "README.md" "extra content" AppendSection Template modName] + result = buildPreview ops Nothing Map.empty + length result `shouldBe` 1 + case head result of + FilePreview status path annotation mMod -> do + status `shouldBe` FsNew + path `shouldBe` "README.md" + annotation `shouldBe` "patch" + mMod `shouldBe` Just modName + _ -> expectationFailure "Expected FilePreview" + + it "maps CopyFileOp to FilePreview with copy annotation" $ do + let ops = [CopyFileOp "templates/LICENSE" "LICENSE"] + result = buildPreview ops Nothing Map.empty + length result `shouldBe` 1 + case head result of + FilePreview _ path annotation _ -> do + path `shouldBe` "LICENSE" + annotation `shouldBe` "copy" + _ -> expectationFailure "Expected FilePreview" + + it "includes correct strategy annotation for WriteFileOp" $ do + let ops = + [ WriteFileOp "a.txt" "" Copy, + WriteFileOp "b.txt" "" Template, + WriteFileOp "c.txt" "" DhallText, + WriteFileOp "d.txt" "" Structured + ] + result = buildPreview ops Nothing Map.empty + map (.previewAnnotation) (filter isFilePreview result) + `shouldBe` ["copy", "template", "dhall-text", "structured"] + + describe "renderPreviewPlain" $ do + it "renders empty list as 'No operations' message" $ do + renderPreviewPlain [] `shouldBe` "No operations to perform.\n" + + it "renders FilePreview lines with status tags" $ do + let lines' = + [ FilePreview FsNew "README.md" "template" Nothing, + FilePreview FsModified "src/Lib.hs" "template" Nothing, + FilePreview FsUnchanged "LICENSE" "copy" Nothing, + FilePreview FsConflict "config.yml" "structured" Nothing, + FilePreview FsOrphaned "old.txt" "template" Nothing + ] + rendered = renderPreviewPlain lines' + renderedLines = T.lines rendered + length renderedLines `shouldBe` 5 + (renderedLines !! 0) `shouldBe` " [new] README.md (template)" + (renderedLines !! 1) `shouldBe` " [modified] src/Lib.hs (template)" + (renderedLines !! 2) `shouldBe` " [unchanged] LICENSE (copy)" + (renderedLines !! 3) `shouldBe` " [conflict] config.yml (structured)" + (renderedLines !! 4) `shouldBe` " [orphaned] old.txt (template)" + + it "renders DirPreview, CommandPreview, and OrphanPreview" $ do + let lines' = + [ DirPreview "src", + CommandPreview "cabal build", + OrphanPreview "gone.txt" modName + ] + rendered = renderPreviewPlain lines' + renderedLines = T.lines rendered + length renderedLines `shouldBe` 3 + (renderedLines !! 0) `shouldBe` " mkdir src" + (renderedLines !! 1) `shouldBe` " run cabal build" + (renderedLines !! 2) `shouldBe` " [orphaned] gone.txt (orphaned from test-module)" + + describe "formatPlanView" $ do + it "includes header with module names" $ do + let preview = [FilePreview FsNew "README.md" "template" (Just modName)] + diff = emptyDiff {new = [PlannedFile "README.md" modName "# Hello"]} + rendered = formatPlanView [modName] Map.empty preview diff + T.isInfixOf "Generation Plan (test-module):" rendered `shouldBe` True + + it "includes header with multiple module names joined by +" $ do + let preview = [] + diff = emptyDiff + rendered = formatPlanView [modName, modName2] Map.empty preview diff + T.isInfixOf "Generation Plan (test-module + other-module):" rendered `shouldBe` True + + it "includes Variables section when variables are present" $ do + let vars = Map.fromList [(VarName "project.name", VText "hello")] + preview = [] + diff = emptyDiff + rendered = formatPlanView [modName] vars preview diff + T.isInfixOf "Variables:" rendered `shouldBe` True + T.isInfixOf "project.name" rendered `shouldBe` True + T.isInfixOf "\"hello\"" rendered `shouldBe` True + + it "omits Variables section when no variables" $ do + let rendered = formatPlanView [modName] Map.empty [] emptyDiff + T.isInfixOf "Variables:" rendered `shouldBe` False + + it "includes summary with file and conflict counts" $ do + let diff = + emptyDiff + { new = [PlannedFile "a.txt" modName ""], + modified = [ModifiedFile "b.txt" modName (SHA256 "old") "new"] + } + rendered = formatPlanView [modName] Map.empty [] diff + T.isInfixOf "2 files to write, 0 conflicts" rendered `shouldBe` True + +-- | Helper to test if a PreviewLine is a FilePreview. +isFilePreview :: PreviewLine -> Bool +isFilePreview (FilePreview {}) = True +isFilePreview _ = False diff --git a/test/Seihou/Engine/RemoveSpec.hs b/test/Seihou/Engine/RemoveSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/RemoveSpec.hs @@ -0,0 +1,392 @@ +module Seihou.Engine.RemoveSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Types +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import Seihou.Engine.Remove +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (emptyManifest) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Remove" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +removeTime :: UTCTime +removeTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-02T09:00:00Z" + +modName :: ModuleName +modName = ModuleName "test-module" + +otherMod :: ModuleName +otherMod = ModuleName "other-module" + +-- | Helper: create a manifest with one applied module and some files. +mkManifest :: Bool -> [(FilePath, Text)] -> Manifest +mkManifest isRemovable fileContents = + (emptyManifest fixedTime) + { modules = + [ AppliedModule + { name = modName, + parentVars = emptyParentVars, + source = "/path/to/test-module", + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = if isRemovable then Just (Removal [] []) else Nothing + } + ], + files = + Map.fromList + [ ( path, + FileRecord + { hash = hashContent content, + moduleName = modName, + strategy = Template, + generatedAt = fixedTime + } + ) + | (path, content) <- fileContents + ] + } + +-- | Helper: create a manifest with a specific removal spec. +mkManifestWithRemoval :: Removal -> [(FilePath, Text)] -> Manifest +mkManifestWithRemoval removal fileContents = + (emptyManifest fixedTime) + { modules = + [ AppliedModule + { name = modName, + source = "/path/to/test-module", + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = Just removal + } + ], + files = + Map.fromList + [ ( path, + FileRecord + { hash = hashContent content, + moduleName = modName, + strategy = Template, + generatedAt = fixedTime + } + ) + | (path, content) <- fileContents + ] + } + +-- | Helper: create a PureFS with files. +mkFS :: [(FilePath, Text)] -> PureFS +mkFS fileContents = PureFS (Map.fromList fileContents) Set.empty + +-- | Run computeRemovalPlan in the pure filesystem. +runPlan :: PureFS -> Manifest -> ModuleName -> Either RemovalError RemovalPlan +runPlan fs manifest name = + fst $ runPureEff $ runFilesystemPure fs $ computeRemovalPlan manifest name + +-- | Run executeRemoval in the pure filesystem. +runExec :: PureFS -> Manifest -> RemovalPlan -> Set.Set FilePath -> (Manifest, PureFS) +runExec fs manifest plan keepSet = + let (result, finalFS) = + runPureEff $ + runFilesystemPure fs $ + executeRemoval manifest plan keepSet removeTime + in (result, finalFS) + +-- | Run buildRemovalOps in the pure filesystem. +runBuildOps :: PureFS -> Manifest -> ModuleName -> Removal -> Either RemovalError ExecutedRemovalPlan +runBuildOps fs manifest name removal = + fst $ runPureEff $ runFilesystemPure fs $ buildRemovalOps manifest name removal + +-- | Run executeRemovalOps in the pure filesystem. +runExecOps :: PureFS -> Manifest -> ExecutedRemovalPlan -> Set.Set FilePath -> (Manifest, PureFS) +runExecOps fs manifest plan keepSet = + let (result, finalFS) = + runPureEff $ + runFilesystemPure fs $ + executeRemovalOps manifest plan keepSet removeTime + in (result, finalFS) + +spec :: Spec +spec = do + describe "computeRemovalPlan" $ do + it "returns ModuleNotApplied when module is not in manifest" $ do + let manifest = emptyManifest fixedTime + result = runPlan emptyFS manifest modName + result `shouldBe` Left (ModuleNotApplied modName) + + it "returns ModuleNotRemovable when removal is Nothing" $ do + let manifest = mkManifest False [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + result = runPlan fs manifest modName + result `shouldBe` Left (ModuleNotRemovable modName) + + it "classifies unchanged files as RemovalSafe" $ do + let manifest = mkManifest True [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + result = runPlan fs manifest modName + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.files `shouldBe` [RemovalSafe "README.md"] + + it "classifies user-modified files as RemovalConflict" $ do + let manifest = mkManifest True [("README.md", "original")] + fs = mkFS [("README.md", "user changed this")] + result = runPlan fs manifest modName + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.files `shouldBe` [RemovalConflict "README.md"] + + it "classifies deleted files as RemovalGone" $ do + let manifest = mkManifest True [("README.md", "hello")] + result = runPlan emptyFS manifest modName + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.files `shouldBe` [RemovalGone "README.md"] + + it "handles mix of safe, conflict, and gone files" $ do + let manifest = mkManifest True [("a.txt", "aaa"), ("b.txt", "bbb"), ("c.txt", "ccc")] + fs = mkFS [("a.txt", "aaa"), ("b.txt", "modified")] + result = runPlan fs manifest modName + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> do + length plan.files `shouldBe` 3 + RemovalSafe "a.txt" `elem` plan.files `shouldBe` True + RemovalConflict "b.txt" `elem` plan.files `shouldBe` True + RemovalGone "c.txt" `elem` plan.files `shouldBe` True + + describe "executeRemoval" $ do + it "deletes safe files from the filesystem" $ do + let manifest = mkManifest True [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "README.md"]} + (_, finalFS) = runExec fs manifest plan Set.empty + Map.member "README.md" finalFS.files `shouldBe` False + + it "preserves files in the keep-set" $ do + let manifest = mkManifest True [("a.txt", "aaa")] + fs = mkFS [("a.txt", "modified")] + plan = RemovalPlan {targetModule = modName, files = [RemovalConflict "a.txt"]} + keepSet = Set.singleton "a.txt" + (_, finalFS) = runExec fs manifest plan keepSet + Map.member "a.txt" finalFS.files `shouldBe` True + + it "removes the module from manifest.modules" $ do + let manifest = mkManifest True [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "README.md"]} + (updated, _) = runExec fs manifest plan Set.empty + updated.modules `shouldBe` [] + + it "removes module's files from manifest.files" $ do + let manifest = mkManifest True [("a.txt", "aaa"), ("b.txt", "bbb")] + fs = mkFS [("a.txt", "aaa"), ("b.txt", "bbb")] + plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "a.txt", RemovalSafe "b.txt"]} + (updated, _) = runExec fs manifest plan Set.empty + Map.null updated.files `shouldBe` True + + it "preserves files from other modules in manifest" $ do + let base = mkManifest True [("mine.txt", "mine")] + otherRec = FileRecord (hashContent "other") otherMod Template fixedTime + manifest = + Manifest + { version = base.version, + genAt = base.genAt, + modules = base.modules, + vars = base.vars, + files = Map.insert "other.txt" otherRec base.files + } + fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")] + plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "mine.txt"]} + (updated, _) = runExec fs manifest plan Set.empty + Map.member "other.txt" updated.files `shouldBe` True + Map.member "mine.txt" updated.files `shouldBe` False + + it "updates genAt timestamp in manifest" $ do + let manifest = mkManifest True [("a.txt", "aaa")] + fs = mkFS [("a.txt", "aaa")] + plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "a.txt"]} + (updated, _) = runExec fs manifest plan Set.empty + updated.genAt `shouldBe` removeTime + + it "full round-trip: manifest returns to clean state after removal" $ do + let manifest = mkManifest True [("a.txt", "aaa"), ("b.txt", "bbb")] + fs = mkFS [("a.txt", "aaa"), ("b.txt", "bbb")] + plan = RemovalPlan {targetModule = modName, files = [RemovalSafe "a.txt", RemovalSafe "b.txt"]} + (updated, finalFS) = runExec fs manifest plan Set.empty + updated.modules `shouldBe` [] + Map.null updated.files `shouldBe` True + Map.member "a.txt" finalFS.files `shouldBe` False + Map.member "b.txt" finalFS.files `shouldBe` False + + describe "buildRemovalOps" $ do + it "returns ModuleNotApplied when module is not in manifest" $ do + let manifest = emptyManifest fixedTime + removal = Removal [] [] + result = runBuildOps emptyFS manifest modName removal + result `shouldBe` Left (ModuleNotApplied modName) + + it "builds DeleteFileOp with RFSafe for unchanged files" $ do + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + manifest = mkManifestWithRemoval removal [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + result = runBuildOps fs manifest modName removal + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.ops `shouldBe` [DeleteFileOp "README.md" RFSafe] + + it "builds DeleteFileOp with RFConflict for modified files" $ do + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + manifest = mkManifestWithRemoval removal [("README.md", "original")] + fs = mkFS [("README.md", "user changed this")] + result = runBuildOps fs manifest modName removal + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.ops `shouldBe` [DeleteFileOp "README.md" RFConflict] + + it "builds DeleteFileOp with RFGone for already-deleted files" $ do + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + manifest = mkManifestWithRemoval removal [("README.md", "hello")] + result = runBuildOps emptyFS manifest modName removal + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.ops `shouldBe` [DeleteFileOp "README.md" RFGone] + + it "builds StripSectionOp for remove-section steps" $ do + let removal = Removal [RemovalStep RemoveSectionAction ".gitignore" Nothing] [] + manifest = mkManifestWithRemoval removal [(".gitignore", "content")] + fs = mkFS [(".gitignore", "content")] + result = runBuildOps fs manifest modName removal + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.ops `shouldBe` [StripSectionOp ".gitignore"] + + it "builds RemovalCommandOp for removal commands" $ do + let removal = Removal [] [Command "cabal clean" Nothing Nothing] + manifest = mkManifestWithRemoval removal [] + result = runBuildOps emptyFS manifest modName removal + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> plan.ops `shouldBe` [RemovalCommandOp "cabal clean" Nothing] + + it "rejects a removal step destination with a parent directory segment" $ do + let removal = Removal [RemovalStep RemoveFileAction "../outside" Nothing] [] + manifest = mkManifestWithRemoval removal [] + fs = mkFS [("../outside", "do not delete")] + result = runBuildOps fs manifest modName removal + result + `shouldBe` Left + ( RemovalUnsafePath + "remove-file destination" + "../outside" + "path must not contain '..' segment: ../outside" + ) + Map.member "../outside" fs.files `shouldBe` True + + it "rejects a removal command workDir with a parent directory segment" $ do + let removal = Removal [] [Command "echo unsafe" (Just "../outside") Nothing] + manifest = mkManifestWithRemoval removal [] + result = runBuildOps emptyFS manifest modName removal + result + `shouldBe` Left + ( RemovalUnsafePath + "remove-command workDir" + "../outside" + "path must not contain '..' segment: ../outside" + ) + + it "combines steps and commands in order" $ do + let removal = + Removal + [RemovalStep RemoveFileAction "a.txt" Nothing, RemovalStep RemoveSectionAction ".gitignore" Nothing] + [Command "echo done" Nothing Nothing] + manifest = mkManifestWithRemoval removal [("a.txt", "aaa")] + fs = mkFS [("a.txt", "aaa"), (".gitignore", "stuff")] + result = runBuildOps fs manifest modName removal + case result of + Left err -> expectationFailure ("unexpected error: " <> show err) + Right plan -> do + length plan.ops `shouldBe` 3 + case plan.ops of + [DeleteFileOp _ _, StripSectionOp _, RemovalCommandOp _ _] -> pure () + other -> expectationFailure ("unexpected ops: " <> show other) + + describe "executeRemovalOps" $ do + it "deletes files with DeleteFileOp" $ do + let removal = Removal [RemovalStep RemoveFileAction "README.md" Nothing] [] + manifest = mkManifestWithRemoval removal [("README.md", "hello")] + fs = mkFS [("README.md", "hello")] + plan = ExecutedRemovalPlan modName [DeleteFileOp "README.md" RFSafe] + (_, finalFS) = runExecOps fs manifest plan Set.empty + Map.member "README.md" finalFS.files `shouldBe` False + + it "preserves files in keep-set for DeleteFileOp" $ do + let removal = Removal [RemovalStep RemoveFileAction "a.txt" Nothing] [] + manifest = mkManifestWithRemoval removal [("a.txt", "aaa")] + fs = mkFS [("a.txt", "modified")] + plan = ExecutedRemovalPlan modName [DeleteFileOp "a.txt" RFConflict] + keepSet = Set.singleton "a.txt" + (_, finalFS) = runExecOps fs manifest plan keepSet + Map.member "a.txt" finalFS.files `shouldBe` True + + it "skips gone files" $ do + let manifest = mkManifest True [("a.txt", "aaa")] + plan = ExecutedRemovalPlan modName [DeleteFileOp "a.txt" RFGone] + (updated, _) = runExecOps emptyFS manifest plan Set.empty + updated.modules `shouldBe` [] + + it "strips section from file with StripSectionOp" $ do + let content = "before\n# --- seihou:test-module ---\nmodule content\n# --- /seihou:test-module ---\nafter\n" + manifest = mkManifest True [(".gitignore", content)] + fs = mkFS [(".gitignore", content)] + plan = ExecutedRemovalPlan modName [StripSectionOp ".gitignore"] + (_, finalFS) = runExecOps fs manifest plan Set.empty + case Map.lookup ".gitignore" finalFS.files of + Nothing -> expectationFailure ".gitignore should still exist" + Just result -> do + result `shouldSatisfy` \t -> + "before" `elem` lines (show t) || not ("seihou:test-module" `elem` lines (show t)) + + it "leaves file unchanged when no section markers found" $ do + let content = "no markers here\n" + manifest = mkManifest True [("file.txt", content)] + fs = mkFS [("file.txt", content)] + plan = ExecutedRemovalPlan modName [StripSectionOp "file.txt"] + (_, finalFS) = runExecOps fs manifest plan Set.empty + Map.lookup "file.txt" finalFS.files `shouldBe` Just content + + it "removes module from manifest after all steps" $ do + let removal = Removal [RemovalStep RemoveFileAction "a.txt" Nothing] [] + manifest = mkManifestWithRemoval removal [("a.txt", "aaa")] + fs = mkFS [("a.txt", "aaa")] + plan = ExecutedRemovalPlan modName [DeleteFileOp "a.txt" RFSafe] + (updated, _) = runExecOps fs manifest plan Set.empty + updated.modules `shouldBe` [] + Map.null updated.files `shouldBe` True + + it "preserves other modules' files in manifest" $ do + let base = mkManifest True [("mine.txt", "mine")] + otherRec = FileRecord (hashContent "other") otherMod Template fixedTime + manifest = + Manifest + { version = base.version, + genAt = base.genAt, + modules = base.modules, + vars = base.vars, + files = Map.insert "other.txt" otherRec base.files + } + fs = mkFS [("mine.txt", "mine"), ("other.txt", "other")] + plan = ExecutedRemovalPlan modName [DeleteFileOp "mine.txt" RFSafe] + (updated, _) = runExecOps fs manifest plan Set.empty + Map.member "other.txt" updated.files `shouldBe` True + Map.member "mine.txt" updated.files `shouldBe` False diff --git a/test/Seihou/Engine/SectionSpec.hs b/test/Seihou/Engine/SectionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/SectionSpec.hs @@ -0,0 +1,171 @@ +module Seihou.Engine.SectionSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Engine.Section +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Section" spec + +modName :: ModuleName +modName = ModuleName "nix-flake" + +marker :: SectionMarker +marker = SectionMarker {sectionPrefix = "#", sectionModule = modName} + +spec :: Spec +spec = do + describe "renderSectionOpen" $ do + it "produces correct format with # prefix" $ do + renderSectionOpen marker `shouldBe` "# --- seihou:nix-flake ---\n" + + it "produces correct format with -- prefix" $ do + let hsMarker = marker {sectionPrefix = "--"} + renderSectionOpen hsMarker `shouldBe` "-- --- seihou:nix-flake ---\n" + + describe "renderSectionClose" $ do + it "produces correct format with # prefix" $ do + renderSectionClose marker `shouldBe` "# --- /seihou:nix-flake ---\n" + + it "produces correct format with -- prefix" $ do + let hsMarker = marker {sectionPrefix = "--"} + renderSectionClose hsMarker `shouldBe` "-- --- /seihou:nix-flake ---\n" + + describe "wrapInSection" $ do + it "wraps content with open and close markers" $ do + wrapInSection marker "extra config\n" + `shouldBe` "# --- seihou:nix-flake ---\nextra config\n# --- /seihou:nix-flake ---\n" + + it "adds trailing newline to content if missing" $ do + wrapInSection marker "no trailing newline" + `shouldBe` "# --- seihou:nix-flake ---\nno trailing newline\n# --- /seihou:nix-flake ---\n" + + it "handles empty content" $ do + wrapInSection marker "" + `shouldBe` "# --- seihou:nix-flake ---\n# --- /seihou:nix-flake ---\n" + + describe "applyTextPatch" $ do + it "AppendFile appends content after existing" $ do + let result = applyTextPatch AppendFile modName "#" "line1\n" "line2\n" + result `shouldBe` Right "line1\nline2\n" + + it "AppendFile ensures newline between existing and new" $ do + let result = applyTextPatch AppendFile modName "#" "line1" "line2\n" + result `shouldBe` Right "line1\nline2\n" + + it "PrependFile prepends content before existing" $ do + let result = applyTextPatch PrependFile modName "#" "line2\n" "line1\n" + result `shouldBe` Right "line1\nline2\n" + + it "PrependFile ensures newline between new and existing" $ do + let result = applyTextPatch PrependFile modName "#" "line2\n" "line1" + result `shouldBe` Right "line1\nline2\n" + + it "AppendSection appends wrapped section" $ do + let result = applyTextPatch AppendSection modName "#" "base content\n" "extra\n" + result + `shouldBe` Right + "base content\n# --- seihou:nix-flake ---\nextra\n# --- /seihou:nix-flake ---\n" + + it "AppendSection uses configured comment prefix" $ do + let result = applyTextPatch AppendSection modName "--" "base\n" "extra\n" + result + `shouldBe` Right + "base\n-- --- seihou:nix-flake ---\nextra\n-- --- /seihou:nix-flake ---\n" + + it "AppendSection works with empty existing content" $ do + let result = applyTextPatch AppendSection modName "#" "" "new section\n" + result + `shouldBe` Right + "# --- seihou:nix-flake ---\nnew section\n# --- /seihou:nix-flake ---\n" + + it "AppendFile with empty existing content" $ do + let result = applyTextPatch AppendFile modName "#" "" "new content\n" + result `shouldBe` Right "new content\n" + + it "PrependFile with empty existing content" $ do + let result = applyTextPatch PrependFile modName "#" "" "new content\n" + result `shouldBe` Right "new content\n" + + it "AppendLineIfAbsent appends only missing lines" $ do + let result = applyTextPatch AppendLineIfAbsent modName "#" "line1\nline2\n" "line2\nline3\n" + result `shouldBe` Right "line1\nline2\nline3\n" + + it "AppendLineIfAbsent is idempotent when all lines present" $ do + let existing = ".claude/\nnode_modules/\n" + result = applyTextPatch AppendLineIfAbsent modName "#" existing ".claude/\n" + result `shouldBe` Right existing + + it "AppendLineIfAbsent with empty existing content" $ do + let result = applyTextPatch AppendLineIfAbsent modName "#" "" ".claude/\n" + result `shouldBe` Right ".claude/\n" + + it "AppendLineIfAbsent ignores trailing whitespace differences" $ do + let result = applyTextPatch AppendLineIfAbsent modName "#" "line1 \n" "line1\n" + result `shouldBe` Right "line1 \n" + + it "AppendLineIfAbsent handles multiple new lines, some present" $ do + let result = + applyTextPatch + AppendLineIfAbsent + modName + "#" + "*.log\n.env\n" + "*.log\n.claude/\n.env\ndist/\n" + result `shouldBe` Right "*.log\n.env\n.claude/\ndist/\n" + + describe "removeSection" $ do + it "removes a section between markers" $ do + let content = "before\n# --- seihou:nix-flake ---\nmodule content\n# --- /seihou:nix-flake ---\nafter\n" + result = removeSection modName "#" content + result `shouldBe` "before\nafter\n" + + it "leaves content outside markers intact" $ do + let content = "line1\nline2\n# --- seihou:nix-flake ---\nstuff\n# --- /seihou:nix-flake ---\nline3\nline4\n" + result = removeSection modName "#" content + result `shouldBe` "line1\nline2\nline3\nline4\n" + + it "returns content unchanged when no markers found" $ do + let content = "no markers here\njust text\n" + result = removeSection modName "#" content + result `shouldBe` content + + it "only removes the target module's section" $ do + let otherMod' = ModuleName "other-module" + content = + "start\n" + <> "# --- seihou:nix-flake ---\nflake stuff\n# --- /seihou:nix-flake ---\n" + <> "# --- seihou:other-module ---\nother stuff\n# --- /seihou:other-module ---\n" + <> "end\n" + -- Remove nix-flake: should keep other-module + let result = removeSection modName "#" content + T.isInfixOf "seihou:nix-flake" result `shouldBe` False + T.isInfixOf "seihou:other-module" result `shouldBe` True + -- Remove other-module: should keep nix-flake + let result2 = removeSection otherMod' "#" content + T.isInfixOf "seihou:nix-flake" result2 `shouldBe` True + T.isInfixOf "seihou:other-module" result2 `shouldBe` False + + it "cleans up double blank lines after removal" $ do + let content = "before\n\n# --- seihou:nix-flake ---\nstuff\n# --- /seihou:nix-flake ---\n\nafter\n" + result = removeSection modName "#" content + -- Should not have triple+ blank lines + T.isInfixOf "\n\n\n" result `shouldBe` False + + it "handles section at beginning of file" $ do + let content = "# --- seihou:nix-flake ---\nstuff\n# --- /seihou:nix-flake ---\nafter\n" + result = removeSection modName "#" content + result `shouldBe` "after\n" + + it "handles section at end of file" $ do + let content = "before\n# --- seihou:nix-flake ---\nstuff\n# --- /seihou:nix-flake ---\n" + result = removeSection modName "#" content + result `shouldBe` "before\n" + + it "works with -- comment prefix" $ do + let content = "before\n-- --- seihou:nix-flake ---\nstuff\n-- --- /seihou:nix-flake ---\nafter\n" + result = removeSection modName "--" content + result `shouldBe` "before\nafter\n" diff --git a/test/Seihou/Engine/TemplateSpec.hs b/test/Seihou/Engine/TemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/TemplateSpec.hs @@ -0,0 +1,419 @@ +module Seihou.Engine.TemplateSpec (tests) where + +import Data.Map.Strict qualified as Map +import Seihou.Core.Types +import Seihou.Engine.Template +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Template" spec + +spec :: Spec +spec = do + describe "valueToText" $ do + it "converts VText" $ do + valueToText (VText "hello") `shouldBe` "hello" + + it "converts VBool True" $ do + valueToText (VBool True) `shouldBe` "true" + + it "converts VBool False" $ do + valueToText (VBool False) `shouldBe` "false" + + it "converts VInt" $ do + valueToText (VInt 42) `shouldBe` "42" + + it "converts VList" $ do + valueToText (VList [VText "a", VText "b", VText "c"]) `shouldBe` "a,b,c" + + describe "renderTemplate" $ do + it "substitutes a simple placeholder" $ do + let vars = Map.fromList [("name", VText "world")] + renderTemplate "Hello, {{name}}!" vars `shouldBe` Right "Hello, world!" + + it "substitutes multiple placeholders on one line" $ do + let vars = Map.fromList [("first", VText "Jane"), ("last", VText "Doe")] + renderTemplate "Name: {{first}} {{last}}" vars + `shouldBe` Right "Name: Jane Doe" + + it "substitutes placeholders across multiple lines" $ do + let vars = Map.fromList [("project.name", VText "my-app"), ("project.version", VText "0.1.0.0")] + renderTemplate "# {{project.name}}\nVersion: {{project.version}}" vars + `shouldBe` Right "# my-app\nVersion: 0.1.0.0" + + it "handles the README fixture pattern" $ do + let vars = Map.fromList [("project.name", VText "my-app"), ("project.version", VText "0.1.0.0")] + renderTemplate "# {{project.name}}\n\nVersion: {{project.version}}\n" vars + `shouldBe` Right "# my-app\n\nVersion: 0.1.0.0\n" + + it "passes through text with no placeholders" $ do + let vars = Map.empty + renderTemplate "No placeholders here." vars + `shouldBe` Right "No placeholders here." + + it "handles empty template" $ do + let vars = Map.empty + renderTemplate "" vars `shouldBe` Right "" + + it "handles escape sequence" $ do + let vars = Map.empty + renderTemplate "Use \\{{var}} for placeholders" vars + `shouldBe` Right "Use {{var}} for placeholders" + + it "handles escape sequence with real placeholder" $ do + let vars = Map.fromList [("name", VText "world")] + renderTemplate "Literal \\{{not.a.var}} and {{name}}" vars + `shouldBe` Right "Literal {{not.a.var}} and world" + + it "coerces VBool to text in placeholder" $ do + let vars = Map.fromList [("enabled", VBool True)] + renderTemplate "Enabled: {{enabled}}" vars + `shouldBe` Right "Enabled: true" + + it "coerces VInt to text in placeholder" $ do + let vars = Map.fromList [("count", VInt 42)] + renderTemplate "Count: {{count}}" vars + `shouldBe` Right "Count: 42" + + it "coerces VList to text in placeholder" $ do + let vars = Map.fromList [("items", VList [VText "a", VText "b"])] + renderTemplate "Items: {{items}}" vars + `shouldBe` Right "Items: a,b" + + it "reports unresolved placeholder with correct line number" $ do + let vars = Map.empty + case renderTemplate "line one\n{{missing}}\nline three" vars of + Left errs -> do + length errs `shouldBe` 1 + case errs of + (UnresolvedPlaceholder name lineNum : _) -> do + name `shouldBe` "missing" + lineNum `shouldBe` 2 + other -> expectationFailure ("Unexpected error: " <> show other) + Right _ -> expectationFailure "Expected Left" + + it "reports multiple unresolved placeholders" $ do + let vars = Map.empty + case renderTemplate "{{a}}\n{{b}}" vars of + Left errs -> length errs `shouldBe` 2 + Right _ -> expectationFailure "Expected Left" + + it "strips whitespace around placeholder name" $ do + let vars = Map.fromList [("name", VText "world")] + renderTemplate "{{ name }}" vars `shouldBe` Right "world" + + describe "renderCommand" $ do + it "substitutes variables in a command string" $ do + let vars = Map.fromList [("project.name", VText "my-app")] + renderCommand "echo {{project.name}}" vars + `shouldBe` Right "echo my-app" + + it "substitutes multiple placeholders" $ do + let vars = Map.fromList [("name", VText "app"), ("ver", VText "1.0")] + renderCommand "echo {{name}}-{{ver}}" vars + `shouldBe` Right "echo app-1.0" + + it "handles escape sequence" $ do + let vars = Map.empty + renderCommand "echo \\{{literal}}" vars + `shouldBe` Right "echo {{literal}}" + + it "reports unresolved placeholder" $ do + let vars = Map.empty + case renderCommand "echo {{missing}}" vars of + Left errs -> length errs `shouldBe` 1 + Right _ -> expectationFailure "Expected Left" + + describe "renderDestPath" $ do + it "expands placeholder in destination path" $ do + let vars = Map.fromList [("project.name", VText "my-app")] + renderDestPath "{{project.name}}.cabal" vars + `shouldBe` Right "my-app.cabal" + + it "handles path with subdirectory and placeholder" $ do + let vars = Map.fromList [("project.name", VText "my-app")] + renderDestPath "src/{{project.name}}/Main.hs" vars + `shouldBe` Right "src/my-app/Main.hs" + + it "passes through path with no placeholders" $ do + let vars = Map.empty + renderDestPath "src/Lib.hs" vars `shouldBe` Right "src/Lib.hs" + + describe "renderTemplateText" $ do + it "behaves like renderTemplate on templates with no blocks" $ do + let vars = Map.fromList [("project.name", VText "my-app")] + tpl = "# {{project.name}}\nVersion: 0.1.0.0\n" + renderTemplateText tpl vars + `shouldBe` renderTemplate tpl vars + + it "selects the then-branch when the if expression is true" $ do + let vars = Map.fromList [("x", VBool True)] + renderTemplateText "{{#if Eq x true}}A{{/if}}" vars + `shouldBe` Right "A" + + it "excludes the then-branch when the if expression is false" $ do + let vars = Map.fromList [("x", VBool False)] + renderTemplateText "{{#if Eq x true}}A{{/if}}" vars + `shouldBe` Right "" + + it "selects the then-branch of an if/else when the variable is set" $ do + let vars = Map.fromList [("foo", VText "bar")] + renderTemplateText "{{#if IsSet foo}}yes{{#else}}no{{/if}}" vars + `shouldBe` Right "yes" + + it "selects the else-branch of an if/else when the variable is unset" $ do + let vars = Map.empty + renderTemplateText "{{#if IsSet foo}}yes{{#else}}no{{/if}}" vars + `shouldBe` Right "no" + + it "handles two-level nesting with both branches taken" $ do + let vars = Map.fromList [("a", VBool True), ("b", VBool True)] + renderTemplateText + "{{#if Eq a true}}outer{{#if Eq b true}}inner{{/if}}outer2{{/if}}" + vars + `shouldBe` Right "outerinnerouter2" + + it "handles three-level nesting" $ do + let vars = Map.fromList [("a", VBool True), ("b", VBool True), ("c", VBool True)] + renderTemplateText + "{{#if Eq a true}}{{#if Eq b true}}{{#if Eq c true}}deep{{/if}}{{/if}}{{/if}}" + vars + `shouldBe` Right "deep" + + it "reports UnterminatedIf with the opener's source line" $ do + let tpl = "line one\nline two\n{{#if Eq x true}}never closed\nline four\n" + vars = Map.fromList [("x", VBool True)] + case renderTemplateText tpl vars of + Right _ -> expectationFailure "expected UnterminatedIf" + Left [UnterminatedIf lineNum] -> lineNum `shouldBe` 3 + Left other -> expectationFailure ("expected [UnterminatedIf 3], got " <> show other) + + it "reports orphan {{/if}} at top level" $ do + let tpl = "a\nb\n{{/if}}\n" + vars = Map.empty + case renderTemplateText tpl vars of + Right _ -> expectationFailure "expected OrphanBlockToken" + Left [OrphanBlockToken tok lineNum] -> do + tok `shouldBe` "{{/if}}" + lineNum `shouldBe` 3 + Left other -> + expectationFailure ("expected [OrphanBlockToken \"{{/if}}\" 3], got " <> show other) + + it "reports orphan {{#else}} at top level" $ do + let tpl = "a\n{{#else}}\n" + vars = Map.empty + case renderTemplateText tpl vars of + Right _ -> expectationFailure "expected OrphanBlockToken" + Left [OrphanBlockToken tok lineNum] -> do + tok `shouldBe` "{{#else}}" + lineNum `shouldBe` 2 + Left other -> + expectationFailure ("expected [OrphanBlockToken \"{{#else}}\" 2], got " <> show other) + + it "reports MalformedIfExpression with the opener line and parser error" $ do + let tpl = "ok\n{{#if &&garbage}}body{{/if}}" + vars = Map.empty + case renderTemplateText tpl vars of + Right _ -> expectationFailure "expected MalformedIfExpression" + Left [MalformedIfExpression rawExpr lineNum _parserErr] -> do + rawExpr `shouldBe` "&&garbage" + lineNum `shouldBe` 2 + Left other -> + expectationFailure ("expected [MalformedIfExpression …], got " <> show other) + + it "substitutes {{var}} inside the taken branch and surfaces unresolved errors" $ do + let vars = Map.fromList [("gate", VBool True)] + case renderTemplateText "{{#if Eq gate true}}hello {{name}}{{/if}}" vars of + Right _ -> expectationFailure "expected UnresolvedPlaceholder in taken branch" + Left [UnresolvedPlaceholder (VarName nm) _] -> nm `shouldBe` "name" + Left other -> expectationFailure ("unexpected errors: " <> show other) + + it "discards untaken branches so their {{var}} errors do not surface" $ do + let vars = Map.fromList [("gate", VBool False)] + renderTemplateText "before {{#if Eq gate true}}hello {{missing}}{{/if}}after" vars + `shouldBe` Right "before after" + + it "evaluates && combinator: both true takes the branch" $ do + let vars = Map.fromList [("a", VBool True), ("b", VBool True)] + renderTemplateText "{{#if Eq a true && Eq b true}}Y{{#else}}N{{/if}}" vars + `shouldBe` Right "Y" + + it "evaluates && combinator: one false drops the branch" $ do + let vars = Map.fromList [("a", VBool True), ("b", VBool False)] + renderTemplateText "{{#if Eq a true && Eq b true}}Y{{#else}}N{{/if}}" vars + `shouldBe` Right "N" + + it "evaluates || combinator: either true takes the branch" $ do + let vars = Map.fromList [("a", VBool False), ("b", VBool True)] + renderTemplateText "{{#if Eq a true || Eq b true}}Y{{#else}}N{{/if}}" vars + `shouldBe` Right "Y" + + it "evaluates ! combinator: negation flips the branch" $ do + let vars = Map.fromList [("a", VBool False)] + renderTemplateText "{{#if !Eq a true}}Y{{#else}}N{{/if}}" vars + `shouldBe` Right "Y" + + it "evaluates a parenthesised expression honouring precedence" $ do + -- (A || B) && !C — with A=false, B=true, C=false → (true) && true = true + let vars = + Map.fromList + [ ("a", VBool False), + ("b", VBool True), + ("c", VBool False) + ] + renderTemplateText + "{{#if (Eq a true || Eq b true) && !Eq c true}}Y{{#else}}N{{/if}}" + vars + `shouldBe` Right "Y" + + it "matches outer {{#else}} past a nested {{#else}} inside the then-branch" $ do + -- The outer if's else is "e"; the inner if (B) has its own else "b2". + -- splitBranches must skip the inner {{#else}} (it's at depth 1) and + -- only mark the outer {{#else}} (at depth 0). + let mkVars a b = + Map.fromList [("a", VBool a), ("b", VBool b)] + renderTemplateText + "{{#if Eq a true}}a1{{#if Eq b true}}b1{{#else}}b2{{/if}}a2{{#else}}e{{/if}}" + (mkVars True True) + `shouldBe` Right "a1b1a2" + renderTemplateText + "{{#if Eq a true}}a1{{#if Eq b true}}b1{{#else}}b2{{/if}}a2{{#else}}e{{/if}}" + (mkVars True False) + `shouldBe` Right "a1b2a2" + renderTemplateText + "{{#if Eq a true}}a1{{#if Eq b true}}b1{{#else}}b2{{/if}}a2{{#else}}e{{/if}}" + (mkVars False True) + `shouldBe` Right "e" + + it "surfaces an UnterminatedIf from a nested block inside the taken branch" $ do + -- Outer if takes the then-branch; the inner {{#if B}} has no closing + -- token before the outer {{/if}}, so splitBranches consumes the outer + -- {{/if}} as the inner's match and reports the outer opener as + -- unterminated. The precise error is UnterminatedIf; line is the + -- opener that actually ran out of closers. + let vars = Map.fromList [("a", VBool True), ("b", VBool True)] + tpl = "{{#if Eq a true}}outer{{#if Eq b true}}inner{{/if}}" + case renderTemplateText tpl vars of + Right r -> expectationFailure ("expected UnterminatedIf, got " <> show r) + Left [UnterminatedIf _] -> pure () + Left other -> + expectationFailure ("expected [UnterminatedIf _], got " <> show other) + + it "reports UnterminatedIf on the opener line for a long preamble" $ do + -- Preamble of ten lines; opener on line 11; no {{/if}} at all. + let preamble = mconcat (replicate 10 "line\n") + tpl = preamble <> "{{#if Eq x true}}body\nmore body\n" + vars = Map.fromList [("x", VBool True)] + case renderTemplateText tpl vars of + Right _ -> expectationFailure "expected UnterminatedIf" + Left [UnterminatedIf lineNum] -> lineNum `shouldBe` 11 + Left other -> expectationFailure ("expected [UnterminatedIf 11], got " <> show other) + + it "handles an empty then-branch" $ do + let vars = Map.fromList [("x", VBool True)] + renderTemplateText "a{{#if Eq x true}}{{/if}}b" vars + `shouldBe` Right "ab" + + it "handles an if/else with both branches empty" $ do + let vars = Map.fromList [("x", VBool False)] + renderTemplateText "a{{#if Eq x true}}{{#else}}{{/if}}b" vars + `shouldBe` Right "ab" + + it "handles multiple top-level blocks back-to-back" $ do + let vars = Map.fromList [("a", VBool True), ("b", VBool False)] + renderTemplateText + "{{#if Eq a true}}A{{/if}}-{{#if Eq b true}}B{{/if}}-{{#if Eq a true}}A2{{/if}}" + vars + `shouldBe` Right "A--A2" + + it "interleaves {{var}} and {{#if}} on the same line" $ do + let vars = + Map.fromList + [ ("flag", VBool True), + ("name", VText "world") + ] + renderTemplateText + "pre {{name}} {{#if Eq flag true}}mid-{{name}}-mid{{/if}} post" + vars + `shouldBe` Right "pre world mid-world-mid post" + + describe "standalone-block whitespace trim" $ do + it "absorbs surrounding indentation and the trailing newline when opener is on its own line" $ do + let vars = Map.fromList [("flag", VBool True)] + tpl = "prev\n {{#if Eq flag true}}\n body\n {{/if}}\nnext\n" + renderTemplateText tpl vars `shouldBe` Right "prev\n body\nnext\n" + + it "absorbs the whole block's lines when the condition is false" $ do + let vars = Map.fromList [("flag", VBool False)] + tpl = "prev\n {{#if Eq flag true}}\n body\n {{/if}}\nnext\n" + renderTemplateText tpl vars `shouldBe` Right "prev\nnext\n" + + it "leaves a compact tag surrounded by content untouched" $ do + -- Opener and closer are not standalone: both share a line + -- with template content. No trim should apply. + let vars = Map.fromList [("x", VBool True)] + renderTemplateText "a{{#if Eq x true}}b{{/if}}c" vars + `shouldBe` Right "abc" + + it "treats a tag with leading/trailing whitespace on its line as standalone" $ do + let vars = Map.fromList [("flag", VBool True)] + -- Tab + {{#if}} + trailing spaces + newline, all standalone. + tpl = "prev\n\t{{#if Eq flag true}} \nbody\n\t{{/if}} \nnext" + renderTemplateText tpl vars `shouldBe` Right "prev\nbody\nnext" + + it "handles standalone if/else with mixed branches" $ do + let tpl = + "outer\n\ + \{{#if Eq x true}}\n\ + \then-branch\n\ + \{{#else}}\n\ + \else-branch\n\ + \{{/if}}\n\ + \tail\n" + renderTemplateText tpl (Map.fromList [("x", VBool True)]) + `shouldBe` Right "outer\nthen-branch\ntail\n" + renderTemplateText tpl (Map.fromList [("x", VBool False)]) + `shouldBe` Right "outer\nelse-branch\ntail\n" + + it "preserves indentation of body lines when tags are standalone" $ do + let vars = Map.fromList [("flag", VBool True)] + tpl = + "foo = [\n\ + \ a\n\ + \ {{#if Eq flag true}}\n\ + \ b\n\ + \ {{/if}}\n\ + \ c\n\ + \];\n" + renderTemplateText tpl vars + `shouldBe` Right "foo = [\n a\n b\n c\n];\n" + + it "treats a standalone tag at end of template (no trailing newline) as standalone" $ do + let vars = Map.fromList [("flag", VBool True)] + tpl = "prev\n {{#if Eq flag true}}\n body\n {{/if}}" + renderTemplateText tpl vars `shouldBe` Right "prev\n body\n" + + it "preserves an explicit blank line inside a standalone block" $ do + -- A blank line immediately after {{#if}} is NOT consumed by + -- the opener's trim (only ONE newline is absorbed). This lets + -- template authors emit an intentional blank separator. + let vars = Map.fromList [("x", VBool True)] + tpl = "alpha\n{{#if Eq x true}}\n\nbeta\n{{/if}}\ngamma\n" + renderTemplateText tpl vars `shouldBe` Right "alpha\n\nbeta\ngamma\n" + + it "handles nested standalone blocks" $ do + let vars = Map.fromList [("a", VBool True), ("b", VBool True)] + tpl = + "head\n\ + \{{#if Eq a true}}\n\ + \outer\n\ + \{{#if Eq b true}}\n\ + \inner\n\ + \{{/if}}\n\ + \outer-tail\n\ + \{{/if}}\n\ + \tail\n" + renderTemplateText tpl vars + `shouldBe` Right "head\nouter\ninner\nouter-tail\ntail\n" diff --git a/test/Seihou/Engine/ValidateSpec.hs b/test/Seihou/Engine/ValidateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Engine/ValidateSpec.hs @@ -0,0 +1,491 @@ +module Seihou.Engine.ValidateSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Engine.Validate +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Engine.Validate" spec + +-- | A well-formed module for validation tests. +goodModule :: Module +goodModule = + Module + { name = "test-module", + version = Just "1.0.0", + description = Just "A test module", + vars = + [ VarDecl + { name = "project.name", + type_ = VTText, + default_ = Nothing, + description = Just "Project name", + required = True, + validation = Nothing + } + ], + exports = [VarExport {var = "project.name", alias = Nothing}], + prompts = [Prompt {var = "project.name", text = "Name?", condition = Nothing, choices = Nothing}], + steps = + [ Step + { strategy = Template, + src = "README.md.tpl", + dest = "README.md", + condition = Nothing, + patch = Nothing + } + ], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + +-- | A module with multiple validation errors. +badModule :: Module +badModule = + Module + { name = "BadName", + version = Nothing, + description = Nothing, + vars = + [ VarDecl "x" VTText Nothing Nothing True Nothing, + VarDecl "x" VTBool Nothing Nothing False Nothing + ], + exports = [VarExport {var = "nonexistent", alias = Nothing}], + prompts = [Prompt {var = "undeclared", text = "?", condition = Nothing, choices = Nothing}], + steps = [Step Template "missing.tpl" "/absolute/path" Nothing Nothing], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + +-- | Helper to update Module fields without ambiguity. +withVars :: [VarDecl] -> Module -> Module +withVars v m = Module m.name m.version m.description v m.exports m.prompts m.steps m.commands m.dependencies m.removal m.migrations + +withSteps :: [Step] -> Module -> Module +withSteps s m = Module m.name m.version m.description m.vars m.exports m.prompts s m.commands m.dependencies m.removal m.migrations + +withPrompts :: [Prompt] -> Module -> Module +withPrompts p m = Module m.name m.version m.description m.vars m.exports p m.steps m.commands m.dependencies m.removal m.migrations + +withCommands :: [Command] -> Module -> Module +withCommands c m = Module m.name m.version m.description m.vars m.exports m.prompts m.steps c m.dependencies m.removal m.migrations + +withVarsAndPrompts :: [VarDecl] -> [Prompt] -> Module -> Module +withVarsAndPrompts v p m = Module m.name m.version m.description v m.exports p m.steps m.commands m.dependencies m.removal m.migrations + +-- | Helper: check if any DiagCheck has the given label and non-empty details. +hasFailedCheck :: T.Text -> [DiagCheck] -> Bool +hasFailedCheck label = any (\c -> c.diagLabel == label && not (null (c.diagDetails))) + +-- | Helper: check if any DiagCheck has the given label and empty details (pass). +hasPassedCheck :: T.Text -> [DiagCheck] -> Bool +hasPassedCheck label = any (\c -> c.diagLabel == label && null (c.diagDetails)) + +-- | Helper: count checks with non-empty details of a given severity. +countFailures :: DiagSeverity -> [DiagCheck] -> Int +countFailures sev = length . filter (\c -> c.diagSeverity == sev && not (null (c.diagDetails))) + +spec :: Spec +spec = do + describe "buildReport" $ do + it "produces all-pass checks for a valid module" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport False tmpDir goodModule + report.reportDhallOk `shouldBe` True + reportHasErrors report `shouldBe` False + countFailures DiagError report.reportChecks `shouldBe` 0 + + it "detects module name format errors" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Module name format" report.reportChecks `shouldBe` True + + it "detects duplicate variable names" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Unique variable names" report.reportChecks `shouldBe` True + + it "detects export referencing undeclared variable" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Export references" report.reportChecks `shouldBe` True + + it "detects prompt referencing undeclared variable" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Prompt references" report.reportChecks `shouldBe` True + + it "detects missing source files" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Source file existence" report.reportChecks `shouldBe` True + + it "detects unsafe step destinations" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Safe step destinations" report.reportChecks `shouldBe` True + + it "detects missing module version" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + hasFailedCheck "Module version declared" report.reportChecks `shouldBe` True + + it "passes when module has a version" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport False tmpDir goodModule + hasPassedCheck "Module version declared" report.reportChecks `shouldBe` True + + it "reports multiple errors at once" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + reportHasErrors report `shouldBe` True + countFailures DiagError report.reportChecks `shouldSatisfy` (>= 5) + + it "does not include lint checks when lint is False" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport False tmpDir goodModule + let hasWarning = any (\c -> c.diagSeverity == DiagWarning) report.reportChecks + hasWarning `shouldBe` False + + it "includes lint checks when lint is True" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport True tmpDir goodModule + let hasWarning = any (\c -> c.diagSeverity == DiagWarning) report.reportChecks + hasWarning `shouldBe` True + + describe "lint checks" $ do + it "detects unused variables" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = + withVars + [ VarDecl "project.name" VTText Nothing (Just "Name") True Nothing, + VarDecl "unused.var" VTText Nothing (Just "Unused") False Nothing + ] + goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Unused variables" report.reportChecks `shouldBe` True + let details = concatMap (.diagDetails) $ filter (\c -> c.diagLabel == "Unused variables") report.reportChecks + any (T.isInfixOf "unused.var") details `shouldBe` True + + it "does not flag used variables as unused" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport True tmpDir goodModule + hasFailedCheck "Unused variables" report.reportChecks `shouldBe` False + + it "detects required variables without prompts" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = + withVarsAndPrompts + [VarDecl "project.name" VTText Nothing (Just "Name") True Nothing] + [] + goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Required variables without prompts" report.reportChecks `shouldBe` True + + it "does not flag required variables that have prompts" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport True tmpDir goodModule + hasFailedCheck "Required variables without prompts" report.reportChecks `shouldBe` False + + it "detects duplicate step destinations" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "a.tpl") "stub" + writeFile (tmpDir "files" "b.tpl") "stub" + let m = + withSteps + [ Step Template "a.tpl" "out.txt" Nothing Nothing, + Step Template "b.tpl" "out.txt" Nothing Nothing + ] + goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Duplicate step destinations" report.reportChecks `shouldBe` True + + it "does not flag patch ops as duplicate destinations" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "a.tpl") "stub" + writeFile (tmpDir "files" "b.tpl") "stub" + let m = + withSteps + [ Step Template "a.tpl" "out.txt" Nothing Nothing, + Step Template "b.tpl" "out.txt" Nothing (Just AppendFile) + ] + goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Duplicate step destinations" report.reportChecks `shouldBe` False + + it "detects empty choice lists" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = + withVars + [VarDecl "pick" (VTChoice []) Nothing (Just "Pick") True Nothing] + goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Empty choice lists" report.reportChecks `shouldBe` True + + it "detects missing variable descriptions" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = + withVars + [VarDecl "project.name" VTText Nothing Nothing True Nothing] + goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Missing variable descriptions" report.reportChecks `shouldBe` True + + it "does not flag variables with descriptions" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport True tmpDir goodModule + hasFailedCheck "Missing variable descriptions" report.reportChecks `shouldBe` False + + describe "conditional lint" $ do + -- Base vars: keep project.name (referenced by goodModule's export/prompt) + -- and add a bool feature flag for the comparison tests. + let baseVars = + [ VarDecl "project.name" VTText Nothing (Just "Name") True Nothing, + VarDecl "feature.on" VTBool Nothing (Just "Feature flag") False Nothing + ] + stepWithCondition cond = + withSteps + [Step Template "README.md.tpl" "README.md" cond Nothing] + (withVars baseVars goodModule) + + it "flags a bool variable compared against a string literal in a when clause" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = stepWithCondition (Just (ExprEq "feature.on" (VText "true"))) + report <- buildReport True tmpDir m + hasFailedCheck "Conditional comparison types" report.reportChecks `shouldBe` True + reportHasErrors report `shouldBe` True + let details = + concatMap (.diagDetails) $ + filter (\c -> c.diagLabel == "Conditional comparison types") report.reportChecks + any (T.isInfixOf "feature.on") details `shouldBe` True + any (T.isInfixOf "bareword true") details `shouldBe` True + + it "does not flag a bool variable compared against a bareword true" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = stepWithCondition (Just (ExprEq "feature.on" (VBool True))) + report <- buildReport True tmpDir m + hasFailedCheck "Conditional comparison types" report.reportChecks `shouldBe` False + hasPassedCheck "Conditional comparison types" report.reportChecks `shouldBe` True + + it "flags a when clause referencing an undeclared variable" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = stepWithCondition (Just (ExprIsSet "nix.treefmtt")) + report <- buildReport True tmpDir m + hasFailedCheck "Conditional variable references" report.reportChecks `shouldBe` True + let details = + concatMap (.diagDetails) $ + filter (\c -> c.diagLabel == "Conditional variable references") report.reportChecks + any (T.isInfixOf "nix.treefmtt") details `shouldBe` True + + it "passes both conditional checks for a correct module" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = stepWithCondition (Just (ExprEq "feature.on" (VBool True))) + report <- buildReport True tmpDir m + hasPassedCheck "Conditional variable references" report.reportChecks `shouldBe` True + hasPassedCheck "Conditional comparison types" report.reportChecks `shouldBe` True + + it "does not run conditional checks when lint is False" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = stepWithCondition (Just (ExprEq "feature.on" (VText "true"))) + report <- buildReport False tmpDir m + any (\c -> c.diagLabel == "Conditional comparison types") report.reportChecks + `shouldBe` False + reportHasErrors report `shouldBe` False + + it "flags an undeclared variable referenced in a template {{#if}} conditional" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile + (tmpDir "files" "README.md.tpl") + "{{#if Eq ghost true}}\nhi\n{{/if}}\n" + let m = withVars baseVars goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Conditional variable references" report.reportChecks `shouldBe` True + let details = + concatMap (.diagDetails) $ + filter (\c -> c.diagLabel == "Conditional variable references") report.reportChecks + any (T.isInfixOf "ghost") details `shouldBe` True + any (T.isInfixOf "README.md.tpl") details `shouldBe` True + + it "flags a bool var compared to a string literal inside a template {{#if}}" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile + (tmpDir "files" "README.md.tpl") + "{{#if Eq feature.on \"true\"}}\nhi\n{{/if}}\n" + let m = withVars baseVars goodModule + report <- buildReport True tmpDir m + hasFailedCheck "Conditional comparison types" report.reportChecks `shouldBe` True + + describe "renderReportPlain" $ do + it "renders a valid module report with check marks" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport False tmpDir goodModule + let rendered = renderReportPlain report + T.isInfixOf "\x2713 module.dhall evaluates successfully" rendered `shouldBe` True + T.isInfixOf "\x2713 Module name: test-module" rendered `shouldBe` True + T.isInfixOf "Module 'test-module' is valid." rendered `shouldBe` True + + it "renders an invalid module report with cross marks and error count" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + let rendered = renderReportPlain report + T.isInfixOf "\x2717 Module name format" rendered `shouldBe` True + T.isInfixOf "error(s) found. Module is invalid." rendered `shouldBe` True + + it "renders a Dhall-failure report" $ do + let report = + ValidateReport + { reportModule = goodModule, + reportPath = "/some/path", + reportDhallOk = False, + reportDhallError = Just "test error message", + reportChecks = [] + } + rendered = renderReportPlain report + T.isInfixOf "\x2717 module.dhall failed to evaluate" rendered `shouldBe` True + T.isInfixOf "test error message" rendered `shouldBe` True + T.isInfixOf "1 error(s) found. Module is invalid." rendered `shouldBe` True + + it "renders a Dhall-failure report without error details when absent" $ do + let report = + ValidateReport + { reportModule = goodModule, + reportPath = "/some/path", + reportDhallOk = False, + reportDhallError = Nothing, + reportChecks = [] + } + rendered = renderReportPlain report + T.isInfixOf "\x2717 module.dhall failed to evaluate" rendered `shouldBe` True + T.isInfixOf "1 error(s) found. Module is invalid." rendered `shouldBe` True + + it "renders lint warnings with warning symbol" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = + withVars + [ VarDecl "project.name" VTText Nothing (Just "Name") True Nothing, + VarDecl "unused" VTText Nothing (Just "Unused") False Nothing + ] + goodModule + report <- buildReport True tmpDir m + let rendered = renderReportPlain report + T.isInfixOf "\x26A0 Unused variables" rendered `shouldBe` True + + describe "reportHasErrors" $ do + it "returns False for a valid report" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + report <- buildReport False tmpDir goodModule + reportHasErrors report `shouldBe` False + + it "returns True for a report with errors" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + report <- buildReport False tmpDir badModule + reportHasErrors report `shouldBe` True + + it "returns False when only warnings are present" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = + withVars + [ VarDecl "project.name" VTText Nothing (Just "Name") True Nothing, + VarDecl "unused" VTText Nothing (Just "Unused") False Nothing + ] + goodModule + report <- buildReport True tmpDir m + reportHasErrors report `shouldBe` False + + it "returns True when Dhall failed" $ do + let report = + ValidateReport + { reportModule = goodModule, + reportPath = "/some/path", + reportDhallOk = False, + reportDhallError = Just "some dhall error", + reportChecks = [] + } + reportHasErrors report `shouldBe` True + + describe "command safety" $ do + it "passes for valid commands" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = withCommands [Command "echo hello" Nothing Nothing] goodModule + report <- buildReport False tmpDir m + hasPassedCheck "Command safety" report.reportChecks `shouldBe` True + + it "fails for empty command text" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = withCommands [Command " " Nothing Nothing] goodModule + report <- buildReport False tmpDir m + hasFailedCheck "Command safety" report.reportChecks `shouldBe` True + + it "fails for absolute workDir" $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = withCommands [Command "echo hi" (Just "/usr/local") Nothing] goodModule + report <- buildReport False tmpDir m + hasFailedCheck "Command safety" report.reportChecks `shouldBe` True + + it "fails for workDir containing .." $ do + withSystemTempDirectory "seihou-validate" $ \tmpDir -> do + createDirectoryIfMissing True (tmpDir "files") + writeFile (tmpDir "files" "README.md.tpl") "stub" + let m = withCommands [Command "echo hi" (Just "../escape") Nothing] goodModule + report <- buildReport False tmpDir m + hasFailedCheck "Command safety" report.reportChecks `shouldBe` True diff --git a/test/Seihou/Evaluation/ConditionalTemplateSpec.hs b/test/Seihou/Evaluation/ConditionalTemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Evaluation/ConditionalTemplateSpec.hs @@ -0,0 +1,82 @@ +module Seihou.Evaluation.ConditionalTemplateSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Engine.Plan (compilePlan) +import Seihou.Engine.Template (renderTemplate) +import System.Directory (getCurrentDirectory) +import System.FilePath (takeDirectory, ()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Evaluation.ConditionalTemplate" spec + +-- | Variable set shared by both postgres on/off runs. +commonVars :: Map.Map VarName VarValue +commonVars = + Map.fromList + [ ("project.name", VText "demo-app"), + ("project.description", VText "A demo Haskell application"), + ("ghc.version", VText "ghc912"), + ("nix.process-compose", VBool True) + ] + +fixtureDir :: IO FilePath +fixtureDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures" "evaluation" "conditional-template-flake") + +splitFlakeBaseline :: FilePath -> Map.Map VarName VarValue -> IO Text +splitFlakeBaseline tplName vars = do + cwd <- getCurrentDirectory + raw <- + TIO.readFile + ( cwd + "test" + "fixtures" + "evaluation" + "split-flake" + "files" + tplName + ) + case renderTemplate raw vars of + Left errs -> fail ("renderTemplate failed: " <> show errs) + Right t -> pure t + +spec :: Spec +spec = do + describe "conditional-template-flake fixture (compilePlan)" $ do + it "with nix.postgresql = false, emits bytes identical to the non-postgres split-flake baseline" $ do + base <- fixtureDir + Right modul <- loadModule [takeDirectory base] "conditional-template-flake" + let vars = Map.insert "nix.postgresql" (VBool False) commonVars + planResult <- compilePlan base modul vars + case planResult of + Left errs -> expectationFailure ("compilePlan failed: " <> show errs) + Right ops -> do + let writeOps = [op | op@WriteFileOp {} <- ops] + writeOps `shouldSatisfy` (\xs -> length xs == 1) + let op = writeOps !! 0 + op.dest `shouldBe` "flake.nix" + expected <- splitFlakeBaseline "flake.nix.tpl" vars + op.content `shouldBe` expected + + it "with nix.postgresql = true, emits bytes identical to the postgres split-flake baseline" $ do + base <- fixtureDir + Right modul <- loadModule [takeDirectory base] "conditional-template-flake" + let vars = Map.insert "nix.postgresql" (VBool True) commonVars + planResult <- compilePlan base modul vars + case planResult of + Left errs -> expectationFailure ("compilePlan failed: " <> show errs) + Right ops -> do + let writeOps = [op | op@WriteFileOp {} <- ops] + writeOps `shouldSatisfy` (\xs -> length xs == 1) + let op = writeOps !! 0 + op.dest `shouldBe` "flake.nix" + expected <- splitFlakeBaseline "flake-with-postgres.nix.tpl" vars + op.content `shouldBe` expected diff --git a/test/Seihou/Evaluation/DhallTextFlakeSpec.hs b/test/Seihou/Evaluation/DhallTextFlakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Evaluation/DhallTextFlakeSpec.hs @@ -0,0 +1,79 @@ +module Seihou.Evaluation.DhallTextFlakeSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Engine.Plan (compilePlan) +import Seihou.Engine.Template (renderTemplate) +import System.Directory (getCurrentDirectory) +import System.FilePath (takeDirectory, ()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Evaluation.DhallTextFlake" spec + +commonVars :: Map.Map VarName VarValue +commonVars = + Map.fromList + [ ("project.name", VText "demo-app"), + ("project.description", VText "A demo Haskell application"), + ("ghc.version", VText "ghc912"), + ("nix.process-compose", VBool True) + ] + +fixtureDir :: IO FilePath +fixtureDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures" "evaluation" "dhall-text-flake") + +splitFlakeDir :: IO FilePath +splitFlakeDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures" "evaluation" "split-flake") + +-- | Render one of the split-flake baseline templates to produce the expected +-- byte string that the Prototype A output must match. +renderSplitFlake :: FilePath -> Map.Map VarName VarValue -> IO Text +renderSplitFlake tplName vars = do + base <- splitFlakeDir + raw <- TIO.readFile (base "files" tplName) + case renderTemplate raw vars of + Left errs -> fail ("renderTemplate failed: " <> show errs) + Right t -> pure t + +spec :: Spec +spec = do + describe "dhall-text-flake fixture (Prototype A)" $ do + it "with nix.postgresql = false, produces bytes identical to the non-postgres baseline" $ do + base <- fixtureDir + Right modul <- loadModule [takeDirectory base] "dhall-text-flake" + let vars = Map.insert "nix.postgresql" (VBool False) commonVars + planResult <- compilePlan base modul vars + case planResult of + Left errs -> expectationFailure ("compilePlan failed: " <> show errs) + Right ops -> do + let writeOps = [op | op@WriteFileOp {} <- ops] + writeOps `shouldSatisfy` (\xs -> length xs == 1) + let op = writeOps !! 0 + op.dest `shouldBe` "flake.nix" + expected <- renderSplitFlake "flake.nix.tpl" vars + op.content `shouldBe` expected + + it "with nix.postgresql = true, produces bytes identical to the postgres baseline" $ do + base <- fixtureDir + Right modul <- loadModule [takeDirectory base] "dhall-text-flake" + let vars = Map.insert "nix.postgresql" (VBool True) commonVars + planResult <- compilePlan base modul vars + case planResult of + Left errs -> expectationFailure ("compilePlan failed: " <> show errs) + Right ops -> do + let writeOps = [op | op@WriteFileOp {} <- ops] + writeOps `shouldSatisfy` (\xs -> length xs == 1) + let op = writeOps !! 0 + op.dest `shouldBe` "flake.nix" + expected <- renderSplitFlake "flake-with-postgres.nix.tpl" vars + op.content `shouldBe` expected diff --git a/test/Seihou/Evaluation/SplitFlakeSpec.hs b/test/Seihou/Evaluation/SplitFlakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Evaluation/SplitFlakeSpec.hs @@ -0,0 +1,73 @@ +module Seihou.Evaluation.SplitFlakeSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Engine.Plan (compilePlan) +import Seihou.Engine.Template (renderTemplate) +import System.Directory (getCurrentDirectory) +import System.FilePath (takeDirectory, ()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Evaluation.SplitFlake" spec + +-- | Variable set common to both variants. +commonVars :: Map.Map VarName VarValue +commonVars = + Map.fromList + [ ("project.name", VText "demo-app"), + ("project.description", VText "A demo Haskell application"), + ("ghc.version", VText "ghc912"), + ("nix.process-compose", VBool True) + ] + +fixtureDir :: IO FilePath +fixtureDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures" "evaluation" "split-flake") + +renderFixtureFile :: FilePath -> Map.Map VarName VarValue -> IO Text +renderFixtureFile src vars = do + base <- fixtureDir + raw <- TIO.readFile (base "files" src) + case renderTemplate raw vars of + Left errs -> fail ("renderTemplate failed: " <> show errs) + Right t -> pure t + +spec :: Spec +spec = do + describe "split-flake fixture" $ do + it "with nix.postgresql = false, emits the non-postgres flake verbatim" $ do + base <- fixtureDir + Right modul <- loadModule [takeDirectory base] "split-flake" + let vars = Map.insert "nix.postgresql" (VBool False) commonVars + planResult <- compilePlan base modul vars + case planResult of + Left errs -> expectationFailure ("compilePlan failed: " <> show errs) + Right ops -> do + let writeOps = [op | op@WriteFileOp {} <- ops] + writeOps `shouldSatisfy` (\xs -> length xs == 1) + let op = writeOps !! 0 + op.dest `shouldBe` "flake.nix" + expected <- renderFixtureFile "flake.nix.tpl" vars + op.content `shouldBe` expected + + it "with nix.postgresql = true, emits the postgres flake verbatim" $ do + base <- fixtureDir + Right modul <- loadModule [takeDirectory base] "split-flake" + let vars = Map.insert "nix.postgresql" (VBool True) commonVars + planResult <- compilePlan base modul vars + case planResult of + Left errs -> expectationFailure ("compilePlan failed: " <> show errs) + Right ops -> do + let writeOps = [op | op@WriteFileOp {} <- ops] + writeOps `shouldSatisfy` (\xs -> length xs == 1) + let op = writeOps !! 0 + op.dest `shouldBe` "flake.nix" + expected <- renderFixtureFile "flake-with-postgres.nix.tpl" vars + op.content `shouldBe` expected diff --git a/test/Seihou/Evaluation/TypedDhallTextSpec.hs b/test/Seihou/Evaluation/TypedDhallTextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Evaluation/TypedDhallTextSpec.hs @@ -0,0 +1,110 @@ +module Seihou.Evaluation.TypedDhallTextSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Types +import Seihou.Engine.Template (renderTemplate) +import Seihou.Engine.TypedDhallText (fieldNameFor, renderTypedDhallText) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Evaluation.TypedDhallText" spec + +commonVars :: Map.Map VarName VarValue +commonVars = + Map.fromList + [ ("project.name", VText "demo-app"), + ("project.description", VText "A demo Haskell application"), + ("ghc.version", VText "ghc912"), + ("nix.process-compose", VBool True) + ] + +fixtureSource :: IO FilePath +fixtureSource = do + cwd <- getCurrentDirectory + pure + ( cwd + "test" + "fixtures" + "evaluation" + "typed-dhall-text-flake" + "files" + "flake.nix.dhall" + ) + +splitFlakeDir :: IO FilePath +splitFlakeDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures" "evaluation" "split-flake") + +renderSplitFlake :: FilePath -> Map.Map VarName VarValue -> IO Text +renderSplitFlake tplName vars = do + base <- splitFlakeDir + raw <- TIO.readFile (base "files" tplName) + case renderTemplate raw vars of + Left errs -> fail ("renderTemplate failed: " <> show errs) + Right t -> pure t + +spec :: Spec +spec = do + describe "fieldNameFor" $ do + it "replaces dots with underscores" $ + fieldNameFor "project.name" `shouldBe` "project_name" + + it "replaces dashes with underscores" $ + fieldNameFor "nix.process-compose" `shouldBe` "nix_process_compose" + + describe "typed-dhall-text-flake fixture (Prototype B)" $ do + it "with nix.postgresql = false, produces bytes identical to the non-postgres baseline" $ do + src <- fixtureSource + let vars = Map.insert "nix.postgresql" (VBool False) commonVars + result <- renderTypedDhallText src vars + case result of + Left err -> expectationFailure ("renderTypedDhallText failed: " <> T.unpack err) + Right txt -> do + expected <- renderSplitFlake "flake.nix.tpl" vars + txt `shouldBe` expected + + it "with nix.postgresql = true, produces bytes identical to the postgres baseline" $ do + src <- fixtureSource + let vars = Map.insert "nix.postgresql" (VBool True) commonVars + result <- renderTypedDhallText src vars + case result of + Left err -> expectationFailure ("renderTypedDhallText failed: " <> T.unpack err) + Right txt -> do + expected <- renderSplitFlake "flake-with-postgres.nix.tpl" vars + txt `shouldBe` expected + + it "reports a field-name typo with the offending field in the error message" $ do + -- Seed a typo: the source says nix_postgres but the record provides + -- nix_postgresql. Dhall must report the mismatch mentioning one of them. + withSystemTempDirectory "seihou-typed-dhall" $ \tmp -> do + let typoSrc = tmp "typo.dhall" + typoSource = + T.unlines + [ "\\(vars :", + " { project_name : Text", + " , project_description : Text", + " , ghc_version : Text", + " , nix_process_compose : Bool", + " , nix_postgres : Bool", + " }", + " ) ->", + " \"${vars.project_name} ${vars.ghc_version}\"" + ] + TIO.writeFile typoSrc typoSource + let vars = Map.insert "nix.postgresql" (VBool False) commonVars + result <- renderTypedDhallText typoSrc vars + case result of + Right _ -> expectationFailure "Expected a Dhall type error" + Left err -> do + -- The error text must mention either the missing field name from + -- the lambda type annotation or the extra field on the record. + T.isInfixOf "nix_postgres" err `shouldBe` True diff --git a/test/Seihou/Integration/CompositionSpec.hs b/test/Seihou/Integration/CompositionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Integration/CompositionSpec.hs @@ -0,0 +1,275 @@ +module Seihou.Integration.CompositionSpec (tests) where + +import Data.Either (isLeft) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Seihou.Composition.Graph (buildGraph, topoSort) +import Seihou.Composition.Instance (ModuleInstance (..), primaryInstance) +import Seihou.Composition.Plan (compileComposedPlan) +import Seihou.Composition.Resolve (loadComposition, resolveComposedVariables) +import Seihou.Core.Types +import System.FilePath (()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Integration.Composition" spec + +fixtureDir :: FilePath +fixtureDir = "test/fixtures" + +spec :: Spec +spec = do + describe "loadComposition" $ do + it "loads haskell-with-nix with all four modules" $ do + result <- loadComposition [fixtureDir] "haskell-with-nix" [] + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right modules -> do + let names = map (\(_, m, _) -> m.name) modules + length names `shouldBe` 4 + -- All four modules should be present + elem "nix-base" names `shouldBe` True + elem "haskell-base" names `shouldBe` True + elem "nix-flake" names `shouldBe` True + elem "haskell-with-nix" names `shouldBe` True + + it "orders dependencies before dependents" $ do + result <- loadComposition [fixtureDir] "haskell-with-nix" [] + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right modules -> do + let names = map (\(_, m, _) -> m.name) modules + indexOf n = case lookup n (zip names [0 :: Int ..]) of + Just i -> i + Nothing -> error $ "Module not found: " ++ show n + -- nix-base before nix-flake + indexOf "nix-base" `shouldSatisfy` (< indexOf "nix-flake") + -- haskell-base before haskell-with-nix + indexOf "haskell-base" `shouldSatisfy` (< indexOf "haskell-with-nix") + -- nix-flake before haskell-with-nix + indexOf "nix-flake" `shouldSatisfy` (< indexOf "haskell-with-nix") + -- haskell-with-nix should be last + indexOf "haskell-with-nix" `shouldBe` 3 + + it "loads a single module with no dependencies" $ do + result <- loadComposition [fixtureDir] "nix-base" [] + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right modules -> do + length modules `shouldBe` 1 + case modules of + [(_, m, _)] -> m.name `shouldBe` "nix-base" + _ -> expectationFailure "Expected exactly one module" + + it "handles additional modules via --module flag" $ do + result <- loadComposition [fixtureDir] "haskell-base" ["nix-base"] + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right modules -> do + let names = map (\(_, m, _) -> m.name) modules + length names `shouldBe` 2 + elem "haskell-base" names `shouldBe` True + elem "nix-base" names `shouldBe` True + + it "returns error for nonexistent dependency" $ do + result <- loadComposition [fixtureDir] "haskell-with-nix" ["nonexistent"] + result `shouldSatisfy` isLeft + + describe "resolveComposedVariables" $ do + it "flows nix.system from nix-base to nix-flake" $ do + result <- loadComposition [fixtureDir] "nix-flake" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Resolve failed: " ++ show errs + Right resolved -> do + let flakeVars = resolved Map.! primaryInstance "nix-flake" + -- nix-flake should see nix.system from nix-base's export + (.value) (flakeVars Map.! "nix.system") `shouldBe` VText "x86_64-linux" + -- nix-flake should also have its own variable + (.value) (flakeVars Map.! "nix.description") `shouldBe` VText "A Nix project" + + it "flows exports through diamond dependency" $ do + result <- loadComposition [fixtureDir] "haskell-with-nix" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + let cliOverrides = Map.singleton "project.name" "my-app" + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Resolve failed: " ++ show errs + Right resolved -> do + -- haskell-base should have project.name from CLI + let baseVars = resolved Map.! primaryInstance "haskell-base" + (.value) (baseVars Map.! "project.name") `shouldBe` VText "my-app" + -- haskell-with-nix should inherit project.name via haskell-base's export + let topVars = resolved Map.! primaryInstance "haskell-with-nix" + Map.member "project.name" topVars `shouldBe` True + (.value) (topVars Map.! "project.name") `shouldBe` VText "my-app" + + describe "compileComposedPlan" $ do + it "produces operations from all composed modules" $ do + result <- loadComposition [fixtureDir] "haskell-with-nix" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + let cliOverrides = Map.singleton "project.name" "my-app" + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Resolve failed: " ++ show errs + Right resolved -> do + let quads = + [ (inst, m, dir, Map.map (.value) (resolved Map.! inst)) + | (inst, m, dir) <- modules + ] + planResult <- compileComposedPlan quads + case planResult of + Left errs -> expectationFailure $ "Plan failed: " ++ show errs + Right (ops, warnings, _) -> do + -- Should have operations for shell.nix, flake.nix, README.md, + -- src/Lib.hs, LICENSE, *.cabal, cabal.project, Makefile (+ dirs) + let writeOps = [d | WriteFileOp d _ _ <- ops] + elem "shell.nix" writeOps `shouldBe` True + elem "flake.nix" writeOps `shouldBe` True + elem "Makefile" writeOps `shouldBe` True + elem "README.md" writeOps `shouldBe` True + + describe "text patching integration" $ do + it "haskell-shared-readme appends section to haskell-base README" $ do + result <- loadComposition [fixtureDir] "haskell-shared-readme" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + let cliOverrides = Map.singleton "project.name" "my-app" + case resolveComposedVariables modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Resolve failed: " ++ show errs + Right resolved -> do + let quads = + [ (inst, m, dir, Map.map (.value) (resolved Map.! inst)) + | (inst, m, dir) <- modules + ] + planResult <- compileComposedPlan quads + case planResult of + Left errs -> expectationFailure $ "Plan failed: " ++ show errs + Right (ops, warnings, _) -> do + -- Find the merged README.md + let readmeOps = [content | WriteFileOp dest content _ <- ops, dest == "README.md"] + length readmeOps `shouldBe` 1 + let readmeContent = head readmeOps + -- Should contain the base content from haskell-base + T.isInfixOf "# my-app" readmeContent `shouldBe` True + -- Should contain the patched section from haskell-shared-readme + T.isInfixOf "Additional Section" readmeContent `shouldBe` True + T.isInfixOf "seihou:haskell-shared-readme" readmeContent `shouldBe` True + -- Should have a ContentMerged warning + any isContentMerged warnings `shouldBe` True + + describe "structured merge integration" $ do + it "two modules contributing to same JSON get deep-merged" $ do + result <- loadComposition [fixtureDir] "structured-merge-b" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Resolve failed: " ++ show errs + Right resolved -> do + let quads = + [ (inst, m, dir, Map.map (.value) (resolved Map.! inst)) + | (inst, m, dir) <- modules + ] + planResult <- compileComposedPlan quads + case planResult of + Left errs -> expectationFailure $ "Plan failed: " ++ show errs + Right (ops, warnings, _) -> do + -- Find the merged config.json + let configOps = [content | WriteFileOp dest content _ <- ops, dest == "config.json"] + length configOps `shouldBe` 1 + let configContent = head configOps + -- Should contain keys from module A + T.isInfixOf "name" configContent `shouldBe` True + T.isInfixOf "my-project" configContent `shouldBe` True + -- Should contain keys from module B + T.isInfixOf "debug" configContent `shouldBe` True + T.isInfixOf "logLevel" configContent `shouldBe` True + -- Should have a ContentMerged warning + any isContentMerged warnings `shouldBe` True + + describe "multi-instantiation diamond" $ do + -- These three fixtures (multi-instance-helper/leaf/diamond) model the + -- agent-seihou master-plan pattern: a parent depends on a leaf that + -- binds the helper one way, and also directly on the helper bound + -- the other way. Before ExecPlan 10, only one invocation survived. + it "loadComposition produces two helper instances with different bindings" $ do + result <- loadComposition [fixtureDir] "multi-instance-diamond" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + -- Expect: helper (skill.name=diamond), helper (skill.name=leaf), + -- leaf, diamond — four entries total. + length modules `shouldBe` 4 + let helperInstances = + [ inst + | (inst, m, _) <- modules, + m.name == "multi-instance-helper" + ] + length helperInstances `shouldBe` 2 + let bindings = + Map.fromList + [ ("diamond" :: Text, True), + ("leaf", True) + ] + haveSkill vn = + any + ( \inst -> + Map.lookup "skill.name" inst.instanceParentVars.unParentVars == Just vn + ) + helperInstances + all haveSkill (Map.keys bindings) `shouldBe` True + + it "compileComposedPlan produces two helper output files with distinct names" $ do + result <- loadComposition [fixtureDir] "multi-instance-diamond" [] + case result of + Left err -> expectationFailure $ "Load failed: " ++ show err + Right modules -> do + case resolveComposedVariables modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure $ "Resolve failed: " ++ show errs + Right resolved -> do + let quads = + [ (inst, m, dir, Map.map (.value) (resolved Map.! inst)) + | (inst, m, dir) <- modules + ] + planResult <- compileComposedPlan quads + case planResult of + Left errs -> expectationFailure $ "Plan failed: " ++ show errs + Right (ops, _, _) -> do + let writeDests = [d | WriteFileOp d _ _ <- ops] + elem "out/leaf.txt" writeDests `shouldBe` True + elem "out/diamond.txt" writeDests `shouldBe` True + + describe "cycle detection" $ do + it "detects a circular dependency" $ do + let mkMod name deps = + Module + { name = name, + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = map simpleDep deps, + removal = Nothing, + migrations = [] + } + a = mkMod "a" ["b"] + b = mkMod "b" ["c"] + c = mkMod "c" ["a"] + graph = buildGraph [(primaryInstance m.name, m) | m <- [a, b, c]] + topoSort graph `shouldSatisfy` isLeft + +isContentMerged :: CompositionWarning -> Bool +isContentMerged (ContentMerged {}) = True +isContentMerged _ = False diff --git a/test/Seihou/Integration/ExecutionSpec.hs b/test/Seihou/Integration/ExecutionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Integration/ExecutionSpec.hs @@ -0,0 +1,200 @@ +module Seihou.Integration.ExecutionSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Core.Variable (resolveVariables) +import Seihou.Effect.FilesystemPure (PureFS (..), emptyFS, runFilesystemPure) +import Seihou.Engine.Diff (computeDiff) +import Seihou.Engine.Execute (dryRunPlan, executePlan) +import Seihou.Engine.Plan (compilePlan) +import Seihou.Manifest.Types (emptyManifest) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Integration.Execution" spec + +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +fixtureDir :: IO FilePath +fixtureDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures") + +-- | Helper to extract the resolved variable values map. +resolvedValues :: Map.Map VarName ResolvedVar -> Map.Map VarName VarValue +resolvedValues = Map.map (.value) + +-- | Load haskell-base fixture, resolve vars, compile plan. +compileFixturePlan :: [(Text, Text)] -> IO (Module, [Operation]) +compileFixturePlan vars = do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> error ("Failed to load module: " <> show err) + Right modul -> do + let cli = Map.fromList [(VarName k, v) | (k, v) <- vars] + env = Map.empty + case resolveVariables (modul.vars) cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> error ("Failed to resolve: " <> show errs) + Right resolved -> do + planResult <- compilePlan (fixtures "haskell-base") modul (resolvedValues resolved) + case planResult of + Left errs -> error ("Plan failed: " <> show errs) + Right ops -> pure (modul, ops) + +-- | Helper to create a manifest with file records (avoids ambiguous record update). +manifestWithFiles :: UTCTime -> Map.Map FilePath FileRecord -> Manifest +manifestWithFiles t recs = + let base = emptyManifest t + in Manifest + { version = base.version, + genAt = base.genAt, + modules = base.modules, + vars = base.vars, + files = recs + } + +-- | Extract planned files from operations for computeDiff. +extractPlanned :: ModuleName -> [Operation] -> [(FilePath, Text, ModuleName, Maybe PatchOp)] +extractPlanned modName' ops = + [(dest, content, modName', Nothing) | WriteFileOp dest content _ <- ops] + ++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- ops] + +spec :: Spec +spec = do + describe "full execution pipeline" $ do + it "first run creates files and builds file records" $ do + (modul, ops) <- compileFixturePlan [("project.name", "my-app")] + let modName = modul.name + (records, fs) = + runPureEff $ + runFilesystemPure emptyFS $ + executePlan "" ops Map.empty modName fixedTime + -- Verify files were created in the filesystem + Map.member "README.md" (fs.files) `shouldBe` True + Map.member "my-app.cabal" (fs.files) `shouldBe` True + Map.member "src/Lib.hs" (fs.files) `shouldBe` True + Map.member "LICENSE" (fs.files) `shouldBe` True + Map.member "cabal.project" (fs.files) `shouldBe` True + -- Verify FileRecords for manifest + Map.member "README.md" records `shouldBe` True + Map.member "my-app.cabal" records `shouldBe` True + Map.member "src/Lib.hs" records `shouldBe` True + -- Verify content + Map.lookup "README.md" (fs.files) `shouldBe` Just "# my-app\n\nVersion: 0.1.0.0\n" + + it "re-run with same plan shows all unchanged" $ do + (modul, ops) <- compileFixturePlan [("project.name", "my-app")] + let modName = modul.name + planned = extractPlanned modName ops + -- First run: execute to get filesystem state and records + (records, fs) = + runPureEff $ + runFilesystemPure emptyFS $ + executePlan "" ops Map.empty modName fixedTime + -- Build manifest from first run + manifest = manifestWithFiles fixedTime records + -- Re-run: compute diff against same plan and same FS + (diff, _) = + runPureEff $ + runFilesystemPure fs $ + computeDiff manifest (Set.singleton modName) planned + -- All files should be unchanged + length (diff.new) `shouldBe` 0 + length (diff.modified) `shouldBe` 0 + length (diff.conflicts) `shouldBe` 0 + length (diff.orphaned) `shouldBe` 0 + length (diff.unchanged) `shouldBe` 5 + + it "re-run with changed variable shows modified, new, and orphaned" $ do + (modul, ops1) <- compileFixturePlan [("project.name", "my-app")] + let modName = modul.name + -- First run + (records, fs) = + runPureEff $ + runFilesystemPure emptyFS $ + executePlan "" ops1 Map.empty modName fixedTime + manifest = manifestWithFiles fixedTime records + -- Compile with changed variable + (_, ops2) <- compileFixturePlan [("project.name", "other-app")] + let planned2 = extractPlanned modName ops2 + (diff, _) = + runPureEff $ + runFilesystemPure fs $ + computeDiff manifest (Set.singleton modName) planned2 + -- README.md and cabal.project have different content → Modified + length (diff.modified) `shouldBe` 2 + -- src/Lib.hs and LICENSE have same content → Unchanged + length (diff.unchanged) `shouldBe` 2 + -- my-app.cabal not in new plan → Orphaned + length (diff.orphaned) `shouldBe` 1 + (head diff.orphaned).path `shouldBe` "my-app.cabal" + -- other-app.cabal is new → New + length (diff.new) `shouldBe` 1 + (head diff.new).path `shouldBe` "other-app.cabal" + -- No conflicts + length (diff.conflicts) `shouldBe` 0 + + it "dryRunPlan lists all operations without execution" $ do + (_, ops) <- compileFixturePlan [("project.name", "my-app")] + let text = dryRunPlan ops + T.isInfixOf "README.md" text `shouldBe` True + T.isInfixOf "my-app.cabal" text `shouldBe` True + T.isInfixOf "cabal.project" text `shouldBe` True + + it "force mode: re-execute after user edit overwrites the file" $ do + (modul, ops) <- compileFixturePlan [("project.name", "my-app")] + let modName = modul.name + planned = extractPlanned modName ops + -- First run + (records, fs1) = + runPureEff $ + runFilesystemPure emptyFS $ + executePlan "" ops Map.empty modName fixedTime + manifest = manifestWithFiles fixedTime records + -- Simulate user editing README.md + fs2 = PureFS (Map.insert "README.md" "user edit" fs1.files) fs1.dirs + -- Compute diff → should detect conflict + (diff, _) = + runPureEff $ + runFilesystemPure fs2 $ + computeDiff manifest (Set.singleton modName) planned + -- README.md is a conflict (user edited, plan unchanged) + length (diff.conflicts) `shouldBe` 1 + (head diff.conflicts).path `shouldBe` "README.md" + -- Force: re-execute (overwrites user changes) + let (_, fs3) = + runPureEff $ + runFilesystemPure fs2 $ + executePlan "" ops Map.empty modName fixedTime + -- Verify README.md was overwritten with plan content + Map.lookup "README.md" fs3.files `shouldBe` Just "# my-app\n\nVersion: 0.1.0.0\n" + + it "records correct strategy per file in FileRecords" $ do + (modul, ops) <- compileFixturePlan [("project.name", "my-app")] + let modName = modul.name + (records, _) = + runPureEff $ + runFilesystemPure emptyFS $ + executePlan "" ops Map.empty modName fixedTime + -- README.md → Template + (records Map.! "README.md").strategy `shouldBe` Template + -- src/Lib.hs → Template + (records Map.! "src/Lib.hs").strategy `shouldBe` Template + -- LICENSE → Copy + (records Map.! "LICENSE").strategy `shouldBe` Copy + -- my-app.cabal → Template + (records Map.! "my-app.cabal").strategy `shouldBe` Template + -- cabal.project → DhallText + (records Map.! "cabal.project").strategy `shouldBe` DhallText diff --git a/test/Seihou/Integration/GenerationSpec.hs b/test/Seihou/Integration/GenerationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Integration/GenerationSpec.hs @@ -0,0 +1,146 @@ +module Seihou.Integration.GenerationSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Core.Variable (resolveVariables) +import Seihou.Engine.Plan (compilePlan) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Integration.Generation" spec + +fixtureDir :: IO FilePath +fixtureDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures") + +-- | Helper to extract the resolved variable values map. +resolvedValues :: Map.Map VarName ResolvedVar -> Map.Map VarName VarValue +resolvedValues = Map.map (.value) + +spec :: Spec +spec = do + describe "full pipeline: load, resolve, compile" $ do + it "produces correct README.md content" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + let cli = Map.fromList [("project.name", "my-app")] + env = Map.empty + case resolveVariables (modul.vars) cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure ("Failed to resolve: " <> show errs) + Right resolved -> do + planResult <- compilePlan (fixtures "haskell-base") modul (resolvedValues resolved) + case planResult of + Left errs -> expectationFailure ("Plan failed: " <> show errs) + Right ops -> do + let readmeOps = [op | op@(WriteFileOp d _ _) <- ops, d == "README.md"] + length readmeOps `shouldBe` 1 + let (WriteFileOp _ content _) = readmeOps !! 0 + content `shouldBe` "# my-app\n\nVersion: 0.1.0.0\n" + + it "produces correct cabal file with expanded destination" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + let cli = Map.fromList [("project.name", "my-app")] + env = Map.empty + case resolveVariables (modul.vars) cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure ("Failed to resolve: " <> show errs) + Right resolved -> do + planResult <- compilePlan (fixtures "haskell-base") modul (resolvedValues resolved) + case planResult of + Left errs -> expectationFailure ("Plan failed: " <> show errs) + Right ops -> do + let cabalOps = [op | op@(WriteFileOp d _ _) <- ops, d == "my-app.cabal"] + length cabalOps `shouldBe` 1 + let (WriteFileOp _ content _) = cabalOps !! 0 + T.isInfixOf "name: my-app" content `shouldBe` True + T.isInfixOf "version: 0.1.0.0" content `shouldBe` True + T.isInfixOf "license: MIT" content `shouldBe` True + + it "includes LICENSE step when license is set" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + let cli = Map.fromList [("project.name", "my-app")] + env = Map.empty + case resolveVariables (modul.vars) cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure ("Failed to resolve: " <> show errs) + Right resolved -> do + planResult <- compilePlan (fixtures "haskell-base") modul (resolvedValues resolved) + case planResult of + Left errs -> expectationFailure ("Plan failed: " <> show errs) + Right ops -> do + let licenseOps = [op | op@(WriteFileOp d _ _) <- ops, d == "LICENSE"] + length licenseOps `shouldBe` 1 + + it "excludes LICENSE step when license is not set" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + -- Provide all vars but use an empty var map for IsSet evaluation. + -- The real scenario: license has a default so it's always set. + -- To test the conditional, we use a stripped-down module with only the LICENSE step. + let licenseStep = Step Copy "LICENSE" "LICENSE" (Just (ExprIsSet "license")) Nothing + smallModule = modul {steps = [licenseStep]} + vars = Map.empty -- no license variable set + planResult <- compilePlan (fixtures "haskell-base") smallModule vars + case planResult of + Left errs -> expectationFailure ("Plan failed: " <> show errs) + Right ops -> do + let licenseOps = [op | op@(WriteFileOp d _ _) <- ops, d == "LICENSE"] + length licenseOps `shouldBe` 0 + + it "produces DhallText output for cabal.project" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + let cli = Map.fromList [("project.name", "my-app")] + env = Map.empty + case resolveVariables (modul.vars) cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure ("Failed to resolve: " <> show errs) + Right resolved -> do + planResult <- compilePlan (fixtures "haskell-base") modul (resolvedValues resolved) + case planResult of + Left errs -> expectationFailure ("Plan failed: " <> show errs) + Right ops -> do + let projectOps = [op | op@(WriteFileOp d _ _) <- ops, d == "cabal.project"] + length projectOps `shouldBe` 1 + let (WriteFileOp _ content _) = projectOps !! 0 + T.isInfixOf "my-app" content `shouldBe` True + + it "resolves variables from env and applies precedence" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Failed to load module: " <> show err) + Right modul -> do + -- CLI overrides project.name, env overrides license + let cli = Map.fromList [("project.name", "cli-app")] + env = Map.fromList [("SEIHOU_VAR_LICENSE", "BSD3")] + case resolveVariables (modul.vars) cli env "" "" Map.empty Map.empty Map.empty Map.empty Map.empty of + Left errs -> expectationFailure ("Failed to resolve: " <> show errs) + Right resolved -> do + (.value) (resolved Map.! "project.name") `shouldBe` VText "cli-app" + (.source) (resolved Map.! "project.name") `shouldBe` FromCLI + (.value) (resolved Map.! "license") `shouldBe` VText "BSD3" + (.source) (resolved Map.! "license") `shouldBe` FromEnv "SEIHOU_VAR_LICENSE" + (.value) (resolved Map.! "project.version") `shouldBe` VText "0.1.0.0" + (.source) (resolved Map.! "project.version") `shouldBe` FromDefault diff --git a/test/Seihou/Integration/ModuleLoadSpec.hs b/test/Seihou/Integration/ModuleLoadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Integration/ModuleLoadSpec.hs @@ -0,0 +1,118 @@ +module Seihou.Integration.ModuleLoadSpec (tests) where + +import Data.Map.Strict qualified as Map +import Effectful +-- Re-use the real loader for end-to-end tests +import Seihou.Core.Module (loadModule) +import Seihou.Core.Types +import Seihou.Effect.DhallEval (evalModuleFile) +import Seihou.Effect.DhallEvalInterp (runDhallEvalPure) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Integration.ModuleLoad" spec + +fixtureDir :: IO FilePath +fixtureDir = do + cwd <- getCurrentDirectory + pure (cwd "test" "fixtures") + +spec :: Spec +spec = do + describe "haskell-base end-to-end" $ do + it "loads with correct name, vars, steps, and prompt" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Expected Right, got: " <> show err) + Right m -> do + m.name `shouldBe` "haskell-base" + m.description `shouldBe` Just "A Haskell project template" + length (m.vars) `shouldBe` 3 + length (m.steps) `shouldBe` 5 + length (m.prompts) `shouldBe` 1 + m.dependencies `shouldBe` [] + + it "has correct variable declarations" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Expected Right, got: " <> show err) + Right m -> do + let vars = m.vars + let names = map ((.unVarName) . (.name)) vars + names `shouldBe` ["project.name", "project.version", "license"] + + let (projectName : projectVersion : license : _) = vars + projectName.required `shouldBe` True + projectName.default_ `shouldBe` Nothing + + projectVersion.default_ `shouldBe` Just (VText "0.1.0.0") + + license.default_ `shouldBe` Just (VText "MIT") + + it "has a when expression on the LICENSE step" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Expected Right, got: " <> show err) + Right m -> do + let steps = m.steps + let licenseStep = steps !! 2 + licenseStep.strategy `shouldBe` Copy + licenseStep.condition `shouldBe` Just (ExprIsSet "license") + + it "has a dest with placeholder variable" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "haskell-base" + case result of + Left err -> expectationFailure ("Expected Right, got: " <> show err) + Right m -> do + let cabalStep = m.steps !! 3 + cabalStep.dest `shouldBe` "{{project.name}}.cabal" + + describe "invalid-module" $ do + it "produces ValidationError with multiple violations" $ do + fixtures <- fixtureDir + result <- loadModule [fixtures] "invalid-module" + case result of + Left (ValidationError _ errs) -> do + length errs `shouldSatisfy` (>= 4) + Left other -> expectationFailure ("Expected ValidationError, got: " <> show other) + Right _ -> expectationFailure "Expected validation failure" + + describe "nonexistent module" $ do + it "produces ModuleNotFound" $ do + result <- loadModule ["/nonexistent"] "no-such-module" + case result of + Left (ModuleNotFound name _) -> + name.unModuleName `shouldBe` "no-such-module" + Left other -> expectationFailure ("Expected ModuleNotFound, got: " <> show other) + Right _ -> expectationFailure "Expected Left" + + describe "pure DhallEval interpreter" $ do + it "returns modules from the in-memory map" $ do + let testModule = + Module + { name = "test", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + modules = Map.fromList [("test/module.dhall", testModule)] + result <- runEff $ runDhallEvalPure modules $ do + evalModuleFile "test/module.dhall" + case result of + Left err -> expectationFailure ("Expected Right, got: " <> show err) + Right m -> m.name `shouldBe` "test" diff --git a/test/Seihou/Interaction/ConfirmSpec.hs b/test/Seihou/Interaction/ConfirmSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Interaction/ConfirmSpec.hs @@ -0,0 +1,172 @@ +module Seihou.Interaction.ConfirmSpec (tests) where + +import Data.Map.Strict qualified as Map +import Effectful +import Seihou.Composition.Instance (primaryInstance) +import Seihou.Core.Types +import Seihou.Effect.ConsolePure +import Seihou.Interaction.Confirm (confirmDefaults) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Interaction.Confirm" spec + +mkModule :: ModuleName -> [VarDecl] -> [Prompt] -> Module +mkModule name vars prompts = + Module + { name = name, + version = Nothing, + description = Nothing, + vars = vars, + exports = [], + prompts = prompts, + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + +mkTextVar :: VarName -> Maybe VarValue -> VarDecl +mkTextVar name defVal = + VarDecl + { name = name, + type_ = VTText, + default_ = defVal, + description = Nothing, + required = True, + validation = Nothing + } + +mkIntVar :: VarName -> Maybe VarValue -> VarDecl +mkIntVar name defVal = + VarDecl + { name = name, + type_ = VTInt, + default_ = defVal, + description = Nothing, + required = True, + validation = Nothing + } + +mkResolved :: VarDecl -> VarValue -> VarSource -> ResolvedVar +mkResolved decl val src = + ResolvedVar {value = val, source = src, decl = decl} + +spec :: Spec +spec = do + describe "confirmDefaults" $ do + it "does nothing when the flag activates but no variables have default sources" $ do + let decl = mkTextVar "project.name" (Just (VText "my-project")) + m = mkModule "base" [decl] [] + resolved = + Map.singleton + (primaryInstance "base") + (Map.singleton "project.name" (mkResolved decl (VText "my-app") FromCLI)) + (result, st) <- + runEff $ + runConsolePure [] $ + confirmDefaults [(primaryInstance m.name, m, "/fake/base")] resolved + result `shouldBe` resolved + st.consoleOutputs `shouldSatisfy` all (/= "Confirm default values:") + + it "prompts for FromDefault variables and accepts Enter as keeping the default" $ do + let decl = mkTextVar "project.version" (Just (VText "0.1.0.0")) + m = mkModule "base" [decl] [] + resolved = + Map.singleton + (primaryInstance "base") + (Map.singleton "project.version" (mkResolved decl (VText "0.1.0.0") FromDefault)) + (result, st) <- + runEff $ + runConsolePure [""] $ + confirmDefaults [(primaryInstance m.name, m, "/fake/base")] resolved + let rv = (result Map.! primaryInstance "base") Map.! "project.version" + rv.value `shouldBe` VText "0.1.0.0" + rv.source `shouldBe` FromDefault + st.consoleOutputs `shouldSatisfy` any (== "Confirm default values:") + st.consoleOutputs `shouldSatisfy` any (== "project.version [0.1.0.0]:") + + it "replaces the value and marks source as FromPrompt when user types a new value" $ do + let decl = mkTextVar "project.version" (Just (VText "0.1.0.0")) + m = mkModule "base" [decl] [] + resolved = + Map.singleton + (primaryInstance "base") + (Map.singleton "project.version" (mkResolved decl (VText "0.1.0.0") FromDefault)) + (result, _st) <- + runEff $ + runConsolePure ["1.0.0"] $ + confirmDefaults [(primaryInstance m.name, m, "/fake/base")] resolved + let rv = (result Map.! primaryInstance "base") Map.! "project.version" + rv.value `shouldBe` VText "1.0.0" + rv.source `shouldBe` FromPrompt + + it "retries on invalid input and keeps the default on final failure" $ do + let decl = mkIntVar "retry.count" (Just (VInt 42)) + m = mkModule "base" [decl] [] + resolved = + Map.singleton + (primaryInstance "base") + (Map.singleton "retry.count" (mkResolved decl (VInt 42) FromDefault)) + (result, _st) <- + runEff $ + runConsolePure ["not-an-int", "still-bad", "nope"] $ + confirmDefaults [(primaryInstance m.name, m, "/fake/base")] resolved + let rv = (result Map.! primaryInstance "base") Map.! "retry.count" + rv.value `shouldBe` VInt 42 + rv.source `shouldBe` FromDefault + + it "prompts for FromParent variables" $ do + let decl = mkTextVar "skill.name" (Just (VText "exec-plan")) + m = mkModule "child" [decl] [] + resolved = + Map.singleton + (primaryInstance "child") + ( Map.singleton + "skill.name" + (mkResolved decl (VText "exec-plan") (FromParent "parent")) + ) + (result, _st) <- + runEff $ + runConsolePure ["override"] $ + confirmDefaults [(primaryInstance m.name, m, "/fake/child")] resolved + let rv = (result Map.! primaryInstance "child") Map.! "skill.name" + rv.value `shouldBe` VText "override" + rv.source `shouldBe` FromPrompt + + it "is a no-op in non-interactive mode" $ do + let decl = mkTextVar "project.version" (Just (VText "0.1.0.0")) + m = mkModule "base" [decl] [] + resolved = + Map.singleton + (primaryInstance "base") + (Map.singleton "project.version" (mkResolved decl (VText "0.1.0.0") FromDefault)) + (result, st) <- + runEff $ + runConsolePureNonInteractive $ + confirmDefaults [(primaryInstance m.name, m, "/fake/base")] resolved + result `shouldBe` resolved + st.consoleOutputs `shouldBe` [] + + it "uses authored Prompt text when available" $ do + let decl = mkTextVar "license" (Just (VText "MIT")) + prompt = + Prompt + { var = "license", + text = "Choose a license", + condition = Nothing, + choices = Nothing + } + m = mkModule "base" [decl] [prompt] + resolved = + Map.singleton + (primaryInstance "base") + (Map.singleton "license" (mkResolved decl (VText "MIT") FromDefault)) + (_result, st) <- + runEff $ + runConsolePure [""] $ + confirmDefaults [(primaryInstance m.name, m, "/fake/base")] resolved + st.consoleOutputs `shouldSatisfy` any (== "Choose a license [MIT]:") diff --git a/test/Seihou/Interaction/PromptSpec.hs b/test/Seihou/Interaction/PromptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Interaction/PromptSpec.hs @@ -0,0 +1,502 @@ +module Seihou.Interaction.PromptSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Effectful +import Seihou.Composition.Instance (primaryInstance) +import Seihou.Composition.Resolve (resolveWithPrompts) +import Seihou.Core.Types +import Seihou.Effect.ConsolePure +import Seihou.Interaction.Prompt (promptForVar, runPrompts) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Interaction.Prompt" spec + +-- | Helper to create a minimal module. +mkModule :: ModuleName -> [ModuleName] -> [VarDecl] -> [VarExport] -> [Prompt] -> Module +mkModule name deps vars exports prompts = + Module + { name = name, + version = Nothing, + description = Nothing, + vars = vars, + exports = exports, + prompts = prompts, + steps = [], + commands = [], + dependencies = map simpleDep deps, + removal = Nothing, + migrations = [] + } + +-- | Helper to create a text variable declaration. +mkTextVar :: VarName -> Maybe VarValue -> Bool -> VarDecl +mkTextVar name defVal required = + VarDecl + { name = name, + type_ = VTText, + default_ = defVal, + description = Nothing, + required = required, + validation = Nothing + } + +-- | Helper to create a bool variable declaration. +mkBoolVar :: VarName -> Maybe VarValue -> Bool -> VarDecl +mkBoolVar name defVal required = + VarDecl + { name = name, + type_ = VTBool, + default_ = defVal, + description = Nothing, + required = required, + validation = Nothing + } + +-- | Helper to create a simple prompt for a variable. +mkPrompt :: VarName -> Text -> Prompt +mkPrompt var text = + Prompt + { var = var, + text = text, + condition = Nothing, + choices = Nothing + } + +-- | Helper to create a prompt with choices. +mkChoicePrompt :: VarName -> Text -> [Text] -> Prompt +mkChoicePrompt var text choices = + Prompt + { var = var, + text = text, + condition = Nothing, + choices = Just choices + } + +-- | Helper to create a prompt with a when condition. +mkConditionalPrompt :: VarName -> Text -> Expr -> Prompt +mkConditionalPrompt var text expr = + Prompt + { var = var, + text = text, + condition = Just expr, + choices = Nothing + } + +-- | Helper to create an export without alias. +mkExport :: VarName -> VarExport +mkExport name = VarExport {var = name, alias = Nothing} + +spec :: Spec +spec = do + describe "runPrompts" $ do + it "fills a required text variable with FromPrompt source" $ do + let decl = mkTextVar "project.name" Nothing True + prompt = mkPrompt "project.name" "What is the project name?" + bindings = Map.empty + (result, st) <- + runEff $ + runConsolePure ["my-app"] $ + runPrompts [prompt] [decl] bindings + Map.member "project.name" result `shouldBe` True + let rv = result Map.! "project.name" + rv.value `shouldBe` VText "my-app" + rv.source `shouldBe` FromPrompt + -- The prompt text should have been output + st.consoleOutputs `shouldSatisfy` any (== "What is the project name?") + + it "fills a prompt with choices via selection number" $ do + let decl = mkTextVar "license" Nothing True + prompt = mkChoicePrompt "license" "Choose a license:" ["MIT", "Apache-2.0", "BSD-3-Clause"] + bindings = Map.empty + (result, _st) <- + runEff $ + runConsolePure ["2"] $ + runPrompts [prompt] [decl] bindings + Map.member "license" result `shouldBe` True + (result Map.! "license").value `shouldBe` VText "Apache-2.0" + (result Map.! "license").source `shouldBe` FromPrompt + + it "skips a prompt whose when condition evaluates to False" $ do + let decl = mkTextVar "extra.flag" Nothing True + -- Condition: IsSet license — but license is not in bindings + prompt = mkConditionalPrompt "extra.flag" "Extra flag?" (ExprIsSet "license") + bindings = Map.empty + (result, st) <- + runEff $ + runConsolePure ["some-value"] $ + runPrompts [prompt] [decl] bindings + -- Prompt was skipped, so the variable is not resolved + Map.member "extra.flag" result `shouldBe` False + -- No prompt text was output + st.consoleOutputs `shouldSatisfy` all (/= "Extra flag?") + + it "shows a prompt whose when condition evaluates to True" $ do + let decl = mkTextVar "extra.flag" Nothing True + -- Condition: IsSet license — license IS in bindings + prompt = mkConditionalPrompt "extra.flag" "Extra flag?" (ExprIsSet "license") + bindings = Map.singleton "license" (VText "MIT") + (result, _st) <- + runEff $ + runConsolePure ["some-value"] $ + runPrompts [prompt] [decl] bindings + Map.member "extra.flag" result `shouldBe` True + (result Map.! "extra.flag").value `shouldBe` VText "some-value" + + it "skips a prompt for a variable not in the unresolved set" $ do + let decl = mkTextVar "project.name" Nothing True + -- Prompt references a different variable + prompt = mkPrompt "other.var" "Other?" + bindings = Map.empty + (result, st) <- + runEff $ + runConsolePure ["anything"] $ + runPrompts [prompt] [decl] bindings + Map.null result `shouldBe` True + st.consoleOutputs `shouldSatisfy` all (/= "Other?") + + describe "default value display" $ do + it "shows default value in prompt text and accepts Enter" $ do + let decl = mkTextVar "project.version" (Just (VText "0.1.0.0")) True + prompt = mkPrompt "project.version" "Project version" + (result, st) <- + runEff $ + runConsolePure [""] $ + promptForVar prompt decl Map.empty + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right rv -> do + rv.value `shouldBe` VText "0.1.0.0" + rv.source `shouldBe` FromPrompt + -- Prompt text should include the default in brackets + st.consoleOutputs `shouldSatisfy` any (== "Project version [0.1.0.0]:") + + it "accepts user input over default when provided" $ do + let decl = mkTextVar "project.version" (Just (VText "0.1.0.0")) True + prompt = mkPrompt "project.version" "Project version" + (result, st) <- + runEff $ + runConsolePure ["1.0.0"] $ + promptForVar prompt decl Map.empty + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right rv -> + rv.value `shouldBe` VText "1.0.0" + st.consoleOutputs `shouldSatisfy` any (== "Project version [0.1.0.0]:") + + it "shows [skip] for optional variable without default" $ do + let decl = mkTextVar "license" Nothing False + prompt = mkPrompt "license" "License" + (_result, st) <- + runEff $ + runConsolePure [""] $ + promptForVar prompt decl Map.empty + st.consoleOutputs `shouldSatisfy` any (== "License [skip]:") + + it "shows bool default as yes/no" $ do + let decl = mkBoolVar "enable.ci" (Just (VBool True)) False + prompt = mkPrompt "enable.ci" "Enable CI?" + (result, st) <- + runEff $ + runConsolePure [""] $ + promptForVar prompt decl Map.empty + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right rv -> + rv.value `shouldBe` VBool True + st.consoleOutputs `shouldSatisfy` any (== "Enable CI? [yes]:") + + describe "promptForVar" $ do + it "coerces boolean input correctly" $ do + let decl = mkBoolVar "use.ci" Nothing True + prompt = mkPrompt "use.ci" "Enable CI?" + (result, _st) <- + runEff $ + runConsolePure ["yes"] $ + promptForVar prompt decl Map.empty + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right rv -> do + rv.value `shouldBe` VBool True + rv.source `shouldBe` FromPrompt + + it "coerces 'no' to False for boolean variable" $ do + let decl = mkBoolVar "use.ci" Nothing True + prompt = mkPrompt "use.ci" "Enable CI?" + (result, _st) <- + runEff $ + runConsolePure ["no"] $ + promptForVar prompt decl Map.empty + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right rv -> + rv.value `shouldBe` VBool False + + it "retries on empty input then succeeds" $ do + let decl = mkTextVar "project.name" Nothing True + prompt = mkPrompt "project.name" "Project name?" + (result, st) <- + runEff $ + runConsolePure ["", "my-app"] $ + promptForVar prompt decl Map.empty + case result of + Left err -> expectationFailure $ "Expected Right, got: " ++ show err + Right rv -> + rv.value `shouldBe` VText "my-app" + -- Should have output a retry message + st.consoleOutputs `shouldSatisfy` any (== "Value cannot be empty. Please try again.") + + it "fails after exhausting retries on empty input" $ do + let decl = mkTextVar "project.name" Nothing True + prompt = mkPrompt "project.name" "Project name?" + (result, _st) <- + runEff $ + runConsolePure ["", "", ""] $ + promptForVar prompt decl Map.empty + case result of + Left (MissingRequiredVar _) -> pure () + Left err -> expectationFailure $ "Expected MissingRequiredVar, got: " ++ show err + Right _ -> expectationFailure "Expected Left, got Right" + + describe "resolveWithPrompts" $ do + it "prompts for missing required variables in interactive mode" $ do + let m = + mkModule + "base" + [] + [mkTextVar "project.name" Nothing True] + [] + [mkPrompt "project.name" "What is the project name?"] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, st) <- + runEff $ + runConsolePure ["my-app"] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + (baseVars Map.! "project.name").value `shouldBe` VText "my-app" + (baseVars Map.! "project.name").source `shouldBe` FromPrompt + st.consoleOutputs `shouldSatisfy` any (== "What is the project name?") + + it "does not prompt when all variables are provided via CLI" $ do + let m = + mkModule + "base" + [] + [mkTextVar "project.name" Nothing True] + [] + [mkPrompt "project.name" "What is the project name?"] + modules = [(primaryInstance m.name, m, "/fake/base")] + cliOverrides = Map.singleton "project.name" "from-cli" + (result, st) <- + runEff $ + runConsolePure [] $ + resolveWithPrompts modules cliOverrides Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + (baseVars Map.! "project.name").value `shouldBe` VText "from-cli" + (baseVars Map.! "project.name").source `shouldBe` FromCLI + -- No prompts should have been displayed + st.consoleOutputs `shouldSatisfy` all (/= "What is the project name?") + + it "skips prompts and errors in non-interactive mode" $ do + let m = + mkModule + "base" + [] + [mkTextVar "project.name" Nothing True] + [] + [mkPrompt "project.name" "What is the project name?"] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, st) <- + runEff $ + runConsolePureNonInteractive $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> case errs of + [MissingRequiredVar name] -> name `shouldBe` "project.name" + [other] -> expectationFailure $ "Expected MissingRequiredVar, got: " ++ show other + _ -> expectationFailure $ "Expected exactly 1 error, got: " ++ show (length errs) + Right _ -> expectationFailure "Expected Left (errors), got Right" + -- No prompts should have been displayed + st.consoleOutputs `shouldSatisfy` all (/= "What is the project name?") + + it "prompts for optional variables after required resolution" $ do + let m = + mkModule + "base" + [] + [ mkTextVar "project.name" Nothing True, + mkTextVar "license" Nothing False + ] + [] + [ mkPrompt "project.name" "What is the project name?", + mkPrompt "license" "License" + ] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, st) <- + runEff $ + runConsolePure ["my-app", "MIT"] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + (baseVars Map.! "project.name").value `shouldBe` VText "my-app" + (baseVars Map.! "project.name").source `shouldBe` FromPrompt + (baseVars Map.! "license").value `shouldBe` VText "MIT" + (baseVars Map.! "license").source `shouldBe` FromPrompt + st.consoleOutputs `shouldSatisfy` any (== "Optional configuration:") + + it "skips optional variable when user presses Enter" $ do + let m = + mkModule + "base" + [] + [ mkTextVar "project.name" Nothing True, + mkTextVar "license" Nothing False + ] + [] + [ mkPrompt "project.name" "What is the project name?", + mkPrompt "license" "License" + ] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, _st) <- + runEff $ + runConsolePure ["my-app", ""] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + Map.member "project.name" baseVars `shouldBe` True + Map.member "license" baseVars `shouldBe` False + + it "shows Optional configuration separator for optional-only modules" $ do + let m = + mkModule + "base" + [] + [mkTextVar "license" Nothing False] + [] + [mkPrompt "license" "License"] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, st) <- + runEff $ + runConsolePure ["MIT"] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + (baseVars Map.! "license").value `shouldBe` VText "MIT" + st.consoleOutputs `shouldSatisfy` any (== "Optional configuration:") + + it "does not show optional prompts in non-interactive mode" $ do + let m = + mkModule + "base" + [] + [mkTextVar "license" Nothing False] + [] + [mkPrompt "license" "License"] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, st) <- + runEff $ + runConsolePureNonInteractive $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left _ -> expectationFailure "Expected Right (no required vars)" + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + Map.member "license" baseVars `shouldBe` False + st.consoleOutputs `shouldSatisfy` all (/= "Optional configuration:") + + it "respects when condition on optional prompts" $ do + let m = + mkModule + "base" + [] + [ mkTextVar "project.name" Nothing True, + mkTextVar "extra" Nothing False + ] + [] + [ mkPrompt "project.name" "Name?", + mkConditionalPrompt "extra" "Extra?" (ExprIsSet "nonexistent") + ] + modules = [(primaryInstance m.name, m, "/fake/base")] + (result, st) <- + runEff $ + runConsolePure ["my-app"] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + Map.member "extra" baseVars `shouldBe` False + -- The condition was false so Optional configuration header should not appear + -- (no optional prompts actually fired) + st.consoleOutputs `shouldSatisfy` all (/= "Extra?") + + it "does not prompt for optional variables already resolved via config" $ do + let m = + mkModule + "base" + [] + [mkTextVar "license" Nothing False] + [] + [mkPrompt "license" "License"] + modules = [(primaryInstance m.name, m, "/fake/base")] + globalConfig = Map.singleton "license" "MIT" + (result, st) <- + runEff $ + runConsolePure [] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty globalConfig + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + let baseVars = resolved Map.! primaryInstance "base" + (baseVars Map.! "license").value `shouldBe` VText "MIT" + (baseVars Map.! "license").source `shouldBe` FromGlobalConfig + st.consoleOutputs `shouldSatisfy` all (/= "Optional configuration:") + + it "flows prompted value from first module to second via exports" $ do + let base = + mkModule + "base" + [] + [mkTextVar "project.name" Nothing True] + [mkExport "project.name"] + [mkPrompt "project.name" "What is the project name?"] + app = + mkModule + "app" + ["base"] + [mkTextVar "project.name" Nothing True] + [] + [] + modules = [(primaryInstance base.name, base, "/fake/base"), (primaryInstance app.name, app, "/fake/app")] + (result, st) <- + runEff $ + runConsolePure ["my-app"] $ + resolveWithPrompts modules Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left errs -> expectationFailure $ "Expected Right, got: " ++ show errs + Right resolved -> do + -- Base module was prompted + let baseVars = resolved Map.! primaryInstance "base" + (baseVars Map.! "project.name").value `shouldBe` VText "my-app" + (baseVars Map.! "project.name").source `shouldBe` FromPrompt + -- App module received the value via export (no additional prompt needed) + let appVars = resolved Map.! primaryInstance "app" + (appVars Map.! "project.name").value `shouldBe` VText "my-app" + -- Only one prompt should have fired (for base), not two + let promptOutputs = filter (== "What is the project name?") (st.consoleOutputs) + length promptOutputs `shouldBe` 1 diff --git a/test/Seihou/Manifest/TypesSpec.hs b/test/Seihou/Manifest/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/Manifest/TypesSpec.hs @@ -0,0 +1,339 @@ +module Seihou.Manifest.TypesSpec (tests) where + +import Data.Aeson qualified as Aeson +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Seihou.Core.Types +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Manifest.Types" spec + +-- Helper to create a fixed timestamp for testing. +fixedTime :: UTCTime +fixedTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T10:30:00Z" + +fixedTime2 :: UTCTime +fixedTime2 = parseTimeOrError True defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" "2026-03-01T11:00:00Z" + +-- | Helper to set modules on a Manifest without ambiguous record update. +withManifestModules :: [AppliedModule] -> Manifest -> Manifest +withManifestModules mods m = + Manifest m.version m.genAt mods m.vars m.files m.recipe m.blueprint + +spec :: Spec +spec = do + describe "emptyManifest" $ do + it "creates a manifest with the current version" $ do + let m = emptyManifest fixedTime + m.version `shouldBe` currentManifestVersion + m.version `shouldBe` 3 + + it "creates a manifest with no modules, vars, or files" $ do + let m = emptyManifest fixedTime + m.modules `shouldBe` [] + m.vars `shouldBe` Map.empty + m.files `shouldBe` Map.empty + + describe "JSON roundtrip" $ do + it "roundtrips an empty manifest" $ do + let m = emptyManifest fixedTime + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a manifest with modules" $ do + let m = + withManifestModules + [ AppliedModule + { name = ModuleName "haskell-base", + parentVars = emptyParentVars, + source = "/home/user/.config/seihou/modules/haskell-base", + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = Nothing + } + ] + (emptyManifest fixedTime) + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a manifest with variables" $ do + let base = emptyManifest fixedTime + m = + Manifest + { version = base.version, + genAt = base.genAt, + modules = base.modules, + vars = + Map.fromList + [ (VarName "project.name", "my-app"), + (VarName "license", "MIT") + ], + files = base.files, + recipe = Nothing, + blueprint = Nothing + } + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a manifest with file records" $ do + let m :: Manifest + m = + (emptyManifest fixedTime) + { files = + Map.fromList + [ ( "README.md", + FileRecord + { hash = SHA256 "abc123", + moduleName = ModuleName "haskell-base", + strategy = Template, + generatedAt = fixedTime + } + ), + ( "my-app.cabal", + FileRecord + { hash = SHA256 "def456", + moduleName = ModuleName "haskell-base", + strategy = DhallText, + generatedAt = fixedTime + } + ) + ] + } + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a full manifest" $ do + let m = + Manifest + { version = currentManifestVersion, + genAt = fixedTime, + modules = + [ AppliedModule (ModuleName "haskell-base") emptyParentVars "/path/to/module" Nothing fixedTime Nothing, + AppliedModule (ModuleName "nix-flake") emptyParentVars "/path/to/nix" Nothing fixedTime2 Nothing + ], + vars = + Map.fromList + [ (VarName "project.name", "my-app"), + (VarName "project.version", "0.1.0.0") + ], + files = + Map.fromList + [ ( "README.md", + FileRecord (SHA256 "aaa") (ModuleName "haskell-base") Template fixedTime + ), + ( "LICENSE", + FileRecord (SHA256 "bbb") (ModuleName "haskell-base") Copy fixedTime + ) + ], + recipe = Nothing, + blueprint = Nothing + } + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips all strategy types" $ do + let strategies = [Copy, Template, DhallText, Structured] + makeRecord s = + FileRecord (SHA256 "hash") (ModuleName "mod") s fixedTime + m :: Manifest + m = + (emptyManifest fixedTime) + { files = + Map.fromList + (zipWith (\i s -> ("file" <> show i, makeRecord s)) [(1 :: Int) ..] strategies) + } + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a manifest with versioned modules" $ do + let m = + withManifestModules + [ AppliedModule + { name = ModuleName "haskell-base", + parentVars = emptyParentVars, + source = "/path/to/module", + moduleVersion = Just "1.0.0", + appliedAt = fixedTime, + removal = Nothing + } + ] + (emptyManifest fixedTime) + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a manifest with unversioned modules" $ do + let m = + withManifestModules + [ AppliedModule + { name = ModuleName "simple-mod", + parentVars = emptyParentVars, + source = "/path/to/mod", + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = Nothing + } + ] + (emptyManifest fixedTime) + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + it "roundtrips a manifest with two instances of the same module" $ do + let pv1 = ParentVars (Map.singleton (VarName "skill.name") "exec-plan") + pv2 = ParentVars (Map.singleton (VarName "skill.name") "master-plan") + m = + withManifestModules + [ AppliedModule + { name = ModuleName "claude-skill-link", + parentVars = pv1, + source = "/modules/claude-skill-link", + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = Nothing + }, + AppliedModule + { name = ModuleName "claude-skill-link", + parentVars = pv2, + source = "/modules/claude-skill-link", + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = Nothing + } + ] + (emptyManifest fixedTime) + manifestFromJSON (manifestToJSON m) `shouldBe` Right m + + describe "AppliedBlueprint" $ do + it "round-trips a fully populated entry through JSON" $ do + let ab = + AppliedBlueprint + { name = ModuleName "payments-service", + blueprintVersion = Just "0.3.1", + appliedAt = fixedTime, + baselineModules = [ModuleName "nix-flake", ModuleName "haskell-base"], + noBaseline = False, + userPrompt = Just "set this up for a payments microservice", + agentSessionId = Nothing + } + Aeson.eitherDecode (Aeson.encode ab) `shouldBe` Right ab + + it "round-trips a --no-baseline entry through JSON" $ do + let ab = + AppliedBlueprint + { name = ModuleName "lone-blueprint", + blueprintVersion = Nothing, + appliedAt = fixedTime, + baselineModules = [], + noBaseline = True, + userPrompt = Nothing, + agentSessionId = Nothing + } + Aeson.eitherDecode (Aeson.encode ab) `shouldBe` Right ab + + it "writeAppliedBlueprint replaces any prior entry" $ do + let m0 = emptyManifest fixedTime + ab1 = + AppliedBlueprint + (ModuleName "first") + Nothing + fixedTime + [] + False + Nothing + Nothing + ab2 = + AppliedBlueprint + (ModuleName "second") + (Just "1.0.0") + fixedTime2 + [ModuleName "x"] + False + (Just "do the thing") + Nothing + m1 = writeAppliedBlueprint ab1 m0 + m2 = writeAppliedBlueprint ab2 m1 + m1.blueprint `shouldBe` Just ab1 + m2.blueprint `shouldBe` Just ab2 + + describe "schema back-compat" $ do + -- A pre-EP-32 (schema v2) manifest has no @blueprint@ key. The + -- decoder must read it as 'Nothing' regardless of the version + -- field, so a pre-bump project does not refuse to load after the + -- user upgrades seihou. + it "decodes a v2 manifest with no blueprint key as Nothing" $ do + let json = "{\"version\":2,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[],\"variables\":{},\"files\":{}}" + case manifestFromJSON json of + Right manifest -> do + manifest.blueprint `shouldBe` Nothing + manifest.version `shouldBe` 2 + Left err -> expectationFailure ("failed to parse: " <> err) + + it "decodes a v3 manifest with an explicit null blueprint as Nothing" $ do + let json = "{\"version\":3,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[],\"variables\":{},\"files\":{},\"blueprint\":null}" + case manifestFromJSON json of + Right manifest -> manifest.blueprint `shouldBe` Nothing + Left err -> expectationFailure ("failed to parse: " <> err) + + it "decodes a v3 manifest with a populated blueprint object" $ do + let json = + "{\"version\":3,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[],\"variables\":{},\"files\":{}," + <> "\"blueprint\":{\"name\":\"payments-service\",\"version\":\"0.3.1\",\"appliedAt\":\"2026-03-01T11:00:00Z\"," + <> "\"baselineModules\":[\"nix-flake\"],\"noBaseline\":false,\"userPrompt\":\"set up payments\"}}" + case manifestFromJSON json of + Right manifest -> case manifest.blueprint of + Just ab -> do + ab.name `shouldBe` ModuleName "payments-service" + ab.blueprintVersion `shouldBe` Just "0.3.1" + ab.baselineModules `shouldBe` [ModuleName "nix-flake"] + ab.noBaseline `shouldBe` False + ab.userPrompt `shouldBe` Just "set up payments" + ab.agentSessionId `shouldBe` Nothing + Nothing -> expectationFailure "expected populated blueprint" + Left err -> expectationFailure ("failed to parse: " <> err) + + describe "schema back-compat (version 1)" $ do + it "decodes a version-1 manifest with parentVars defaulting to empty" $ do + let json = "{\"version\":1,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[{\"name\":\"haskell-base\",\"source\":\"/path\",\"appliedAt\":\"2026-03-01T10:30:00Z\"}],\"variables\":{},\"files\":{}}" + case manifestFromJSON json of + Right manifest -> do + length manifest.modules `shouldBe` 1 + (head manifest.modules).parentVars `shouldBe` emptyParentVars + Left err -> expectationFailure ("failed to parse: " <> err) + + it "parses old manifest without version key as Nothing" $ do + let json = "{\"version\":1,\"generatedAt\":\"2026-03-01T10:30:00Z\",\"modules\":[{\"name\":\"old-mod\",\"source\":\"/path\",\"appliedAt\":\"2026-03-01T10:30:00Z\"}],\"variables\":{},\"files\":{}}" + result = manifestFromJSON json + case result of + Right manifest -> (head manifest.modules).moduleVersion `shouldBe` Nothing + Left err -> expectationFailure ("failed to parse: " <> err) + + describe "version checking" $ do + it "rejects manifests with version higher than current" $ do + let base = emptyManifest fixedTime + m = Manifest {version = 99, genAt = base.genAt, modules = base.modules, vars = base.vars, files = base.files, recipe = Nothing, blueprint = Nothing} + result = manifestFromJSON (manifestToJSON m) + case result of + Left err -> err `shouldContain` "newer version" + Right _ -> expectationFailure "should have rejected future version" + + describe "hashContent" $ do + it "produces a hex-encoded SHA256 digest" $ do + let h = hashContent "hello world" + -- SHA256 of "hello world" is a well-known value + h.unSHA256 `shouldBe` "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9" + + it "produces different hashes for different content" $ do + let h1 = hashContent "hello" + h2 = hashContent "world" + h1 `shouldNotBe` h2 + + it "produces consistent hashes for the same content" $ do + let h1 = hashContent "test content" + h2 = hashContent "test content" + h1 `shouldBe` h2 + + it "produces a 64-character hex string" $ do + let SHA256 hex = hashContent "anything" + T.length hex `shouldBe` 64 + + it "handles empty content" $ do + let h = hashContent "" + -- SHA256 of empty string is a well-known value + h.unSHA256 `shouldBe` "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"