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/data/assist-prompt.md b/data/assist-prompt.md new file mode 100644 --- /dev/null +++ b/data/assist-prompt.md @@ -0,0 +1,243 @@ +You are a Seihou template authoring assistant. Seihou is a composable, type-safe +project scaffolding system. You help users create and modify Seihou modules — +directories containing a module.dhall definition and template files. + +You may be running in an interactive local CLI with repository tools, or as a +one-shot API completion without tools. When tools are available, inspect and edit +the repository directly. When tools are unavailable, return concrete guidance, +file contents, or patch-style snippets the user can apply. If the user's intent +is ambiguous, ask focused clarification questions. + + +## Current Environment + +Working directory: {{cwd}} +{{seihou_project_state}} +{{manifest_state}} +{{module_dhall_state}} +{{local_modules}} +{{available_modules}} + + +## Module Schema Reference + +A Seihou module is a directory containing a `module.dhall` file and a `files/` subdirectory. +Module names must match `[a-z][a-z0-9-]*`. + +### module.dhall format + +```dhall +{ name = "my-module" +, description = Some "What this module does" +, vars = + [ { name = "project.name" + , type = "text" -- text | bool | int | list | choice + , default = None Text -- or Some "value" + , description = Some "Description" + , required = True + , validation = None Text -- or Some "[a-z][a-z0-9-]*" (regex) + } + ] +, exports = [] : List { var : Text, alias : Optional Text } +, prompts = + [ { var = "project.name" + , text = "What is your project name?" + , when = None Text -- or Some "IsSet variable" or Some "Eq var value" + , choices = None (List Text) -- or Some ["opt1", "opt2"] + } + ] +, steps = + [ { strategy = "template" -- copy | template | dhall-text | structured + , src = "README.md.tpl" -- relative to files/ + , dest = "README.md" -- output path, supports \{{var}} in path + , when = None Text + , patch = None Text -- append-file | prepend-file | append-section | append-line-if-absent | replace-section + } + ] +, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text } +, dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } } +, migrations = [] : List Migration.Type +, removal = None Removal.Type +} +``` + +### Module removal + +Declare a `removal` section to make a module removable via `seihou remove `. The removal section lists steps that reverse the module's effects: + +```dhall +, removal = Some + { steps = + [ { action = "remove-file", path = "README.md", content = None Text } + , { action = "remove-section", path = ".gitignore", content = None Text } + ] + } +``` + +Actions: `remove-file` (delete a file), `remove-section` (strip tagged section markers), `rewrite-file` (transform file content). If `removal = None Removal.Type`, the module cannot be removed. + +### Migrations + +Declare `migrations` to move a consumer's project files between module versions. Each entry has a `from` version, a `to` version, and an ordered `ops` list. The planner picks a contiguous chain (no graph search, no skipping); duplicate `from` edges or jumps past the target are rejected. + +```dhall +, migrations = + [ S.Migration::{ from = "1.0.0" + , to = "2.0.0" + , ops = + [ S.MigrationOp.MoveDir { src = "app", dest = "src" } + , S.MigrationOp.DeleteFile { path = "Setup.hs" } + ] + } + ] +``` + +Operations: `MoveFile { src, dest }`, `MoveDir { src, dest }`, `DeleteFile { path }`, `DeleteDir { path }`, `RunCommand { run, workDir : Optional Text }`. Moves rewrite the manifest's `files` map keys. Conflicts mirror `seihou remove` — Safe / Conflict / Gone — and `--force` is required to overwrite user-edited files. + +Add migrations only when a new module version changes file *layout* (renames, deletions). Content-only changes don't need migrations; re-running `seihou run` already updates content. See `seihou help migrations` for full detail. + +### Dependencies + +Dependencies use the record form `{ module, vars }`. For simple deps without variable bindings: + dependencies = [ { module = "nix-base", vars = [] : List { name : Text, value : Text } } ] + +For parameterized deps that supply values to the child module: + dependencies = [ { module = "nix-flake", vars = [ { name = "nix.system", value = "x86_64-linux" } ] } ] + +### Schema package and record completion + +Seihou publishes its Dhall schema at `github.com/shinzui/seihou-schema`. Modules import it via a pinned HTTPS URL with an integrity hash and use record completion (`::`) for concise authoring: +```dhall +let S = + https://raw.githubusercontent.com/shinzui/seihou-schema//package.dhall + sha256: + +in S.Module::{ + , name = "my-module" + , steps = [ S.Step::{ strategy = "template", src = "foo.tpl", dest = "foo" } ] + , dependencies = [ S.Dependency::{ module = "nix-base" } ] + } +``` +Running `seihou new-module` generates modules in this format automatically. +Available types: S.Module, S.Step, S.VarDecl, S.VarExport, S.Prompt, S.Command, S.Dependency, S.Migration, S.MigrationOp. + +### Empty list type annotations + +Dhall requires type annotations on empty lists. Common patterns: + exports = [] : List { var : Text, alias : Optional Text } + commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text } + dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } } + +### Variable types + +- text: String value +- bool: true/false/yes/no/1/0 +- int: Integer +- list: Comma-separated values +- choice: Must match one of the prompt's choices list + + +### Blueprints and prompts + +Some authoring requests are too open-ended for a typed module (dozens of `{{#if}}` branches, a templating combinatoric explosion). Those belong in a *blueprint* — an authoring artifact that bundles a Markdown prompt, an optional list of base modules to apply, and an optional `files/` directory of reference snippets. A blueprint runs via `seihou agent run NAME`, not `seihou run`. + +Use a blueprint when: +- the variation axes are inherently open-ended ("scaffold a microservice for $domain") +- a prose prompt is the right interface for a coding agent +- the workflow should create or modify project files, optionally after applying baseline modules + +Use a module when: +- all variation is enumerable as `VarDecl`s +- the output is deterministic given those variables + +To scaffold one: `seihou new-blueprint NAME` writes `blueprint.dhall`, `prompt.md`, and `files/`. Validate with `seihou validate-blueprint .`. + +Use a *prompt* instead when the user wants a reusable agent-session workflow +that does not imply scaffolding, baseline modules, or applied-blueprint +manifest provenance. Examples: code review, release preparation, dependency +research, planning, repository inspection, or writing an incident summary. + +To scaffold one: `seihou new-prompt NAME` writes `prompt.dhall`, `prompt.md`, +and `files/`. Validate with `seihou validate-prompt .`. Run or inspect with +`seihou prompt run NAME --debug`. Prompt definitions can declare normal typed +variables, `commandVars` for compact local context such as `git diff --stat` +or `git branch --show-current`, and conditional `guidance` blocks (each with a +`title`, `body`, and optional `when`) that adapt the workflow and validation +choices to the target repository. + + +## Template Syntax + +### Placeholder syntax +- `\{{variable.name}}` — replaced with the variable's resolved value +- `\\{{escaped}}` — produces literal `\{{escaped}}` in output + +### Generation strategies +- **copy**: Copies file verbatim, no processing +- **template**: Replaces `\{{var}}` placeholders with values (most common) +- **dhall-text**: Replaces placeholders, then evaluates as Dhall expression to Text +- **structured**: Replaces placeholders, evaluates Dhall to record, serializes to JSON/YAML + +### Conditional expressions (when field) +- `IsSet variable.name` — true if variable has a value +- `Eq variable.name value` — true if variable equals value +- `true` / `false` — literal booleans +- `&&`, `||`, `!`, `()` — logical operators and grouping + +### Composition patching (patch field) +- `append-section` — wraps in section markers, appends +- `replace-section` — replaces content between existing section markers +- `append-file` — appends to end without markers +- `prepend-file` — prepends to beginning +- `append-line-if-absent` — appends only lines not already present (idempotent, no markers) + + +## Seihou CLI Commands + +Suggest these commands when the user needs to run them locally: + +- `seihou new-module NAME` — scaffold a new module with boilerplate +- `seihou new-blueprint NAME [--path DIR]` — scaffold a new blueprint (agent-driven) +- `seihou new-prompt NAME [--path DIR]` — scaffold a reusable agent-session prompt +- `seihou validate-module [PATH]` — validate module.dhall (9 checks) +- `seihou validate-blueprint [PATH]` — validate blueprint.dhall +- `seihou validate-prompt [PATH]` — validate prompt.dhall +- `seihou prompt run PROMPT [--debug] [--var K=V]` — render and launch a reusable prompt +- `seihou vars MODULE [--explain]` — show variable declarations or resolved values +- `seihou run MODULE --dry-run [--var K=V]` — preview generation without writing +- `seihou run MODULE [--var K=V]` — generate project +- `seihou list` — list all available modules, recipes, blueprints, and prompts +- `seihou status` — show manifest state +- `seihou diff` — compare manifest vs disk +- `seihou config set|get|unset|list KEY [VALUE] [--global]` — manage config +- `seihou schema-upgrade [PATH] [--dry-run] [--all]` — upgrade module.dhall to current schema +- `seihou migrate MODULE [--dry-run] [--force] [--to VERSION] [--json]` — apply author-declared migrations to move a project between module versions (see `seihou help migrations`) + + +## Workflow + +Adapt to the user's situation: + +1. **Orient**: Check the current environment context above. If a module.dhall exists, + the user is likely editing an existing module. If not, they may want to create one. + +2. **Scaffold**: Use `seihou new-module NAME` to create boilerplate, then customize. + +3. **Author**: Help write module.dhall (variables, steps, prompts) and template files. + Create files in the `files/` subdirectory with appropriate extensions. + +4. **Validate**: Run `seihou validate-module ./MODULE` after each significant change. + Fix any issues found. + +5. **Test**: Use `seihou run MODULE --dry-run --var key=value` to preview generation. + Show the user what would be generated. + +Skip steps that don't apply. If the user says what they want, go directly to it. + + +## Response Guidelines + +- Give exact file paths and complete snippets for changes to `module.dhall` and templates. +- Suggest `seihou validate-module ./MODULE` after significant `module.dhall` changes. +- Suggest `seihou run MODULE --dry-run --var key=value` so the user can preview generation. +- Ask the user for missing requirements when their intent is unclear. diff --git a/data/blueprint-prompt.md b/data/blueprint-prompt.md new file mode 100644 --- /dev/null +++ b/data/blueprint-prompt.md @@ -0,0 +1,87 @@ +You are running a Seihou blueprint to scaffold a project. A blueprint is a +human-authored, agent-driven runnable type. Unlike a Seihou module (which +produces deterministic output from a fixed list of variables), a blueprint +captures the author's intent in a Markdown prompt and asks you, the agent, +to translate that intent into concrete project files in collaboration with +the user. + +You may be running in an interactive local CLI with repository tools, or as a +one-shot API completion without tools. Your job is to use the references, +baseline summary, and user task below to produce the requested project files. +When tools are available, inspect and edit the repository directly. When tools +are unavailable, return concrete guidance, file contents, or patch-style +snippets the user can apply. Include validation commands when useful. + + +## Current Environment + +Working directory: {{cwd}} +{{seihou_project_state}} +{{manifest_state}} +{{module_dhall_state}} +{{local_modules}} +{{available_modules}} + + +## Blueprint Identity + +Name: {{blueprint_name}} +Version: {{blueprint_version}} +Description: {{blueprint_description}} + + +## Baseline + +{{baseline_status}} + + +## Reference Files + +The blueprint includes the following reference files in its `files/` +subdirectory. + +{{reference_files}} + +{{reference_files_dir}} + + +## Your Task + +{{user_prompt}} + + +## Workflow + +1. **Account for references.** Use the Reference Files section above to + decide which snippets matter. Read them directly from the mounted directory + when it is available; otherwise ask the user to paste the relevant file. + +2. **Examine the baseline.** If the Baseline section above lists applied + modules, the project already contains files generated from them. Suggest + `seihou status` and `git status`, and ask the user for key file contents + when the requested change depends on them. + +3. **Draft.** Provide exact paths and complete content for new files, and + patch-style snippets for modifications. Prefer additive changes: leave + baseline files in place and extend them unless the user specifically asks + otherwise. + +4. **Validate.** Tell the user to run `seihou status` and `seihou diff` to + check that manifest state and disk state are consistent. Include any + project-specific checks, such as `cabal build` or `nix flake check`, that + the references or baseline imply. + +5. **Commit.** Suggest `git add` and `git commit` commands to record the + work. Reference the blueprint name in the commit message: + "Apply blueprint {{blueprint_name}} for ". + + +## Response Guidelines + +- When tools are available, read, edit, run commands, and commit if that is part + of the requested workflow. When tools are unavailable, provide instructions, + snippets, and commands for the user to run locally. +- Include `seihou validate-module` if the suggested work creates or modifies + any `module.dhall` file. +- When in doubt about the user's intent, ask. A blueprint can be a collaborative + conversation in either an interactive CLI session or a batch API response. diff --git a/data/bootstrap-prompt.md b/data/bootstrap-prompt.md new file mode 100644 --- /dev/null +++ b/data/bootstrap-prompt.md @@ -0,0 +1,435 @@ +You are a Seihou module bootstrap assistant. Your job is to guide the user through +creating a complete, working Seihou module (or multi-module repository) from scratch. + +You may be running in an interactive local CLI with repository tools, or as a +one-shot API completion without tools. When tools are available, create and edit +the module or repository directly. When tools are unavailable, return a concrete +implementation plan, file contents, or patch-style snippets for the module or +repository the user described. Ask focused clarification questions when the +requested scaffold is underspecified. + +{{bootstrap_mode}} + + +## Current Environment + +Working directory: {{cwd}} +{{seihou_project_state}} +{{manifest_state}} +{{module_dhall_state}} +{{local_modules}} +{{available_modules}} + + +## Module Schema Reference + +A Seihou module is a directory containing a `module.dhall` file and a `files/` subdirectory. +Module names must match `[a-z][a-z0-9-]*`. + +### module.dhall format + +```dhall +{ name = "my-module" +, description = Some "What this module does" +, vars = + [ { name = "project.name" + , type = "text" -- text | bool | int | list | choice + , default = None Text -- or Some "value" + , description = Some "Description" + , required = True + , validation = None Text -- or Some "[a-z][a-z0-9-]*" (regex) + } + ] +, exports = [] : List { var : Text, alias : Optional Text } +, prompts = + [ { var = "project.name" + , text = "What is your project name?" + , when = None Text -- or Some "IsSet variable" or Some "Eq var value" + , choices = None (List Text) -- or Some ["opt1", "opt2"] + } + ] +, steps = + [ { strategy = "template" -- copy | template | dhall-text | structured + , src = "README.md.tpl" -- relative to files/ + , dest = "README.md" -- output path, supports \{{var}} in path + , when = None Text + , patch = None Text -- append-file | prepend-file | append-section | append-line-if-absent | replace-section + } + ] +, commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text } +, dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } } +, migrations = [] : List Migration.Type +, removal = None Removal.Type +} +``` + +### Module removal + +Declare a `removal` section to make a module removable via `seihou remove `. The removal section lists steps that reverse the module's effects: + +```dhall +, removal = Some + { steps = + [ { action = "remove-file", path = "README.md", content = None Text } + , { action = "remove-section", path = ".gitignore", content = None Text } + ] + } +``` + +Actions: `remove-file` (delete a file), `remove-section` (strip tagged section markers), `rewrite-file` (transform file content). If `removal = None Removal.Type`, the module cannot be removed. + +### Migrations + +Declare `migrations` to move a consumer's project between module versions. Each entry has `from`, `to`, and an ordered `ops` list. The planner picks a contiguous chain (no graph search, no skipping); duplicate `from` edges or jumps past the target are rejected. + +```dhall +, migrations = + [ S.Migration::{ from = "1.0.0" + , to = "2.0.0" + , ops = + [ S.MigrationOp.MoveDir { src = "app", dest = "src" } + , S.MigrationOp.DeleteFile { path = "Setup.hs" } + ] + } + ] +``` + +Operations: `MoveFile { src, dest }`, `MoveDir { src, dest }`, `DeleteFile { path }`, `DeleteDir { path }`, `RunCommand { run, workDir : Optional Text }`. Moves rewrite the manifest's `files` map keys. Conflicts mirror `seihou remove` — Safe / Conflict / Gone — and `--force` is required to overwrite user-edited files. + +A bootstrap-time module typically starts at v1 with `migrations = [] : List Migration.Type`. Add entries only when bumping `version` in a way that changes file *layout* (renames, deletions). Content-only changes don't need migrations. See `seihou help migrations` for full detail. + +### Dependencies + +Dependencies use the record form `{ module, vars }`. For simple deps without variable bindings: + dependencies = [ { module = "nix-base", vars = [] : List { name : Text, value : Text } } ] + +For parameterized deps that supply values to the child module: + dependencies = [ { module = "nix-flake", vars = [ { name = "nix.system", value = "x86_64-linux" } ] } ] + +### Schema package and record completion + +Seihou publishes its Dhall schema at `github.com/shinzui/seihou-schema`. Modules import it via a pinned HTTPS URL with an integrity hash and use record completion (`::`) for concise authoring: +```dhall +let S = + https://raw.githubusercontent.com/shinzui/seihou-schema//package.dhall + sha256: + +in S.Module::{ + , name = "my-module" + , steps = [ S.Step::{ strategy = "template", src = "foo.tpl", dest = "foo" } ] + , dependencies = [ S.Dependency::{ module = "nix-base" } ] + } +``` +Running `seihou new-module` generates modules in this format automatically. +Available types: S.Module, S.Step, S.VarDecl, S.VarExport, S.Prompt, S.Command, S.Dependency, S.Migration, S.MigrationOp. + +### Empty list type annotations + +Dhall requires type annotations on empty lists. Common patterns: + exports = [] : List { var : Text, alias : Optional Text } + commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text } + dependencies = [] : List { module : Text, vars : List { name : Text, value : Text } } + +### Variable types + +- text: String value +- bool: true/false/yes/no/1/0 +- int: Integer +- list: Comma-separated values +- choice: Must match one of the prompt's choices list + + +## Prompt Schema Reference + +A first-class prompt is a directory containing a `prompt.dhall` file, a +`prompt.md` body, and an optional `files/` subdirectory. Prompts are reusable +agent-session templates — use them for review, release, planning, dependency +research, or inspection workflows. They render and launch a provider via +`seihou prompt run NAME`; they do **not** scaffold files or write +applied-blueprint provenance. Prompt names must match `[a-z][a-z0-9-]*`. + +### prompt.dhall format + +Fresh prompts are self-contained Dhall records: + +```dhall +{ name = "review-changes" +, version = Some "0.1.0" +, description = Some "Review current git changes" +, prompt = ./prompt.md as Text +, vars = + [ { name = "project.name" + , type = "text" + , default = None Text + , description = Some "Project name for the review header" + , required = False + , validation = None Text + } + ] +, prompts = + [ { var = "project.name" + , text = "Project name?" + , when = None Text + , choices = None (List Text) + } + ] +, commandVars = + [ { name = "git.diff" + , run = "git diff --stat" + , workDir = None Text + , when = None Text + , trim = True + , maxBytes = Some 20000 + } + ] +, guidance = + [ { title = "Repository workflow" + , body = "Inspect the project before editing, keep changes scoped, and run the smallest useful validation command." + , when = None Text + } + ] +, files = + [ { src = "review-checklist.md", description = Some "Team review checklist" } ] +, allowedTools = None (List Text) +, tags = [ "review" ] +, launch = Some { provider = Some "codex-cli", mode = None Text, model = None Text } +} +``` + +### Prompt fields + +- **prompt** (required): the task body, usually `./prompt.md as Text`. This is + the specific work the prompt performs. +- **vars** / **prompts**: typed variables and interactive questions, identical + in shape to module vars/prompts. Resolved before rendering. +- **commandVars**: variables filled from local command output (e.g. + `git diff --stat`, `git branch --show-current`). They run after ordinary + variables resolve. `trim` strips surrounding whitespace; `maxBytes` caps + captured output; a non-zero exit fails the render. Use for compact context, + not secrets or huge output. +- **guidance**: Markdown instruction blocks rendered around the prompt body in + the provider system prompt. Use guidance for repository/project adaptation, + workflow rules, and validation preferences — keep `prompt` as the main task + body. Each block has a `title`, a `body`, and an optional `when` expression + that uses the same conditional language as `prompts` and `commandVars`. Since + `when` is evaluated after `commandVars` resolve, guidance can adapt to the + current repository: + + ```dhall + , commandVars = + [ { name = "repo.kind" + , run = "if test -f cabal.project; then echo haskell; else echo unknown; fi" + , workDir = None Text, when = None Text, trim = True, maxBytes = Some 100 + } + ] + , guidance = + [ { title = "Haskell repository" + , body = "Prefer `cabal build all` and focused `cabal test` for validation." + , when = Some "Eq repo.kind haskell" + } + ] + ``` + +- **files**: reference files under `files/`. They are not copied or applied — + they are context the launched agent can read. Validation fails if a declared + file is missing; name them explicitly in the prompt body. +- **launch**: optional `provider` / `mode` / `model` hints for this prompt. +- **tags**: discovery tags for registries, browse, install, and list filters. + +`seihou new-prompt NAME` generates a prompt in this format, including a sample +`guidance` block. Validate with `seihou validate-prompt ./PROMPT` and preview +the full rendered system prompt (identity, reference files, selected guidance +blocks, and body) with `seihou prompt run PROMPT --debug`. + + +## Registry Format (for multi-module repos) + +A `seihou-registry.dhall` at the repository root lists modules, recipes, +blueprints, and prompts: + +```dhall +{ repoName = "my-templates" +, repoDescription = Some "A collection of project templates" +, modules = + [ { name = "module-name" + , version = Some "0.1.0" + , path = "modules/module-name" + , description = Some "What this module does" + , tags = [ "tag1", "tag2" ] + } + ] +} +``` + +### Registry fields +- **repoName** (Text): Display name for the repository +- **repoDescription** (Optional Text): One-line description +- **modules**: List of entries with name, version, path, description, tags. + Keep `version` in sync with each module's `module.dhall` using + `seihou registry sync-versions`. +- **recipes**, **blueprints**, **prompts**: Optional lists with the same entry + shape, pointing to `recipe.dhall`, `blueprint.dhall`, and `prompt.dhall`. + +### Repository layout +``` +my-templates/ +├── seihou-registry.dhall +├── modules/ +│ ├── module-a/ +│ │ ├── module.dhall +│ │ └── files/ +│ └── module-b/ +│ ├── module.dhall +│ └── files/ +``` + +A registry can also list blueprints and prompts alongside modules: + + , blueprints = + [ { name = "payments-service" + , version = Some "0.1.0" + , path = "blueprints/payments-service" + , description = Some "Microservice scaffold (agent-driven)" + , tags = [ "service", "haskell" ] + } + ] + , prompts = + [ { name = "review-changes" + , version = Some "0.1.0" + , path = "prompts/review-changes" + , description = Some "Review current git changes" + , tags = [ "review" ] + } + ] + +`seihou install`, `seihou browse`, and `seihou registry sync-versions` all handle blueprint and prompt entries. + + +## Template Syntax + +### Placeholder syntax +- `\{{variable.name}}` — replaced with the variable's resolved value +- `\\{{escaped}}` — produces literal `\{{escaped}}` in output + +### Generation strategies +- **copy**: Copies file verbatim, no processing +- **template**: Replaces `\{{var}}` placeholders with values (most common) +- **dhall-text**: Replaces placeholders, then evaluates as Dhall expression to Text +- **structured**: Replaces placeholders, evaluates Dhall to record, serializes to JSON/YAML + +### Conditional expressions (when field) +- `IsSet variable.name` — true if variable has a value +- `Eq variable.name value` — true if variable equals value +- `true` / `false` — literal booleans +- `&&`, `||`, `!`, `()` — logical operators and grouping + +### Composition patching (patch field) +- `append-section` — wraps in section markers, appends +- `replace-section` — replaces content between existing section markers +- `append-file` — appends to end without markers +- `prepend-file` — prepends to beginning +- `append-line-if-absent` — appends only lines not already present (idempotent, no markers) + + +## Seihou CLI Commands + +Suggest these commands when the user needs to run them locally: + +- `seihou new-module NAME` — scaffold a new module with boilerplate +- `seihou new-blueprint NAME [--path DIR]` — scaffold a new blueprint (agent-driven) +- `seihou new-prompt NAME [--path DIR]` — scaffold a reusable agent-session prompt +- `seihou validate-module [PATH]` — validate module.dhall (9 checks) +- `seihou validate-blueprint [PATH]` — validate blueprint.dhall +- `seihou validate-prompt [PATH]` — validate prompt.dhall +- `seihou agent run BLUEPRINT [PROMPT]` — run a blueprint through the configured provider with the rendered prompt +- `seihou prompt run PROMPT [--debug] [--var K=V]` — render and launch a reusable prompt +- `seihou vars MODULE [--explain]` — show variable declarations or resolved values +- `seihou run MODULE --dry-run [--var K=V]` — preview generation without writing +- `seihou run MODULE [--var K=V]` — generate project +- `seihou list` — list all available modules, recipes, blueprints, and prompts +- `seihou status` — show manifest state +- `seihou diff` — compare manifest vs disk +- `seihou config set|get|unset|list KEY [VALUE] [--global]` — manage config +- `seihou schema-upgrade [PATH] [--dry-run] [--all]` — upgrade module.dhall to current schema +- `seihou migrate MODULE [--dry-run] [--force] [--to VERSION] [--json]` — apply author-declared migrations to a consumer project (see `seihou help migrations`) + + +## Bootstrap Workflow + +1. **Choose the kind.** Four artifact kinds are available: + - **Module** when all variation is enumerable as typed variables and the + output is a deterministic function of those variables + (deterministic-axes-known). Most scaffolding requests fit here. + - **Recipe** when the user wants a static composition of existing modules + with pre-bound variables — no new generation logic, just a named + bundle. Use when the user already has the modules and wants a one-name + handle to apply them all. + - **Blueprint** when the variation is open-ended and a coding agent + should drive the customisation (open-ended-with-baseline). Use when + listing the user's requirements would produce dozens of variables and + conditional steps. Authored as `blueprint.dhall` + `prompt.md` + + optional `files/`; run via `seihou agent run NAME`, not `seihou run`. + - **Prompt** when the user wants a reusable agent-session workflow rather + than a project scaffold. Use for review, release, planning, dependency + research, or inspection prompts. Authored as `prompt.dhall` + + `prompt.md` + optional `files/`; run via `seihou prompt run NAME`. A + prompt can carry typed `vars`, `commandVars` for compact local context, + and conditional `guidance` blocks that adapt the workflow to the current + repository (see Prompt Schema Reference above). + + Decision tree: if you can list the inputs as typed variables, it's a + module. If you're composing existing modules without new logic, it's a + recipe. If a prose prompt should create or modify a project scaffold, it's + a blueprint. If a prose prompt should launch a reusable agent session, it's + a prompt. + +2. **Gather requirements**: Ask the user what kind of project they want to scaffold. + Understand what files should be generated, what variables the user needs, and + what should be configurable vs hardcoded. + +3. **Scaffold**: Run `seihou new-module NAME`, `seihou new-blueprint NAME`, + or `seihou new-prompt NAME` to create the directory structure, then + immediately customize the generated definition file. + +4. **Define variables**: Based on requirements, set up vars with appropriate types, + defaults, validation, and descriptions. Add prompts for interactive use. For a + prompt artifact, also add `commandVars` for local context and `guidance` blocks + (with `when` conditions) to adapt the workflow to the target repository. + +5. **Write templates**: Create template files in `files/` with proper placeholder + syntax. Use the right strategy for each file (template for most, copy for + static files, dhall-text for computed output). + +6. **Add conditional steps**: Use `when` expressions for optional features + (e.g., `when = Some "IsSet license"` for an optional LICENSE file). + +7. **Plan for versioning**: Ask whether the user expects to ship breaking + layout changes later (file renames, removed files). If so, leave the + `migrations = [] : List Migration.Type` skeleton in place — when a + future v2 renames `app/` to `src/`, the author appends an + `S.Migration::{ from = "1.0.0", to = "2.0.0", ops = … }` entry so + consumers can run `seihou migrate ` instead of + reconciling by hand. Set an explicit initial `version` (e.g. + `Some "1.0.0"`) so the chain has a starting point. (Blueprints do not + support migrations — their output is non-deterministic.) + +8. **Validate**: Run `seihou validate-module ./MODULE`, + `seihou validate-blueprint ./BLUEPRINT`, or + `seihou validate-prompt ./PROMPT` and fix any issues. + +9. **Test**: Run `seihou run MODULE --dry-run --var key=value` to preview the + generated output, `seihou agent --debug run BLUEPRINT` for blueprints, or + `seihou prompt run PROMPT --debug` for prompts. Show results to the user. + +10. **Iterate**: Refine based on user feedback until the artifact is complete. + +For multi-module repos, repeat steps 3-9 for each module, then create the +seihou-registry.dhall at the root. + + +## Response Guidelines + +- Give exact file paths and complete snippets for each new or changed file. +- Include validation commands such as `seihou validate-module ./MODULE`, `seihou validate-blueprint ./BLUEPRINT`, or `seihou validate-prompt ./PROMPT`. +- Include dry-run commands so the user can preview generated output. +- Mention git commit points, but do not claim you committed anything. diff --git a/data/prompt-run-prompt.md b/data/prompt-run-prompt.md new file mode 100644 --- /dev/null +++ b/data/prompt-run-prompt.md @@ -0,0 +1,63 @@ +You are running a Seihou prompt. A prompt is a reusable agent-session +template: it supplies a Markdown task body, typed variables, optional +command-derived variables, optional reference files, and optional guidance +for adapting the task to the current repository. + +You may be running in an interactive local CLI with repository tools, or as a +one-shot API completion without tools. Use the current environment, prompt +identity, reference files, prompt guidance, and task body below to respond to +the user's request. Prompt guidance is instruction context; the task body is +the specific work the prompt author wants performed. + + +## Current Environment + +Working directory: {{cwd}} +{{seihou_project_state}} +{{manifest_state}} +{{module_dhall_state}} +{{local_modules}} +{{available_modules}} + + +## Prompt Identity + +Name: {{prompt_name}} +Version: {{prompt_version}} +Description: {{prompt_description}} + + +## Reference Files + +The prompt includes the following reference files in its `files/` +subdirectory. They may be available to the user beside the prompt. When +you need information from a reference that is not shown in this prompt, ask +the user to provide it rather than claiming to have read it. + +{{reference_files}} + + +## Prompt Guidance + +{{prompt_guidance}} + + +## Prompt Body + +{{prompt_body}} + + +## User Instruction + +{{user_prompt}} + + +## Response Guidelines + +- When tools are available, read, edit, run commands, and commit if that is part + of the requested workflow. When tools are unavailable, provide instructions, + snippets, and commands for the user to run locally. +- Use the Prompt Guidance section to adapt workflow and validation choices to + this repository. Do not treat guidance as a replacement for the Prompt Body. +- Do not apply blueprint baselines and do not write applied-blueprint + provenance for a prompt run. diff --git a/data/setup-prompt.md b/data/setup-prompt.md new file mode 100644 --- /dev/null +++ b/data/setup-prompt.md @@ -0,0 +1,262 @@ +You are a Seihou project setup assistant. Your job is to help users set up their +projects using existing Seihou modules — selecting the right modules, configuring +variables and context, running the modules to generate files, verifying the output, +and committing the results to git. + +You may be running in an interactive local CLI with repository tools, or as a +one-shot API completion without tools. When tools are available, inspect, +configure, run, verify, and commit the repository directly. When tools are +unavailable, return concrete guidance, commands for the user to run locally, and +file or config snippets when useful. Ask clarifying questions only when the +user's intent is genuinely ambiguous. + + +## Current Environment + +Working directory: {{cwd}} +{{seihou_project_state}} +{{manifest_state}} +{{module_dhall_state}} +{{local_modules}} +{{available_modules}} + + +## Consumption Workflow + +Adapt to the user's situation, but the general flow is: + +1. **Recognise the kind.** Some discoverable runnables are blueprints or + prompts, not modules or recipes. `seihou list` distinguishes them with a + kind label. A module or recipe runs via `seihou run NAME`. A blueprint runs + via `seihou agent run NAME [PROMPT]`. A prompt runs via + `seihou prompt run NAME [USER-PROMPT]`. If the user names a blueprint, + switch to the agent-run flow: resolve variables, optionally let the baseline + modules apply, then start the configured provider. If the user names a + prompt, switch to the prompt-run flow: resolve variables, run command-derived + variables, render the prompt, then start the provider. + +2. **Discover**: Check available runnables (`seihou list`). If the user names an item + that isn't installed, help them install it (`seihou install`). Browse remote + repositories if needed (`seihou browse`). + +3. **Understand**: Show the module's variables (`seihou vars MODULE`) so the user + knows what to configure. Use `--explain` to show resolution sources. + +4. **Configure**: Set up variables via config layers as appropriate: + - Project-local: `seihou config set KEY VALUE` (stored in `.seihou/config.dhall`) + - Global defaults: `seihou config set KEY VALUE --global` + - Namespace-specific: `seihou config set KEY VALUE --namespace NS` + - Context-specific: First set context with `seihou context set NAME`, then + edit `~/.config/seihou/contexts/NAME/config.dhall` + - One-off overrides: pass `--var KEY=VALUE` to `seihou run` + +5. **Preview**: Run `seihou run MODULE --dry-run [--var K=V]` to show what files + will be generated. Review the plan with the user before proceeding. + +6. **Execute**: Run `seihou run MODULE [--var K=V]` to generate files. Use `--force` + only if the user explicitly wants to overwrite conflicting files. + +7. **Verify**: Check the results with `seihou status` and `seihou diff`. Read key + generated files to confirm they look correct. + +8. **Commit**: Stage and commit the generated files to git. See the Git Workflow + section below for details. + +9. **Stay current**: When a module's source repository ships a new version, the + user has two surfaces that surface migrations: + - `seihou outdated` lists installed modules whose source has advanced. + - `seihou upgrade` (or `seihou upgrade `) replaces the central + installed copy. If the new version declares `migrations` covering the + project's applied version, the upgrade output ends with an advisory: + `note: has N migration(s) pending; run 'seihou migrate '`. + - `seihou status` then shows a `Pending migrations: …` sub-line under that + module until the migrations are applied. + - `seihou migrate --dry-run` previews the plan; `seihou migrate + ` applies it (rewrites files, updates the manifest, bumps + `moduleVersion`). If the user wants both upgrade and migrate in one shot, + pass `--with-migrations` to `seihou upgrade`. + - When a migration's classifier reports `Conflict` for a file (the user has + edited it since generation), `seihou migrate` refuses without `--force`. + Confirm with the user before passing `--force`. + +Skip steps that don't apply. If the user already knows which module and variables +they want, go directly to preview and execution. + + +## Seihou CLI Commands + +Suggest these commands when the user needs to run them locally: + +### Module discovery and inspection +- `seihou list` — list all available modules, recipes, blueprints, and prompts (project, user, installed) +- `seihou list --prompts` — show only prompt artifacts +- `seihou vars MODULE` — show variable declarations (types, defaults, descriptions) +- `seihou vars MODULE --explain --var K=V` — show resolved values with provenance +- `seihou browse GIT-URL [--tag TAG]` — preview registry entries in a remote repo +- `seihou install GIT-URL [--module NAME] [--all]` — install registry entries from git + +### Configuration +- `seihou config set KEY VALUE` — set local config (.seihou/config.dhall) +- `seihou config set KEY VALUE --global` — set global config +- `seihou config set KEY VALUE --namespace NS` — set namespace config +- `seihou config get KEY` — read a config value +- `seihou config list [--effective]` — list config values (--effective merges all scopes) +- `seihou config unset KEY [--global]` — remove a config value +- `seihou context show` — show active context +- `seihou context set NAME` — set project context (e.g., "work", "personal") +- `seihou context default NAME` — set global default context +- `seihou context clear` — remove project context + +### Generation +- `seihou run MODULE [--var K=V] [--dry-run] [--diff] [--force]` — run a module + - `--dry-run`: preview the plan without writing files + - `--diff`: show diff against current disk state + - `--force`: auto-resolve conflicts by overwriting + - `-m MODULE`: compose additional modules (repeatable) + - `--namespace NS`: override namespace for config lookup + - `-c CTX`: override context for config lookup + - `--no-commands`: skip shell command steps +- `seihou remove MODULE [--dry-run] [--force]` — remove an applied module by executing its declared removal steps + - Only works for modules with a `removal` section (not `None`) + - `--dry-run`: preview the removal plan (Delete, Strip, Rewrite, Run operations) + - `--force`: skip confirmation prompts +- `seihou agent run BLUEPRINT [PROMPT] [--var K=V] [--no-baseline]` — run a blueprint + - Discovers the blueprint, resolves variables (same precedence chain as `seihou run`), optionally applies base modules, then starts the configured provider + - `--no-baseline`: skip applying declared base modules + - `seihou agent --debug run BLUEPRINT`: print the resolved system prompt without contacting the provider +- `seihou prompt run PROMPT [USER-PROMPT] [--var K=V] [--debug]` — run a reusable prompt + - Discovers the prompt, resolves variables, runs command-derived variables, renders the prompt body, then starts the configured provider + - `--debug`: print the rendered prompt without contacting the provider + +### Upgrade and migration +- `seihou outdated` — show installed modules whose source repos have newer versions +- `seihou upgrade [MODULE] [--dry-run] [--with-migrations]` — replace the central installed copy of a module with the latest from its source + - Operates on `~/.config/seihou/installed/`, not on any project's working tree + - When the new version ships migrations covering an applied module, prints a one-line advisory: `note: has N migration(s) pending; run 'seihou migrate '` + - `--with-migrations`: after each upgrade, also run `seihou migrate` against the current project for any applied module that has pending migrations +- `seihou migrate MODULE [--dry-run] [--force] [--to VERSION] [--json]` — apply author-declared migrations to the current project + - Reads `migrations` from the installed module.dhall, plans a contiguous chain from the manifest's recorded version up to the installed version (or `--to`), classifies files (Safe / Conflict / Gone — mirrors `seihou remove`), and executes + - `--dry-run`: preview the plan (per-step op breakdown, total counts) + - `--force`: proceed even when files have user edits + - `--to VERSION`: stop at an intermediate version + - `--json`: machine-readable plan + - See `seihou help migrations` + +### Status and diagnostics +- `seihou status` — show manifest state (applied modules, tracked files, variables); also surfaces a `Pending migrations: N migration(s) pending: X → Y` sub-line under any applied module whose installed copy has advanced past the manifest's recorded version with a covering chain +- `seihou diff` — compare tracked files against disk (modified, deleted, orphaned) +- `seihou validate-module [PATH]` — validate a module definition +- `seihou schema-upgrade [PATH] [--dry-run] [--all]` — upgrade module.dhall to current schema + +### Project initialization +- `seihou init` — initialize ~/.config/seihou/ (run once per machine) + + +## Variable Resolution + +Variables resolve through a 9-level precedence chain (highest to lowest): + +1. CLI flags (`--var key=value`) +2. Environment variables (`SEIHOU_VAR_*`) +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 / interactive prompts + +When helping users configure variables, choose the right scope: +- **Project-specific** values (project.name, project.description) → local config +- **Identity** values (user.name, user.email) → context config (work vs personal) +- **Preference** values (license, default language) → global config +- **Domain** defaults (haskell version, nix settings) → namespace config + + +## Module Schema Reference + +A Seihou module is a directory containing a `module.dhall` file and a `files/` subdirectory. + +### module.dhall format + +```dhall +{ name = "my-module" +, description = Some "What this module does" +, vars = + [ { name = "project.name" + , type = "text" -- text | bool | int | list | choice + , default = None Text -- or Some "value" + , description = Some "Description" + , required = True + , validation = None Text -- or Some "[a-z][a-z0-9-]*" (regex) + } + ] +, exports = [] : List { var : Text, alias : Optional Text } +, prompts = + [ { var = "project.name" + , text = "What is your project name?" + , when = None Text + , choices = None (List Text) + } + ] +, steps = + [ { strategy = "template" -- copy | template | dhall-text | structured + , src = "README.md.tpl" -- relative to files/ + , dest = "README.md" -- output path + , 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 Migration.Type +} +``` + +Modules may declare `migrations` — author-supplied steps that move a project's existing files between module versions. Consumers apply them with `seihou migrate `. Run `seihou help migrations` for detail. + +### Dependencies + +Dependencies use the record form `{ module, vars }`: + dependencies = [ { module = "nix-base", vars = [] : List { name : Text, value : Text } } ] + +### Variable types +- text: String value +- bool: true/false/yes/no/1/0 +- int: Integer +- list: Comma-separated values +- choice: Must match one of the prompt's choices list + + +## Git Workflow + +After generating files with `seihou run`, help the user commit the changes: + +1. **Initialize if needed**: If there's no git repo, run `git init`. + +2. **Review changes**: Run `git status` to see what was generated. Read key files + to confirm they look right. + +3. **Stage files**: Stage the generated files. The `.seihou/` directory should be + committed — it contains the manifest that tracks applied modules and enables + incremental updates. + +4. **Commit**: Write a clear commit message that mentions: + - Which module(s) were applied + - Key variable values (e.g., project name) + - Example: "Apply haskell-base module for my-project" + +5. **Multiple modules**: If composing multiple modules, you can either commit after + each module or after all modules are applied. Committing after each gives a + cleaner history; committing once is simpler. + +6. **Re-runs**: When re-running a module (e.g., to update variables), commit the + changes separately from the initial generation so the history shows what changed. + + +## Response Guidelines + +- Provide exact commands for `seihou`, `git`, and related checks instead of claiming to run them. +- Recommend previewing with `--dry-run` before running for real unless the user explicitly wants to skip. +- Recommend `seihou status` after generation to confirm what was applied. +- Use `seihou vars MODULE --explain` in suggested workflows when the user needs to understand variable resolution. +- If a module is not installed, explain the install command before proceeding. diff --git a/help/agent.md b/help/agent.md new file mode 100644 --- /dev/null +++ b/help/agent.md @@ -0,0 +1,124 @@ +AGENT COMMANDS + +`seihou agent` renders Seihou-aware prompts and starts a configured +provider. The agent commands are for AI-assisted +module authoring, bootstrapping, project setup, and running +agent-driven blueprints. + +CLI providers open interactive local Claude Code or Codex sessions. +API providers send one rendered prompt as a batch completion and print +one assistant response. + +USAGE + + seihou agent [--debug] [--provider PROVIDER] [--model MODEL] [options] + +PARENT OPTIONS + + --debug + Print the resolved system prompt and exit without contacting any + provider. Use this to inspect what Seihou would send. + + --provider PROVIDER + Select the provider for this invocation. Accepted values: + `claude-cli`, `codex-cli`, `anthropic`, `openai`. + + --model MODEL + Select a provider-specific model name or alias for this + invocation. + +Provider and model options may appear on the parent command or on the +subcommand: + + seihou agent --provider codex-cli --model gpt-5 assist "create a module" + seihou agent assist --provider codex-cli --model gpt-5 "create a module" + seihou agent --debug --provider openai setup "inspect this prompt" + +PROVIDERS + + claude-cli + Starts an interactive Claude Code session. Requires the + `claude` binary on PATH and a working local login. With no + explicit model, the CLI chooses its own default. + + codex-cli + Starts an interactive Codex session. Requires the `codex` + binary on PATH and a working local login. With no explicit + model, the CLI chooses its own default. Seihou launches Codex + with workspace-write sandboxing and on-request approvals. + + anthropic + Uses the Anthropic Messages API. Requires `ANTHROPIC_API_KEY` + or `ANTHROPIC_KEY`. Defaults to `claude-sonnet-4-6` when no + model is configured. + + openai + Uses the OpenAI Chat Completions API. Requires `OPENAI_API_KEY` + or `OPENAI_KEY`. Defaults to `gpt-4o-mini` when no model is + configured. + +CONFIGURATION + +Provider and model values resolve independently from module variables. +The first non-blank value wins: + + 1. Subcommand CLI flags: `--provider`, `--model` + 2. Parent CLI flags: `--provider`, `--model` + 3. Environment: `SEIHOU_AGENT_PROVIDER`, `SEIHOU_AGENT_MODEL` + 4. Local config: `.seihou/config.dhall` + 5. Global config: `~/.config/seihou/config.dhall` + 6. Built-in defaults: provider `claude-cli`, no explicit model + +Set personal defaults globally: + + seihou config set agent.provider codex-cli --global + seihou config set agent.model gpt-5 --global + +Use environment variables for a temporary shell session: + + export SEIHOU_AGENT_PROVIDER=openai + export SEIHOU_AGENT_MODEL=gpt-4o-mini + +SUBCOMMANDS + + seihou agent assist [PROMPT] + Render a prompt for creating or modifying Seihou modules. The + prompt includes current project context, available modules, and + the module schema. + + seihou agent bootstrap [PROMPT] [--repo] + Render a prompt for creating a new module from scratch. With + `--repo`, target a multi-module repository with + `seihou-registry.dhall`. + + seihou agent setup [PROMPT] + Render a prompt for using existing Seihou modules in a project: + selecting modules, configuring variables, previewing, running, + verifying, and committing. + + seihou agent run BLUEPRINT [PROMPT] [--var KEY=VALUE] [--no-baseline] + Resolve a blueprint, optionally apply its baseline modules, + render the blueprint prompt, and send it to the configured + provider. A successful non-debug run records applied-blueprint + provenance in `.seihou/manifest.json`. + + seihou prompt run PROMPT [USER-PROMPT] [--var KEY=VALUE] [--debug] + Resolve a reusable prompt, run command-derived variables, render + the prompt body, and send it to the configured provider. Prompts + do not apply blueprint baselines or record blueprint provenance. + +DEBUG EXAMPLES + + seihou agent --debug --provider claude-cli assist "inspect this prompt" + seihou agent --debug --provider codex-cli bootstrap --repo "inspect this prompt" + seihou agent --debug --provider openai setup "inspect this prompt" + seihou agent --debug run my-blueprint --var project.name=demo + +SEE ALSO + + seihou agent --help + seihou help config + seihou help variables + seihou help prompts + docs/cli/agent.md + docs/user/config-and-variables.md diff --git a/help/blueprints.md b/help/blueprints.md new file mode 100644 --- /dev/null +++ b/help/blueprints.md @@ -0,0 +1,138 @@ +BLUEPRINTS + +A blueprint is an agent-driven runnable artifact. Modules and recipes use +Seihou's deterministic execution engine to write files from declared steps. +Blueprints instead package a prompt, optional baseline modules, variables, +and reference files for `seihou agent run`. + +Use a blueprint when the desired output needs judgement, iteration, or +project-specific design decisions that do not fit a fixed module template. +Use a module or recipe when the same inputs should always produce the same +file plan. + +BLUEPRINT STRUCTURE + + A blueprint directory looks like: + + my-blueprint/ + blueprint.dhall Blueprint definition (required) + prompt.md Markdown prompt imported by blueprint.dhall + files/ Optional reference files for the agent + example.md + config.sample + + `seihou new-blueprint my-blueprint` creates this layout. The generated + `blueprint.dhall` imports `prompt.md` as Text so authors can edit the + prompt as normal Markdown instead of escaping it through a Dhall string. + +SCHEMA FIELDS + + The Dhall record uses the Blueprint schema: + + name Blueprint name. Must match [a-z][a-z0-9-]*. + version Optional dotted version for provenance and status. + description Optional human-facing summary. + prompt Required prompt body. Usually `./prompt.md as Text`. + vars Variables resolved before the prompt is rendered. + prompts Interactive questions for missing required variables. + baseModules Modules or recipes to apply before the agent runs. + files Reference files under the blueprint's files/ directory. + allowedTools Extra tools to pre-approve in addition to the base set. + tags Optional discovery tags. + + Blueprints share the same name lookup namespace as modules and recipes. + If a directory contains more than one runnable definition, lookup prefers + `module.dhall`, then `recipe.dhall`, then `blueprint.dhall`. + +VARIABLES AND PROMPTS + + Blueprint variables use the same declaration and resolution model as + module variables: + + seihou agent run my-blueprint --var project.name=demo + + Resolution follows the normal precedence chain: CLI overrides, environment, + local config, namespace config, context config, global config, defaults, + then interactive prompts. Resolved values are substituted into the blueprint + prompt with `{{variable.name}}` placeholders before the agent sees it. + + `seihou vars my-blueprint` lists a blueprint's declared variables. + +BASELINE MODULES + + `baseModules` lets a blueprint apply deterministic scaffolding before the + agent starts. This is useful for stable foundations such as a language + skeleton, Nix setup, CI defaults, or shared repository conventions. + + Each base module entry has the same dependency shape used by recipes: + + { module = "haskell-base" + , vars = [ { name = "project.name", value = "demo" } ] + } + + Base modules must resolve to modules or recipes, not other blueprints. The + agent runner records the applied blueprint in `.seihou/manifest.json` after + a successful run, including baseline provenance. + +REFERENCE FILES + + Files declared in the `files` list must live under the blueprint's `files/` + directory: + + files = + [ { src = "example.md", description = Some "Reference README style" } + ] + + Reference files are meant for examples, snippets, partial templates, design + notes, or sample configs that help the agent produce the right project. They + are not copied automatically by the deterministic engine. During interactive + `claude-cli` and `codex-cli` runs, the runner mounts the existing `files/` + directory and prints its absolute path in the agent prompt so the agent can + read references directly. API providers receive fallback guidance because + they cannot access local directories. + +ALLOWED TOOLS + + `allowedTools` grants a blueprint extra tools beyond the base set required by + every blueprint run. The runner keeps the base tools first and removes + duplicates: + + allowedTools = Some [ "Bash(cabal *)", "Bash(mori *)" ] + + Claude Code receives the effective set through `--allowedTools`. Codex keeps + its workspace-write sandbox and on-request approval policy because it has no + equivalent per-tool allow-list option. + +COMMON COMMANDS + + seihou new-blueprint api-service Scaffold a blueprint + seihou validate-blueprint api-service Check blueprint.dhall and files/ + seihou list List modules, recipes, blueprints, and prompts + seihou vars api-service Show blueprint variables + seihou agent run api-service Run the blueprint with an agent + + `seihou run api-service` refuses when `api-service` resolves to a blueprint. + That command is reserved for deterministic modules and recipes; use + `seihou agent run` for blueprints. + +VALIDATION + + `seihou validate-blueprint [PATH]` checks that: + + - blueprint.dhall exists and evaluates + - the name, version, tags, and allowed tool entries are valid + - the prompt body is non-empty + - variables are unique + - prompts reference declared variables + - baseModules resolve to modules or recipes + - declared reference files exist under files/ + + If validation fails, fix the reported check before publishing or running + the blueprint. + +FURTHER READING + + docs/cli/new-blueprint.md command reference for scaffolding + docs/cli/validate-blueprint.md command reference for validation + seihou help variables variable precedence and overrides + seihou help modules deterministic module authoring diff --git a/help/config.md b/help/config.md new file mode 100644 --- /dev/null +++ b/help/config.md @@ -0,0 +1,64 @@ +CONFIG + +Seihou uses Dhall config files to store variable values that modules can +reference during scaffolding. Config values are organized into scopes, and +the effective config is the merge of all applicable scopes. + +CONFIG SCOPES + + Seihou resolves config from four scopes, in priority order: + + 1. Local .seihou/config.dhall in the current project + 2. Namespace ~/.config/seihou/namespaces//config.dhall + 3. Context ~/.config/seihou/contexts//config.dhall + 4. Global ~/.config/seihou/config.dhall + + Higher-priority scopes override lower ones. Local config is specific to + a single project, while global config applies everywhere. + +READING AND WRITING CONFIG + + seihou config set project.name my-app Set a local value + seihou config get project.name Read a value + seihou config unset project.name Remove a value + seihou config list List all values in scope + seihou config list --effective Show merged config across all scopes + + Scope flags: + + --global, -g Target global scope + --namespace NS, -n Target a namespace scope + --context CTX, -c Target a context scope + + Without any scope flag, commands operate on the local project scope. + +INITIALIZATION + + seihou init + + Creates ~/.config/seihou/ with subdirectories for modules, installed + modules, and a default config.dhall. Safe to run multiple times. + +HOW CONFIG FEEDS INTO MODULES + + When you run a module, Seihou resolves each declared variable by + checking (in order): CLI overrides, config scopes, exported values + from dependencies, and finally defaults or prompts. Use 'seihou vars + MODULE --explain' to see where each value comes from. + +TYPICAL SETUP + + Set up global defaults that apply everywhere: + + seihou config set author.name "Your Name" --global + seihou config set author.email "you@example.com" --global + seihou config set license MIT --global + + Override per-project: + + cd ~/projects/my-app + seihou config set project.name my-app + + Use namespaces for language-specific defaults: + + seihou config set ghc-version 9.12.2 --namespace haskell diff --git a/help/contexts.md b/help/contexts.md new file mode 100644 --- /dev/null +++ b/help/contexts.md @@ -0,0 +1,58 @@ +CONTEXTS + +Contexts let you maintain separate configurations for different environments +— for example, "work" and "personal" — so that variables like author.email +resolve to different values depending on which context is active. + +HOW CONTEXTS WORK + + A context is a named directory under ~/.config/seihou/contexts/ containing + a config.dhall file: + + ~/.config/seihou/contexts/work/config.dhall + ~/.config/seihou/contexts/personal/config.dhall + + When a context is active, its config values participate in variable + resolution alongside local and global config. This means you can set + author.email = "me@work.com" in your work context and + author.email = "me@home.com" in your personal context. + +SETTING AND CLEARING CONTEXTS + + seihou context set work Set project context (writes .seihou/context) + seihou context default personal Set global default (~/.config/seihou/default-context) + seihou context show Show active context and its source + seihou context clear Remove project context + seihou context clear-default Remove global default + +RESOLUTION CHAIN + + Seihou determines the active context by checking: + + 1. Project context .seihou/context file in the current directory + 2. Global default ~/.config/seihou/default-context + 3. None No context is active + + The project context takes priority, so you can have a global default of + "personal" but override it to "work" in specific project directories. + +TYPICAL USE CASE + + Set up two contexts with different author info: + + seihou config set author.name "Work Name" --context work + seihou config set author.email "me@work.com" --context work + seihou config set author.name "Personal Name" --context personal + seihou config set author.email "me@home.com" --context personal + + Then in a work project: + + cd ~/work/my-project + seihou context set work + seihou run haskell-base # uses work author info + + And in a personal project: + + cd ~/personal/my-project + seihou context set personal + seihou run haskell-base # uses personal author info diff --git a/help/git-repository.md b/help/git-repository.md new file mode 100644 --- /dev/null +++ b/help/git-repository.md @@ -0,0 +1,88 @@ +GIT REPOSITORY + +Seihou modules, recipes, blueprints, and prompts can be shared and installed from git +repositories. A repository can contain a single runnable item or multiple items +organized as a registry. + +SINGLE-MODULE REPOSITORY + + A repository with a module.dhall at the root is treated as a single + module. When installed, the module name defaults to the repository name. + + my-module/ + module.dhall + templates/ + ... + + Install with: + + seihou install https://github.com/user/my-module.git + seihou install https://github.com/user/my-module.git --name custom-name + +SINGLE-RECIPE, SINGLE-BLUEPRINT, OR SINGLE-PROMPT REPOSITORY + + A repository with a recipe.dhall, blueprint.dhall, or prompt.dhall at the + root is treated as a single recipe, single blueprint, or single prompt. + Install it the same way: + + seihou install https://github.com/user/my-recipe.git + seihou install https://github.com/user/my-blueprint.git + seihou install https://github.com/user/my-prompt.git + + Recipes run through `seihou run`; blueprints run through + `seihou agent run`; prompts run through `seihou prompt run`. + +REGISTRY REPOSITORY + + A repository with a seihou-registry.dhall at the root is treated as a + registry containing multiple modules, recipes, blueprints, and prompts. Each item + lives in its own subdirectory with its own runnable definition. + + my-templates/ + seihou-registry.dhall + modules/haskell-base/module.dhall + recipes/haskell-library/recipe.dhall + blueprints/api-service/blueprint.dhall + prompts/review-changes/prompt.dhall + + The registry file declares available items with descriptions, versions, and + tags. Install specific items, all items, or choose interactively: + + seihou install https://github.com/user/templates.git --module haskell-base + seihou install https://github.com/user/templates.git --all + seihou install https://github.com/user/templates.git # interactive + +BROWSING BEFORE INSTALLING + + Use 'seihou browse' to inspect a repository without installing anything: + + seihou browse https://github.com/user/templates.git + seihou browse https://github.com/user/templates.git --tag haskell + + For registry repos, this lists all items with descriptions and tags. + +WHERE ITEMS ARE INSTALLED + + Installed items are stored under ~/.config/seihou/installed//. + They appear alongside user-created modules, recipes, blueprints, and prompts in the + search path: + + 1. .seihou/modules/ Project-local items + 2. ~/.config/seihou/modules/ User items + 3. ~/.config/seihou/installed/ Installed (from git) + +BOOTSTRAPPING A NEW REPOSITORY + + The agent bootstrap command can create a new module or registry repository + structure for you: + + seihou agent bootstrap # single module + seihou agent bootstrap --repo # multi-module with registry + +UPGRADE WORKFLOW + + Once installed, modules can be upgraded with `seihou upgrade`. If a newer + module version ships migrations (for renames, + deletions, etc.), the upgrade command surfaces them via an advisory; running + `seihou migrate ` is the post-upgrade step that applies them + to the current project. See `seihou help migrations`. diff --git a/help/kit.md b/help/kit.md new file mode 100644 --- /dev/null +++ b/help/kit.md @@ -0,0 +1,59 @@ +KIT — MANAGE CLAUDE CODE AND CODEX SKILLS AND SUBAGENTS + +Seihou Kit lets you install, update, and remove skills and subagents from +a remote repository (seihou-kit). Install writes provider-native copies +for both Claude Code and Codex. + +COMMANDS + + seihou kit list List available skills and agents + seihou kit install NAME Install to user scope (global) + seihou kit install NAME --project Install to project scope (local) + seihou kit update Pull latest and re-install all + seihou kit update NAME Pull latest and re-install one + seihou kit uninstall NAME Remove from user scope + seihou kit uninstall NAME --project Remove from project scope + seihou kit status Show installed items with scope, providers, and state + +SCOPES + + User scope (default): + ~/.config/seihou/agents/.claude/skills// + ~/.config/seihou/agents/.claude/agents/.md + ~/.agents/skills// + ~/.codex/agents/.toml + Available across all projects. + + Project scope (--project): + .seihou/agents/.claude/skills// + .seihou/agents/.claude/agents/.md + .agents/skills// + .codex/agents/.toml + Scoped to the current project. Can be version-controlled. + +HOW IT WORKS + + The kit repository is shallow-cloned to ~/.cache/seihou/kit/ on first + use. Subsequent operations pull updates with git pull --ff-only. + + A kit.json manifest at the repo root enumerates all available skills + and agents. The install command copies files from the cache to the + target scope directory. + + Each installed item writes a .seihou-kit.json sidecar next to the + provider-native files so status and update can report whether the + installed copy is current, modified, or missing. + + When you run seihou agent assist (or bootstrap, setup), installed + Claude scope directories are passed to Claude Code via --add-dir + flags. Claude Code discovers .claude/skills/ and .claude/agents/ + within each add-dir automatically. + + Codex discovers skills from .agents/skills and custom agents from + .codex/agents in the project, or from ~/.agents/skills and + ~/.codex/agents for user scope. Kit agent Markdown is converted into + Codex custom-agent TOML when installed. + + The cache is disposable — delete ~/.cache/seihou/kit/ and it will + be re-cloned on next use. If the network is unavailable but cached + data exists, commands continue with cached data. diff --git a/help/migrations.md b/help/migrations.md new file mode 100644 --- /dev/null +++ b/help/migrations.md @@ -0,0 +1,176 @@ +MIGRATIONS + +A migration is an author-declared sequence of file-system operations that +moves a project's working tree from one module version to another. When a +module is upgraded — say, from haskell-base 1.0.0 to 2.0.0 — the project +that has it applied may need to rename directories, drop files that v2 +doesn't ship, or run a one-off command. Migrations let module authors +ship that knowledge inside `module.dhall` so consumers don't have to read +a CHANGELOG and reconcile by hand. + +WHEN TO AUTHOR A MIGRATION + + Add a migration when a new version of your module changes the *layout* + of the files it generates: a directory rename, a file removal, a path + pattern shift. You do not need a migration for content-only changes; + re-running `seihou run ` already updates file content. Use + migrations specifically for things that `seihou run` cannot infer on + its own. + +THE MIGRATION RECORD + + Each migration is one record in the `migrations` field of `module.dhall`: + + , migrations = + [ S.Migration::{ from = "1.0.0" + , to = "2.0.0" + , ops = + [ S.MigrationOp.MoveDir + { src = "app", dest = "src" } + , S.MigrationOp.DeleteFile + { path = "Setup.hs" } + ] + } + ] + + - `from` and `to` are dotted versions parsed by `parseVersion`. + - `ops` is the list of operations applied in order. + +OPERATIONS + + Authors compose migrations from five typed operations: + + MoveFile Rename a single tracked file. The engine rewrites the + manifest's files-map key from src to dest so subsequent + `seihou status` and `seihou diff` keep working. + + S.MigrationOp.MoveFile { src = "lib/Old.hs", dest = "src/New.hs" } + + MoveDir Rename a directory. Every manifest entry whose path lies + under src/ has its key rewritten with the dest/ prefix. + + S.MigrationOp.MoveDir { src = "app", dest = "src" } + + DeleteFile Remove a tracked file. Drops the manifest entry. + + S.MigrationOp.DeleteFile { path = "Setup.hs" } + + DeleteDir Recursively remove a directory and drop every manifest + entry under that prefix. + + S.MigrationOp.DeleteDir { path = "obsolete" } + + RunCommand Run a shell command. The escape hatch for changes the + other ops can't express. The manifest is *not* + automatically updated; if your command moves files, you + are responsible for following it with explicit + MoveFile/DeleteFile ops or living with manifest drift. + + S.MigrationOp.RunCommand + { run = "cabal run my-tool -- migrate", workDir = None Text } + +WINDOW SEMANTICS + + When a user runs `seihou migrate`, the planner walks every declared + migration whose [from, to] range falls inside [installed, target] in + ascending `from` order, advancing a cursor as it goes. Migrations + whose `from` is already past the cursor (overlap or stale) are + skipped silently; migrations whose `to` exceeds the target are + skipped (a future invocation with a higher target will pick them + up). + + The cursor never has to land on a declared `from`. Gaps are + permitted: + + installed: 0.2 target: 0.6 + declared: 0.2 → 0.3, 0.5 → 0.6 + + Both edges run in order. The 0.3 → 0.5 gap has no declared + migration and the planner does not stop — it skips the gap and + keeps walking. + +MANIFEST ALWAYS LANDS AT TARGET + + After a successful (non-dry-run) migration, the manifest's recorded + version for the module advances to the supplied target — regardless + of whether any of the declared migrations bridged every gap. A plan + with zero in-window migrations is a "pure version bump" that + advances the manifest's `moduleVersion` field without running any + ops. The terms "blocked migration", "benign upgrade", and + "bump-through" are gone; every invocation either has nothing to do + (`installed == target`) or lands the manifest at the target. + +DUPLICATES AND OVERLAPS + + If two migrations share the same `from`, that is an ambiguity and + the planner refuses (`MigrationDuplicateEdge`). Authors who want a + "leapfrog" migration alongside the smaller steps should declare the + longer span and let the smaller overlapping edges sit unused — the + cursor will advance past them after picking the leapfrog. + +CONFLICT SEMANTICS + + Mirroring `seihou remove`, the engine classifies each + file-targeted op into one of three states before touching disk: + + MFSafe Disk hash matches the manifest's recorded hash. Free + to move or delete. + MFConflict Disk hash differs. The user has edited the file since + it was generated. The engine refuses to overwrite + unless `--force` is passed. + MFGone File is absent on disk. The op is a no-op. + + The conflict check happens up front. With one or more `MFConflict` + paths and no `--force`, no disk mutation occurs. With `--force`, the + migration proceeds and the user-edited bytes ride along (a + MoveFile preserves content; a DeleteFile drops it). + +DRY RUN + + `seihou migrate --dry-run` prints the plan and exits. The + output is identical to a real run, minus the actual disk + modifications. Use this before any non-trivial migration to see + what would be touched. + + For a machine-readable form, pass `--json` (works alongside + `--dry-run`). + +UPGRADE INTEGRATION + + `seihou upgrade` updates the central installed copy under + ~/.config/seihou/installed// but does *not* rewrite project + trees by default. After an upgrade that brings new migrations, + `seihou upgrade` prints a one-line advisory: + + note: haskell-base has 1 migration(s) pending (1.0.0 → 2.0.0); + run 'seihou migrate haskell-base' + + Pass `--with-migrations` to skip the advisory and run migrations + for each upgraded module against the current project in one shot. + +STATUS INTEGRATION + + `seihou status` shows a `Pending migration: -> ( + step(s)). Run: seihou migrate ` sub-line under any applied + module whose installed copy has advanced past the manifest's + recorded version. `` is the count of in-window declared + migrations that will run; it may be zero (the version range has no + applicable migrations and the run will only advance the manifest). + The line is informational — use `seihou migrate ` to apply. + +MANIFEST GUARANTEE + + After a successful (non-dry-run) migration, the manifest's files map + reflects the new paths exactly: a MoveFile rewrites one key, a + MoveDir rewrites every contained key, deletes drop their entries, + and the manifest's `genAt` is bumped. The named applied module's + `moduleVersion` is updated to the supplied target (which may differ + from the highest `to` in the applied migrations — see "Manifest + always lands at target" above). `seihou diff` after a clean + migration is empty; `seihou status` shows no pending migrations. + +SEE ALSO + + seihou migrate --help + seihou upgrade --help + docs/user/migrations.md diff --git a/help/modules.md b/help/modules.md new file mode 100644 --- /dev/null +++ b/help/modules.md @@ -0,0 +1,92 @@ +MODULES + +A module is the basic unit of project scaffolding in Seihou. Each module is a +directory containing a module.dhall definition file and optional supporting +files (templates, static files, Dhall expressions). + +MODULE SEARCH PATH + + Seihou searches for modules in three locations, in order: + + 1. Project modules .seihou/modules// + 2. User modules ~/.config/seihou/modules// + 3. Installed modules ~/.config/seihou/installed// + + The first match wins. Project modules shadow user modules, which shadow + installed modules. + +MODULE STRUCTURE + + A minimal module directory looks like: + + my-module/ + module.dhall Module definition (required) + files/ Static and template files + README.md.tpl Template file (rendered with variables) + .gitignore Static file (copied as-is) + + The module.dhall file declares the module's name, description, variables, + generation steps, and optional dependencies or exports. + +GENERATION STRATEGIES + + Each step in a module uses one of four strategies: + + Copy Copy a file verbatim from the module to the output. + Template Render a Mustache-style template with resolved variables. + DhallText Evaluate a Dhall expression that produces Text output. + Structured (Reserved for future structured merge support.) + +DEPENDENCIES + + Modules can declare dependencies on other modules using the record form: + + dependencies = + [ { module = "nix-base", vars = [] : List { name : Text, value : Text } } + ] + + When you run a module, Seihou loads its dependencies first (topological + sort) and resolves variables across the full dependency graph. Dependencies + can export variables for downstream modules to consume. + + Dependencies can also supply variable bindings to child modules: + + { module = "nix-flake" + , vars = [ { name = "nix.system", value = "x86_64-linux" } ] + } + +SCHEMA PACKAGE + + Seihou publishes its Dhall schema at github.com/shinzui/seihou-schema. + Modules import it via a pinned HTTPS URL with an integrity hash and + use record completion (::) for concise authoring: + + let S = + https://raw.githubusercontent.com/shinzui/seihou-schema//package.dhall + sha256: + + in S.Module::{ name = "my-module" + , steps = [ S.Step::{ strategy = "template" + , src = "foo.tpl", dest = "foo" } ] + } + + Running `seihou new-module` generates modules in this format. + Record completion fills in defaults for optional fields automatically. + +COMMON COMMANDS + + seihou list List all available modules + seihou new-module my-template Scaffold a new module + seihou validate-module ./my-module Check a module is well-formed + seihou install Install modules, recipes, or blueprints from git + seihou run --var k=v Run a module to generate files + seihou remove Remove an applied module and its files + seihou schema-upgrade ./my-module Upgrade module.dhall to current schema + +VERSIONING AND MIGRATIONS + + Modules carry a `version` field that follows dotted-version semantics + (1.0.0, 1.2.3, etc.). When an author bumps a module's version and + changes its file layout, they can ship migrations alongside the new + version that move existing project files into the new shape. Run + `seihou help migrations` for the full reference. diff --git a/help/prompts.md b/help/prompts.md new file mode 100644 --- /dev/null +++ b/help/prompts.md @@ -0,0 +1,119 @@ +PROMPTS + +A prompt is a reusable agent-session template. It renders a Markdown prompt +from Seihou variables, local command output, optional guidance blocks, optional +reference files, and an optional user instruction, then starts the configured +provider. + +Use a prompt for repeatable agent workflows such as code review, release +preparation, planning, repository inspection, or dependency research. Use a +module or recipe for deterministic file generation. Use a blueprint when an +agent should scaffold or modify a project shape and optionally apply baseline +modules first. + +PROMPT STRUCTURE + + A prompt directory looks like: + + review-changes/ + prompt.dhall Prompt definition (required) + prompt.md Markdown body imported by prompt.dhall + files/ Optional reference files for the agent + + `seihou new-prompt review-changes` creates this layout. + +SCHEMA FIELDS + + name Prompt name. Must match [a-z][a-z0-9-]*. + version Optional version for registries and installed origin metadata. + description Optional human-facing summary. + prompt Required prompt body. Usually `./prompt.md as Text`. + vars Typed variables resolved before the prompt is rendered. + prompts Interactive questions for missing typed variables. + commandVars Variables filled by local command output. + guidance Markdown instruction blocks selected after variables resolve. + files Reference files under the prompt's files/ directory. + allowedTools Optional tool allow-list metadata. + tags Optional discovery tags. + launch Optional provider/mode/model hints. + + Prompts share the same name lookup namespace as modules, recipes, and + blueprints. If a directory contains multiple runnable definitions, lookup + prefers `module.dhall`, then `recipe.dhall`, then `blueprint.dhall`, then + `prompt.dhall`. + +VARIABLES + + Prompt variables use the standard Seihou precedence chain: + + CLI --var, environment, local config, namespace config, context config, + global config, defaults, interactive prompts. + + Example: + + seihou config set project.name seihou --global + seihou prompt run review-changes --debug + + A `prompt.md` body containing `{{project.name}}` will render the configured + value unless a higher-precedence source overrides it. + +COMMAND-DERIVED VARIABLES + + `commandVars` fill placeholders from local command output after normal + variables resolve: + + { name = "git.branch" + , run = "git branch --show-current" + , workDir = None Text + , when = None Text + , trim = True + , maxBytes = Some 4096 + } + + Use command variables for compact local context such as branch names, diff + stats, test summaries, or file lists. Non-zero exits fail rendering, and + `maxBytes` limits captured output. + +PROMPT GUIDANCE + + `guidance` adds Markdown instruction blocks around the prompt body in the + provider prompt. Use it for repository workflow rules, project-specific + validation commands, or adaptation based on command-derived variables. + + guidance = + [ { title = "Haskell repository" + , body = "Prefer cabal build all and focused cabal test commands." + , when = Some "Eq repo.kind haskell" + } + ] + + Guidance does not apply blueprint baseline modules and does not write + applied-blueprint provenance. + +COMMON COMMANDS + + seihou new-prompt review-changes Scaffold a prompt + seihou validate-prompt review-changes Check prompt.dhall and files/ + seihou prompt run review-changes Run the prompt with a provider + seihou prompt run review-changes --debug + Print the complete provider prompt + seihou list --prompts Show only prompt artifacts + +PUBLISHING + + Registries can list prompts alongside modules, recipes, and blueprints in a + `prompts = [...]` field. Install prompt entries with the existing registry + selector: + + seihou install GIT-URL --module review-changes + + The selector flag is still named `--module` for compatibility, but it can + select any registry entry kind. + +FURTHER READING + + docs/user/prompts.md prompt authoring guide + docs/cli/new-prompt.md command reference for scaffolding + docs/cli/validate-prompt.md command reference for validation + docs/cli/prompt.md command reference for running prompts + seihou help variables variable precedence and overrides diff --git a/help/templating.md b/help/templating.md new file mode 100644 --- /dev/null +++ b/help/templating.md @@ -0,0 +1,177 @@ +TEMPLATING + +The Template strategy is the middle rung of Seihou's four generation +strategies. It is dispatched by the .tpl file extension and gives a step +two powers: replace {{variable.name}} with the resolved value, and gate +regions of text on a boolean expression via {{#if ...}} blocks. + +Templates stay intentionally dumb. Anything richer -- loops, arithmetic, +derived values, multi-way branching -- belongs to the DhallText strategy, +which evaluates a full Dhall expression after placeholder substitution. +When a template starts fighting you, switch the step to dhall-text rather +than contort the template. + +PLACEHOLDERS + + Syntax: + + {{variable.name}} standard form + {{ variable.name }} surrounding whitespace inside the braces is ignored + \{{variable.name}} literal "{{variable.name}}" in output (escape) + + Variable names match [a-zA-Z][a-zA-Z0-9._-]*. Dots are part of the + name, not structural. + + Coercion from the resolved value to text: + + VText "hello" -> hello + VBool True -> true + VBool False -> false + VInt 42 -> 42 + VList ["a", "b"] -> a,b (comma-separated, recursive) + + Placeholder substitution runs in three positions: + + Template bodies the .tpl file contents + Destination path the `dest` field of a step + Shell commands the `run` and `workDir` fields of command steps + +ESCAPING {{ + + \{{ is consumed and emits a literal {{ in the output. There is no + corresponding \}} escape -- unmatched closers are emitted verbatim. + + Use \{{name}} for placeholders -> Use {{name}} for placeholders + + The escape applies to placeholder syntax only. There is no escape + for block tags; a template cannot emit a literal {{#if sequence. + Use the DhallText strategy when that is required. + +CONDITIONAL BLOCKS + + Inline blocks gate regions of a template body on a boolean expression: + + {{#if EXPR}} ... {{/if}} + {{#if EXPR}} ... {{#else}} ... {{/if}} + + Blocks nest to arbitrary depth; a {{/if}} always pairs with its + nearest open {{#if}}. + + Only the selected branch is expanded. The untaken branch's text is + discarded before it reaches the placeholder engine. Unresolved + placeholders and malformed sub-expressions inside the untaken branch + therefore do not produce errors. This is deliberate: it lets authors + gate optional features without having to declare every variable + referenced inside the gate. + + Conditional blocks work in template bodies only. They do NOT work in + `dest`, `run`, or `workDir`; those positions accept placeholders only + and will treat {{#if}} as a placeholder name that fails to resolve. + The dhall-text and structured strategies express conditionals with + Dhall's own if/then/else after placeholder substitution. + +EXPRESSION LANGUAGE + + The grammar used by {{#if ...}} (and by step-level `when` clauses): + + expr = or_expr + or_expr = and_expr ("||" and_expr)* + and_expr = not_expr ("&&" not_expr)* + not_expr = "!" atom | atom + atom = "IsSet" NAME + | "Eq" NAME VALUE + | "(" expr ")" + | "true" | "false" + VALUE = "quoted string" | bareWord + + IsSet foo true iff foo has a resolved value. + Eq foo VALUE true iff foo's value equals VALUE. Values are + type-sensitive: a bool variable compares against + bare-word true/false, not against quoted "true". + A text variable compares against a quoted string. + && || ! the usual boolean operators. + ( ... ) parentheses group sub-expressions. + true / false literal constants. + +STANDALONE TAG WHITESPACE + + A block tag is standalone on its line when everything before it on + the line is spaces or tabs (or the line starts with the tag) AND + everything after it is spaces or tabs followed by a newline (or the + template ends). A standalone tag absorbs its leading indent and one + trailing newline. A tag that shares a line with other content keeps + all surrounding whitespace verbatim. + + So the readable form: + + prev + {{#if Eq flag true}} + body + {{/if}} + next + + emits `prev\n body\nnext\n` when flag = True and `prev\nnext\n` + when flag = False -- no blank-line cruft either way. The body's + indentation is preserved; the tag lines' indentation is not. + + Only ASCII space (0x20) and tab (0x09) qualify. NBSP and other + Unicode whitespace do NOT trigger the trim. + + A blank line INSIDE a block body survives the trim, so to emit a + deliberate blank separator at the boundary of a gated region, put + the blank inside the block body rather than outside it. + +ERRORS + + The engine reports five error kinds, each with a line number: + + UnresolvedPlaceholder {{name}} references a variable with no value. + MalformedPlaceholder {{ opened on a line without a closing }}. + UnterminatedIf {{#if}} opener with no matching {{/if}}. + OrphanBlockToken {{/if}} or {{#else}} outside any open {{#if}}. + MalformedIfExpression The expression inside {{#if ...}} failed to parse. + + Block-level errors point at the source line of the offending tag. + Placeholder errors inside a taken branch report a line number measured + in the post-expansion text, which may drift from the source line by + the number of newlines absorbed by standalone-trim; the variable name + and relative position are still informative. + +COMMON PATTERNS + + Optional single line: + + nativeBuildInputs = [ + pkgs.cabal-install + {{#if Eq nix.postgresql true}} + pkgs.postgresql + {{/if}} + ]; + + If / else with a default (kept on one line so the output is one line): + + runtime = "{{#if IsSet docker.registry}}{{docker.registry}}/{{project.name}}{{#else}}{{project.name}}{{/if}}"; + + Version-gated content (Eq does string-equal for text variables): + + {{#if Eq ghc.version "ghc912"}} + -- ghc912-specific build flags + ghc-options: -Wno-x-partial + {{/if}} + +WHEN TO USE DHALL-TEXT INSTEAD + + Switch the step's strategy from `template` to `dhall-text` (freeform + Text) or `structured` (JSON / YAML with record-level composition) + when you need to loop over a list, compute a derived value (for + example, major.minor from ghc.version), choose among more than a + handful of discrete cases, or merge structured data across modules. + Both strategies substitute {{variable}} placeholders first, then + evaluate the resulting Dhall expression -- so you still get variable + interpolation on the way in and the full power of Dhall on the way out. + +FURTHER READING + + docs/user/templating.md full reference (this topic condensed) + docs/user/module-authoring.md variables, steps, and strategies in context + docs/user/config-and-variables.md how variables are resolved diff --git a/help/variables.md b/help/variables.md new file mode 100644 --- /dev/null +++ b/help/variables.md @@ -0,0 +1,52 @@ +VARIABLES + +Variables are named, typed values that modules use to customize generated +output. They are declared in module.dhall and resolved at generation time +from multiple sources. + +DECLARING VARIABLES + + Each variable in module.dhall has: + + name Dotted name like "project.name" or "author.email" + type Text (the only type currently supported) + default Optional default value + description Human-readable explanation (shown in prompts) + + Variables without defaults are required — Seihou will prompt for them + interactively or fail if no value is available. + +RESOLUTION ORDER + + When resolving a variable's value, Seihou checks these sources in order: + + 1. CLI overrides --var project.name=my-app + 2. Config values From config.dhall (local, namespace, or global) + 3. Context values From the active context's config.dhall + 4. Exported values From dependency modules that export the variable + 5. Default value Declared in module.dhall + 6. Interactive prompt If running in a TTY, prompt the user + + The first source that provides a value wins. + +EXPORTS + + A module can export variables so that dependent modules can use them. + Exports are declared in module.dhall and make a variable's resolved value + available to any module that depends on this one. + +INSPECTING VARIABLES + + seihou vars List declared variables + seihou vars --explain Show resolved values with provenance + seihou vars --var k=v Supply values for resolution + + The --explain flag is especially useful for debugging: it shows where each + variable's value came from (CLI, config, default, export, etc.). + +NAMESPACING + + When composing multiple modules, variables are scoped by module namespace + to avoid collisions. The namespace defaults to the module name but can be + overridden with --namespace. Config keys under a namespace are looked up + as namespace.variable.name. diff --git a/seihou-cli.cabal b/seihou-cli.cabal new file mode 100644 --- /dev/null +++ b/seihou-cli.cabal @@ -0,0 +1,246 @@ +cabal-version: 3.0 +name: seihou-cli +version: 0.4.0.0 +synopsis: CLI for Seihou project scaffolding +description: + Command-line interface for Seihou, a composable project scaffolding + system. It creates and manages typed scaffolding modules, blueprints, + migrations, registry operations, and project-local configuration. + +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 +extra-source-files: + data/assist-prompt.md + data/blueprint-prompt.md + data/bootstrap-prompt.md + data/prompt-run-prompt.md + data/setup-prompt.md + help/agent.md + help/blueprints.md + help/config.md + help/contexts.md + help/git-repository.md + help/kit.md + help/migrations.md + help/modules.md + help/prompts.md + help/templating.md + help/variables.md + +source-repository head + type: git + location: https://github.com/shinzui/seihou.git + +library seihou-cli-internal + default-language: GHC2024 + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + TypeFamilies + + hs-source-dirs: src + visibility: private + exposed-modules: + Seihou.CLI.AgentCompletion + Seihou.CLI.AgentConfig + Seihou.CLI.AgentLaunch + Seihou.CLI.AppliedBlueprint + Seihou.CLI.BrowseFormat + Seihou.CLI.CommitMessage + Seihou.CLI.Completions.Bash + Seihou.CLI.Completions.Fish + Seihou.CLI.Completions.Zsh + Seihou.CLI.Diff + Seihou.CLI.Extension + Seihou.CLI.Git + Seihou.CLI.Init + Seihou.CLI.InstallHistory + Seihou.CLI.InstallShared + Seihou.CLI.List + Seihou.CLI.Migrate + Seihou.CLI.PendingMigrations + Seihou.CLI.PromptRender + Seihou.CLI.Registry + Seihou.CLI.Registry.Sync + Seihou.CLI.Registry.Validate + Seihou.CLI.RemoteVersion + Seihou.CLI.SavePrompted + Seihou.CLI.SchemaVersion + Seihou.CLI.Shared + Seihou.CLI.StatusRender + Seihou.CLI.Style + Seihou.CLI.VersionCompare + Seihou.Effect.Fzf + Seihou.Effect.FzfInterp + Seihou.Fzf + Seihou.Fzf.Selector + Seihou.Fzf.Selector.Module + + build-depends: + aeson >=2.1 && <3, + aeson-pretty >=0.8 && <1, + ansi-terminal >=1.1 && <2, + baikai ^>=0.3.0.0, + baikai-claude ^>=0.3.0.0, + baikai-openai ^>=0.3.0.0, + base >=4.18 && <5, + bytestring >=0.11 && <1, + containers >=0.6 && <1, + directory >=1.3 && <2, + effectful-core >=2.4 && <3, + file-embed >=0.0.15 && <1, + filepath >=1.4 && <2, + process >=1.6 && <2, + seihou-core ^>=0.4.0.0, + temporary >=1.3 && <2, + text >=2.0 && <3, + time >=1.12 && <2, + vector ^>=0.13.2.0, + +executable seihou + default-language: GHC2024 + ghc-options: -threaded + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + TypeFamilies + + hs-source-dirs: src-exe + main-is: Main.hs + autogen-modules: Paths_seihou_cli + -- Every module below is "trapped" in the executable target by one + -- of: Options.Applicative, Data.FileEmbed, GitHash, + -- Paths_seihou_cli, or — transitively — another trapped seihou + -- module (most often Seihou.CLI.Commands). For the per-module + -- trapping reason, see docs/dev/architecture/overview.md, section + -- "CLI Module Placement Convention" and its "Trapped-modules + -- inventory" subsection. New code should default to the + -- seihou-cli-internal library at hs-source-dirs: src. + other-modules: + Paths_seihou_cli + Seihou.CLI.AgentLaunchExec + Seihou.CLI.AgentRun + Seihou.CLI.Assist + Seihou.CLI.Bootstrap + Seihou.CLI.Browse + Seihou.CLI.Commands + Seihou.CLI.Completions + Seihou.CLI.Config + Seihou.CLI.Context + Seihou.CLI.Help + Seihou.CLI.Install + Seihou.CLI.Kit + Seihou.CLI.NewBlueprint + Seihou.CLI.NewModule + Seihou.CLI.NewPrompt + Seihou.CLI.NewRecipe + Seihou.CLI.Outdated + Seihou.CLI.PromptRun + Seihou.CLI.Remove + Seihou.CLI.Run + Seihou.CLI.SchemaUpgrade + Seihou.CLI.Setup + Seihou.CLI.Status + Seihou.CLI.Upgrade + Seihou.CLI.Validate + Seihou.CLI.ValidateBlueprint + Seihou.CLI.ValidatePrompt + Seihou.CLI.Vars + Seihou.CLI.Version + + build-depends: + aeson >=2.1 && <3, + aeson-pretty >=0.8 && <1, + ansi-terminal >=1.1 && <2, + baikai ^>=0.3.0.0, + baikai-claude ^>=0.3.0.0, + baikai-kit ^>=0.1.0.1, + baikai-openai ^>=0.3.0.0, + base >=4.18 && <5, + bytestring >=0.11 && <1, + containers >=0.6 && <1, + directory >=1.3 && <2, + effectful-core >=2.4 && <3, + file-embed >=0.0.15 && <1, + filepath >=1.4 && <2, + githash ^>=0.1, + optparse-applicative >=0.18 && <1, + process >=1.6 && <2, + seihou-cli-internal, + seihou-core ^>=0.4.0.0, + temporary >=1.3 && <2, + text >=2.0 && <3, + time >=1.12 && <2, + +test-suite seihou-cli-test + type: exitcode-stdio-1.0 + default-language: GHC2024 + default-extensions: + DuplicateRecordFields + NoFieldSelectors + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + + hs-source-dirs: test + main-is: Main.hs + default-extensions: + TypeFamilies + + other-modules: + Seihou.CLI.AgentCompletionSpec + Seihou.CLI.AgentConfigSpec + Seihou.CLI.AgentLaunchSpec + Seihou.CLI.AppliedBlueprintSpec + Seihou.CLI.BrowseFormatSpec + Seihou.CLI.CommitMessageSpec + Seihou.CLI.DiffSpec + Seihou.CLI.ExtensionSpec + Seihou.CLI.GitSpec + Seihou.CLI.InitSpec + Seihou.CLI.InstallHistorySpec + Seihou.CLI.ListSpec + Seihou.CLI.MigrateSpec + Seihou.CLI.PendingMigrationSpec + Seihou.CLI.PromptRenderSpec + Seihou.CLI.Registry.SyncSpec + Seihou.CLI.Registry.ValidateSpec + Seihou.CLI.RemoteVersionSpec + Seihou.CLI.RunBlueprintRefusalSpec + Seihou.CLI.SavePromptedSpec + Seihou.CLI.StatusSpec + Seihou.CLI.UpgradeSpec + Seihou.FzfSpec + + build-depends: + aeson >=2.1 && <3, + baikai ^>=0.3.0.0, + base >=4.18 && <5, + bytestring >=0.11 && <1, + containers >=0.6 && <1, + directory >=1.3 && <2, + effectful-core >=2.4 && <3, + filepath >=1.4 && <2, + hspec >=2.11 && <3, + process >=1.6 && <2, + seihou-cli-internal, + seihou-core ^>=0.4.0.0, + tasty >=1.4 && <2, + tasty-hspec >=1.2 && <2, + temporary >=1.3 && <2, + text >=2.0 && <3, + time >=1.12 && <2, + vector ^>=0.13.2.0, diff --git a/src-exe/Main.hs b/src-exe/Main.hs new file mode 100644 --- /dev/null +++ b/src-exe/Main.hs @@ -0,0 +1,162 @@ +module Main (main) where + +import Control.Applicative ((<|>)) +import Data.List (isPrefixOf) +import Data.String (fromString) +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import Options.Applicative (customExecParser, prefs, showHelpOnEmpty) +import Seihou.CLI.AgentCompletion qualified as AgentCompletion +import Seihou.CLI.AgentConfig (loadAgentModelConfig) +import Seihou.CLI.AgentRun (handleAgentRun) +import Seihou.CLI.Assist (handleAssist) +import Seihou.CLI.Bootstrap (handleBootstrap) +import Seihou.CLI.Browse (handleBrowse) +import Seihou.CLI.Commands +import Seihou.CLI.Completions (handleCompletionsCommand) +import Seihou.CLI.Config (handleConfig) +import Seihou.CLI.Context (handleContext) +import Seihou.CLI.Diff (handleDiff) +import Seihou.CLI.Extension (ExtensionRunOpts (..), handleExtensionRun) +import Seihou.CLI.Help (handleHelpCommand) +import Seihou.CLI.Init (handleInit) +import Seihou.CLI.Install (handleInstall) +import Seihou.CLI.Kit (runKit) +import Seihou.CLI.List (ListFilter (..), handleList) +import Seihou.CLI.Migrate (handleMigrate) +import Seihou.CLI.NewBlueprint (handleNewBlueprint) +import Seihou.CLI.NewModule (handleNewModule) +import Seihou.CLI.NewPrompt (handleNewPrompt) +import Seihou.CLI.NewRecipe (handleNewRecipe) +import Seihou.CLI.Outdated (handleOutdated) +import Seihou.CLI.PromptRun (handlePromptRun) +import Seihou.CLI.Registry (handleRegistry) +import Seihou.CLI.Remove (handleRemove) +import Seihou.CLI.Run (handleRun) +import Seihou.CLI.SchemaUpgrade (handleSchemaUpgrade) +import Seihou.CLI.Setup (handleSetup) +import Seihou.CLI.Status (handleStatus) +import Seihou.CLI.Upgrade (handleUpgrade) +import Seihou.CLI.Validate (handleValidateModule) +import Seihou.CLI.ValidateBlueprint (handleValidateBlueprint) +import Seihou.CLI.ValidatePrompt (handleValidatePrompt) +import Seihou.CLI.Vars (handleVars) +import Seihou.Core.Module (RunnableKind (..)) +import System.Environment (getArgs) +import System.Exit (exitFailure) + +main :: IO () +main = do + rawArgs <- getArgs + case extensionRunFromRawArgs rawArgs of + Just extensionRunOpts -> + handleExtensionRun extensionRunOpts + Nothing -> do + cmd <- customExecParser (prefs showHelpOnEmpty) opts + dispatch cmd + +extensionRunFromRawArgs :: [String] -> Maybe ExtensionRunOpts +extensionRunFromRawArgs ("extension" : "run" : name : rest) + | not ("-" `isPrefixOf` name) = + Just + ExtensionRunOpts + { extensionName = fromString name, + extensionArgs = + case rest of + "--" : forwarded -> forwarded + forwarded -> forwarded + } +extensionRunFromRawArgs _ = Nothing + +dispatch :: Command -> IO () +dispatch cmd = + case cmd of + Init -> + handleInit + Run runOpts -> + handleRun runOpts + Remove removeOpts -> + handleRemove removeOpts + Vars varsOpts -> + handleVars varsOpts + Install installOpts -> + handleInstall installOpts + Status statusOpts -> + handleStatus statusOpts + Diff -> + handleDiff + List listOpts -> + let kinds = + [KindModule | listOpts.listModulesOnly] + <> [KindRecipe | listOpts.listRecipesOnly] + <> [KindBlueprint | listOpts.listBlueprintsOnly] + <> [KindPrompt | listOpts.listPromptsOnly] + in handleList (ListFilter listOpts.listRepo listOpts.listTag kinds) + NewModule newModOpts -> + handleNewModule newModOpts + NewRecipe newRecOpts -> + handleNewRecipe newRecOpts + NewBlueprint newBpOpts -> + handleNewBlueprint newBpOpts + NewPrompt newPromptOpts -> + handleNewPrompt newPromptOpts + ValidateModule validateOpts -> + handleValidateModule validateOpts + ValidateBlueprint validateBpOpts -> + handleValidateBlueprint validateBpOpts + ValidatePrompt validatePromptOpts -> + handleValidatePrompt validatePromptOpts + Config configOpts -> + handleConfig configOpts + Context contextAction -> + handleContext contextAction + Browse browseOpts -> + handleBrowse browseOpts + Outdated outdatedOpts -> + handleOutdated outdatedOpts + Upgrade upgradeOpts -> + handleUpgrade upgradeOpts + Migrate migrateOpts -> + handleMigrate migrateOpts + SchemaUpgrade schemaUpgradeOpts -> + handleSchemaUpgrade schemaUpgradeOpts + Registry registryCmd -> + handleRegistry registryCmd + Kit kitCmd -> + runKit kitCmd + Agent agentOpts -> do + case agentOpts.agentCommand of + AgentAssist assistOpts -> do + modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel assistOpts.assistProvider assistOpts.assistModel + handleAssist agentOpts.agentDebug modelConfig assistOpts + AgentBootstrap bootstrapOpts -> do + modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel bootstrapOpts.bootstrapProvider bootstrapOpts.bootstrapModel + handleBootstrap agentOpts.agentDebug modelConfig bootstrapOpts + AgentSetup setupOpts -> do + modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel setupOpts.setupProvider setupOpts.setupModel + handleSetup agentOpts.agentDebug modelConfig setupOpts + AgentRun blueprintRunOpts -> do + modelConfig <- resolveAgentModelConfig agentOpts.agentProvider agentOpts.agentModel blueprintRunOpts.runBlueprintProvider blueprintRunOpts.runBlueprintModel + handleAgentRun agentOpts.agentDebug modelConfig blueprintRunOpts + Prompt promptCmd -> do + case promptCmd of + PromptRun promptRunOpts -> do + modelConfig <- resolveAgentModelConfig Nothing Nothing promptRunOpts.runPromptProvider promptRunOpts.runPromptModel + handlePromptRun modelConfig promptRunOpts + Extension extensionCmd -> do + case extensionCmd of + ExtensionRun extensionRunOpts -> + handleExtensionRun extensionRunOpts + HelpCmd helpCmd -> + handleHelpCommand helpCmd + Completions completionsCmd -> + handleCompletionsCommand completionsCmd + +resolveAgentModelConfig :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> IO AgentCompletion.AgentModelConfig +resolveAgentModelConfig parentProvider parentModel commandProvider commandModel = do + configResult <- loadAgentModelConfig (commandProvider <|> parentProvider) (commandModel <|> parentModel) + case configResult of + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure + Right config -> pure config diff --git a/src-exe/Seihou/CLI/AgentLaunchExec.hs b/src-exe/Seihou/CLI/AgentLaunchExec.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/AgentLaunchExec.hs @@ -0,0 +1,115 @@ +module Seihou.CLI.AgentLaunchExec + ( launchConfiguredAgent, + launchConfiguredAgentAddingDirs, + launchConfiguredAgentWith, + ) +where + +import Baikai.Interactive + ( CodexApprovalPolicy (CodexApprovalOnRequest), + CodexSandboxMode (CodexWorkspaceWrite), + InteractiveLaunchResult (..), + InteractiveSafety (ClaudeAllowedTools, CodexSandbox), + extraDirs, + interactiveLaunchRequest, + modelId, + safety, + systemPrompt, + workingDir, + ) +import Baikai.Kit.Session qualified as KitSession +import Baikai.Provider.Claude.Interactive + ( defaultClaudeInteractiveConfig, + launchClaudeInteractive, + ) +import Baikai.Provider.OpenAI.Interactive + ( defaultCodexInteractiveConfig, + launchCodexInteractive, + ) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentCompletion (AgentModelConfig (..), AgentProvider (..)) +import Seihou.CLI.Kit (seihouKitConfig) +import Seihou.Prelude +import System.Directory (findExecutable, getCurrentDirectory) +import System.Exit (ExitCode (..), exitFailure) + +launchConfiguredAgent :: AgentModelConfig -> [String] -> Bool -> Text -> Maybe Text -> IO ExitCode +launchConfiguredAgent = launchConfiguredAgentAddingDirs [] + +launchConfiguredAgentAddingDirs :: [FilePath] -> AgentModelConfig -> [String] -> Bool -> Text -> Maybe Text -> IO ExitCode +launchConfiguredAgentAddingDirs extraDirs modelConfig tools debug systemPrompt initialPrompt = do + sessionDirs <- KitSession.agentDirsForSession seihouKitConfig + launchConfiguredAgentWith (sessionDirs <> extraDirs) modelConfig tools debug systemPrompt initialPrompt + +launchConfiguredAgentWith :: [FilePath] -> AgentModelConfig -> [String] -> Bool -> Text -> Maybe Text -> IO ExitCode +launchConfiguredAgentWith addDirs modelConfig tools debug systemPrompt initialPrompt + | debug = do + TIO.putStr systemPrompt + pure ExitSuccess + | otherwise = + case modelConfig.agentProvider of + AgentProviderClaudeCli -> + launchClaude addDirs tools modelConfig.agentModel systemPrompt initialPrompt + AgentProviderCodexCli -> + launchCodex addDirs modelConfig.agentModel systemPrompt initialPrompt + AgentProviderAnthropic -> + unsupportedInteractiveProvider "anthropic" + AgentProviderOpenAI -> + unsupportedInteractiveProvider "openai" + +launchClaude :: [FilePath] -> [String] -> Maybe Text -> Text -> Maybe Text -> IO ExitCode +launchClaude addDirs tools model systemPrompt initialPrompt = do + claudePath <- findExecutable "claude" + case claudePath of + Nothing -> do + TIO.putStrLn "Error: 'claude' CLI (Claude Code) not found on PATH." + TIO.putStrLn "Install it from: https://docs.anthropic.com/en/docs/claude-code" + exitFailure + Just _ -> do + cwd <- getCurrentDirectory + InteractiveLaunchResult {exitCode} <- + launchClaudeInteractive + defaultClaudeInteractiveConfig + (interactiveLaunchRequest (promptOrEmpty initialPrompt)) + { systemPrompt = Just systemPrompt, + modelId = model, + workingDir = Just cwd, + extraDirs = addDirs, + safety = ClaudeAllowedTools (map T.pack tools) + } + pure exitCode + +launchCodex :: [FilePath] -> Maybe Text -> Text -> Maybe Text -> IO ExitCode +launchCodex addDirs model systemPrompt initialPrompt = do + codexPath <- findExecutable "codex" + case codexPath of + Nothing -> do + TIO.putStrLn "Error: 'codex' CLI not found on PATH." + TIO.putStrLn "Install and authenticate Codex CLI, then retry." + exitFailure + Just _ -> do + cwd <- getCurrentDirectory + InteractiveLaunchResult {exitCode} <- + launchCodexInteractive + defaultCodexInteractiveConfig + (interactiveLaunchRequest (promptOrEmpty initialPrompt)) + { systemPrompt = Just systemPrompt, + modelId = model, + workingDir = Just cwd, + extraDirs = addDirs, + safety = CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest + } + pure exitCode + +promptOrEmpty :: Maybe Text -> Text +promptOrEmpty = maybe "" id + +unsupportedInteractiveProvider :: Text -> IO ExitCode +unsupportedInteractiveProvider providerName = do + TIO.putStrLn $ + "Error: provider '" + <> providerName + <> "' is an API provider and cannot start an interactive local agent session." + TIO.putStrLn "Use --provider claude-cli or --provider codex-cli for interactive agent sessions." + exitFailure diff --git a/src-exe/Seihou/CLI/AgentRun.hs b/src-exe/Seihou/CLI/AgentRun.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/AgentRun.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Agent runner for blueprints. Loads a blueprint, resolves its +-- variables (with the same precedence chain as @seihou run@), optionally +-- applies its declared @baseModules@, renders the prompt template, and +-- sends the rendered prompt through the configured Baikai provider. See EP-31 +-- (docs/plans/31-blueprint-agent-runner.md) for the full design. +module Seihou.CLI.AgentRun + ( handleAgentRun, + appliedBlueprintFromOutcome, + runRenderedAgentPrompt, + ) +where + +import Control.Monad (when) +import Data.FileEmbed (embedFile) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, maybeToList) +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.Time (UTCTime) +import Data.Time.Clock (getCurrentTime) +import Seihou.CLI.AgentCompletion + ( AgentModelConfig (..), + AgentProvider (..), + buildAgentCompletionRequest, + runAgentCompletion, + ) +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + BaselineStatus (..), + formatAvailableModules, + formatBaselineStatus, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatReferenceFiles, + formatReferenceFilesDir, + formatSeihouProjectState, + gatherAgentContext, + resolveBlueprintTools, + substitute, + ) +import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs) +import Seihou.CLI.AppliedBlueprint (recordAppliedBlueprint) +import Seihou.CLI.Commands (BlueprintRunOpts (..)) +import Seihou.CLI.Shared + ( deriveNamespace, + formatVarError, + logIO, + toVarNameMap, + unwrapConfig, + ) +import Seihou.Composition.Instance (ModuleInstance (..), primaryInstance, qualifiedName) +import Seihou.Composition.Plan (compileComposedPlan) +import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) +import Seihou.Core.Context (resolveContext) +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) +import Seihou.Core.Types +import Seihou.Effect.ConfigReader + ( readContextConfig, + readGlobalConfig, + readLocalConfig, + readNamespaceConfig, + ) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConsoleInterp (runConsole) +import Seihou.Effect.Filesystem (createDirectoryIfMissing) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Logger (logError, logInfo) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Engine.Conflict (resolveConflicts) +import Seihou.Engine.Diff (computeDiff) +import Seihou.Engine.Execute (executePlan) +import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) +import Seihou.Prelude +import System.Directory (doesDirectoryExist, makeAbsolute) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..), exitFailure, exitWith) +import System.FilePath (takeDirectory, ()) + +-- | The prompt template, embedded at compile time from data/blueprint-prompt.md. +promptTemplate :: Text +promptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-prompt.md") + +handleAgentRun :: Bool -> AgentModelConfig -> BlueprintRunOpts -> IO () +handleAgentRun debug modelConfig opts = do + let level = if opts.runBlueprintVerbose then LogVerbose else LogNormal + + -- (a) Discover and validate. discoverRunnable resolves by directory + -- name (priority: module > recipe > blueprint). + searchPaths <- defaultSearchPaths + runnableResult <- discoverRunnable searchPaths opts.runBlueprintName + (bp, blueprintDir) <- case runnableResult of + Right (RunnableBlueprint b dir) -> pure (b, dir) + Right (RunnableModule _ _) -> + exitErr level $ + "'" + <> opts.runBlueprintName.unModuleName + <> "' is a module, not a blueprint. Did you mean 'seihou run " + <> opts.runBlueprintName.unModuleName + <> "'?" + Right (RunnableRecipe _ _) -> + exitErr level $ + "'" + <> opts.runBlueprintName.unModuleName + <> "' is a recipe, not a blueprint. Did you mean 'seihou run " + <> opts.runBlueprintName.unModuleName + <> "'?" + Left err -> exitErr level (renderModuleLoadError err) + + let filesDir = blueprintDir "files" + providerCanMountFiles = + modelConfig.agentProvider == AgentProviderClaudeCli + || modelConfig.agentProvider == AgentProviderCodexCli + filesExist <- doesDirectoryExist filesDir + mFilesDir <- + if filesExist && providerCanMountFiles + then Just <$> makeAbsolute filesDir + else pure Nothing + + -- (b) Resolve blueprint variables. Wrap the blueprint's vars/prompts + -- in a placeholder Module so 'resolveWithPrompts' can run the + -- standard precedence chain (CLI > env > local > namespace > context + -- > global > defaults > interactive prompts). + let placeholderModule = + Module + { name = bp.name, + version = bp.version, + description = bp.description, + vars = bp.vars, + exports = [], + prompts = bp.prompts, + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + placeholderInst = primaryInstance bp.name + placeholderTriple = (placeholderInst, placeholderModule, blueprintDir) + + envPairs <- getEnvironment + let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runBlueprintVars] + envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] + namespace = fromMaybe (deriveNamespace bp.name) opts.runBlueprintNamespace + context <- resolveContext opts.runBlueprintContext envVars + let contextName = fromMaybe "" context + + resolveResult <- runEff $ runConfigReader $ runConsole $ do + localCfg <- readLocalConfig >>= unwrapConfig level + nsCfg <- readNamespaceConfig namespace >>= unwrapConfig level + ctxCfg <- readContextConfig contextName >>= unwrapConfig level + gCfg <- readGlobalConfig >>= unwrapConfig level + resolveWithPrompts + [placeholderTriple] + cliOverrides + envVars + namespace + contextName + (toVarNameMap localCfg) + (toVarNameMap nsCfg) + (toVarNameMap ctxCfg) + (toVarNameMap gCfg) + + resolved <- case resolveResult of + Left errs -> do + logIO level $ logError "Error resolving blueprint variables:" + mapM_ (logIO level . logError . (" " <>) . formatVarError) errs + exitFailure + Right r -> pure (Map.findWithDefault Map.empty placeholderInst r) + + -- (c) Baseline. + baseline <- + if opts.runBlueprintNoBaseline + then pure BaselineSkipped + else + if null bp.baseModules + then pure BaselineEmpty + else applyBaseline level opts bp.baseModules cliOverrides resolved + + -- (d) Render the user prompt: substitute resolved vars into bp.prompt. + let renderedUser = renderUserPrompt resolved bp.prompt + + -- (e) Render the system prompt around the user body. + ctx <- gatherAgentContext + let systemPrompt = renderSystemPrompt ctx bp baseline mFilesDir renderedUser + + -- (f) Launch. + launchSucceeded <- + runRenderedAgentPrompt + debug + modelConfig + (resolveBlueprintTools bp.allowedTools) + mFilesDir + systemPrompt + opts.runBlueprintPrompt + + -- (g) Record the applied-blueprint provenance into + -- .seihou/manifest.json only after a successful provider response. In + -- debug mode, keep the previous successful dry-launch behavior by recording + -- after the rendered prompt is printed successfully. + when launchSucceeded $ do + now <- getCurrentTime + let entry = appliedBlueprintFromOutcome bp baseline opts now + manifestPath = ".seihou" "manifest.json" + writeRes <- recordAppliedBlueprint manifestPath entry + case writeRes of + Right () -> pure () + Left err -> + logIO level $ + logError $ + "Warning: agent succeeded but recording the applied-blueprint entry failed: " + <> err + +runRenderedAgentPrompt :: Bool -> AgentModelConfig -> [String] -> Maybe FilePath -> Text -> Maybe Text -> IO Bool +runRenderedAgentPrompt debug modelConfig tools mFilesDir systemPrompt initialPrompt + | debug = do + TIO.putStr systemPrompt + pure True + | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + exitCode <- + launchConfiguredAgentAddingDirs + (maybeToList mFilesDir) + modelConfig + tools + debug + systemPrompt + initialPrompt + case exitCode of + ExitSuccess -> pure True + ExitFailure _ -> exitWith exitCode + | otherwise = do + result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + case result of + Right assistantText -> do + TIO.putStrLn assistantText + pure True + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure + +-- | Project the runner's local state into the persistent +-- 'AppliedBlueprint' shape. Pure so the manifest writer remains a +-- one-liner at the call site and so cross-plan tests can drive it +-- with synthetic inputs. +appliedBlueprintFromOutcome :: + Blueprint -> BaselineStatus -> BlueprintRunOpts -> UTCTime -> AppliedBlueprint +appliedBlueprintFromOutcome bp baseline opts now = + AppliedBlueprint + { name = bp.name, + blueprintVersion = bp.version, + appliedAt = now, + baselineModules = case baseline of + BaselineApplied entries -> map fst entries + BaselineEmpty -> [] + BaselineSkipped -> [], + noBaseline = case baseline of + BaselineSkipped -> True + _ -> False, + userPrompt = opts.runBlueprintPrompt, + agentSessionId = Nothing + } + +-- | Apply the blueprint's @baseModules@ to the cwd. Mirrors the +-- composition pipeline in @Seihou.CLI.Run.handleRun@: load every +-- declared base module (plus transitive deps), resolve their variables +-- through the same precedence chain (with the blueprint's own resolved +-- vars folded into the CLI override map so the agent's prompt and the +-- base modules see the same values), compile the composed plan, +-- compute the diff, resolve conflicts, execute the plan, and write the +-- resulting manifest. Returns 'BaselineApplied' listing each module's +-- (name, version) for the prompt's "Baseline" section. +applyBaseline :: + LogLevel -> + BlueprintRunOpts -> + [Dependency] -> + Map VarName Text -> + Map VarName ResolvedVar -> + IO BaselineStatus +applyBaseline level opts baseModules cliOverridesIn resolvedBlueprintVars = do + searchPaths <- defaultSearchPaths + (primary, additionals) <- case baseModules of + d : rs -> pure (d.depModule, map (.depModule) rs) + [] -> exitErr level "internal error: applyBaseline called with empty baseModules" + compositionResult <- loadComposition searchPaths primary additionals + modulesInOrder <- case compositionResult of + Left err -> do + logIO level $ logError $ "Baseline error: " <> renderModuleLoadError err + exitFailure + Right ms -> pure ms + + -- Fold the blueprint's resolved vars into the CLI override map for + -- the base modules. CLI overrides (already present in cliOverridesIn) + -- win over blueprint values, mirroring 'seihou run' semantics. + let blueprintAsOverrides = + Map.fromList + [(vn, varValueToText rv.value) | (vn, rv) <- Map.toList resolvedBlueprintVars] + cliOverrides = Map.union cliOverridesIn blueprintAsOverrides + + envPairs <- getEnvironment + let envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] + namespace = fromMaybe (deriveNamespace primary) opts.runBlueprintNamespace + context <- resolveContext opts.runBlueprintContext envVars + let contextName = fromMaybe "" context + + baseResolveResult <- runEff $ runConfigReader $ runConsole $ do + localCfg <- readLocalConfig >>= unwrapConfig level + nsCfg <- readNamespaceConfig namespace >>= unwrapConfig level + ctxCfg <- readContextConfig contextName >>= unwrapConfig level + gCfg <- readGlobalConfig >>= unwrapConfig level + resolveWithPrompts + modulesInOrder + cliOverrides + envVars + namespace + contextName + (toVarNameMap localCfg) + (toVarNameMap nsCfg) + (toVarNameMap ctxCfg) + (toVarNameMap gCfg) + + baseResolved <- case baseResolveResult of + Left errs -> do + logIO level $ logError "Error resolving baseline variables:" + mapM_ (logIO level . logError . (" " <>) . formatVarError) errs + exitFailure + Right r -> pure r + + -- Compile the plan. + let quads = + [ (inst, m, dir, Map.map (.value) (baseResolved Map.! inst)) + | (inst, m, dir) <- modulesInOrder + ] + planResult <- compileComposedPlan quads + (ops, _warnings, ownerMap) <- case planResult of + Left errs -> do + logIO level $ logError "Errors compiling baseline plan:" + mapM_ (logIO level . logError . (" " <>)) errs + exitFailure + Right r -> pure r + + -- Read the manifest, compute the diff, resolve conflicts, execute, + -- write the manifest. Mirrors Seihou.CLI.Run.handleRun. + now <- getCurrentTime + let manifestPath = ".seihou" "manifest.json" + planned = + [(dest, content, primary, Nothing) | WriteFileOp dest content _ <- ops] + ++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- ops] + + existingRes <- runEff $ runFilesystem $ runManifestStore manifestPath $ do + createDirectoryIfMissing True (takeDirectory manifestPath) + readManifest + manifest <- case existingRes of + Left err -> do + logIO level $ logError $ "Error reading manifest: " <> err + exitFailure + Right m -> pure (fromMaybe (emptyManifest now) m) + + diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do + let composedNames = + Set.fromList $ + concatMap (\(inst, _, _) -> [inst.instanceModule, qualifiedName inst]) modulesInOrder + computeDiff manifest composedNames planned + + resolutions <- + runEff $ runConsole $ resolveConflicts opts.runBlueprintForce diff.conflicts + case resolutions of + Nothing -> do + logIO level $ logError "Baseline conflicts detected (use --force to overwrite):" + mapM_ (\c -> logIO level (logError (" ! " <> T.pack c.path))) diff.conflicts + exitFailure + Just conflictResolved -> do + let keepRecords = + Map.fromList + [ ( c.path, + case Map.lookup c.path manifest.files of + Just existing -> existing {hash = c.diskHash, generatedAt = now} + Nothing -> + FileRecord + { hash = c.diskHash, + moduleName = c.moduleName, + strategy = Template, + generatedAt = now + } + ) + | (c, KeepCurrent) <- conflictResolved + ] + skipPaths = [c.path | (c, Skip) <- conflictResolved] + excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths) + opsForExec = filter (not . opTargetsPath excludePaths) ops + + runEff $ runFilesystem $ runManifestStore manifestPath $ do + recs <- executePlan "" opsForExec ownerMap primary now + + let orphanedPaths = map (.path) diff.orphaned + cleanedFiles = foldr Map.delete manifest.files orphanedPaths + allModuleEntries = updateAllModules manifest.modules modulesInOrder now + allResolvedVals = + Map.unions [Map.map (.value) vs | vs <- Map.elems baseResolved] + newManifest = + Manifest + { version = currentManifestVersion, + genAt = now, + modules = allModuleEntries, + vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, + files = Map.unions [recs, keepRecords, cleanedFiles], + recipe = manifest.recipe, + blueprint = manifest.blueprint + } + writeManifest newManifest + + let nNew = length diff.new + nMod = length diff.modified + nUnch = length diff.unchanged + logIO level $ + logInfo $ + "Baseline applied: " + <> T.pack (show nNew) + <> " new, " + <> T.pack (show nMod) + <> " modified, " + <> T.pack (show nUnch) + <> " unchanged." + pure $ + BaselineApplied + [(m.name, m.version) | (_, m, _) <- modulesInOrder] + +-- | Stitch the system-prompt template together. Each block in +-- @blueprint-prompt.md@ has a @{{key}}@ placeholder filled here. +renderSystemPrompt :: AgentContext -> Blueprint -> BaselineStatus -> Maybe FilePath -> Text -> Text +renderSystemPrompt ctx bp baseline mFilesDir userPrompt = + substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx), + ("blueprint_name", bp.name.unModuleName), + ("blueprint_version", fromMaybe "(unspecified)" bp.version), + ("blueprint_description", fromMaybe "(no description)" bp.description), + ("baseline_status", formatBaselineStatus baseline), + ("reference_files", formatReferenceFiles bp.files), + ("reference_files_dir", formatReferenceFilesDir mFilesDir), + ("user_prompt", userPrompt) + ] + promptTemplate + +-- | Substitute resolved blueprint variables into the user prompt body. +renderUserPrompt :: Map VarName ResolvedVar -> Text -> Text +renderUserPrompt resolved tpl = + substitute + [(vn.unVarName, varValueToText rv.value) | (vn, rv) <- Map.toList resolved] + tpl + +-- | Local copy of @Seihou.CLI.Run.varValueToText@. Kept in sync with the +-- original; if a third caller appears, lift it into Seihou.CLI.Shared. +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) + +-- | Whether an operation targets a file in the given path set. Local +-- copy of @Seihou.CLI.Run.opTargetsPath@. +opTargetsPath :: Set FilePath -> Operation -> Bool +opTargetsPath paths (WriteFileOp dest _ _) = Set.member dest paths +opTargetsPath paths (PatchFileOp dest _ _ _ _) = Set.member dest paths +opTargetsPath _ _ = False + +-- | Merge freshly-composed module instances into the manifest's +-- applied-modules list. Local copy of @Seihou.CLI.Run.updateAllModules@. +updateAllModules :: + [AppliedModule] -> + [(ModuleInstance, Module, FilePath)] -> + UTCTime -> + [AppliedModule] +updateAllModules existing modulesInOrder now = + let composedKeys = + Set.fromList + [ (inst.instanceModule, inst.instanceParentVars) + | (inst, _, _) <- modulesInOrder + ] + filtered = + filter (\am -> not (Set.member (am.name, am.parentVars) composedKeys)) existing + new = + [ AppliedModule + { name = inst.instanceModule, + parentVars = inst.instanceParentVars, + source = dir, + moduleVersion = m.version, + appliedAt = now, + removal = m.removal + } + | (inst, m, dir) <- modulesInOrder + ] + in filtered ++ new + +-- | Print an error message and exit with code 1. +exitErr :: LogLevel -> Text -> IO a +exitErr level msg = do + logIO level (logError msg) + exitFailure + +-- | Render a 'ModuleLoadError' for display. +renderModuleLoadError :: ModuleLoadError -> Text +renderModuleLoadError = \case + ModuleNotFound name searched -> + "Module '" + <> name.unModuleName + <> "' not found. Searched in:\n" + <> T.intercalate "\n" (map ((" " <>) . T.pack) searched) + DhallEvalError name msg -> + "Failed to evaluate '" <> name.unModuleName <> "': " <> msg + DhallDecodeError name msg -> + "Failed to decode '" <> name.unModuleName <> "': " <> msg + ValidationError name msgs -> + "Validation failed for '" + <> name.unModuleName + <> "':\n" + <> T.intercalate "\n" (map (" " <>) msgs) + CircularDependency names -> + "Circular dependency detected: " + <> T.intercalate " -> " (map (.unModuleName) names) + MissingSourceFile name path -> + "Missing source file in '" + <> name.unModuleName + <> "': " + <> T.pack path + RegistryEvalError path msg -> + "Failed to evaluate registry at '" <> path <> "': " <> msg diff --git a/src-exe/Seihou/CLI/Assist.hs b/src-exe/Seihou/CLI/Assist.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Assist.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.Assist + ( handleAssist, + ) +where + +import Data.FileEmbed (embedFile) +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentCompletion + ( AgentModelConfig (..), + AgentProvider (..), + buildAgentCompletionRequest, + runAgentCompletion, + ) +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + defaultAllowedTools, + formatAvailableModules, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatSeihouProjectState, + gatherAgentContext, + substitute, + ) +import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent) +import Seihou.CLI.Commands (AssistOpts (..)) +import Seihou.Prelude +import System.Exit (exitFailure, exitWith) + +-- | The prompt template, embedded at compile time from data/assist-prompt.md. +promptTemplate :: Text +promptTemplate = TE.decodeUtf8 $(embedFile "data/assist-prompt.md") + +handleAssist :: Bool -> AgentModelConfig -> AssistOpts -> IO () +handleAssist debug modelConfig assistOpts = do + ctx <- gatherAgentContext + let systemPrompt = renderPrompt ctx + runRenderedAgentPrompt debug modelConfig systemPrompt assistOpts.assistPrompt + +renderPrompt :: AgentContext -> Text +renderPrompt ctx = + substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx) + ] + promptTemplate + +runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () +runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt + | debug = TIO.putStr systemPrompt + | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + exitCode <- launchConfiguredAgent modelConfig defaultAllowedTools debug systemPrompt initialPrompt + exitWith exitCode + | otherwise = do + result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + case result of + Right assistantText -> TIO.putStrLn assistantText + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure diff --git a/src-exe/Seihou/CLI/Bootstrap.hs b/src-exe/Seihou/CLI/Bootstrap.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Bootstrap.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.Bootstrap + ( handleBootstrap, + ) +where + +import Data.FileEmbed (embedFile) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentCompletion + ( AgentModelConfig (..), + AgentProvider (..), + buildAgentCompletionRequest, + runAgentCompletion, + ) +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + bootstrapAllowedTools, + formatAvailableModules, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatSeihouProjectState, + gatherAgentContext, + substitute, + ) +import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent) +import Seihou.CLI.Commands (BootstrapOpts (..)) +import Seihou.Prelude +import System.Exit (exitFailure, exitWith) + +-- | The prompt template, embedded at compile time from data/bootstrap-prompt.md. +promptTemplate :: Text +promptTemplate = TE.decodeUtf8 $(embedFile "data/bootstrap-prompt.md") + +handleBootstrap :: Bool -> AgentModelConfig -> BootstrapOpts -> IO () +handleBootstrap debug modelConfig bootstrapOpts = do + ctx <- gatherAgentContext + let systemPrompt = renderPrompt ctx bootstrapOpts + runRenderedAgentPrompt debug modelConfig systemPrompt bootstrapOpts.bootstrapPrompt + +renderPrompt :: AgentContext -> BootstrapOpts -> Text +renderPrompt ctx bootstrapOpts = + substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx), + ("bootstrap_mode", bootstrapMode bootstrapOpts) + ] + promptTemplate + +runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () +runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt + | debug = TIO.putStr systemPrompt + | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + exitCode <- launchConfiguredAgent modelConfig bootstrapAllowedTools debug systemPrompt initialPrompt + exitWith exitCode + | otherwise = do + result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + case result of + Right assistantText -> TIO.putStrLn assistantText + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure + +bootstrapMode :: BootstrapOpts -> Text +bootstrapMode opts + | opts.bootstrapRepo = + T.unlines + [ "**Mode: Multi-module repository**", + "", + "You are bootstrapping a multi-module repository. This means:", + "- Create a `seihou-registry.dhall` at the repository root", + "- Organize modules under a `modules/` directory", + "- Each module gets its own `module.dhall` and `files/` subdirectory", + "- Modules can declare dependencies on each other", + "- Add meaningful tags to each registry entry for discoverability", + "", + "Start by asking what modules the repository should contain, then create", + "them one by one before writing the registry file." + ] + | otherwise = + T.unlines + [ "**Mode: Single module**", + "", + "You are bootstrapping a single Seihou module. Ask the user what kind of", + "project they want to scaffold, then create a complete module with variables,", + "templates, prompts, and validation." + ] diff --git a/src-exe/Seihou/CLI/Browse.hs b/src-exe/Seihou/CLI/Browse.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Browse.hs @@ -0,0 +1,94 @@ +module Seihou.CLI.Browse + ( handleBrowse, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.BrowseFormat (formatBrowseRegistry, formatBrowseSingleBlueprint, formatBrowseSingleModule, formatBrowseSinglePrompt) +import Seihou.CLI.Commands (BrowseOpts (..)) +import Seihou.CLI.Registry.Sync (checkRegistryVersionDrift) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Install (parseModuleName) +import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRecipeFromFile, evalRegistryFromFile) +import Seihou.Effect.Logger (logError, logWarn) +import Seihou.Prelude +import System.Exit (ExitCode (..), exitFailure) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) + +handleBrowse :: BrowseOpts -> IO () +handleBrowse bopts = do + let source = bopts.browseSource + + withSystemTempDirectory "seihou-browse" $ \tmpDir -> do + let repoName = parseModuleName source + cloneDir = tmpDir repoName + + -- Shallow clone + (exitCode, _stdout, stderr) <- readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack source, cloneDir] "" + case exitCode of + ExitFailure _ -> do + logIO LogNormal $ do + logError $ "git clone failed for '" <> source <> "'." + logError $ " " <> T.pack stderr + exitFailure + ExitSuccess -> pure () + + contents <- discoverRepoContents evalRegistryFromFile cloneDir + case contents of + EmptyRepo -> do + logIO LogNormal (logError "repository contains neither seihou-registry.dhall nor module.dhall.") + exitFailure + SingleModule rootDir -> do + let dhallFile = rootDir "module.dhall" + decoded <- evalModuleFromFile dhallFile + case decoded of + Left err -> do + logIO LogNormal (logError $ "failed to load module: " <> T.pack (show err)) + exitFailure + Right m -> + TIO.putStr $ formatBrowseSingleModule source m.name.unModuleName m.description + SingleRecipe rootDir -> do + let dhallFile = rootDir "recipe.dhall" + decoded <- evalRecipeFromFile dhallFile + case decoded of + Left err -> do + logIO LogNormal (logError $ "failed to load recipe: " <> T.pack (show err)) + exitFailure + Right r -> + TIO.putStr $ formatBrowseSingleModule source r.name.unRecipeName r.description + SingleBlueprint rootDir -> do + let dhallFile = rootDir "blueprint.dhall" + decoded <- evalBlueprintFromFile dhallFile + case decoded of + Left err -> do + logIO LogNormal (logError $ "failed to load blueprint: " <> T.pack (show err)) + exitFailure + Right b -> do + let bpName = case b of Blueprint nm _ _ _ _ _ _ _ _ _ -> nm + bpDesc = case b of Blueprint _ _ d _ _ _ _ _ _ _ -> d + TIO.putStr $ formatBrowseSingleBlueprint source bpName.unModuleName bpDesc + SinglePrompt rootDir -> do + let dhallFile = rootDir "prompt.dhall" + decoded <- evalAgentPromptFromFile dhallFile + case decoded of + Left err -> do + logIO LogNormal (logError $ "failed to load prompt: " <> T.pack (show err)) + exitFailure + Right p -> + TIO.putStr $ formatBrowseSinglePrompt source p.name.unModuleName p.description + MultiModule registry -> do + driftWarnings <- checkRegistryVersionDrift cloneDir registry + logIO LogNormal (mapM_ logWarn driftWarnings) + let matchTag e = case bopts.browseTag of + Nothing -> True + Just tag -> tag `elem` e.tags + tagged = + [(ModuleEntry, e) | e <- registry.modules, matchTag e] + ++ [(RecipeEntry, e) | e <- registry.recipes, matchTag e] + ++ [(BlueprintEntry, e) | e <- registry.blueprints, matchTag e] + ++ [(PromptEntry, e) | e <- registry.prompts, matchTag e] + TIO.putStr $ formatBrowseRegistry source registry tagged bopts.browseTag diff --git a/src-exe/Seihou/CLI/Commands.hs b/src-exe/Seihou/CLI/Commands.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Commands.hs @@ -0,0 +1,1782 @@ +module Seihou.CLI.Commands + ( Command (..), + RunOpts (..), + RemoveOpts (..), + VarsOpts (..), + InstallOpts (..), + NewModuleOpts (..), + NewRecipeOpts (..), + NewBlueprintOpts (..), + NewPromptOpts (..), + ValidateOpts (..), + ValidateBlueprintOpts (..), + ValidatePromptOpts (..), + ConfigOpts (..), + ConfigAction (..), + ContextAction (..), + ListOpts (..), + StatusOpts (..), + BrowseOpts (..), + OutdatedOpts (..), + UpgradeOpts (..), + MigrateOpts (..), + SchemaUpgradeOpts (..), + AgentOpts (..), + AgentCommand (..), + AssistOpts (..), + BootstrapOpts (..), + SetupOpts (..), + BlueprintRunOpts (..), + PromptCommand (..), + PromptRunOpts (..), + CompletionsCommand (..), + ExtensionCommand (..), + HelpCommand (..), + KitCommand (..), + RegistryCommand (..), + SyncVersionsOpts (..), + ValidateRegistryOpts (..), + commandParser, + opts, + ) +where + +import Data.Text qualified as T +import GHC.Generics (Generic) +import Options.Applicative +import Options.Applicative.Help.Pretty (Doc, indent, line, pretty, vsep) +import Seihou.CLI.Extension (ExtensionRunOpts (..)) +import Seihou.CLI.Help (HelpCommand, helpCommandParser) +import Seihou.CLI.Kit (KitCommand, kitCommandParser) +import Seihou.CLI.Migrate (MigrateOpts (..)) +import Seihou.CLI.Registry (RegistryCommand (..)) +import Seihou.CLI.Registry.Sync (SyncVersionsOpts (..)) +import Seihou.CLI.Registry.Validate (ValidateRegistryOpts (..)) +import Seihou.CLI.Version (seihouVersionWithGit) +import Seihou.Core.Types (ModuleName (..)) +import Seihou.Prelude + +data Command + = Init + | Run RunOpts + | Remove RemoveOpts + | Vars VarsOpts + | Install InstallOpts + | Status StatusOpts + | Diff + | List ListOpts + | NewModule NewModuleOpts + | NewRecipe NewRecipeOpts + | NewBlueprint NewBlueprintOpts + | NewPrompt NewPromptOpts + | ValidateModule ValidateOpts + | ValidateBlueprint ValidateBlueprintOpts + | ValidatePrompt ValidatePromptOpts + | Config ConfigOpts + | Context ContextAction + | Browse BrowseOpts + | Outdated OutdatedOpts + | Upgrade UpgradeOpts + | Migrate MigrateOpts + | SchemaUpgrade SchemaUpgradeOpts + | Registry RegistryCommand + | Kit KitCommand + | Agent AgentOpts + | Prompt PromptCommand + | Extension ExtensionCommand + | HelpCmd HelpCommand + | Completions CompletionsCommand + deriving stock (Eq, Show, Generic) + +data ExtensionCommand + = ExtensionRun ExtensionRunOpts + deriving stock (Eq, Show, Generic) + +data CompletionsCommand + = CompletionsBash + | CompletionsZsh + | CompletionsFish + deriving stock (Eq, Show, Generic) + +data AgentOpts = AgentOpts + { agentDebug :: Bool, + agentProvider :: Maybe Text, + agentModel :: Maybe Text, + agentCommand :: AgentCommand + } + deriving stock (Eq, Show, Generic) + +data AgentCommand + = AgentAssist AssistOpts + | AgentBootstrap BootstrapOpts + | AgentSetup SetupOpts + | AgentRun BlueprintRunOpts + deriving stock (Eq, Show, Generic) + +data RunOpts = RunOpts + { runModule :: Maybe ModuleName, + runAdditional :: [ModuleName], + runVars :: [(Text, Text)], + runDryRun :: Bool, + runDiff :: Bool, + runForce :: Bool, + runNoCommands :: Bool, + runNamespace :: Maybe Text, + runContext :: Maybe Text, + runVerbose :: Bool, + runSavePrompted :: Maybe Bool, + runConfirmDefaults :: Bool, + runCommit :: Bool, + runCommitMessage :: Maybe Text, + -- | When 'True', a pre-flight pending-migration check that finds + -- any chain for one of the composed modules will apply that chain + -- to the project (and the manifest) before the run plan is + -- computed. When 'False' (the default), pending chains cause + -- 'seihou run' to refuse with an actionable message and a + -- non-zero exit, so a user never silently writes new templates + -- into paths a migration would have moved. + runWithMigrations :: Bool + } + deriving stock (Eq, Show, Generic) + +data RemoveOpts = RemoveOpts + { removeModule :: ModuleName, + removeDryRun :: Bool, + removeForce :: Bool, + removeVerbose :: Bool + } + deriving stock (Eq, Show, Generic) + +data VarsOpts = VarsOpts + { varsModule :: Maybe ModuleName, + varsExplain :: Bool, + varsVars :: [(Text, Text)], + varsNamespace :: Maybe Text, + varsContext :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data InstallOpts = InstallOpts + { installSource :: Maybe Text, + installName :: Maybe Text, + installModules :: [Text], + installAll :: Bool + } + deriving stock (Eq, Show, Generic) + +data NewModuleOpts = NewModuleOpts + { newModuleName :: Text, + newModulePath :: Maybe FilePath + } + deriving stock (Eq, Show, Generic) + +data NewRecipeOpts = NewRecipeOpts + { newRecipeName :: Text, + newRecipeModules :: [Text], + newRecipePath :: Maybe FilePath + } + deriving stock (Eq, Show, Generic) + +data NewBlueprintOpts = NewBlueprintOpts + { newBlueprintName :: Text, + newBlueprintPath :: Maybe FilePath + } + deriving stock (Eq, Show, Generic) + +data NewPromptOpts = NewPromptOpts + { newPromptName :: Text, + newPromptPath :: Maybe FilePath + } + deriving stock (Eq, Show, Generic) + +data ValidateOpts = ValidateOpts + { validatePath :: Maybe FilePath, + validateLint :: Bool + } + deriving stock (Eq, Show, Generic) + +data ValidateBlueprintOpts = ValidateBlueprintOpts + { validateBlueprintPath :: Maybe FilePath, + validateBlueprintLint :: Bool + } + deriving stock (Eq, Show, Generic) + +data ValidatePromptOpts = ValidatePromptOpts + { validatePromptPath :: Maybe FilePath, + validatePromptLint :: Bool + } + deriving stock (Eq, Show, Generic) + +data ConfigAction + = ConfigSet Text Text + | ConfigGet Text + | ConfigUnset Text + | ConfigList + deriving stock (Eq, Show, Generic) + +data ConfigOpts = ConfigOpts + { configAction :: ConfigAction, + configGlobal :: Bool, + configNamespace :: Maybe Text, + configContext :: Maybe Text, + configEffective :: Bool + } + deriving stock (Eq, Show, Generic) + +data ContextAction + = ContextSet (Maybe Text) + | ContextDefault Text + | ContextShow + | ContextClear + | ContextClearDefault + deriving stock (Eq, Show, Generic) + +data ListOpts = ListOpts + { listRepo :: Maybe Text, + listTag :: Maybe Text, + listModulesOnly :: Bool, + listRecipesOnly :: Bool, + listBlueprintsOnly :: Bool, + listPromptsOnly :: Bool + } + deriving stock (Eq, Show, Generic) + +data BrowseOpts = BrowseOpts + { browseSource :: Text, + browseTag :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data StatusOpts = StatusOpts + { statusCheckUpdates :: Bool + } + deriving stock (Eq, Show, Generic) + +data OutdatedOpts = OutdatedOpts + { outdatedJson :: Bool + } + deriving stock (Eq, Show, Generic) + +data UpgradeOpts = UpgradeOpts + { upgradeModules :: [Text], + upgradeDryRun :: Bool, + upgradeJson :: Bool, + upgradeSkipUnversioned :: Bool, + -- | If 'True', after each successful per-module upgrade, also run + -- 'Seihou.CLI.Migrate.runMigrate' against the *current project* + -- (cwd), if and only if that module is applied locally. Default + -- 'False'; the unset path emits a one-line advisory pointing the + -- user at @seihou migrate@ when migrations would be pending. + upgradeWithMigrations :: Bool + } + deriving stock (Eq, Show, Generic) + +data SchemaUpgradeOpts = SchemaUpgradeOpts + { schemaUpgradePath :: Maybe FilePath, + schemaUpgradeDryRun :: Bool, + schemaUpgradeAll :: Bool + } + deriving stock (Eq, Show, Generic) + +data AssistOpts = AssistOpts + { assistPrompt :: Maybe Text, + assistProvider :: Maybe Text, + assistModel :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data BootstrapOpts = BootstrapOpts + { bootstrapPrompt :: Maybe Text, + bootstrapRepo :: Bool, + bootstrapProvider :: Maybe Text, + bootstrapModel :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data SetupOpts = SetupOpts + { setupPrompt :: Maybe Text, + setupProvider :: Maybe Text, + setupModel :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data BlueprintRunOpts = BlueprintRunOpts + { runBlueprintName :: ModuleName, + runBlueprintPrompt :: Maybe Text, + runBlueprintVars :: [(Text, Text)], + runBlueprintNoBaseline :: Bool, + runBlueprintNamespace :: Maybe Text, + runBlueprintContext :: Maybe Text, + runBlueprintVerbose :: Bool, + runBlueprintForce :: Bool, + runBlueprintProvider :: Maybe Text, + runBlueprintModel :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +data PromptCommand + = PromptRun PromptRunOpts + deriving stock (Eq, Show, Generic) + +data PromptRunOpts = PromptRunOpts + { runPromptName :: ModuleName, + runPromptPrompt :: Maybe Text, + runPromptVars :: [(Text, Text)], + runPromptNamespace :: Maybe Text, + runPromptContext :: Maybe Text, + runPromptVerbose :: Bool, + runPromptDebug :: Bool, + runPromptProvider :: Maybe Text, + runPromptModel :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +opts :: ParserInfo Command +opts = + info + (commandParser <**> helper <**> version) + ( fullDesc + <> progDesc "Composable, type-safe project scaffolding" + <> header "seihou - composable project scaffolding" + <> footerDoc (Just topLevelFooter) + ) + where + version = infoOption (T.unpack seihouVersionWithGit) (long "version" <> help "Show version") + +topLevelFooter :: Doc +topLevelFooter = + vsep + [ pretty ("Getting started:" :: String), + mempty, + indent 2 $ vsep [pretty ("seihou init" :: String), pretty ("seihou run --var project.name=my-app" :: String), pretty ("seihou status" :: String)], + mempty, + pretty ("Learn more:" :: String), + mempty, + indent 2 $ + vsep + [ pretty ("seihou help # list all help topics" :: String), + pretty ("seihou help modules # how modules work" :: String), + pretty ("seihou help migrations # apply author-declared migrations between versions" :: String) + ], + mempty, + pretty ("Run 'seihou COMMAND --help' for details on a specific command." :: String) + ] + +commandParser :: Parser Command +commandParser = + hsubparser + ( command "init" initInfo + <> command "run" runInfo + <> command "remove" removeInfo + <> command "status" statusInfo + <> command "diff" diffInfo + ) + <|> hsubparser + ( command "list" listInfo + <> command "install" installInfo + <> command "browse" browseInfo + <> command "outdated" outdatedInfo + <> command "upgrade" upgradeInfo + <> command "migrate" migrateInfo + <> commandGroup "Module management:" + <> hidden + ) + <|> hsubparser + ( command "new-module" newModuleInfo + <> command "new-recipe" newRecipeInfo + <> command "new-blueprint" newBlueprintInfo + <> command "new-prompt" newPromptInfo + <> command "validate-module" validateInfo + <> command "validate-blueprint" validateBlueprintInfo + <> command "validate-prompt" validatePromptInfo + <> command "vars" varsInfo + <> command "schema-upgrade" schemaUpgradeInfo + <> command "registry" registryInfo + <> commandGroup "Authoring:" + <> hidden + ) + <|> hsubparser + ( command "config" configInfo + <> command "context" contextInfo + <> commandGroup "Configuration:" + <> hidden + ) + <|> hsubparser + ( command "agent" agentInfo + <> command "prompt" promptInfo + <> command "kit" kitInfo + <> commandGroup "AI agent:" + <> hidden + ) + <|> hsubparser + ( command "help" helpCmdInfo + <> command "completions" completionsInfo + <> command "extension" extensionInfo + <> commandGroup "Help & shell integration:" + <> hidden + ) + +-- Command info blocks + +initInfo :: ParserInfo Command +initInfo = + info + (pure Init <**> helper) + ( fullDesc + <> progDesc "Initialize Seihou configuration" + <> footerDoc + ( Just $ + vsep + [ pretty ("Creates the Seihou configuration directory at ~/.config/seihou/ with" :: String), + pretty ("subdirectories for user modules and installed modules. Also writes a" :: String), + pretty ("default config.dhall. Safe to run multiple times; existing files are" :: String), + pretty ("left untouched." :: String) + ] + ) + ) + +runInfo :: ParserInfo Command +runInfo = + info + (runParser <**> helper) + ( fullDesc + <> progDesc "Run modules to generate a project" + <> footerDoc + ( Just $ + vsep + [ pretty ("Loads the specified module and its dependencies, resolves all variables," :: String), + pretty ("compiles a generation plan, and executes it in the current directory." :: String), + line, + pretty ("Compose multiple modules with -m/--module (repeatable). Override" :: String), + pretty ("variables with --var KEY=VALUE (repeatable). Use --dry-run to preview" :: String), + pretty ("the plan without writing files, or --diff to compare against disk." :: String), + line, + pretty ("When re-running, Seihou uses the .seihou/manifest.json to detect" :: String), + pretty ("new, modified, unchanged, and conflicting files. Conflicts are" :: String), + pretty ("reported and block execution unless --force is used." :: String), + line, + pretty ("If an applied module's installed copy has advanced past the manifest's" :: String), + pretty ("recorded version and ships migrations that move project files," :: String), + pretty ("'seihou run' refuses to proceed (so it never writes new templates into" :: String), + pretty ("paths a migration would have moved). Run 'seihou migrate '" :: String), + pretty ("first, or pass --with-migrations to apply pending chains in-band." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou run haskell-base --var project.name=my-app" :: String), + pretty ("seihou run haskell-base -m nix-flake --dry-run" :: String), + pretty ("seihou run my-module --diff" :: String), + pretty ("seihou run haskell-base --confirm-defaults # review and override default values" :: String), + pretty ("seihou run haskell-base --with-migrations # apply pending migrations before regenerating" :: String) + ] + ] + ) + ) + +removeInfo :: ParserInfo Command +removeInfo = + info + (removeParser <**> helper) + ( fullDesc + <> progDesc "Remove an applied module and delete its generated files" + <> footerDoc + ( Just $ + vsep + [ pretty ("Removes a module that was previously applied via 'seihou run' and" :: String), + pretty ("reverses its effects. Only modules with a 'removal' section" :: String), + pretty ("in their module.dhall can be removed." :: String), + line, + pretty ("Files that have been modified since generation are treated as" :: String), + pretty ("conflicts. Use --force to delete them without prompting, or" :: String), + pretty ("respond interactively to keep or delete each one." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou remove haskell-base" :: String), + pretty ("seihou remove haskell-base --dry-run" :: String), + pretty ("seihou remove haskell-base --force" :: String) + ] + ] + ) + ) + +removeParser :: Parser Command +removeParser = + fmap Remove $ + RemoveOpts + <$> argument moduleNameReader (metavar "MODULE" <> help "Module to remove") + <*> switch (long "dry-run" <> help "Show removal plan without executing") + <*> switch (long "force" <> help "Delete conflicted files without prompting") + <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") + +varsInfo :: ParserInfo Command +varsInfo = + info + (varsParser <**> helper) + ( fullDesc + <> progDesc "Inspect resolved variables" + <> footerDoc + ( Just $ + vsep + [ pretty ("By default, lists all variable declarations for the module with their" :: String), + pretty ("types, defaults, and descriptions." :: String), + line, + pretty ("With --explain, resolves variables and shows the provenance of each" :: String), + pretty ("value (default, CLI override, environment variable, or export from a" :: String), + pretty ("dependency). Use --var KEY=VALUE to supply context for resolution." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ vsep [pretty ("seihou vars haskell-base" :: String), pretty ("seihou vars haskell-base --explain --var project.name=my-app" :: String)] + ] + ) + ) + +installInfo :: ParserInfo Command +installInfo = + info + (installParser <**> helper) + ( fullDesc + <> progDesc "Install module(s), recipe(s), blueprint(s), or prompt(s) from git" + <> footerDoc + ( Just $ + vsep + [ pretty ("Clones the git repository and installs modules, recipes," :: String), + pretty ("blueprints, or prompts to ~/.config/seihou/installed//." :: String), + line, + pretty ("If the repository contains a seihou-registry.dhall file, it is" :: String), + pretty ("treated as a multi-module registry. Use --module to pick specific" :: String), + pretty ("entries or --all to install everything. Without either flag, you" :: String), + pretty ("will be prompted to choose interactively." :: String), + line, + pretty ("For single-artifact repositories (a root module.dhall, recipe.dhall," :: String), + pretty ("blueprint.dhall, or prompt.dhall), the artifact name defaults to the repository" :: String), + pretty ("name. Use --name to override." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou install https://github.com/user/haskell-module.git" :: String), + pretty ("seihou install https://github.com/user/templates.git --all" :: String), + pretty ("seihou install https://github.com/user/templates.git --module haskell-base" :: String) + ] + ] + ) + ) + +statusInfo :: ParserInfo Command +statusInfo = + info + (statusParser <**> helper) + ( fullDesc + <> progDesc "Show manifest state" + <> footerDoc + ( Just $ + vsep + [ pretty ("Reads .seihou/manifest.json in the current directory and displays" :: String), + pretty ("applied modules, tracked files, and resolved variable values." :: String), + pretty ("If no manifest exists, reports that and exits successfully." :: String), + line, + pretty ("Use --check-updates to also report which applied modules have newer" :: String), + pretty ("versions available from their source repository. This requires network" :: String), + pretty ("access and will clone each source repo shallowly." :: String), + line, + pretty ("When an applied module's installed copy has advanced past the manifest's" :: String), + pretty ("recorded version, status reports the pending migration count under that" :: String), + pretty ("module's line; run 'seihou migrate ' to apply them." :: String) + ] + ) + ) + +statusParser :: Parser Command +statusParser = + fmap Status $ + StatusOpts + <$> switch + ( long "check-updates" + <> short 'u' + <> help "Check installed modules for available updates (requires network)" + ) + +diffInfo :: ParserInfo Command +diffInfo = + info + (pure Diff <**> helper) + ( fullDesc + <> progDesc "Show changes since last generation" + <> footerDoc + ( Just $ + vsep + [ pretty ("Compares tracked files in .seihou/manifest.json against the current" :: String), + pretty ("disk state. Shows files that have been modified or deleted since the" :: String), + pretty ("last 'seihou run'. Does not load modules or resolve variables." :: String) + ] + ) + ) + +listInfo :: ParserInfo Command +listInfo = + info + (listParser <**> helper) + ( fullDesc + <> progDesc "List available modules, recipes, blueprints, and prompts" + <> footerDoc + ( Just $ + vsep + [ pretty ("Scans all search paths and lists every available runnable artifact" :: String), + pretty ("(modules, recipes, blueprints, prompts) with its name, kind, description, and" :: String), + pretty ("source location (project, user, or installed). Entries that fail to" :: String), + pretty ("load are shown with an error indicator." :: String), + line, + pretty ("Use --repo and --tag to filter the output." :: String), + pretty ("Use --modules, --recipes, --blueprints, and --prompts to restrict by kind" :: String), + pretty ("(combine them to show several kinds; omit all to show every kind)." :: String) + ] + ) + ) + +listParser :: Parser Command +listParser = + fmap List $ + ListOpts + <$> optional (option (T.pack <$> str) (long "repo" <> metavar "REPO" <> help "Filter by repository name")) + <*> optional (option (T.pack <$> str) (long "tag" <> metavar "TAG" <> help "Filter by tag")) + <*> switch (long "modules" <> help "Show only modules") + <*> switch (long "recipes" <> help "Show only recipes") + <*> switch (long "blueprints" <> help "Show only blueprints") + <*> switch (long "prompts" <> help "Show only prompts") + +newModuleInfo :: ParserInfo Command +newModuleInfo = + info + (newModuleParser <**> helper) + ( fullDesc + <> progDesc "Scaffold a new module" + <> footerDoc + ( Just $ + vsep + [ pretty ("Creates a new module directory with a boilerplate module.dhall and an" :: String), + pretty ("example template file at files/README.md.tpl. The output directory" :: String), + pretty ("defaults to .// in the current directory." :: String), + line, + pretty ("Module names must match [a-z][a-z0-9-]* (lowercase, hyphens allowed," :: String), + pretty ("must start with a letter)." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou new-module my-template --path ~/modules/my-template" :: String) + ] + ) + ) + +validateInfo :: ParserInfo Command +validateInfo = + info + (validateParser <**> helper) + ( fullDesc + <> progDesc "Validate a module" + <> footerDoc + ( Just $ + vsep + [ pretty ("Checks that a module directory is well-formed: module.dhall exists and" :: String), + pretty ("evaluates, the module name is valid, variable names are unique, prompts" :: String), + pretty ("reference declared variables, step source files exist, and exports" :: String), + pretty ("reference declared variables." :: String), + line, + pretty ("PATH defaults to the current directory if not specified." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou validate-module ./my-module" :: String) + ] + ) + ) + +configInfo :: ParserInfo Command +configInfo = + info + (configParser <**> helper) + ( fullDesc + <> progDesc "Read and write config values" + <> footerDoc + ( Just $ + vsep + [ pretty ("Manage config values across local, namespace, and global scopes." :: String), + pretty ("Default scope is local (.seihou/config.dhall). Use --global or" :: String), + pretty ("--namespace NS for other scopes." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou config set project.name my-app" :: String), + pretty ("seihou config get project.name" :: String), + pretty ("seihou config list" :: String), + pretty ("seihou config set license MIT --global" :: String), + pretty ("seihou config unset license --global" :: String), + pretty ("seihou config list --namespace haskell" :: String) + ] + ] + ) + ) + +-- Subparsers + +runParser :: Parser Command +runParser = + fmap Run $ + RunOpts + <$> optional (argument moduleNameReader (metavar "MODULE")) + <*> many + ( option + moduleNameReader + (long "module" <> short 'm' <> metavar "MODULE" <> help "Additional module to compose (repeatable)") + ) + <*> many + ( option + varPair + (long "var" <> metavar "KEY=VALUE" <> help "Variable override (repeatable)") + ) + <*> switch (long "dry-run" <> help "Show plan without executing") + <*> switch (long "diff" <> help "Show diff against current disk state") + <*> switch (long "force" <> help "Auto-resolve conflicts (accept new files)") + <*> switch (long "no-commands" <> help "Skip shell command steps") + <*> optional (option (T.pack <$> str) (long "namespace" <> metavar "NS" <> help "Override namespace for config lookup")) + <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) + <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") + <*> optional + ( flag' True (long "save-prompted" <> help "Save prompted values to local config without asking") + <|> flag' False (long "no-save-prompted" <> help "Do not offer to save prompted values") + ) + <*> switch (long "confirm-defaults" <> help "Step through default values and confirm or override each one") + <*> switch (long "commit" <> help "Commit generated files to git after execution (uses AI-generated message)") + <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)")) + <*> switch + ( long "with-migrations" + <> help "Apply any pending module migrations before the run plan; without this, 'seihou run' refuses when migrations are pending" + ) + +varsParser :: Parser Command +varsParser = + fmap Vars $ + VarsOpts + <$> optional (argument moduleNameReader (metavar "MODULE")) + <*> switch (long "explain" <> help "Show resolved values with provenance") + <*> many + ( option + varPair + (long "var" <> metavar "KEY=VALUE" <> help "Provide variable values for resolution (repeatable)") + ) + <*> optional (option (T.pack <$> str) (long "namespace" <> metavar "NS" <> help "Override namespace for config lookup")) + <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) + +installParser :: Parser Command +installParser = + fmap Install $ + InstallOpts + <$> optional (argument (T.pack <$> str) (metavar "GIT-URL")) + <*> optional (option (T.pack <$> str) (long "name" <> metavar "NAME" <> help "Override installed module name")) + <*> many (option (T.pack <$> str) (long "module" <> metavar "MODULE" <> help "Module, recipe, blueprint, or prompt name from the registry to install (repeatable)")) + <*> switch (long "all" <> help "Install every module, recipe, blueprint, and prompt listed in the registry") + +newModuleParser :: Parser Command +newModuleParser = + fmap NewModule $ + NewModuleOpts + <$> argument (T.pack <$> str) (metavar "NAME") + <*> optional (option str (long "path" <> metavar "DIR" <> help "Output directory (default: .//)")) + +newRecipeInfo :: ParserInfo Command +newRecipeInfo = + info + (newRecipeParser <**> helper) + ( fullDesc + <> progDesc "Scaffold a new recipe" + <> footerDoc + ( Just $ + vsep + [ pretty ("Creates a new recipe directory with a boilerplate recipe.dhall." :: String), + pretty ("The output directory defaults to .// in the current directory." :: String), + line, + pretty ("Recipe names must match [a-z][a-z0-9-]* (lowercase, hyphens allowed," :: String), + pretty ("must start with a letter)." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou new-recipe haskell-library --module nix-flake --module cabal-ghc" :: String) + ] + ) + ) + +newRecipeParser :: Parser Command +newRecipeParser = + fmap NewRecipe $ + NewRecipeOpts + <$> argument (T.pack <$> str) (metavar "NAME") + <*> many (option (T.pack <$> str) (long "module" <> short 'm' <> metavar "MODULE" <> help "Module to include in the recipe")) + <*> optional (option str (long "path" <> metavar "DIR" <> help "Output directory (default: .//)")) + +validateParser :: Parser Command +validateParser = + fmap ValidateModule $ + ValidateOpts + <$> optional (argument str (metavar "PATH")) + <*> switch (long "lint" <> help "Include advisory lint warnings") + +newBlueprintInfo :: ParserInfo Command +newBlueprintInfo = + info + (newBlueprintParser <**> helper) + ( fullDesc + <> progDesc "Scaffold a new agent-driven blueprint" + <> footerDoc + ( Just $ + vsep + [ pretty ("Creates a new blueprint directory containing three artifacts:" :: String), + indent 2 $ + vsep + [ pretty ("blueprint.dhall the blueprint record (imports the schema)" :: String), + pretty ("prompt.md the Markdown body the agent runner consumes" :: String), + pretty ("files/ empty reference directory for snippets, templates" :: String) + ], + line, + pretty ("The output directory defaults to .// in the current directory." :: String), + line, + pretty ("Blueprint names must match [a-z][a-z0-9-]* (lowercase, hyphens allowed," :: String), + pretty ("must start with a letter)." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou new-blueprint payments-service" :: String) + ] + ) + ) + +newBlueprintParser :: Parser Command +newBlueprintParser = + fmap NewBlueprint $ + NewBlueprintOpts + <$> argument (T.pack <$> str) (metavar "NAME") + <*> optional (option str (long "path" <> metavar "DIR" <> help "Output directory (default: .//)")) + +newPromptInfo :: ParserInfo Command +newPromptInfo = + info + (newPromptParser <**> helper) + ( fullDesc + <> progDesc "Scaffold a new agent-session prompt" + <> footerDoc + ( Just $ + vsep + [ pretty ("Creates a new prompt directory containing three artifacts:" :: String), + indent 2 $ + vsep + [ pretty ("prompt.dhall the prompt record" :: String), + pretty ("prompt.md the Markdown body rendered before launch" :: String), + pretty ("files/ empty reference directory for snippets and docs" :: String) + ], + line, + pretty ("The output directory defaults to .// in the current directory." :: String), + line, + pretty ("Prompt names must match [a-z][a-z0-9-]* (lowercase, hyphens allowed," :: String), + pretty ("must start with a letter)." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou new-prompt review-changes" :: String) + ] + ) + ) + +newPromptParser :: Parser Command +newPromptParser = + fmap NewPrompt $ + NewPromptOpts + <$> argument (T.pack <$> str) (metavar "NAME") + <*> optional (option str (long "path" <> metavar "DIR" <> help "Output directory (default: .//)")) + +validateBlueprintInfo :: ParserInfo Command +validateBlueprintInfo = + info + (validateBlueprintParser <**> helper) + ( fullDesc + <> progDesc "Validate a blueprint" + <> footerDoc + ( Just $ + vsep + [ pretty ("Checks that a blueprint directory is well-formed: blueprint.dhall" :: String), + pretty ("evaluates, the blueprint name is valid, the prompt body is non-empty," :: String), + pretty ("variable names are unique, prompts reference declared variables," :: String), + pretty ("every entry in the files list resolves under files/, and base modules" :: String), + pretty ("are not themselves blueprints." :: String), + line, + pretty ("PATH defaults to the current directory if not specified." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou validate-blueprint ./payments-service" :: String) + ] + ) + ) + +validateBlueprintParser :: Parser Command +validateBlueprintParser = + fmap ValidateBlueprint $ + ValidateBlueprintOpts + <$> optional (argument str (metavar "PATH")) + <*> switch (long "lint" <> help "Include advisory lint warnings") + +validatePromptInfo :: ParserInfo Command +validatePromptInfo = + info + (validatePromptParser <**> helper) + ( fullDesc + <> progDesc "Validate a prompt" + <> footerDoc + ( Just $ + vsep + [ pretty ("Checks that a prompt directory is well-formed: prompt.dhall" :: String), + pretty ("evaluates, the prompt name is valid, the prompt body is non-empty," :: String), + pretty ("variable names are unique, prompts reference declared variables," :: String), + pretty ("command variables are well-formed, and every entry in files resolves" :: String), + pretty ("under files/." :: String), + line, + pretty ("PATH defaults to the current directory if not specified." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou validate-prompt ./review-changes" :: String) + ] + ) + ) + +validatePromptParser :: Parser Command +validatePromptParser = + fmap ValidatePrompt $ + ValidatePromptOpts + <$> optional (argument str (metavar "PATH")) + <*> switch (long "lint" <> help "Include advisory lint warnings") + +configParser :: Parser Command +configParser = + fmap Config $ + ConfigOpts + <$> configActionParser + <*> switch (long "global" <> short 'g' <> help "Use global scope (~/.config/seihou/config.dhall)") + <*> optional (option (T.pack <$> str) (long "namespace" <> short 'n' <> metavar "NS" <> help "Use namespace scope")) + <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Use context scope")) + <*> switch (long "effective" <> short 'e' <> help "Show merged config across all scopes (with list)") + +configActionParser :: Parser ConfigAction +configActionParser = + subparser + ( command "set" (info configSetParser (progDesc "Set a config value")) + <> command "get" (info configGetParser (progDesc "Get a config value")) + <> command "unset" (info configUnsetParser (progDesc "Remove a config value")) + <> command "list" (info (pure ConfigList) (progDesc "List config values")) + ) + +configSetParser :: Parser ConfigAction +configSetParser = + ConfigSet + <$> argument (T.pack <$> str) (metavar "KEY") + <*> argument (T.pack <$> str) (metavar "VALUE") + +configGetParser :: Parser ConfigAction +configGetParser = ConfigGet <$> argument (T.pack <$> str) (metavar "KEY") + +configUnsetParser :: Parser ConfigAction +configUnsetParser = ConfigUnset <$> argument (T.pack <$> str) (metavar "KEY") + +contextInfo :: ParserInfo Command +contextInfo = + info + (contextParser <**> helper) + ( fullDesc + <> progDesc "Manage the active context (work, personal, etc.)" + <> footerDoc + ( Just $ + vsep + [ pretty ("Contexts allow variables like user.email to resolve differently" :: String), + pretty ("depending on whether you're working in a 'work' or 'personal'" :: String), + pretty ("context. Context config files live at" :: String), + pretty ("~/.config/seihou/contexts//config.dhall." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou context show # show active context" :: String), + pretty ("seihou context set work # set project context" :: String), + pretty ("seihou context default personal # set global default" :: String), + pretty ("seihou context clear # remove project context" :: String), + pretty ("seihou context clear-default # remove global default" :: String) + ] + ] + ) + ) + +contextParser :: Parser Command +contextParser = + fmap Context $ + subparser + ( command "show" (info (pure ContextShow) (progDesc "Show the active context and its source")) + <> command "set" (info (ContextSet <$> optional (argument (T.pack <$> str) (metavar "NAME"))) (progDesc "Set the project context (.seihou/context)")) + <> command "default" (info (ContextDefault <$> argument (T.pack <$> str) (metavar "NAME")) (progDesc "Set the global default context (~/.config/seihou/default-context)")) + <> command "clear" (info (pure ContextClear) (progDesc "Remove the project context file")) + <> command "clear-default" (info (pure ContextClearDefault) (progDesc "Remove the global default context")) + ) + +browseInfo :: ParserInfo Command +browseInfo = + info + (browseParser <**> helper) + ( fullDesc + <> progDesc "Browse modules, recipes, blueprints, and prompts in a git repository" + <> footerDoc + ( Just $ + vsep + [ pretty ("Clones the repository and shows available modules, recipes," :: String), + pretty ("blueprints, and prompts without installing anything. For multi-artifact repos" :: String), + pretty ("with a seihou-registry.dhall, displays all entries with descriptions," :: String), + pretty ("kind labels, and tags. Use --tag to filter by tag." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou browse https://github.com/user/templates.git" :: String), + pretty ("seihou browse https://github.com/user/templates.git --tag haskell" :: String) + ] + ] + ) + ) + +browseParser :: Parser Command +browseParser = + fmap Browse $ + BrowseOpts + <$> argument (T.pack <$> str) (metavar "GIT-URL") + <*> optional (option (T.pack <$> str) (long "tag" <> metavar "TAG" <> help "Filter modules by tag")) + +outdatedInfo :: ParserInfo Command +outdatedInfo = + info + (outdatedParser <**> helper) + ( fullDesc + <> progDesc "Check installed modules for newer versions" + <> footerDoc + ( Just $ + vsep + [ pretty ("Checks each installed module's source registry for a newer version." :: String), + pretty ("Modules without version information are shown as 'unversioned'." :: String), + pretty ("Only modules installed via 'seihou install' are checked." :: String), + line, + pretty ("Example:" :: String), + indent 2 $ pretty ("seihou outdated" :: String), + line, + pretty ("Run 'seihou upgrade' to apply available updates. If a module ships" :: String), + pretty ("migrations, 'seihou upgrade' will surface them via an advisory; run" :: String), + pretty ("'seihou migrate ' (or 'seihou upgrade --with-migrations')" :: String), + pretty ("to apply them to the current project." :: String) + ] + ) + ) + +outdatedParser :: Parser Command +outdatedParser = + fmap Outdated $ + OutdatedOpts + <$> switch (long "json" <> help "Output as JSON") + +upgradeInfo :: ParserInfo Command +upgradeInfo = + info + (upgradeParser <**> helper) + ( fullDesc + <> progDesc "Upgrade installed modules to latest versions" + <> footerDoc (Just upgradeFooter) + ) + +upgradeParser :: Parser Command +upgradeParser = + fmap Upgrade $ + UpgradeOpts + <$> many (argument (T.pack <$> str) (metavar "MODULE" <> help "Module(s) to upgrade (default: all)")) + <*> switch (long "dry-run" <> help "Show what would be upgraded without making changes") + <*> switch (long "json" <> help "Output as JSON") + <*> switch (long "skip-unversioned" <> help "Skip modules without version information") + <*> switch + ( long "with-migrations" + <> help "After each upgrade, also run 'seihou migrate' against the current project for that module" + ) + +upgradeFooter :: Doc +upgradeFooter = + vsep + [ pretty ("Upgrades installed modules to the latest version available from their" :: String), + pretty ("source repository. Only modules installed via 'seihou install' are checked." :: String), + pretty ("Modules without version information are upgraded by default." :: String), + pretty ("Use --skip-unversioned to skip them." :: String), + line, + pretty ("With no arguments, checks all installed modules. Pass module names to" :: String), + pretty ("upgrade specific modules only." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou upgrade # upgrade all installed modules" :: String), + pretty ("seihou upgrade haskell-base # upgrade a specific module" :: String), + pretty ("seihou upgrade --dry-run # preview without changes" :: String), + pretty ("seihou upgrade --skip-unversioned # skip unversioned modules" :: String), + pretty ("seihou upgrade --with-migrations # also run 'seihou migrate' for each upgrade" :: String) + ], + line, + pretty ("Migrations:" :: String), + indent 2 $ + vsep + [ pretty ("Newer module versions may declare migrations that move project files" :: String), + pretty ("when applied. By default 'seihou upgrade' does not run them — it only" :: String), + pretty ("prints an advisory pointing at 'seihou migrate '. Pass" :: String), + pretty ("--with-migrations to run them as part of the upgrade." :: String) + ] + ] + +migrateInfo :: ParserInfo Command +migrateInfo = + info + (migrateParser <**> helper) + ( fullDesc + <> progDesc "Apply module-declared migrations to the current project" + <> footerDoc (Just migrateFooter) + ) + +migrateParser :: Parser Command +migrateParser = + fmap Migrate $ + MigrateOpts + <$> argument (ModuleName . T.pack <$> str) (metavar "MODULE" <> help "The applied module to migrate") + <*> optional + ( option + (T.pack <$> str) + ( long "to" + <> metavar "VERSION" + <> help "Target version (default: installed module's current version)" + ) + ) + <*> switch (long "dry-run" <> help "Show the migration plan without modifying any files") + <*> switch (long "force" <> help "Proceed even when files have been edited since generation") + <*> switch (long "json" <> help "Emit the plan as JSON instead of human-readable text") + <*> switch (long "verbose" <> short 'v' <> help "Print extra detail about each operation") + <*> switch (long "no-fetch" <> help "Skip the remote fetch; use only the locally installed copy") + <*> switch (long "commit" <> help "Commit migrated files to git after execution (uses AI-generated message)") + <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)")) + +migrateFooter :: Doc +migrateFooter = + vsep + [ pretty ("Applies the migrations declared on a module's module.dhall file to the" :: String), + pretty ("current project's working tree and manifest at .seihou/manifest.json." :: String), + pretty ("The chain that runs is determined by the manifest's recorded version" :: String), + pretty ("of the applied module (the 'from') and either the installed copy's" :: String), + pretty ("current version or a --to override (the 'to')." :: String), + line, + pretty ("Available migration operations:" :: String), + indent 2 $ + vsep + [ pretty ("MoveFile rename a single tracked file" :: String), + pretty ("MoveDir rename a directory; rewrites every contained manifest entry" :: String), + pretty ("DeleteFile remove a tracked file" :: String), + pretty ("DeleteDir recursively remove a directory" :: String), + pretty ("RunCommand run a shell command (escape hatch; manifest is not auto-updated)" :: String) + ], + line, + pretty ("Conflict semantics mirror 'seihou remove': files whose disk hash differs" :: String), + pretty ("from the manifest are flagged. Without --force the engine refuses to" :: String), + pretty ("overwrite them and exits non-zero. With --force, the migration proceeds." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou migrate haskell-base # plan + apply" :: String), + pretty ("seihou migrate haskell-base --dry-run # preview only" :: String), + pretty ("seihou migrate haskell-base --to 1.5.0 # stop at intermediate version" :: String), + pretty ("seihou migrate haskell-base --force # overwrite conflicted files" :: String), + pretty ("seihou migrate haskell-base --json # machine-readable plan" :: String), + pretty ("seihou migrate haskell-base --commit # auto-commit after migrate" :: String) + ], + line, + pretty ("See also: seihou help migrations" :: String) + ] + +schemaUpgradeInfo :: ParserInfo Command +schemaUpgradeInfo = + info + (schemaUpgradeParser <**> helper) + ( fullDesc + <> progDesc "Upgrade module.dhall files to the current schema" + <> footerDoc (Just schemaUpgradeFooter) + ) + +schemaUpgradeParser :: Parser Command +schemaUpgradeParser = + fmap SchemaUpgrade $ + SchemaUpgradeOpts + <$> optional (argument str (metavar "PATH" <> help "Module directory (default: current directory)")) + <*> switch (long "dry-run" <> help "Show what would change without modifying files") + <*> switch (long "all" <> help "Upgrade all discovered modules") + +schemaUpgradeFooter :: Doc +schemaUpgradeFooter = + vsep + [ pretty ("Detects missing or outdated fields in module.dhall files and" :: String), + pretty ("rewrites them to match the current schema. Handles:" :: String), + line, + indent 2 $ + vsep + [ pretty ("- Missing 'version' field" :: String), + pretty ("- Missing 'patch' field on steps" :: String), + pretty ("- Missing 'commands' field" :: String), + pretty ("- Bare string dependencies (converts to record form)" :: String), + pretty ("- 'List Text' dependency type annotation" :: String) + ], + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou schema-upgrade # upgrade ./module.dhall" :: String), + pretty ("seihou schema-upgrade ./my-module # upgrade specific module" :: String), + pretty ("seihou schema-upgrade --dry-run # preview changes" :: String), + pretty ("seihou schema-upgrade --all # upgrade all modules" :: String) + ] + ] + +kitInfo :: ParserInfo Command +kitInfo = + info + (Kit <$> kitCommandParser <**> helper) + ( fullDesc + <> progDesc "Manage Claude Code and Codex skills and subagents" + ) + +registryInfo :: ParserInfo Command +registryInfo = + info + (Registry <$> registryCommandParser <**> helper) + ( fullDesc + <> progDesc "Manage seihou-registry.dhall files" + <> footerDoc + ( Just $ + vsep + [ pretty ("Authoring-time operations on a multi-artifact repository's" :: String), + pretty ("seihou-registry.dhall. Run against a writable checkout." :: String), + line, + pretty ("Current subcommands:" :: String), + indent 2 $ + vsep + [ pretty ("sync-versions Copy each entry's declared version into the registry" :: String), + pretty ("validate Check that registry entries match their on-disk artifacts" :: String) + ], + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou registry sync-versions" :: String), + pretty ("seihou registry sync-versions --dry-run" :: String), + pretty ("seihou registry sync-versions --check" :: String), + pretty ("seihou registry validate" :: String) + ] + ] + ) + ) + +registryCommandParser :: Parser RegistryCommand +registryCommandParser = + hsubparser + ( command "sync-versions" syncVersionsInfo + <> command "validate" validateRegistryInfo + ) + +syncVersionsInfo :: ParserInfo RegistryCommand +syncVersionsInfo = + info + (syncVersionsParser <**> helper) + ( fullDesc + <> progDesc "Populate registry entry versions from each module/recipe/blueprint/prompt" + <> footerDoc + ( Just $ + vsep + [ pretty ("Reads every entry's module.dhall, recipe.dhall, blueprint.dhall, or prompt.dhall," :: String), + pretty ("copies the declared version into the registry, and rewrites" :: String), + pretty ("seihou-registry.dhall. Hand-written comments and formatting are lost." :: String), + line, + pretty ("With --dry-run the diff is printed but the file is left untouched." :: String), + pretty ("With --check the command exits 1 if any entry is out of sync — suitable" :: String), + pretty ("for CI. --check takes precedence over --dry-run if both are given." :: String) + ] + ) + ) + +syncVersionsParser :: Parser RegistryCommand +syncVersionsParser = + fmap RegistrySyncVersions $ + SyncVersionsOpts + <$> optional + ( option + str + ( long "dir" + <> metavar "PATH" + <> help "Registry repo root (default: current directory)" + ) + ) + <*> switch (long "dry-run" <> help "Show diff without writing the registry file") + <*> switch (long "check" <> help "Exit 1 if any entry is out of sync; do not write") + +validateRegistryInfo :: ParserInfo RegistryCommand +validateRegistryInfo = + info + (validateRegistryParser <**> helper) + ( fullDesc + <> progDesc "Check that registry entries match their on-disk artifacts" + <> footerDoc + ( Just $ + vsep + [ pretty ("Validates a multi-artifact repository's seihou-registry.dhall:" :: String), + indent 2 $ + vsep + [ pretty ("- every entry path resolves to a module.dhall, recipe.dhall, blueprint.dhall, or prompt.dhall" :: String), + pretty ("- entry names match [a-z][a-z0-9-]*" :: String), + pretty ("- no name collisions between modules, recipes, blueprints, and prompts" :: String), + pretty ("- entry paths are relative and contain no '..'" :: String), + pretty ("- each entry's `version` matches the underlying module/recipe/blueprint/prompt" :: String) + ], + line, + pretty ("Exits 1 on any failure. Run from a writable checkout of the registry repo." :: String) + ] + ) + ) + +validateRegistryParser :: Parser RegistryCommand +validateRegistryParser = + fmap RegistryValidate $ + ValidateRegistryOpts + <$> optional + ( option + str + ( long "dir" + <> metavar "PATH" + <> help "Registry repo root (default: current directory)" + ) + ) + +agentInfo :: ParserInfo Command +agentInfo = + info + (agentParser <**> helper) + ( fullDesc + <> progDesc "AI-powered agent commands" + <> footerDoc + ( Just $ + vsep + [ pretty ("Agent subcommands provide AI-assisted workflows powered by" :: String), + pretty ("configurable CLI or API providers. Use --provider to select claude-cli, codex-cli," :: String), + pretty ("anthropic, or openai, and --model for a provider-specific model." :: String), + line, + pretty ("Use --debug with any subcommand to print the resolved system" :: String), + pretty ("prompt without contacting the configured provider." :: String), + line, + pretty ("Available subcommands:" :: String), + indent 2 $ + vsep + [ pretty ("assist AI-assisted template authoring prompt" :: String), + pretty ("bootstrap Bootstrap a new module or multi-module repo" :: String), + pretty ("setup Guided project setup: configure, run, and commit" :: String), + pretty ("run Run an agent-driven blueprint" :: String) + ] + ] + ) + ) + +agentParser :: Parser Command +agentParser = + fmap Agent $ + AgentOpts + <$> switch (long "debug" <> help "Print the resolved system prompt and exit") + <*> optional + ( option + (T.pack <$> str) + ( long "provider" + <> metavar "PROVIDER" + <> help "Agent provider: claude-cli, codex-cli, anthropic, or openai" + ) + ) + <*> optional + ( option + (T.pack <$> str) + ( long "model" + <> metavar "MODEL" + <> help "Agent model name or provider-specific model alias" + ) + ) + <*> agentCommandParser + +agentCommandParser :: Parser AgentCommand +agentCommandParser = + subparser + ( command "assist" agentAssistInfo + <> command "bootstrap" agentBootstrapInfo + <> command "setup" agentSetupInfo + <> command "run" agentRunInfo + ) + +agentAssistInfo :: ParserInfo AgentCommand +agentAssistInfo = + info + (agentAssistParser <**> helper) + ( fullDesc + <> progDesc "Launch AI-assisted template authoring session" + <> footerDoc + ( Just $ + vsep + [ pretty ("Renders a Seihou-aware prompt for creating and modifying" :: String), + pretty ("modules, then starts the configured provider." :: String), + pretty ("The prompt gathers context" :: String), + pretty ("about your current directory (existing modules, manifest state," :: String), + pretty ("available modules) and includes the Seihou" :: String), + pretty ("module schema." :: String), + line, + pretty ("CLI providers open interactive Claude Code or Codex sessions;" :: String), + pretty ("API providers run one-shot text completions." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent assist" :: String), + pretty ("seihou agent assist \"create a rust project template\"" :: String), + pretty ("seihou agent assist \"add a LICENSE step to my-module\"" :: String) + ] + ] + ) + ) + +agentAssistParser :: Parser AgentCommand +agentAssistParser = + fmap AgentAssist $ + AssistOpts + <$> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Initial prompt describing what you want to do")) + <*> providerOption + <*> modelOption + +agentBootstrapInfo :: ParserInfo AgentCommand +agentBootstrapInfo = + info + (agentBootstrapParser <**> helper) + ( fullDesc + <> progDesc "Bootstrap a new module or multi-module repository" + <> footerDoc + ( Just $ + vsep + [ pretty ("Renders a Seihou-aware prompt for creating a complete module" :: String), + pretty ("from scratch: defining variables," :: String), + pretty ("writing templates, setting up prompts, and validating the result." :: String), + line, + pretty ("Use --repo to bootstrap a multi-module repository with a" :: String), + pretty ("seihou-registry.dhall and multiple module directories." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent bootstrap" :: String), + pretty ("seihou agent bootstrap \"a haskell project template\"" :: String), + pretty ("seihou agent bootstrap --repo" :: String), + pretty ("seihou agent bootstrap --repo \"team templates for rust projects\"" :: String) + ] + ] + ) + ) + +agentBootstrapParser :: Parser AgentCommand +agentBootstrapParser = + fmap AgentBootstrap $ + BootstrapOpts + <$> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Description of what to bootstrap")) + <*> switch (long "repo" <> help "Bootstrap a multi-module repository with registry") + <*> providerOption + <*> modelOption + +agentSetupInfo :: ParserInfo AgentCommand +agentSetupInfo = + info + (agentSetupParser <**> helper) + ( fullDesc + <> progDesc "Guided project setup: configure, run, and commit" + <> footerDoc + ( Just $ + vsep + [ pretty ("Renders a Seihou-aware prompt for using a module: selecting" :: String), + pretty ("a module, configuring variables and" :: String), + pretty ("context, running the module to generate files, verifying the output," :: String), + pretty ("and committing the changes to git." :: String), + line, + pretty ("The rendered prompt is sent to the configured provider;" :: String), + pretty ("--debug prints it without contacting that provider." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent setup" :: String), + pretty ("seihou agent setup \"set up a haskell project with nix\"" :: String), + pretty ("seihou agent setup \"add nix-flake module to this project\"" :: String) + ] + ] + ) + ) + +agentSetupParser :: Parser AgentCommand +agentSetupParser = + fmap AgentSetup $ + SetupOpts + <$> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Description of what you want to set up")) + <*> providerOption + <*> modelOption + +agentRunInfo :: ParserInfo AgentCommand +agentRunInfo = + info + (agentRunParser <**> helper) + ( fullDesc + <> progDesc "Run an agent-driven blueprint" + <> footerDoc + ( Just $ + vsep + [ pretty ("Resolves the named blueprint, prompts for any required variables," :: String), + pretty ("optionally applies the blueprint's baseModules as a starting scaffold," :: String), + pretty ("renders the prompt template, and starts the configured" :: String), + pretty ("provider." :: String), + line, + pretty ("Variable resolution follows the same precedence as 'seihou run':" :: String), + pretty ("CLI overrides > env > local config > namespace > context > global > defaults" :: String), + pretty ("> interactive prompts." :: String), + line, + pretty ("Pass --no-baseline to skip baseline application; --debug (on the parent" :: String), + pretty ("'seihou agent --debug') prints the resolved system prompt without" :: String), + pretty ("contacting the configured provider." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou agent run my-blueprint" :: String), + pretty ("seihou agent run my-blueprint \"set this up for billing\"" :: String), + pretty ("seihou agent run my-blueprint --var service.name=billing" :: String), + pretty ("seihou agent run my-blueprint --no-baseline" :: String), + pretty ("seihou agent --debug run my-blueprint" :: String) + ] + ] + ) + ) + +agentRunParser :: Parser AgentCommand +agentRunParser = + fmap AgentRun $ + BlueprintRunOpts + <$> argument moduleNameReader (metavar "BLUEPRINT" <> help "Name of the blueprint to run") + <*> optional (argument (T.pack <$> str) (metavar "PROMPT" <> help "Optional initial user prompt")) + <*> many + ( option + varPair + (long "var" <> metavar "KEY=VALUE" <> help "Variable override (repeatable)") + ) + <*> switch (long "no-baseline" <> help "Skip applying the blueprint's baseModules before rendering the prompt") + <*> optional (option (T.pack <$> str) (long "namespace" <> metavar "NS" <> help "Override namespace for config lookup")) + <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) + <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") + <*> switch (long "force" <> help "Auto-resolve baseline conflicts (accept new files)") + <*> providerOption + <*> modelOption + +promptInfo :: ParserInfo Command +promptInfo = + info + (promptParser <**> helper) + ( fullDesc + <> progDesc "Run first-class agent-session prompts" + <> footerDoc + ( Just $ + vsep + [ pretty ("Prompt subcommands render reusable prompt.dhall artifacts and" :: String), + pretty ("start the configured provider. Use 'prompt run --debug' to print" :: String), + pretty ("the fully rendered prompt without contacting a provider." :: String), + line, + pretty ("Available subcommands:" :: String), + indent 2 $ + vsep + [ pretty ("run Resolve, render, and launch a prompt" :: String) + ] + ] + ) + ) + +promptParser :: Parser Command +promptParser = + fmap Prompt $ + subparser + (command "run" promptRunInfo) + +promptRunInfo :: ParserInfo PromptCommand +promptRunInfo = + info + (promptRunParser <**> helper) + ( fullDesc + <> progDesc "Run an agent-session prompt" + <> footerDoc + ( Just $ + vsep + [ pretty ("Resolves the named prompt, prompts for any required variables," :: String), + pretty ("runs command-derived variables, renders the prompt body, and" :: String), + pretty ("starts the configured provider." :: String), + line, + pretty ("Variable resolution follows the same precedence as 'seihou run':" :: String), + pretty ("CLI overrides > env > local config > namespace > context > global > defaults" :: String), + pretty ("> interactive prompts. Command-derived variables fill any remaining" :: String), + pretty ("prompt variables after that chain resolves." :: String), + line, + pretty ("CLI providers open interactive Claude Code or Codex sessions;" :: String), + pretty ("API providers run one-shot text completions. Use --debug to print" :: String), + pretty ("the rendered prompt and skip provider launch." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou prompt run review-changes" :: String), + pretty ("seihou prompt run review-changes \"focus on API changes\"" :: String), + pretty ("seihou prompt run review-changes --var project.name=demo" :: String), + pretty ("seihou prompt run review-changes --debug" :: String) + ] + ] + ) + ) + +promptRunParser :: Parser PromptCommand +promptRunParser = + fmap PromptRun $ + PromptRunOpts + <$> argument moduleNameReader (metavar "PROMPT" <> help "Name of the prompt to run") + <*> optional (argument (T.pack <$> str) (metavar "USER-PROMPT" <> help "Optional initial user prompt")) + <*> many + ( option + varPair + (long "var" <> metavar "KEY=VALUE" <> help "Variable override (repeatable)") + ) + <*> optional (option (T.pack <$> str) (long "namespace" <> metavar "NS" <> help "Override namespace for config lookup")) + <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup")) + <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages") + <*> switch (long "debug" <> help "Print the rendered prompt and exit") + <*> providerOption + <*> modelOption + +helpCmdInfo :: ParserInfo Command +helpCmdInfo = + info + (HelpCmd <$> helpCommandParser <**> helper) + ( fullDesc + <> progDesc "Show help for commands and topics" + ) + +extensionInfo :: ParserInfo Command +extensionInfo = + info + (Extension <$> extensionParser <**> helper) + ( fullDesc + <> progDesc "Run external seihou extensions" + <> footerDoc + ( Just $ + vsep + [ pretty ("Extensions are external executables named seihou--extension." :: String), + pretty ("Everything after '--' is forwarded unchanged to the extension process." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou extension run okf -- --help" :: String), + pretty ("seihou extension run okf -- docs --dir . --out okf-docs" :: String) + ] + ] + ) + ) + +extensionParser :: Parser ExtensionCommand +extensionParser = + hsubparser + (command "run" extensionRunInfo) + +extensionRunInfo :: ParserInfo ExtensionCommand +extensionRunInfo = + info + (extensionRunParser <**> helper) + ( fullDesc + <> progDesc "Run an extension executable from PATH" + ) + +extensionRunParser :: Parser ExtensionCommand +extensionRunParser = + fmap ExtensionRun $ + ExtensionRunOpts + <$> argument (T.pack <$> str) (metavar "NAME" <> help "Extension name") + <*> many (strArgument (metavar "ARGS...")) + +completionsInfo :: ParserInfo Command +completionsInfo = + info + (completionsParser <**> helper) + ( fullDesc + <> progDesc "Generate shell completion scripts" + <> footerDoc + ( Just $ + vsep + [ pretty ("Outputs a completion script for the specified shell. Source the" :: String), + pretty ("script in your shell profile to enable Tab completion for all" :: String), + pretty ("seihou commands, subcommands, and flags." :: String), + line, + pretty ("Examples:" :: String), + indent 2 $ + vsep + [ pretty ("seihou completions bash > ~/.local/share/bash-completion/completions/seihou" :: String), + pretty ("seihou completions zsh > ~/.zfunc/_seihou" :: String), + pretty ("seihou completions fish > ~/.config/fish/completions/seihou.fish" :: String) + ] + ] + ) + ) + +completionsParser :: Parser Command +completionsParser = + fmap Completions $ + subparser + ( command "bash" (info (pure CompletionsBash) (progDesc "Generate Bash completion script")) + <> command "zsh" (info (pure CompletionsZsh) (progDesc "Generate Zsh completion script")) + <> command "fish" (info (pure CompletionsFish) (progDesc "Generate Fish completion script")) + ) + +-- Helpers + +moduleNameReader :: ReadM ModuleName +moduleNameReader = ModuleName . T.pack <$> str + +varPair :: ReadM (Text, Text) +varPair = eitherReader $ \s -> + case T.breakOn "=" (T.pack s) of + (k, v) + | T.null k -> Left "variable name cannot be empty" + | T.null v -> Left "expected KEY=VALUE format" + | otherwise -> Right (k, T.drop 1 v) + +providerOption :: Parser (Maybe Text) +providerOption = + optional $ + option + (T.pack <$> str) + ( long "provider" + <> metavar "PROVIDER" + <> help "Agent provider: claude-cli, codex-cli, anthropic, or openai" + ) + +modelOption :: Parser (Maybe Text) +modelOption = + optional $ + option + (T.pack <$> str) + ( long "model" + <> metavar "MODEL" + <> help "Agent model name or provider-specific model alias" + ) diff --git a/src-exe/Seihou/CLI/Completions.hs b/src-exe/Seihou/CLI/Completions.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Completions.hs @@ -0,0 +1,16 @@ +module Seihou.CLI.Completions + ( handleCompletionsCommand, + ) +where + +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (CompletionsCommand (..)) +import Seihou.CLI.Completions.Bash (generateBashCompletion) +import Seihou.CLI.Completions.Fish (generateFishCompletion) +import Seihou.CLI.Completions.Zsh (generateZshCompletion) + +handleCompletionsCommand :: CompletionsCommand -> IO () +handleCompletionsCommand = \case + CompletionsBash -> TIO.putStrLn generateBashCompletion + CompletionsZsh -> TIO.putStrLn generateZshCompletion + CompletionsFish -> TIO.putStrLn generateFishCompletion diff --git a/src-exe/Seihou/CLI/Config.hs b/src-exe/Seihou/CLI/Config.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Config.hs @@ -0,0 +1,157 @@ +module Seihou.CLI.Config + ( handleConfig, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (ConfigAction (..), ConfigOpts (..)) +import Seihou.CLI.Shared (formatConfigError, logIO) +import Seihou.Core.Types (ConfigError, ConfigScope (..), LogLevel (..)) +import Seihou.Effect.ConfigReader (readContextConfig, readGlobalConfig, readLocalConfig, readNamespaceConfig) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConfigWriter (deleteConfigValue, listConfigValues, writeConfigValue) +import Seihou.Effect.ConfigWriterInterp (runConfigWriter) +import Seihou.Effect.Logger (logError) +import Seihou.Prelude +import System.Exit (exitFailure) + +handleConfig :: ConfigOpts -> IO () +handleConfig ConfigOpts {configAction, configGlobal, configNamespace, configContext, configEffective} = do + let scope = resolveScope configGlobal configNamespace configContext + case configAction of + ConfigSet key value -> handleSet scope key value + ConfigGet key -> handleGet scope key + ConfigUnset key -> handleUnset scope key + ConfigList + | configEffective -> handleListEffective configNamespace configContext + | otherwise -> handleList configGlobal configNamespace configContext + +resolveScope :: Bool -> Maybe Text -> Maybe Text -> ConfigScope +resolveScope True _ _ = ScopeGlobal +resolveScope _ (Just ns) _ = ScopeNamespace ns +resolveScope _ _ (Just ctx) = ScopeContext ctx +resolveScope _ _ _ = ScopeLocal + +scopeLabel :: ConfigScope -> Text +scopeLabel ScopeLocal = "local" +scopeLabel (ScopeNamespace ns) = "namespace " <> ns +scopeLabel (ScopeContext ctx) = "context " <> ctx +scopeLabel ScopeGlobal = "global" + +handleSet :: ConfigScope -> Text -> Text -> IO () +handleSet scope key value = do + runEff $ runConfigWriter $ writeConfigValue scope key value + TIO.putStrLn $ "Set " <> key <> " = " <> value <> " in " <> scopeLabel scope <> " config" + +handleGet :: ConfigScope -> Text -> IO () +handleGet scope key = do + result <- runEff $ runConfigWriter $ listConfigValues scope + case result of + Left err -> configError err + Right m -> case Map.lookup key m of + Just val -> TIO.putStrLn val + Nothing -> TIO.putStrLn $ key <> " is not set in " <> scopeLabel scope <> " config" + +handleUnset :: ConfigScope -> Text -> IO () +handleUnset scope key = do + result <- runEff $ runConfigWriter $ listConfigValues scope + case result of + Left err -> configError err + Right m -> + if Map.member key m + then do + runEff $ runConfigWriter $ deleteConfigValue scope key + TIO.putStrLn $ "Removed " <> key <> " from " <> scopeLabel scope <> " config" + else TIO.putStrLn $ key <> " is not set in " <> scopeLabel scope <> " config" + +handleList :: Bool -> Maybe Text -> Maybe Text -> IO () +handleList isGlobal mNamespace mContext + | isGlobal = listScope ScopeGlobal + | Just ns <- mNamespace = listScope (ScopeNamespace ns) + | Just ctx <- mContext = listScope (ScopeContext ctx) + | otherwise = listAllScopes + +-- | Show the merged effective config across all scopes. +-- Precedence: local > namespace > global (matching variable resolution order). +handleListEffective :: Maybe Text -> Maybe Text -> IO () +handleListEffective mNamespace mContext = do + results <- runEff $ runConfigReader $ do + l <- readLocalConfig + n <- case mNamespace of + Just ns -> readNamespaceConfig ns + Nothing -> pure (Right Map.empty) + c <- case mContext of + Just ctx -> readContextConfig ctx + Nothing -> pure (Right Map.empty) + g <- readGlobalConfig + pure (l, n, c, g) + let (localResult, nsResult, ctxResult, globalResult) = results + case (globalResult, ctxResult, nsResult, localResult) of + (Left err, _, _, _) -> configError err + (_, Left err, _, _) -> configError err + (_, _, Left err, _) -> configError err + (_, _, _, Left err) -> configError err + (Right globalMap, Right ctxMap, Right nsMap, Right localMap) -> do + -- Build merged map with source tracking: local > namespace > context > global + let taggedGlobal = Map.map (\v -> (v, "global" :: Text)) globalMap + taggedCtx = Map.map (\v -> (v, maybe "context" (\ctx -> "context: " <> ctx) mContext)) ctxMap + taggedNs = Map.map (\v -> (v, maybe "namespace" (\ns -> "namespace: " <> ns) mNamespace)) nsMap + taggedLocal = Map.map (\v -> (v, "local")) localMap + merged = taggedLocal `Map.union` taggedNs `Map.union` taggedCtx `Map.union` taggedGlobal + if Map.null merged + then TIO.putStrLn "No config values set in any scope." + else do + TIO.putStrLn "Effective config:" + let entries = Map.toAscList merged + maxKeyLen = maximum (0 : map (T.length . fst) entries) + maxValLen = maximum (0 : map (T.length . fst . snd) entries) + mapM_ (printEffectiveEntry maxKeyLen maxValLen) entries + +printEffectiveEntry :: Int -> Int -> (Text, (Text, Text)) -> IO () +printEffectiveEntry maxKeyLen maxValLen (key, (value, source)) = do + let keyPad = T.replicate (maxKeyLen - T.length key) " " + valPad = T.replicate (maxValLen - T.length value) " " + TIO.putStrLn $ " " <> key <> keyPad <> " = " <> value <> valPad <> " [" <> source <> "]" + +listScope :: ConfigScope -> IO () +listScope scope = do + result <- runEff $ runConfigWriter $ listConfigValues scope + case result of + Left err -> configError err + Right m + | Map.null m -> TIO.putStrLn $ "No config values in " <> scopeLabel scope <> " scope" + | otherwise -> do + TIO.putStrLn $ scopeLabel scope <> " config:" + mapM_ printEntry (Map.toAscList m) + +listAllScopes :: IO () +listAllScopes = do + results <- runEff $ runConfigReader $ do + l <- readLocalConfig + g <- readGlobalConfig + pure (l, g) + let (localResult, globalResult) = results + printScopeIfNonEmpty "local" localResult + printScopeIfNonEmpty "global" globalResult + +printScopeIfNonEmpty :: Text -> Either ConfigError (Map.Map Text Text) -> IO () +printScopeIfNonEmpty label result = + case result of + Left err -> do + TIO.putStrLn $ label <> " config: " <> formatConfigError err + Right m + | Map.null m -> pure () + | otherwise -> do + TIO.putStrLn $ label <> " config:" + mapM_ printEntry (Map.toAscList m) + TIO.putStrLn "" + +printEntry :: (Text, Text) -> IO () +printEntry (key, value) = TIO.putStrLn $ " " <> key <> " = " <> value + +configError :: ConfigError -> IO () +configError err = do + logIO LogNormal (logError $ "Config error: " <> formatConfigError err) + exitFailure diff --git a/src-exe/Seihou/CLI/Context.hs b/src-exe/Seihou/CLI/Context.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Context.hs @@ -0,0 +1,150 @@ +module Seihou.CLI.Context + ( handleContext, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (ContextAction (..)) +import Seihou.Core.Context (resolveContext, validateContextName) +import Seihou.Effect.Fzf (selectOne) +import Seihou.Effect.FzfInterp (runFzfIO) +import Seihou.Fzf (Candidate (..), FzfResult (..), detectFzfConfig, isFzfUsable, withAnsi, withHeight, withNoSort, withPrompt) +import Seihou.Fzf qualified +import Seihou.Prelude +import System.Directory + ( XdgDirectory (..), + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + getCurrentDirectory, + getXdgDirectory, + listDirectory, + removeFile, + ) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..), exitFailure, exitWith) + +handleContext :: ContextAction -> IO () +handleContext ContextShow = showContext +handleContext (ContextSet mName) = do + name <- case mName of + Just n -> pure n + Nothing -> do + fzfCfg <- detectFzfConfig + if isFzfUsable fzfCfg + then do + result <- selectContextFzf fzfCfg + case result of + FzfSelected n -> pure n + FzfCancelled -> exitWith ExitSuccess + FzfNoMatch -> do + TIO.putStrLn "No contexts found." + exitFailure + FzfError err -> do + TIO.putStrLn $ "fzf error: " <> err + exitFailure + else do + TIO.putStrLn "NAME argument is required when fzf is not available." + exitFailure + setProjectContext name +handleContext (ContextDefault name) = setGlobalDefault name +handleContext ContextClear = clearProjectContext +handleContext ContextClearDefault = clearGlobalDefault + +-- | Select a context via fzf from available context directories. +selectContextFzf :: Seihou.Fzf.FzfConfig -> IO (FzfResult Text) +selectContextFzf fzfCfg = do + base <- getXdgDirectory XdgConfig "seihou" + let contextsDir = base "contexts" + exists <- doesDirectoryExist contextsDir + if not exists + then pure FzfNoMatch + else do + entries <- listDirectory contextsDir + dirs <- filterM (doesDirectoryExist . (contextsDir )) entries + let candidates = [Candidate {candidateDisplay = T.pack d, candidateValue = T.pack d} | d <- dirs] + opts = withPrompt "context> " <> withHeight "40%" <> withAnsi <> withNoSort + runEff $ runFzfIO fzfCfg $ selectOne opts candidates + where + filterM _ [] = pure [] + filterM p (x : xs) = do + b <- p x + rest <- filterM p xs + if b then pure (x : rest) else pure rest + +showContext :: IO () +showContext = do + envPairs <- getEnvironment + let envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] + result <- resolveContext Nothing envVars + case result of + Nothing -> TIO.putStrLn "No active context." + Just ctx -> do + TIO.putStrLn $ "Active context: " <> ctx + -- Show where it came from + case Map.lookup "SEIHOU_CONTEXT" envVars of + Just _ -> TIO.putStrLn " Source: SEIHOU_CONTEXT environment variable" + Nothing -> do + cwd <- getCurrentDirectory + let projectFile = cwd ".seihou" "context" + projectExists <- doesFileExist projectFile + if projectExists + then TIO.putStrLn " Source: .seihou/context (project)" + else do + base <- getXdgDirectory XdgConfig "seihou" + let defaultFile = base "default-context" + defaultExists <- doesFileExist defaultFile + if defaultExists + then TIO.putStrLn $ " Source: " <> T.pack defaultFile <> " (global default)" + else TIO.putStrLn " Source: unknown" + +setProjectContext :: Text -> IO () +setProjectContext name = do + case validateContextName name of + Just err -> do + TIO.putStrLn $ "Invalid context name: " <> err + exitFailure + Nothing -> do + cwd <- getCurrentDirectory + let dir = cwd ".seihou" + path = dir "context" + createDirectoryIfMissing True dir + TIO.writeFile path (name <> "\n") + TIO.putStrLn $ "Set project context to: " <> name + +setGlobalDefault :: Text -> IO () +setGlobalDefault name = do + case validateContextName name of + Just err -> do + TIO.putStrLn $ "Invalid context name: " <> err + exitFailure + Nothing -> do + base <- getXdgDirectory XdgConfig "seihou" + createDirectoryIfMissing True base + let path = base "default-context" + TIO.writeFile path (name <> "\n") + TIO.putStrLn $ "Set global default context to: " <> name + +clearProjectContext :: IO () +clearProjectContext = do + cwd <- getCurrentDirectory + let path = cwd ".seihou" "context" + exists <- doesFileExist path + if exists + then do + removeFile path + TIO.putStrLn "Removed project context." + else TIO.putStrLn "No project context set." + +clearGlobalDefault :: IO () +clearGlobalDefault = do + base <- getXdgDirectory XdgConfig "seihou" + let path = base "default-context" + exists <- doesFileExist path + if exists + then do + removeFile path + TIO.putStrLn "Removed global default context." + else TIO.putStrLn "No global default context set." diff --git a/src-exe/Seihou/CLI/Help.hs b/src-exe/Seihou/CLI/Help.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Help.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.Help + ( HelpCommand (..), + helpCommandParser, + handleHelpCommand, + ) +where + +import Data.FileEmbed (embedStringFile) +import Data.Foldable (forM_) +import Data.List (find) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Options.Applicative +import Seihou.Prelude + +data HelpTopic = HelpTopic + { topicName :: !Text, + topicDescription :: !Text, + topicContent :: !Text + } + +data HelpCommand + = ListTopics + | ShowTopic !Text + deriving stock (Eq, Show) + +helpTopics :: [HelpTopic] +helpTopics = + [ HelpTopic "agent" "Configurable AI assistance commands" agentContent, + HelpTopic "blueprints" "Agent-driven project blueprints" blueprintsContent, + HelpTopic "modules" "How Seihou modules work" modulesContent, + HelpTopic "variables" "Variable declaration, resolution, and overrides" variablesContent, + HelpTopic "contexts" "Using contexts for environment-specific config" contextsContent, + HelpTopic "config" "Config scopes, reading, and writing values" configContent, + HelpTopic "git-repository" "Sharing and installing items from git" gitRepositoryContent, + HelpTopic "kit" "Manage Claude Code and Codex skills and subagents" kitContent, + HelpTopic "migrations" "Migrating a project between module versions" migrationsContent, + HelpTopic "prompts" "Reusable agent-session prompt artifacts" promptsContent, + HelpTopic "templating" "Placeholder substitution, {{#if}} blocks, and patterns" templatingContent + ] + +agentContent :: Text +agentContent = $(embedStringFile "help/agent.md") + +blueprintsContent :: Text +blueprintsContent = $(embedStringFile "help/blueprints.md") + +modulesContent :: Text +modulesContent = $(embedStringFile "help/modules.md") + +variablesContent :: Text +variablesContent = $(embedStringFile "help/variables.md") + +contextsContent :: Text +contextsContent = $(embedStringFile "help/contexts.md") + +configContent :: Text +configContent = $(embedStringFile "help/config.md") + +gitRepositoryContent :: Text +gitRepositoryContent = $(embedStringFile "help/git-repository.md") + +kitContent :: Text +kitContent = $(embedStringFile "help/kit.md") + +migrationsContent :: Text +migrationsContent = $(embedStringFile "help/migrations.md") + +promptsContent :: Text +promptsContent = $(embedStringFile "help/prompts.md") + +templatingContent :: Text +templatingContent = $(embedStringFile "help/templating.md") + +helpCommandParser :: Parser HelpCommand +helpCommandParser = + showTopicParser <|> pure ListTopics + +showTopicParser :: Parser HelpCommand +showTopicParser = + ShowTopic + <$> strArgument + ( metavar "TOPIC" + <> help ("Help topic: " <> T.unpack topicList) + ) + where + topicList = T.intercalate ", " (map (.topicName) helpTopics) + +handleHelpCommand :: HelpCommand -> IO () +handleHelpCommand = \case + ListTopics -> listTopics + ShowTopic name -> showTopic name + +listTopics :: IO () +listTopics = do + TIO.putStrLn "HELP TOPICS\n" + forM_ helpTopics $ \t -> + TIO.putStrLn $ " " <> padRight 17 t.topicName <> t.topicDescription + TIO.putStrLn "\nUse 'seihou help ' for details." + +padRight :: Int -> Text -> Text +padRight n t = t <> T.replicate (max 0 (n - T.length t)) " " + +showTopic :: Text -> IO () +showTopic name = + case find (\t -> t.topicName == T.toLower name) helpTopics of + Just t -> TIO.putStrLn t.topicContent + Nothing -> do + TIO.putStrLn $ "Unknown topic: " <> name + TIO.putStrLn $ "Available: " <> T.intercalate ", " (map (.topicName) helpTopics) diff --git a/src-exe/Seihou/CLI/Install.hs b/src-exe/Seihou/CLI/Install.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Install.hs @@ -0,0 +1,500 @@ +module Seihou.CLI.Install + ( handleInstall, + installModuleDir, + cloneRepo, + copyDirectoryRecursive, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.BrowseFormat (kindLabel) +import Seihou.CLI.Commands (InstallOpts (..)) +import Seihou.CLI.InstallHistory (HistoryEntry (..), InstallHistory (..), readHistory, recordUrl) +import Seihou.CLI.InstallShared (cloneRepo, copyDirectoryRecursive, installModuleDir) +import Seihou.CLI.Registry.Sync (checkRegistryVersionDrift) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.AgentPrompt (validateAgentPrompt) +import Seihou.Core.Blueprint (validateBlueprint) +import Seihou.Core.Install (parseModuleName) +import Seihou.Core.Module (validateModule) +import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents, validateRegistry) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRegistryFromFile) +import Seihou.Effect.Fzf (selectOne) +import Seihou.Effect.FzfInterp (runFzfIO) +import Seihou.Effect.Logger (logError, logWarn) +import Seihou.Fzf (Candidate (..), FzfConfig, FzfResult (..), detectFzfConfig, isFzfUsable, withAnsi, withHeader, withHeight, withNoSort, withPrompt) +import Seihou.Fzf qualified +import Seihou.Prelude +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (hFlush, stdout) +import System.IO.Temp (withSystemTempDirectory) + +handleInstall :: InstallOpts -> IO () +handleInstall iopts = do + source <- resolveSource iopts.installSource + + TIO.putStrLn $ "Installing from " <> source <> "..." + + -- Clone into a temporary directory + withSystemTempDirectory "seihou-install" $ \tmpDir -> do + let repoName = parseModuleName source + cloneDir = tmpDir repoName + cloneRes <- cloneRepo source cloneDir + case cloneRes of + Left err -> do + logIO LogNormal $ do + logError err + exitFailure + Right () -> TIO.putStrLn " Cloned repository" + + -- Determine what the repo contains + contents <- discoverRepoContents evalRegistryFromFile cloneDir + case contents of + EmptyRepo -> do + logIO LogNormal (logError "repository contains neither seihou-registry.dhall nor a supported runnable Dhall file.") + exitFailure + SingleModule rootDir -> do + when (not (null iopts.installModules) || iopts.installAll) $ + logIO LogNormal (logWarn "--module and --all flags are ignored for single-module repositories.") + installSingleModule iopts rootDir source Nothing + SingleRecipe rootDir -> do + when (not (null iopts.installModules) || iopts.installAll) $ + logIO LogNormal (logWarn "--module and --all flags are ignored for single-recipe repositories.") + installSingleRecipe iopts rootDir source + SingleBlueprint rootDir -> do + when (not (null iopts.installModules) || iopts.installAll) $ + logIO LogNormal (logWarn "--module and --all flags are ignored for single-blueprint repositories.") + installSingleBlueprint iopts rootDir source + SinglePrompt rootDir -> do + when (not (null iopts.installModules) || iopts.installAll) $ + logIO LogNormal (logWarn "--module and --all flags are ignored for single-prompt repositories.") + installSinglePrompt iopts rootDir source + MultiModule registry -> do + regErrors <- validateRegistry cloneDir registry + if not (null regErrors) + then do + logIO LogNormal $ do + logError "registry has validation errors:" + mapM_ (\e -> logError $ " - " <> e) regErrors + exitFailure + else do + driftWarnings <- checkRegistryVersionDrift cloneDir registry + logIO LogNormal (mapM_ logWarn driftWarnings) + installFromRegistry iopts cloneDir registry source + + -- Record URL in history for future recall (only reached on success) + recordUrl source + +-- | Resolve the install source: use the explicit URL if given, otherwise pick from history. +resolveSource :: Maybe Text -> IO Text +resolveSource (Just url) = pure url +resolveSource Nothing = do + history <- readHistory + case history.entries of + [] -> do + TIO.putStrLn "No URL specified and no install history found." + TIO.putStrLn "Usage: seihou install " + exitFailure + entries -> do + fzfCfg <- detectFzfConfig + if isFzfUsable fzfCfg + then fzfUrlSelection fzfCfg entries + else promptUrlSelection entries + +-- | FZF selection of a URL from history. +fzfUrlSelection :: FzfConfig -> [HistoryEntry] -> IO Text +fzfUrlSelection fzfCfg entries = do + let candidates = + [ Candidate + { candidateDisplay = entry.url, + candidateValue = entry.url + } + | entry <- entries + ] + opts = withPrompt "install> " <> withHeader "Select a previously used source:" <> withHeight "40%" <> withAnsi <> withNoSort + result <- runEff $ runFzfIO fzfCfg $ selectOne opts candidates + case result of + FzfSelected url -> pure url + FzfCancelled -> do + TIO.putStrLn "Cancelled." + exitFailure + FzfNoMatch -> do + TIO.putStrLn "No match." + exitFailure + FzfError err -> do + TIO.putStrLn $ "fzf error: " <> err <> ", falling back to prompt" + promptUrlSelection entries + +-- | Numbered prompt fallback for URL selection. +promptUrlSelection :: [HistoryEntry] -> IO Text +promptUrlSelection entries = do + TIO.putStrLn "" + TIO.putStrLn "Previously used sources:" + let numbered = zip [1 :: Int ..] entries + mapM_ + (\(i, entry) -> TIO.putStrLn $ " " <> T.pack (show i) <> ") " <> entry.url) + numbered + TIO.putStrLn "" + TIO.putStr "Select a source (number): " + hFlush stdout + input <- TIO.getLine + case readMaybe (T.unpack (T.strip input)) of + Just n + | n >= 1 && n <= length entries -> + pure (entries !! (n - 1)).url + _ -> do + TIO.putStrLn "Invalid selection." + exitFailure + +-- | Install a single-module repo (legacy behavior). +installSingleModule :: InstallOpts -> FilePath -> Text -> Maybe Text -> IO () +installSingleModule iopts rootDir source registryName = do + let name = case iopts.installName of + Just n -> T.unpack n + Nothing -> parseModuleName source + + let dhallFile = rootDir "module.dhall" + decoded <- evalModuleFromFile dhallFile + modul <- case decoded of + Left err -> do + logIO LogNormal $ do + logError "repository is not a valid seihou module." + logError $ " " <> T.pack (show err) + exitFailure + Right m -> pure m + + result <- validateModule rootDir modul + case result of + Left (ValidationError _ errors) -> do + logIO LogNormal $ do + logError "module has validation errors:" + mapM_ (\e -> logError $ " - " <> e) errors + exitFailure + Left err -> do + logIO LogNormal (logError $ T.pack (show err)) + exitFailure + Right _ -> pure () + TIO.putStrLn " Validated module definition" + + installModuleDir rootDir name source registryName modul.version [] + TIO.putStrLn "" + TIO.putStrLn $ "Module available as: " <> T.pack name + +-- | Install a single-recipe repo. +installSingleRecipe :: InstallOpts -> FilePath -> Text -> IO () +installSingleRecipe iopts rootDir source = do + let name = case iopts.installName of + Just n -> T.unpack n + Nothing -> parseModuleName source + + -- Validate recipe.dhall exists (discoverRepoContents already confirmed it) + TIO.putStrLn " Validated recipe definition" + + installModuleDir rootDir name source Nothing Nothing [] + TIO.putStrLn "" + TIO.putStrLn $ "Recipe available as: " <> T.pack name + +-- | Install a single-blueprint repo. +installSingleBlueprint :: InstallOpts -> FilePath -> Text -> IO () +installSingleBlueprint iopts rootDir source = do + let name = case iopts.installName of + Just n -> T.unpack n + Nothing -> parseModuleName source + + let dhallFile = rootDir "blueprint.dhall" + decoded <- evalBlueprintFromFile dhallFile + bp <- case decoded of + Left err -> do + logIO LogNormal $ do + logError "repository is not a valid seihou blueprint." + logError $ " " <> T.pack (show err) + exitFailure + Right b -> pure b + + result <- validateBlueprint rootDir bp + case result of + Left (ValidationError _ errors) -> do + logIO LogNormal $ do + logError "blueprint has validation errors:" + mapM_ (\e -> logError $ " - " <> e) errors + exitFailure + Left err -> do + logIO LogNormal (logError $ T.pack (show err)) + exitFailure + Right _ -> pure () + TIO.putStrLn " Validated blueprint definition" + + let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ -> v + installModuleDir rootDir name source Nothing bpVersion [] + TIO.putStrLn "" + TIO.putStrLn $ "Blueprint available as: " <> T.pack name + +-- | Install a single-prompt repo. +installSinglePrompt :: InstallOpts -> FilePath -> Text -> IO () +installSinglePrompt iopts rootDir source = do + let name = case iopts.installName of + Just n -> T.unpack n + Nothing -> parseModuleName source + + let dhallFile = rootDir "prompt.dhall" + decoded <- evalAgentPromptFromFile dhallFile + prompt <- case decoded of + Left err -> do + logIO LogNormal $ do + logError "repository is not a valid seihou prompt." + logError $ " " <> T.pack (show err) + exitFailure + Right p -> pure p + + result <- validateAgentPrompt rootDir prompt + case result of + Left (ValidationError _ errors) -> do + logIO LogNormal $ do + logError "prompt has validation errors:" + mapM_ (\e -> logError $ " - " <> e) errors + exitFailure + Left err -> do + logIO LogNormal (logError $ T.pack (show err)) + exitFailure + Right _ -> pure () + TIO.putStrLn " Validated prompt definition" + + installModuleDir rootDir name source Nothing prompt.version [] + TIO.putStrLn "" + TIO.putStrLn $ "Prompt available as: " <> T.pack name + +-- | Install from a multi-module registry. +installFromRegistry :: InstallOpts -> FilePath -> Registry -> Text -> IO () +installFromRegistry iopts cloneDir registry source = do + selected <- selectModules iopts registry + if null selected + then TIO.putStrLn "No entries selected." + else do + results <- mapM (installRegistryEntry cloneDir source registry.repoName) selected + let succeeded = length (filter id results) + failed = length results - succeeded + TIO.putStrLn "" + TIO.putStrLn $ + T.pack (show succeeded) + <> " " + <> (if succeeded == 1 then "entry" else "entries") + <> " installed" + <> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "") + <> "." + +-- | All registry entries (modules, recipes, blueprints, prompts) in display order. +-- Used wherever installation must treat all four kinds uniformly. +allEntries :: Registry -> [RegistryEntry] +allEntries registry = registry.modules ++ registry.recipes ++ registry.blueprints ++ registry.prompts + +-- | Pair each registry entry with its 'EntryKind' tag, preserving the +-- module → recipe → blueprint → prompt display order. Used by the install picker +-- to render per-kind labels and by callers that need to discriminate +-- after selection. +labelledEntries :: Registry -> [(EntryKind, RegistryEntry)] +labelledEntries registry = + map ((,) ModuleEntry) registry.modules + ++ map ((,) RecipeEntry) registry.recipes + ++ map ((,) BlueprintEntry) registry.blueprints + ++ map ((,) PromptEntry) registry.prompts + +-- | Select which modules to install from a registry. +selectModules :: InstallOpts -> Registry -> IO [RegistryEntry] +selectModules iopts registry + | iopts.installAll = pure (allEntries registry) + | not (null iopts.installModules) = do + let entries = allEntries registry + findEntry name = filter (\e -> e.name.unModuleName == name) entries + (found, missing) = + foldr + ( \name (f, m) -> case findEntry name of + (e : _) -> (e : f, m) + [] -> (f, name : m) + ) + ([], []) + iopts.installModules + if not (null missing) + then do + logIO LogNormal $ do + logError "the following entries were not found in the registry:" + mapM_ (\n -> logError $ " - " <> n) missing + exitFailure + else pure found + | otherwise = do + fzfCfg <- detectFzfConfig + if isFzfUsable fzfCfg + then fzfModuleSelection fzfCfg registry + else promptModuleSelection registry + +-- | Interactive module selection via fzf. +fzfModuleSelection :: Seihou.Fzf.FzfConfig -> Registry -> IO [RegistryEntry] +fzfModuleSelection fzfCfg registry = do + let entries = labelledEntries registry + candidates = + [ Candidate + { candidateDisplay = + kindLabel kind + <> " " + <> entry.name.unModuleName + <> maybe "" (\d -> " " <> d) entry.description + <> if null entry.tags then "" else " [" <> T.intercalate ", " entry.tags <> "]", + candidateValue = entry + } + | (kind, entry) <- entries + ] + opts = withPrompt "entry> " <> withHeight "40%" <> withAnsi <> withNoSort + result <- runEff $ runFzfIO fzfCfg $ selectOne opts candidates + case result of + FzfSelected entry -> pure [entry] + FzfCancelled -> pure [] + FzfNoMatch -> pure [] + FzfError err -> do + TIO.putStrLn $ "fzf error: " <> err + promptModuleSelection registry + +-- | Interactive module selection via numbered list. +promptModuleSelection :: Registry -> IO [RegistryEntry] +promptModuleSelection registry = do + TIO.putStrLn "" + TIO.putStrLn $ registry.repoName + case registry.repoDescription of + Just desc -> TIO.putStrLn $ " " <> desc + Nothing -> pure () + TIO.putStrLn "" + TIO.putStrLn "Available modules, recipes, blueprints, and prompts:" + let entries = zip [1 :: Int ..] (labelledEntries registry) + mapM_ + ( \(i, (kind, entry)) -> + TIO.putStrLn $ + " " + <> T.pack (show i) + <> ") " + <> kindLabel kind + <> " " + <> entry.name.unModuleName + <> maybe "" (\d -> " - " <> d) entry.description + ) + entries + TIO.putStrLn "" + TIO.putStr "Select entries (comma-separated numbers, or 'all'): " + hFlush stdout + input <- TIO.getLine + let trimmed = T.strip input + let entryList = allEntries registry + if T.toLower trimmed == "all" + then pure entryList + else do + let nums = map (readMaybe . T.unpack . T.strip) (T.splitOn "," trimmed) + if any (== Nothing) nums + then do + TIO.putStrLn "Invalid input. Please enter numbers separated by commas." + pure [] + else do + let indices = map (\(Just n) -> n) nums + maxIdx = length entryList + valid = all (\n -> n >= 1 && n <= maxIdx) indices + if not valid + then do + TIO.putStrLn $ "Invalid selection. Please enter numbers between 1 and " <> T.pack (show maxIdx) <> "." + pure [] + else pure [entryList !! (n - 1) | n <- indices] + +-- | Install a single registry entry (module, recipe, blueprint, or prompt). +installRegistryEntry :: FilePath -> Text -> Text -> RegistryEntry -> IO Bool +installRegistryEntry cloneDir source repoName entry = do + let entryDir = cloneDir entry.path + name = T.unpack entry.name.unModuleName + moduleDhall = entryDir "module.dhall" + recipeDhall = entryDir "recipe.dhall" + blueprintDhall = entryDir "blueprint.dhall" + promptDhall = entryDir "prompt.dhall" + TIO.putStrLn $ " Installing " <> entry.name.unModuleName <> "..." + + hasModule <- doesFileExist moduleDhall + if hasModule + then do + decoded <- evalModuleFromFile moduleDhall + case decoded of + Left err -> do + logIO LogNormal $ do + logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) + pure False + Right modul -> do + result <- validateModule entryDir modul + case result of + Left (ValidationError _ errors) -> do + logIO LogNormal $ do + logError $ " " <> entry.name.unModuleName <> " has validation errors:" + mapM_ (\e -> logError $ " - " <> e) errors + pure False + Left err -> do + logIO LogNormal (logError $ " " <> T.pack (show err)) + pure False + Right _ -> do + let ver = entry.version <|> modul.version + installModuleDir entryDir name source (Just repoName) ver entry.tags + TIO.putStrLn $ " Installed as: " <> T.pack name + pure True + else do + hasRecipe <- doesFileExist recipeDhall + if hasRecipe + then do + installModuleDir entryDir name source (Just repoName) entry.version entry.tags + TIO.putStrLn $ " Installed recipe as: " <> T.pack name + pure True + else do + hasBlueprint <- doesFileExist blueprintDhall + if hasBlueprint + then do + decoded <- evalBlueprintFromFile blueprintDhall + case decoded of + Left err -> do + logIO LogNormal $ do + logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) + pure False + Right bp -> do + let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ -> v + ver = entry.version <|> bpVersion + installModuleDir entryDir name source (Just repoName) ver entry.tags + TIO.putStrLn $ " Installed blueprint as: " <> T.pack name + pure True + else do + hasPrompt <- doesFileExist promptDhall + if hasPrompt + then do + decoded <- evalAgentPromptFromFile promptDhall + case decoded of + Left err -> do + logIO LogNormal $ do + logError $ " failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err) + pure False + Right prompt -> do + result <- validateAgentPrompt entryDir prompt + case result of + Left (ValidationError _ errors) -> do + logIO LogNormal $ do + logError $ " " <> entry.name.unModuleName <> " has validation errors:" + mapM_ (\e -> logError $ " - " <> e) errors + pure False + Left err -> do + logIO LogNormal (logError $ " " <> T.pack (show err)) + pure False + Right _ -> do + let ver = entry.version <|> prompt.version + installModuleDir entryDir name source (Just repoName) ver entry.tags + TIO.putStrLn $ " Installed prompt as: " <> T.pack name + pure True + else do + logIO LogNormal $ do + logError $ " entry '" <> entry.name.unModuleName <> "' has no supported runnable Dhall file at " <> T.pack entry.path + pure False + +readMaybe :: String -> Maybe Int +readMaybe s = case reads s of + [(n, "")] -> Just n + _ -> Nothing diff --git a/src-exe/Seihou/CLI/Kit.hs b/src-exe/Seihou/CLI/Kit.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Kit.hs @@ -0,0 +1,51 @@ +module Seihou.CLI.Kit + ( KitCommand (..), + kitCommandParser, + seihouKitConfig, + runKit, + ) +where + +import Baikai.Interactive (InteractiveProvider (..)) +import Baikai.Kit.Command qualified as Kit +import Baikai.Kit.Config (KitConfig (..), KitScope (..)) +import Options.Applicative (Parser) +import Seihou.Prelude + +data KitCommand + = KitList + | KitInstall !Text !KitScope + | KitUpdate !(Maybe Text) + | KitUninstall !Text !KitScope + | KitStatus + deriving stock (Eq, Show) + +kitCommandParser :: Parser KitCommand +kitCommandParser = fromShared <$> Kit.kitCommandParser + +seihouKitConfig :: KitConfig +seihouKitConfig = + KitConfig + { toolName = "seihou", + repoUrl = "https://github.com/shinzui/seihou-kit.git", + providers = [InteractiveClaude, InteractiveCodex] + } + +runKit :: KitCommand -> IO () +runKit = Kit.runKit seihouKitConfig . toShared + +fromShared :: Kit.KitCommand -> KitCommand +fromShared = \case + Kit.KitList -> KitList + Kit.KitInstall name scope -> KitInstall name scope + Kit.KitUpdate name -> KitUpdate name + Kit.KitUninstall name scope -> KitUninstall name scope + Kit.KitStatus -> KitStatus + +toShared :: KitCommand -> Kit.KitCommand +toShared = \case + KitList -> Kit.KitList + KitInstall name scope -> Kit.KitInstall name scope + KitUpdate name -> Kit.KitUpdate name + KitUninstall name scope -> Kit.KitUninstall name scope + KitStatus -> Kit.KitStatus diff --git a/src-exe/Seihou/CLI/NewBlueprint.hs b/src-exe/Seihou/CLI/NewBlueprint.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/NewBlueprint.hs @@ -0,0 +1,69 @@ +module Seihou.CLI.NewBlueprint + ( handleNewBlueprint, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (NewBlueprintOpts (..)) +import Seihou.CLI.SchemaVersion (schemaHash, schemaUrl) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Scaffold (blueprintDhall, examplePromptMarkdown) +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (logError) +import Seihou.Prelude +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.Exit (exitFailure) + +handleNewBlueprint :: NewBlueprintOpts -> IO () +handleNewBlueprint nopts = do + let name = nopts.newBlueprintName + + -- Validate blueprint name format + if not (isValidBlueprintName name) + then do + logIO LogNormal $ do + logError $ "invalid blueprint name '" <> name <> "'." + logError "Blueprint names must match [a-z][a-z0-9-]*." + exitFailure + else pure () + + -- Determine output directory + let outputDir = case nopts.newBlueprintPath of + Just p -> p + Nothing -> T.unpack name + + -- Refuse to overwrite an existing directory + exists <- doesDirectoryExist outputDir + if exists + then do + logIO LogNormal (logError $ "directory '" <> T.pack outputDir <> "' already exists.") + exitFailure + else pure () + + -- Create directory structure (output dir + empty files/ subdir) + createDirectoryIfMissing True (outputDir "files") + + -- Write blueprint.dhall + let dhallContent = blueprintDhall name schemaUrl schemaHash + writeFile (outputDir "blueprint.dhall") (T.unpack dhallContent) + TIO.putStrLn $ "Created " <> T.pack (outputDir "blueprint.dhall") + + -- Write prompt.md + writeFile (outputDir "prompt.md") (T.unpack examplePromptMarkdown) + TIO.putStrLn $ "Created " <> T.pack (outputDir "prompt.md") + + -- Announce the empty files/ subdir so the user knows it is intentional + TIO.putStrLn $ "Created " <> T.pack (outputDir "files/") + + TIO.putStrLn $ "Blueprint '" <> name <> "' created at " <> T.pack outputDir <> "/" + +-- | Check if a blueprint name matches [a-z][a-z0-9-]*. Mirrors +-- 'Seihou.CLI.NewModule.isValidModuleName' so the rule stays a single +-- source of truth across all three runnable kinds. +isValidBlueprintName :: Text -> Bool +isValidBlueprintName 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 diff --git a/src-exe/Seihou/CLI/NewModule.hs b/src-exe/Seihou/CLI/NewModule.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/NewModule.hs @@ -0,0 +1,65 @@ +module Seihou.CLI.NewModule + ( handleNewModule, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (NewModuleOpts (..)) +import Seihou.CLI.SchemaVersion (schemaHash, schemaUrl) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Scaffold (moduleDhall, readmeTemplate) +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (logError) +import Seihou.Prelude +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.Exit (exitFailure) + +handleNewModule :: NewModuleOpts -> IO () +handleNewModule nopts = do + let name = nopts.newModuleName + + -- Validate module name format + if not (isValidModuleName name) + then do + logIO LogNormal $ do + logError $ "invalid module name '" <> name <> "'." + logError "Module names must match [a-z][a-z0-9-]*." + exitFailure + else pure () + + -- Determine output directory + let outputDir = case nopts.newModulePath of + Just p -> p + Nothing -> T.unpack name + + -- Check that the target directory does not already exist + exists <- doesDirectoryExist outputDir + if exists + then do + logIO LogNormal (logError $ "directory '" <> T.pack outputDir <> "' already exists.") + exitFailure + else pure () + + -- Create directory structure + createDirectoryIfMissing True (outputDir "files") + + -- Write module.dhall + let dhallContent = moduleDhall name schemaUrl schemaHash + writeFile (outputDir "module.dhall") (T.unpack dhallContent) + TIO.putStrLn $ "Created " <> T.pack (outputDir "module.dhall") + + -- Write files/README.md.tpl + let templateContent = readmeTemplate + writeFile (outputDir "files" "README.md.tpl") (T.unpack templateContent) + TIO.putStrLn $ "Created " <> T.pack (outputDir "files" "README.md.tpl") + + TIO.putStrLn $ "Module '" <> name <> "' created at " <> T.pack outputDir <> "/" + +-- | Check if a module name matches [a-z][a-z0-9-]* +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 diff --git a/src-exe/Seihou/CLI/NewPrompt.hs b/src-exe/Seihou/CLI/NewPrompt.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/NewPrompt.hs @@ -0,0 +1,52 @@ +module Seihou.CLI.NewPrompt + ( handleNewPrompt, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (NewPromptOpts (..)) +import Seihou.CLI.SchemaVersion (schemaHash, schemaUrl) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Module (isValidModuleName) +import Seihou.Core.Scaffold (exampleAgentPromptMarkdown, promptDhall) +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (logError) +import Seihou.Prelude +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.Exit (exitFailure) + +handleNewPrompt :: NewPromptOpts -> IO () +handleNewPrompt nopts = do + let name = nopts.newPromptName + + if not (isValidModuleName name) + then do + logIO LogNormal $ do + logError $ "invalid prompt name '" <> name <> "'." + logError "Prompt names must match [a-z][a-z0-9-]*." + exitFailure + else pure () + + let outputDir = case nopts.newPromptPath of + Just p -> p + Nothing -> T.unpack name + + exists <- doesDirectoryExist outputDir + if exists + then do + logIO LogNormal (logError $ "directory '" <> T.pack outputDir <> "' already exists.") + exitFailure + else pure () + + createDirectoryIfMissing True (outputDir "files") + + let dhallContent = promptDhall name schemaUrl schemaHash + writeFile (outputDir "prompt.dhall") (T.unpack dhallContent) + TIO.putStrLn $ "Created " <> T.pack (outputDir "prompt.dhall") + + writeFile (outputDir "prompt.md") (T.unpack exampleAgentPromptMarkdown) + TIO.putStrLn $ "Created " <> T.pack (outputDir "prompt.md") + + TIO.putStrLn $ "Created " <> T.pack (outputDir "files/") + TIO.putStrLn $ "Prompt '" <> name <> "' created at " <> T.pack outputDir <> "/" diff --git a/src-exe/Seihou/CLI/NewRecipe.hs b/src-exe/Seihou/CLI/NewRecipe.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/NewRecipe.hs @@ -0,0 +1,85 @@ +module Seihou.CLI.NewRecipe + ( handleNewRecipe, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (NewRecipeOpts (..)) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (logError) +import Seihou.Prelude +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.Exit (exitFailure) + +handleNewRecipe :: NewRecipeOpts -> IO () +handleNewRecipe ropts = do + let name = ropts.newRecipeName + + -- Validate recipe name format + if not (isValidRecipeName name) + then do + logIO LogNormal $ do + logError $ "invalid recipe name '" <> name <> "'." + logError "Recipe names must match [a-z][a-z0-9-]*." + exitFailure + else pure () + + -- Determine output directory + let outputDir = case ropts.newRecipePath of + Just p -> p + Nothing -> T.unpack name + + -- Check that the target directory does not already exist + exists <- doesDirectoryExist outputDir + if exists + then do + logIO LogNormal (logError $ "directory '" <> T.pack outputDir <> "' already exists.") + exitFailure + else pure () + + -- Create directory + createDirectoryIfMissing True outputDir + + -- Write recipe.dhall + let dhallContent = recipeDhall name ropts.newRecipeModules + writeFile (outputDir "recipe.dhall") (T.unpack dhallContent) + TIO.putStrLn $ "Created " <> T.pack (outputDir "recipe.dhall") + + TIO.putStrLn $ "Recipe '" <> name <> "' created at " <> T.pack outputDir <> "/" + +-- | Check if a recipe name matches [a-z][a-z0-9-]* +isValidRecipeName :: Text -> Bool +isValidRecipeName 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 + +-- | Generate recipe.dhall content. +recipeDhall :: Text -> [Text] -> Text +recipeDhall name mods = + "{ name = \"" + <> name + <> "\"\n" + <> ", version = Some \"0.1.0\"\n" + <> ", description = Some \"\"\n" + <> ", modules =\n" + <> modulesSection mods + <> ", 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" + <> "}\n" + +modulesSection :: [Text] -> Text +modulesSection [] = + " [] : List { module : Text, vars : List { name : Text, value : Text } }\n" +modulesSection mods = + " [ " + <> T.intercalate "\n , " (map formatModEntry mods) + <> "\n ]\n" + where + formatModEntry m = + "{ module = \"" + <> m + <> "\", vars = [] : List { name : Text, value : Text } }" diff --git a/src-exe/Seihou/CLI/Outdated.hs b/src-exe/Seihou/CLI/Outdated.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Outdated.hs @@ -0,0 +1,218 @@ +module Seihou.CLI.Outdated + ( handleOutdated, + checkInstalledModulesForUpdates, + readOriginWithModule, + moduleNameFromDm, + checkSource, + ) +where + +import Control.Exception (SomeException, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (OutdatedOpts (..)) +import Seihou.CLI.InstallShared (OriginInfo (..)) +import Seihou.CLI.RemoteVersion (fetchTrueModuleVersion) +import Seihou.CLI.Style (dim, green, red, useColor, yellow) +import Seihou.CLI.VersionCompare + ( CheckStats (..), + OutdatedEntry (..), + OutdatedStatus (..), + compareVersions, + ) +import Seihou.Core.Install (parseModuleName) +import Seihou.Core.Module (DiscoveredModule (..), ModuleSource (..), defaultSearchPaths, discoverAllModules) +import Seihou.Core.Types (Module (..), ModuleName (..)) +import Seihou.Prelude +import System.Directory (doesFileExist) +import System.Exit (ExitCode (..)) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) + +handleOutdated :: OutdatedOpts -> IO () +handleOutdated oopts = do + searchPaths <- defaultSearchPaths + modules <- discoverAllModules searchPaths + let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules + + if null installed + then TIO.putStrLn "No installed modules found." + else do + (entries, _stats) <- checkInstalledModulesForUpdates installed + if null entries + then TIO.putStrLn "No installed modules with origin metadata found." + else + if oopts.outdatedJson + then LBS.putStr (encodePretty entries) + else renderTable entries + +-- | Check a list of already-discovered modules for updates. +-- +-- Filters to @SourceInstalled@ modules internally, reads @.seihou-origin.json@ +-- for each, groups by source URL, clones each source shallowly, and compares +-- installed versions against what the remote registry advertises. +-- +-- Prints progress lines to stdout via 'checkSource'. Returns the flat list +-- of outdated entries plus stats describing how many modules were actually +-- checked versus skipped for lack of origin metadata. +checkInstalledModulesForUpdates :: + [DiscoveredModule] -> + IO ([OutdatedEntry], CheckStats) +checkInstalledModulesForUpdates modules = do + let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules + originsWithModules <- mapM readOriginWithModule installed + let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules] + skipped = length installed - length withOrigins + if null withOrigins + then + pure + ( [], + CheckStats {checkedCount = 0, skippedNoOrigin = skipped} + ) + else do + let grouped = + Map.toList $ + Map.fromListWith + (++) + [(origin.sourceUrl, [(dm, origin)]) | (dm, origin) <- withOrigins] + TIO.putStrLn "Checking installed modules for updates..." + entries <- concat <$> mapM checkSource grouped + pure + ( entries, + CheckStats {checkedCount = length entries, skippedNoOrigin = skipped} + ) + +-- | Read origin info from a discovered module's directory. +readOriginWithModule :: DiscoveredModule -> IO (DiscoveredModule, Maybe OriginInfo) +readOriginWithModule dm = do + let originFile = dm.discoveredDir ".seihou-origin.json" + exists <- doesFileExist originFile + if exists + then do + bs <- LBS.readFile originFile + case Aeson.decode bs of + Just info -> pure (dm, Just info) + Nothing -> pure (dm, Nothing) + else pure (dm, Nothing) + +-- | Check a single source URL for updates. Clones the repo and compares versions. +-- +-- The comparison must happen inside 'withSystemTempDirectory' because +-- 'fetchTrueModuleVersion' reads @module.dhall@ off disk. If we returned +-- the clone path to the caller, the temp directory would already be gone +-- by the time the Dhall read ran, and every module would resolve to +-- @Nothing@ (appearing as \"unversioned\"). +checkSource :: (Text, [(DiscoveredModule, OriginInfo)]) -> IO [OutdatedEntry] +checkSource (sourceUrl, modulesWithOrigins) = do + let repoName = parseModuleName sourceUrl + TIO.putStrLn $ " Cloning " <> T.pack repoName <> "..." + + result <- try $ withSystemTempDirectory "seihou-outdated" $ \tmpDir -> do + let cloneDir = tmpDir repoName + (exitCode, _stdout, _stderr) <- readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack sourceUrl, cloneDir] "" + case exitCode of + ExitFailure _ -> pure Nothing + ExitSuccess -> + Just <$> mapM (compareModule cloneDir) modulesWithOrigins + + case result of + Left (_ :: SomeException) -> + pure [mkUnreachable dm origin | (dm, origin) <- modulesWithOrigins] + Right Nothing -> + pure [mkUnreachable dm origin | (dm, origin) <- modulesWithOrigins] + Right (Just entries) -> pure entries + +-- | Compare a single installed module against the remote contents. +compareModule :: FilePath -> (DiscoveredModule, OriginInfo) -> IO OutdatedEntry +compareModule cloneDir (dm, origin) = do + let name = moduleNameFromDm dm + installedVer = origin.version + availableVer <- fetchAvailable cloneDir (ModuleName name) + let status = compareVersions installedVer availableVer + pure + OutdatedEntry + { moduleName = name, + installedVersion = installedVer, + availableVersion = availableVer, + status = status + } + +-- | Look up the available version of a module in a cloned repo. Wraps +-- 'fetchTrueModuleVersion' so that fetch errors collapse to @Nothing@ for +-- the consumer-facing comparison; downstream renderers display this as +-- "unversioned". +fetchAvailable :: FilePath -> ModuleName -> IO (Maybe Text) +fetchAvailable cloneDir name = do + result <- fetchTrueModuleVersion cloneDir name + case result of + Right v -> pure v + Left _ -> pure Nothing + +-- | Compare installed and available version strings. +-- | Extract the module name text from a DiscoveredModule. +moduleNameFromDm :: DiscoveredModule -> Text +moduleNameFromDm dm = case dm.discoveredResult of + Right m -> m.name.unModuleName + Left _ -> dirName dm.discoveredDir + +-- | Extract the last path component as a name. +dirName :: FilePath -> Text +dirName path = case reverse (T.splitOn "/" (T.pack path)) of + (name : _) -> name + [] -> T.pack path + +-- | Create an unreachable entry for a module. +mkUnreachable :: DiscoveredModule -> OriginInfo -> OutdatedEntry +mkUnreachable dm origin = + OutdatedEntry + { moduleName = moduleNameFromDm dm, + installedVersion = origin.version, + availableVersion = Nothing, + status = Unreachable + } + +-- | Render the outdated report as a table. +renderTable :: [OutdatedEntry] -> IO () +renderTable entries = do + colorEnabled <- useColor + let maxNameLen = max 6 (maximum (map (T.length . (.moduleName)) entries)) + maxInstLen = max 9 (maximum (map (T.length . maybe "(none)" id . (.installedVersion)) entries)) + maxAvailLen = max 9 (maximum (map (T.length . maybe "(none)" id . (.availableVersion)) entries)) + + padR n t = t <> T.replicate (n - T.length t + 2) " " + + header = + padR maxNameLen "Module" + <> padR maxInstLen "Installed" + <> padR maxAvailLen "Available" + <> "Status" + + formatRow e = + let instText = maybe "(none)" id e.installedVersion + availText = maybe "(none)" id e.availableVersion + statusTxt = case e.status of + UpToDate -> if colorEnabled then green "up to date" else "up to date" + OutdatedSt -> if colorEnabled then red "outdated" else "outdated" + Unversioned -> if colorEnabled then dim "unversioned" else "unversioned" + Unreachable -> if colorEnabled then yellow "unreachable" else "unreachable" + in padR maxNameLen e.moduleName + <> padR maxInstLen instText + <> padR maxAvailLen availText + <> statusTxt + + TIO.putStrLn "" + TIO.putStrLn header + mapM_ (TIO.putStrLn . formatRow) entries + + let total = length entries + outdated = length (filter (\e -> e.status == OutdatedSt) entries) + TIO.putStrLn "" + TIO.putStrLn $ + T.pack (show total) + <> " module(s) checked, " + <> T.pack (show outdated) + <> " outdated." diff --git a/src-exe/Seihou/CLI/PromptRun.hs b/src-exe/Seihou/CLI/PromptRun.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/PromptRun.hs @@ -0,0 +1,189 @@ +module Seihou.CLI.PromptRun + ( handlePromptRun, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.CLI.AgentCompletion (AgentModelConfig) +import Seihou.CLI.AgentLaunch (gatherAgentContext, setupAllowedTools) +import Seihou.CLI.AgentRun (runRenderedAgentPrompt) +import Seihou.CLI.Commands (PromptRunOpts (..)) +import Seihou.CLI.PromptRender (renderPromptBody, renderPromptSystemPrompt) +import Seihou.CLI.Shared + ( deriveNamespace, + formatVarError, + logIO, + toVarNameMap, + unwrapConfig, + ) +import Seihou.Composition.Instance (primaryInstance) +import Seihou.Composition.Resolve (resolveWithPrompts) +import Seihou.Core.AgentPrompt (validateAgentPrompt) +import Seihou.Core.CommandVar (resolveCommandVars) +import Seihou.Core.Context (resolveContext) +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) +import Seihou.Core.Types +import Seihou.Effect.ConfigReader + ( readContextConfig, + readGlobalConfig, + readLocalConfig, + readNamespaceConfig, + ) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConsoleInterp (runConsole) +import Seihou.Effect.Logger (logError) +import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Prelude +import System.Environment (getEnvironment) +import System.Exit (exitFailure) + +handlePromptRun :: AgentModelConfig -> PromptRunOpts -> IO () +handlePromptRun modelConfig opts = do + let level = if opts.runPromptVerbose then LogVerbose else LogNormal + + searchPaths <- defaultSearchPaths + runnableResult <- discoverRunnable searchPaths opts.runPromptName + (prompt, promptDir) <- case runnableResult of + Right (RunnableAgentPrompt p dir) -> pure (p, dir) + Right (RunnableModule _ _) -> + exitErr level $ + "'" + <> opts.runPromptName.unModuleName + <> "' is a module, not a prompt. Did you mean 'seihou run " + <> opts.runPromptName.unModuleName + <> "'?" + Right (RunnableRecipe _ _) -> + exitErr level $ + "'" + <> opts.runPromptName.unModuleName + <> "' is a recipe, not a prompt. Did you mean 'seihou run " + <> opts.runPromptName.unModuleName + <> "'?" + Right (RunnableBlueprint _ _) -> + exitErr level $ + "'" + <> opts.runPromptName.unModuleName + <> "' is a blueprint, not a prompt. Did you mean 'seihou agent run " + <> opts.runPromptName.unModuleName + <> "'?" + Left err -> exitErr level (renderModuleLoadError err) + + validation <- validateAgentPrompt promptDir prompt + case validation of + Left err -> exitErr level (renderModuleLoadError err) + Right _ -> pure () + + let placeholderModule = + Module + { name = prompt.name, + version = prompt.version, + description = prompt.description, + vars = relaxCommandVarDecls prompt.commandVars prompt.vars, + exports = [], + prompts = prompt.prompts, + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + placeholderInst = primaryInstance prompt.name + placeholderTriple = (placeholderInst, placeholderModule, promptDir) + + envPairs <- getEnvironment + let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runPromptVars] + envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] + namespace = fromMaybe (deriveNamespace prompt.name) opts.runPromptNamespace + context <- resolveContext opts.runPromptContext envVars + let contextName = fromMaybe "" context + + resolveResult <- runEff $ runConfigReader $ runConsole $ do + localCfg <- readLocalConfig >>= unwrapConfig level + nsCfg <- readNamespaceConfig namespace >>= unwrapConfig level + ctxCfg <- readContextConfig contextName >>= unwrapConfig level + gCfg <- readGlobalConfig >>= unwrapConfig level + resolveWithPrompts + [placeholderTriple] + cliOverrides + envVars + namespace + contextName + (toVarNameMap localCfg) + (toVarNameMap nsCfg) + (toVarNameMap ctxCfg) + (toVarNameMap gCfg) + + resolvedNormal <- case resolveResult of + Left errs -> do + logIO level $ do + logError "Error resolving prompt variables:" + mapM_ (logError . (" " <>) . formatVarError) errs + exitFailure + Right r -> pure (Map.findWithDefault Map.empty placeholderInst r) + + commandResult <- runEff $ runProcessIO $ resolveCommandVars prompt.vars prompt.commandVars resolvedNormal + resolved <- case commandResult of + Left errs -> do + logIO level $ do + logError "Error resolving command variables:" + mapM_ (logError . (" " <>) . formatVarError) errs + exitFailure + Right r -> pure r + + let renderedPrompt = renderPromptBody resolved prompt.prompt + ctx <- gatherAgentContext + let systemPrompt = renderPromptSystemPrompt ctx prompt resolved renderedPrompt opts.runPromptPrompt + + _ <- + runRenderedAgentPrompt + opts.runPromptDebug + modelConfig + setupAllowedTools + Nothing + systemPrompt + opts.runPromptPrompt + pure () + +relaxCommandVarDecls :: [CommandVar] -> [VarDecl] -> [VarDecl] +relaxCommandVarDecls commandVars = + map relaxOne + where + commandNames = Set.fromList (map (.name) commandVars) + relaxOne decl + | Set.member decl.name commandNames = decl {required = False} + | otherwise = decl + +exitErr :: LogLevel -> Text -> IO a +exitErr level msg = do + logIO level (logError msg) + exitFailure + +renderModuleLoadError :: ModuleLoadError -> Text +renderModuleLoadError = \case + ModuleNotFound name searched -> + "Prompt '" + <> name.unModuleName + <> "' not found. Searched in:\n" + <> T.intercalate "\n" (map ((" " <>) . T.pack) searched) + DhallEvalError name msg -> + "Failed to evaluate '" <> name.unModuleName <> "': " <> msg + DhallDecodeError name msg -> + "Failed to decode '" <> name.unModuleName <> "': " <> msg + ValidationError name msgs -> + "Validation failed for '" + <> name.unModuleName + <> "':\n" + <> T.intercalate "\n" (map (" " <>) msgs) + CircularDependency names -> + "Circular dependency detected: " + <> T.intercalate " -> " (map (.unModuleName) names) + MissingSourceFile name path -> + "Missing source file in '" + <> name.unModuleName + <> "': " + <> T.pack path + RegistryEvalError path msg -> + "Failed to evaluate registry at '" <> path <> "': " <> msg diff --git a/src-exe/Seihou/CLI/Remove.hs b/src-exe/Seihou/CLI/Remove.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Remove.hs @@ -0,0 +1,194 @@ +module Seihou.CLI.Remove + ( handleRemove, + ) +where + +import Control.Monad (foldM, when) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Time.Clock (getCurrentTime) +import Seihou.CLI.Commands (RemoveOpts (..)) +import Seihou.CLI.Style (bold, dim, green, useColor, yellow) +import Seihou.Core.Types +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Engine.Remove +import Seihou.Prelude +import System.Exit (ExitCode (..), exitFailure, exitWith) +import System.IO (hFlush, hIsTerminalDevice, stdin, stdout) + +handleRemove :: RemoveOpts -> IO () +handleRemove opts = do + let manifestPath = ".seihou" "manifest.json" + modName = opts.removeModule + + -- Read the manifest + manifestResult <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest + manifest <- case manifestResult of + Left err -> do + TIO.putStrLn $ "Error reading manifest: " <> err + exitFailure + Right Nothing -> do + TIO.putStrLn "No Seihou manifest found. Nothing to remove." + exitFailure + Right (Just m) -> pure m + + -- Find the module's removal spec + let mApplied = findAppliedModule manifest modName + case mApplied of + Nothing -> do + TIO.putStrLn $ "Module '" <> modName.unModuleName <> "' is not applied in this project." + exitFailure + Just am -> case am.removal of + Nothing -> do + TIO.putStrLn $ + "Module '" + <> modName.unModuleName + <> "' has no removal spec. Add a 'removal' section to its module.dhall to make it removable." + exitFailure + Just removal -> do + -- Build removal plan from declared steps + planResult <- runEff $ runFilesystem $ buildRemovalOps manifest modName removal + plan <- case planResult of + Left (ModuleNotApplied name) -> do + TIO.putStrLn $ "Module '" <> name.unModuleName <> "' is not applied in this project." + exitFailure + Left (ModuleNotRemovable name) -> do + TIO.putStrLn $ + "Module '" + <> name.unModuleName + <> "' has no removal spec." + exitFailure + Left (RemovalUnsafePath label path reason) -> do + TIO.putStrLn $ + "Unsafe removal " + <> label + <> " '" + <> path + <> "': " + <> reason + exitFailure + Right p -> pure p + + colorEnabled <- useColor + + -- Display plan + TIO.putStrLn $ "Removal plan for " <> modName.unModuleName <> ":" + + if null plan.ops + then TIO.putStrLn " (no removal operations)" + else mapM_ (displayOp colorEnabled) plan.ops + + -- Dry run exits here + when opts.removeDryRun $ do + TIO.putStrLn "" + TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)" + exitWith ExitSuccess + + -- Collect conflict files for interactive resolution + let conflictFiles = [p | DeleteFileOp p RFConflict <- plan.ops] + + -- Resolve conflicts + keepSet <- + if null conflictFiles || opts.removeForce + then pure Set.empty + else do + isInteractive <- hIsTerminalDevice stdin + if not isInteractive + then do + TIO.putStrLn "Conflicted files found. Use --force to delete them non-interactively." + exitFailure + else resolveConflictsInteractively conflictFiles + + -- Prompt for confirmation (if there are any actionable ops) + let actionableOps = [() | op <- plan.ops, isActionable op] + when (not (null actionableOps)) $ do + TIO.putStr "\n Proceed? [y/N] " + hFlush stdout + response <- T.strip . T.pack <$> getLine + when (T.toLower response /= "y") $ + exitWith (ExitFailure 3) + + -- Execute removal + now <- getCurrentTime + updatedManifest <- runEff $ runFilesystem $ executeRemovalOps manifest plan keepSet now + + -- Write updated manifest + runEff $ runFilesystem $ runManifestStore manifestPath $ writeManifest updatedManifest + + -- Report + let deleted = length [() | DeleteFileOp _ s <- plan.ops, s /= RFGone, not (Set.member "" keepSet)] + stripped = length [() | StripSectionOp _ <- plan.ops] + commands = length [() | RemovalCommandOp _ _ <- plan.ops] + TIO.putStrLn $ + applyColor colorEnabled green "✓" + <> " Removed module " + <> applyColor colorEnabled bold modName.unModuleName + <> "." + <> formatCounts deleted stripped commands + +-- | Display a single removal operation. +displayOp :: Bool -> RemovalOp -> IO () +displayOp c (DeleteFileOp path RFSafe) = + TIO.putStrLn $ " " <> applyColor c green "Delete" <> " " <> T.pack path <> applyColor c dim " (unchanged)" +displayOp c (DeleteFileOp path RFConflict) = + TIO.putStrLn $ " " <> applyColor c yellow "Delete" <> " " <> T.pack path <> applyColor c yellow " (modified by user)" +displayOp c (DeleteFileOp path RFGone) = + TIO.putStrLn $ " " <> applyColor c dim "Skip" <> " " <> T.pack path <> applyColor c dim " (already deleted)" +displayOp c (StripSectionOp path) = + TIO.putStrLn $ " " <> applyColor c green "Strip" <> " " <> T.pack path <> applyColor c dim " (remove section)" +displayOp c (RewriteOp path _) = + TIO.putStrLn $ " " <> applyColor c green "Rewrite" <> " " <> T.pack path +displayOp c (RemovalCommandOp cmd _) = + TIO.putStrLn $ " " <> applyColor c green "Run" <> " " <> cmd + +-- | Check if a removal op does something (not just skip). +isActionable :: RemovalOp -> Bool +isActionable (DeleteFileOp _ RFGone) = False +isActionable _ = True + +-- | Format a summary of counts. +formatCounts :: Int -> Int -> Int -> Text +formatCounts 0 0 0 = "" +formatCounts d s c = + " " + <> T.intercalate + ", " + ( filter + (not . T.null) + [ if d > 0 then T.pack (show d) <> " file" <> plural d <> " deleted" else "", + if s > 0 then T.pack (show s) <> " section" <> plural s <> " stripped" else "", + if c > 0 then T.pack (show c) <> " command" <> plural c <> " run" else "" + ] + ) + <> "." + where + plural n = if n /= 1 then "s" else "" + +-- | Find an applied module by name in the manifest. +findAppliedModule :: Manifest -> ModuleName -> Maybe AppliedModule +findAppliedModule manifest modName = + case filter (\am -> am.name == modName) manifest.modules of + (am : _) -> Just am + [] -> Nothing + +-- | Ask the user about each conflicted file interactively. +resolveConflictsInteractively :: [FilePath] -> IO (Set.Set FilePath) +resolveConflictsInteractively paths = do + TIO.putStrLn "\nThe following files have been modified since generation:" + foldM askOne Set.empty paths + where + askOne keepSet path = do + TIO.putStr $ " " <> T.pack path <> " — keep or delete? [k/d] " + hFlush stdout + response <- T.strip . T.toLower . T.pack <$> getLine + if response == "k" || response == "keep" + then pure (Set.insert path keepSet) + else pure keepSet + +-- | Apply a color function if colors are enabled. +applyColor :: Bool -> (Text -> Text) -> Text -> Text +applyColor True f t = f t +applyColor False _ t = t diff --git a/src-exe/Seihou/CLI/Run.hs b/src-exe/Seihou/CLI/Run.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Run.hs @@ -0,0 +1,633 @@ +module Seihou.CLI.Run + ( handleRun, + ) +where + +import Control.Monad (foldM, unless, when) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Time (UTCTime) +import Data.Time.Clock (getCurrentTime) +import Seihou.CLI.Commands (RunOpts (..)) +import Seihou.CLI.CommitMessage (generateCommitMessage) +import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) +import Seihou.CLI.Migrate + ( MigrateError (..), + MigrateOpts (..), + MigrateResult (..), + runMigrate, + ) +import Seihou.CLI.PendingMigrations + ( detectPendingMigrations, + formatRefusalMessage, + ) +import Seihou.CLI.SavePrompted (collectPromptedValues, offerSavePrompted) +import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, toVarNameMap, unwrapConfig) +import Seihou.CLI.Style (bold, dim, formatPlanViewColor, green, magenta, red, useColor, yellow) +import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) +import Seihou.Composition.Plan (compileComposedPlan) +import Seihou.Composition.Recipe (expandRecipe) +import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) +import Seihou.Core.Context (resolveContext) +import Seihou.Core.Migration (MigrationPlan (..)) +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) +import Seihou.Core.Types +import Seihou.Core.Variable (diagnoseResolution) +import Seihou.Core.Version (renderVersion) +import Seihou.Effect.ConfigReader (readContextConfig, readGlobalConfig, readLocalConfig, readNamespaceConfig) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConfigWriterInterp (runConfigWriter) +import Seihou.Effect.ConsoleInterp (runConsole) +import Seihou.Effect.Filesystem (createDirectoryIfMissing) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.FzfInterp (runFzfIO) +import Seihou.Effect.Logger (logDebug, logError, logInfo, logWarn) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Effect.Process (runProcess) +import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Engine.Conflict (resolveConflicts) +import Seihou.Engine.Diff (computeDiff) +import Seihou.Engine.Execute (executePlan) +import Seihou.Engine.Preview (buildPreview) +import Seihou.Fzf (FzfResult (..), detectFzfConfig, isFzfUsable) +import Seihou.Fzf.Selector (selectModule) +import Seihou.Interaction.Confirm (confirmDefaults) +import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) +import Seihou.Prelude +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..), exitFailure, exitWith) +import System.FilePath (takeDirectory) +import System.IO (hFlush, hIsTerminalDevice, stdin, stdout) + +handleRun :: RunOpts -> IO () +handleRun runOpts = do + let additional = runOpts.runAdditional + level = if runOpts.runVerbose then LogVerbose else LogNormal + + -- 0. Resolve module name (from argument or fzf picker) + modName <- case runOpts.runModule of + Just name -> pure name + Nothing -> do + fzfCfg <- detectFzfConfig + if isFzfUsable fzfCfg + then do + result <- runEff $ runFzfIO fzfCfg $ selectModule + case result of + FzfSelected name -> pure name + FzfCancelled -> exitWith ExitSuccess + FzfNoMatch -> do + logIO level (logError "No modules found.") + exitFailure + FzfError err -> do + logIO level (logError $ "fzf error: " <> err) + exitFailure + else do + logIO level (logError "MODULE argument is required when fzf is not available.") + exitFailure + + -- 0b. Recipe detection: check if the name resolves to a recipe or a module + searchPaths <- defaultSearchPaths + (primaryName, allAdditional, recipeOverrides, recipeInfo) <- do + runnableResult <- discoverRunnable searchPaths modName + case runnableResult of + Right (RunnableRecipe recipe _recipeDir) -> do + case expandRecipe recipe of + Left errs -> do + logIO level $ + logError $ + "Invalid recipe '" + <> recipe.name.unRecipeName + <> "': " + <> T.intercalate "; " errs + exitFailure + Right (primary, recipeAdditional, overrides, _recipeVars, _recipePrompts) -> do + logIO level $ + logInfo $ + "Recipe '" <> recipe.name.unRecipeName <> "' expanding to " <> T.pack (show (length recipe.modules)) <> " modules" + pure (primary, recipeAdditional ++ additional, overrides, Just (recipe.name, recipe.version)) + Right (RunnableModule _ _) -> + pure (modName, additional, Map.empty, Nothing) + Right (RunnableBlueprint _b _blueprintDir) -> do + -- Use the user-typed name (modName) rather than the blueprint's + -- declared name. Discovery resolves by directory name; the + -- suggested 'seihou agent run NAME' must match what the user + -- can re-type to find the same artifact. + logIO level $ logError (formatBlueprintRefusal modName) + exitFailure + Left _ -> + -- Discovery failed — let loadComposition handle the error with its detailed message + pure (modName, additional, Map.empty, Nothing) + + -- 1. Load all modules in the composition (primary + additional + transitive deps) + compositionResult <- loadComposition searchPaths primaryName allAdditional + modulesInOrder <- case compositionResult of + Left (ModuleNotFound name searched) -> do + logIO level $ do + logError $ "Module '" <> name.unModuleName <> "' not found." + logError "Searched in:" + mapM_ (\p -> logError $ " " <> T.pack p) searched + exitFailure + Left (CircularDependency names) -> do + logIO level $ do + logError "Circular dependency detected:" + logError $ " " <> T.intercalate " -> " (map (.unModuleName) names) + exitFailure + Left err -> exitError level (T.pack (show err)) + Right ms -> pure ms + + -- Report composition when multiple modules are involved + when (length modulesInOrder > 1) $ + logIO level $ do + logInfo $ "Composing " <> T.pack (show (length modulesInOrder)) <> " modules:" + mapM_ (\(_, m, _) -> logInfo $ " " <> m.name.unModuleName) modulesInOrder + + -- 2. Resolve variables with export visibility and interactive prompts + envPairs <- getEnvironment + -- Merge recipe overrides with CLI overrides (CLI wins on conflict) + let cliOverrides = Map.union (Map.fromList [(VarName k, v) | (k, v) <- runOpts.runVars]) recipeOverrides + envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] + namespace = fromMaybe (deriveNamespace primaryName) runOpts.runNamespace + context <- resolveContext runOpts.runContext envVars + let contextName = fromMaybe "" context + (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do + localCfg <- readLocalConfig >>= unwrapConfig level + namespaceCfg <- readNamespaceConfig namespace >>= unwrapConfig level + contextCfg <- readContextConfig contextName >>= unwrapConfig level + globalCfg <- readGlobalConfig >>= unwrapConfig level + let lm = toVarNameMap localCfg + nm = toVarNameMap namespaceCfg + cm = toVarNameMap contextCfg + gm = toVarNameMap globalCfg + r <- resolveWithPrompts modulesInOrder cliOverrides envVars namespace contextName lm nm cm gm + pure (r, lm, nm, cm, gm) + resolvedInitial <- case resolveResult of + Left errs -> do + logIO level $ do + logError "Error resolving variables:" + mapM_ (logError . (" " <>) . formatVarError) errs + exitFailure + Right r -> pure r + + -- 2a. Optionally confirm default-sourced values. + resolved <- + if runOpts.runConfirmDefaults + then runEff $ runConsole $ confirmDefaults modulesInOrder resolvedInitial + else pure resolvedInitial + + -- 2b. Emit diagnostics for unused config keys + let allDecls = concatMap (\(_, m, _) -> m.vars) modulesInOrder + allResolved = Map.unions [vs | vs <- Map.elems resolved] + (unusedKeys, _) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap + when (not (null unusedKeys)) $ + logIO level $ + logWarn $ + "Config keys not matching any declared variable: " + <> T.intercalate ", " (map (.unVarName) unusedKeys) + + -- 3. Compile composed plan (all modules merged) + let quads = + [ (inst, m, dir, Map.map (.value) (resolved Map.! inst)) + | (inst, m, dir) <- modulesInOrder + ] + planResult <- compileComposedPlan quads + (ops, warnings, ownerMap) <- case planResult of + Left errs -> do + logIO level $ do + logError "Errors compiling plan:" + mapM_ (logError . (" " <>)) errs + exitFailure + Right r -> pure r + + -- 4. Filter out command ops if --no-commands + let opsFiltered = + if runOpts.runNoCommands + then filter (not . isCommandOp) ops + else ops + + -- 5. Print composition warnings + mapM_ (printWarning level) warnings + + -- 6. Compute diff (shared by dry-run, --diff, and execution paths) + now <- getCurrentTime + let manifestPath = ".seihou" "manifest.json" + planned = + [(dest, content, modName, Nothing) | WriteFileOp dest content _ <- opsFiltered] + ++ [(dest, content, mName, Just pOp) | PatchFileOp dest content pOp _ mName <- opsFiltered] + + -- 6a. Read the manifest before computing the diff so the pre-flight + -- migration check can run against it (and, with --with-migrations, so + -- 'runMigrate' can rewrite it before the diff is taken). + existingRes <- runEff $ runFilesystem $ runManifestStore manifestPath $ do + createDirectoryIfMissing True (takeDirectory manifestPath) + readManifest + initialManifest <- case existingRes of + Left err -> do + logIO level (logError $ "Error reading manifest: " <> err) + exitFailure + Right m -> pure (fromMaybe (emptyManifest now) m) + + -- 6b. Pre-flight pending-migration check. We only consider modules in + -- the current composition: a pending chain on an unrelated module + -- must not block this run. + let composedModuleNames = + Set.fromList [m.name | (_, m, _) <- modulesInOrder] + pendings <- + detectPendingMigrations initialManifest (Just composedModuleNames) + manifest <- + handlePendingMigrations level runOpts manifestPath initialManifest pendings + + -- 6c. Compute the diff against the (possibly post-migration) manifest. + diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do + -- Diff needs every name that could own a manifest file. Each + -- instance owns its qualified name; the bare module name is still + -- matched to cover manifest entries written before the schema bump. + let composedNames = + Set.fromList $ + concatMap (\(inst, _, _) -> [inst.instanceModule, qualifiedName inst]) modulesInOrder + computeDiff manifest composedNames planned + + colorEnabled <- useColor + + let modNames = map (\(_, m, _) -> m.name) modulesInOrder + allVarValues = + Map.unions + [Map.map (.value) vs | vs <- Map.elems resolved] + preview = buildPreview opsFiltered (Just diff) ownerMap + + -- 6. Handle --dry-run: show plan view and exit + if runOpts.runDryRun + then + TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff) + else + if runOpts.runDiff + then TIO.putStr (formatDiff colorEnabled diff ownerMap) + else do + -- Show plan view + TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff) + + -- Prompt for confirmation (skip if --force or non-interactive) + interactive <- hIsTerminalDevice stdin + when (interactive && not runOpts.runForce) $ do + TIO.putStr "\n Proceed? [Y/n] " + hFlush stdout + response <- T.strip . T.pack <$> getLine + when (response /= "" && T.toLower response /= "y") $ + exitWith (ExitFailure 3) + + -- Resolve conflicts interactively (or abort) + resolutions <- + runEff $ + runConsole $ + resolveConflicts runOpts.runForce diff.conflicts + case resolutions of + Nothing -> do + TIO.putStrLn "Conflicts detected (use --force to overwrite):" + mapM_ (\c -> TIO.putStrLn $ " ! " <> T.pack c.path) diff.conflicts + exitFailure + Just conflictResolved -> do + -- Partition resolutions: accept (overwrite), keep (update manifest only), skip (ignore) + let keepRecords = + Map.fromList + [ ( c.path, + case Map.lookup c.path manifest.files of + Just existing -> + existing {hash = c.diskHash, generatedAt = now} + Nothing -> + FileRecord + { hash = c.diskHash, + moduleName = c.moduleName, + strategy = Template, + generatedAt = now + } + ) + | (c, KeepCurrent) <- conflictResolved + ] + skipPaths = [c.path | (c, Skip) <- conflictResolved] + excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths) + opsForExec = filter (not . opTargetsPath excludePaths) opsFiltered + + -- Execute the plan (excluding kept/skipped files) + runEff $ runFilesystem $ runManifestStore manifestPath $ do + recs <- executePlan "" opsForExec ownerMap modName now + + -- Build updated manifest with all composed modules + let orphanedPaths = map (.path) diff.orphaned + cleanedFiles = foldr Map.delete manifest.files orphanedPaths + allModuleEntries = updateAllModules manifest.modules modulesInOrder now + allResolvedVals = + Map.unions + [Map.map (.value) vs | vs <- Map.elems resolved] + appliedRecipe = case recipeInfo of + Just (rName, rVersion) -> + Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now} + Nothing -> manifest.recipe + newManifest = + Manifest + { version = currentManifestVersion, + genAt = now, + modules = allModuleEntries, + vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars, + files = Map.unions [recs, keepRecords, cleanedFiles], + recipe = appliedRecipe, + blueprint = manifest.blueprint + } + + -- Save manifest + writeManifest newManifest + + -- Report results + let nNew = length diff.new + nMod = length diff.modified + nUnch = length diff.unchanged + TIO.putStrLn $ + T.pack (show nNew) + <> " new, " + <> T.pack (show nMod) + <> " modified, " + <> T.pack (show nUnch) + <> " unchanged." + + -- Commit generated files if --commit or --commit-message + when (runOpts.runCommit || isJust runOpts.runCommitMessage) $ do + let filesToStage = + map (.path) diff.new + ++ map (.path) diff.modified + ++ [manifestPath] + inGit <- runEff $ runProcessIO $ isGitRepo + if inGit + then do + ignored <- runEff $ runProcessIO $ gitCheckIgnore filesToStage + let filteredFiles = filter (`notElem` ignored) filesToStage + if null filteredFiles + then logIO level (logDebug "--commit: all generated files are git-ignored, skipping commit.") + else do + (addExit, _, addErr) <- runEff $ runProcessIO $ gitAdd filteredFiles + case addExit of + ExitFailure _ -> logIO level (logWarn $ "git add failed: " <> addErr) + ExitSuccess -> do + commitMsg <- case runOpts.runCommitMessage of + Just msg -> pure msg + Nothing -> do + diffText <- runEff $ runProcessIO $ gitDiffCached + generateCommitMessage modNames diffText + (commitExit, _, commitErr) <- runEff $ runProcessIO $ gitCommit commitMsg + case commitExit of + ExitSuccess -> logIO level (logInfo "Committed generated files to git.") + ExitFailure _ -> logIO level (logWarn $ "git commit failed: " <> commitErr) + else + logIO level (logDebug "--commit: not inside a git repository, skipping.") + + -- Execute commands after file generation + let commandOps = [(cmd, wd) | RunCommandOp cmd wd <- opsForExec] + mapM_ (executeCommand level) commandOps + + -- Offer to save prompted values to local config + let prompted = collectPromptedValues resolved localMap + when (not (null prompted)) $ + runEff $ + runConfigWriter $ + runConsole $ + offerSavePrompted runOpts.runSavePrompted interactive prompted + +-- Helpers + +exitError :: LogLevel -> Text -> IO a +exitError level msg = do + logIO level (logError $ "Error: " <> msg) + exitFailure + +printWarning :: LogLevel -> CompositionWarning -> IO () +printWarning level (FileOverwritten path overwritten overwriter) = + logIO level . logWarn $ + "Warning: " + <> T.pack path + <> " (from " + <> overwritten.unModuleName + <> ") overwritten by " + <> overwriter.unModuleName +printWarning level (ContentMerged path base contributor) = + logIO level . logWarn $ + "Merged: " + <> T.pack path + <> " (base from " + <> base.unModuleName + <> ", patched by " + <> contributor.unModuleName + <> ")" + +formatDiff :: Bool -> DiffResult -> Map.Map FilePath ModuleName -> Text +formatDiff color diff ownerMap' = + T.unlines $ + concat + [ if null diff.new + then [] + else "New files:" : map (\f -> " " <> colorWrap green "[new]" <> " " <> colorWrap green (T.pack f.path) <> modSuffix f.path) diff.new, + if null diff.modified + then [] + else "Modified files:" : map (\f -> " " <> colorWrap yellow "[modified]" <> " " <> colorWrap yellow (T.pack f.path) <> modSuffix f.path) diff.modified, + if null diff.unchanged + then [] + else "Unchanged files:" : map (\f -> " " <> colorWrap dim "[unchanged]" <> " " <> colorWrap dim (T.pack f)) diff.unchanged, + if null diff.conflicts + then [] + else "Conflicts:" : map (\f -> " " <> colorWrap (bold . red) "[conflict]" <> " " <> colorWrap (bold . red) (T.pack f.path) <> modSuffix f.path) diff.conflicts, + if null diff.orphaned + then [] + else "Orphaned files:" : map (\f -> " " <> colorWrap magenta "[orphaned]" <> " " <> colorWrap magenta (T.pack f.path)) diff.orphaned + ] + where + colorWrap fn t = if color then fn t else t + modSuffix path = case Map.lookup path ownerMap' of + Just mn -> " " <> colorWrap dim ("(" <> mn.unModuleName <> ")") + Nothing -> "" + +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) + +-- | Whether an operation is a command (RunCommandOp). +isCommandOp :: Operation -> Bool +isCommandOp (RunCommandOp _ _) = True +isCommandOp _ = False + +-- | Check whether an operation targets a file in the given path set. +opTargetsPath :: Set.Set FilePath -> Operation -> Bool +opTargetsPath paths (WriteFileOp dest _ _) = Set.member dest paths +opTargetsPath paths (PatchFileOp dest _ _ _ _) = Set.member dest paths +opTargetsPath _ _ = False + +-- | Execute a shell command via @sh -c@, printing output and halting on failure. +executeCommand :: LogLevel -> (Text, Maybe FilePath) -> IO () +executeCommand level (cmd, workDir) = do + logIO level (logDebug $ " run " <> cmd) + (exitCode, cmdOut, cmdErr) <- runEff $ runProcessIO $ runProcess "sh" ["-c", cmd] workDir + when (not (T.null cmdOut)) $ TIO.putStr cmdOut + case exitCode of + ExitSuccess -> pure () + ExitFailure code -> do + when (not (T.null cmdErr)) $ TIO.putStr cmdErr + logIO level (logError $ "Command failed (exit " <> T.pack (show code) <> "): " <> cmd) + exitFailure + +-- | Apply the pending-migration policy. +-- +-- Without @--with-migrations@: the run refuses and prints a one-line +-- summary per pending module. +-- With @--with-migrations@ in dry-run mode: print the same summary +-- and proceed with the diff against the current (pre-migration) disk +-- state. +-- With @--with-migrations@ in apply mode: run @seihou migrate@ for +-- each pending module before computing the run plan, persist the new +-- manifest, and continue. +-- +-- Returns the manifest the run flow should continue with. +handlePendingMigrations :: + LogLevel -> + RunOpts -> + FilePath -> + Manifest -> + [(ModuleName, MigrationPlan)] -> + IO Manifest +handlePendingMigrations _ _ _ manifest [] = pure manifest +handlePendingMigrations level runOpts manifestPath manifest pendings + | not runOpts.runWithMigrations = do + TIO.putStr (formatRefusalMessage pendings) + exitFailure + | runOpts.runDryRun = do + TIO.putStrLn "Pending migrations detected (--with-migrations + --dry-run):" + mapM_ (TIO.putStrLn . renderPendingSummary) pendings + TIO.putStrLn "" + TIO.putStrLn "Note: the run plan below is computed against the current (pre-migration)" + TIO.putStrLn "disk state. Re-run without --dry-run to apply migrations and regenerate." + pure manifest + | otherwise = do + logIO level (logInfo "Applying pending migrations before run plan...") + manifest' <- foldM (applyOneMigration level) manifest pendings + runEff $ + runFilesystem $ + runManifestStore manifestPath $ + writeManifest manifest' + pure manifest' + +renderPendingSummary :: (ModuleName, MigrationPlan) -> Text +renderPendingSummary (name, plan) = + " " + <> name.unModuleName + <> ": " + <> renderVersion plan.planFrom + <> " -> " + <> renderVersion plan.planTo + <> " (" + <> T.pack (show (length plan.planSteps)) + <> " step(s))" + +-- | Apply one pending plan in-band. Reuses 'runMigrate' with +-- @migrateNoFetch=True@ since 'detectPendingMigrations' already +-- compared against the locally installed copy: there is no need to +-- clone the source repo a second time. Migration conflicts (a tracked +-- file the user has edited since generation) propagate as a hard +-- failure here; @seihou run --force@ governs the run plan's diff +-- conflicts, not migration conflicts. The fix is to run @seihou +-- migrate --force@ first. +applyOneMigration :: + LogLevel -> + Manifest -> + (ModuleName, MigrationPlan) -> + IO Manifest +applyOneMigration level manifest (modName, _) = + case findAppliedByName manifest modName of + Nothing -> do + logIO level $ + logError $ + "internal error: applied module '" + <> modName.unModuleName + <> "' missing while applying its migration" + exitFailure + Just am -> do + let opts = + MigrateOpts + { migrateModule = modName, + migrateTo = Nothing, + migrateDryRun = False, + migrateForce = False, + migrateJson = False, + migrateVerbose = False, + migrateNoFetch = True, + migrateCommit = False, + migrateCommitMessage = Nothing + } + result <- runMigrate opts manifest am.source + case result of + Right (MigrateApplied _ manifest' _ _) -> do + TIO.putStrLn $ " Migrated " <> modName.unModuleName + pure manifest' + Right (MigrateNoOp _) -> pure manifest + Right (MigrateDryRunOK {}) -> pure manifest + Left err -> do + logIO level $ + logError $ + "Migration failed for " + <> modName.unModuleName + <> ": " + <> renderMigrateError err + exitFailure + +renderMigrateError :: MigrateError -> Text +renderMigrateError err = case err of + MigrateModuleNotApplied n -> "module " <> n.unModuleName <> " not applied" + MigrateNoRecordedVersion n -> "no version recorded for " <> n.unModuleName + MigrateInstalledModuleEvalFailed _ msg -> msg + MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> n.unModuleName + MigrateUnparseableInstalledVersion v -> "bad version " <> v + MigrateUnparseableTargetVersion v -> "bad target version " <> v + MigrateUnparseableManifestVersion v -> "bad manifest version " <> v + MigratePlanFailed _ -> "plan failed" + MigrateExecFailed _ -> "execution failed; revert your edits or run 'seihou migrate --force' first" + MigrateNoManifest _ -> "no manifest in current dir" + +findAppliedByName :: Manifest -> ModuleName -> Maybe AppliedModule +findAppliedByName manifest name = + case filter (\am -> am.name == name) manifest.modules of + (am : _) -> Just am + [] -> Nothing + +-- | Update manifest's applied modules list with all composed modules. +-- | Merge the freshly-composed module instances into the manifest's +-- applied-modules list. +-- +-- Each entry keeps its bare 'ModuleName' plus the edge decoration that +-- produced it, so two instances of the same module with different +-- 'ParentVars' coexist in the manifest. Matching against existing +-- entries uses the @(name, parentVars)@ pair, so regenerating only +-- refreshes the matching instance and leaves siblings unchanged. +updateAllModules :: + [AppliedModule] -> + [(ModuleInstance, Module, FilePath)] -> + UTCTime -> + [AppliedModule] +updateAllModules existing modulesInOrder now = + let composedKeys = + Set.fromList + [ (inst.instanceModule, inst.instanceParentVars) + | (inst, _, _) <- modulesInOrder + ] + filtered = filter (\am -> not (Set.member (am.name, am.parentVars) composedKeys)) existing + new = + [ AppliedModule + { name = inst.instanceModule, + parentVars = inst.instanceParentVars, + source = dir, + moduleVersion = m.version, + appliedAt = now, + removal = m.removal + } + | (inst, m, dir) <- modulesInOrder + ] + in filtered ++ new diff --git a/src-exe/Seihou/CLI/SchemaUpgrade.hs b/src-exe/Seihou/CLI/SchemaUpgrade.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/SchemaUpgrade.hs @@ -0,0 +1,93 @@ +module Seihou.CLI.SchemaUpgrade + ( handleSchemaUpgrade, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (SchemaUpgradeOpts (..)) +import Seihou.CLI.SchemaVersion (schemaHash, schemaUrl) +import Seihou.CLI.Style (dim, green, yellow) +import Seihou.Core.Module (DiscoveredModule (..), defaultSearchPaths, discoverAllModules) +import Seihou.Core.SchemaUpgrade +import Seihou.Prelude +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Exit (exitFailure) + +handleSchemaUpgrade :: SchemaUpgradeOpts -> IO () +handleSchemaUpgrade opts + | opts.schemaUpgradeAll = do + searchPaths <- defaultSearchPaths + modules <- discoverAllModules searchPaths + let paths = [dir "module.dhall" | DiscoveredModule {discoveredDir = dir} <- modules] + results <- mapM (processModule opts.schemaUpgradeDryRun) paths + printSummary results + | otherwise = do + moduleDir <- case opts.schemaUpgradePath of + Just p -> pure p + Nothing -> getCurrentDirectory + let dhallFile = moduleDir "module.dhall" + exists <- doesFileExist dhallFile + if not exists + then do + TIO.putStrLn $ "Error: " <> T.pack dhallFile <> " not found." + exitFailure + else do + results <- sequence [processModule opts.schemaUpgradeDryRun dhallFile] + printSummary results + +data ProcessResult + = UpToDate FilePath + | Fixed FilePath [UpgradeIssue] + | WouldFix FilePath [UpgradeIssue] + | ProcessError FilePath Text + +processModule :: Bool -> FilePath -> IO ProcessResult +processModule dryRun path = do + exists <- doesFileExist path + if not exists + then pure (ProcessError path "file not found") + else do + content <- TIO.readFile path + case upgradeModuleText schemaUrl schemaHash content of + AlreadyCurrent -> pure (UpToDate path) + Upgraded newContent issues + | dryRun -> do + printDryRun path issues + pure (WouldFix path issues) + | otherwise -> do + TIO.writeFile path newContent + printFixed path issues + pure (Fixed path issues) + +printDryRun :: FilePath -> [UpgradeIssue] -> IO () +printDryRun path issues = do + TIO.putStrLn $ yellow "[dry run] " <> T.pack path + mapM_ (\i -> TIO.putStrLn $ " Would fix: " <> issueMessage i) issues + +printFixed :: FilePath -> [UpgradeIssue] -> IO () +printFixed path issues = do + let count = length issues + label = if count == 1 then " issue" else " issues" + TIO.putStrLn $ green " ✓ " <> T.pack path <> " — " <> T.pack (show count) <> label <> " fixed" + mapM_ (\i -> TIO.putStrLn $ " + " <> issueMessage i) issues + +printSummary :: [ProcessResult] -> IO () +printSummary results = do + let total = length results + fixed = length [() | Fixed {} <- results] + wouldFix = length [() | WouldFix {} <- results] + upToDate = length [() | UpToDate {} <- results] + errors = length [() | ProcessError {} <- results] + TIO.putStrLn "" + if fixed > 0 + then TIO.putStrLn $ green (T.pack (show fixed) <> " upgraded") <> dim (", " <> T.pack (show upToDate) <> " already current, " <> T.pack (show total) <> " total") + else + if wouldFix > 0 + then TIO.putStrLn $ yellow (T.pack (show wouldFix) <> " would be upgraded") <> dim (", " <> T.pack (show upToDate) <> " already current, " <> T.pack (show total) <> " total") + else TIO.putStrLn $ green "All modules up to date." <> dim (" (" <> T.pack (show total) <> " checked)") + if errors > 0 + then do + TIO.putStrLn $ T.pack (show errors) <> " errors:" + mapM_ (\case ProcessError p msg -> TIO.putStrLn $ " " <> T.pack p <> ": " <> msg; _ -> pure ()) results + else pure () diff --git a/src-exe/Seihou/CLI/Setup.hs b/src-exe/Seihou/CLI/Setup.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Setup.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.Setup + ( handleSetup, + ) +where + +import Data.FileEmbed (embedFile) +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Seihou.CLI.AgentCompletion + ( AgentModelConfig (..), + AgentProvider (..), + buildAgentCompletionRequest, + runAgentCompletion, + ) +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + formatAvailableModules, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatSeihouProjectState, + gatherAgentContext, + setupAllowedTools, + substitute, + ) +import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent) +import Seihou.CLI.Commands (SetupOpts (..)) +import Seihou.Prelude +import System.Exit (exitFailure, exitWith) + +-- | The prompt template, embedded at compile time from data/setup-prompt.md. +promptTemplate :: Text +promptTemplate = TE.decodeUtf8 $(embedFile "data/setup-prompt.md") + +handleSetup :: Bool -> AgentModelConfig -> SetupOpts -> IO () +handleSetup debug modelConfig setupOpts = do + ctx <- gatherAgentContext + let systemPrompt = renderPrompt ctx + runRenderedAgentPrompt debug modelConfig systemPrompt setupOpts.setupPrompt + +renderPrompt :: AgentContext -> Text +renderPrompt ctx = + substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx) + ] + promptTemplate + +runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () +runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt + | debug = TIO.putStr systemPrompt + | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do + exitCode <- launchConfiguredAgent modelConfig setupAllowedTools debug systemPrompt initialPrompt + exitWith exitCode + | otherwise = do + result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt) + case result of + Right assistantText -> TIO.putStrLn assistantText + Left err -> do + TIO.putStrLn $ "Error: " <> err + exitFailure diff --git a/src-exe/Seihou/CLI/Status.hs b/src-exe/Seihou/CLI/Status.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Status.hs @@ -0,0 +1,68 @@ +module Seihou.CLI.Status + ( handleStatus, + ) +where + +import Control.Exception (SomeException, try) +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (StatusOpts (..)) +import Seihou.CLI.Outdated (checkInstalledModulesForUpdates) +import Seihou.CLI.PendingMigrations (detectPendingMigrations) +import Seihou.CLI.Shared (logIO) +import Seihou.CLI.StatusRender (formatStatus) +import Seihou.CLI.Style (useColor) +import Seihou.CLI.VersionCompare (OutdatedEntry (..)) +import Seihou.Core.Module (defaultSearchPaths, discoverAllModules) +import Seihou.Core.Status (computeTrackedFileStatuses) +import Seihou.Core.Types +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Logger (logError) +import Seihou.Effect.ManifestStore (readManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Prelude +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +handleStatus :: StatusOpts -> IO () +handleStatus opts = do + let manifestPath = ".seihou" "manifest.json" + + -- Run both manifest read and file status computation in the same effect block. + result <- runEff $ runFilesystem $ runManifestStore manifestPath $ do + mResult <- readManifest + case mResult of + Left err -> pure (Left err) + Right Nothing -> pure (Right Nothing) + Right (Just manifest) -> do + tracked <- computeTrackedFileStatuses manifest + pure (Right (Just (manifest, tracked))) + + colorEnabled <- useColor + + case result of + Left err -> do + logIO LogNormal (logError $ "Error reading manifest: " <> err) + exitFailure + Right Nothing -> + TIO.putStrLn "No Seihou manifest found. Run 'seihou run ' to generate a project." + Right (Just (manifest, tracked)) -> do + mEntries <- + if opts.statusCheckUpdates && not (null manifest.modules) + then fetchUpdateEntries + else pure Nothing + pendings <- detectPendingMigrations manifest Nothing + TIO.putStr (formatStatus colorEnabled manifest tracked mEntries pendings) + +-- | Run the update check, catching any IO failure so status still renders. +fetchUpdateEntries :: IO (Maybe [OutdatedEntry]) +fetchUpdateEntries = do + outcome <- try $ do + searchPaths <- defaultSearchPaths + modules <- discoverAllModules searchPaths + checkInstalledModulesForUpdates modules + case outcome of + Left (e :: SomeException) -> do + hPutStrLn stderr $ + "warning: update check failed: " <> show e + pure Nothing + Right (entries, _stats) -> pure (Just entries) diff --git a/src-exe/Seihou/CLI/Upgrade.hs b/src-exe/Seihou/CLI/Upgrade.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Upgrade.hs @@ -0,0 +1,400 @@ +module Seihou.CLI.Upgrade + ( handleUpgrade, + ) +where + +import Control.Applicative ((<|>)) +import Control.Exception (SomeException, try) +import Control.Monad (when) +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (UpgradeOpts (..)) +import Seihou.CLI.Install (installModuleDir) +import Seihou.CLI.InstallShared (OriginInfo (..)) +import Seihou.CLI.Migrate + ( MigrateError (..), + MigrateOpts (..), + MigrateResult (..), + pendingChainFor, + runMigrate, + ) +import Seihou.CLI.Outdated (moduleNameFromDm, readOriginWithModule) +import Seihou.CLI.RemoteVersion (fetchTrueModuleVersion) +import Seihou.CLI.Style (dim, green, red, useColor, yellow) +import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions) +import Seihou.Core.Install (parseModuleName) +import Seihou.Core.Migration (MigrationPlan (..)) +import Seihou.Core.Module (DiscoveredModule (..), ModuleSource (..), defaultSearchPaths, discoverAllModules, validateModule) +import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents) +import Seihou.Core.Types (AppliedModule (..), Manifest (..), Module (..), ModuleName (..)) +import Seihou.Core.Version (renderVersion) +import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.ManifestStore (readManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Prelude +import System.Exit (ExitCode (..), exitFailure) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) + +data UpgradeStatus + = Upgraded + | AlreadyUpToDate + | Skipped + | UpgradeFailed Text + | SourceUnreachable + deriving stock (Eq, Show) + +data UpgradeEntry = UpgradeEntry + { moduleName :: Text, + oldVersion :: Maybe Text, + newVersion :: Maybe Text, + upgradeStatus :: UpgradeStatus + } + deriving stock (Eq, Show) + +instance ToJSON UpgradeEntry where + toJSON e = + object + [ "module" .= e.moduleName, + "oldVersion" .= e.oldVersion, + "newVersion" .= e.newVersion, + "status" .= statusText e.upgradeStatus + ] + where + statusText :: UpgradeStatus -> Text + statusText Upgraded = "upgraded" + statusText AlreadyUpToDate = "up to date" + statusText Skipped = "skipped" + statusText (UpgradeFailed reason) = "failed: " <> reason + statusText SourceUnreachable = "unreachable" + +handleUpgrade :: UpgradeOpts -> IO () +handleUpgrade uopts = do + searchPaths <- defaultSearchPaths + modules <- discoverAllModules searchPaths + let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules + + if null installed + then TIO.putStrLn "No installed modules found." + else do + originsWithModules <- mapM readOriginWithModule installed + let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules] + + filtered <- case uopts.upgradeModules of + [] -> pure withOrigins + names -> do + let result = [(dm, origin) | (dm, origin) <- withOrigins, moduleNameFromDm dm `elem` names] + found = map (moduleNameFromDm . fst) result + missing = filter (`notElem` found) names + when (not (null missing)) $ do + TIO.putStrLn $ "Module(s) not found: " <> T.intercalate ", " missing + exitFailure + pure result + + if null filtered + then TIO.putStrLn "No installed modules with origin metadata found." + else do + let grouped = Map.toList $ Map.fromListWith (++) [(origin.sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered] + + if uopts.upgradeDryRun + then TIO.putStrLn "Checking installed modules for updates (dry run)..." + else TIO.putStrLn "Upgrading installed modules..." + + entries <- concat <$> mapM (upgradeSource uopts) grouped + + if uopts.upgradeJson + then LBS.putStr (encodePretty entries) + else renderUpgradeTable entries + + -- After all upgrades, see whether the *current project* has + -- migrations pending for any module that was upgraded just + -- now. Either run them (--with-migrations) or print a + -- one-line advisory per module. + unless uopts.upgradeDryRun $ + handlePostUpgradeMigrations uopts entries + +upgradeSource :: UpgradeOpts -> (Text, [(DiscoveredModule, OriginInfo)]) -> IO [UpgradeEntry] +upgradeSource uopts (sourceUrl, modulesWithOrigins) = do + let repoName = parseModuleName sourceUrl + TIO.putStrLn $ " Cloning " <> T.pack repoName <> "..." + + result <- try $ withSystemTempDirectory "seihou-upgrade" $ \tmpDir -> do + let cloneDir = tmpDir repoName + (exitCode, _stdout, _stderr) <- readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack sourceUrl, cloneDir] "" + case exitCode of + ExitFailure _ -> pure Nothing + ExitSuccess -> do + contents <- discoverRepoContents evalRegistryFromFile cloneDir + Just <$> mapM (upgradeModule uopts cloneDir contents sourceUrl) modulesWithOrigins + + case result of + Left (_ :: SomeException) -> + pure [mkUnreachableEntry dm origin | (dm, origin) <- modulesWithOrigins] + Right Nothing -> + pure [mkUnreachableEntry dm origin | (dm, origin) <- modulesWithOrigins] + Right (Just entries) -> + pure entries + +mkUnreachableEntry :: DiscoveredModule -> OriginInfo -> UpgradeEntry +mkUnreachableEntry dm origin = + UpgradeEntry + { moduleName = moduleNameFromDm dm, + oldVersion = origin.version, + newVersion = Nothing, + upgradeStatus = SourceUnreachable + } + +upgradeModule :: UpgradeOpts -> FilePath -> RepoContents -> Text -> (DiscoveredModule, OriginInfo) -> IO UpgradeEntry +upgradeModule uopts cloneDir contents sourceUrl (dm, origin) = do + let name = moduleNameFromDm dm + installedVer = origin.version + availableVer <- fetchAvailable cloneDir (ModuleName name) + let status = compareVersions installedVer availableVer + + case status of + OutdatedSt + | uopts.upgradeDryRun -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} + | otherwise -> + doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer + UpToDate -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = AlreadyUpToDate} + Unversioned + | uopts.upgradeSkipUnversioned -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Skipped} + | uopts.upgradeDryRun -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} + | otherwise -> + doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer + Unreachable -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = Nothing, upgradeStatus = SourceUnreachable} + +doUpgrade :: FilePath -> RepoContents -> Text -> OriginInfo -> Text -> Maybe Text -> Maybe Text -> IO UpgradeEntry +doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer = do + let result = case contents of + SingleModule rootDir -> Just (rootDir, origin.repoName) + MultiModule registry -> + case filter (\e -> e.name.unModuleName == name) registry.modules of + (entry : _) -> Just (cloneDir entry.path, Just registry.repoName) + [] -> Nothing + SingleRecipe _ -> Nothing + SingleBlueprint _ -> Nothing + SinglePrompt _ -> Nothing + EmptyRepo -> Nothing + + case result of + Nothing -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed "module not found in remote"} + Just (moduleDir, registryName) -> do + let dhallFile = moduleDir "module.dhall" + decoded <- evalModuleFromFile dhallFile + case decoded of + Left err -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed (T.pack (show err))} + Right modul -> do + valResult <- validateModule moduleDir modul + case valResult of + Left err -> + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed (T.pack (show err))} + Right _ -> do + -- Trust the module.dhall version over the registry's static + -- entry.version: the registry can be stale (the bug fixed in + -- docs/plans/14-fix-outdated-version-detection.md). Tags are + -- still sourced from the registry entry since module.dhall + -- has no equivalent field. + let (ver, entryTags) = case contents of + MultiModule registry -> case filter (\e -> e.name.unModuleName == name) registry.modules of + (entry : _) -> (modul.version <|> entry.version, entry.tags) + [] -> (modul.version, []) + _ -> (modul.version, []) + installModuleDir moduleDir (T.unpack name) sourceUrl registryName ver entryTags + TIO.putStrLn $ " Upgraded " <> name + pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded} + +renderUpgradeTable :: [UpgradeEntry] -> IO () +renderUpgradeTable entries = do + colorEnabled <- useColor + let maxNameLen = max 6 (maximum (map (T.length . (.moduleName)) entries)) + maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (.oldVersion)) entries)) + maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (.newVersion)) entries)) + + padR n t = t <> T.replicate (n - T.length t + 2) " " + + header = + padR maxNameLen "Module" + <> padR maxOldLen "Old" + <> padR maxNewLen "New" + <> "Status" + + formatRow e = + let oldText = maybe "(none)" id e.oldVersion + newText = maybe "(none)" id e.newVersion + statusTxt = case e.upgradeStatus of + Upgraded -> if colorEnabled then green "upgraded" else "upgraded" + AlreadyUpToDate -> if colorEnabled then dim "up to date" else "up to date" + Skipped -> if colorEnabled then yellow "skipped (unversioned)" else "skipped (unversioned)" + UpgradeFailed reason -> if colorEnabled then red ("failed: " <> reason) else "failed: " <> reason + SourceUnreachable -> if colorEnabled then yellow "unreachable" else "unreachable" + in padR maxNameLen e.moduleName + <> padR maxOldLen oldText + <> padR maxNewLen newText + <> statusTxt + + TIO.putStrLn "" + TIO.putStrLn header + mapM_ (TIO.putStrLn . formatRow) entries + + let upgraded = length (filter (\e -> e.upgradeStatus == Upgraded) entries) + failed = length (filter isFailedEntry entries) + skipped = length (filter (\e -> e.upgradeStatus == Skipped) entries) + TIO.putStrLn "" + TIO.putStrLn $ + T.pack (show (length entries)) + <> " module(s) checked, " + <> T.pack (show upgraded) + <> " upgraded" + <> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "") + <> (if skipped > 0 then ", " <> T.pack (show skipped) <> " skipped" else "") + <> "." + +isFailedEntry :: UpgradeEntry -> Bool +isFailedEntry e = case e.upgradeStatus of + UpgradeFailed _ -> True + SourceUnreachable -> True + _ -> False + +-- | After the upgrade table is printed, look at the project's local +-- manifest for each module that was just upgraded. If the upgrade +-- raised the installed-copy version above the manifest's recorded +-- version, there are migrations to run. With @--with-migrations@, +-- run them. Otherwise, print a single advisory line per module. +-- +-- If there's no local manifest at all (the user is upgrading without +-- a project), this is a silent no-op. +handlePostUpgradeMigrations :: UpgradeOpts -> [UpgradeEntry] -> IO () +handlePostUpgradeMigrations uopts entries = do + let manifestPath = ".seihou" "manifest.json" + upgraded = + [ entry.moduleName | entry <- entries, entry.upgradeStatus == Upgraded + ] + if null upgraded + then pure () + else do + mfRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest + case mfRes of + Left _ -> pure () + Right Nothing -> pure () + Right (Just manifest) -> + mapM_ (handleOneModule uopts manifest) upgraded + +handleOneModule :: UpgradeOpts -> Manifest -> Text -> IO () +handleOneModule uopts manifest name = + case findAppliedByName manifest name of + Nothing -> pure () + Just am -> do + let dhallFile = am.source "module.dhall" + r <- evalModuleFromFile dhallFile + case r of + Left _ -> pure () + Right installed -> + case pendingChainFor am installed of + Nothing -> pure () + Just plan + | uopts.upgradeWithMigrations -> runOnePostUpgradeMigration am.source name + | otherwise -> printAdvisory name plan + +findAppliedByName :: Manifest -> Text -> Maybe AppliedModule +findAppliedByName manifest name = + case filter (\am -> am.name.unModuleName == name) manifest.modules of + (am : _) -> Just am + [] -> Nothing + +printAdvisory :: Text -> MigrationPlan -> IO () +printAdvisory name plan = do + colorEnabled <- useColor + let msg = + "note: " + <> name + <> " has " + <> T.pack (show (length plan.planSteps)) + <> " migration(s) pending (" + <> renderVersion plan.planFrom + <> " → " + <> renderVersion plan.planTo + <> "); run 'seihou migrate " + <> name + <> "'" + TIO.putStrLn $ if colorEnabled then yellow msg else msg + +-- | Run a migration for a single module. Reads the manifest fresh so +-- chained migrations against multiple upgraded modules see each +-- other's effects. +runOnePostUpgradeMigration :: FilePath -> Text -> IO () +runOnePostUpgradeMigration installedDir name = do + let manifestPath = ".seihou" "manifest.json" + mfRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest + case mfRes of + Right (Just manifest) -> do + let opts = + MigrateOpts + { migrateModule = ModuleName name, + migrateTo = Nothing, + migrateDryRun = False, + migrateForce = False, + migrateJson = False, + migrateVerbose = False, + -- The post-upgrade hook has already refreshed the + -- installed copy via 'seihou upgrade'; skip the + -- redundant fetch in 'runMigrate'. + migrateNoFetch = True, + migrateCommit = False, + migrateCommitMessage = Nothing + } + result <- runMigrate opts manifest installedDir + case result of + Right (MigrateApplied _ _ _ _) -> do + colorEnabled <- useColor + let msg = " Migrated " <> name + TIO.putStrLn $ if colorEnabled then green msg else msg + Right (MigrateNoOp _) -> pure () + Right (MigrateDryRunOK {}) -> pure () + Left err -> do + colorEnabled <- useColor + let msg = " Migration failed for " <> name <> ": " <> renderMigrateError err + TIO.putStrLn $ if colorEnabled then red msg else msg + _ -> pure () + +renderMigrateError :: MigrateError -> Text +renderMigrateError err = case err of + MigrateModuleNotApplied n -> "module " <> n.unModuleName <> " not applied" + MigrateNoRecordedVersion n -> "no version recorded for " <> n.unModuleName + MigrateInstalledModuleEvalFailed _ msg -> msg + MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> n.unModuleName + MigrateUnparseableInstalledVersion v -> "bad version " <> v + MigrateUnparseableTargetVersion v -> "bad target version " <> v + MigrateUnparseableManifestVersion v -> "bad manifest version " <> v + MigratePlanFailed _ -> "plan failed" + MigrateExecFailed _ -> "execution failed (use --force or revert your edits)" + MigrateNoManifest _ -> "no manifest in current dir" + +-- | Local @unless@ to avoid pulling in another import. +unless :: Bool -> IO () -> IO () +unless True _ = pure () +unless False action = action + +-- | Look up the available version of a module in a cloned repo by reading +-- its @module.dhall@. Fetch errors collapse to @Nothing@; downstream +-- 'compareVersions' treats that as "unversioned" and 'doUpgrade' will +-- still attempt the install (the registry's static @version@ is no longer +-- consulted for the comparison — see EP-1). +fetchAvailable :: FilePath -> ModuleName -> IO (Maybe Text) +fetchAvailable cloneDir name = do + result <- fetchTrueModuleVersion cloneDir name + case result of + Right v -> pure v + Left _ -> pure Nothing diff --git a/src-exe/Seihou/CLI/Validate.hs b/src-exe/Seihou/CLI/Validate.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Validate.hs @@ -0,0 +1,73 @@ +module Seihou.CLI.Validate + ( handleValidateModule, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (ValidateOpts (..)) +import Seihou.CLI.Shared (logIO) +import Seihou.CLI.Style (renderReportColor, useColor) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Effect.Logger (logError) +import Seihou.Engine.Validate (ValidateReport (..), buildReport, reportHasErrors) +import Seihou.Prelude +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Exit (ExitCode (..), exitFailure, exitWith) + +handleValidateModule :: ValidateOpts -> IO () +handleValidateModule vopts = do + -- Determine module path + moduleDir <- case vopts.validatePath of + Just p -> pure p + Nothing -> getCurrentDirectory + + let dhallFile = moduleDir "module.dhall" + + -- Check that module.dhall exists + exists <- doesFileExist dhallFile + if not exists + then do + logIO LogNormal (logError $ T.pack dhallFile <> " not found.") + exitWith (ExitFailure 4) + else pure () + + -- Evaluate Dhall + decoded <- evalModuleFromFile dhallFile + colorEnabled <- useColor + + case decoded of + Left err -> do + -- Dhall failed: build a report with reportDhallOk = False + let dummyModule = + Module + { name = ModuleName "", + version = Nothing, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + } + report = + ValidateReport + { reportModule = dummyModule, + reportPath = moduleDir, + reportDhallOk = False, + reportDhallError = Just (T.pack (show err)), + reportChecks = [] + } + TIO.putStr (renderReportColor colorEnabled report) + exitFailure + Right modul -> do + -- Build the structured report + report <- buildReport vopts.validateLint moduleDir modul + TIO.putStr (renderReportColor colorEnabled report) + if reportHasErrors report + then exitFailure + else pure () diff --git a/src-exe/Seihou/CLI/ValidateBlueprint.hs b/src-exe/Seihou/CLI/ValidateBlueprint.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/ValidateBlueprint.hs @@ -0,0 +1,187 @@ +module Seihou.CLI.ValidateBlueprint + ( handleValidateBlueprint, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (ValidateBlueprintOpts (..)) +import Seihou.CLI.Shared (logIO) +import Seihou.CLI.Style (bold, cyan, dim, green, red, useColor, yellow) +import Seihou.Core.Blueprint + ( checkBlueprintAllowedTools, + checkBlueprintBaseModules, + checkBlueprintFiles, + checkBlueprintNameFormat, + checkBlueprintPromptNonEmpty, + checkBlueprintPromptRefs, + checkBlueprintTags, + checkBlueprintUniqueVars, + checkBlueprintVersionPresent, + ) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalBlueprintFromFile) +import Seihou.Effect.Logger (logError) +import Seihou.Engine.Validate (DiagCheck (..), DiagSeverity (..)) +import Seihou.Prelude +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Exit (ExitCode (..), exitFailure, exitWith) + +-- | A complete validation report for a blueprint. Mirrors +-- 'Seihou.Engine.Validate.ValidateReport' but is keyed on a 'Blueprint' +-- rather than a 'Module', and reports on the rules that apply to +-- blueprints (no steps, no exports, no commands, but a non-empty prompt +-- and a 'files/' integrity check). +data BlueprintReport = BlueprintReport + { -- | 'Nothing' when Dhall evaluation failed; otherwise the decoded record + brBlueprint :: Maybe Blueprint, + -- | Display name; equals the decoded blueprint's name when available + brName :: Text, + brPath :: FilePath, + brDhallOk :: Bool, + brDhallError :: Maybe Text, + brChecks :: [DiagCheck] + } + +handleValidateBlueprint :: ValidateBlueprintOpts -> IO () +handleValidateBlueprint vopts = do + blueprintDir <- case vopts.validateBlueprintPath of + Just p -> pure p + Nothing -> getCurrentDirectory + + let dhallFile = blueprintDir "blueprint.dhall" + + exists <- doesFileExist dhallFile + if not exists + then do + logIO LogNormal (logError $ T.pack dhallFile <> " not found.") + exitWith (ExitFailure 4) + else pure () + + decoded <- evalBlueprintFromFile dhallFile + colorEnabled <- useColor + + case decoded of + Left err -> do + let report = + BlueprintReport + { brBlueprint = Nothing, + brName = "", + brPath = blueprintDir, + brDhallOk = False, + brDhallError = Just (T.pack (show err)), + brChecks = [] + } + TIO.putStr (renderBlueprintReport colorEnabled report) + exitFailure + Right bp -> do + report <- buildBlueprintReport blueprintDir bp + TIO.putStr (renderBlueprintReport colorEnabled report) + if blueprintReportHasErrors report + then exitFailure + else pure () + +-- | Build a structured validation report for a decoded blueprint by +-- running each of EP-29's pure and IO check functions and labelling the +-- result. Lint warnings are not yet implemented — the @--lint@ flag is +-- accepted for parity with @validate-module@ but currently has no +-- effect; future work can extend this list. +buildBlueprintReport :: FilePath -> Blueprint -> IO BlueprintReport +buildBlueprintReport baseDir b = do + fileErrors <- checkBlueprintFiles baseDir b + baseErrors <- checkBlueprintBaseModules b + let checks = + [ DiagCheck "Blueprint name format" DiagError (checkBlueprintNameFormat b), + DiagCheck "Blueprint version" DiagError (checkBlueprintVersionPresent b), + DiagCheck "Prompt body non-empty" DiagError (checkBlueprintPromptNonEmpty b), + DiagCheck "Unique variable names" DiagError (checkBlueprintUniqueVars b), + DiagCheck "Prompt references" DiagError (checkBlueprintPromptRefs b), + DiagCheck "Base modules" DiagError baseErrors, + DiagCheck "Reference file existence" DiagError fileErrors, + DiagCheck "Tags" DiagError (checkBlueprintTags b), + DiagCheck "Allowed tools" DiagError (checkBlueprintAllowedTools b) + ] + pure + BlueprintReport + { brBlueprint = Just b, + brName = b.name.unModuleName, + brPath = baseDir, + brDhallOk = True, + brDhallError = Nothing, + brChecks = checks + } + +blueprintReportHasErrors :: BlueprintReport -> Bool +blueprintReportHasErrors r = + not r.brDhallOk + || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) r.brChecks + +renderBlueprintReport :: Bool -> BlueprintReport -> Text +renderBlueprintReport color report = + T.unlines $ + [ "Validating blueprint at " <> T.pack report.brPath <> "...", + "" + ] + ++ dhallLine + ++ summaryLines + ++ checkLines + ++ [""] + ++ [resultLine] + where + okMark = if color then green "\x2713" else "\x2713" + errMark = if color then bold (red "\x2717") else "\x2717" + warnMark = if color then yellow "\x26A0" else "\x26A0" + nameStyle t = if color then cyan t else t + detailStyle t = if color then dim t else t + labelErr t = if color then red t else t + labelWarn t = if color then yellow t else t + + dhallLine = + if report.brDhallOk + then [" " <> okMark <> " blueprint.dhall evaluates successfully"] + else + [" " <> errMark <> " blueprint.dhall failed to evaluate"] + ++ case report.brDhallError of + Just errText -> [" " <> detailStyle errText] + Nothing -> [] + + summaryLines = case report.brBlueprint of + Nothing -> [] + Just b -> + [ " " <> okMark <> " Blueprint name: " <> nameStyle b.name.unModuleName, + " " <> okMark <> " " <> T.pack (show (length b.vars)) <> " variables declared", + " " <> okMark <> " " <> T.pack (show (length b.prompts)) <> " prompts defined", + " " <> okMark <> " " <> T.pack (show (length b.baseModules)) <> " base modules declared", + " " <> okMark <> " " <> T.pack (show (length b.files)) <> " reference files declared" + ] + + checkLines = concatMap renderCheck report.brChecks + + renderCheck c + | null c.diagDetails = + [" " <> okMark <> " " <> c.diagLabel] + | c.diagSeverity == DiagWarning = + (" " <> warnMark <> " " <> labelWarn c.diagLabel) + : map (\d -> " " <> detailStyle d) c.diagDetails + | otherwise = + (" " <> errMark <> " " <> labelErr c.diagLabel) + : map (\d -> " " <> detailStyle d) c.diagDetails + + errorCount = + length + [ () + | c <- report.brChecks, + c.diagSeverity == DiagError, + not (null c.diagDetails) + ] + + dhallFailed = not report.brDhallOk + totalErrors = errorCount + (if dhallFailed then 1 else 0) + + resultLine + | totalErrors > 0 = + let msg = T.pack (show totalErrors) <> " error(s) found." + in (if color then bold (red msg) else msg) <> " Blueprint is invalid." + | otherwise = + let msg = "Blueprint '" <> report.brName <> "' is valid." + in if color then green msg else msg diff --git a/src-exe/Seihou/CLI/ValidatePrompt.hs b/src-exe/Seihou/CLI/ValidatePrompt.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/ValidatePrompt.hs @@ -0,0 +1,177 @@ +module Seihou.CLI.ValidatePrompt + ( handleValidatePrompt, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (ValidatePromptOpts (..)) +import Seihou.CLI.Shared (logIO) +import Seihou.CLI.Style (bold, cyan, dim, green, red, useColor, yellow) +import Seihou.Core.AgentPrompt + ( checkAgentPromptAllowedTools, + checkAgentPromptBodyNonEmpty, + checkAgentPromptCommandVars, + checkAgentPromptFiles, + checkAgentPromptGuidance, + checkAgentPromptNameFormat, + checkAgentPromptPromptRefs, + checkAgentPromptTags, + checkAgentPromptUniqueVars, + checkAgentPromptVersionPresent, + ) +import Seihou.Core.Types +import Seihou.Dhall.Eval (evalAgentPromptFromFile) +import Seihou.Effect.Logger (logError) +import Seihou.Engine.Validate (DiagCheck (..), DiagSeverity (..)) +import Seihou.Prelude +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Exit (ExitCode (..), exitFailure, exitWith) + +data PromptReport = PromptReport + { prPrompt :: Maybe AgentPrompt, + prName :: Text, + prPath :: FilePath, + prDhallOk :: Bool, + prDhallError :: Maybe Text, + prChecks :: [DiagCheck] + } + +handleValidatePrompt :: ValidatePromptOpts -> IO () +handleValidatePrompt vopts = do + promptDir <- case vopts.validatePromptPath of + Just p -> pure p + Nothing -> getCurrentDirectory + + let dhallFile = promptDir "prompt.dhall" + + exists <- doesFileExist dhallFile + if not exists + then do + logIO LogNormal (logError $ T.pack dhallFile <> " not found.") + exitWith (ExitFailure 4) + else pure () + + decoded <- evalAgentPromptFromFile dhallFile + colorEnabled <- useColor + + case decoded of + Left err -> do + let report = + PromptReport + { prPrompt = Nothing, + prName = "", + prPath = promptDir, + prDhallOk = False, + prDhallError = Just (T.pack (show err)), + prChecks = [] + } + TIO.putStr (renderPromptReport colorEnabled report) + exitFailure + Right p -> do + report <- buildPromptReport promptDir p + TIO.putStr (renderPromptReport colorEnabled report) + if promptReportHasErrors report + then exitFailure + else pure () + +buildPromptReport :: FilePath -> AgentPrompt -> IO PromptReport +buildPromptReport baseDir p = do + fileErrors <- checkAgentPromptFiles baseDir p + let checks = + [ DiagCheck "Prompt name format" DiagError (checkAgentPromptNameFormat p), + DiagCheck "Prompt version" DiagError (checkAgentPromptVersionPresent p), + DiagCheck "Prompt body non-empty" DiagError (checkAgentPromptBodyNonEmpty p), + DiagCheck "Unique variable names" DiagError (checkAgentPromptUniqueVars p), + DiagCheck "Prompt references" DiagError (checkAgentPromptPromptRefs p), + DiagCheck "Command variables" DiagError (checkAgentPromptCommandVars p), + DiagCheck "Prompt guidance" DiagError (checkAgentPromptGuidance p), + DiagCheck "Reference file existence" DiagError fileErrors, + DiagCheck "Tags" DiagError (checkAgentPromptTags p), + DiagCheck "Allowed tools" DiagError (checkAgentPromptAllowedTools p) + ] + pure + PromptReport + { prPrompt = Just p, + prName = p.name.unModuleName, + prPath = baseDir, + prDhallOk = True, + prDhallError = Nothing, + prChecks = checks + } + +promptReportHasErrors :: PromptReport -> Bool +promptReportHasErrors r = + not r.prDhallOk + || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) r.prChecks + +renderPromptReport :: Bool -> PromptReport -> Text +renderPromptReport color report = + T.unlines $ + [ "Validating prompt at " <> T.pack report.prPath <> "...", + "" + ] + ++ dhallLine + ++ summaryLines + ++ checkLines + ++ [""] + ++ [resultLine] + where + okMark = if color then green "\x2713" else "\x2713" + errMark = if color then bold (red "\x2717") else "\x2717" + warnMark = if color then yellow "\x26A0" else "\x26A0" + nameStyle t = if color then cyan t else t + detailStyle t = if color then dim t else t + labelErr t = if color then red t else t + labelWarn t = if color then yellow t else t + + dhallLine = + if report.prDhallOk + then [" " <> okMark <> " prompt.dhall evaluates successfully"] + else + [" " <> errMark <> " prompt.dhall failed to evaluate"] + ++ case report.prDhallError of + Just errText -> [" " <> detailStyle errText] + Nothing -> [] + + summaryLines = case report.prPrompt of + Nothing -> [] + Just p -> + [ " " <> okMark <> " Prompt name: " <> nameStyle p.name.unModuleName, + " " <> okMark <> " " <> T.pack (show (length p.vars)) <> " variables declared", + " " <> okMark <> " " <> T.pack (show (length p.prompts)) <> " prompts defined", + " " <> okMark <> " " <> T.pack (show (length p.commandVars)) <> " command variables declared", + " " <> okMark <> " " <> T.pack (show (length p.guidance)) <> " guidance blocks declared", + " " <> okMark <> " " <> T.pack (show (length p.files)) <> " reference files declared" + ] + + checkLines = concatMap renderCheck report.prChecks + + renderCheck c + | null c.diagDetails = + [" " <> okMark <> " " <> c.diagLabel] + | c.diagSeverity == DiagWarning = + (" " <> warnMark <> " " <> labelWarn c.diagLabel) + : map (\d -> " " <> detailStyle d) c.diagDetails + | otherwise = + (" " <> errMark <> " " <> labelErr c.diagLabel) + : map (\d -> " " <> detailStyle d) c.diagDetails + + errorCount = + length + [ () + | c <- report.prChecks, + c.diagSeverity == DiagError, + not (null c.diagDetails) + ] + + dhallFailed = not report.prDhallOk + totalErrors = errorCount + (if dhallFailed then 1 else 0) + + resultLine + | totalErrors > 0 = + let msg = T.pack (show totalErrors) <> " error(s) found." + in (if color then bold (red msg) else msg) <> " Prompt is invalid." + | otherwise = + let msg = "Prompt '" <> report.prName <> "' is valid." + in if color then green msg else msg diff --git a/src-exe/Seihou/CLI/Vars.hs b/src-exe/Seihou/CLI/Vars.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Vars.hs @@ -0,0 +1,210 @@ +module Seihou.CLI.Vars + ( handleVars, + ) +where + +import Control.Monad (when) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Commands (VarsOpts (..)) +import Seihou.CLI.Shared (deriveNamespace, formatVarError, logIO, toVarNameMap, unwrapConfig) +import Seihou.Composition.Instance (ModuleInstance (..)) +import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) +import Seihou.Core.Context (resolveContext) +import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) +import Seihou.Core.Types +import Seihou.Core.Variable (diagnoseResolution, formatDeclarations, formatExplain) +import Seihou.Effect.ConfigReader (readContextConfig, readGlobalConfig, readLocalConfig, readNamespaceConfig) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Effect.ConsoleInterp (runConsole) +import Seihou.Effect.FzfInterp (runFzfIO) +import Seihou.Effect.Logger (logError, logInfo) +import Seihou.Fzf (FzfResult (..), detectFzfConfig, isFzfUsable) +import Seihou.Fzf.Selector (selectModule) +import Seihou.Prelude +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..), exitFailure, exitWith) + +handleVars :: VarsOpts -> IO () +handleVars vopts = do + -- Resolve module name (from argument or fzf picker) + modName <- case vopts.varsModule of + Just name -> pure name + Nothing -> do + fzfCfg <- detectFzfConfig + if isFzfUsable fzfCfg + then do + result <- runEff $ runFzfIO fzfCfg $ selectModule + case result of + FzfSelected name -> pure name + FzfCancelled -> exitWith ExitSuccess + FzfNoMatch -> do + logIO LogNormal (logError "No modules found.") + exitFailure + FzfError err -> do + logIO LogNormal (logError $ "fzf error: " <> err) + exitFailure + else do + logIO LogNormal (logError "MODULE argument is required when fzf is not available.") + exitFailure + + -- Resolve the runnable's kind first so we can dispatch correctly: + -- modules go through the existing module/composition pipeline, + -- recipes show their declared vars in declaration mode, and + -- blueprints get their own declaration-mode formatter and refuse + -- @--explain@ entirely (resolving a blueprint's variables is the + -- agent runner's job, not vars'). + searchPaths <- defaultSearchPaths + discResult <- discoverRunnable searchPaths modName + case discResult of + Left (ModuleNotFound _ searched) -> do + logIO LogNormal $ do + logError $ "Module '" <> modName.unModuleName <> "' not found." + logError "Searched in:" + mapM_ (\p -> logError $ " " <> T.pack p) searched + exitFailure + Left err -> do + logIO LogNormal (logError $ T.pack (show err)) + exitFailure + Right (RunnableModule m _) -> + if vopts.varsExplain + then explainMode modName vopts + else declarationModeModule m + Right (RunnableRecipe r _) -> + if vopts.varsExplain + then explainMode modName vopts + else declarationModeRecipe r + Right (RunnableBlueprint b _) -> + if vopts.varsExplain + then do + logIO LogNormal $ do + logError $ "'" <> modName.unModuleName <> "' is a blueprint; --explain is not supported in this release." + logError "Resolving a blueprint's variables requires the agent runner." + logError "Run `seihou agent run ` instead (when EP-31 ships)." + logError "For a read-only listing of declared variables, omit --explain." + exitFailure + else declarationModeBlueprint b + +-- | Declaration mode for a module: list declared variables. +declarationModeModule :: Module -> IO () +declarationModeModule modul = do + let vs = modul.vars + if null vs + then TIO.putStrLn "No variables declared." + else do + TIO.putStrLn $ "Variables for " <> modul.name.unModuleName <> ":" + TIO.putStrLn "" + TIO.putStr (formatDeclarations vs) + +-- | Declaration mode for a recipe: list its declared variables. Recipes +-- carry their own @vars@ list (separately from the modules they +-- compose); this prints those without expanding the recipe. +declarationModeRecipe :: Recipe -> IO () +declarationModeRecipe r = do + let vs = r.vars + if null vs + then TIO.putStrLn "No variables declared." + else do + TIO.putStrLn $ "Variables for " <> r.name.unRecipeName <> " (recipe):" + TIO.putStrLn "" + TIO.putStr (formatDeclarations vs) + +-- | Declaration mode for a blueprint: list its declared variables. The +-- blueprint kind is surfaced in the heading so users can tell at a +-- glance that this is the agent-driven runnable, not a module/recipe. +declarationModeBlueprint :: Blueprint -> IO () +declarationModeBlueprint b = do + let vs = b.vars + if null vs + then TIO.putStrLn "No variables declared." + else do + TIO.putStrLn $ "Variables for " <> b.name.unModuleName <> " (blueprint):" + TIO.putStrLn "" + TIO.putStr (formatDeclarations vs) + +-- | Explain mode: load full composition, resolve variables with exports, show provenance +explainMode :: ModuleName -> VarsOpts -> IO () +explainMode modName vopts = do + -- Load the full composition (target module + transitive dependencies) + searchPaths <- defaultSearchPaths + compositionResult <- loadComposition searchPaths modName [] + modulesInOrder <- case compositionResult of + Left (ModuleNotFound name searched) -> do + logIO LogNormal $ do + logError $ "Module '" <> name.unModuleName <> "' not found." + logError "Searched in:" + mapM_ (\p -> logError $ " " <> T.pack p) searched + exitFailure + Left (CircularDependency names) -> do + logIO LogNormal $ do + logError "Circular dependency detected:" + logError $ " " <> T.intercalate " -> " (map (.unModuleName) names) + exitFailure + Left err -> do + logIO LogNormal (logError $ T.pack (show err)) + exitFailure + Right ms -> pure ms + + -- Report composition when multiple modules are involved + when (length modulesInOrder > 1) $ + logIO LogNormal $ + logInfo $ + "Resolving with " + <> T.pack (show (length modulesInOrder)) + <> " modules in composition" + + -- Resolve variables with the full composition pipeline + envPairs <- getEnvironment + let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- vopts.varsVars] + envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs] + namespace = fromMaybe (deriveNamespace modName) vopts.varsNamespace + context <- resolveContext vopts.varsContext envVars + let contextName = fromMaybe "" context + (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do + localCfg <- readLocalConfig >>= unwrapConfig LogNormal + namespaceCfg <- readNamespaceConfig namespace >>= unwrapConfig LogNormal + contextCfg <- readContextConfig contextName >>= unwrapConfig LogNormal + globalCfg <- readGlobalConfig >>= unwrapConfig LogNormal + let lm = toVarNameMap localCfg + nm = toVarNameMap namespaceCfg + cm = toVarNameMap contextCfg + gm = toVarNameMap globalCfg + r <- resolveWithPrompts modulesInOrder cliOverrides envVars namespace contextName lm nm cm gm + pure (r, lm, nm, cm, gm) + case resolveResult of + Left errs -> do + logIO LogNormal $ do + logError "Error resolving variables:" + mapM_ (logError . (" " <>) . formatVarError) errs + exitFailure + Right resolved -> do + -- Show only the target module's resolved variables. `seihou vars` is + -- scoped to a module name, so if multiple instances exist we merge + -- their resolved maps (last wins on overlap — matches how a user + -- reads "the variables of module X" before any disambiguation UI). + let targetResolved = + Map.unions + [ vs + | (inst, vs) <- Map.toList resolved, + inst.instanceModule == modName + ] + TIO.putStrLn $ "Variables for " <> modName.unModuleName <> ":" + TIO.putStrLn "" + if Map.null targetResolved + then TIO.putStrLn " (no variables resolved)" + else TIO.putStr (formatExplain targetResolved) + + -- Show diagnostics + let allDecls = concatMap (\(_, m, _) -> m.vars) modulesInOrder + allResolved = Map.unions [vs | vs <- Map.elems resolved] + (unusedKeys, unresolvedOpt) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap + when (not (null unusedKeys)) $ do + TIO.putStrLn "" + TIO.putStrLn "Unused config keys (not matching any declared variable):" + mapM_ (\(VarName n) -> TIO.putStrLn $ " " <> n) unusedKeys + when (not (null unresolvedOpt)) $ do + TIO.putStrLn "" + TIO.putStrLn "Unresolved optional variables:" + mapM_ (\(VarName n) -> TIO.putStrLn $ " " <> n) unresolvedOpt diff --git a/src-exe/Seihou/CLI/Version.hs b/src-exe/Seihou/CLI/Version.hs new file mode 100644 --- /dev/null +++ b/src-exe/Seihou/CLI/Version.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.Version + ( seihouVersion, + seihouVersionWithGit, + gitCommitShort, + ) +where + +import Data.Text (Text, pack) +import Data.Version (showVersion) +import GitHash (GitInfo, giHash, tGitInfoCwdTry) +import Paths_seihou_cli (version) + +seihouVersion :: Text +seihouVersion = pack (showVersion version) + +-- | Git info embedded at compile time (Right if in git repo, Left with error message otherwise) +gitInfo :: Either String GitInfo +gitInfo = $$tGitInfoCwdTry + +-- | Fallback git hash injected via CPP for Nix builds where .git is absent. +nixGitHash :: Maybe Text +#ifdef GIT_HASH +nixGitHash = Just GIT_HASH +#else +nixGitHash = Nothing +#endif + +-- | Get the short git commit hash (first 7 characters). +-- Falls back to CPP-injected GIT_HASH for Nix builds. +gitCommitShort :: Maybe Text +gitCommitShort = case gitInfo of + Right gi -> Just $ pack $ take 7 $ giHash gi + Left _ -> nixGitHash + +-- | Version string with git commit suffix (e.g. "seihou v0.1.0.0 (a1b2c3d)") +seihouVersionWithGit :: Text +seihouVersionWithGit = "seihou v" <> seihouVersion <> commitSuffix + where + commitSuffix = maybe "" (\c -> " (" <> c <> ")") gitCommitShort diff --git a/src/Seihou/CLI/AgentCompletion.hs b/src/Seihou/CLI/AgentCompletion.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentCompletion.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Seihou.CLI.AgentCompletion + ( AgentProvider (..), + AgentModelConfig (..), + AgentCompletionRequest (..), + defaultAgentModelConfig, + providerFromText, + providerToText, + buildAgentCompletionRequest, + buildBaikaiModel, + runAgentCompletion, + responseText, + ) +where + +import Baikai qualified +import Baikai.Provider.Claude.Api qualified as ClaudeApi +import Baikai.Provider.Claude.Cli qualified as ClaudeCli +import Baikai.Provider.OpenAI.Api qualified as OpenAIApi +import Baikai.Provider.OpenAI.Cli qualified as CodexCli +import Control.Exception (try) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as V + +data AgentProvider + = AgentProviderClaudeCli + | AgentProviderCodexCli + | AgentProviderAnthropic + | AgentProviderOpenAI + deriving stock (Eq, Show) + +data AgentModelConfig = AgentModelConfig + { agentProvider :: AgentProvider, + agentModel :: Maybe Text + } + deriving stock (Eq, Show) + +data AgentCompletionRequest = AgentCompletionRequest + { completionSystemPrompt :: Text, + completionInitialPrompt :: Maybe Text, + completionModelConfig :: AgentModelConfig + } + deriving stock (Eq, Show) + +buildAgentCompletionRequest :: AgentModelConfig -> Text -> Maybe Text -> AgentCompletionRequest +buildAgentCompletionRequest modelConfig systemPrompt initialPrompt = + AgentCompletionRequest + { completionSystemPrompt = systemPrompt, + completionInitialPrompt = initialPrompt, + completionModelConfig = modelConfig + } + +defaultAgentModelConfig :: AgentModelConfig +defaultAgentModelConfig = + AgentModelConfig + { agentProvider = AgentProviderClaudeCli, + agentModel = Nothing + } + +providerFromText :: Text -> Either Text AgentProvider +providerFromText raw = + case Text.toLower (Text.strip raw) of + "claude-cli" -> Right AgentProviderClaudeCli + "codex-cli" -> Right AgentProviderCodexCli + "anthropic" -> Right AgentProviderAnthropic + "openai" -> Right AgentProviderOpenAI + other -> + Left $ + "Unknown agent provider '" + <> other + <> "'. Expected one of: claude-cli, codex-cli, anthropic, openai." + +providerToText :: AgentProvider -> Text +providerToText AgentProviderClaudeCli = "claude-cli" +providerToText AgentProviderCodexCli = "codex-cli" +providerToText AgentProviderAnthropic = "anthropic" +providerToText AgentProviderOpenAI = "openai" + +buildBaikaiModel :: AgentModelConfig -> Baikai.Model +buildBaikaiModel config = + case config.agentProvider of + AgentProviderClaudeCli -> + baseCliModel + { Baikai.modelId = maybe "" id config.agentModel, + Baikai.name = maybe "Claude CLI default" id config.agentModel, + Baikai.api = Baikai.AnthropicMessagesCli, + Baikai.provider = "anthropic" + } + AgentProviderCodexCli -> + baseCliModel + { Baikai.modelId = maybe "" id config.agentModel, + Baikai.name = maybe "Codex CLI default" id config.agentModel, + Baikai.api = Baikai.OpenAICompletionsCli, + Baikai.provider = "openai" + } + AgentProviderAnthropic -> + Baikai.emptyModel + { Baikai.modelId = maybe "claude-sonnet-4-6" id config.agentModel, + Baikai.name = maybe "Claude Sonnet 4.6" id config.agentModel, + Baikai.api = Baikai.AnthropicMessages, + Baikai.provider = "anthropic", + Baikai.baseUrl = "https://api.anthropic.com" + } + AgentProviderOpenAI -> + Baikai.emptyModel + { Baikai.modelId = maybe "gpt-4o-mini" id config.agentModel, + Baikai.name = maybe "GPT-4o Mini" id config.agentModel, + Baikai.api = Baikai.OpenAIChatCompletions, + Baikai.provider = "openai", + Baikai.baseUrl = "https://api.openai.com" + } + where + baseCliModel = + Baikai.emptyModel + { Baikai.contextWindow = 0, + Baikai.maxOutputTokens = 0 + } + +runAgentCompletion :: AgentCompletionRequest -> IO (Either Text Text) +runAgentCompletion req = do + registerAgentProviders + initialMessages <- + maybe + (pure V.empty) + (fmap V.singleton . Baikai.userNow) + req.completionInitialPrompt + let model = buildBaikaiModel req.completionModelConfig + ctx = + Baikai.emptyContext + { Baikai.systemPrompt = Just req.completionSystemPrompt, + Baikai.messages = initialMessages + } + result <- try (Baikai.completeRequest model ctx Baikai.emptyOptions) :: IO (Either Baikai.BaikaiError Baikai.Response) + pure $ case result of + Left err -> Left (Text.pack (show err)) + Right resp -> + let body = responseText resp + in if Text.null (Text.strip body) + then Left "Provider returned no assistant text." + else Right body + +responseText :: Baikai.Response -> Text +responseText = + Text.intercalate "\n" + . V.toList + . V.mapMaybe assistantText + . Baikai.flattenAssistantBlocks + where + assistantText (Baikai.AssistantText (Baikai.TextContent t)) = Just t + assistantText _ = Nothing + +registerAgentProviders :: IO () +registerAgentProviders = do + ClaudeCli.register + CodexCli.register + ClaudeApi.register + OpenAIApi.register diff --git a/src/Seihou/CLI/AgentConfig.hs b/src/Seihou/CLI/AgentConfig.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentConfig.hs @@ -0,0 +1,93 @@ +module Seihou.CLI.AgentConfig + ( AgentConfigInputs (..), + agentProviderConfigKey, + agentModelConfigKey, + agentProviderEnvVar, + agentModelEnvVar, + resolveAgentModelConfig, + loadAgentModelConfig, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.CLI.AgentCompletion + ( AgentModelConfig (..), + defaultAgentModelConfig, + providerFromText, + ) +import Seihou.CLI.Shared (formatConfigError) +import Seihou.Effect.ConfigReader (readGlobalConfig, readLocalConfig) +import Seihou.Effect.ConfigReaderInterp (runConfigReader) +import Seihou.Prelude +import System.Environment (lookupEnv) + +data AgentConfigInputs = AgentConfigInputs + { cliProvider :: Maybe Text, + cliModel :: Maybe Text, + envProvider :: Maybe Text, + envModel :: Maybe Text, + localConfig :: Map Text Text, + globalConfig :: Map Text Text + } + deriving stock (Eq, Show) + +agentProviderConfigKey :: Text +agentProviderConfigKey = "agent.provider" + +agentModelConfigKey :: Text +agentModelConfigKey = "agent.model" + +agentProviderEnvVar :: String +agentProviderEnvVar = "SEIHOU_AGENT_PROVIDER" + +agentModelEnvVar :: String +agentModelEnvVar = "SEIHOU_AGENT_MODEL" + +resolveAgentModelConfig :: AgentConfigInputs -> Either Text AgentModelConfig +resolveAgentModelConfig inputs = do + provider <- + maybe + (Right defaultAgentModelConfig.agentProvider) + providerFromText + (firstNonBlank [inputs.cliProvider, inputs.envProvider, configValue inputs.localConfig agentProviderConfigKey, configValue inputs.globalConfig agentProviderConfigKey]) + pure + AgentModelConfig + { agentProvider = provider, + agentModel = firstNonBlank [inputs.cliModel, inputs.envModel, configValue inputs.localConfig agentModelConfigKey, configValue inputs.globalConfig agentModelConfigKey] + } + +loadAgentModelConfig :: Maybe Text -> Maybe Text -> IO (Either Text AgentModelConfig) +loadAgentModelConfig cliProvider cliModel = do + envProvider <- fmap T.pack <$> lookupEnv agentProviderEnvVar + envModel <- fmap T.pack <$> lookupEnv agentModelEnvVar + (localResult, globalResult) <- runEff $ runConfigReader $ do + local <- readLocalConfig + global <- readGlobalConfig + pure (local, global) + pure $ do + local <- first formatConfigError localResult + global <- first formatConfigError globalResult + resolveAgentModelConfig + AgentConfigInputs + { cliProvider = cliProvider, + cliModel = cliModel, + envProvider = envProvider, + envModel = envModel, + localConfig = local, + globalConfig = global + } + +configValue :: Map Text Text -> Text -> Maybe Text +configValue config key = Map.lookup key config + +firstNonBlank :: [Maybe Text] -> Maybe Text +firstNonBlank = + foldr + ( \candidate acc -> + case T.strip <$> candidate of + Just "" -> acc + Just value -> Just value + Nothing -> acc + ) + Nothing diff --git a/src/Seihou/CLI/AgentLaunch.hs b/src/Seihou/CLI/AgentLaunch.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AgentLaunch.hs @@ -0,0 +1,260 @@ +module Seihou.CLI.AgentLaunch + ( AgentContext (..), + BaselineStatus (..), + gatherAgentContext, + defaultAllowedTools, + setupAllowedTools, + bootstrapAllowedTools, + substitute, + formatSeihouProjectState, + formatManifestState, + formatModuleDhallState, + formatLocalModules, + formatAvailableModules, + formatBlueprintIdentity, + formatBaselineStatus, + formatReferenceFiles, + formatReferenceFilesDir, + resolveBlueprintTools, + ) +where + +import Data.List (nub) +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Seihou.Core.Module (DiscoveredModule (..), ModuleSource (..), defaultSearchPaths, discoverAllModules) +import Seihou.Core.Types +import Seihou.Prelude +import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory) + +-- | Dynamic context gathered from the current directory, shared across agent commands. +data AgentContext = AgentContext + { cwd :: Text, + seihouInitialized :: Bool, + hasManifest :: Bool, + localModuleDhall :: Bool, + localModules :: [Text], + -- | (name, description, source) + availableModules :: [(Text, Text, Text)] + } + +gatherAgentContext :: IO AgentContext +gatherAgentContext = do + cwd <- T.pack <$> getCurrentDirectory + seihouInitialized <- doesDirectoryExist (T.unpack cwd ".seihou") + hasManifest <- doesFileExist (T.unpack cwd ".seihou" "manifest.json") + localModuleDhall <- doesFileExist (T.unpack cwd "module.dhall") + + localMods <- findLocalModuleDirs (T.unpack cwd) + + searchPaths <- defaultSearchPaths + discovered <- discoverAllModules searchPaths + let available = concatMap toModuleInfo discovered + + pure + AgentContext + { cwd = cwd, + seihouInitialized = seihouInitialized, + hasManifest = hasManifest, + localModuleDhall = localModuleDhall, + localModules = localMods, + availableModules = available + } + +-- | Default allowed tools for agent commands (assist, bootstrap). +defaultAllowedTools :: [String] +defaultAllowedTools = + [ "Bash(seihou *)", + "Bash(git *)", + "Bash(ls *)", + "Bash(mkdir *)", + "Bash(cat *)", + "Bash(pwd)", + "Read", + "Write", + "Edit", + "Glob", + "Grep", + "EnterWorktree", + "ExitWorktree" + ] + +-- | Allowed tools for the setup command — grants full git and seihou access +-- since setup needs to init repos, stage files, commit, and run any seihou command. +setupAllowedTools :: [String] +setupAllowedTools = + [ "Bash(seihou *)", + "Bash(git *)", + "Bash(ls *)", + "Bash(mkdir *)", + "Bash(cat *)", + "Bash(pwd)", + "Read", + "Write", + "Edit", + "Glob", + "Grep", + "EnterWorktree", + "ExitWorktree" + ] + +-- | Allowed tools for the bootstrap command — grants full git access, temp directories, +-- and common shell utilities so the agent can scaffold, test, and commit without prompting. +bootstrapAllowedTools :: [String] +bootstrapAllowedTools = + [ "Bash(seihou *)", + "Bash(git *)", + "Bash(ls *)", + "Bash(mkdir *)", + "Bash(cat *)", + "Bash(pwd)", + "Bash(mktemp *)", + "Bash(cp *)", + "Bash(rm *)", + "Bash(mv *)", + "Bash(touch *)", + "Bash(tree *)", + "Bash(find *)", + "Bash(wc *)", + "Bash(diff *)", + "Bash(head *)", + "Bash(tail *)", + "Bash(echo *)", + "Bash(chmod *)", + "Read", + "Write", + "Edit", + "Glob", + "Grep", + "EnterWorktree", + "ExitWorktree" + ] + +-- | Simple {{key}} substitution. Replaces each {{key}} with the corresponding value. +substitute :: [(Text, Text)] -> Text -> Text +substitute vars template = foldl' replaceOne template vars + where + replaceOne t (key, val) = T.replace ("{{" <> key <> "}}") val t + +-- Shared context formatters + +formatSeihouProjectState :: AgentContext -> Text +formatSeihouProjectState ctx + | ctx.seihouInitialized = "Seihou project: .seihou/ directory exists (this is a seihou-managed project)" + | otherwise = "Seihou project: No .seihou/ directory (not yet a seihou project in this directory)" + +formatManifestState :: AgentContext -> Text +formatManifestState ctx + | ctx.hasManifest = "Manifest: .seihou/manifest.json exists (modules have been applied here)" + | otherwise = "Manifest: No manifest (no modules applied yet)" + +formatModuleDhallState :: AgentContext -> Text +formatModuleDhallState ctx + | ctx.localModuleDhall = "Module in cwd: module.dhall found in current directory (user is authoring a module here)" + | otherwise = "" + +formatLocalModules :: AgentContext -> Text +formatLocalModules ctx + | null ctx.localModules = "" + | otherwise = T.intercalate "\n" $ "Local modules:" : map (" - " <>) ctx.localModules + +formatAvailableModules :: AgentContext -> Text +formatAvailableModules ctx + | null ctx.availableModules = "Available modules: None discovered" + | otherwise = + T.intercalate "\n" $ + "Available modules across search paths:" + : map formatMod ctx.availableModules + where + formatMod (name, desc, src) = " - " <> name <> " — " <> desc <> " (" <> src <> ")" + +-- Internal helpers + +findLocalModuleDirs :: FilePath -> IO [Text] +findLocalModuleDirs dir = do + let seihouModsDir = dir ".seihou" "modules" + hasSeihouMods <- doesDirectoryExist seihouModsDir + if hasSeihouMods + then pure ["(project modules directory exists at .seihou/modules/)"] + else pure [] + +toModuleInfo :: DiscoveredModule -> [(Text, Text, Text)] +toModuleInfo dm = case dm.discoveredResult of + Right m -> + [ ( m.name.unModuleName, + maybe "(no description)" id m.description, + sourceLabel dm.discoveredSource + ) + ] + Left _ -> [] + +sourceLabel :: ModuleSource -> Text +sourceLabel SourceProject = "project" +sourceLabel SourceUser = "user" +sourceLabel SourceInstalled = "installed" + +-- | Outcome of the optional baseline-application phase in +-- @seihou agent run@. Captured here in the library so the runner +-- (in @src-exe@) and the formatter share one shape. +data BaselineStatus + = -- | The user passed @--no-baseline@; the runner skipped baseline application entirely. + BaselineSkipped + | -- | The blueprint declared no @baseModules@; nothing to apply. + BaselineEmpty + | -- | Baseline modules were applied. Each entry is the module's name and (optional) version. + BaselineApplied [(ModuleName, Maybe Text)] + deriving stock (Eq, Show) + +-- | Render a blueprint's identity (name, version, description) as the +-- block embedded under "## Blueprint Identity" in the agent's system prompt. +formatBlueprintIdentity :: Blueprint -> Text +formatBlueprintIdentity bp = + T.intercalate + "\n" + [ "Name: " <> bp.name.unModuleName, + "Version: " <> fromMaybe "(unspecified)" bp.version, + "Description: " <> fromMaybe "(no description)" bp.description + ] + +-- | Render the "## Baseline" body for the agent prompt. +formatBaselineStatus :: BaselineStatus -> Text +formatBaselineStatus BaselineSkipped = + "(no baseline applied — `--no-baseline` was passed)" +formatBaselineStatus BaselineEmpty = + "(this blueprint declares no base modules)" +formatBaselineStatus (BaselineApplied entries) = + T.intercalate "\n" (map render entries) + where + render (n, Just v) = " - " <> n.unModuleName <> " (v" <> v <> ")" + render (n, Nothing) = " - " <> n.unModuleName <> " (unversioned)" + +-- | Render a blueprint's @files@ list as the body of the +-- "## Reference Files" block. When the directory exists, the interactive +-- runner mounts it via @--add-dir@ and 'formatReferenceFilesDir' prints its +-- path; this list helps the agent pick the right reference for the request. +formatReferenceFiles :: [BlueprintFile] -> Text +formatReferenceFiles [] = "(no reference files)" +formatReferenceFiles bfs = T.intercalate "\n" (map render bfs) + where + render bf = case bf.description of + Just d -> " - " <> T.pack bf.src <> " — " <> d + Nothing -> " - " <> T.pack bf.src + +-- | Render guidance for the blueprint's reference-files directory. A +-- present path means the directory is mounted and readable by the interactive +-- agent; 'Nothing' means the provider cannot access it in this session. +formatReferenceFilesDir :: Maybe FilePath -> Text +formatReferenceFilesDir (Just dir) = + "These files are readable at: " + <> T.pack dir + <> " — open them directly with your file tools before asking the user." +formatReferenceFilesDir Nothing = + "These files are not mounted in this session; ask the user to paste any " + <> "reference you need and never claim to have read one." + +-- | Effective pre-approved tools for a blueprint run: the base set every +-- blueprint needs plus any tools it declares, de-duplicated and base-first. +-- No declaration yields exactly 'setupAllowedTools'. +resolveBlueprintTools :: Maybe [Text] -> [String] +resolveBlueprintTools declared = + nub (setupAllowedTools <> map T.unpack (fromMaybe [] declared)) diff --git a/src/Seihou/CLI/AppliedBlueprint.hs b/src/Seihou/CLI/AppliedBlueprint.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/AppliedBlueprint.hs @@ -0,0 +1,45 @@ +-- | Persist 'AppliedBlueprint' provenance to a project's +-- @.seihou/manifest.json@. The runner in @src-exe/Seihou/CLI/AgentRun.hs@ +-- assembles an 'AppliedBlueprint' after a successful agent session and +-- delegates the actual read-modify-write to 'recordAppliedBlueprint'. +-- Keeping this helper in @seihou-cli-internal@ (rather than next to the +-- runner) lets the test suite cover it directly: the @seihou@ +-- executable target is trapped by @Options.Applicative@/@Data.FileEmbed@ +-- and is not importable by @seihou-cli-test@. +module Seihou.CLI.AppliedBlueprint + ( recordAppliedBlueprint, + ) +where + +import Seihou.Core.Types (AppliedBlueprint (..)) +import Seihou.Effect.Filesystem (createDirectoryIfMissing) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Manifest.Types (emptyManifest, writeAppliedBlueprint) +import Seihou.Prelude +import System.FilePath (takeDirectory) + +-- | Read the manifest at @manifestPath@, attach the supplied +-- 'AppliedBlueprint' as the project's blueprint provenance, and write +-- the manifest back. If no manifest exists yet, a fresh one is created +-- using the entry's @appliedAt@ timestamp as its @genAt@. +-- +-- Returns @Left err@ when the existing manifest cannot be parsed — +-- callers should leave the manifest untouched in that case rather than +-- silently overwriting a hand-edited file. The directory containing +-- the manifest is created if missing, mirroring the pre-existing +-- @applyBaseline@ flow. +recordAppliedBlueprint :: FilePath -> AppliedBlueprint -> IO (Either Text ()) +recordAppliedBlueprint manifestPath ab = + runEff $ runFilesystem $ runManifestStore manifestPath $ do + createDirectoryIfMissing True (takeDirectory manifestPath) + mManifest <- readManifest + case mManifest of + Right (Just m) -> do + writeManifest (writeAppliedBlueprint ab m) + pure (Right ()) + Right Nothing -> do + writeManifest (writeAppliedBlueprint ab (emptyManifest ab.appliedAt)) + pure (Right ()) + Left err -> pure (Left err) diff --git a/src/Seihou/CLI/BrowseFormat.hs b/src/Seihou/CLI/BrowseFormat.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/BrowseFormat.hs @@ -0,0 +1,105 @@ +module Seihou.CLI.BrowseFormat + ( formatBrowseRegistry, + formatBrowseSingleModule, + formatBrowseSingleBlueprint, + formatBrowseSinglePrompt, + kindLabel, + ) +where + +import Data.Text qualified as T +import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..)) +import Seihou.Core.Types (ModuleName (..)) +import Seihou.Prelude + +-- | Display-string label for an 'EntryKind'. Each label is padded to +-- eleven characters so registry rows line up regardless of which kind +-- appears on a given row. +kindLabel :: EntryKind -> Text +kindLabel ModuleEntry = "[module] " +kindLabel RecipeEntry = "[recipe] " +kindLabel BlueprintEntry = "[blueprint]" +kindLabel PromptEntry = "[prompt] " + +-- | Format browse output for a multi-module registry. Each row begins +-- with a per-kind label so the user can see at a glance whether they are +-- selecting a module, recipe, or blueprint. +formatBrowseRegistry :: Text -> Registry -> [(EntryKind, RegistryEntry)] -> Maybe Text -> Text +formatBrowseRegistry source registry filtered tagFilter = + let header = + registry.repoName + <> "\n" + <> maybe "" (<> "\n") registry.repoDescription + <> "\n" + in if null filtered + then + header + <> ( case tagFilter of + Just tag -> "No entries matching tag '" <> tag <> "'.\n" + Nothing -> "No entries in registry.\n" + ) + else + let nameOf e = let (ModuleName n) = e.name in n + maxNameLen = maximum (map (T.length . nameOf . snd) filtered) + entryLines = T.unlines (map (formatEntry maxNameLen) filtered) + n = length filtered + noun = if n == 1 then "entry" else "entries" + footer = + T.pack (show n) + <> " " + <> noun + <> " available. Install with:\n" + <> " seihou install " + <> source + <> " --module \n" + <> " seihou install " + <> source + <> " --all\n" + in header <> "Available entries:\n\n" <> entryLines <> "\n" <> footer + +-- | Format browse output for a single-module repo. +formatBrowseSingleModule :: Text -> Text -> Maybe Text -> Text +formatBrowseSingleModule source name desc = + name + <> "\n" + <> maybe "" (\d -> " " <> d <> "\n") desc + <> "\n" + <> "Single-module repository. Install with:\n" + <> " seihou install " + <> source + <> "\n" + +-- | Format browse output for a single-blueprint repo. +formatBrowseSingleBlueprint :: Text -> Text -> Maybe Text -> Text +formatBrowseSingleBlueprint source name desc = + name + <> "\n" + <> maybe "" (\d -> " " <> d <> "\n") desc + <> "\n" + <> "Single-blueprint repository. Install with:\n" + <> " seihou install " + <> source + <> "\n" + +-- | Format browse output for a single-prompt repo. +formatBrowseSinglePrompt :: Text -> Text -> Maybe Text -> Text +formatBrowseSinglePrompt source name desc = + name + <> "\n" + <> maybe "" (\d -> " " <> d <> "\n") desc + <> "\n" + <> "Single-prompt repository. Install with:\n" + <> " seihou install " + <> source + <> "\n" + +formatEntry :: Int -> (EntryKind, RegistryEntry) -> Text +formatEntry maxNameLen (kind, entry) = + let (ModuleName name) = entry.name + padding = T.replicate (maxNameLen - T.length name + 3) " " + desc = maybe "" id entry.description + tagsText = + if null entry.tags + then "" + else " [" <> T.intercalate ", " entry.tags <> "]" + in " " <> kindLabel kind <> " " <> name <> padding <> desc <> tagsText diff --git a/src/Seihou/CLI/CommitMessage.hs b/src/Seihou/CLI/CommitMessage.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/CommitMessage.hs @@ -0,0 +1,93 @@ +module Seihou.CLI.CommitMessage + ( generateCommitMessage, + stripCodeFence, + ) +where + +import Control.Exception (SomeException, try) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Core.Types (ModuleName (..)) +import System.Directory (findExecutable) +import System.Exit (ExitCode (..)) +import System.IO (hClose) +import System.Process (CreateProcess (..), StdStream (..), createProcess, proc, waitForProcess) + +-- | Generate a commit message using Claude Code CLI. +-- Takes the module names applied and the staged diff. +-- Returns the AI-generated message, or a fallback if claude is unavailable. +generateCommitMessage :: [ModuleName] -> T.Text -> IO T.Text +generateCommitMessage modNames diffText = do + claudePath <- findExecutable "claude" + case claudePath of + Nothing -> pure (fallbackMessage modNames) + Just _ -> do + result <- callClaude modNames diffText + case result of + Nothing -> pure (fallbackMessage modNames) + Just msg + | T.null (T.strip msg) -> pure (fallbackMessage modNames) + | otherwise -> pure (stripCodeFence (T.strip msg)) + +callClaude :: [ModuleName] -> T.Text -> IO (Maybe T.Text) +callClaude modNames diffText = do + let prompt = buildPrompt modNames diffText + cp = + (proc "claude" ["-p", T.unpack prompt]) + { std_out = CreatePipe, + std_err = CreatePipe, + std_in = NoStream + } + result <- try @SomeException $ do + (_, Just hOut, Just hErr, ph) <- createProcess cp + output <- TIO.hGetContents hOut + _ <- TIO.hGetContents hErr + exitCode <- waitForProcess ph + hClose hOut + hClose hErr + pure (exitCode, output) + case result of + Left _ -> pure Nothing + Right (ExitSuccess, output) -> pure (Just output) + Right (ExitFailure _, _) -> pure Nothing + +buildPrompt :: [ModuleName] -> T.Text -> T.Text +buildPrompt modNames diffText = + T.unlines + [ "Generate a concise git commit message for seihou scaffolding changes.", + "", + "Modules applied: " <> moduleList, + "", + "Staged changes:", + diffText, + "", + "Rules:", + "- Use conventional commit style (e.g., \"feat: ...\", \"chore: ...\")", + "- Keep the subject line under 72 characters", + "- Mention which seihou module(s) were applied", + "- Output ONLY the commit message, nothing else", + "- Do not wrap the output in backticks or code fences" + ] + where + moduleList = T.intercalate ", " (map (.unModuleName) modNames) + +-- | Strip markdown code-fence wrapping (``` ... ```) from text. +-- Handles optional language tags (e.g., ```text). +stripCodeFence :: T.Text -> T.Text +stripCodeFence txt = + let ls = T.lines txt + nonEmpty = filter (not . T.null . T.strip) ls + in case nonEmpty of + (first : rest) + | "```" `T.isPrefixOf` first, + not (null rest), + T.strip (last rest) == "```" -> + let -- Drop the opening fence line and closing fence line + body = drop 1 (take (length ls - 1) ls) + in T.strip (T.unlines body) + _ -> txt + +fallbackMessage :: [ModuleName] -> T.Text +fallbackMessage [] = "seihou: apply modules" +fallbackMessage [m] = "seihou: apply module " <> m.unModuleName +fallbackMessage ms = "seihou: apply modules " <> T.intercalate ", " (map (.unModuleName) ms) diff --git a/src/Seihou/CLI/Completions/Bash.hs b/src/Seihou/CLI/Completions/Bash.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Completions/Bash.hs @@ -0,0 +1,25 @@ +module Seihou.CLI.Completions.Bash + ( generateBashCompletion, + ) +where + +import Data.Text qualified as T +import Seihou.Prelude + +generateBashCompletion :: Text +generateBashCompletion = + T.unlines + [ "_seihou_completions() {", + " local CMDLINE", + " local IFS=$'\\n'", + " CMDLINE=(--bash-completion-index $COMP_CWORD)", + "", + " for arg in ${COMP_WORDS[@]}; do", + " CMDLINE=(${CMDLINE[@]} --bash-completion-word \"$arg\")", + " done", + "", + " COMPREPLY=( $(seihou \"${CMDLINE[@]}\" 2>/dev/null) )", + "}", + "", + "complete -o filenames -F _seihou_completions seihou" + ] diff --git a/src/Seihou/CLI/Completions/Fish.hs b/src/Seihou/CLI/Completions/Fish.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Completions/Fish.hs @@ -0,0 +1,38 @@ +module Seihou.CLI.Completions.Fish + ( generateFishCompletion, + ) +where + +import Data.Text qualified as T +import Seihou.Prelude + +generateFishCompletion :: Text +generateFishCompletion = + T.unlines + [ "# Disable file completion by default", + "complete -c seihou -f", + "", + "function __seihou_complete", + " set -l tokens (commandline -cop)", + " set -l current (commandline -ct)", + " set -l index (count $tokens)", + "", + " set -l args --bash-completion-enriched --bash-completion-index $index", + " for token in $tokens", + " set args $args --bash-completion-word $token", + " end", + " set args $args --bash-completion-word \"$current\"", + "", + " for line in (seihou $args 2>/dev/null)", + " # Split on tab: worddescription", + " set -l parts (string split \\t -- $line)", + " if test (count $parts) -ge 2", + " printf '%s\\t%s\\n' $parts[1] $parts[2]", + " else", + " echo $line", + " end", + " end", + "end", + "", + "complete -c seihou -a '(__seihou_complete)'" + ] diff --git a/src/Seihou/CLI/Completions/Zsh.hs b/src/Seihou/CLI/Completions/Zsh.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Completions/Zsh.hs @@ -0,0 +1,42 @@ +module Seihou.CLI.Completions.Zsh + ( generateZshCompletion, + ) +where + +import Data.Text qualified as T +import Seihou.Prelude + +generateZshCompletion :: Text +generateZshCompletion = + T.unlines + [ "#compdef seihou", + "", + "_seihou() {", + " local -a completions", + " local CMDLINE", + " local IFS=$'\\n'", + "", + " CMDLINE=(--bash-completion-enriched --bash-completion-index $((CURRENT - 1)))", + "", + " for arg in ${words[@]}; do", + " CMDLINE=(${CMDLINE[@]} --bash-completion-word \"$arg\")", + " done", + "", + " local line", + " for line in $(seihou \"${CMDLINE[@]}\" 2>/dev/null); do", + " local word=${line%%$'\\t'*}", + " local desc=${line#*$'\\t'}", + " if [[ \"$word\" != \"$desc\" ]]; then", + " completions+=(\"${word//:/\\\\:}:${desc}\")", + " else", + " completions+=(\"$word\")", + " fi", + " done", + "", + " if [[ ${#completions[@]} -gt 0 ]]; then", + " _describe 'seihou' completions", + " fi", + "}", + "", + "_seihou" + ] diff --git a/src/Seihou/CLI/Diff.hs b/src/Seihou/CLI/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Diff.hs @@ -0,0 +1,80 @@ +module Seihou.CLI.Diff + ( handleDiff, + formatDiffOutput, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Shared (logIO) +import Seihou.CLI.Style (dim, red, useColor, yellow) +import Seihou.Core.Status (computeTrackedFileStatuses) +import Seihou.Core.Types +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.Logger (logError) +import Seihou.Effect.ManifestStore (readManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Prelude +import System.Exit (exitFailure) + +handleDiff :: IO () +handleDiff = do + let manifestPath = ".seihou" "manifest.json" + + result <- runEff $ runFilesystem $ runManifestStore manifestPath $ do + mResult <- readManifest + case mResult of + Left err -> pure (Left err) + Right Nothing -> pure (Right Nothing) + Right (Just manifest) -> do + tracked <- computeTrackedFileStatuses manifest + pure (Right (Just tracked)) + + colorEnabled <- useColor + + case result of + Left err -> do + logIO LogNormal (logError $ "Error reading manifest: " <> err) + exitFailure + Right Nothing -> + TIO.putStrLn "No Seihou manifest found. Run 'seihou run ' to generate a project." + Right (Just tracked) -> + TIO.putStr (formatDiffOutput colorEnabled tracked) + +formatDiffOutput :: Bool -> [TrackedFile] -> Text +formatDiffOutput color tracked = + let modified = filter (\t -> t.status == TfsModified) tracked + deleted = filter (\t -> t.status == TfsDeleted) tracked + unchanged = filter (\t -> t.status == TfsUnchanged) tracked + nMod = length modified + nDel = length deleted + nUnch = length unchanged + changed = modified ++ deleted + in if null changed + then "No changes since last generation.\n" + else + let maxPathLen = maximum (map (length . (.path)) changed) + header = "Seihou Diff:\n" + fileLines = map (formatLine color maxPathLen) changed + summary = + " " + <> T.pack (show nUnch) + <> " unchanged, " + <> T.pack (show nMod) + <> " modified, " + <> T.pack (show nDel) + <> " deleted\n" + in header <> "\n" <> T.unlines fileLines <> "\n" <> summary + +formatLine :: Bool -> Int -> TrackedFile -> Text +formatLine color maxPathLen tf = + let (label, colorFn) = case tf.status of + TfsModified -> ("modified", yellow) + TfsDeleted -> ("deleted ", red) + TfsUnchanged -> ("unchanged", dim) + path = T.pack tf.path + modName = tf.moduleName.unModuleName + paddedLabel = if color then colorFn label else label + paddedPath = path <> T.replicate (maxPathLen - T.length path + 3) " " + modAttr = if color then dim ("(" <> modName <> ")") else "(" <> modName <> ")" + in " " <> paddedLabel <> " " <> paddedPath <> modAttr diff --git a/src/Seihou/CLI/Extension.hs b/src/Seihou/CLI/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Extension.hs @@ -0,0 +1,57 @@ +module Seihou.CLI.Extension + ( ExtensionRunOpts (..), + ExtensionRunError (..), + extensionExecutableName, + runExtension, + handleExtensionRun, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.Prelude +import System.Directory (findExecutable) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) +import System.Process (rawSystem) + +data ExtensionRunOpts = ExtensionRunOpts + { extensionName :: Text, + extensionArgs :: [String] + } + deriving stock (Eq, Show) + +data ExtensionRunError + = ExtensionNotFound Text String + | ExtensionExited Text ExitCode + deriving stock (Eq, Show) + +extensionExecutableName :: Text -> String +extensionExecutableName name = + "seihou-" <> T.unpack name <> "-extension" + +runExtension :: ExtensionRunOpts -> IO (Either ExtensionRunError ()) +runExtension opts = do + let exeName = extensionExecutableName opts.extensionName + found <- findExecutable exeName + case found of + Nothing -> + pure (Left (ExtensionNotFound opts.extensionName exeName)) + Just exePath -> do + code <- rawSystem exePath opts.extensionArgs + pure $ case code of + ExitSuccess -> Right () + failure -> Left (ExtensionExited opts.extensionName failure) + +handleExtensionRun :: ExtensionRunOpts -> IO () +handleExtensionRun opts = do + result <- runExtension opts + case result of + Right () -> + pure () + Left (ExtensionNotFound _ exeName) -> do + hPutStrLn stderr ("error: extension executable not found: " <> exeName) + exitWith (ExitFailure 127) + Left (ExtensionExited name code) -> do + TIO.hPutStrLn stderr ("error: extension '" <> name <> "' exited with " <> T.pack (show code)) + exitWith code diff --git a/src/Seihou/CLI/Git.hs b/src/Seihou/CLI/Git.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Git.hs @@ -0,0 +1,49 @@ +module Seihou.CLI.Git + ( isGitRepo, + gitAdd, + gitCommit, + gitDiffCached, + gitCheckIgnore, + ) +where + +import Data.Text qualified as T +import Seihou.Effect.Process (Process, runProcess) +import Seihou.Prelude +import System.Exit (ExitCode (..)) + +-- | Check if the current directory is inside a git work tree. +isGitRepo :: (Process :> es) => Eff es Bool +isGitRepo = do + (exitCode, _, _) <- runProcess "git" ["rev-parse", "--is-inside-work-tree"] Nothing + pure (exitCode == ExitSuccess) + +-- | Stage specific files. +gitAdd :: (Process :> es) => [FilePath] -> Eff es (ExitCode, Text, Text) +gitAdd paths = + runProcess "git" ("add" : map T.pack paths) Nothing + +-- | Create a commit with the given message. +gitCommit :: (Process :> es) => Text -> Eff es (ExitCode, Text, Text) +gitCommit msg = + runProcess "git" ["commit", "-m", msg] Nothing + +-- | Check which files are ignored by git. Returns the subset of input paths +-- that are covered by .gitignore rules. +gitCheckIgnore :: (Process :> es) => [FilePath] -> Eff es [FilePath] +gitCheckIgnore [] = pure [] +gitCheckIgnore paths = do + (exitCode, stdout', _) <- runProcess "git" ("check-ignore" : map T.pack paths) Nothing + case exitCode of + ExitSuccess -> pure (map T.unpack $ filter (not . T.null) $ T.lines stdout') + _ -> pure [] -- exit 1 = no matches, exit 128 = error; both → empty + +-- | Get the diff of staged changes for feeding to the commit message generator. +-- Returns a stat summary followed by the full diff (truncated to ~4000 chars). +gitDiffCached :: (Process :> es) => Eff es Text +gitDiffCached = do + (_, stat, _) <- runProcess "git" ["diff", "--cached", "--stat"] Nothing + (_, fullDiff, _) <- runProcess "git" ["diff", "--cached"] Nothing + let truncatedDiff = T.take 4000 fullDiff + suffix = if T.length fullDiff > 4000 then "\n... (diff truncated)" else "" + pure (stat <> "\n" <> truncatedDiff <> suffix) diff --git a/src/Seihou/CLI/Init.hs b/src/Seihou/CLI/Init.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Init.hs @@ -0,0 +1,76 @@ +module Seihou.CLI.Init + ( handleInit, + formatInitOutput, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Shared (shortenHome) +import Seihou.Prelude +import System.Directory + ( XdgDirectory (..), + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + getXdgDirectory, + ) + +handleInit :: IO () +handleInit = do + base <- getXdgDirectory XdgConfig "seihou" + createDirectoryIfMissing True base + + -- config.dhall + let configPath = base "config.dhall" + configExists <- doesFileExist configPath + if configExists + then pure () + else writeFile configPath defaultConfig + let configCreated = not configExists + + -- modules/ + modulesExists <- doesDirectoryExist (base "modules") + createDirectoryIfMissing True (base "modules") + let modulesCreated = not modulesExists + + -- installed/ + installedExists <- doesDirectoryExist (base "installed") + createDirectoryIfMissing True (base "installed") + let installedCreated = not installedExists + + -- namespaces/ (internal, not reported) + createDirectoryIfMissing True (base "namespaces") + + -- contexts/ (internal, not reported) + createDirectoryIfMissing True (base "contexts") + + -- Output + basePath <- shortenHome base + let items = + [ ("config.dhall", "global defaults", configCreated), + ("modules/", "user modules", modulesCreated), + ("installed/", "git-installed modules", installedCreated) + ] + TIO.putStr (formatInitOutput basePath items) + +-- | Format the init command output. Takes the abbreviated base path and a list +-- of @(item, description, wasCreated)@ triples. +formatInitOutput :: Text -> [(Text, Text, Bool)] -> Text +formatInitOutput basePath items = + T.unlines $ + ("Initialized Seihou configuration at " <> basePath <> "/") + : map formatItem items + where + formatItem (item, desc, created) = + let label = if created then "Created:" else "Exists: " + in " " <> label <> " " <> item <> " (" <> desc <> ")" + +defaultConfig :: String +defaultConfig = + unlines + [ "-- Seihou global configuration", + "-- Add variable defaults that apply to all modules.", + "-- Example: { `project.name` = \"my-app\", `license` = \"MIT\" }", + "{=}" + ] diff --git a/src/Seihou/CLI/InstallHistory.hs b/src/Seihou/CLI/InstallHistory.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/InstallHistory.hs @@ -0,0 +1,106 @@ +module Seihou.CLI.InstallHistory + ( HistoryEntry (..), + InstallHistory (..), + readHistory, + readHistoryFrom, + writeHistory, + writeHistoryTo, + recordUrl, + recordUrlTo, + maxHistoryEntries, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecodeStrict', object, withObject, (.:), (.=)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) +import Seihou.Prelude +import System.Directory + ( XdgDirectory (..), + createDirectoryIfMissing, + doesFileExist, + getXdgDirectory, + ) +import System.FilePath (takeDirectory) + +-- | A single entry in the install URL history. +data HistoryEntry = HistoryEntry + { url :: Text, + lastUsed :: Text + } + deriving stock (Eq, Show) + +instance ToJSON HistoryEntry where + toJSON e = object ["url" .= e.url, "lastUsed" .= e.lastUsed] + +instance FromJSON HistoryEntry where + parseJSON = withObject "HistoryEntry" $ \o -> + HistoryEntry <$> o .: "url" <*> o .: "lastUsed" + +-- | The full install history. +newtype InstallHistory = InstallHistory + { entries :: [HistoryEntry] + } + deriving stock (Eq, Show) + +instance ToJSON InstallHistory where + toJSON h = object ["entries" .= h.entries] + +instance FromJSON InstallHistory where + parseJSON = withObject "InstallHistory" $ \o -> + InstallHistory <$> o .: "entries" + +-- | Maximum number of history entries to retain. +maxHistoryEntries :: Int +maxHistoryEntries = 50 + +-- | Path to the history file: ~/.config/seihou/install-history.json +historyFilePath :: IO FilePath +historyFilePath = do + base <- getXdgDirectory XdgConfig "seihou" + pure (base "install-history.json") + +-- | Read history from the XDG config path. Returns empty on missing/malformed file. +readHistory :: IO InstallHistory +readHistory = historyFilePath >>= readHistoryFrom + +-- | Read history from a specific file path (for testing). +readHistoryFrom :: FilePath -> IO InstallHistory +readHistoryFrom path = do + exists <- doesFileExist path + if not exists + then pure (InstallHistory []) + else do + bs <- BS.readFile path + case eitherDecodeStrict' bs of + Left _ -> pure (InstallHistory []) + Right h -> pure h + +-- | Write history to the XDG config path. +writeHistory :: InstallHistory -> IO () +writeHistory history = historyFilePath >>= \path -> writeHistoryTo path history + +-- | Write history to a specific file path (for testing). +writeHistoryTo :: FilePath -> InstallHistory -> IO () +writeHistoryTo path history = do + createDirectoryIfMissing True (takeDirectory path) + LBS.writeFile path (encodePretty history) + +-- | Record a URL after successful install. Deduplicates, sorts recent-first, caps at 50. +recordUrl :: Text -> IO () +recordUrl url = historyFilePath >>= \path -> recordUrlTo path url + +-- | Record a URL to a specific history file (for testing). +recordUrlTo :: FilePath -> Text -> IO () +recordUrlTo path url = do + now <- getCurrentTime + history <- readHistoryFrom path + let timestamp = T.pack (iso8601Show now) + newEntry = HistoryEntry {url = url, lastUsed = timestamp} + filtered = filter (\e -> e.url /= url) history.entries + updated = take maxHistoryEntries (newEntry : filtered) + writeHistoryTo path (InstallHistory updated) diff --git a/src/Seihou/CLI/InstallShared.hs b/src/Seihou/CLI/InstallShared.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/InstallShared.hs @@ -0,0 +1,147 @@ +module Seihou.CLI.InstallShared + ( -- * Origin metadata + OriginInfo (..), + OriginMeta (..), + readOriginInfo, + + -- * Install primitives + installModuleDir, + cloneRepo, + copyDirectoryRecursive, + ) +where + +import Control.Monad (when) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Time (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) +import Seihou.CLI.Shared (logIO) +import Seihou.Core.Types (LogLevel (..)) +import Seihou.Effect.Logger (logWarn) +import Seihou.Prelude +import System.Directory + ( XdgDirectory (..), + copyFile, + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + getXdgDirectory, + listDirectory, + removeDirectoryRecursive, + ) +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) + +-- ---------------------------------------------------------------------------- +-- Origin metadata +-- ---------------------------------------------------------------------------- + +-- | Read side of @.seihou-origin.json@. Tolerates files written by older +-- 'seihou install' runs that may have been missing optional fields. +data OriginInfo = OriginInfo + { sourceUrl :: Text, + repoName :: Maybe Text, + version :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON OriginInfo where + parseJSON = withObject "OriginInfo" $ \v -> + OriginInfo <$> v .: "sourceUrl" <*> v .:? "repoName" <*> v .:? "version" + +-- | Read and parse @.seihou-origin.json@ at the given installed-module +-- directory. Returns 'Nothing' if the file is absent or unparseable. +readOriginInfo :: FilePath -> IO (Maybe OriginInfo) +readOriginInfo installedDir = do + let path = installedDir ".seihou-origin.json" + exists <- doesFileExist path + if not exists + then pure Nothing + else do + bs <- LBS.readFile path + pure (Aeson.decode bs) + +-- | Write side of @.seihou-origin.json@. Captures everything 'seihou +-- install' / 'seihou upgrade' want to record at install time, including +-- the timestamp. +data OriginMeta = OriginMeta + { sourceUrl :: Text, + repoName :: Maybe Text, + installedAt :: Text, + version :: Maybe Text, + tags :: [Text] + } + +instance ToJSON OriginMeta where + toJSON m = + object + [ "sourceUrl" .= m.sourceUrl, + "repoName" .= m.repoName, + "installedAt" .= m.installedAt, + "version" .= m.version, + "tags" .= m.tags + ] + +-- ---------------------------------------------------------------------------- +-- Install primitives +-- ---------------------------------------------------------------------------- + +-- | Copy a module directory to @~/.config/seihou/installed/@, +-- replacing any existing installation, and write origin metadata. The +-- source directory must already contain the module's files; this +-- function does not clone or fetch. +installModuleDir :: FilePath -> String -> Text -> Maybe Text -> Maybe Text -> [Text] -> IO () +installModuleDir moduleDir name source registryName moduleVersion moduleTags = do + xdgConfig <- getXdgDirectory XdgConfig "seihou" + let installDir = xdgConfig "installed" name + + exists <- doesDirectoryExist installDir + when exists $ do + logIO LogNormal (logWarn $ "overwriting existing installation of '" <> T.pack name <> "'") + removeDirectoryRecursive installDir + + createDirectoryIfMissing True installDir + copyDirectoryRecursive moduleDir installDir + + now <- getCurrentTime + let origin = OriginMeta source registryName (T.pack (iso8601Show now)) moduleVersion moduleTags + LBS.writeFile (installDir ".seihou-origin.json") (encodePretty origin) + +-- | Recursively copy a directory tree, excluding the @.git@ directory. +copyDirectoryRecursive :: FilePath -> FilePath -> IO () +copyDirectoryRecursive src dst = do + entries <- listDirectory src + mapM_ (copyEntry src dst) entries + where + copyEntry s d entry + | entry == ".git" = pure () + | otherwise = do + let srcPath = s entry + dstPath = d entry + isDir <- doesDirectoryExist srcPath + if isDir + then do + createDirectoryIfMissing True dstPath + copyDirectoryRecursive srcPath dstPath + else copyFile srcPath dstPath + +-- | Clone a git repo shallowly into the target directory. Returns 'Left' +-- with a human-readable message on failure (the caller decides how to +-- recover or report). On success returns 'Right ()' with no progress +-- chatter; the caller is expected to print whatever progress message +-- fits its UX. +cloneRepo :: Text -> FilePath -> IO (Either Text ()) +cloneRepo source cloneDir = do + (exitCode, _stdout, stderr) <- + readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack source, cloneDir] "" + case exitCode of + ExitFailure _ -> + pure + ( Left $ + "git clone failed for '" <> source <> "': " <> T.pack stderr + ) + ExitSuccess -> pure (Right ()) diff --git a/src/Seihou/CLI/List.hs b/src/Seihou/CLI/List.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/List.hs @@ -0,0 +1,290 @@ +module Seihou.CLI.List + ( handleList, + formatListOutput, + formatListOutputEntries, + applyFilters, + ListFilter (..), + Entry (..), + runnableToEntryWithOrigin, + ) +where + +import Data.Aeson (FromJSON (..), withObject, (.:?)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Shared (shortenHome) +import Seihou.CLI.Style (dim, red, useColor) +import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables) +import Seihou.Core.Types +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Origin metadata read from @.seihou-origin.json@. +data OriginInfo = OriginInfo + { originRepoName :: Maybe Text, + originVersion :: Maybe Text, + originTags :: [Text] + } + +instance FromJSON OriginInfo where + parseJSON = withObject "OriginInfo" $ \v -> + OriginInfo <$> v .:? "repoName" <*> v .:? "version" <*> (fromMaybe [] <$> v .:? "tags") + +-- | Filter criteria for the list command. Defined here (rather than +-- imported from Commands) so the internal library does not depend on +-- optparse-applicative. +data ListFilter = ListFilter + { filterRepo :: Maybe Text, + filterTag :: Maybe Text, + filterKinds :: [RunnableKind] + } + deriving stock (Eq, Show) + +noFilter :: ListFilter +noFilter = ListFilter Nothing Nothing [] + +handleList :: ListFilter -> IO () +handleList listOpts = do + searchPaths <- defaultSearchPaths + runnables <- discoverAllRunnables searchPaths + colorEnabled <- useColor + shortenedPaths <- mapM shortenHome searchPaths + -- Read origin metadata for installed items + origins <- Map.fromList <$> mapM readRunnableOrigin runnables + let entries = map (runnableToEntryWithOrigin origins) runnables + filtered = applyFilters listOpts entries + TIO.putStr (formatListOutputEntries colorEnabled filtered shortenedPaths listOpts) + +readOrigin :: DiscoveredModule -> IO (FilePath, Maybe OriginInfo) +readOrigin dm = do + let originFile = dm.discoveredDir ".seihou-origin.json" + exists <- doesFileExist originFile + if exists + then do + bs <- LBS.readFile originFile + case Aeson.decode bs of + Just info -> pure (dm.discoveredDir, Just info) + Nothing -> pure (dm.discoveredDir, Nothing) + else pure (dm.discoveredDir, Nothing) + +readRunnableOrigin :: DiscoveredRunnable -> IO (FilePath, Maybe OriginInfo) +readRunnableOrigin dr = do + let originFile = dr.drDir ".seihou-origin.json" + exists <- doesFileExist originFile + if exists + then do + bs <- LBS.readFile originFile + case Aeson.decode bs of + Just info -> pure (dr.drDir, Just info) + Nothing -> pure (dr.drDir, Nothing) + else pure (dr.drDir, Nothing) + +runnableToEntryWithOrigin :: Map FilePath (Maybe OriginInfo) -> DiscoveredRunnable -> Entry +runnableToEntryWithOrigin origins dr = + let (originName, originVer, originTags) = case Map.lookup dr.drDir origins of + Just (Just info) -> (info.originRepoName, info.originVersion, info.originTags) + _ -> (Nothing, Nothing, []) + srcLabel = sourceLabelWithOrigin dr.drSource originName originVer + kindSuffix = case dr.drKind of + KindModule -> "" + KindRecipe -> " [recipe]" + KindBlueprint -> " [blueprint]" + KindPrompt -> " [prompt]" + in if dr.drIsError + then + Entry + { entryName = dr.drName, + entryDesc = "[error: " <> fromMaybe "unknown" dr.drError <> "]", + entrySource = srcLabel <> kindSuffix, + entryIsError = True, + entryRepoName = originName, + entryTags = originTags, + entryKind = dr.drKind + } + else + Entry + { entryName = dr.drName, + entryDesc = fromMaybe "(no description)" dr.drDescription, + entrySource = srcLabel <> kindSuffix, + entryIsError = False, + entryRepoName = originName, + entryTags = originTags, + entryKind = dr.drKind + } + +-- | Format list output — backward-compatible version without origin info. +-- Used by tests that construct DiscoveredModule values directly. +formatListOutput :: Bool -> [DiscoveredModule] -> [Text] -> Text +formatListOutput color modules searchPaths = + let entries = map toEntry modules + in formatListOutputEntries color entries searchPaths noFilter + +formatListOutputEntries :: Bool -> [Entry] -> [Text] -> ListFilter -> Text +formatListOutputEntries color entries searchPaths listOpts + | null entries = + -- With nothing to show, the kind comes from the active filter (if any). + "No " + <> pluralize 0 (summaryNoun listOpts.filterKinds) + <> " found." + <> filterSuffix + <> "\n\nSearched:\n" + <> T.unlines (map (" " <>) searchPaths) + | otherwise = + let maxNameLen = maximum (map (T.length . (.entryName)) entries) + maxDescLen = maximum (map (T.length . (.entryDesc)) entries) + header = "Available modules, recipes, blueprints, and prompts:\n" + fileLines = map (formatEntry color maxNameLen maxDescLen) entries + n = length entries + nSources = length searchPaths + -- The count noun reflects the kinds actually shown: a single shared + -- kind names that kind; a mix falls back to the neutral "item". + noun = pluralize n (summaryNoun (map (.entryKind) entries)) + summary = + T.pack (show n) + <> " " + <> noun + <> " found (" + <> T.pack (show nSources) + <> " sources searched)" + <> filterSuffix + <> "\n" + in header <> "\n" <> T.unlines fileLines <> "\n" <> summary + where + filterSuffix = formatFilterSuffix listOpts + +-- | Choose the singular base noun for a set of kinds. When every kind is the +-- same, name it ("module", "recipe", "blueprint"); when the set is empty or +-- mixed, fall back to the neutral "item". +summaryNoun :: [RunnableKind] -> Text +summaryNoun kinds = case kinds of + [] -> "item" + (k : ks) + | all (== k) ks -> kindBase k + | otherwise -> "item" + where + kindBase KindModule = "module" + kindBase KindRecipe = "recipe" + kindBase KindBlueprint = "blueprint" + kindBase KindPrompt = "prompt" + +-- | Append @s@ to a singular noun unless the count is exactly one. +pluralize :: Int -> Text -> Text +pluralize n base = if n == 1 then base else base <> "s" + +-- | Build a display suffix describing the active filters, e.g. +-- @" [filtered: repo=foo, tag=bar]"@. Returns empty text when no filters +-- are active. +formatFilterSuffix :: ListFilter -> Text +formatFilterSuffix opts = + let parts = + maybe [] (\r -> ["repo=" <> r]) opts.filterRepo + <> maybe [] (\t -> ["tag=" <> t]) opts.filterTag + <> kindPart + kindPart = case opts.filterKinds of + [] -> [] + ks -> ["kind=" <> T.intercalate "+" (map kindNoun ks)] + in if null parts + then "" + else " [filtered: " <> T.intercalate ", " parts <> "]" + where + kindNoun KindModule = "module" + kindNoun KindRecipe = "recipe" + kindNoun KindBlueprint = "blueprint" + kindNoun KindPrompt = "prompt" + +-- | Apply repo and tag filters to a list of entries. Both filters combine +-- with AND: an entry must match all active filters to be included. +applyFilters :: ListFilter -> [Entry] -> [Entry] +applyFilters opts = filter match + where + match entry = repoMatch entry && tagMatch entry && kindMatch entry + repoMatch entry = case opts.filterRepo of + Nothing -> True + Just r -> entry.entryRepoName == Just r + tagMatch entry = case opts.filterTag of + Nothing -> True + Just t -> t `elem` entry.entryTags + kindMatch entry = case opts.filterKinds of + [] -> True + ks -> entry.entryKind `elem` ks + +data Entry = Entry + { entryName :: Text, + entryDesc :: Text, + entrySource :: Text, + entryIsError :: Bool, + entryRepoName :: Maybe Text, + entryTags :: [Text], + entryKind :: RunnableKind + } + deriving stock (Eq, Show) + +toEntry :: DiscoveredModule -> Entry +toEntry = toEntryWithOrigin Map.empty + +toEntryWithOrigin :: Map FilePath (Maybe OriginInfo) -> DiscoveredModule -> Entry +toEntryWithOrigin origins dm = + let (originName, originVer, originTags) = case Map.lookup dm.discoveredDir origins of + Just (Just info) -> (info.originRepoName, info.originVersion, info.originTags) + _ -> (Nothing, Nothing, []) + srcLabel = sourceLabelWithOrigin dm.discoveredSource originName originVer + in case dm.discoveredResult of + Right m -> + Entry + { entryName = m.name.unModuleName, + entryDesc = maybe "(no description)" id m.description, + entrySource = srcLabel, + entryIsError = False, + entryRepoName = originName, + entryTags = originTags, + entryKind = KindModule + } + Left err -> + Entry + { entryName = dirName dm.discoveredDir, + entryDesc = "[error: " <> briefError err <> "]", + entrySource = srcLabel, + entryIsError = True, + entryRepoName = originName, + entryTags = originTags, + entryKind = KindModule + } + +sourceLabelWithOrigin :: ModuleSource -> Maybe Text -> Maybe Text -> Text +sourceLabelWithOrigin SourceProject _ _ = "project" +sourceLabelWithOrigin SourceUser _ _ = "user" +sourceLabelWithOrigin SourceInstalled Nothing Nothing = "installed" +sourceLabelWithOrigin SourceInstalled (Just rn) Nothing = "installed: " <> rn +sourceLabelWithOrigin SourceInstalled (Just rn) (Just v) = "installed: " <> rn <> " v" <> v +sourceLabelWithOrigin SourceInstalled Nothing (Just v) = "installed v" <> v + +dirName :: FilePath -> Text +dirName path = case reverse (T.splitOn "/" (T.pack path)) of + (name : _) -> name + [] -> T.pack path + +briefError :: ModuleLoadError -> Text +briefError (DhallEvalError _ _) = "Dhall evaluation failed" +briefError (DhallDecodeError _ _) = "Dhall decode failed" +briefError (ValidationError _ _) = "validation failed" +briefError (ModuleNotFound _ _) = "not found" +briefError (MissingSourceFile _ _) = "missing source file" +briefError (CircularDependency _) = "circular dependency" +briefError (RegistryEvalError _ _) = "registry eval failed" + +formatEntry :: Bool -> Int -> Int -> Entry -> Text +formatEntry color maxNameLen maxDescLen entry = + let name = entry.entryName + desc = entry.entryDesc + src = entry.entrySource + paddedName = name <> T.replicate (maxNameLen - T.length name + 3) " " + paddedDesc = desc <> T.replicate (maxDescLen - T.length desc + 3) " " + srcTag = "(" <> src <> ")" + colorDesc = if color && entry.entryIsError then red desc else desc + colorSrc = if color then dim srcTag else srcTag + colorPaddedDesc = colorDesc <> T.replicate (maxDescLen - T.length desc + 3) " " + in " " <> paddedName <> (if color && entry.entryIsError then colorPaddedDesc else paddedDesc) <> colorSrc diff --git a/src/Seihou/CLI/Migrate.hs b/src/Seihou/CLI/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Migrate.hs @@ -0,0 +1,808 @@ +module Seihou.CLI.Migrate + ( -- * Options + MigrateOpts (..), + + -- * Handlers + handleMigrate, + runMigrate, + MigrateError (..), + MigrateResult (..), + + -- * Helpers for upgrade/status integration + pendingChainFor, + + -- * Auto-commit helper + commitMigratedFiles, + ) +where + +import Control.Monad (unless, when) +import Data.Aeson (ToJSON, object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Time.Clock (getCurrentTime) +import Effectful (runEff) +import GHC.Generics (Generic) +import Seihou.CLI.CommitMessage (generateCommitMessage) +import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) +import Seihou.CLI.InstallShared + ( OriginInfo (..), + cloneRepo, + installModuleDir, + readOriginInfo, + ) +import Seihou.CLI.Style (bold, dim, green, red, useColor, yellow) +import Seihou.Core.Migration + ( Migration (..), + MigrationOp (..), + MigrationPlan (..), + MigrationPlanError (..), + planMigrationChain, + ) +import Seihou.Core.Registry + ( Registry (..), + RegistryEntry (..), + RepoContents (..), + discoverRepoContents, + ) +import Seihou.Core.Types + ( AppliedModule (..), + Manifest (..), + Module (..), + ModuleName (..), + ) +import Seihou.Core.Version (Version, parseVersion, renderVersion) +import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.ManifestStore (readManifest, writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Effect.ProcessInterp (runProcessIO) +import Seihou.Engine.Migrate + ( ExecutedMigrationPlan (..), + MigrationExecError (..), + MigrationFileStatus (..), + MigrationOpInstance (..), + classifyMigration, + executeMigration, + ) +import Seihou.Prelude +import System.Directory (doesFileExist) +import System.Exit (ExitCode (..), exitFailure, exitSuccess) +import System.FilePath (takeFileName, ()) +import System.IO (stderr) +import System.IO.Temp (withSystemTempDirectory) + +-- ---------------------------------------------------------------------------- +-- Options +-- ---------------------------------------------------------------------------- + +-- | Options for @seihou migrate@: applies module-declared migrations to +-- the current project's working tree and manifest. +data MigrateOpts = MigrateOpts + { migrateModule :: ModuleName, + -- | Override the target version. Defaults to the installed + -- module's current version (i.e. "migrate up to where the + -- installed copy is now"). Under the gap-tolerant planner, the + -- target is just the manifest's landing version: every declared + -- migration whose @to@ does not exceed the target is applied, + -- and the manifest advances to the target on success. + migrateTo :: Maybe Text, + migrateDryRun :: Bool, + -- | Proceed even when the plan touches files the user has edited + -- since they were generated. Mirrors @seihou remove --force@. + migrateForce :: Bool, + migrateJson :: Bool, + migrateVerbose :: Bool, + -- | Skip the default fetch-and-refresh step that clones the module's + -- source repo and refreshes @~/.config/seihou/installed//@ + -- before planning the chain. When 'True', the command performs no + -- network IO and uses only the locally installed copy as the source + -- of truth. Default: 'False' (fetch is the new default after EP-2; + -- before EP-2 the only behavior was local-only). + migrateNoFetch :: Bool, + -- | When 'True', and only on success branches that mutated the + -- project's working tree, stage the touched files plus + -- @.seihou/manifest.json@ and create a git commit. The commit + -- message is supplied by 'migrateCommitMessage' if set, otherwise + -- generated by 'Seihou.CLI.CommitMessage.generateCommitMessage'. + -- Has no effect for dry-run or no-op outcomes. Has no effect + -- outside a git work tree. + migrateCommit :: Bool, + -- | Custom commit message; implies @migrateCommit = True@. + -- When 'Nothing', the AI-generated message is used. + migrateCommitMessage :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +-- ---------------------------------------------------------------------------- +-- Errors and results +-- ---------------------------------------------------------------------------- + +-- | Reasons the @seihou migrate@ handler exits non-zero. Each variant +-- carries a human-readable message that the IO shell prints and uses +-- as its error message. +data MigrateError + = MigrateNoManifest FilePath + | MigrateModuleNotApplied ModuleName + | MigrateNoRecordedVersion ModuleName + | MigrateInstalledModuleEvalFailed FilePath Text + | MigrateInstalledModuleHasNoVersion ModuleName FilePath + | MigrateUnparseableInstalledVersion Text + | MigrateUnparseableTargetVersion Text + | MigrateUnparseableManifestVersion Text + | MigratePlanFailed MigrationPlanError + | MigrateExecFailed MigrationExecError + deriving stock (Eq, Show, Generic) + +-- | Outcome of a successful @runMigrate@ call. +-- +-- Three shapes only: +-- +-- * 'MigrateNoOp' — the manifest already records the target version; +-- no work to do. +-- * 'MigrateApplied' — the manifest advanced from @from@ to @to@. +-- The carried 'ExecutedMigrationPlan' lists every step that +-- actually ran; it may be empty (a pure version bump where no +-- declared migration falls in the @[from, to]@ window). +-- * 'MigrateDryRunOK' — dry-run companion of 'MigrateApplied'. +data MigrateResult + = MigrateNoOp Version + | MigrateApplied ExecutedMigrationPlan Manifest Version Version + | MigrateDryRunOK ExecutedMigrationPlan Version Version + deriving stock (Eq, Show, Generic) + +-- ---------------------------------------------------------------------------- +-- IO shell +-- ---------------------------------------------------------------------------- + +-- | The IO entry point dispatched from @main@. Loads the manifest, +-- delegates planning + execution to 'runMigrate' (which handles the +-- fetch-and-refresh dance unless @--no-fetch@ was passed), and renders +-- the result. +handleMigrate :: MigrateOpts -> IO () +handleMigrate opts = do + let manifestPath = ".seihou" "manifest.json" + modName = opts.migrateModule + + manifestRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest + manifest <- case manifestRes of + Left err -> die (MigrateNoManifest (T.unpack err)) + Right Nothing -> die (MigrateNoManifest manifestPath) + Right (Just m) -> pure m + + applied <- case findApplied manifest modName of + Nothing -> die (MigrateModuleNotApplied modName) + Just am -> pure am + + _fromV <- case applied.moduleVersion >>= parseVersion of + Just v -> pure v + Nothing -> case applied.moduleVersion of + Nothing -> die (MigrateNoRecordedVersion modName) + Just t -> die (MigrateUnparseableManifestVersion t) + + result <- runMigrate opts manifest applied.source + + colorEnabled <- useColor + case result of + Left err -> die err + Right (MigrateNoOp toV) -> do + TIO.putStrLn $ + applyColor colorEnabled green "✓" + <> " " + <> modName.unModuleName + <> " is already at version " + <> renderVersion toV + <> "; nothing to do." + exitSuccess + Right (MigrateDryRunOK plan fromV toV) -> do + if opts.migrateJson + then LBS.putStr (encodePretty (planToJson plan)) + else do + renderPlan colorEnabled plan fromV toV + TIO.putStrLn "" + TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)" + exitSuccess + Right (MigrateApplied plan manifest' fromV toV) -> do + if opts.migrateJson + then LBS.putStr (encodePretty (planToJson plan)) + else renderPlan colorEnabled plan fromV toV + runEff $ + runFilesystem $ + runManifestStore manifestPath $ + writeManifest manifest' + when (opts.migrateCommit || isJust opts.migrateCommitMessage) $ + commitMigratedFiles opts manifestPath plan + unless opts.migrateJson $ do + TIO.putStrLn "" + TIO.putStrLn $ + applyColor colorEnabled green "✓" + <> " Migrated " + <> applyColor colorEnabled bold modName.unModuleName + <> " " + <> renderVersion fromV + <> " → " + <> renderVersion toV + <> "." + +-- | The non-IO core of the handler. Useful as a building block for +-- other CLI surfaces (e.g. @seihou upgrade --with-migrations@) that +-- already have a manifest and an installed-module dir in hand. +-- +-- Behavior depends on @opts.migrateNoFetch@: +-- +-- * @True@ — operate purely on the supplied @installedDir@. This is +-- the legacy behavior used by @seihou upgrade --with-migrations@, +-- which has already refreshed the installed copy. +-- * @False@ (default) — read @\/.seihou-origin.json@, +-- clone the source repository shallowly, use the clone's module +-- dir as the source of truth for planning the chain, and on a +-- successful non-dry-run application refresh @installedDir@ from +-- the clone via 'installModuleDir'. Failures (missing origin file, +-- clone failure, module not present in remote) silently fall back +-- to the local-only path. +runMigrate :: + MigrateOpts -> + Manifest -> + -- | Installed-module directory, the path that holds @module.dhall@ + FilePath -> + IO (Either MigrateError MigrateResult) +runMigrate opts manifest installedDir + | opts.migrateNoFetch = runMigrateLocal opts manifest installedDir + | otherwise = runMigrateWithFetch opts manifest installedDir + +-- | Plan and (optionally) execute a migration chain using @sourceDir@ +-- as the source of truth for the module's @module.dhall@ and migrations +-- list. Performs no network IO. +runMigrateLocal :: + MigrateOpts -> + Manifest -> + -- | Directory holding the module's @module.dhall@ — either the + -- locally installed copy or a freshly cloned moduleDir. + FilePath -> + IO (Either MigrateError MigrateResult) +runMigrateLocal opts manifest sourceDir = do + let modName = opts.migrateModule + case findApplied manifest modName of + Nothing -> pure (Left (MigrateModuleNotApplied modName)) + Just applied -> case applied.moduleVersion of + Nothing -> pure (Left (MigrateNoRecordedVersion modName)) + Just fromText -> + case parseVersion fromText of + Nothing -> pure (Left (MigrateUnparseableManifestVersion fromText)) + Just fromV -> do + let sourceDhall = sourceDir "module.dhall" + exists <- doesFileExist sourceDhall + if not exists + then + pure + ( Left + ( MigrateInstalledModuleEvalFailed + sourceDhall + "module.dhall not found at installed dir" + ) + ) + else do + r <- evalModuleFromFile sourceDhall + case r of + Left err -> + pure + ( Left + ( MigrateInstalledModuleEvalFailed + sourceDhall + (T.pack (show err)) + ) + ) + Right sourceModule -> case resolveTarget opts sourceModule modName sourceDhall of + Left e -> pure (Left e) + Right toV -> + case planMigrationChain + modName.unModuleName + sourceModule.migrations + fromV + toV of + Left e -> pure (Left (MigratePlanFailed e)) + Right Nothing -> pure (Right (MigrateNoOp toV)) + Right (Just plan) -> + dispatchPlan opts manifest plan + +-- | The fetch-and-refresh wrapper. Reads @\/.seihou-origin.json@, +-- clones the source repo to a temp dir, locates the module within the +-- clone, and dispatches to 'runMigrateLocal' with the cloned module +-- dir. On a successful non-dry-run apply, refreshes @installedDir@ +-- from the clone so the next @seihou status@/@migrate@ call sees the +-- new version locally. +-- +-- Any soft failure in the fetch path (missing origin metadata, clone +-- failure, module not in remote) emits a one-line note (unless JSON +-- output is requested, in which case the path stays silent so JSON +-- consumers aren't disturbed) and falls back to 'runMigrateLocal' +-- against the original 'installedDir'. +runMigrateWithFetch :: + MigrateOpts -> + Manifest -> + FilePath -> + IO (Either MigrateError MigrateResult) +runMigrateWithFetch opts manifest installedDir = do + origin <- readOriginInfo installedDir + case origin of + Nothing -> do + note opts $ + " no origin metadata at " + <> T.pack (installedDir ".seihou-origin.json") + <> "; using locally installed copy." + runMigrateLocal opts manifest installedDir + Just o -> withSystemTempDirectory "seihou-migrate-fetch" $ \tmp -> do + let cloneDir = tmp "clone" + note opts (" Fetching " <> o.sourceUrl <> "...") + cloneRes <- cloneRepo o.sourceUrl cloneDir + case cloneRes of + Left err -> do + note opts (" fetch failed: " <> err <> "; using locally installed copy.") + runMigrateLocal opts manifest installedDir + Right () -> do + contents <- discoverRepoContents evalRegistryFromFile cloneDir + case findRemoteModuleDir cloneDir contents opts.migrateModule of + Nothing -> do + note opts $ + " module '" + <> opts.migrateModule.unModuleName + <> "' not present in remote; using locally installed copy." + runMigrateLocal opts manifest installedDir + Just (moduleDir, tags) -> do + -- Plan and execute against the clone's module dir. The + -- chain operates on the project's working tree; the + -- moduleDir only supplies the migrations list and the + -- target version. + cloneResult <- runMigrateLocal opts manifest moduleDir + -- EP-27 / EP-35 M5: when the local install declares more + -- in-window migrations than the clone, prefer the local + -- plan. The user's installed copy may still declare an + -- applicable edge that the remote dropped; honour it + -- rather than silently skip. + result <- maybeFallbackToLocal opts manifest installedDir cloneResult + -- Refresh the installed copy on the disk so future + -- commands see the new version locally. Any successful + -- apply (with or without ops) updates the disk; dry-run + -- and no-op outcomes leave it untouched. + case result of + Right (MigrateApplied {}) + | not opts.migrateDryRun -> + refreshInstalledFromClone moduleDir installedDir o tags + _ -> pure () + pure result + +-- | If the local install yields a plan with strictly more in-window +-- migrations than the clone-based plan, prefer the local result. +-- Otherwise the clone's plan stands. The check fires on any successful +-- result (Applied, DryRunOK, NoOp); errors are passed through +-- unchanged. +maybeFallbackToLocal :: + MigrateOpts -> + Manifest -> + FilePath -> + Either MigrateError MigrateResult -> + IO (Either MigrateError MigrateResult) +maybeFallbackToLocal opts manifest installedDir cloneResult = case cloneResult of + Left _ -> pure cloneResult + Right cloneOk -> do + localResult <- runMigrateLocal opts manifest installedDir + pure $ case localResult of + Right localOk + | resultStepCount localOk > resultStepCount cloneOk -> localResult + _ -> cloneResult + +-- | Number of migration steps a result actually carries (or would +-- carry, in dry-run form). Used by 'maybeFallbackToLocal'. +resultStepCount :: MigrateResult -> Int +resultStepCount = \case + MigrateNoOp {} -> 0 + MigrateApplied execPlan _ _ _ -> length execPlan.planSource.planSteps + MigrateDryRunOK execPlan _ _ -> length execPlan.planSource.planSteps + +-- | Print a one-line note unless JSON output is requested. Using JSON +-- output requires a clean, parseable stdout. +note :: MigrateOpts -> Text -> IO () +note opts msg = unless opts.migrateJson (TIO.putStrLn msg) + +-- | Locate the module's directory inside a cloned repo and return any +-- registry-declared tags. Returns 'Nothing' for empty repos or +-- recipe-only repos, or for multi-module repos that do not list the +-- requested module. +findRemoteModuleDir :: + FilePath -> + RepoContents -> + ModuleName -> + Maybe (FilePath, [Text]) +findRemoteModuleDir cloneDir contents modName = case contents of + SingleModule rootDir -> Just (rootDir, []) + MultiModule registry -> + case filter (\e -> e.name == modName) registry.modules of + (entry : _) -> Just (cloneDir entry.path, entry.tags) + [] -> Nothing + SingleRecipe _ -> Nothing + SingleBlueprint _ -> Nothing + SinglePrompt _ -> Nothing + EmptyRepo -> Nothing + +-- | Refresh the on-disk installed module directory from a cloned +-- module dir. Reads the clone's @module.dhall@ for its declared +-- version, then calls 'installModuleDir' with the same name as the +-- existing installation (basename of @installedDir@) so the XDG-derived +-- destination matches the original install path. +refreshInstalledFromClone :: + FilePath -> + FilePath -> + OriginInfo -> + [Text] -> + IO () +refreshInstalledFromClone moduleDir installedDir origin tags = do + let dhallFile = moduleDir "module.dhall" + modulRes <- evalModuleFromFile dhallFile + case modulRes of + Left _ -> pure () + Right modul -> do + let installedName = takeFileName installedDir + installModuleDir + moduleDir + installedName + origin.sourceUrl + origin.repoName + modul.version + tags + +-- ---------------------------------------------------------------------------- +-- Pending-migration detection (used by status / upgrade) +-- ---------------------------------------------------------------------------- + +-- | Detect whether the manifest's recorded version of an applied module +-- has fallen behind the installed copy. Returns: +-- +-- * @Nothing@ — versions equal, manifest version unrecorded, +-- installed-module version unrecorded, parse failure anywhere, or +-- the planner reported a hard error. +-- * @Just plan@ — a non-trivial plan whose 'planSteps' may be empty +-- (a pure version bump) or non-empty. +-- +-- Parse failures and planner errors are treated as "no pending +-- migration" rather than surfaced — this is the soft-warning path for +-- @seihou status@. Hard errors land on the user when they actually +-- run @seihou migrate@. +pendingChainFor :: + AppliedModule -> + Module -> + Maybe MigrationPlan +pendingChainFor applied installed = do + fromText <- applied.moduleVersion + fromV <- parseVersion fromText + toText <- installed.version + toV <- parseVersion toText + case planMigrationChain + applied.name.unModuleName + installed.migrations + fromV + toV of + Right (Just plan) -> Just plan + _ -> Nothing + +-- ---------------------------------------------------------------------------- +-- Helpers +-- ---------------------------------------------------------------------------- + +-- | Decide what to do with a 'MigrationPlan' returned by the planner. +-- Pure-IO: classifies the plan, optionally executes it, and packs the +-- outcome into a 'MigrateResult' variant the renderer knows how to +-- print. +-- +-- The plan from the gap-tolerant walker is always one shape — an +-- ordered list of in-window migrations plus the supplied @planFrom@ +-- and @planTo@. The dispatcher branches only on @planFrom == planTo@ +-- (no work) and dry-run vs apply. +dispatchPlan :: + MigrateOpts -> + Manifest -> + MigrationPlan -> + IO (Either MigrateError MigrateResult) +dispatchPlan opts manifest plan + | plan.planFrom == plan.planTo = pure (Right (MigrateNoOp plan.planTo)) + | otherwise = applyOrDryRun opts manifest plan + +-- | Classify the plan, optionally execute it, and return the +-- appropriate 'MigrateResult' variant. Empty 'planSteps' is fine — +-- 'executeMigration' runs zero file ops but still advances the +-- manifest's recorded @moduleVersion@ to @planTo@. +applyOrDryRun :: + MigrateOpts -> + Manifest -> + MigrationPlan -> + IO (Either MigrateError MigrateResult) +applyOrDryRun opts manifest plan = do + classifyResult <- + runEff $ + runFilesystem $ + classifyMigration manifest plan + case classifyResult of + Left err -> pure (Left (MigrateExecFailed err)) + Right executedPlan -> + if opts.migrateDryRun + then pure (Right (MigrateDryRunOK executedPlan plan.planFrom plan.planTo)) + else do + now <- getCurrentTime + execRes <- + runEff $ + runFilesystem $ + runProcessIO $ + executeMigration opts.migrateForce executedPlan manifest now + case execRes of + Left err -> pure (Left (MigrateExecFailed err)) + Right manifest' -> + pure (Right (MigrateApplied executedPlan manifest' plan.planFrom plan.planTo)) + +-- | Stage and commit the files touched by a successful migration plan. +-- Mirrors the @seihou run --commit@ post-execution helper. No-op +-- outside a git work tree, when every staged path is git-ignored, or +-- when both flags are off (callers gate on the flags before invoking +-- this). 'RunCommandInst' ops contribute no paths — their filesystem +-- effects are opaque, so any extra working-tree changes need a +-- separate manual commit. +commitMigratedFiles :: + MigrateOpts -> + -- | Manifest path (added to the staged set). + FilePath -> + ExecutedMigrationPlan -> + IO () +commitMigratedFiles opts manifestPath plan = do + let touched = concatMap pathsForOp plan.planOps + filesToStage = touched ++ [manifestPath] + inGit <- runEff $ runProcessIO isGitRepo + when inGit $ do + ignored <- runEff $ runProcessIO $ gitCheckIgnore filesToStage + let staged = filter (`notElem` ignored) filesToStage + unless (null staged) $ do + (addExit, _, addErr) <- runEff $ runProcessIO $ gitAdd staged + case addExit of + ExitFailure _ -> TIO.hPutStrLn stderr ("git add failed: " <> addErr) + ExitSuccess -> do + msg <- case opts.migrateCommitMessage of + Just m -> pure m + Nothing -> do + diffText <- runEff $ runProcessIO gitDiffCached + generateCommitMessage [opts.migrateModule] diffText + (cExit, _, cErr) <- runEff $ runProcessIO $ gitCommit msg + case cExit of + ExitSuccess -> pure () + ExitFailure _ -> + TIO.hPutStrLn stderr ("git commit failed: " <> cErr) + where + pathsForOp inst = case inst of + MoveFileInst src dest _ -> [src, dest] + MoveDirInst src dest -> [src, dest] + DeleteFileInst path _ -> [path] + DeleteDirInst path -> [path] + RunCommandInst _ _ -> [] + +resolveTarget :: + MigrateOpts -> Module -> ModuleName -> FilePath -> Either MigrateError Version +resolveTarget opts installedModule modName installedDhall = + case opts.migrateTo of + Just t -> case parseVersion t of + Just v -> Right v + Nothing -> Left (MigrateUnparseableTargetVersion t) + Nothing -> case installedModule.version of + Nothing -> Left (MigrateInstalledModuleHasNoVersion modName installedDhall) + Just t -> case parseVersion t of + Just v -> Right v + Nothing -> Left (MigrateUnparseableInstalledVersion t) + +findApplied :: Manifest -> ModuleName -> Maybe AppliedModule +findApplied m name = + case filter (\am -> am.name == name) m.modules of + (am : _) -> Just am + [] -> Nothing + +-- | Render a classified plan to stdout in the human-readable format. +-- The supplied versions are the user-visible "X → Y" header taken from +-- the source plan's @planFrom@ and @planTo@; the manifest will land at +-- @planTo@ even when 'planSteps' is empty. +renderPlan :: Bool -> ExecutedMigrationPlan -> Version -> Version -> IO () +renderPlan c plan fromV toV = do + let src = plan.planSource + TIO.putStrLn $ + "Migration plan: " + <> applyColor c bold (src.planModule) + <> " " + <> renderVersion fromV + <> " → " + <> renderVersion toV + if null src.planSteps + then TIO.putStrLn " (no migration ops)" + else mapM_ (renderStep c) src.planSteps + let conflictCount = + length + [ () | inst <- plan.planOps, isConflict inst + ] + affectedCount = + length + [ () | inst <- plan.planOps, touchesFs inst + ] + TIO.putStrLn "" + TIO.putStrLn $ + T.pack (show affectedCount) + <> " operation(s), " + <> T.pack (show conflictCount) + <> " conflict(s)." + where + isConflict (MoveFileInst _ _ MFConflict) = True + isConflict (DeleteFileInst _ MFConflict) = True + isConflict _ = False + + touchesFs (RunCommandInst _ _) = True + touchesFs _ = True + +renderStep :: Bool -> Migration -> IO () +renderStep c step = do + TIO.putStrLn $ " " <> step.from <> " → " <> step.to <> ":" + mapM_ (renderOp c) step.ops + +renderOp :: Bool -> MigrationOp -> IO () +renderOp c op = case op of + MoveFile {src, dest} -> + TIO.putStrLn $ " " <> applyColor c green "move-file " <> T.pack src <> " -> " <> T.pack dest + MoveDir {src, dest} -> + TIO.putStrLn $ " " <> applyColor c green "move-dir " <> T.pack src <> " -> " <> T.pack dest + DeleteFile {path} -> + TIO.putStrLn $ " " <> applyColor c yellow "delete " <> T.pack path + DeleteDir {path} -> + TIO.putStrLn $ " " <> applyColor c yellow "delete-dir" <> " " <> T.pack path + RunCommand {run, workDir} -> + let suffix = case workDir of + Just wd -> applyColor c dim (" (in " <> T.pack wd <> ")") + Nothing -> "" + in TIO.putStrLn $ " " <> applyColor c green "run " <> run <> suffix + +-- ---------------------------------------------------------------------------- +-- JSON output +-- ---------------------------------------------------------------------------- + +planToJson :: ExecutedMigrationPlan -> Aeson.Value +planToJson plan = + let src = plan.planSource + in object + [ "module" .= plan.planModule.unModuleName, + "from" .= renderVersion src.planFrom, + "to" .= renderVersion src.planTo, + "steps" + .= [ object + [ "from" .= step.from, + "to" .= step.to, + "ops" .= map opToJson step.ops + ] + | step <- src.planSteps + ], + "operations" .= map instToJson plan.planOps + ] + +opToJson :: MigrationOp -> Aeson.Value +opToJson op = case op of + MoveFile {src, dest} -> + object ["op" .= ("move-file" :: Text), "src" .= T.pack src, "dest" .= T.pack dest] + MoveDir {src, dest} -> + object ["op" .= ("move-dir" :: Text), "src" .= T.pack src, "dest" .= T.pack dest] + DeleteFile {path} -> + object ["op" .= ("delete-file" :: Text), "path" .= T.pack path] + DeleteDir {path} -> + object ["op" .= ("delete-dir" :: Text), "path" .= T.pack path] + RunCommand {run, workDir} -> + object ["op" .= ("run-command" :: Text), "run" .= run, "workDir" .= fmap T.pack workDir] + +instToJson :: MigrationOpInstance -> Aeson.Value +instToJson inst = case inst of + MoveFileInst src dest status -> + object + [ "op" .= ("move-file" :: Text), + "src" .= T.pack src, + "dest" .= T.pack dest, + "status" .= statusToJson status + ] + MoveDirInst src dest -> + object + ["op" .= ("move-dir" :: Text), "src" .= T.pack src, "dest" .= T.pack dest] + DeleteFileInst p status -> + object + [ "op" .= ("delete-file" :: Text), + "path" .= T.pack p, + "status" .= statusToJson status + ] + DeleteDirInst p -> + object ["op" .= ("delete-dir" :: Text), "path" .= T.pack p] + RunCommandInst run wd -> + object ["op" .= ("run-command" :: Text), "run" .= run, "workDir" .= fmap T.pack wd] + +statusToJson :: MigrationFileStatus -> Text +statusToJson MFSafe = "safe" +statusToJson MFConflict = "conflict" +statusToJson MFGone = "gone" + +-- ---------------------------------------------------------------------------- +-- Misc +-- ---------------------------------------------------------------------------- + +-- | Apply ANSI styling when colour is enabled. +applyColor :: Bool -> (Text -> Text) -> Text -> Text +applyColor True f = f +applyColor False _ = id + +-- | Print the error and exit non-zero. The IO shell calls this; the +-- pure 'runMigrate' returns 'Left' instead. +die :: MigrateError -> IO a +die err = do + c <- useColor + TIO.putStrLn $ applyColor c red "Error: " <> renderError err + exitFailure + +renderError :: MigrateError -> Text +renderError (MigrateNoManifest path) = + "no Seihou manifest at " <> T.pack path <> "; run from a project that has been initialized." +renderError (MigrateModuleNotApplied modName) = + "module '" <> modName.unModuleName <> "' is not applied in this project." +renderError (MigrateNoRecordedVersion modName) = + "module '" + <> modName.unModuleName + <> "' has no version recorded in the manifest. Re-apply the module with 'seihou run' to record one before migrating." +renderError (MigrateInstalledModuleEvalFailed path msg) = + "could not evaluate installed module at " <> T.pack path <> ": " <> msg +renderError (MigrateInstalledModuleHasNoVersion modName path) = + "installed module '" + <> modName.unModuleName + <> "' at " + <> T.pack path + <> " has no version field; either pass --to or add a version to its module.dhall." +renderError (MigrateUnparseableInstalledVersion v) = + "installed module's version '" <> v <> "' is not a valid dotted version." +renderError (MigrateUnparseableTargetVersion v) = + "--to value '" <> v <> "' is not a valid dotted version." +renderError (MigrateUnparseableManifestVersion v) = + "manifest's recorded module version '" <> v <> "' is not a valid dotted version." +renderError (MigratePlanFailed e) = renderPlanError e +renderError (MigrateExecFailed e) = renderExecError e + +renderPlanError :: MigrationPlanError -> Text +renderPlanError (MigrationVersionUnparseable t) = + "a migration declares an unparseable version: '" <> t <> "'" +renderPlanError (MigrationDowngradeNotSupported installed target) = + "downgrade not supported: installed " + <> renderVersion installed + <> ", requested target " + <> renderVersion target + <> "." +renderPlanError (MigrationDuplicateEdge fromV _) = + "two or more migrations declare the same 'from = " + <> renderVersion fromV + <> "'. The chain is ambiguous; the module author needs to merge or remove the duplicate." + +renderExecError :: MigrationExecError -> Text +renderExecError (MigrationConflict paths) = + "the following file(s) have been modified since they were generated:\n" + <> T.intercalate "\n" [" - " <> T.pack p | p <- paths] + <> "\n\nRe-run with --force to overwrite them, or revert your edits first." +renderExecError (MigrationCommandFailed msg code) = + "a run-command op exited with code " + <> T.pack (show code) + <> ":\n " + <> msg +renderExecError (MigrationUnsafePath label path reason) = + "unsafe migration " + <> label + <> " '" + <> T.pack path + <> "': " + <> reason + +-- Aeson ToJSON pass-through for ExecutedMigrationPlan: routed through +-- planToJson manually rather than deriving so we have the field shape +-- documented above. +instance ToJSON ExecutedMigrationPlan where + toJSON = planToJson diff --git a/src/Seihou/CLI/PendingMigrations.hs b/src/Seihou/CLI/PendingMigrations.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/PendingMigrations.hs @@ -0,0 +1,86 @@ +module Seihou.CLI.PendingMigrations + ( detectPendingMigrations, + formatRefusalMessage, + ) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as T +import Seihou.CLI.Migrate (pendingChainFor) +import Seihou.Core.Migration (MigrationPlan (..)) +import Seihou.Core.Types + ( AppliedModule (..), + Manifest (..), + ModuleName (..), + ) +import Seihou.Core.Version (renderVersion) +import Seihou.Dhall.Eval (evalModuleFromFile) +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Detect pending migrations across applied modules in a manifest. +-- +-- For each applied module whose installed @module.dhall@ declares a +-- newer version than the manifest's recorded version, return the +-- migration plan that describes the gap. Under the gap-tolerant +-- planner the plan always advances the manifest to the supplied +-- target on apply; the carried 'planSteps' may be empty (a pure +-- version bump where no declared migration falls in the window) or +-- non-empty. +-- +-- IO failures (missing @module.dhall@, eval errors, parse failures) are +-- silently skipped: pending-migration reporting is best-effort and never +-- raises. +-- +-- The optional filter restricts detection to a subset of module names. +-- 'Nothing' means "consider every applied module" (used by @seihou +-- status@). @'Just' names@ keeps only modules whose name is in the set +-- (used by @seihou run@, which only blocks when a module it is about +-- to write into has a pending plan). +detectPendingMigrations :: + Manifest -> + Maybe (Set ModuleName) -> + IO [(ModuleName, MigrationPlan)] +detectPendingMigrations manifest mFilter = + fmap + (\xs -> [(name, p) | (name, Just p) <- xs]) + (mapM check candidates) + where + candidates = case mFilter of + Nothing -> manifest.modules + Just names -> filter (\am -> Set.member am.name names) manifest.modules + + check am = do + let dhallFile = am.source "module.dhall" + exists <- doesFileExist dhallFile + if not exists + then pure (am.name, Nothing) + else do + r <- evalModuleFromFile dhallFile + case r of + Left _ -> pure (am.name, Nothing) + Right installed -> pure (am.name, pendingChainFor am installed) + +-- | Format the user-facing refusal message that @seihou run@ prints +-- when it detects pending migrations and the user has not opted into +-- @--with-migrations@. Each row reports the module, the version range +-- the migration would cover, and how many migration ops it would run +-- (which may be zero — a pure version bump). +formatRefusalMessage :: [(ModuleName, MigrationPlan)] -> Text +formatRefusalMessage pendings = + T.unlines $ + "Pending migrations detected:" + : map renderEntry pendings + ++ ["", "Run 'seihou migrate ' for each, or pass --with-migrations to apply during this run."] + where + renderEntry (name, plan) = + " " + <> name.unModuleName + <> ": " + <> renderVersion plan.planFrom + <> " -> " + <> renderVersion plan.planTo + <> " (" + <> T.pack (show (length plan.planSteps)) + <> " step(s))" diff --git a/src/Seihou/CLI/PromptRender.hs b/src/Seihou/CLI/PromptRender.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/PromptRender.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Seihou.CLI.PromptRender + ( renderPromptSystemPrompt, + renderPromptBody, + formatPromptGuidance, + ) +where + +import Data.FileEmbed (embedFile) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + formatAvailableModules, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatReferenceFiles, + formatSeihouProjectState, + substitute, + ) +import Seihou.Core.Expr (evalExpr) +import Seihou.Core.Types + +promptRunTemplate :: T.Text +promptRunTemplate = TE.decodeUtf8 $(embedFile "data/prompt-run-prompt.md") + +renderPromptSystemPrompt :: + AgentContext -> + AgentPrompt -> + Map VarName ResolvedVar -> + T.Text -> + Maybe T.Text -> + T.Text +renderPromptSystemPrompt ctx prompt resolved renderedPrompt userPrompt = + substitute + [ ("cwd", ctx.cwd), + ("seihou_project_state", formatSeihouProjectState ctx), + ("manifest_state", formatManifestState ctx), + ("module_dhall_state", formatModuleDhallState ctx), + ("local_modules", formatLocalModules ctx), + ("available_modules", formatAvailableModules ctx), + ("prompt_name", prompt.name.unModuleName), + ("prompt_version", fromMaybe "(unspecified)" prompt.version), + ("prompt_description", fromMaybe "(no description)" prompt.description), + ("reference_files", formatReferenceFiles prompt.files), + ("prompt_guidance", formatPromptGuidance resolved prompt.guidance), + ("prompt_body", renderedPrompt), + ("user_prompt", fromMaybe "(no one-off user instruction)" userPrompt) + ] + promptRunTemplate + +renderPromptBody :: Map VarName ResolvedVar -> T.Text -> T.Text +renderPromptBody resolved tpl = + substitute + [(vn.unVarName, varValueToText rv.value) | (vn, rv) <- Map.toList resolved] + tpl + +formatPromptGuidance :: Map VarName ResolvedVar -> [PromptGuidance] -> T.Text +formatPromptGuidance resolved guidance = + case filter selected guidance of + [] -> "(no prompt guidance)" + selectedGuidance -> T.intercalate "\n\n" (map render selectedGuidance) + where + bindings = Map.map (.value) resolved + + selected g = + case g.condition of + Nothing -> True + Just cond -> evalExpr bindings cond + + render g = + T.unlines + [ "### " <> g.title, + "", + g.body + ] + +varValueToText :: VarValue -> T.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) diff --git a/src/Seihou/CLI/Registry.hs b/src/Seihou/CLI/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Registry.hs @@ -0,0 +1,22 @@ +module Seihou.CLI.Registry + ( RegistryCommand (..), + handleRegistry, + ) +where + +import GHC.Generics (Generic) +import Seihou.CLI.Registry.Sync (SyncVersionsOpts, handleSyncVersions) +import Seihou.CLI.Registry.Validate (ValidateRegistryOpts, handleValidate) + +-- | Subcommand selector for the @seihou registry@ group. Reserves space for +-- future operations (e.g. @registry add@, @registry publish@) without +-- another CLI restructuring pass. +data RegistryCommand + = RegistrySyncVersions SyncVersionsOpts + | RegistryValidate ValidateRegistryOpts + deriving stock (Eq, Show, Generic) + +-- | Dispatch the selected @registry@ subcommand to its handler. +handleRegistry :: RegistryCommand -> IO () +handleRegistry (RegistrySyncVersions opts) = handleSyncVersions opts +handleRegistry (RegistryValidate opts) = handleValidate opts diff --git a/src/Seihou/CLI/Registry/Sync.hs b/src/Seihou/CLI/Registry/Sync.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Registry/Sync.hs @@ -0,0 +1,287 @@ +module Seihou.CLI.Registry.Sync + ( SyncVersionsOpts (..), + SyncAction (..), + SyncOutcome (..), + runSync, + handleSyncVersions, + renderSyncReport, + checkRegistryVersionDrift, + resolveOnDiskVersions, + ) +where + +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import GHC.Generics (Generic) +import Seihou.Core.Registry + ( EntryKind (..), + Registry (..), + RegistryEntry (..), + RepoContents (..), + SyncDiff (..), + SyncReport (..), + SyncStatus (..), + computeRegistrySync, + discoverRepoContents, + formatDriftWarning, + renderRegistryDhall, + ) +import Seihou.Core.Types (AgentPrompt, Blueprint, Module, ModuleName (..), Recipe) +import Seihou.Core.Types qualified as Types +import Seihou.Dhall.Eval + ( evalAgentPromptFromFile, + evalBlueprintFromFile, + evalModuleFromFile, + evalRecipeFromFile, + evalRegistryFromFile, + ) +import Seihou.Prelude +import System.Directory (doesDirectoryExist) +import System.Exit (ExitCode (..), exitWith) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) + +-- | Flags parsed for the @seihou registry sync-versions@ subcommand. +data SyncVersionsOpts = SyncVersionsOpts + { syncVersionsDir :: Maybe FilePath, + syncVersionsDryRun :: Bool, + syncVersionsCheck :: Bool + } + deriving stock (Eq, Show, Generic) + +-- | What the sync pass did with the registry file. +data SyncAction + = -- | Registry file rewritten on disk. + Wrote + | -- | @--dry-run@: diff computed, file left untouched. + WouldWrite + | -- | @--check@: diff computed, file left untouched, exit code reflects drift. + Checked + deriving stock (Eq, Show, Generic) + +-- | Terminal outcome of a sync run, decoupled from IO concerns like printing +-- and 'exitWith' so tests can assert without capturing stdout. +data SyncOutcome + = -- | Registry loaded, diff computed, action applied. + SyncSuccess SyncReport SyncAction + | -- | Target invalid (directory missing, no registry file, etc.); carries a + -- human-readable error. + SyncFailure Text + deriving stock (Eq, Show, Generic) + +-- | Testable core of @seihou registry sync-versions@. Locates the registry, +-- reads each entry's on-disk version, computes the diff, writes the file +-- when appropriate, and returns a structured outcome. +runSync :: SyncVersionsOpts -> IO SyncOutcome +runSync opts = do + let targetDir = maybe "." id opts.syncVersionsDir + dirExists <- doesDirectoryExist targetDir + if not dirExists + then pure (SyncFailure ("target directory does not exist: " <> T.pack targetDir)) + else do + contents <- discoverRepoContents evalRegistryFromFile targetDir + case contents of + MultiModule reg -> do + lookups <- resolveOnDiskVersions targetDir reg + let report = computeRegistrySync reg lookups + let checkMode = opts.syncVersionsCheck + dryRun = opts.syncVersionsDryRun && not checkMode + writeMode = not checkMode && not dryRun + action <- + if writeMode + then do + let rendered = renderRegistryDhall report.syncUpdated + TIO.writeFile (targetDir "seihou-registry.dhall") rendered + pure Wrote + else + if checkMode + then pure Checked + else pure WouldWrite + pure (SyncSuccess report action) + _ -> + pure + ( SyncFailure + "registry sync-versions requires a seihou-registry.dhall at the target directory" + ) + +-- | Read each registry entry's runnable Dhall file and pair it with the +-- entry's @(kind, name)@. Entries whose file fails to evaluate are omitted +-- from the returned list, which causes 'computeRegistrySync' to classify them +-- as 'SyncOrphan'. +resolveOnDiskVersions :: + FilePath -> + Registry -> + IO [(EntryKind, ModuleName, Maybe Text)] +resolveOnDiskVersions repoRoot reg = do + modulePairs <- mapM (loadModule repoRoot) reg.modules + recipePairs <- mapM (loadRecipe repoRoot) reg.recipes + blueprintPairs <- mapM (loadBlueprint repoRoot) reg.blueprints + promptPairs <- mapM (loadPrompt repoRoot) reg.prompts + pure (concat modulePairs <> concat recipePairs <> concat blueprintPairs <> concat promptPairs) + where + loadModule :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] + loadModule root entry = do + let path = root entry.path "module.dhall" + decoded <- evalModuleFromFile path + case decoded of + Right m -> pure [(ModuleEntry, entry.name, moduleVersion m)] + Left _ -> pure [] + loadRecipe :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] + loadRecipe root entry = do + let path = root entry.path "recipe.dhall" + decoded <- evalRecipeFromFile path + case decoded of + Right r -> pure [(RecipeEntry, entry.name, recipeVersion r)] + Left _ -> pure [] + loadBlueprint :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] + loadBlueprint root entry = do + let path = root entry.path "blueprint.dhall" + decoded <- evalBlueprintFromFile path + case decoded of + Right b -> pure [(BlueprintEntry, entry.name, blueprintVersion b)] + Left _ -> pure [] + loadPrompt :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)] + loadPrompt root entry = do + let path = root entry.path "prompt.dhall" + decoded <- evalAgentPromptFromFile path + case decoded of + Right p -> pure [(PromptEntry, entry.name, promptVersion p)] + Left _ -> pure [] + +-- | Extract the @version@ field from a 'Module' by pattern match. A direct +-- record-dot access (@m.version@) fails under 'DuplicateRecordFields' + +-- 'NoFieldSelectors' in this module because 'RegistryEntry' and 'Module' +-- share the field name. +moduleVersion :: Module -> Maybe Text +moduleVersion Types.Module {Types.version = v} = v + +-- | Analogous accessor for 'Recipe.version'. See 'moduleVersion'. +recipeVersion :: Recipe -> Maybe Text +recipeVersion Types.Recipe {Types.version = v} = v + +-- | Analogous accessor for 'Blueprint.version'. See 'moduleVersion'. +blueprintVersion :: Blueprint -> Maybe Text +blueprintVersion Types.Blueprint {Types.version = v} = v + +-- | Analogous accessor for 'AgentPrompt.version'. See 'moduleVersion'. +promptVersion :: AgentPrompt -> Maybe Text +promptVersion Types.AgentPrompt {Types.version = v} = v + +-- | Handler wired into the CLI command dispatcher. Drives 'runSync', prints a +-- human-readable diff, and exits with 0 or 1 as appropriate. +handleSyncVersions :: SyncVersionsOpts -> IO () +handleSyncVersions opts = do + outcome <- runSync opts + case outcome of + SyncFailure msg -> do + hPutStrLn stderr ("error: " <> T.unpack msg) + exitWith (ExitFailure 1) + SyncSuccess report action -> do + TIO.putStr (renderSyncReport report) + case action of + Wrote -> exitWith ExitSuccess + WouldWrite -> exitWith ExitSuccess + Checked -> + if anyDrift report + then exitWith (ExitFailure 1) + else exitWith ExitSuccess + +-- | Format the diff table and summary line for display on stdout. +-- The first entry in 'syncDiffs' appears first, preserving registry order. +renderSyncReport :: SyncReport -> Text +renderSyncReport report + | null report.syncDiffs = + "Registry is empty.\n" + | otherwise = + T.unlines $ + header + : map (" " <>) rows + <> ["", summary report] + where + header = "Updated seihou-registry.dhall:" + rows = map renderRow report.syncDiffs + + renderRow :: SyncDiff -> Text + renderRow diff = + let label = kindPrefix diff.diffKind <> diff.diffName.unModuleName <> ":" + padded = padRight labelWidth label + old = renderVersion diff.diffOld + new = renderVersion diff.diffNew + arrow = case diff.diffStatus of + SyncInSync -> " == " <> new <> " (no change)" + SyncOrphan -> " ?? " <> old <> " (" <> entryFile diff.diffKind <> " missing)" + _ -> " -> " <> new + in padded <> old <> arrow + + labelWidth = maximum (24 : map diffLabelWidth report.syncDiffs) + diffLabelWidth d = + T.length (kindPrefix d.diffKind <> d.diffName.unModuleName) + 2 + +kindPrefix :: EntryKind -> Text +kindPrefix ModuleEntry = "modules." +kindPrefix RecipeEntry = "recipes." +kindPrefix BlueprintEntry = "blueprints." +kindPrefix PromptEntry = "prompts." + +entryFile :: EntryKind -> Text +entryFile ModuleEntry = "module.dhall" +entryFile RecipeEntry = "recipe.dhall" +entryFile BlueprintEntry = "blueprint.dhall" +entryFile PromptEntry = "prompt.dhall" + +renderVersion :: Maybe Text -> Text +renderVersion Nothing = "(none)" +renderVersion (Just v) = v + +padRight :: Int -> Text -> Text +padRight w t = + let pad = max 0 (w - T.length t) + in t <> T.replicate pad " " + +summary :: SyncReport -> Text +summary report = + let updated = length [d | d <- report.syncDiffs, changesVersion d.diffStatus] + orphans = length [d | d <- report.syncDiffs, d.diffStatus == SyncOrphan] + unchanged = length [d | d <- report.syncDiffs, d.diffStatus == SyncInSync] + base = + T.pack (show updated) + <> " " + <> pluralize updated "entry" "entries" + <> " updated, " + <> T.pack (show unchanged) + <> " unchanged" + suffix = + if orphans > 0 + then ", " <> T.pack (show orphans) <> " orphan" <> (if orphans > 1 then "s" else "") + else "" + in base <> suffix <> "." + where + changesVersion SyncMissing = True + changesVersion (SyncStale _) = True + changesVersion _ = False + pluralize 1 s _ = s + pluralize _ _ p = p + +anyDrift :: SyncReport -> Bool +anyDrift report = + any + ( \d -> case d.diffStatus of + SyncInSync -> False + _ -> True + ) + report.syncDiffs + +-- | Soft-warning pass: compare each registry entry's 'version' with the +-- on-disk module.dhall / recipe.dhall and return one warning per out-of-sync +-- entry. Entries whose file is missing or unparseable are treated as orphan +-- and excluded here, matching 'formatDriftWarning' (they are already flagged +-- by 'validateRegistry'). +-- +-- Intended to be called after 'discoverRepoContents' yields 'MultiModule' — +-- the caller has already decoded the registry and knows the repo root. +checkRegistryVersionDrift :: FilePath -> Registry -> IO [Text] +checkRegistryVersionDrift repoRoot reg = do + lookups <- resolveOnDiskVersions repoRoot reg + let report = computeRegistrySync reg lookups + pure (mapMaybe formatDriftWarning report.syncDiffs) diff --git a/src/Seihou/CLI/Registry/Validate.hs b/src/Seihou/CLI/Registry/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Registry/Validate.hs @@ -0,0 +1,128 @@ +module Seihou.CLI.Registry.Validate + ( ValidateRegistryOpts (..), + ValidateOutcome (..), + runValidate, + handleValidate, + renderValidationReport, + ) +where + +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import GHC.Generics (Generic) +import Seihou.CLI.Registry.Sync (resolveOnDiskVersions) +import Seihou.Core.Registry + ( RegistryValidationIssue (..), + RegistryValidationReport (..), + RepoContents (..), + discoverRepoContents, + formatValidationIssue, + reportHasIssues, + validateRegistryFull, + ) +import Seihou.Dhall.Eval (evalRegistryFromFile) +import Seihou.Prelude +import System.Directory (doesDirectoryExist) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) + +-- | Flags parsed for the @seihou registry validate@ subcommand. +data ValidateRegistryOpts = ValidateRegistryOpts + { validateRegistryDir :: Maybe FilePath + } + deriving stock (Eq, Show, Generic) + +-- | Terminal outcome of a validate run, decoupled from IO concerns like +-- printing and 'exitWith' so tests can assert without capturing stdout. +data ValidateOutcome + = -- | Report ran. Caller decides exit code from 'reportHasIssues'. + ValidateOk RegistryValidationReport + | -- | Could not even start (no registry at target dir, etc.). + ValidateFailed Text + deriving stock (Eq, Show, Generic) + +-- | Testable core of @seihou registry validate@. Locates the registry, +-- resolves each entry's on-disk version, and produces the unified report. +runValidate :: ValidateRegistryOpts -> IO ValidateOutcome +runValidate opts = do + let target = maybe "." id opts.validateRegistryDir + dirExists <- doesDirectoryExist target + if not dirExists + then pure (ValidateFailed ("target directory does not exist: " <> T.pack target)) + else do + contents <- discoverRepoContents evalRegistryFromFile target + case contents of + MultiModule reg -> do + lookups <- resolveOnDiskVersions target reg + report <- validateRegistryFull target reg lookups + pure (ValidateOk report) + _ -> + pure + ( ValidateFailed + "registry validate requires a seihou-registry.dhall at the target directory" + ) + +-- | Handler wired into the CLI command dispatcher. Drives 'runValidate', +-- prints the report, and exits 0 or 1 based on 'reportHasIssues'. +handleValidate :: ValidateRegistryOpts -> IO () +handleValidate opts = do + outcome <- runValidate opts + case outcome of + ValidateFailed msg -> do + hPutStrLn stderr ("error: " <> T.unpack msg) + exitWith (ExitFailure 1) + ValidateOk report -> do + TIO.putStr (renderValidationReport report) + if reportHasIssues report + then exitWith (ExitFailure 1) + else exitWith ExitSuccess + +-- | Format the report for stdout. Mirrors the wording shown in the ExecPlan +-- example: an "OK" one-liner on success, an "errors:" list with a summary +-- line on failure. +renderValidationReport :: RegistryValidationReport -> Text +renderValidationReport r + | null r.reportIssues = + T.unlines + [ "OK: " + <> T.pack (show r.reportModuleCount) + <> " " + <> pluralize r.reportModuleCount "module" "modules" + <> ", " + <> T.pack (show r.reportRecipeCount) + <> " " + <> pluralize r.reportRecipeCount "recipe" "recipes" + <> ", " + <> T.pack (show r.reportBlueprintCount) + <> " " + <> pluralize r.reportBlueprintCount "blueprint" "blueprints" + <> ", " + <> T.pack (show r.reportPromptCount) + <> " " + <> pluralize r.reportPromptCount "prompt" "prompts" + <> ", all versions in sync." + ] + | otherwise = + T.unlines $ + ["errors:"] + <> map ((" " <>) . formatValidationIssue) r.reportIssues + <> [""] + <> [summary r] + +summary :: RegistryValidationReport -> Text +summary r = + let n = length r.reportIssues + hasVersionDrift = any isVersionMismatch r.reportIssues + base = T.pack (show n) <> " " <> pluralize n "error" "errors" + tail_ = + if hasVersionDrift + then ". Run `seihou registry sync-versions` to fix version drift." + else "." + in base <> tail_ + where + isVersionMismatch (VersionMismatch _) = True + isVersionMismatch _ = False + +pluralize :: Int -> Text -> Text -> Text +pluralize 1 s _ = s +pluralize _ _ p = p diff --git a/src/Seihou/CLI/RemoteVersion.hs b/src/Seihou/CLI/RemoteVersion.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/RemoteVersion.hs @@ -0,0 +1,97 @@ +module Seihou.CLI.RemoteVersion + ( FetchError (..), + fetchTrueModuleVersion, + renderFetchError, + ) +where + +import Data.Text qualified as T +import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents) +import Seihou.Core.Types (Module (..), ModuleName (..)) +import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile) +import Seihou.Prelude +import System.Directory (doesFileExist) + +-- | Reasons a remote-version lookup can fail. These are distinct from +-- "the module declares no version", which is represented by @Right Nothing@ +-- in the result of 'fetchTrueModuleVersion'. +data FetchError + = -- | The repo had no @seihou-registry.dhall@ and no @module.dhall@ at the + -- root, so the cloned tree exposes nothing we can read. Carries the + -- path that was checked. + RegistryNotFound FilePath + | -- | The repo's @seihou-registry.dhall@ parsed, but no entry whose + -- @name@ matches the requested module name. + EntryNotFound ModuleName + | -- | The path the registry pointed at (or the single-module root) does + -- not contain a @module.dhall@ file. Carries the absolute path that + -- was checked. + ModuleDhallNotFound FilePath + | -- | Either @seihou-registry.dhall@ or @module.dhall@ failed to evaluate + -- or decode. Carries a human-readable description of the failure. + ParseFailed Text + deriving stock (Show, Eq) + +-- | Read the truthful @version@ field of a module declared in a cloned +-- repository. Reads the module's @module.dhall@ directly, ignoring any +-- @version@ field that the registry might also declare. +-- +-- The third state in the result, @Right Nothing@, represents a module whose +-- @module.dhall@ declares @version = None Text@ — i.e., an unversioned +-- module. Callers display this as "unversioned" rather than as an error. +-- +-- Behavior depends on what the cloned repo contains, as classified by +-- 'discoverRepoContents': +-- +-- * 'MultiModule' — look up the registry entry by name, then read +-- @//module.dhall@. +-- * 'SingleModule' — read @/module.dhall@ regardless of the +-- requested name. (Single-module repos host exactly one module; the +-- name in @module.dhall@ is its own source of truth.) +-- * 'SingleRecipe' or 'EmptyRepo' — no module to read; return +-- 'RegistryNotFound'. +fetchTrueModuleVersion :: FilePath -> ModuleName -> IO (Either FetchError (Maybe Text)) +fetchTrueModuleVersion clonedRepoPath name = do + contents <- discoverRepoContents evalRegistryFromFile clonedRepoPath + case contents of + SingleModule rootDir -> + readModuleDhallVersion (rootDir "module.dhall") + MultiModule registry -> case findEntry registry of + Nothing -> pure (Left (EntryNotFound name)) + Just entry -> + readModuleDhallVersion (clonedRepoPath entry.path "module.dhall") + SingleRecipe _ -> pure (Left (RegistryNotFound clonedRepoPath)) + SingleBlueprint _ -> pure (Left (RegistryNotFound clonedRepoPath)) + SinglePrompt _ -> pure (Left (RegistryNotFound clonedRepoPath)) + EmptyRepo -> pure (Left (RegistryNotFound clonedRepoPath)) + where + findEntry :: Registry -> Maybe RegistryEntry + findEntry registry = + case filter (\e -> e.name == name) registry.modules of + (entry : _) -> Just entry + [] -> Nothing + +-- | Read a @module.dhall@ at the given path and return its @version@ field. +readModuleDhallVersion :: FilePath -> IO (Either FetchError (Maybe Text)) +readModuleDhallVersion path = do + exists <- doesFileExist path + if not exists + then pure (Left (ModuleDhallNotFound path)) + else do + result <- evalModuleFromFile path + case result of + Left err -> pure (Left (ParseFailed (T.pack (show err)))) + Right modul -> pure (Right modul.version) + +-- | Render a 'FetchError' as a single-line human-readable message suitable +-- for printing in CLI output ("could not determine remote version: ..."). +renderFetchError :: FetchError -> Text +renderFetchError = \case + RegistryNotFound path -> + "no module.dhall or seihou-registry.dhall in " <> T.pack path + EntryNotFound (ModuleName n) -> + "module '" <> n <> "' not listed in remote registry" + ModuleDhallNotFound path -> + "module.dhall not found at " <> T.pack path + ParseFailed msg -> + "could not parse remote module: " <> msg diff --git a/src/Seihou/CLI/SavePrompted.hs b/src/Seihou/CLI/SavePrompted.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/SavePrompted.hs @@ -0,0 +1,84 @@ +module Seihou.CLI.SavePrompted + ( collectPromptedValues, + offerSavePrompted, + ) +where + +import Control.Monad (when) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Composition.Instance (ModuleInstance) +import Seihou.Core.Types +import Seihou.Effect.ConfigWriter (ConfigWriter, writeConfigValue) +import Seihou.Effect.Console (Console, confirm, putText) +import Seihou.Prelude + +-- | Collect variables resolved via interactive prompts that are not already +-- in local config with the same value. Returns triples of (variable name, +-- prompted text value, Just existingValue if overwriting). +collectPromptedValues :: + Map ModuleInstance (Map VarName ResolvedVar) -> + Map VarName Text -> + [(VarName, Text, Maybe Text)] +collectPromptedValues resolved localConfig = + let allPrompted = + Map.toAscList $ + Map.unions + [ Map.mapMaybe promptedOnly vs + | vs <- Map.elems resolved + ] + promptedOnly rv = + case rv.source of + FromPrompt -> Just (varValueToText rv.value) + _ -> Nothing + in [ (vn, val, existing) + | (vn, val) <- allPrompted, + let existing = Map.lookup vn localConfig, + existing /= Just val + ] + +-- | Offer to save prompted values to local config. +-- Nothing = ask interactively, Just True = auto-save, Just False = skip. +offerSavePrompted :: + (Console :> es, ConfigWriter :> es) => + Maybe Bool -> + Bool -> + [(VarName, Text, Maybe Text)] -> + Eff es () +offerSavePrompted (Just False) _ _ = pure () +offerSavePrompted _ _ [] = pure () +offerSavePrompted mode interactive entries = do + let shouldSave = case mode of + Just True -> pure True + _ | not interactive -> pure False + _ -> do + putText "" + putText "Save prompted values to .seihou/config.dhall?" + putText "" + mapM_ + ( \(VarName n, val, mExisting) -> do + let overwriteNote = case mExisting of + Just old -> " (overwrites current: \"" <> old <> "\")" + Nothing -> "" + putText (" " <> n <> " = \"" <> val <> "\"" <> overwriteNote) + ) + entries + putText "" + confirm "Save? [Y/n]" + doSave <- shouldSave + when doSave $ do + mapM_ + ( \(VarName n, val, _) -> + writeConfigValue ScopeLocal n val + ) + entries + putText $ "Saved " <> T.pack (show (length entries)) <> " value(s) to .seihou/config.dhall" + putText "Use 'seihou config list' to view or 'seihou config unset ' to remove." + +-- | Convert a VarValue to its text representation. +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) diff --git a/src/Seihou/CLI/SchemaVersion.hs b/src/Seihou/CLI/SchemaVersion.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/SchemaVersion.hs @@ -0,0 +1,24 @@ +module Seihou.CLI.SchemaVersion + ( schemaUrl, + schemaHash, + schemaImportLine, + ) +where + +import Data.Text (Text) + +-- | Raw URL for the seihou-schema package.dhall at a pinned commit +schemaUrl :: Text +schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/a0fba0d17b43b14bfdf6d0bf98f1b7ff7af4ebab/package.dhall" + +-- | SHA256 integrity hash for the schema import +schemaHash :: Text +schemaHash = "sha256:36250d32d50cec0ea8c74926684ffb8b20f6d0b4f2152930dfa04a1ff108ef3f" + +-- | Complete Dhall import line for use in generated modules +schemaImportLine :: Text +schemaImportLine = + "let S =\n " + <> schemaUrl + <> "\n " + <> schemaHash diff --git a/src/Seihou/CLI/Shared.hs b/src/Seihou/CLI/Shared.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Shared.hs @@ -0,0 +1,83 @@ +module Seihou.CLI.Shared + ( formatVarError, + formatConfigError, + formatBlueprintRefusal, + deriveNamespace, + toVarNameMap, + logIO, + unwrapConfig, + shortenHome, + ) +where + +import Data.List (isPrefixOf) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types +import Seihou.Effect.Logger (Logger, logError) +import Seihou.Effect.LoggerInterp (runLoggerIO) +import Seihou.Prelude +import System.Directory (getHomeDirectory) +import System.Exit (exitFailure) + +-- | Format a 'VarError' for display in CLI output. +formatVarError :: VarError -> Text +formatVarError (MissingRequiredVar (VarName n)) = "missing required variable: " <> n +formatVarError (TypeMismatch (VarName n) _ _) = "type mismatch for variable: " <> n +formatVarError (ValidationFailed (VarName n) msg) = "validation failed for " <> n <> ": " <> msg +formatVarError (CoercionFailed (VarName n) _ raw) = "cannot coerce '" <> raw <> "' for variable: " <> n + +-- | Format a 'ConfigError' for display in CLI output. +formatConfigError :: ConfigError -> Text +formatConfigError (ConfigParseError path msg) = T.pack path <> ": " <> msg +formatConfigError (InvalidNamespace ns reason) = "invalid namespace '" <> ns <> "': " <> reason + +-- | The canonical message text emitted when @seihou run NAME@ resolves +-- to a blueprint. Returned as a single multi-line string so the run +-- handler can pass it to a single 'logError' call (the logger +-- prefixes each invocation with @[error] @, so emitting the body in +-- one call keeps the prefix off the continuation lines). Kept here in +-- @Seihou.CLI.Shared@ — rather than inlined in @Seihou.CLI.Run@ — +-- specifically so the message can be unit-tested without invoking the +-- full run handler. +formatBlueprintRefusal :: ModuleName -> Text +formatBlueprintRefusal name = + T.intercalate + "\n" + [ "'" <> name.unModuleName <> "' is a blueprint, not a module or recipe.", + "Blueprints must be run interactively via:", + " seihou agent run " <> name.unModuleName + ] + +-- | Derive the namespace from a module name by taking the prefix before the first hyphen. +-- For example, @ModuleName "haskell-base"@ yields @"haskell"@. +-- Modules without a hyphen yield an empty text (no namespace). +deriveNamespace :: ModuleName -> Text +deriveNamespace (ModuleName name) = + let (prefix, _) = T.breakOn "-" name + in if prefix == name then "" else prefix + +-- | Convert a @Map Text Text@ (with text keys like @"project.name"@) to a @Map VarName Text@. +toVarNameMap :: Map.Map Text Text -> Map.Map VarName Text +toVarNameMap = Map.mapKeys VarName + +-- | Run a one-shot Logger action in plain IO, using the given verbosity level. +logIO :: LogLevel -> Eff '[Logger, IOE] () -> IO () +logIO level action = runEff $ runLoggerIO level action + +-- | Abbreviate the user's home directory as @~\/@ for display. +shortenHome :: FilePath -> IO Text +shortenHome path = do + home <- getHomeDirectory + pure $ + if home `isPrefixOf` path + then "~/" <> T.pack (drop (length home + 1) path) + else T.pack path + +-- | Unwrap an 'Either ConfigError' in an effectful context, logging an error +-- and exiting on 'Left'. +unwrapConfig :: (IOE :> es) => LogLevel -> Either ConfigError a -> Eff es a +unwrapConfig _ (Right a) = pure a +unwrapConfig level (Left err) = liftIO $ do + logIO level (logError $ "Error reading config: " <> formatConfigError err) + exitFailure diff --git a/src/Seihou/CLI/StatusRender.hs b/src/Seihou/CLI/StatusRender.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/StatusRender.hs @@ -0,0 +1,343 @@ +module Seihou.CLI.StatusRender + ( formatStatus, + ModuleAdvice (..), + moduleAdvice, + ) +where + +import Data.List (intersperse) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time.Format (defaultTimeLocale, formatTime) +import Seihou.CLI.Style (dim, green, red, yellow) +import Seihou.CLI.VersionCompare + ( OutdatedEntry (..), + OutdatedStatus (..), + ) +import Seihou.Core.Migration (MigrationPlan (..)) +import Seihou.Core.Types + ( AppliedBlueprint (..), + AppliedModule (..), + AppliedRecipe (..), + Manifest (..), + ModuleName (..), + ParentVars (..), + RecipeName (..), + TrackedFile (..), + TrackedFileStatus (..), + VarName (..), + ) +import Seihou.Core.Version (renderVersion) + +-- | What action a single applied-module row recommends. +-- +-- Order of precedence: a pending migration always wins over a bare +-- "outdated" annotation, because @seihou migrate@ (after EP-2) is +-- self-contained and one command suffices to bring the project to the +-- new version. An outdated row with no detected pending plan falls +-- back to @seihou upgrade@. +data ModuleAdvice + = -- | Nothing pending; do not emit a hint. + AdviceNone + | -- | Module is outdated and no pending migration was detected. The + -- renderer prints @"Run: seihou upgrade "@. + AdviceUpgradeOnly Text + | -- | A pending migration was detected. The carried 'MigrationPlan' + -- describes the version range and the in-window migrations that + -- would run; 'planSteps' may be empty (a pure version bump) or + -- non-empty. The renderer prints a one-line summary and + -- @"Run: seihou migrate "@. + AdvicePendingMigration Text MigrationPlan + deriving stock (Eq, Show) + +-- | Decide which advice to emit for a single applied module. Any +-- detected pending plan wins over a bare outdated annotation because +-- @seihou migrate@ (after EP-2) is self-contained. +moduleAdvice :: + AppliedModule -> + Maybe OutdatedStatus -> + Maybe MigrationPlan -> + ModuleAdvice +moduleAdvice am mStatus mPlan = case mPlan of + Just plan -> AdvicePendingMigration am.name.unModuleName plan + Nothing -> case mStatus of + Just OutdatedSt -> AdviceUpgradeOnly am.name.unModuleName + _ -> AdviceNone + +-- | Render the full @seihou status@ output as a single 'Text' value. +-- +-- @color@ controls ANSI styling; pass 'False' for plain text (used by +-- the test suite). +formatStatus :: + Bool -> + Manifest -> + [TrackedFile] -> + Maybe [OutdatedEntry] -> + [(ModuleName, MigrationPlan)] -> + Text +formatStatus color manifest tracked mEntries pendings = + T.unlines $ + ["Seihou Status:", ""] + ++ recipeSection manifest + ++ blueprintSection manifest + ++ appliedSection color manifest mEntries pendings + ++ trackedSection color tracked + ++ varsSection manifest + ++ updateSummarySection mEntries + ++ recommendedActionsSection adviceList + where + entryMap = case mEntries of + Just es -> Map.fromList [(e.moduleName, e) | e <- es] + Nothing -> Map.empty + pendingMap = + Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings] + adviceList = map (rowAdvice entryMap pendingMap) manifest.modules + +-- | Build a 'ModuleAdvice' for one applied module from the lookup maps. +rowAdvice :: + Map Text OutdatedEntry -> + Map Text MigrationPlan -> + AppliedModule -> + ModuleAdvice +rowAdvice entryMap pendingMap am = + let name = am.name.unModuleName + mStatus = (.status) <$> Map.lookup name entryMap + mPlan = Map.lookup name pendingMap + in moduleAdvice am mStatus mPlan + +-- --------------------------------------------------------------------------- +-- Section renderers +-- --------------------------------------------------------------------------- + +recipeSection :: Manifest -> [Text] +recipeSection manifest = case manifest.recipe of + Nothing -> [] + Just ar -> + [ "Recipe: " + <> ar.name.unRecipeName + <> maybe "" (\v -> " v" <> v) ar.recipeVersion, + "" + ] + +-- | Render the "Blueprint:" provenance block when 'Manifest.blueprint' +-- is populated. Empty otherwise. +-- +-- Header line: name, optional @vX.Y.Z@, and the applied timestamp. +-- Baseline line: comma-separated baseline module names, or one of the +-- two empty-baseline placeholders. +-- Prompt line: present only when the user passed a positional prompt. +blueprintSection :: Manifest -> [Text] +blueprintSection manifest = case manifest.blueprint of + Nothing -> [] + Just ab -> + let header = + "Blueprint: " + <> ab.name.unModuleName + <> maybe "" (\v -> " v" <> v) ab.blueprintVersion + <> " (applied " + <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" ab.appliedAt) + <> ")" + baselineLine = " Baseline: " <> renderBaseline ab + promptLines = case ab.userPrompt of + Nothing -> [] + Just p -> [" Prompt: \"" <> p <> "\""] + in [header, baselineLine] ++ promptLines ++ [""] + +-- | Render the baseline body for the blueprint section. Three cases: +-- @--no-baseline@ was passed, the blueprint declared no baseline at +-- all, or one or more baseline modules were applied. +renderBaseline :: AppliedBlueprint -> Text +renderBaseline ab + | ab.noBaseline = "(none -- --no-baseline)" + | null ab.baselineModules = "(none declared)" + | otherwise = + T.intercalate ", " (map (.unModuleName) ab.baselineModules) + +appliedSection :: + Bool -> + Manifest -> + Maybe [OutdatedEntry] -> + [(ModuleName, MigrationPlan)] -> + [Text] +appliedSection color manifest mEntries pendings = + "Applied modules:" + : moduleLines + ++ [""] + where + entryMap = case mEntries of + Just es -> Map.fromList [(e.moduleName, e) | e <- es] + Nothing -> Map.empty + pendingMap = + Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings] + moduleLines + | null manifest.modules = [" (none)"] + | otherwise = + concatMap + ( \am -> + let advice = rowAdvice entryMap pendingMap am + annotation = lookupEntry mEntries entryMap am + headerLine = formatModuleLine color annotation am + hintLines = formatAdvice color advice + in headerLine : hintLines + ) + manifest.modules + +trackedSection :: Bool -> [TrackedFile] -> [Text] +trackedSection color tracked = + ("Tracked files: " <> T.pack (show (length tracked))) + : ( if null tracked + then [" (none)"] + else map (formatTrackedFile color maxPathLen maxModLen) tracked + ) + ++ [""] + where + maxPathLen = maximum (map (length . (.path)) tracked) + maxModLen = maximum (map (T.length . displayModuleName . (.moduleName)) tracked) + +varsSection :: Manifest -> [Text] +varsSection manifest = + ["Variables: " <> T.pack (show (Map.size manifest.vars)) <> " resolved"] + +updateSummarySection :: Maybe [OutdatedEntry] -> [Text] +updateSummarySection Nothing = [] +updateSummarySection (Just entries) = + let total = length entries + outdated = length (filter (\e -> e.status == OutdatedSt) entries) + in [ "", + T.pack (show total) + <> " module(s) checked, " + <> T.pack (show outdated) + <> " outdated." + ] + +-- | Print a "Recommended actions:" block listing the exact commands a +-- user should run for each problem row. Skipped when no row had an +-- actionable problem. +recommendedActionsSection :: [ModuleAdvice] -> [Text] +recommendedActionsSection advices = + case [c | Just c <- map adviceCommand advices] of + [] -> [] + cmds -> ["", "Recommended actions:"] ++ map (" " <>) cmds + +adviceCommand :: ModuleAdvice -> Maybe Text +adviceCommand AdviceNone = Nothing +adviceCommand (AdviceUpgradeOnly name) = Just ("seihou upgrade " <> name) +adviceCommand (AdvicePendingMigration name _) = Just ("seihou migrate " <> name) + +-- --------------------------------------------------------------------------- +-- Per-row formatting +-- --------------------------------------------------------------------------- + +-- | Per-row update annotation source, mirroring the previous local +-- @UpdateAnnotation@ enum in @Status.hs@. +data UpdateAnnotation + = NoCheck + | NoOrigin + | Entry OutdatedEntry + +lookupEntry :: + Maybe [OutdatedEntry] -> + Map Text OutdatedEntry -> + AppliedModule -> + UpdateAnnotation +lookupEntry Nothing _ _ = NoCheck +lookupEntry (Just _) m am = case Map.lookup am.name.unModuleName m of + Just e -> Entry e + Nothing -> NoOrigin + +formatModuleLine :: Bool -> UpdateAnnotation -> AppliedModule -> Text +formatModuleLine color annotation am = + let verText = case am.moduleVersion of + Just v -> " " <> applyColor color green ("v" <> v) + Nothing -> "" + appliedText = + " (applied " + <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" am.appliedAt) + <> ")" + parentVarsText = + let m = am.parentVars.unParentVars + in if Map.null m + then "" + else + let pairs = + T.concat + ( intersperse + ", " + [ vn.unVarName <> "=" <> v + | (vn, v) <- Map.toAscList m + ] + ) + rendered = " [" <> pairs <> "]" + in applyColor color dim rendered + updateText = case annotation of + NoCheck -> "" + NoOrigin -> " " <> applyColor color dim "(no origin)" + Entry e -> " " <> renderEntry color e + in " " + <> am.name.unModuleName + <> parentVarsText + <> verText + <> appliedText + <> updateText + +-- | Per-row remediation hint. Indented two characters past the row's +-- two-space indentation (i.e. four spaces total) so it visually nests +-- under the module name. +formatAdvice :: Bool -> ModuleAdvice -> [Text] +formatAdvice _ AdviceNone = [] +formatAdvice color (AdviceUpgradeOnly name) = + [" " <> applyColor color yellow ("Run: seihou upgrade " <> name)] +formatAdvice color (AdvicePendingMigration name plan) = + [" " <> applyColor color yellow (planSummary name plan)] + +-- | Format the "Pending migration: from -> to (N step(s)). Run: +-- seihou migrate " line for a pending-migration advice row. +planSummary :: Text -> MigrationPlan -> Text +planSummary name plan = + "Pending migration: " + <> renderVersion plan.planFrom + <> " -> " + <> renderVersion plan.planTo + <> " (" + <> T.pack (show (length plan.planSteps)) + <> " step(s)). Run: seihou migrate " + <> name + +renderEntry :: Bool -> OutdatedEntry -> Text +renderEntry color e = case e.status of + UpToDate -> applyColor color dim "up to date" + OutdatedSt -> + let avail = maybe "?" id e.availableVersion + txt = "outdated: " <> avail <> " available" + in applyColor color red txt + Unversioned -> applyColor color dim "unversioned" + Unreachable -> applyColor color yellow "unreachable" + +formatTrackedFile :: Bool -> Int -> Int -> TrackedFile -> Text +formatTrackedFile color maxPathLen maxModLen tf = + let path = T.pack tf.path + modName = displayModuleName tf.moduleName + paddedPath = path <> T.replicate (maxPathLen - T.length path + 3) " " + paddedMod = modName <> T.replicate (maxModLen - T.length modName + 3) " " + label = statusLabel tf.status + colored = applyColor color (statusColor tf.status) label + in " " <> paddedPath <> paddedMod <> colored + +displayModuleName :: ModuleName -> Text +displayModuleName (ModuleName n) = T.takeWhile (/= '#') n + +statusLabel :: TrackedFileStatus -> Text +statusLabel TfsUnchanged = "unchanged" +statusLabel TfsModified = "modified by user" +statusLabel TfsDeleted = "deleted by user" + +statusColor :: TrackedFileStatus -> Text -> Text +statusColor TfsUnchanged = dim +statusColor TfsModified = yellow +statusColor TfsDeleted = red + +applyColor :: Bool -> (Text -> Text) -> Text -> Text +applyColor True f = f +applyColor False _ = id diff --git a/src/Seihou/CLI/Style.hs b/src/Seihou/CLI/Style.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/Style.hs @@ -0,0 +1,230 @@ +module Seihou.CLI.Style + ( useColor, + green, + yellow, + red, + magenta, + dim, + bold, + cyan, + renderPreviewColor, + renderReportColor, + formatPlanViewColor, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.Core.Types (DiffResult (..), Module (..), ModuleName (..), VarName (..), VarValue (..)) +import Seihou.Engine.Preview +import Seihou.Engine.Validate +import Seihou.Prelude +import System.Console.ANSI + ( Color (..), + ColorIntensity (..), + ConsoleIntensity (..), + ConsoleLayer (..), + SGR (..), + hSupportsANSIColor, + setSGRCode, + ) +import System.IO (stdout) + +-- | Check whether stdout supports ANSI color output. +useColor :: IO Bool +useColor = hSupportsANSIColor stdout + +-- | Wrap text in ANSI color codes. +withSGR :: [SGR] -> Text -> Text +withSGR codes t = + T.pack (setSGRCode codes) <> t <> T.pack (setSGRCode [Reset]) + +green :: Text -> Text +green = withSGR [SetColor Foreground Dull Green] + +yellow :: Text -> Text +yellow = withSGR [SetColor Foreground Dull Yellow] + +red :: Text -> Text +red = withSGR [SetColor Foreground Vivid Red] + +magenta :: Text -> Text +magenta = withSGR [SetColor Foreground Dull Magenta] + +dim :: Text -> Text +dim = withSGR [SetConsoleIntensity FaintIntensity] + +bold :: Text -> Text +bold = withSGR [SetConsoleIntensity BoldIntensity] + +cyan :: Text -> Text +cyan = withSGR [SetColor Foreground Dull Cyan] + +-- | Render preview lines with optional ANSI color. +-- When the first argument is False, falls back to plain text. +renderPreviewColor :: Bool -> [PreviewLine] -> Text +renderPreviewColor False lines' = renderPreviewPlain lines' +renderPreviewColor True lines' = + if null lines' + then "No operations to perform.\n" + else T.unlines (map (renderColorLine maxPathLen) fileLines ++ map renderNonFileColor nonFileLines) + where + fileLines = [l | l@(FilePreview {}) <- lines'] + nonFileLines = [l | l <- lines', not (isFilePreview' l)] + maxPathLen = maximum (0 : map (T.length . T.pack . (.previewPath)) fileLines) + +renderColorLine :: Int -> PreviewLine -> Text +renderColorLine maxPath (FilePreview status path annotation mMod) = + let (tag, colorFn) = statusStyleColor status + pathText = T.pack path + pathPad = T.replicate (maxPath - T.length pathText) " " + modSuffix = case mMod of + Just mn -> ", " <> mn.unModuleName + Nothing -> "" + in " " <> tag <> " " <> colorFn pathText <> pathPad <> " " <> dim ("(" <> annotation <> modSuffix <> ")") +renderColorLine _ other = renderNonFileColor other + +renderNonFileColor :: PreviewLine -> Text +renderNonFileColor (DirPreview path) = + " " <> cyan "mkdir" <> " " <> cyan (T.pack path) +renderNonFileColor (CommandPreview cmd) = + " " <> dim "run" <> " " <> dim cmd +renderNonFileColor (OrphanPreview path modName') = + " " <> magenta "[orphaned]" <> " " <> magenta (T.pack path) <> " " <> dim ("(orphaned from " <> modName'.unModuleName <> ")") +renderNonFileColor _ = "" + +isFilePreview' :: PreviewLine -> Bool +isFilePreview' (FilePreview {}) = True +isFilePreview' _ = False + +statusStyleColor :: FileStatus -> (Text, Text -> Text) +statusStyleColor FsNew = (green "[new]", green) +statusStyleColor FsModified = (yellow "[modified]", yellow) +statusStyleColor FsUnchanged = (dim "[unchanged]", dim) +statusStyleColor FsConflict = (bold (red "[conflict]"), bold . red) +statusStyleColor FsOrphaned = (magenta "[orphaned]", magenta) +statusStyleColor FsUnknown = ("[unknown]", id) + +-- | Format a complete plan view with optional ANSI color. +formatPlanViewColor :: Bool -> [ModuleName] -> Map VarName VarValue -> [PreviewLine] -> DiffResult -> Text +formatPlanViewColor False modNames vars preview diff = formatPlanView modNames vars preview diff +formatPlanViewColor True modNames vars preview diff = + T.unlines $ + [header, ""] + ++ varsSection + ++ [" Operations:"] + ++ map (" " <>) (T.lines (renderPreviewColor True preview)) + ++ [""] + ++ [summaryText'] + where + header = + bold + ( "Generation Plan (" + <> T.intercalate " + " (map (cyan . (.unModuleName)) modNames) + <> "):" + ) + + 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 <> " = " <> showVarValueColor val + + showVarValueColor (VText t) = cyan ("\"" <> t <> "\"") + showVarValueColor (VBool True) = cyan "true" + showVarValueColor (VBool False) = cyan "false" + showVarValueColor (VInt n) = cyan (T.pack (show n)) + showVarValueColor (VList vs) = "[" <> T.intercalate ", " (map showVarValueColor vs) <> "]" + + nFiles = countNew preview + countMod preview + nConflicts = countConf preview + + summaryText' + | nConflicts > 0 = + " " + <> T.pack (show nFiles) + <> " files to write, " + <> bold (red (T.pack (show nConflicts) <> " conflicts")) + | otherwise = + " " + <> T.pack (show nFiles) + <> " files to write, " + <> T.pack (show nConflicts) + <> " conflicts" + + countNew = length . filter (\l -> case l of FilePreview FsNew _ _ _ -> True; _ -> False) + countMod = length . filter (\l -> case l of FilePreview FsModified _ _ _ -> True; _ -> False) + countConf = length . filter (\l -> case l of FilePreview FsConflict _ _ _ -> True; _ -> False) + +-- | Render a validation report with optional ANSI color. +-- When the first argument is False, falls back to plain text. +renderReportColor :: Bool -> ValidateReport -> Text +renderReportColor False report = renderReportPlain report +renderReportColor True report = + T.unlines $ + [ "Validating module at " <> T.pack report.reportPath <> "...", + "" + ] + ++ dhallLine' + ++ summaryLines' + ++ checkLines' + ++ [""] + ++ [resultLine'] + where + m = report.reportModule + + dhallLine' = + if report.reportDhallOk + then [" " <> green "\x2713" <> " module.dhall evaluates successfully"] + else + [" " <> bold (red "\x2717") <> " module.dhall failed to evaluate"] + ++ case report.reportDhallError of + Just errText -> [" " <> dim errText] + Nothing -> [] + + summaryLines' = + if report.reportDhallOk + then + [ " " <> green "\x2713" <> " Module name: " <> cyan m.name.unModuleName, + " " <> green "\x2713" <> " " <> T.pack (show (length m.vars)) <> " variables declared", + " " <> green "\x2713" <> " " <> T.pack (show (length m.prompts)) <> " prompts defined", + " " <> green "\x2713" <> " " <> T.pack (show (length m.steps)) <> " steps defined" + ] + else [] + + checkLines' = concatMap renderCheckColor (report.reportChecks) + + renderCheckColor c + | null (c.diagDetails) = + [" " <> green "\x2713" <> " " <> c.diagLabel] + | c.diagSeverity == DiagWarning = + (" " <> yellow "\x26A0" <> " " <> yellow (c.diagLabel)) + : map (\d -> " " <> dim d) (c.diagDetails) + | otherwise = + (" " <> bold (red "\x2717") <> " " <> red (c.diagLabel)) + : map (\d -> " " <> dim 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 = + bold (red (T.pack (show totalErrors) <> " error(s) found.")) <> " Module is invalid." + | otherwise = + green ("Module '" <> m.name.unModuleName <> "' is valid.") diff --git a/src/Seihou/CLI/VersionCompare.hs b/src/Seihou/CLI/VersionCompare.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/CLI/VersionCompare.hs @@ -0,0 +1,61 @@ +module Seihou.CLI.VersionCompare + ( OutdatedStatus (..), + OutdatedEntry (..), + CheckStats (..), + compareVersions, + ) +where + +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Text (Text) +import Seihou.Core.Version (parseVersion) + +-- | Status of a module with respect to available updates. +data OutdatedStatus + = UpToDate + | OutdatedSt + | Unversioned + | Unreachable + deriving stock (Eq, Show) + +-- | A single entry in the outdated report. Shared between the +-- @seihou outdated@ command (which formats them as a table) and +-- @seihou status@ (which folds them into per-row annotations). +data OutdatedEntry = OutdatedEntry + { moduleName :: Text, + installedVersion :: Maybe Text, + availableVersion :: Maybe Text, + status :: OutdatedStatus + } + deriving stock (Eq, Show) + +instance ToJSON OutdatedEntry where + toJSON e = + object + [ "module" .= e.moduleName, + "installed" .= e.installedVersion, + "available" .= e.availableVersion, + "status" .= statusText e.status + ] + where + statusText UpToDate = "up to date" :: Text + statusText OutdatedSt = "outdated" + statusText Unversioned = "unversioned" + statusText Unreachable = "unreachable" + +-- | Summary statistics for an update check. +data CheckStats = CheckStats + { checkedCount :: Int, + skippedNoOrigin :: Int + } + deriving stock (Eq, Show) + +-- | Compare installed and available version strings. +compareVersions :: Maybe Text -> Maybe Text -> OutdatedStatus +compareVersions (Just instText) (Just availText) = + case (parseVersion instText, parseVersion availText) of + (Just instV, Just availV) + | instV < availV -> OutdatedSt + | otherwise -> UpToDate + _ -> Unversioned -- unparseable version treated as unversioned +compareVersions _ _ = Unversioned diff --git a/src/Seihou/Effect/Fzf.hs b/src/Seihou/Effect/Fzf.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/Fzf.hs @@ -0,0 +1,21 @@ +module Seihou.Effect.Fzf + ( Fzf (..), + selectOne, + isFzfAvailable, + ) +where + +import Seihou.Fzf (Candidate, FzfOpts, FzfResult) +import Seihou.Prelude + +data Fzf :: Effect where + SelectOne :: FzfOpts -> [Candidate a] -> Fzf (Eff es) (FzfResult a) + IsFzfAvailable :: Fzf (Eff es) Bool + +type instance DispatchOf Fzf = Dynamic + +selectOne :: (Fzf :> es) => FzfOpts -> [Candidate a] -> Eff es (FzfResult a) +selectOne opts cs = send (SelectOne opts cs) + +isFzfAvailable :: (Fzf :> es) => Eff es Bool +isFzfAvailable = send IsFzfAvailable diff --git a/src/Seihou/Effect/FzfInterp.hs b/src/Seihou/Effect/FzfInterp.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Effect/FzfInterp.hs @@ -0,0 +1,27 @@ +module Seihou.Effect.FzfInterp + ( runFzfIO, + runFzfPure, + ) +where + +import Seihou.Effect.Fzf (Fzf (..)) +import Seihou.Fzf (FzfConfig, FzfResult (..), isFzfUsable) +import Seihou.Fzf qualified as Fzf +import Seihou.Prelude + +-- | Run fzf effects using a real fzf subprocess. +runFzfIO :: (IOE :> es) => FzfConfig -> Eff (Fzf : es) a -> Eff es a +runFzfIO cfg = interpret $ \_ -> \case + SelectOne opts candidates -> liftIO $ Fzf.runFzf cfg opts candidates + IsFzfAvailable -> pure (isFzfUsable cfg) + +-- | Pure interpreter for testing. Always selects the candidate at the given +-- index, or returns 'FzfNoMatch' if the index is out of bounds. +runFzfPure :: Int -> Eff (Fzf : es) a -> Eff es a +runFzfPure idx = interpret $ \_ -> \case + SelectOne _ candidates -> + pure $ + if idx >= 0 && idx < length candidates + then FzfSelected (candidates !! idx).candidateValue + else FzfNoMatch + IsFzfAvailable -> pure True diff --git a/src/Seihou/Fzf.hs b/src/Seihou/Fzf.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Fzf.hs @@ -0,0 +1,199 @@ +module Seihou.Fzf + ( -- * Config + FzfConfig (..), + detectFzfConfig, + isFzfUsable, + + -- * Options + FzfOpts (..), + withPrompt, + withHeader, + withHeight, + withAnsi, + withNoSort, + withPreview, + optsToArgs, + + -- * Candidates and Results + Candidate (..), + FzfResult (..), + + -- * Running + runFzf, + ) +where + +import Control.Exception (SomeException, try) +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 System.Directory (findExecutable) +import System.Exit (ExitCode (..)) +import System.IO (IOMode (..), hClose, hIsTerminalDevice, openFile, stdin) +import System.Process + ( CreateProcess (..), + StdStream (..), + createProcess, + proc, + waitForProcess, + ) +import Text.Read (readMaybe) + +-- | Runtime configuration for fzf, detected once at CLI startup. +data FzfConfig = FzfConfig + { fzfBinary :: !FilePath, + fzfAvailable :: !Bool, + stdinIsTerminal :: !Bool, + ttyAvailable :: !Bool + } + deriving stock (Eq, Show) + +-- | Detect fzf availability and terminal state. +detectFzfConfig :: IO FzfConfig +detectFzfConfig = do + mFzf <- findExecutable "fzf" + stdinTerm <- hIsTerminalDevice stdin + ttyOk <- checkTtyAvailable + pure + FzfConfig + { fzfBinary = maybe "fzf" id mFzf, + fzfAvailable = case mFzf of Nothing -> False; Just _ -> True, + stdinIsTerminal = stdinTerm, + ttyAvailable = ttyOk + } + +-- | Check whether /dev/tty can be opened (for fzf in piped contexts). +checkTtyAvailable :: IO Bool +checkTtyAvailable = do + result <- try @SomeException $ openFile "/dev/tty" ReadMode + case result of + Left _ -> pure False + Right h -> hClose h >> pure True + +-- | Whether fzf can be used for interactive selection. +isFzfUsable :: FzfConfig -> Bool +isFzfUsable cfg = cfg.fzfAvailable && (cfg.stdinIsTerminal || cfg.ttyAvailable) + +-- | Composable fzf options. Combine with '<>'. +data FzfOpts = FzfOpts + { fzfPrompt :: !(Maybe Text), + fzfHeader :: !(Maybe Text), + fzfPreview :: !(Maybe Text), + fzfHeight :: !(Maybe Text), + fzfAnsi :: !Bool, + fzfNoSort :: !Bool + } + deriving stock (Eq, Show) + +instance Semigroup FzfOpts where + a <> b = + FzfOpts + { fzfPrompt = b.fzfPrompt <|> a.fzfPrompt, + fzfHeader = b.fzfHeader <|> a.fzfHeader, + fzfPreview = b.fzfPreview <|> a.fzfPreview, + fzfHeight = b.fzfHeight <|> a.fzfHeight, + fzfAnsi = a.fzfAnsi || b.fzfAnsi, + fzfNoSort = a.fzfNoSort || b.fzfNoSort + } + where + (<|>) :: Maybe a -> Maybe a -> Maybe a + (<|>) Nothing y = y + (<|>) x _ = x + +instance Monoid FzfOpts where + mempty = FzfOpts Nothing Nothing Nothing Nothing False False + +withPrompt :: Text -> FzfOpts +withPrompt p = mempty {fzfPrompt = Just p} + +withHeader :: Text -> FzfOpts +withHeader h = mempty {fzfHeader = Just h} + +withHeight :: Text -> FzfOpts +withHeight h = mempty {fzfHeight = Just h} + +withAnsi :: FzfOpts +withAnsi = mempty {fzfAnsi = True} + +withNoSort :: FzfOpts +withNoSort = mempty {fzfNoSort = True} + +withPreview :: Text -> FzfOpts +withPreview p = mempty {fzfPreview = Just p} + +-- | Convert options to fzf CLI arguments. +optsToArgs :: FzfOpts -> [String] +optsToArgs opts = + concat + [ maybe [] (\p -> ["--prompt", T.unpack p]) opts.fzfPrompt, + maybe [] (\h -> ["--header", T.unpack h]) opts.fzfHeader, + maybe [] (\p -> ["--preview", T.unpack p]) opts.fzfPreview, + maybe [] (\h -> ["--height", T.unpack h]) opts.fzfHeight, + ["--ansi" | opts.fzfAnsi], + ["--no-sort" | opts.fzfNoSort] + ] + +-- | A selectable candidate with display text and an associated value. +data Candidate a = Candidate + { candidateDisplay :: !Text, + candidateValue :: !a + } + deriving stock (Functor) + +-- | Result of an fzf selection. +data FzfResult a + = FzfSelected !a + | FzfNoMatch + | FzfCancelled + | FzfError !Text + deriving stock (Functor) + +-- | Run fzf as a subprocess with the given candidates. +-- +-- Uses index-based selection: each candidate line is prefixed with a hidden +-- integer index. The index is parsed back from fzf's output to look up the +-- original value, avoiding any issues with special characters in display text. +runFzf :: FzfConfig -> FzfOpts -> [Candidate a] -> IO (FzfResult a) +runFzf _ _ [] = pure FzfNoMatch +runFzf cfg opts candidates + | not (isFzfUsable cfg) = pure (FzfError "fzf is not available") + | otherwise = do + let indexed = zip [0 :: Int ..] candidates + valueMap = Map.fromList [(i, c.candidateValue) | (i, c) <- indexed] + inputLines = [show i <> "\t" <> T.unpack c.candidateDisplay | (i, c) <- indexed] + args = ["-1", "--with-nth=2.."] ++ optsToArgs opts + + let processSpec = + (proc cfg.fzfBinary args) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = Inherit, + delegate_ctlc = True + } + + result <- try @SomeException $ do + (Just hIn, Just hOut, _, ph) <- createProcess processSpec + mapM_ (TIO.hPutStrLn hIn . T.pack) inputLines + hClose hIn + outputStr <- TIO.hGetContents hOut + exitCode <- waitForProcess ph + pure (exitCode, T.strip outputStr) + + case result of + Left err -> pure (FzfError (T.pack (show err))) + Right (exitCode, output) -> case exitCode of + ExitSuccess -> pure (parseSelection valueMap output) + ExitFailure 1 -> pure FzfNoMatch + ExitFailure 130 -> pure FzfCancelled + ExitFailure n -> pure (FzfError ("fzf exited with code " <> T.pack (show n))) + +-- | Parse the index from fzf output and look up the value. +parseSelection :: Map.Map Int a -> Text -> FzfResult a +parseSelection valueMap output = + let indexText = T.takeWhile (/= '\t') output + in case readMaybe (T.unpack indexText) of + Just idx -> case Map.lookup idx valueMap of + Just val -> FzfSelected val + Nothing -> FzfError ("invalid index in fzf output: " <> indexText) + Nothing -> FzfError ("could not parse fzf output: " <> output) diff --git a/src/Seihou/Fzf/Selector.hs b/src/Seihou/Fzf/Selector.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Fzf/Selector.hs @@ -0,0 +1,6 @@ +module Seihou.Fzf.Selector + ( module Seihou.Fzf.Selector.Module, + ) +where + +import Seihou.Fzf.Selector.Module diff --git a/src/Seihou/Fzf/Selector/Module.hs b/src/Seihou/Fzf/Selector/Module.hs new file mode 100644 --- /dev/null +++ b/src/Seihou/Fzf/Selector/Module.hs @@ -0,0 +1,62 @@ +module Seihou.Fzf.Selector.Module + ( formatModuleCandidate, + formatRunnableCandidate, + defaultModuleOpts, + selectModule, + ) +where + +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables) +import Seihou.Core.Types +import Seihou.Effect.Fzf (Fzf, selectOne) +import Seihou.Fzf (Candidate (..), FzfOpts, FzfResult, withAnsi, withHeight, withNoSort, withPrompt) +import Seihou.Prelude + +-- | Format a discovered module as an fzf candidate. +-- Returns 'Nothing' for modules that failed to load. +formatModuleCandidate :: DiscoveredModule -> Maybe (Candidate ModuleName) +formatModuleCandidate dm = case dm.discoveredResult of + Left _ -> Nothing + Right m -> + let nameText = m.name.unModuleName + descText = maybe "" (\d -> " " <> d) m.description + sourceTag = case dm.discoveredSource of + SourceProject -> "[project]" + SourceUser -> "[user]" + SourceInstalled -> "[installed]" + display = nameText <> descText <> " " <> sourceTag + in Just Candidate {candidateDisplay = display, candidateValue = m.name} + +-- | Format a discovered runnable (module or recipe) as an fzf candidate. +-- Returns 'Nothing' for items that failed to load. +formatRunnableCandidate :: DiscoveredRunnable -> Maybe (Candidate ModuleName) +formatRunnableCandidate dr + | dr.drIsError = Nothing + | otherwise = + let nameText = dr.drName + descText = maybe "" (\d -> " " <> d) dr.drDescription + kindTag = case dr.drKind of + KindModule -> "" + KindRecipe -> " [recipe]" + KindBlueprint -> " [blueprint]" + KindPrompt -> " [prompt]" + sourceTag = case dr.drSource of + SourceProject -> "[project]" + SourceUser -> "[user]" + SourceInstalled -> "[installed]" + display = nameText <> descText <> kindTag <> " " <> sourceTag + in Just Candidate {candidateDisplay = display, candidateValue = ModuleName nameText} + +-- | Default fzf options for module selection. +defaultModuleOpts :: FzfOpts +defaultModuleOpts = withPrompt "module> " <> withHeight "40%" <> withAnsi <> withNoSort + +-- | Discover all available modules and recipes and present them in an fzf picker. +selectModule :: (Fzf :> es, IOE :> es) => Eff es (FzfResult ModuleName) +selectModule = do + searchPaths <- liftIO defaultSearchPaths + discovered <- liftIO (discoverAllRunnables searchPaths) + let candidates = mapMaybe formatRunnableCandidate discovered + selectOne defaultModuleOpts candidates diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,56 @@ +module Main (main) where + +import Seihou.CLI.AgentCompletionSpec qualified as AgentCompletionSpec +import Seihou.CLI.AgentConfigSpec qualified as AgentConfigSpec +import Seihou.CLI.AgentLaunchSpec qualified as AgentLaunchSpec +import Seihou.CLI.AppliedBlueprintSpec qualified as AppliedBlueprintSpec +import Seihou.CLI.BrowseFormatSpec qualified as BrowseFormatSpec +import Seihou.CLI.CommitMessageSpec qualified as CommitMessageSpec +import Seihou.CLI.DiffSpec qualified as DiffSpec +import Seihou.CLI.ExtensionSpec qualified as ExtensionSpec +import Seihou.CLI.GitSpec qualified as GitSpec +import Seihou.CLI.InitSpec qualified as InitSpec +import Seihou.CLI.InstallHistorySpec qualified as InstallHistorySpec +import Seihou.CLI.ListSpec qualified as ListSpec +import Seihou.CLI.MigrateSpec qualified as MigrateSpec +import Seihou.CLI.PendingMigrationSpec qualified as PendingMigrationSpec +import Seihou.CLI.PromptRenderSpec qualified as PromptRenderSpec +import Seihou.CLI.Registry.SyncSpec qualified as RegistrySyncSpec +import Seihou.CLI.Registry.ValidateSpec qualified as RegistryValidateSpec +import Seihou.CLI.RemoteVersionSpec qualified as RemoteVersionSpec +import Seihou.CLI.RunBlueprintRefusalSpec qualified as RunBlueprintRefusalSpec +import Seihou.CLI.SavePromptedSpec qualified as SavePromptedSpec +import Seihou.CLI.StatusSpec qualified as StatusSpec +import Seihou.CLI.UpgradeSpec qualified as UpgradeSpec +import Seihou.FzfSpec qualified as FzfSpec +import Test.Tasty + +main :: IO () +main = do + tests <- + sequence + [ AgentLaunchSpec.tests, + AgentCompletionSpec.tests, + AgentConfigSpec.tests, + AppliedBlueprintSpec.tests, + BrowseFormatSpec.tests, + CommitMessageSpec.tests, + DiffSpec.tests, + ExtensionSpec.tests, + GitSpec.tests, + InitSpec.tests, + InstallHistorySpec.tests, + ListSpec.tests, + MigrateSpec.tests, + PendingMigrationSpec.tests, + PromptRenderSpec.tests, + RegistrySyncSpec.tests, + RegistryValidateSpec.tests, + RemoteVersionSpec.tests, + RunBlueprintRefusalSpec.tests, + SavePromptedSpec.tests, + StatusSpec.tests, + UpgradeSpec.tests, + FzfSpec.tests + ] + defaultMain (testGroup "seihou-cli" tests) diff --git a/test/Seihou/CLI/AgentCompletionSpec.hs b/test/Seihou/CLI/AgentCompletionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentCompletionSpec.hs @@ -0,0 +1,100 @@ +module Seihou.CLI.AgentCompletionSpec (tests) where + +import Baikai qualified +import Baikai.Model qualified as BaikaiModel +import Baikai.Response qualified as BaikaiResponse +import Data.Text qualified as Text +import Data.Time (UTCTime) +import Data.Vector qualified as V +import Seihou.CLI.AgentCompletion +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AgentCompletion" $ do + describe "provider text helpers" $ do + it "parses known providers case-insensitively" $ do + providerFromText "claude-cli" `shouldBe` Right AgentProviderClaudeCli + providerFromText "CODEX-CLI" `shouldBe` Right AgentProviderCodexCli + providerFromText " anthropic " `shouldBe` Right AgentProviderAnthropic + providerFromText "openai" `shouldBe` Right AgentProviderOpenAI + + it "renders providers to canonical config text" $ do + providerToText AgentProviderClaudeCli `shouldBe` "claude-cli" + providerToText AgentProviderCodexCli `shouldBe` "codex-cli" + providerToText AgentProviderAnthropic `shouldBe` "anthropic" + providerToText AgentProviderOpenAI `shouldBe` "openai" + + it "returns a useful error for unknown providers" $ + providerFromText "llama" `shouldSatisfy` \case + Left err -> + "claude-cli" `Text.isInfixOf` err + && "codex-cli" `Text.isInfixOf` err + && "anthropic" `Text.isInfixOf` err + && "openai" `Text.isInfixOf` err + Right _ -> False + + describe "model construction" $ do + it "defaults to the Claude CLI provider with no explicit model" $ + defaultAgentModelConfig + `shouldBe` AgentModelConfig + { agentProvider = AgentProviderClaudeCli, + agentModel = Nothing + } + + it "builds a Claude CLI model using the CLI API tag" $ do + let model = + buildBaikaiModel + AgentModelConfig + { agentProvider = AgentProviderClaudeCli, + agentModel = Just "sonnet" + } + BaikaiModel.api model `shouldBe` Baikai.AnthropicMessagesCli + BaikaiModel.provider model `shouldBe` "anthropic" + BaikaiModel.modelId model `shouldBe` "sonnet" + + it "builds a Codex CLI model using the CLI API tag" $ do + let model = + buildBaikaiModel + AgentModelConfig + { agentProvider = AgentProviderCodexCli, + agentModel = Just "gpt-5" + } + BaikaiModel.api model `shouldBe` Baikai.OpenAICompletionsCli + BaikaiModel.provider model `shouldBe` "openai" + BaikaiModel.modelId model `shouldBe` "gpt-5" + + describe "buildAgentCompletionRequest" $ do + it "preserves rendered prompts and resolved model configuration" $ do + let config = + AgentModelConfig + { agentProvider = AgentProviderCodexCli, + agentModel = Just "gpt-5" + } + buildAgentCompletionRequest config "system" (Just "user") + `shouldBe` AgentCompletionRequest + { completionSystemPrompt = "system", + completionInitialPrompt = Just "user", + completionModelConfig = config + } + + describe "responseText" $ do + it "extracts and joins assistant text blocks only" $ do + let resp = + BaikaiResponse.emptyResponse + { BaikaiResponse.message = + Baikai.AssistantPayload + { Baikai.content = + V.fromList + [ Baikai.AssistantText (Baikai.TextContent "hello"), + Baikai.AssistantThinking Baikai.emptyThinkingContent, + Baikai.AssistantText (Baikai.TextContent "world") + ], + Baikai.usage = Baikai.zeroUsage, + Baikai.stopReason = Baikai.Stop, + Baikai.errorMessage = Nothing, + Baikai.timestamp = Just (read "2026-05-23 00:00:00 UTC" :: UTCTime) + } + } + responseText resp `shouldBe` "hello\nworld" diff --git a/test/Seihou/CLI/AgentConfigSpec.hs b/test/Seihou/CLI/AgentConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentConfigSpec.hs @@ -0,0 +1,89 @@ +module Seihou.CLI.AgentConfigSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Seihou.CLI.AgentCompletion +import Seihou.CLI.AgentConfig +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AgentConfig" spec + +spec :: Spec +spec = do + describe "resolveAgentModelConfig" $ do + it "uses CLI flags before environment variables" $ do + resolveAgentModelConfig + (baseInputs {cliProvider = Just "codex-cli", cliModel = Just "gpt-5", envProvider = Just "anthropic", envModel = Just "claude-sonnet-4-6"}) + `shouldBe` Right + AgentModelConfig + { agentProvider = AgentProviderCodexCli, + agentModel = Just "gpt-5" + } + + it "uses environment variables before local config" $ do + resolveAgentModelConfig + (baseInputs {envProvider = Just "openai", envModel = Just "gpt-4o", localConfig = config "anthropic" "claude-sonnet-4-6"}) + `shouldBe` Right + AgentModelConfig + { agentProvider = AgentProviderOpenAI, + agentModel = Just "gpt-4o" + } + + it "uses local config before global config" $ do + resolveAgentModelConfig + (baseInputs {localConfig = config "anthropic" "claude-opus-4-1", globalConfig = config "openai" "gpt-4o-mini"}) + `shouldBe` Right + AgentModelConfig + { agentProvider = AgentProviderAnthropic, + agentModel = Just "claude-opus-4-1" + } + + it "falls back to the Claude CLI default" $ + resolveAgentModelConfig baseInputs `shouldBe` Right defaultAgentModelConfig + + it "returns provider diagnostics for invalid provider text" $ + resolveAgentModelConfig (baseInputs {cliProvider = Just "llama"}) `shouldSatisfy` \case + Left err -> + "Unknown agent provider" `Text.isInfixOf` err + && "claude-cli" `Text.isInfixOf` err + && "codex-cli" `Text.isInfixOf` err + Right _ -> False + + it "allows a model-only override while keeping the default provider" $ + resolveAgentModelConfig (baseInputs {cliModel = Just "sonnet"}) + `shouldBe` Right + AgentModelConfig + { agentProvider = AgentProviderClaudeCli, + agentModel = Just "sonnet" + } + + it "ignores blank higher-precedence values" $ + resolveAgentModelConfig + (baseInputs {cliProvider = Just " ", envProvider = Just "codex-cli", cliModel = Just "", envModel = Just "gpt-5"}) + `shouldBe` Right + AgentModelConfig + { agentProvider = AgentProviderCodexCli, + agentModel = Just "gpt-5" + } + +baseInputs :: AgentConfigInputs +baseInputs = + AgentConfigInputs + { cliProvider = Nothing, + cliModel = Nothing, + envProvider = Nothing, + envModel = Nothing, + localConfig = Map.empty, + globalConfig = Map.empty + } + +config :: Text -> Text -> Map.Map Text Text +config provider model = + Map.fromList + [ (agentProviderConfigKey, provider), + (agentModelConfigKey, model) + ] diff --git a/test/Seihou/CLI/AgentLaunchSpec.hs b/test/Seihou/CLI/AgentLaunchSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AgentLaunchSpec.hs @@ -0,0 +1,163 @@ +module Seihou.CLI.AgentLaunchSpec (tests) where + +import Data.List (nub) +import Data.Text qualified as T +import Seihou.CLI.AgentLaunch + ( AgentContext (..), + BaselineStatus (..), + formatAvailableModules, + formatBaselineStatus, + formatBlueprintIdentity, + formatLocalModules, + formatManifestState, + formatModuleDhallState, + formatReferenceFiles, + formatReferenceFilesDir, + formatSeihouProjectState, + resolveBlueprintTools, + setupAllowedTools, + substitute, + ) +import Seihou.Core.Types + ( Blueprint (..), + BlueprintFile (..), + ModuleName (..), + ) +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.AgentLaunch" $ do + describe "substitute" $ do + it "replaces a single key" $ + substitute [("name", "Alice")] "Hello {{name}}" + `shouldBe` "Hello Alice" + it "replaces multiple keys" $ + substitute [("a", "1"), ("b", "2")] "{{a}}-{{b}}" + `shouldBe` "1-2" + it "leaves unknown keys untouched" $ + substitute [("a", "1")] "{{a}} and {{c}}" + `shouldBe` "1 and {{c}}" + it "is a no-op on a template with no placeholders" $ + substitute [("a", "1")] "no placeholders here" + `shouldBe` "no placeholders here" + + describe "AgentContext formatters" $ do + let baseCtx = + AgentContext + { cwd = "/tmp/test", + seihouInitialized = False, + hasManifest = False, + localModuleDhall = False, + localModules = [], + availableModules = [] + } + + describe "formatSeihouProjectState" $ do + it "names .seihou/ when initialised" $ + formatSeihouProjectState (baseCtx {seihouInitialized = True}) + `shouldBe` "Seihou project: .seihou/ directory exists (this is a seihou-managed project)" + it "states 'No .seihou/' when not initialised" $ + formatSeihouProjectState baseCtx + `shouldBe` "Seihou project: No .seihou/ directory (not yet a seihou project in this directory)" + + describe "formatManifestState" $ do + it "names manifest.json when present" $ + formatManifestState (baseCtx {hasManifest = True}) + `shouldBe` "Manifest: .seihou/manifest.json exists (modules have been applied here)" + it "reports no manifest otherwise" $ + formatManifestState baseCtx + `shouldBe` "Manifest: No manifest (no modules applied yet)" + + describe "formatModuleDhallState" $ do + it "names module.dhall when present in cwd" $ + formatModuleDhallState (baseCtx {localModuleDhall = True}) + `shouldBe` "Module in cwd: module.dhall found in current directory (user is authoring a module here)" + it "is empty when module.dhall is absent" $ + formatModuleDhallState baseCtx `shouldBe` "" + + describe "formatLocalModules" $ do + it "is empty when there are no local modules" $ + formatLocalModules baseCtx `shouldBe` "" + it "lists local modules with bullet prefixes" $ + formatLocalModules (baseCtx {localModules = ["foo", "bar"]}) + `shouldBe` "Local modules:\n - foo\n - bar" + + describe "formatAvailableModules" $ do + it "states 'None discovered' when empty" $ + formatAvailableModules baseCtx + `shouldBe` "Available modules: None discovered" + it "renders entries as 'name — description (source)' lines" $ + formatAvailableModules + (baseCtx {availableModules = [("foo", "the foo module", "user")]}) + `shouldBe` "Available modules across search paths:\n - foo — the foo module (user)" + + describe "formatBaselineStatus" $ do + it "names --no-baseline as the reason when skipped" $ + formatBaselineStatus BaselineSkipped + `shouldBe` "(no baseline applied — `--no-baseline` was passed)" + it "calls out an empty baseModules list" $ + formatBaselineStatus BaselineEmpty + `shouldBe` "(this blueprint declares no base modules)" + it "renders an applied versioned module as a bullet" $ + formatBaselineStatus (BaselineApplied [(ModuleName "foo", Just "1.0.0")]) + `shouldBe` " - foo (v1.0.0)" + it "renders an applied unversioned module as a bullet" $ + formatBaselineStatus (BaselineApplied [(ModuleName "foo", Nothing)]) + `shouldBe` " - foo (unversioned)" + + describe "formatReferenceFiles" $ do + it "states '(no reference files)' when empty" $ + formatReferenceFiles [] `shouldBe` "(no reference files)" + it "renders an entry with a description as 'path — description'" $ + formatReferenceFiles [BlueprintFile {src = "x.txt", description = Just "an example"}] + `shouldBe` " - x.txt — an example" + it "renders an entry without a description as just the path" $ + formatReferenceFiles [BlueprintFile {src = "y.txt", description = Nothing}] + `shouldBe` " - y.txt" + + describe "formatReferenceFilesDir" $ do + it "renders the mounted path with read-directly guidance" $ do + let rendered = formatReferenceFilesDir (Just "/tmp/bp/files") + rendered `shouldSatisfy` T.isInfixOf "/tmp/bp/files" + rendered `shouldSatisfy` T.isInfixOf "open them directly" + it "renders the ask-the-user fallback when no directory is mounted" $ do + let rendered = formatReferenceFilesDir Nothing + rendered `shouldSatisfy` T.isInfixOf "ask the user" + rendered `shouldSatisfy` (not . T.isInfixOf "readable at") + + describe "resolveBlueprintTools" $ do + it "returns exactly the base set when nothing is declared" $ + resolveBlueprintTools Nothing `shouldBe` setupAllowedTools + it "unions declared tools onto the base set without duplicates" $ do + let result = resolveBlueprintTools (Just ["Bash(mori *)"]) + result `shouldSatisfy` (\tools -> all (`elem` tools) setupAllowedTools) + result `shouldSatisfy` (elem "Bash(mori *)") + length result `shouldBe` length (nub result) + it "does not duplicate a declared base tool" $ + resolveBlueprintTools (Just ["Read"]) `shouldBe` setupAllowedTools + + describe "formatBlueprintIdentity" $ do + let mk v d = + Blueprint + { name = ModuleName "bp", + version = v, + description = d, + prompt = "", + vars = [], + prompts = [], + baseModules = [], + files = [], + allowedTools = Nothing, + tags = [] + } + it "renders name, version, description as a three-line block" $ + formatBlueprintIdentity (mk (Just "0.1") (Just "a thing")) + `shouldBe` "Name: bp\nVersion: 0.1\nDescription: a thing" + it "names '(unspecified)' when version is missing" $ + formatBlueprintIdentity (mk Nothing (Just "a thing")) + `shouldBe` "Name: bp\nVersion: (unspecified)\nDescription: a thing" + it "names '(no description)' when description is missing" $ + formatBlueprintIdentity (mk (Just "0.1") Nothing) + `shouldBe` "Name: bp\nVersion: 0.1\nDescription: (no description)" diff --git a/test/Seihou/CLI/AppliedBlueprintSpec.hs b/test/Seihou/CLI/AppliedBlueprintSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/AppliedBlueprintSpec.hs @@ -0,0 +1,106 @@ +module Seihou.CLI.AppliedBlueprintSpec (tests) where + +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Seihou.CLI.AppliedBlueprint (recordAppliedBlueprint) +import Seihou.Core.Types + ( AppliedBlueprint (..), + AppliedRecipe (..), + Manifest (..), + ModuleName (..), + RecipeName (..), + ) +import Seihou.Manifest.Types (currentManifestVersion, emptyManifest, manifestFromJSON, manifestToJSON) +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.CLI.AppliedBlueprint" spec + +fixedTime :: UTCTime +fixedTime = + parseTimeOrError + True + defaultTimeLocale + "%Y-%m-%dT%H:%M:%SZ" + "2026-05-12T14:23:00Z" + +mkEntry :: Text -> Maybe Text -> [Text] -> Bool -> Maybe Text -> AppliedBlueprint +mkEntry name mver baseline noBL prompt = + AppliedBlueprint + { name = ModuleName name, + blueprintVersion = mver, + appliedAt = fixedTime, + baselineModules = map ModuleName baseline, + noBaseline = noBL, + userPrompt = prompt, + agentSessionId = Nothing + } + +readManifestFile :: FilePath -> IO Manifest +readManifestFile path = do + bs <- LBS.readFile path + case manifestFromJSON bs of + Right m -> pure m + Left err -> error ("test fixture: malformed manifest: " <> err) + +spec :: Spec +spec = do + describe "recordAppliedBlueprint" $ do + it "creates a fresh manifest when none exists" $ + withSystemTempDirectory "seihou-ab" $ \dir -> do + let manifestPath = dir ".seihou" "manifest.json" + entry = mkEntry "payments-service" (Just "0.3.1") ["nix-flake"] False (Just "set up payments") + res <- recordAppliedBlueprint manifestPath entry + res `shouldBe` Right () + m <- readManifestFile manifestPath + m.version `shouldBe` currentManifestVersion + m.blueprint `shouldBe` Just entry + + it "preserves unrelated manifest fields" $ + withSystemTempDirectory "seihou-ab" $ \dir -> do + let manifestPath = dir "manifest.json" + seedRecipe = + AppliedRecipe + { name = RecipeName "haskell-library", + recipeVersion = Just "1.2.0", + appliedAt = fixedTime + } + seed = + (emptyManifest fixedTime) + { recipe = Just seedRecipe, + vars = Map.empty + } + LBS.writeFile manifestPath (manifestToJSON seed) + let entry = mkEntry "payments-service" Nothing [] True Nothing + res <- recordAppliedBlueprint manifestPath entry + res `shouldBe` Right () + m <- readManifestFile manifestPath + m.recipe `shouldBe` Just seedRecipe + m.blueprint `shouldBe` Just entry + + it "overwrites a prior blueprint entry" $ + withSystemTempDirectory "seihou-ab" $ \dir -> do + let manifestPath = dir "manifest.json" + ab1 = mkEntry "first" Nothing [] False Nothing + ab2 = mkEntry "second" (Just "0.2.0") ["base"] False (Just "second run") + _ <- recordAppliedBlueprint manifestPath ab1 + _ <- recordAppliedBlueprint manifestPath ab2 + m <- readManifestFile manifestPath + m.blueprint `shouldBe` Just ab2 + + it "returns Left when the existing manifest is unreadable" $ + withSystemTempDirectory "seihou-ab" $ \dir -> do + let manifestPath = dir "manifest.json" + writeFile manifestPath "{ this is not valid json" + let entry = mkEntry "x" Nothing [] False Nothing + res <- recordAppliedBlueprint manifestPath entry + case res of + Left err -> err `shouldSatisfy` not . T.null + Right () -> expectationFailure "expected Left for corrupt manifest" diff --git a/test/Seihou/CLI/BrowseFormatSpec.hs b/test/Seihou/CLI/BrowseFormatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/BrowseFormatSpec.hs @@ -0,0 +1,211 @@ +module Seihou.CLI.BrowseFormatSpec (tests) where + +import Data.Text (Text, pack) +import Seihou.CLI.BrowseFormat (formatBrowseRegistry, formatBrowseSingleBlueprint, formatBrowseSingleModule, formatBrowseSinglePrompt) +import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..)) +import Seihou.Core.Types (ModuleName (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.BrowseFormat" spec + +mkEntry :: String -> String -> Maybe String -> [String] -> RegistryEntry +mkEntry n p desc ts = + RegistryEntry + { name = ModuleName (pack n), + version = Nothing, + path = p, + description = fmap pack desc, + tags = map pack ts + } + +mkRegistry :: String -> Maybe String -> [RegistryEntry] -> Registry +mkRegistry n desc ms = + Registry + { repoName = pack n, + repoDescription = fmap pack desc, + modules = ms, + recipes = [], + blueprints = [], + prompts = [] + } + +asModules :: [RegistryEntry] -> [(EntryKind, RegistryEntry)] +asModules = map ((,) ModuleEntry) + +spec :: Spec +spec = do + describe "formatBrowseSingleModule" $ do + it "formats single module with description" $ do + let result = formatBrowseSingleModule "https://github.com/user/repo" "haskell-base" (Just "Base Haskell setup") + result + `shouldBe` "haskell-base\n\ + \ Base Haskell setup\n\ + \\n\ + \Single-module repository. Install with:\n\ + \ seihou install https://github.com/user/repo\n" + + it "formats single module without description" $ do + let result = formatBrowseSingleModule "https://github.com/user/repo" "minimal" Nothing + result + `shouldBe` "minimal\n\ + \\n\ + \Single-module repository. Install with:\n\ + \ seihou install https://github.com/user/repo\n" + + describe "formatBrowseSingleBlueprint" $ do + it "formats single blueprint with description" $ do + let result = formatBrowseSingleBlueprint "https://github.com/user/bp" "payments-service" (Just "Agent-driven payments scaffold") + result + `shouldBe` "payments-service\n\ + \ Agent-driven payments scaffold\n\ + \\n\ + \Single-blueprint repository. Install with:\n\ + \ seihou install https://github.com/user/bp\n" + + it "formats single blueprint without description" $ do + let result = formatBrowseSingleBlueprint "https://github.com/user/bp" "minimal-bp" Nothing + result + `shouldBe` "minimal-bp\n\ + \\n\ + \Single-blueprint repository. Install with:\n\ + \ seihou install https://github.com/user/bp\n" + + describe "formatBrowseSinglePrompt" $ do + it "formats single prompt with description" $ do + let result = formatBrowseSinglePrompt "https://github.com/user/prompt" "review-changes" (Just "Review the current diff") + result + `shouldBe` "review-changes\n\ + \ Review the current diff\n\ + \\n\ + \Single-prompt repository. Install with:\n\ + \ seihou install https://github.com/user/prompt\n" + + it "formats single prompt without description" $ do + let result = formatBrowseSinglePrompt "https://github.com/user/prompt" "quick-note" Nothing + result + `shouldBe` "quick-note\n\ + \\n\ + \Single-prompt repository. Install with:\n\ + \ seihou install https://github.com/user/prompt\n" + + describe "formatBrowseRegistry" $ do + it "formats multi-module registry with kind labels" $ do + let entries = + [ mkEntry "haskell-base" "modules/haskell-base" (Just "Base Haskell project") ["haskell"], + mkEntry "nix-flake" "modules/nix-flake" (Just "Nix flake setup") ["nix", "devops"] + ] + registry = mkRegistry "my-templates" (Just "A collection of project templates") entries + result = formatBrowseRegistry "https://github.com/user/templates" registry (asModules entries) Nothing + result + `shouldBe` "my-templates\n\ + \A collection of project templates\n\ + \\n\ + \Available entries:\n\ + \\n\ + \ [module] haskell-base Base Haskell project [haskell]\n\ + \ [module] nix-flake Nix flake setup [nix, devops]\n\ + \\n\ + \2 entries available. Install with:\n\ + \ seihou install https://github.com/user/templates --module \n\ + \ seihou install https://github.com/user/templates --all\n" + + it "formats registry with no description" $ do + let entries = [mkEntry "only-mod" "modules/only-mod" (Just "The only module") []] + registry = mkRegistry "simple-repo" Nothing entries + result = formatBrowseRegistry "https://github.com/user/repo" registry (asModules entries) Nothing + result + `shouldBe` "simple-repo\n\ + \\n\ + \Available entries:\n\ + \\n\ + \ [module] only-mod The only module\n\ + \\n\ + \1 entry available. Install with:\n\ + \ seihou install https://github.com/user/repo --module \n\ + \ seihou install https://github.com/user/repo --all\n" + + it "formats empty registry" $ do + let registry = mkRegistry "empty-repo" (Just "Nothing here") [] + result = formatBrowseRegistry "source" registry [] Nothing + result + `shouldBe` "empty-repo\n\ + \Nothing here\n\ + \\n\ + \No entries in registry.\n" + + it "formats tag filter with no matches" $ do + let registry = mkRegistry "my-templates" Nothing [] + result = formatBrowseRegistry "source" registry [] (Just "rust") + result + `shouldBe` "my-templates\n\ + \\n\ + \No entries matching tag 'rust'.\n" + + it "formats filtered results by tag" $ do + let allMods = + [ mkEntry "haskell-base" "modules/haskell-base" (Just "Haskell setup") ["haskell"], + mkEntry "nix-flake" "modules/nix-flake" (Just "Nix flake") ["nix"] + ] + filtered = [head allMods] -- only the haskell one + registry = mkRegistry "templates" Nothing allMods + result = formatBrowseRegistry "source" registry (asModules filtered) (Just "haskell") + result + `shouldBe` "templates\n\ + \\n\ + \Available entries:\n\ + \\n\ + \ [module] haskell-base Haskell setup [haskell]\n\ + \\n\ + \1 entry available. Install with:\n\ + \ seihou install source --module \n\ + \ seihou install source --all\n" + + it "aligns columns when names have different lengths" $ do + let entries = + [ mkEntry "a" "modules/a" (Just "Short name") [], + mkEntry "very-long-module-name" "modules/vlmn" (Just "Long name") [] + ] + registry = mkRegistry "repo" Nothing entries + result = formatBrowseRegistry "source" registry (asModules entries) Nothing + -- The short name should be padded to match the longest + result + `shouldBe` "repo\n\ + \\n\ + \Available entries:\n\ + \\n\ + \ [module] a Short name\n\ + \ [module] very-long-module-name Long name\n\ + \\n\ + \2 entries available. Install with:\n\ + \ seihou install source --module \n\ + \ seihou install source --all\n" + + it "formats a mixed-kind registry with module, recipe, blueprint, and prompt labels" $ do + let modEntry = mkEntry "haskell-base" "modules/haskell-base" (Just "Module entry") ["haskell"] + recEntry = mkEntry "lib-recipe" "recipes/lib-recipe" (Just "Recipe entry") [] + bpEntry = mkEntry "payments-service" "blueprints/payments-service" (Just "Blueprint entry") [] + promptEntry = mkEntry "review-changes" "prompts/review-changes" (Just "Prompt entry") ["review"] + mixed = + [ (ModuleEntry, modEntry), + (RecipeEntry, recEntry), + (BlueprintEntry, bpEntry), + (PromptEntry, promptEntry) + ] + registry = mkRegistry "mixed-repo" Nothing [modEntry] + result = formatBrowseRegistry "source" registry mixed Nothing + result + `shouldBe` "mixed-repo\n\ + \\n\ + \Available entries:\n\ + \\n\ + \ [module] haskell-base Module entry [haskell]\n\ + \ [recipe] lib-recipe Recipe entry\n\ + \ [blueprint] payments-service Blueprint entry\n\ + \ [prompt] review-changes Prompt entry [review]\n\ + \\n\ + \4 entries available. Install with:\n\ + \ seihou install source --module \n\ + \ seihou install source --all\n" diff --git a/test/Seihou/CLI/CommitMessageSpec.hs b/test/Seihou/CLI/CommitMessageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/CommitMessageSpec.hs @@ -0,0 +1,47 @@ +module Seihou.CLI.CommitMessageSpec (tests) where + +import Data.Text qualified as T +import Seihou.CLI.CommitMessage (generateCommitMessage, stripCodeFence) +import Seihou.Core.Types (ModuleName (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.CommitMessage" spec + +spec :: Spec +spec = do + describe "generateCommitMessage" $ do + it "returns a non-empty message for a single module" $ do + msg <- generateCommitMessage [ModuleName "haskell-base"] "diff content" + T.null msg `shouldBe` False + + it "returns a non-empty message for multiple modules" $ do + msg <- generateCommitMessage [ModuleName "base", ModuleName "extras"] "diff content" + T.null msg `shouldBe` False + + it "returns a non-empty message with empty diff" $ do + msg <- generateCommitMessage [ModuleName "haskell-base"] "" + T.null msg `shouldBe` False + + describe "stripCodeFence" $ do + it "strips triple-backtick fencing" $ do + stripCodeFence "```\nfeat: apply module\n```" `shouldBe` "feat: apply module" + + it "strips fencing with language tag" $ do + stripCodeFence "```text\nfeat: apply module\n```" `shouldBe` "feat: apply module" + + it "leaves unfenced text unchanged" $ do + stripCodeFence "feat: apply module" `shouldBe` "feat: apply module" + + it "leaves text with backticks in the middle unchanged" $ do + let input = "feat: use ```code``` in template" + stripCodeFence input `shouldBe` input + + it "handles empty input" $ do + stripCodeFence "" `shouldBe` "" + + it "preserves multiline commit messages inside fences" $ do + stripCodeFence "```\nfeat: apply modules\n\nApply base and extras.\n```" + `shouldBe` "feat: apply modules\n\nApply base and extras." diff --git a/test/Seihou/CLI/DiffSpec.hs b/test/Seihou/CLI/DiffSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/DiffSpec.hs @@ -0,0 +1,70 @@ +module Seihou.CLI.DiffSpec (tests) where + +import Data.Text qualified as T +import Seihou.CLI.Diff (formatDiffOutput) +import Seihou.Core.Types (ModuleName (..), TrackedFile (..), TrackedFileStatus (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Diff" spec + +spec :: Spec +spec = do + describe "formatDiffOutput" $ do + it "shows no-changes message when all files unchanged" $ do + let tracked = + [ TrackedFile "README.md" (ModuleName "haskell-base") TfsUnchanged, + TrackedFile "src/Lib.hs" (ModuleName "haskell-base") TfsUnchanged + ] + result = formatDiffOutput False tracked + result `shouldBe` "No changes since last generation.\n" + + it "includes header line" $ do + let tracked = + [ TrackedFile "src/Lib.hs" (ModuleName "haskell-base") TfsModified + ] + result = formatDiffOutput False tracked + T.isInfixOf "Seihou Diff:" result `shouldBe` True + + it "shows modified files" $ do + let tracked = + [ TrackedFile "src/Lib.hs" (ModuleName "haskell-base") TfsModified + ] + result = formatDiffOutput False tracked + T.isInfixOf "modified" result `shouldBe` True + T.isInfixOf "src/Lib.hs" result `shouldBe` True + + it "shows deleted files" $ do + let tracked = + [ TrackedFile "app/Main.hs" (ModuleName "haskell-base") TfsDeleted + ] + result = formatDiffOutput False tracked + T.isInfixOf "deleted" result `shouldBe` True + T.isInfixOf "app/Main.hs" result `shouldBe` True + + it "shows summary count line" $ do + let tracked = + [ TrackedFile "README.md" (ModuleName "haskell-base") TfsUnchanged, + TrackedFile "src/Lib.hs" (ModuleName "haskell-base") TfsModified, + TrackedFile "app/Main.hs" (ModuleName "haskell-base") TfsDeleted + ] + result = formatDiffOutput False tracked + T.isInfixOf "1 unchanged, 1 modified, 1 deleted" result `shouldBe` True + + it "shows module attribution in parentheses" $ do + let tracked = + [ TrackedFile "src/Lib.hs" (ModuleName "haskell-base") TfsModified + ] + result = formatDiffOutput False tracked + T.isInfixOf "(haskell-base)" result `shouldBe` True + + it "hides unchanged files from main listing" $ do + let tracked = + [ TrackedFile "README.md" (ModuleName "haskell-base") TfsUnchanged, + TrackedFile "src/Lib.hs" (ModuleName "haskell-base") TfsModified + ] + result = formatDiffOutput False tracked + bodyLines = filter (T.isInfixOf "README.md") (T.lines result) + bodyLines `shouldBe` [] diff --git a/test/Seihou/CLI/ExtensionSpec.hs b/test/Seihou/CLI/ExtensionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/ExtensionSpec.hs @@ -0,0 +1,64 @@ +module Seihou.CLI.ExtensionSpec (tests) where + +import Control.Exception (bracket_) +import Seihou.CLI.Extension +import System.Directory + ( getPermissions, + setOwnerExecutable, + setPermissions, + ) +import System.Environment (getEnv, setEnv) +import System.Exit (ExitCode (..)) +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.CLI.Extension" spec + +spec :: Spec +spec = do + describe "extensionExecutableName" $ do + it "uses the seihou extension executable naming convention" $ do + extensionExecutableName "okf" `shouldBe` "seihou-okf-extension" + + describe "runExtension" $ do + it "reports a missing executable by its resolved name" $ do + result <- runExtension (ExtensionRunOpts "missing-extension-spec" ["--help"]) + result `shouldBe` Left (ExtensionNotFound "missing-extension-spec" "seihou-missing-extension-spec-extension") + + it "forwards arguments to the resolved extension executable unchanged" $ + withSystemTempDirectory "seihou-extension-spec" $ \dir -> do + let exePath = dir "seihou-okf-extension" + argsPath = dir "args.txt" + writeFile exePath $ + unlines + [ "#!/bin/sh", + "printf '%s\\n' \"$@\" > " <> show argsPath + ] + permissions <- getPermissions exePath + setPermissions exePath (setOwnerExecutable True permissions) + withPrependedPath dir $ do + result <- runExtension (ExtensionRunOpts "okf" ["docs", "--dir", "."]) + result `shouldBe` Right () + readFile argsPath `shouldReturn` "docs\n--dir\n.\n" + + it "reports the extension exit code when the executable fails" $ + withSystemTempDirectory "seihou-extension-failure-spec" $ \dir -> do + let exePath = dir "seihou-okf-extension" + writeFile exePath "#!/bin/sh\nexit 42\n" + permissions <- getPermissions exePath + setPermissions exePath (setOwnerExecutable True permissions) + withPrependedPath dir $ do + result <- runExtension (ExtensionRunOpts "okf" []) + result `shouldBe` Left (ExtensionExited "okf" (ExitFailure 42)) + +withPrependedPath :: FilePath -> IO a -> IO a +withPrependedPath dir action = do + originalPath <- getEnv "PATH" + bracket_ + (setEnv "PATH" (dir <> ":" <> originalPath)) + (setEnv "PATH" originalPath) + action diff --git a/test/Seihou/CLI/GitSpec.hs b/test/Seihou/CLI/GitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/GitSpec.hs @@ -0,0 +1,132 @@ +module Seihou.CLI.GitSpec (tests) where + +import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) +import Seihou.Effect.ProcessPure (ProcessMock (..), runProcessPure) +import Seihou.Prelude +import System.Exit (ExitCode (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Git" spec + +spec :: Spec +spec = do + describe "isGitRepo" $ do + it "returns True when git rev-parse succeeds" $ do + let mocks = + [ ProcessMock + "git" + ["rev-parse", "--is-inside-work-tree"] + (ExitSuccess, "true\n", "") + ] + result <- runEff $ runProcessPure mocks isGitRepo + result `shouldBe` True + + it "returns False when git rev-parse fails" $ do + let mocks = + [ ProcessMock + "git" + ["rev-parse", "--is-inside-work-tree"] + (ExitFailure 128, "", "fatal: not a git repository\n") + ] + result <- runEff $ runProcessPure mocks isGitRepo + result `shouldBe` False + + it "returns False when git is not found" $ do + result <- runEff $ runProcessPure [] isGitRepo + result `shouldBe` False + + describe "gitAdd" $ do + it "stages specified files" $ do + let mocks = + [ ProcessMock + "git" + ["add", "README.md", "src/Lib.hs"] + (ExitSuccess, "", "") + ] + (exitCode, _, _) <- runEff $ runProcessPure mocks $ gitAdd ["README.md", "src/Lib.hs"] + exitCode `shouldBe` ExitSuccess + + it "returns failure for nonexistent files" $ do + let mocks = + [ ProcessMock + "git" + ["add", "missing.txt"] + (ExitFailure 128, "", "fatal: pathspec 'missing.txt' did not match any files\n") + ] + (exitCode, _, _) <- runEff $ runProcessPure mocks $ gitAdd ["missing.txt"] + exitCode `shouldBe` ExitFailure 128 + + describe "gitCommit" $ do + it "creates a commit with given message" $ do + let mocks = + [ ProcessMock + "git" + ["commit", "-m", "feat: add scaffolding"] + (ExitSuccess, "[main abc1234] feat: add scaffolding\n 2 files changed\n", "") + ] + (exitCode, _, _) <- runEff $ runProcessPure mocks $ gitCommit "feat: add scaffolding" + exitCode `shouldBe` ExitSuccess + + it "returns failure when nothing to commit" $ do + let mocks = + [ ProcessMock + "git" + ["commit", "-m", "empty"] + (ExitFailure 1, "", "nothing to commit, working tree clean\n") + ] + (exitCode, _, stderr) <- runEff $ runProcessPure mocks $ gitCommit "empty" + exitCode `shouldBe` ExitFailure 1 + stderr `shouldBe` "nothing to commit, working tree clean\n" + + describe "gitCheckIgnore" $ do + it "returns ignored files when git check-ignore succeeds" $ do + let mocks = + [ ProcessMock + "git" + ["check-ignore", "README.md", "dist/bundle.js", ".env"] + (ExitSuccess, "dist/bundle.js\n.env\n", "") + ] + result <- runEff $ runProcessPure mocks $ gitCheckIgnore ["README.md", "dist/bundle.js", ".env"] + result `shouldBe` ["dist/bundle.js", ".env"] + + it "returns empty list when no files are ignored (exit 1)" $ do + let mocks = + [ ProcessMock + "git" + ["check-ignore", "README.md", "src/Lib.hs"] + (ExitFailure 1, "", "") + ] + result <- runEff $ runProcessPure mocks $ gitCheckIgnore ["README.md", "src/Lib.hs"] + result `shouldBe` [] + + it "returns empty list on error (exit 128)" $ do + let mocks = + [ ProcessMock + "git" + ["check-ignore", "README.md"] + (ExitFailure 128, "", "fatal: not a git repository\n") + ] + result <- runEff $ runProcessPure mocks $ gitCheckIgnore ["README.md"] + result `shouldBe` [] + + it "returns empty list for empty input" $ do + result <- runEff $ runProcessPure [] $ gitCheckIgnore [] + result `shouldBe` [] + + describe "gitDiffCached" $ do + it "returns stat and diff combined" $ do + let mocks = + [ ProcessMock + "git" + ["diff", "--cached", "--stat"] + (ExitSuccess, " README.md | 1 +\n", ""), + ProcessMock + "git" + ["diff", "--cached"] + (ExitSuccess, "+hello world\n", "") + ] + result <- runEff $ runProcessPure mocks gitDiffCached + result `shouldBe` " README.md | 1 +\n\n+hello world\n" diff --git a/test/Seihou/CLI/InitSpec.hs b/test/Seihou/CLI/InitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/InitSpec.hs @@ -0,0 +1,62 @@ +module Seihou.CLI.InitSpec (tests) where + +import Data.Text qualified as T +import Seihou.CLI.Init (formatInitOutput) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Init" spec + +spec :: Spec +spec = do + describe "formatInitOutput" $ do + it "includes header with base path" $ do + let result = formatInitOutput "~/.config/seihou" [] + T.isInfixOf "Initialized Seihou configuration at ~/.config/seihou/" result + `shouldBe` True + + it "shows Created: for newly created items" $ do + let items = [("config.dhall", "global defaults", True)] + result = formatInitOutput "~/.config/seihou" items + T.isInfixOf "Created: config.dhall (global defaults)" result + `shouldBe` True + + it "shows Exists: for already existing items" $ do + let items = [("config.dhall", "global defaults", False)] + result = formatInitOutput "~/.config/seihou" items + T.isInfixOf "Exists: config.dhall (global defaults)" result + `shouldBe` True + + it "formats all three spec items correctly when all created" $ do + let items = + [ ("config.dhall", "global defaults", True), + ("modules/", "user modules", True), + ("installed/", "git-installed modules", True) + ] + result = formatInitOutput "~/.config/seihou" items + resultLines = T.lines result + length resultLines `shouldBe` 4 + (resultLines !! 0) `shouldBe` "Initialized Seihou configuration at ~/.config/seihou/" + (resultLines !! 1) `shouldBe` " Created: config.dhall (global defaults)" + (resultLines !! 2) `shouldBe` " Created: modules/ (user modules)" + (resultLines !! 3) `shouldBe` " Created: installed/ (git-installed modules)" + + it "formats mixed created and existing items" $ do + let items = + [ ("config.dhall", "global defaults", False), + ("modules/", "user modules", True), + ("installed/", "git-installed modules", False) + ] + result = formatInitOutput "~/.config/seihou" items + resultLines = T.lines result + (resultLines !! 1) `shouldBe` " Exists: config.dhall (global defaults)" + (resultLines !! 2) `shouldBe` " Created: modules/ (user modules)" + (resultLines !! 3) `shouldBe` " Exists: installed/ (git-installed modules)" + + it "uses two-space indentation for items" $ do + let items = [("test.txt", "test file", True)] + result = formatInitOutput "~/path" items + resultLines = T.lines result + T.isPrefixOf " " (resultLines !! 1) `shouldBe` True diff --git a/test/Seihou/CLI/InstallHistorySpec.hs b/test/Seihou/CLI/InstallHistorySpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/InstallHistorySpec.hs @@ -0,0 +1,86 @@ +module Seihou.CLI.InstallHistorySpec (tests) where + +import Data.Text qualified as T +import Seihou.CLI.InstallHistory + ( HistoryEntry (..), + InstallHistory (..), + maxHistoryEntries, + readHistoryFrom, + recordUrlTo, + writeHistoryTo, + ) +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.CLI.InstallHistory" spec + +spec :: Spec +spec = do + describe "readHistoryFrom" $ do + it "returns empty history when file does not exist" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + h <- readHistoryFrom (tmp "nonexistent.json") + h.entries `shouldBe` [] + + it "returns empty history for malformed JSON" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + let path = tmp "bad.json" + writeFile path "not json" + h <- readHistoryFrom path + h.entries `shouldBe` [] + + describe "writeHistoryTo / readHistoryFrom round-trip" $ do + it "round-trips an empty history" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + let path = tmp "history.json" + original = InstallHistory [] + writeHistoryTo path original + result <- readHistoryFrom path + result `shouldBe` original + + it "round-trips a history with entries" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + let path = tmp "history.json" + original = + InstallHistory + [ HistoryEntry "https://github.com/a/b.git" "2026-01-01T00:00:00Z", + HistoryEntry "https://github.com/c/d.git" "2025-12-01T00:00:00Z" + ] + writeHistoryTo path original + result <- readHistoryFrom path + result `shouldBe` original + + describe "recordUrlTo" $ do + it "creates a history file when none exists" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + let path = tmp "history.json" + recordUrlTo path "https://github.com/foo/bar.git" + exists <- doesFileExist path + exists `shouldBe` True + h <- readHistoryFrom path + length h.entries `shouldBe` 1 + (head h.entries).url `shouldBe` "https://github.com/foo/bar.git" + + it "deduplicates by URL, keeping most recent first" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + let path = tmp "history.json" + recordUrlTo path "https://github.com/a/first.git" + recordUrlTo path "https://github.com/b/second.git" + recordUrlTo path "https://github.com/a/first.git" + h <- readHistoryFrom path + length h.entries `shouldBe` 2 + (head h.entries).url `shouldBe` "https://github.com/a/first.git" + + it "caps history at maxHistoryEntries" $ do + withSystemTempDirectory "history-test" $ \tmp -> do + let path = tmp "history.json" + mapM_ + (\i -> recordUrlTo path ("https://example.com/repo-" <> T.pack (show i) <> ".git")) + [1 .. maxHistoryEntries + 5 :: Int] + h <- readHistoryFrom path + length h.entries `shouldBe` maxHistoryEntries diff --git a/test/Seihou/CLI/ListSpec.hs b/test/Seihou/CLI/ListSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/ListSpec.hs @@ -0,0 +1,267 @@ +module Seihou.CLI.ListSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.CLI.List (Entry (..), ListFilter (..), applyFilters, formatListOutput, formatListOutputEntries, runnableToEntryWithOrigin) +import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..)) +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.List" spec + +-- | A valid discovered module for testing. +validModule :: String -> String -> ModuleSource -> DiscoveredModule +validModule name desc src = + DiscoveredModule + { discoveredResult = + Right + Module + { name = ModuleName (T.pack name), + version = Nothing, + description = Just (T.pack desc), + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + }, + discoveredSource = src, + discoveredDir = "/fake/" ++ name + } + +-- | A broken discovered module for testing. +brokenModule :: String -> ModuleSource -> DiscoveredModule +brokenModule name src = + DiscoveredModule + { discoveredResult = Left (DhallEvalError (ModuleName (T.pack name)) "parse error"), + discoveredSource = src, + discoveredDir = "/fake/" ++ name + } + +-- | Helper to build an Entry for filter tests. Defaults the kind to a module. +mkEntry :: T.Text -> Maybe T.Text -> [T.Text] -> Entry +mkEntry = mkEntryK KindModule + +-- | Helper to build an Entry with an explicit kind for kind-filter tests. +mkEntryK :: RunnableKind -> T.Text -> Maybe T.Text -> [T.Text] -> Entry +mkEntryK kind name repo tags = + Entry + { entryName = name, + entryDesc = "desc", + entrySource = "installed", + entryIsError = False, + entryRepoName = repo, + entryTags = tags, + entryKind = kind + } + +noFilter :: ListFilter +noFilter = ListFilter Nothing Nothing [] + +spec :: Spec +spec = do + describe "formatListOutput" $ do + it "shows no-items message when list is empty" $ do + let result = formatListOutput False [] ["path1", "path2"] + T.isInfixOf "No items found." result `shouldBe` True + T.isInfixOf "path1" result `shouldBe` True + T.isInfixOf "path2" result `shouldBe` True + + it "shows available modules header" $ do + let mods = [validModule "test-mod" "A test module" SourceUser] + result = formatListOutput False mods ["p1", "p2", "p3"] + T.isInfixOf "Available modules, recipes, blueprints, and prompts:" result `shouldBe` True + + it "shows module name and description" $ do + let mods = [validModule "haskell-base" "Haskell boilerplate" SourceUser] + result = formatListOutput False mods ["p1"] + T.isInfixOf "haskell-base" result `shouldBe` True + T.isInfixOf "Haskell boilerplate" result `shouldBe` True + + it "shows source tag in parentheses" $ do + let mods = [validModule "my-mod" "desc" SourceInstalled] + result = formatListOutput False mods ["p1"] + T.isInfixOf "(installed)" result `shouldBe` True + + it "shows error indicator for failed modules" $ do + let mods = [brokenModule "broken-mod" SourceUser] + result = formatListOutput False mods ["p1"] + T.isInfixOf "[error:" result `shouldBe` True + T.isInfixOf "broken-mod" result `shouldBe` True + + it "shows count summary" $ do + let mods = + [ validModule "mod-a" "desc a" SourceProject, + validModule "mod-b" "desc b" SourceInstalled + ] + result = formatListOutput False mods ["p1", "p2", "p3"] + T.isInfixOf "2 modules found" result `shouldBe` True + T.isInfixOf "3 sources searched" result `shouldBe` True + + it "shows singular noun for one module" $ do + let mods = [validModule "only-one" "desc" SourceUser] + result = formatListOutput False mods ["p1"] + T.isInfixOf "1 module found" result `shouldBe` True + + describe "applyFilters" $ do + let entries = + [ mkEntry "mod-a" (Just "repo-x") ["haskell", "cli"], + mkEntry "mod-b" (Just "repo-x") ["python"], + mkEntry "mod-c" (Just "repo-y") ["haskell"], + mkEntry "mod-d" Nothing [] + ] + + it "returns all entries with no filters" $ do + let result = applyFilters noFilter entries + length result `shouldBe` 4 + + it "filters by repo name" $ do + let opts = ListFilter (Just "repo-x") Nothing [] + result = applyFilters opts entries + length result `shouldBe` 2 + map (.entryName) result `shouldBe` ["mod-a", "mod-b"] + + it "filters by tag" $ do + let opts = ListFilter Nothing (Just "haskell") [] + result = applyFilters opts entries + length result `shouldBe` 2 + map (.entryName) result `shouldBe` ["mod-a", "mod-c"] + + it "combines repo and tag filters with AND" $ do + let opts = ListFilter (Just "repo-x") (Just "haskell") [] + result = applyFilters opts entries + length result `shouldBe` 1 + map (.entryName) result `shouldBe` ["mod-a"] + + it "returns empty list when repo filter matches nothing" $ do + let opts = ListFilter (Just "nonexistent") Nothing [] + result = applyFilters opts entries + result `shouldBe` [] + + it "returns empty list when tag filter matches nothing" $ do + let opts = ListFilter Nothing (Just "ruby") [] + result = applyFilters opts entries + result `shouldBe` [] + + it "excludes modules without origin metadata when repo filter is active" $ do + let opts = ListFilter (Just "repo-x") Nothing [] + result = applyFilters opts entries + all (\e -> e.entryRepoName == Just "repo-x") result `shouldBe` True + + describe "applyFilters (by kind)" $ do + let mixed = + [ mkEntryK KindModule "mod-a" Nothing [], + mkEntryK KindRecipe "rec-a" Nothing [], + mkEntryK KindBlueprint "bp-a" Nothing [], + mkEntryK KindPrompt "prompt-a" Nothing [], + mkEntryK KindModule "mod-b" (Just "repo-x") ["haskell"] + ] + + it "keeps all kinds when filterKinds is empty" $ do + length (applyFilters (ListFilter Nothing Nothing []) mixed) `shouldBe` 5 + + it "keeps only modules with --modules" $ do + let result = applyFilters (ListFilter Nothing Nothing [KindModule]) mixed + map (.entryName) result `shouldBe` ["mod-a", "mod-b"] + + it "keeps only recipes with --recipes" $ do + let result = applyFilters (ListFilter Nothing Nothing [KindRecipe]) mixed + map (.entryName) result `shouldBe` ["rec-a"] + + it "keeps only blueprints with --blueprints" $ do + let result = applyFilters (ListFilter Nothing Nothing [KindBlueprint]) mixed + map (.entryName) result `shouldBe` ["bp-a"] + + it "keeps only prompts with --prompts" $ do + let result = applyFilters (ListFilter Nothing Nothing [KindPrompt]) mixed + map (.entryName) result `shouldBe` ["prompt-a"] + + it "unions kinds when several flags are given" $ do + let result = applyFilters (ListFilter Nothing Nothing [KindModule, KindRecipe]) mixed + map (.entryName) result `shouldBe` ["mod-a", "rec-a", "mod-b"] + + it "combines kind and repo with AND" $ do + let result = applyFilters (ListFilter (Just "repo-x") Nothing [KindModule]) mixed + map (.entryName) result `shouldBe` ["mod-b"] + + it "returns empty when kind matches nothing in the set" $ do + let onlyRecipes = filter (\e -> e.entryKind == KindRecipe) mixed + result = applyFilters (ListFilter Nothing Nothing [KindBlueprint]) onlyRecipes + result `shouldBe` [] + + describe "formatListOutputEntries (count noun)" $ do + let noFilterF = ListFilter Nothing Nothing [] + + it "uses the kind noun when all shown entries share one kind" $ do + let entries = [mkEntryK KindBlueprint "bp-a" Nothing [], mkEntryK KindBlueprint "bp-b" Nothing []] + result = formatListOutputEntries False entries ["p1"] noFilterF + T.isInfixOf "2 blueprints found" result `shouldBe` True + + it "uses the singular kind noun for one entry" $ do + let entries = [mkEntryK KindRecipe "rec-a" Nothing []] + result = formatListOutputEntries False entries ["p1"] noFilterF + T.isInfixOf "1 recipe found" result `shouldBe` True + + it "uses the prompt noun when all shown entries are prompts" $ do + let entries = [mkEntryK KindPrompt "review" Nothing [], mkEntryK KindPrompt "explain" Nothing []] + result = formatListOutputEntries False entries ["p1"] noFilterF + T.isInfixOf "2 prompts found" result `shouldBe` True + + it "falls back to the neutral noun for a mix of kinds" $ do + let entries = [mkEntryK KindModule "mod-a" Nothing [], mkEntryK KindRecipe "rec-a" Nothing []] + result = formatListOutputEntries False entries ["p1"] noFilterF + T.isInfixOf "2 items found" result `shouldBe` True + + it "names the kind in the empty message when filtered to one kind" $ do + let result = formatListOutputEntries False [] ["p1"] (ListFilter Nothing Nothing [KindBlueprint]) + T.isInfixOf "No blueprints found." result `shouldBe` True + + it "names prompts in the empty message when filtered to prompts" $ do + let result = formatListOutputEntries False [] ["p1"] (ListFilter Nothing Nothing [KindPrompt]) + T.isInfixOf "No prompts found." result `shouldBe` True + + it "uses the neutral noun in the empty message with no kind filter" $ do + let result = formatListOutputEntries False [] ["p1"] noFilterF + T.isInfixOf "No items found." result `shouldBe` True + + describe "runnableToEntryWithOrigin (blueprint)" $ do + it "tags blueprint entries with [blueprint] in the source label" $ do + let dr = + DiscoveredRunnable + { drName = "demo", + drDescription = Just "A new seihou blueprint", + drKind = KindBlueprint, + drSource = SourceProject, + drDir = "/fake/demo", + drIsError = False, + drError = Nothing + } + entry = runnableToEntryWithOrigin Map.empty dr + entry.entrySource `shouldBe` "project [blueprint]" + entry.entryName `shouldBe` "demo" + entry.entryIsError `shouldBe` False + entry.entryKind `shouldBe` KindBlueprint + + describe "runnableToEntryWithOrigin (prompt)" $ do + it "tags prompt entries with [prompt] in the source label" $ do + let dr = + DiscoveredRunnable + { drName = "review", + drDescription = Just "Review current changes", + drKind = KindPrompt, + drSource = SourceProject, + drDir = "/fake/review", + drIsError = False, + drError = Nothing + } + entry = runnableToEntryWithOrigin Map.empty dr + entry.entrySource `shouldBe` "project [prompt]" + entry.entryName `shouldBe` "review" + entry.entryIsError `shouldBe` False + entry.entryKind `shouldBe` KindPrompt diff --git a/test/Seihou/CLI/MigrateSpec.hs b/test/Seihou/CLI/MigrateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/MigrateSpec.hs @@ -0,0 +1,768 @@ +module Seihou.CLI.MigrateSpec (tests) where + +import Control.Exception (bracket_) +import Data.Aeson (encode, object, (.=)) +import Data.ByteString.Lazy qualified as LBS +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 Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Effectful (runEff) +import Seihou.CLI.Migrate + ( MigrateError (..), + MigrateOpts (..), + MigrateResult (..), + commitMigratedFiles, + runMigrate, + ) +import Seihou.Core.Migration (MigrationPlan (..)) +import Seihou.Core.Types + ( AppliedModule (..), + FileRecord (..), + Manifest (..), + ModuleName (..), + Strategy (..), + emptyParentVars, + ) +import Seihou.Core.Version (renderVersion) +import Seihou.Effect.FilesystemInterp (runFilesystem) +import Seihou.Effect.ManifestStore (writeManifest) +import Seihou.Effect.ManifestStoreInterp (runManifestStore) +import Seihou.Engine.Migrate (ExecutedMigrationPlan (..)) +import Seihou.Manifest.Hash (hashContent) +import Seihou.Manifest.Types (emptyManifest) +import System.Directory (createDirectoryIfMissing, doesFileExist, withCurrentDirectory) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Migrate" spec + +-- ---------------------------------------------------------------------------- +-- Fixture helpers +-- ---------------------------------------------------------------------------- + +modName :: ModuleName +modName = ModuleName "demo" + +fixedTime :: UTCTime +fixedTime = + parseTimeOrError + True + defaultTimeLocale + "%Y-%m-%dT%H:%M:%SZ" + "2026-04-01T10:00:00Z" + +writeInstalledModule :: FilePath -> Text -> Text -> IO () +writeInstalledModule dir version migrationsLit = do + createDirectoryIfMissing True dir + TIO.writeFile (dir "module.dhall") body + where + body = + T.unlines + [ "{ name = \"demo\"", + ", version = Some \"" <> version <> "\"", + ", 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, + "}" + ] + +moveOldToNewLit :: Text +moveOldToNewLit = + T.unlines + [ "[ { from = \"1.0.0\"", + " , to = \"2.0.0\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"old.txt\", dest = \"new.txt\" }", + " ]", + " }", + "]" + ] + +moveAppToSrcLit :: Text +moveAppToSrcLit = + T.unlines + [ "[ { from = \"1.0.0\"", + " , to = \"2.0.0\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"app/Main.hs\", dest = \"src/Main.hs\" }", + " ]", + " }", + "]" + ] + +emptyMigrationsLit :: Text +emptyMigrationsLit = + "[] : 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 } > }" + +mkManifest :: Text -> FilePath -> [(FilePath, Text)] -> Manifest +mkManifest version installedDir entries = + (emptyManifest fixedTime) + { modules = + [ AppliedModule + { name = modName, + parentVars = emptyParentVars, + source = installedDir, + moduleVersion = Just version, + appliedAt = fixedTime, + removal = Nothing + } + ], + files = + Map.fromList + [ ( path, + FileRecord + { hash = hashContent content, + moduleName = modName, + strategy = Template, + generatedAt = fixedTime + } + ) + | (path, content) <- entries + ] + } + +defaultOpts :: MigrateOpts +defaultOpts = + MigrateOpts + { migrateModule = modName, + migrateTo = Nothing, + migrateDryRun = False, + migrateForce = False, + migrateJson = False, + migrateVerbose = False, + migrateNoFetch = True, + migrateCommit = False, + migrateCommitMessage = Nothing + } + +-- ---------------------------------------------------------------------------- +-- Fetch-path fixture +-- ---------------------------------------------------------------------------- + +data FetchFixture = FetchFixture + { modName :: Text, + remoteDir :: FilePath, + installedDir :: FilePath, + projectDir :: FilePath + } + +withFetchFixture :: Text -> Text -> Text -> (FetchFixture -> IO ()) -> IO () +withFetchFixture installedVer remoteVer migrationsLit action = + withSystemTempDirectory "seihou-migrate-fetch" $ \tmp -> do + let xdgHome = tmp "xdg" + remoteDir = tmp "remote" + projectDir = tmp "project" + nameStr = "demo" + installedDir = xdgHome "seihou" "installed" nameStr + fix = + FetchFixture + { modName = T.pack nameStr, + remoteDir = remoteDir, + installedDir = installedDir, + projectDir = projectDir + } + + createDirectoryIfMissing True remoteDir + createDirectoryIfMissing True projectDir + createDirectoryIfMissing True installedDir + + writeInstalledModule remoteDir remoteVer migrationsLit + initRemoteRepo remoteDir + + writeInstalledModule installedDir installedVer emptyMigrationsLit + writeOriginJson installedDir (T.pack remoteDir) + + withSavedEnv "XDG_CONFIG_HOME" (Just xdgHome) $ + withSavedEnv "GIT_ALLOW_PROTOCOL" (Just "file") $ + action fix + +initRemoteRepo :: FilePath -> IO () +initRemoteRepo dir = do + run "git" ["init", "--quiet", "--initial-branch=main", dir] + run "git" ["-C", dir, "config", "user.email", "test@example.com"] + run "git" ["-C", dir, "config", "user.name", "Test"] + run "git" ["-C", dir, "config", "commit.gpgsign", "false"] + run "git" ["-C", dir, "add", "."] + run "git" ["-C", dir, "commit", "--quiet", "--no-verify", "-m", "fixture"] + where + run cmd args = do + (code, _out, err) <- readProcessWithExitCode cmd args "" + case code of + ExitSuccess -> pure () + ExitFailure n -> + expectationFailure + ( cmd + <> " " + <> show args + <> " exited with " + <> show n + <> ":\n" + <> err + ) + +initProjectRepo :: FilePath -> IO () +initProjectRepo dir = do + run "git" ["init", "--quiet", "--initial-branch=main", dir] + run "git" ["-C", dir, "config", "user.email", "test@example.com"] + run "git" ["-C", dir, "config", "user.name", "Test"] + run "git" ["-C", dir, "config", "commit.gpgsign", "false"] + run "git" ["-C", dir, "add", "."] + run "git" ["-C", dir, "commit", "--quiet", "--no-verify", "-m", "baseline"] + where + run cmd args = do + (code, _out, err) <- readProcessWithExitCode cmd args "" + case code of + ExitSuccess -> pure () + ExitFailure n -> + expectationFailure + ( cmd + <> " " + <> show args + <> " exited with " + <> show n + <> ":\n" + <> err + ) + +writeOriginJson :: FilePath -> Text -> IO () +writeOriginJson installedDir sourceUrl = do + let payload = + object + [ "sourceUrl" .= sourceUrl, + "repoName" .= (Nothing :: Maybe Text), + "version" .= (Nothing :: Maybe Text) + ] + LBS.writeFile (installedDir ".seihou-origin.json") (encode payload) + +mkManifestAt :: FetchFixture -> Text -> [(FilePath, Text)] -> Manifest +mkManifestAt fix version entries = + (emptyManifest fixedTime) + { modules = + [ AppliedModule + { name = ModuleName fix.modName, + parentVars = emptyParentVars, + source = fix.installedDir, + moduleVersion = Just version, + appliedAt = fixedTime, + removal = Nothing + } + ], + files = + Map.fromList + [ ( path, + FileRecord + { hash = hashContent content, + moduleName = ModuleName fix.modName, + strategy = Template, + generatedAt = fixedTime + } + ) + | (path, content) <- entries + ] + } + +withSavedEnv :: String -> Maybe String -> IO () -> IO () +withSavedEnv key newVal action = do + prev <- lookupEnv key + let setNew = case newVal of + Just v -> setEnv key v + Nothing -> unsetEnv key + restore = case prev of + Just v -> setEnv key v + Nothing -> unsetEnv key + bracket_ setNew restore action + +-- ---------------------------------------------------------------------------- +-- Spec +-- ---------------------------------------------------------------------------- + +spec :: Spec +spec = do + describe "runMigrate" $ do + it "errors when the module isn't applied" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" emptyMigrationsLit + let manifest = (emptyManifest fixedTime) {modules = []} + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Left (MigrateModuleNotApplied n) -> n `shouldBe` modName + other -> expectationFailure ("expected MigrateModuleNotApplied, got: " <> show other) + + it "errors when the manifest has no recorded version for the module" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" emptyMigrationsLit + let manifest = + (emptyManifest fixedTime) + { modules = + [ AppliedModule + { name = modName, + parentVars = emptyParentVars, + source = installed, + moduleVersion = Nothing, + appliedAt = fixedTime, + removal = Nothing + } + ] + } + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Left (MigrateNoRecordedVersion n) -> n `shouldBe` modName + other -> expectationFailure ("expected MigrateNoRecordedVersion, got: " <> show other) + + it "returns MigrateNoOp when manifest version equals installed version" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "1.0.0" emptyMigrationsLit + let manifest = mkManifest "1.0.0" installed [] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Right (MigrateNoOp _) -> pure () + other -> expectationFailure ("expected MigrateNoOp, got: " <> show other) + + it "returns a dry-run plan without touching disk" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "module Main where" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] + opts = defaultOpts {migrateDryRun = True} + result <- + withCurrentDirectory dir $ + runMigrate opts manifest installed + case result of + Right (MigrateDryRunOK _plan _from _to) -> do + doesFileExist (dir "app" "Main.hs") `shouldReturn` True + doesFileExist (dir "src" "Main.hs") `shouldReturn` False + other -> expectationFailure ("expected MigrateDryRunOK, got: " <> show other) + + it "executes the plan and returns the rewritten manifest" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "module Main where" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Right (MigrateApplied _plan manifest' fromV toV) -> do + renderVersion fromV `shouldBe` "1.0.0" + renderVersion toV `shouldBe` "2.0.0" + Map.member "src/Main.hs" manifest'.files `shouldBe` True + Map.member "app/Main.hs" manifest'.files `shouldBe` False + (head manifest'.modules).moduleVersion `shouldBe` Just "2.0.0" + doesFileExist (dir "src" "Main.hs") `shouldReturn` True + doesFileExist (dir "app" "Main.hs") `shouldReturn` False + other -> expectationFailure ("expected MigrateApplied, got: " <> show other) + + it "refuses to execute without --force when a tracked file has been modified" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "user-edited" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "original")] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Left (MigrateExecFailed _) -> + doesFileExist (dir "src" "Main.hs") `shouldReturn` False + other -> expectationFailure ("expected MigrateExecFailed, got: " <> show other) + + it "executes through a conflict when --force is set" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "user-edited" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "original")] + opts = defaultOpts {migrateForce = True} + result <- + withCurrentDirectory dir $ + runMigrate opts manifest installed + case result of + Right (MigrateApplied _ manifest' _ _) -> do + doesFileExist (dir "src" "Main.hs") `shouldReturn` True + doesFileExist (dir "app" "Main.hs") `shouldReturn` False + Map.member "src/Main.hs" manifest'.files `shouldBe` True + other -> expectationFailure ("expected MigrateApplied, got: " <> show other) + + -- ------------------------------------------------------------------ + -- Fetch-path tests (EP-2): clone source repo, refresh installed + -- copy, apply chain in one shot. + -- ------------------------------------------------------------------ + it "fetches a newer remote, refreshes the installed copy, and applies the chain" $ + withFetchFixture "1.0.0" "2.0.0" moveOldToNewLit $ \fix -> do + TIO.writeFile (fix.projectDir "old.txt") "x" + let manifest = mkManifestAt fix "1.0.0" [("old.txt", "x")] + opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + result <- + withCurrentDirectory fix.projectDir $ + runMigrate opts manifest fix.installedDir + case result of + Right (MigrateApplied _ manifest' _ _) -> do + doesFileExist (fix.projectDir "old.txt") `shouldReturn` False + doesFileExist (fix.projectDir "new.txt") `shouldReturn` True + case manifest'.modules of + (am : _) -> am.moduleVersion `shouldBe` Just "2.0.0" + [] -> expectationFailure "manifest has no modules" + Map.member "new.txt" manifest'.files `shouldBe` True + Map.member "old.txt" manifest'.files `shouldBe` False + installedBody <- TIO.readFile (fix.installedDir "module.dhall") + T.isInfixOf "2.0.0" installedBody `shouldBe` True + other -> + expectationFailure ("expected MigrateApplied, got: " <> show other) + + it "is a no-op when the remote and installed versions match" $ + withFetchFixture "1.0.0" "1.0.0" emptyMigrationsLit $ \fix -> do + let manifest = mkManifestAt fix "1.0.0" [] + opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + result <- + withCurrentDirectory fix.projectDir $ + runMigrate opts manifest fix.installedDir + case result of + Right (MigrateNoOp _) -> pure () + other -> expectationFailure ("expected MigrateNoOp, got: " <> show other) + + it "ignores a newer remote when --no-fetch is set" $ + withFetchFixture "1.0.0" "2.0.0" moveOldToNewLit $ \fix -> do + let manifest = mkManifestAt fix "1.0.0" [] + opts = (defaultOpts {migrateNoFetch = True}) {migrateModule = ModuleName fix.modName} + result <- + withCurrentDirectory fix.projectDir $ + runMigrate opts manifest fix.installedDir + case result of + Right (MigrateNoOp _) -> pure () + other -> expectationFailure ("expected MigrateNoOp, got: " <> show other) + + it "respects --to to stop at an intermediate version" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + twoStepLit = + T.unlines + [ "[ { from = \"1.0.0\"", + " , to = \"1.5.0\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"a.txt\", dest = \"b.txt\" }", + " ]", + " }", + ", { from = \"1.5.0\"", + " , to = \"2.0.0\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"b.txt\", dest = \"c.txt\" }", + " ]", + " }", + "]" + ] + writeInstalledModule installed "2.0.0" twoStepLit + TIO.writeFile (dir "a.txt") "x" + let manifest = mkManifest "1.0.0" installed [("a.txt", "x")] + opts = defaultOpts {migrateTo = Just "1.5.0"} + result <- + withCurrentDirectory dir $ + runMigrate opts manifest installed + case result of + Right (MigrateApplied _ manifest' _ toV) -> do + renderVersion toV `shouldBe` "1.5.0" + Map.member "b.txt" manifest'.files `shouldBe` True + Map.member "c.txt" manifest'.files `shouldBe` False + (head manifest'.modules).moduleVersion `shouldBe` Just "1.5.0" + doesFileExist (dir "b.txt") `shouldReturn` True + doesFileExist (dir "c.txt") `shouldReturn` False + other -> expectationFailure ("expected MigrateApplied, got: " <> show other) + + -- ------------------------------------------------------------------ + -- EP-35: gap-tolerant scenarios. + -- + -- The window walker applies any in-window declared migrations and + -- always advances the manifest to the supplied target. There are + -- no "blocked" / "benign" / "bump-through" outcomes — every + -- non-trivial run yields MigrateApplied. + -- ------------------------------------------------------------------ + + it "Scenario A: applies a partial-cover plan and lands the manifest at the target" $ + -- User's reported scenario shape: manifest at 1.0.0, installed + -- declares 3.0.0 with one edge {1.0.0 -> 2.0.0}. The walker picks + -- the edge, the engine runs its ops, and the manifest advances + -- to 3.0.0 (the supplied target) in one command. + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "3.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "module Main where" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Right (MigrateApplied _ manifest' fromV toV) -> do + renderVersion fromV `shouldBe` "1.0.0" + renderVersion toV `shouldBe` "3.0.0" + (head manifest'.modules).moduleVersion `shouldBe` Just "3.0.0" + Map.member "src/Main.hs" manifest'.files `shouldBe` True + Map.member "app/Main.hs" manifest'.files `shouldBe` False + doesFileExist (dir "src" "Main.hs") `shouldReturn` True + doesFileExist (dir "app" "Main.hs") `shouldReturn` False + other -> + expectationFailure ("expected MigrateApplied, got: " <> show other) + + it "Scenario B: pure version bump (migrations = []) lands the manifest at the target" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "0.3.0" emptyMigrationsLit + let manifest = mkManifest "0.1.3" installed [] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Right (MigrateApplied execPlan manifest' _ toV) -> do + renderVersion toV `shouldBe` "0.3.0" + null execPlan.planSource.planSteps `shouldBe` True + (head manifest'.modules).moduleVersion `shouldBe` Just "0.3.0" + other -> expectationFailure ("expected MigrateApplied (pure bump), got: " <> show other) + + it "Scenario C: orphan-edge entirely outside the window also lands the manifest at target" $ + -- Same outcome as Scenario B from the user's perspective — the + -- manifest advances, no ops run. The walker silently skips the + -- out-of-window edge. + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + orphanEdgeLit = + T.unlines + [ "[ { from = \"0.5.0\"", + " , to = \"0.6.0\"", + " , ops = [] : List < MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >", + " }", + "]" + ] + writeInstalledModule installed "0.3.0" orphanEdgeLit + let manifest = mkManifest "0.1.3" installed [] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Right (MigrateApplied execPlan manifest' _ toV) -> do + renderVersion toV `shouldBe` "0.3.0" + null execPlan.planSource.planSteps `shouldBe` True + (head manifest'.modules).moduleVersion `shouldBe` Just "0.3.0" + other -> expectationFailure ("expected MigrateApplied (orphan-edge skip), got: " <> show other) + + it "User's two-component fixture: 0.2 -> 0.6 with [{0.2->0.3}, {0.5->0.6}]" $ + -- The literal example from the user's prompt: two declared + -- migrations, two-component versions, manifest skips the gap and + -- runs both edges in order. + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + twoEdgesLit = + T.unlines + [ "[ { from = \"0.2\"", + " , to = \"0.3\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"v2.txt\", dest = \"v3.txt\" }", + " ]", + " }", + ", { from = \"0.5\"", + " , to = \"0.6\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"v5.txt\", dest = \"v6.txt\" }", + " ]", + " }", + "]" + ] + writeInstalledModule installed "0.6" twoEdgesLit + TIO.writeFile (dir "v2.txt") "at-v2" + TIO.writeFile (dir "v5.txt") "at-v5" + let manifest = mkManifest "0.2" installed [("v2.txt", "at-v2"), ("v5.txt", "at-v5")] + result <- + withCurrentDirectory dir $ + runMigrate defaultOpts manifest installed + case result of + Right (MigrateApplied execPlan manifest' _ toV) -> do + renderVersion toV `shouldBe` "0.6" + length execPlan.planSource.planSteps `shouldBe` 2 + (head manifest'.modules).moduleVersion `shouldBe` Just "0.6" + doesFileExist (dir "v3.txt") `shouldReturn` True + doesFileExist (dir "v6.txt") `shouldReturn` True + doesFileExist (dir "v2.txt") `shouldReturn` False + doesFileExist (dir "v5.txt") `shouldReturn` False + other -> expectationFailure ("expected MigrateApplied (two-edge), got: " <> show other) + + -- ------------------------------------------------------------------ + -- EP-26: --commit / --commit-message auto-commit flags. + -- ------------------------------------------------------------------ + + it "--commit-message stages moved files plus the manifest into a single git commit" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + manifestPath = ".seihou" "manifest.json" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "module Main where" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] + opts = + defaultOpts + { migrateCommit = True, + migrateCommitMessage = Just "chore: migrate" + } + withCurrentDirectory dir $ do + createDirectoryIfMissing True (dir ".seihou") + runEff $ + runFilesystem $ + runManifestStore manifestPath $ + writeManifest manifest + initProjectRepo dir + result <- runMigrate opts manifest installed + case result of + Right (MigrateApplied plan manifest' _ _) -> do + runEff $ + runFilesystem $ + runManifestStore manifestPath $ + writeManifest manifest' + commitMigratedFiles opts manifestPath plan + (subjectExit, subject, _) <- + readProcessWithExitCode "git" ["log", "-1", "--pretty=%s"] "" + subjectExit `shouldBe` ExitSuccess + T.strip (T.pack subject) `shouldBe` "chore: migrate" + (_, names, _) <- + readProcessWithExitCode + "git" + ["log", "-1", "--name-only", "--no-renames", "--pretty="] + "" + let touched = filter (not . T.null) (T.lines (T.pack names)) + touched `shouldContain` ["app/Main.hs"] + touched `shouldContain` ["src/Main.hs"] + touched `shouldContain` [".seihou/manifest.json"] + other -> + expectationFailure ("expected MigrateApplied, got: " <> show other) + + it "--commit outside a git repo is a silent no-op (apply still succeeds)" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + manifestPath = ".seihou" "manifest.json" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "module Main where" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] + opts = defaultOpts {migrateCommitMessage = Just "chore: migrate"} + withCurrentDirectory dir $ do + createDirectoryIfMissing True (dir ".seihou") + result <- runMigrate opts manifest installed + case result of + Right (MigrateApplied plan manifest' _ _) -> do + runEff $ + runFilesystem $ + runManifestStore manifestPath $ + writeManifest manifest' + commitMigratedFiles opts manifestPath plan + doesFileExist (dir "src" "Main.hs") `shouldReturn` True + doesFileExist (dir manifestPath) `shouldReturn` True + other -> + expectationFailure ("expected MigrateApplied, got: " <> show other) + + it "--commit on a dry-run path returns a dry-run variant (helper is never invoked)" $ + withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do + let installed = dir "installed-demo" + writeInstalledModule installed "2.0.0" moveAppToSrcLit + createDirectoryIfMissing True (dir "app") + TIO.writeFile (dir "app" "Main.hs") "module Main where" + let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")] + opts = + defaultOpts + { migrateDryRun = True, + migrateCommit = True, + migrateCommitMessage = Just "chore: migrate" + } + withCurrentDirectory dir $ do + initProjectRepo dir + result <- runMigrate opts manifest installed + case result of + Right (MigrateDryRunOK {}) -> pure () + other -> + expectationFailure ("expected MigrateDryRunOK, got: " <> show other) + (_, before, _) <- readProcessWithExitCode "git" ["rev-list", "--count", "HEAD"] "" + T.strip (T.pack before) `shouldBe` "1" + + -- ------------------------------------------------------------------ + -- EP-27 / EP-35 M5: fetch-vs-local divergence fallback. + -- + -- When the cloned remote ships fewer applicable migrations than + -- the locally installed copy, the planner prefers the local plan. + -- This guards against a remote that has dropped a migration the + -- user's installed copy still declares. + -- ------------------------------------------------------------------ + + it "fetch fallback: local declares partial chain, clone has empty list -> local wins" $ + let partialLit = + T.unlines + [ "[ { from = \"0.1\"", + " , to = \"0.2\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"old.txt\", dest = \"new.txt\" }", + " ]", + " }", + "]" + ] + in withFetchFixture "0.3" "0.3" emptyMigrationsLit $ \fix -> do + writeInstalledModule fix.installedDir "0.3" partialLit + writeOriginJson fix.installedDir (T.pack fix.remoteDir) + TIO.writeFile (fix.projectDir "old.txt") "tracked\n" + let manifest = mkManifestAt fix "0.1" [("old.txt", "tracked\n")] + opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + result <- + withCurrentDirectory fix.projectDir $ + runMigrate opts manifest fix.installedDir + case result of + Right (MigrateApplied execPlan manifest' _ toV) -> do + renderVersion toV `shouldBe` "0.3" + length execPlan.planSource.planSteps `shouldBe` 1 + case manifest'.modules of + (am : _) -> am.moduleVersion `shouldBe` Just "0.3" + [] -> expectationFailure "manifest has no modules" + doesFileExist (fix.projectDir "new.txt") `shouldReturn` True + doesFileExist (fix.projectDir "old.txt") `shouldReturn` False + other -> + expectationFailure + ("expected MigrateApplied (local fallback), got: " <> show other) + + it "fetch fallback: clone-based plan stands when neither side declares applicable edges" $ + withFetchFixture "0.3" "0.3" emptyMigrationsLit $ \fix -> do + let manifest = mkManifestAt fix "0.1" [] + opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName} + result <- + withCurrentDirectory fix.projectDir $ + runMigrate opts manifest fix.installedDir + case result of + Right (MigrateApplied execPlan manifest' _ toV) -> do + renderVersion toV `shouldBe` "0.3" + null execPlan.planSource.planSteps `shouldBe` True + case manifest'.modules of + (am : _) -> am.moduleVersion `shouldBe` Just "0.3" + [] -> expectationFailure "manifest has no modules" + other -> + expectationFailure ("expected MigrateApplied (no-op-style bump), got: " <> show other) diff --git a/test/Seihou/CLI/PendingMigrationSpec.hs b/test/Seihou/CLI/PendingMigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/PendingMigrationSpec.hs @@ -0,0 +1,311 @@ +module Seihou.CLI.PendingMigrationSpec (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.Text.IO qualified as TIO +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Seihou.CLI.Migrate (pendingChainFor) +import Seihou.CLI.PendingMigrations + ( detectPendingMigrations, + formatRefusalMessage, + ) +import Seihou.Core.Migration + ( Migration (..), + MigrationOp (..), + MigrationPlan (..), + ) +import Seihou.Core.Types + ( AppliedModule (..), + Manifest (..), + Module (..), + ModuleName (..), + emptyParentVars, + ) +import Seihou.Core.Version qualified +import Seihou.Manifest.Types (emptyManifest) +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.CLI.PendingMigration" spec + +fixedTime :: UTCTime +fixedTime = + parseTimeOrError + True + defaultTimeLocale + "%Y-%m-%dT%H:%M:%SZ" + "2026-04-01T10:00:00Z" + +mkApplied :: Maybe Text -> AppliedModule +mkApplied mver = + AppliedModule + { name = ModuleName "demo", + parentVars = emptyParentVars, + source = "/installed/demo", + moduleVersion = mver, + appliedAt = fixedTime, + removal = Nothing + } + +mkInstalled :: Maybe Text -> [Migration] -> Module +mkInstalled v migs = + Module + { name = ModuleName "demo", + version = v, + description = Nothing, + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = migs + } + +writeInstalledModule :: FilePath -> Text -> Text -> Text -> IO () +writeInstalledModule dir name version migrationsLit = do + createDirectoryIfMissing True dir + TIO.writeFile (dir "module.dhall") body + where + body = + T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> version <> "\"", + ", 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, + "}" + ] + +moveOldToNewLit :: Text +moveOldToNewLit = + T.unlines + [ "[ { from = \"1.0.0\"", + " , to = \"2.0.0\"", + " , ops =", + " [ (< MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } >).MoveFile { src = \"old.txt\", dest = \"new.txt\" }", + " ]", + " }", + "]" + ] + +emptyMigrationsLit :: Text +emptyMigrationsLit = + "[] : 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 } > }" + +mkAppliedAt :: Text -> FilePath -> Maybe Text -> AppliedModule +mkAppliedAt name source mver = + AppliedModule + { name = ModuleName name, + parentVars = emptyParentVars, + source = source, + moduleVersion = mver, + appliedAt = fixedTime, + removal = Nothing + } + +spec :: Spec +spec = do + describe "pendingChainFor" $ do + it "returns Nothing when manifest has no recorded version" $ do + let am = mkApplied Nothing + installed = mkInstalled (Just "2.0.0") [Migration "1.0.0" "2.0.0" []] + pendingChainFor am installed `shouldBe` Nothing + + it "returns Nothing when installed has no version" $ do + let am = mkApplied (Just "1.0.0") + installed = mkInstalled Nothing [] + pendingChainFor am installed `shouldBe` Nothing + + it "returns Nothing when versions match (no chain)" $ do + let am = mkApplied (Just "1.0.0") + installed = mkInstalled (Just "1.0.0") [] + pendingChainFor am installed `shouldBe` Nothing + + it "returns Just plan with full chain when manifest is behind installed" $ do + let mig = Migration "1.0.0" "2.0.0" [DeleteFile "Setup.hs"] + am = mkApplied (Just "1.0.0") + installed = mkInstalled (Just "2.0.0") [mig] + case pendingChainFor am installed of + Just plan -> do + plan.planSteps `shouldBe` [mig] + plan.planTo `shouldBe` parseV "2.0.0" + Nothing -> expectationFailure "expected Just plan" + + it "returns Nothing for downgrade (manifest > installed)" $ do + let am = mkApplied (Just "2.0.0") + installed = mkInstalled (Just "1.0.0") [] + pendingChainFor am installed `shouldBe` Nothing + + it "returns a partial-cover plan when the chain reaches some intermediate version" $ do + -- master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0, + -- edges=[0.1.0 -> 0.2.0]. Under the gap-tolerant walker the plan + -- always carries the supplied target as planTo, regardless of + -- whether the steps reach it. + let am = mkApplied (Just "0.1.0") + mig = Migration "0.1.0" "0.2.0" [DeleteFile "x"] + installed = mkInstalled (Just "0.3.0") [mig] + case pendingChainFor am installed of + Just plan -> do + plan.planSteps `shouldBe` [mig] + plan.planFrom `shouldBe` parseV "0.1.0" + plan.planTo `shouldBe` parseV "0.3.0" + Nothing -> expectationFailure "expected Just plan with partial cover" + + it "returns an empty-steps plan when no edge starts at the manifest version" $ do + let am = mkApplied (Just "0.1.3") + installed = mkInstalled (Just "0.3.0") [] + case pendingChainFor am installed of + Just plan -> do + plan.planSteps `shouldBe` [] + plan.planFrom `shouldBe` parseV "0.1.3" + plan.planTo `shouldBe` parseV "0.3.0" + Nothing -> expectationFailure "expected Just plan with empty steps" + + it "[] vs [orphanEdge] both yield empty-steps plans (window walker)" $ do + -- Under the gap-tolerant walker an orphan edge entirely outside + -- the [installed, target] window contributes nothing — same plan + -- shape as no migrations declared at all. + let am = mkApplied (Just "0.2.0") + emptyInstalled = mkInstalled (Just "0.3.0") [] + orphanInstalled = + mkInstalled (Just "0.3.0") [Migration "0.5.0" "0.6.0" []] + case (pendingChainFor am emptyInstalled, pendingChainFor am orphanInstalled) of + (Just pEmpty, Just pOrphan) -> do + pEmpty.planSteps `shouldBe` [] + pOrphan.planSteps `shouldBe` [] + pEmpty.planFrom `shouldBe` pOrphan.planFrom + pEmpty.planTo `shouldBe` pOrphan.planTo + other -> + expectationFailure + ("expected two Just plans, got: " <> show other) + + describe "detectPendingMigrations" $ do + it "with Nothing filter, surfaces every applied module's pending plan" $ + withSystemTempDirectory "seihou-pending-detect" $ \dir -> do + let aDir = dir "demo-a" + bDir = dir "demo-b" + writeInstalledModule aDir "demo-a" "2.0.0" moveOldToNewLit + writeInstalledModule bDir "demo-b" "2.0.0" moveOldToNewLit + let manifest = + (emptyManifest fixedTime) + { modules = + [ mkAppliedAt "demo-a" aDir (Just "1.0.0"), + mkAppliedAt "demo-b" bDir (Just "1.0.0") + ], + files = Map.empty + } + result <- detectPendingMigrations manifest Nothing + map fst result `shouldMatchList` [ModuleName "demo-a", ModuleName "demo-b"] + + it "with a Just filter, restricts detection to the named modules" $ + withSystemTempDirectory "seihou-pending-detect" $ \dir -> do + let aDir = dir "demo-a" + bDir = dir "demo-b" + writeInstalledModule aDir "demo-a" "2.0.0" moveOldToNewLit + writeInstalledModule bDir "demo-b" "2.0.0" moveOldToNewLit + let manifest = + (emptyManifest fixedTime) + { modules = + [ mkAppliedAt "demo-a" aDir (Just "1.0.0"), + mkAppliedAt "demo-b" bDir (Just "1.0.0") + ], + files = Map.empty + } + result <- + detectPendingMigrations + manifest + (Just (Set.singleton (ModuleName "demo-a"))) + map fst result `shouldBe` [ModuleName "demo-a"] + + it "skips modules whose installed copy has no module.dhall" $ + withSystemTempDirectory "seihou-pending-detect" $ \dir -> do + let bogus = dir "missing-installed" + let manifest = + (emptyManifest fixedTime) + { modules = [mkAppliedAt "demo" bogus (Just "1.0.0")], + files = Map.empty + } + result <- detectPendingMigrations manifest Nothing + result `shouldBe` [] + + it "skips modules with no pending chain (manifest already at installed version)" $ + withSystemTempDirectory "seihou-pending-detect" $ \dir -> do + let modDir = dir "demo" + writeInstalledModule modDir "demo" "1.0.0" emptyMigrationsLit + let manifest = + (emptyManifest fixedTime) + { modules = [mkAppliedAt "demo" modDir (Just "1.0.0")], + files = Map.empty + } + result <- detectPendingMigrations manifest Nothing + result `shouldBe` [] + + it "with a filter selecting only no-chain modules, returns empty" $ + withSystemTempDirectory "seihou-pending-detect" $ \dir -> do + let withChain = dir "with-chain" + noChain = dir "no-chain" + writeInstalledModule withChain "with-chain" "2.0.0" moveOldToNewLit + writeInstalledModule noChain "no-chain" "1.0.0" emptyMigrationsLit + let manifest = + (emptyManifest fixedTime) + { modules = + [ mkAppliedAt "with-chain" withChain (Just "1.0.0"), + mkAppliedAt "no-chain" noChain (Just "1.0.0") + ], + files = Map.empty + } + result <- + detectPendingMigrations + manifest + (Just (Set.singleton (ModuleName "no-chain"))) + result `shouldBe` [] + + describe "formatRefusalMessage" $ do + it "lists each module's plan summary and the actionable next step" $ do + let plan = + MigrationPlan + { planModule = "demo", + planFrom = parseV "1.0.0", + planTo = parseV "2.0.0", + planSteps = + [Migration "1.0.0" "2.0.0" [DeleteFile "Setup.hs"]] + } + msg = formatRefusalMessage [(ModuleName "demo", plan)] + msg `shouldSatisfy` T.isInfixOf "Pending migrations detected:" + msg `shouldSatisfy` T.isInfixOf "demo: 1.0.0 -> 2.0.0 (1 step(s))" + msg `shouldSatisfy` T.isInfixOf "--with-migrations" + msg `shouldSatisfy` T.isInfixOf "seihou migrate " + + it "reports a 0-step pure version-bump entry without doomed vocabulary" $ do + let plan = + MigrationPlan + { planModule = "demo", + planFrom = parseV "0.2.0", + planTo = parseV "0.3.0", + planSteps = [] + } + msg = formatRefusalMessage [(ModuleName "demo", plan)] + msg `shouldSatisfy` T.isInfixOf "demo: 0.2.0 -> 0.3.0 (0 step(s))" + msg `shouldNotSatisfy` T.isInfixOf "Blocked" + msg `shouldNotSatisfy` T.isInfixOf "--bump-only" + msg `shouldNotSatisfy` T.isInfixOf "--bump-blocked" + +parseV :: Text -> Seihou.Core.Version.Version +parseV t = case Seihou.Core.Version.parseVersion t of + Just v -> v + Nothing -> error ("test fixture: unparseable version " <> T.unpack t) diff --git a/test/Seihou/CLI/PromptRenderSpec.hs b/test/Seihou/CLI/PromptRenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/PromptRenderSpec.hs @@ -0,0 +1,86 @@ +module Seihou.CLI.PromptRenderSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Seihou.CLI.AgentLaunch (AgentContext (..)) +import Seihou.CLI.PromptRender (formatPromptGuidance, renderPromptBody, renderPromptSystemPrompt) +import Seihou.Core.Types +import Test.Hspec +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.PromptRender" $ do + describe "formatPromptGuidance" $ do + it "includes guidance whose condition is true and omits false guidance" $ do + let rendered = formatPromptGuidance resolvedVars sampleGuidance + rendered `shouldSatisfy` T.isInfixOf "### Haskell repository" + rendered `shouldSatisfy` T.isInfixOf "Use cabal build all." + rendered `shouldNotSatisfy` T.isInfixOf "Use npm test." + + it "renders a stable empty message when no guidance is selected" $ + formatPromptGuidance resolvedVars [PromptGuidance "Node" "Use npm test." (Just (ExprEq "repo.kind" (VText "node")))] + `shouldBe` "(no prompt guidance)" + + describe "renderPromptSystemPrompt" $ do + it "renders context, prompt identity, selected guidance, and the prompt body" $ do + let body = renderPromptBody resolvedVars "Review {{project.name}}." + rendered = renderPromptSystemPrompt sampleContext samplePrompt resolvedVars body (Just "Focus on tests.") + rendered `shouldSatisfy` T.isInfixOf "## Current Environment" + rendered `shouldSatisfy` T.isInfixOf "## Prompt Identity" + rendered `shouldSatisfy` T.isInfixOf "## Reference Files" + rendered `shouldSatisfy` T.isInfixOf "## Prompt Guidance" + rendered `shouldSatisfy` T.isInfixOf "Use cabal build all." + rendered `shouldNotSatisfy` T.isInfixOf "Use npm test." + rendered `shouldSatisfy` T.isInfixOf "Review seihou." + rendered `shouldSatisfy` T.isInfixOf "Focus on tests." + +sampleContext :: AgentContext +sampleContext = + AgentContext + { cwd = "/tmp/project", + seihouInitialized = True, + hasManifest = False, + localModuleDhall = False, + localModules = [], + availableModules = [] + } + +samplePrompt :: AgentPrompt +samplePrompt = + AgentPrompt + { name = "review-guided", + version = Just "0.1.0", + description = Just "Review with guidance", + prompt = "Review {{project.name}}.", + vars = [projectNameDecl], + prompts = [], + commandVars = [repoKindCommand], + guidance = sampleGuidance, + files = [BlueprintFile {src = "style.md", description = Just "Style notes"}], + allowedTools = Nothing, + tags = ["review"], + launch = Nothing + } + +sampleGuidance :: [PromptGuidance] +sampleGuidance = + [ PromptGuidance "Haskell repository" "Use cabal build all." (Just (ExprEq "repo.kind" (VText "haskell"))), + PromptGuidance "Node repository" "Use npm test." (Just (ExprEq "repo.kind" (VText "node"))) + ] + +resolvedVars :: Map.Map VarName ResolvedVar +resolvedVars = + Map.fromList + [ ("project.name", ResolvedVar (VText "seihou") FromDefault projectNameDecl), + ("repo.kind", ResolvedVar (VText "haskell") (FromCommand "detect repo") repoKindDecl) + ] + +projectNameDecl :: VarDecl +projectNameDecl = VarDecl "project.name" VTText Nothing Nothing False Nothing + +repoKindDecl :: VarDecl +repoKindDecl = VarDecl "repo.kind" VTText Nothing Nothing False Nothing + +repoKindCommand :: CommandVar +repoKindCommand = CommandVar "repo.kind" "echo haskell" Nothing Nothing True (Just 100) diff --git a/test/Seihou/CLI/Registry/SyncSpec.hs b/test/Seihou/CLI/Registry/SyncSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/Registry/SyncSpec.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Seihou.CLI.Registry.SyncSpec (tests) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Registry.Sync + ( SyncAction (..), + SyncOutcome (..), + SyncVersionsOpts (..), + renderSyncReport, + runSync, + ) +import Seihou.Core.Registry + ( Registry (..), + RegistryEntry (..), + SyncDiff (..), + SyncReport (..), + SyncStatus (..), + ) +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.CLI.Registry.Sync" spec + +spec :: Spec +spec = do + describe "runSync" $ do + it "rewrites the registry with each module's on-disk version" $ do + withFixture $ \dir -> do + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = False, + syncVersionsCheck = False + } + case outcome of + SyncFailure msg -> + expectationFailure ("expected SyncSuccess, got failure: " <> T.unpack msg) + SyncSuccess _ action -> action `shouldBe` Wrote + reloaded <- evalRegistryFromFile (dir "seihou-registry.dhall") + case reloaded of + Left err -> expectationFailure ("failed to reload: " <> show err) + Right reg -> do + map (.version) reg.modules `shouldBe` [Just "2.0.0", Just "2.0.0"] + + it "leaves the file untouched under --dry-run" $ do + withFixture $ \dir -> do + before <- TIO.readFile (dir "seihou-registry.dhall") + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = True, + syncVersionsCheck = False + } + case outcome of + SyncSuccess _ WouldWrite -> pure () + other -> expectationFailure ("expected WouldWrite, got " <> show other) + after <- TIO.readFile (dir "seihou-registry.dhall") + after `shouldBe` before + + it "leaves the file untouched and reports drift under --check" $ do + withFixture $ \dir -> do + before <- TIO.readFile (dir "seihou-registry.dhall") + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = False, + syncVersionsCheck = True + } + case outcome of + SyncSuccess report Checked -> do + -- first entry missing, second entry stale + map (.diffStatus) report.syncDiffs + `shouldBe` [SyncMissing, SyncStale "2.0.0"] + other -> expectationFailure ("expected Checked, got " <> show other) + after <- TIO.readFile (dir "seihou-registry.dhall") + after `shouldBe` before + + it "fails when the target directory has no seihou-registry.dhall" $ do + withSystemTempDirectory "seihou-sync-empty" $ \dir -> do + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = False, + syncVersionsCheck = False + } + case outcome of + SyncFailure _ -> pure () + SyncSuccess {} -> expectationFailure "expected SyncFailure for empty directory" + + it "rewrites a blueprint entry's on-disk version into the registry" $ do + withBlueprintFixture $ \dir -> do + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = False, + syncVersionsCheck = False + } + case outcome of + SyncFailure msg -> expectationFailure ("expected success, got: " <> T.unpack msg) + SyncSuccess _ action -> action `shouldBe` Wrote + reloaded <- evalRegistryFromFile (dir "seihou-registry.dhall") + case reloaded of + Left err -> expectationFailure ("failed to reload: " <> show err) + Right reg -> map (.version) reg.blueprints `shouldBe` [Just "0.2.0"] + + it "renderSyncReport prefixes blueprint rows with blueprints." $ do + withBlueprintFixture $ \dir -> do + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = True, + syncVersionsCheck = False + } + case outcome of + SyncSuccess report _ -> do + let rendered = renderSyncReport report + T.isInfixOf "blueprints.payments-service:" rendered `shouldBe` True + other -> expectationFailure ("expected SyncSuccess, got " <> show other) + + it "rewrites a prompt entry's on-disk version into the registry" $ do + withPromptFixture $ \dir -> do + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = False, + syncVersionsCheck = False + } + case outcome of + SyncFailure msg -> expectationFailure ("expected success, got: " <> T.unpack msg) + SyncSuccess _ action -> action `shouldBe` Wrote + reloaded <- evalRegistryFromFile (dir "seihou-registry.dhall") + case reloaded of + Left err -> expectationFailure ("failed to reload: " <> show err) + Right reg -> map (.version) reg.prompts `shouldBe` [Just "0.2.0"] + + it "renderSyncReport prefixes prompt rows with prompts." $ do + withPromptFixture $ \dir -> do + outcome <- + runSync + SyncVersionsOpts + { syncVersionsDir = Just dir, + syncVersionsDryRun = True, + syncVersionsCheck = False + } + case outcome of + SyncSuccess report _ -> do + let rendered = renderSyncReport report + T.isInfixOf "prompts.review-changes:" rendered `shouldBe` True + other -> expectationFailure ("expected SyncSuccess, got " <> show other) + +-- | Build a temp registry repo with: +-- +-- * modules/alpha/module.dhall declaring version = Some "2.0.0" +-- * modules/beta/module.dhall declaring version = Some "2.0.0" +-- * seihou-registry.dhall listing both, with the first unversioned and the +-- second stuck at an old "1.0.0" +withFixture :: (FilePath -> IO ()) -> IO () +withFixture action = withSystemTempDirectory "seihou-sync-fixture" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "alpha") + createDirectoryIfMissing True (dir "modules" "beta") + writeModuleDhall (dir "modules" "alpha" "module.dhall") "alpha" "2.0.0" + writeModuleDhall (dir "modules" "beta" "module.dhall") "beta" "2.0.0" + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "alpha" Nothing "beta" (Just "1.0.0")) + action dir + +-- | Build a temp registry repo with a single blueprint entry whose +-- on-disk @blueprint.dhall@ declares @version = "0.2.0"@ but the +-- @seihou-registry.dhall@ pins @"0.1.0"@. +withBlueprintFixture :: (FilePath -> IO ()) -> IO () +withBlueprintFixture action = withSystemTempDirectory "seihou-sync-bp" $ \dir -> do + createDirectoryIfMissing True (dir "blueprints" "payments-service") + writeBlueprintDhall (dir "blueprints" "payments-service" "blueprint.dhall") "payments-service" "0.2.0" + TIO.writeFile (dir "seihou-registry.dhall") (registryWithBlueprint "payments-service" (Just "0.1.0")) + action dir + +-- | Build a temp registry repo with a single prompt entry whose on-disk +-- @prompt.dhall@ declares @version = "0.2.0"@ but the registry pins @"0.1.0"@. +withPromptFixture :: (FilePath -> IO ()) -> IO () +withPromptFixture action = withSystemTempDirectory "seihou-sync-prompt" $ \dir -> do + createDirectoryIfMissing True (dir "prompts" "review-changes") + writePromptDhall (dir "prompts" "review-changes" "prompt.dhall") "review-changes" "0.2.0" + TIO.writeFile (dir "seihou-registry.dhall") (registryWithPrompt "review-changes" (Just "0.1.0")) + action dir + +writeBlueprintDhall :: FilePath -> Text -> Text -> IO () +writeBlueprintDhall path name ver = + TIO.writeFile + path + ( T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> ver <> "\"", + ", description = None Text", + ", prompt = \"hi\"", + ", 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", + "}" + ] + ) + +registryWithBlueprint :: Text -> Maybe Text -> Text +registryWithBlueprint n v = + T.unlines + [ "{ repoName = \"Test\"", + ", repoDescription = None Text", + ", modules = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", recipes = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", blueprints =", + " [ { name = \"" <> n <> "\"", + " , version = " <> optVersion v, + " , path = \"blueprints/" <> n <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +writePromptDhall :: FilePath -> Text -> Text -> IO () +writePromptDhall path name ver = + TIO.writeFile + path + ( T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> ver <> "\"", + ", description = None Text", + ", prompt = \"Review the current changes.\"", + ", 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 = [] : List Text", + ", launch = None { provider : Optional Text, mode : Optional Text, model : Optional Text }", + "}" + ] + ) + +registryWithPrompt :: Text -> Maybe Text -> Text +registryWithPrompt n v = + T.unlines + [ "{ repoName = \"Test\"", + ", repoDescription = None Text", + ", modules = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", recipes = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", prompts =", + " [ { name = \"" <> n <> "\"", + " , version = " <> optVersion v, + " , path = \"prompts/" <> n <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +writeModuleDhall :: FilePath -> Text -> Text -> IO () +writeModuleDhall path name ver = + TIO.writeFile + path + ( T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> ver <> "\"", + ", 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", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + ) + +registryDhall :: Text -> Maybe Text -> Text -> Maybe Text -> Text +registryDhall n1 v1 n2 v2 = + T.unlines + [ "{ repoName = \"Test\"", + ", repoDescription = None Text", + ", modules =", + " [ { name = \"" <> n1 <> "\"", + " , version = " <> optVersion v1, + " , path = \"modules/" <> n1 <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " , { name = \"" <> n2 <> "\"", + " , version = " <> optVersion v2, + " , path = \"modules/" <> n2 <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +optVersion :: Maybe Text -> Text +optVersion Nothing = "None Text" +optVersion (Just v) = "Some \"" <> v <> "\"" diff --git a/test/Seihou/CLI/Registry/ValidateSpec.hs b/test/Seihou/CLI/Registry/ValidateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/Registry/ValidateSpec.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Seihou.CLI.Registry.ValidateSpec (tests) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.Registry.Validate + ( ValidateOutcome (..), + ValidateRegistryOpts (..), + renderValidationReport, + runValidate, + ) +import Seihou.Core.Registry + ( RegistryValidationIssue (..), + RegistryValidationReport (..), + SyncDiff (..), + SyncStatus (..), + ) +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.CLI.Registry.Validate" spec + +spec :: Spec +spec = do + describe "runValidate" $ do + it "succeeds with no issues for a clean registry" $ do + withCleanFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + r.reportIssues `shouldBe` [] + r.reportModuleCount `shouldBe` 2 + r.reportRecipeCount `shouldBe` 0 + other -> expectationFailure ("expected ValidateOk, got " <> show other) + + it "flags both stale and missing version entries" $ do + withDriftedFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + let statuses = + [ d.diffStatus + | VersionMismatch d <- r.reportIssues + ] + statuses `shouldBe` [SyncMissing, SyncStale "2.0.0"] + other -> expectationFailure ("unexpected outcome: " <> show other) + + it "flags structural issues alongside version issues" $ do + withMissingFileFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + let structurals = + [ msg + | StructuralError msg <- r.reportIssues + ] + any ("missing module.dhall" `T.isInfixOf`) structurals + `shouldBe` True + other -> expectationFailure ("unexpected outcome: " <> show other) + + it "fails when there is no registry at the target directory" $ do + withSystemTempDirectory "seihou-validate-empty" $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateFailed _ -> pure () + ValidateOk _ -> + expectationFailure "expected ValidateFailed for empty directory" + + it "flags blueprint version drift with the blueprints. prefix" $ do + withDriftedBlueprintFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + let rendered = renderValidationReport r + T.isInfixOf "blueprints.payments-service:" rendered `shouldBe` True + other -> expectationFailure ("unexpected outcome: " <> show other) + + it "renders the success summary with module, recipe, and blueprint counts" $ do + withCleanBlueprintFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + let rendered = renderValidationReport r + T.isInfixOf "1 module" rendered `shouldBe` True + T.isInfixOf "0 recipes" rendered `shouldBe` True + T.isInfixOf "1 blueprint" rendered `shouldBe` True + T.isInfixOf "0 prompts" rendered `shouldBe` True + T.isInfixOf "all versions in sync" rendered `shouldBe` True + other -> expectationFailure ("unexpected outcome: " <> show other) + + it "flags prompt version drift with the prompts. prefix" $ do + withDriftedPromptFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + let rendered = renderValidationReport r + T.isInfixOf "prompts.review-changes:" rendered `shouldBe` True + other -> expectationFailure ("unexpected outcome: " <> show other) + + it "renders prompt counts in the success summary" $ do + withCleanPromptFixture $ \dir -> do + outcome <- runValidate (ValidateRegistryOpts (Just dir)) + case outcome of + ValidateOk r -> do + let rendered = renderValidationReport r + T.isInfixOf "0 modules" rendered `shouldBe` True + T.isInfixOf "0 recipes" rendered `shouldBe` True + T.isInfixOf "0 blueprints" rendered `shouldBe` True + T.isInfixOf "1 prompt" rendered `shouldBe` True + T.isInfixOf "all versions in sync" rendered `shouldBe` True + other -> expectationFailure ("unexpected outcome: " <> show other) + +-- | Two modules at version 1.0.0, registry lists both at version 1.0.0. +withCleanFixture :: (FilePath -> IO ()) -> IO () +withCleanFixture action = withSystemTempDirectory "seihou-validate-clean" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "alpha") + createDirectoryIfMissing True (dir "modules" "beta") + writeModuleDhall (dir "modules" "alpha" "module.dhall") "alpha" "1.0.0" + writeModuleDhall (dir "modules" "beta" "module.dhall") "beta" "1.0.0" + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "alpha" (Just "1.0.0") "beta" (Just "1.0.0")) + action dir + +-- | Two modules on disk at 2.0.0; registry lists alpha unversioned and +-- beta stuck at 1.0.0 — produces SyncMissing then SyncStale "2.0.0". +withDriftedFixture :: (FilePath -> IO ()) -> IO () +withDriftedFixture action = withSystemTempDirectory "seihou-validate-drift" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "alpha") + createDirectoryIfMissing True (dir "modules" "beta") + writeModuleDhall (dir "modules" "alpha" "module.dhall") "alpha" "2.0.0" + writeModuleDhall (dir "modules" "beta" "module.dhall") "beta" "2.0.0" + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "alpha" Nothing "beta" (Just "1.0.0")) + action dir + +-- | One real module + one entry whose path points at a directory with no +-- module.dhall. Produces a "missing module.dhall" structural error. +withMissingFileFixture :: (FilePath -> IO ()) -> IO () +withMissingFileFixture action = withSystemTempDirectory "seihou-validate-missing" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "alpha") + writeModuleDhall (dir "modules" "alpha" "module.dhall") "alpha" "1.0.0" + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "alpha" (Just "1.0.0") "ghost" Nothing) + action dir + +-- | One module + one drifted blueprint. Module's registry version +-- matches its on-disk version (no module drift); the blueprint's +-- registry version is "0.1.0" while its on-disk version is "0.2.0". +withDriftedBlueprintFixture :: (FilePath -> IO ()) -> IO () +withDriftedBlueprintFixture action = withSystemTempDirectory "seihou-validate-bp-drift" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "alpha") + writeModuleDhall (dir "modules" "alpha" "module.dhall") "alpha" "1.0.0" + createDirectoryIfMissing True (dir "blueprints" "payments-service") + writeBlueprintDhall (dir "blueprints" "payments-service" "blueprint.dhall") "payments-service" "0.2.0" + TIO.writeFile + (dir "seihou-registry.dhall") + (mixedRegistry "alpha" (Just "1.0.0") "payments-service" (Just "0.1.0")) + action dir + +-- | One module + one blueprint, all versions matching on disk and in +-- the registry. +withCleanBlueprintFixture :: (FilePath -> IO ()) -> IO () +withCleanBlueprintFixture action = withSystemTempDirectory "seihou-validate-bp-clean" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "alpha") + writeModuleDhall (dir "modules" "alpha" "module.dhall") "alpha" "1.0.0" + createDirectoryIfMissing True (dir "blueprints" "payments-service") + writeBlueprintDhall (dir "blueprints" "payments-service" "blueprint.dhall") "payments-service" "0.1.0" + TIO.writeFile + (dir "seihou-registry.dhall") + (mixedRegistry "alpha" (Just "1.0.0") "payments-service" (Just "0.1.0")) + action dir + +-- | One prompt whose registry version is stale relative to prompt.dhall. +withDriftedPromptFixture :: (FilePath -> IO ()) -> IO () +withDriftedPromptFixture action = withSystemTempDirectory "seihou-validate-prompt-drift" $ \dir -> do + createDirectoryIfMissing True (dir "prompts" "review-changes") + writePromptDhall (dir "prompts" "review-changes" "prompt.dhall") "review-changes" "0.2.0" + TIO.writeFile + (dir "seihou-registry.dhall") + (promptRegistry "review-changes" (Just "0.1.0")) + action dir + +-- | One prompt, all versions matching on disk and in the registry. +withCleanPromptFixture :: (FilePath -> IO ()) -> IO () +withCleanPromptFixture action = withSystemTempDirectory "seihou-validate-prompt-clean" $ \dir -> do + createDirectoryIfMissing True (dir "prompts" "review-changes") + writePromptDhall (dir "prompts" "review-changes" "prompt.dhall") "review-changes" "0.2.0" + TIO.writeFile + (dir "seihou-registry.dhall") + (promptRegistry "review-changes" (Just "0.2.0")) + action dir + +writeBlueprintDhall :: FilePath -> Text -> Text -> IO () +writeBlueprintDhall path name ver = + TIO.writeFile + path + ( T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> ver <> "\"", + ", description = None Text", + ", prompt = \"hi\"", + ", 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", + "}" + ] + ) + +mixedRegistry :: Text -> Maybe Text -> Text -> Maybe Text -> Text +mixedRegistry modName modVer bpName bpVer = + T.unlines + [ "{ repoName = \"Mixed\"", + ", repoDescription = None Text", + ", modules =", + " [ { name = \"" <> modName <> "\"", + " , version = " <> optVersion modVer, + " , path = \"modules/" <> modName <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + ", blueprints =", + " [ { name = \"" <> bpName <> "\"", + " , version = " <> optVersion bpVer, + " , path = \"blueprints/" <> bpName <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +writePromptDhall :: FilePath -> Text -> Text -> IO () +writePromptDhall path name ver = + TIO.writeFile + path + ( T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> ver <> "\"", + ", description = None Text", + ", prompt = \"Review the current changes.\"", + ", 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 = [] : List Text", + ", launch = None { provider : Optional Text, mode : Optional Text, model : Optional Text }", + "}" + ] + ) + +promptRegistry :: Text -> Maybe Text -> Text +promptRegistry promptName promptVer = + T.unlines + [ "{ repoName = \"Prompts\"", + ", repoDescription = None Text", + ", modules = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", recipes = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", blueprints = [] : List { name : Text, version : Optional Text, path : Text, description : Optional Text, tags : List Text }", + ", prompts =", + " [ { name = \"" <> promptName <> "\"", + " , version = " <> optVersion promptVer, + " , path = \"prompts/" <> promptName <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +writeModuleDhall :: FilePath -> Text -> Text -> IO () +writeModuleDhall path name ver = + TIO.writeFile + path + ( T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = Some \"" <> ver <> "\"", + ", 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", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + ) + +registryDhall :: Text -> Maybe Text -> Text -> Maybe Text -> Text +registryDhall n1 v1 n2 v2 = + T.unlines + [ "{ repoName = \"Test\"", + ", repoDescription = None Text", + ", modules =", + " [ { name = \"" <> n1 <> "\"", + " , version = " <> optVersion v1, + " , path = \"modules/" <> n1 <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " , { name = \"" <> n2 <> "\"", + " , version = " <> optVersion v2, + " , path = \"modules/" <> n2 <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +optVersion :: Maybe Text -> Text +optVersion Nothing = "None Text" +optVersion (Just v) = "Some \"" <> v <> "\"" diff --git a/test/Seihou/CLI/RemoteVersionSpec.hs b/test/Seihou/CLI/RemoteVersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/RemoteVersionSpec.hs @@ -0,0 +1,117 @@ +module Seihou.CLI.RemoteVersionSpec (tests) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Seihou.CLI.RemoteVersion (FetchError (..), fetchTrueModuleVersion) +import Seihou.Core.Types (ModuleName (..)) +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.CLI.RemoteVersion" spec + +spec :: Spec +spec = do + describe "fetchTrueModuleVersion (multi-module repo)" $ do + it "returns the module.dhall version even when the registry says otherwise" $ + withSystemTempDirectory "seihou-rv-stale" $ \dir -> do + -- Stale registry: registry declares 1.0.0, module.dhall declares 2.0.0. + createDirectoryIfMissing True (dir "modules" "demo") + writeModuleDhall (dir "modules" "demo" "module.dhall") "demo" (Just "2.0.0") + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "demo" (Just "1.0.0") "modules/demo") + + result <- fetchTrueModuleVersion dir (ModuleName "demo") + result `shouldBe` Right (Just "2.0.0") + + it "returns Right Nothing when module.dhall declares no version" $ + withSystemTempDirectory "seihou-rv-unver" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "demo") + writeModuleDhall (dir "modules" "demo" "module.dhall") "demo" Nothing + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "demo" (Just "1.0.0") "modules/demo") + + result <- fetchTrueModuleVersion dir (ModuleName "demo") + result `shouldBe` Right Nothing + + it "returns EntryNotFound when the registry has no matching module" $ + withSystemTempDirectory "seihou-rv-missing" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "demo") + writeModuleDhall (dir "modules" "demo" "module.dhall") "demo" (Just "2.0.0") + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "demo" (Just "1.0.0") "modules/demo") + + result <- fetchTrueModuleVersion dir (ModuleName "other") + result `shouldBe` Left (EntryNotFound (ModuleName "other")) + + it "returns ModuleDhallNotFound when the registry path doesn't have module.dhall" $ + withSystemTempDirectory "seihou-rv-broken" $ \dir -> do + createDirectoryIfMissing True (dir "modules" "demo") + TIO.writeFile (dir "seihou-registry.dhall") (registryDhall "demo" (Just "1.0.0") "modules/demo") + + result <- fetchTrueModuleVersion dir (ModuleName "demo") + case result of + Left (ModuleDhallNotFound _) -> pure () + other -> expectationFailure ("expected ModuleDhallNotFound, got " <> show other) + + describe "fetchTrueModuleVersion (single-module repo)" $ do + it "reads module.dhall at the repo root" $ + withSystemTempDirectory "seihou-rv-single" $ \dir -> do + writeModuleDhall (dir "module.dhall") "demo" (Just "3.4.5") + + result <- fetchTrueModuleVersion dir (ModuleName "demo") + result `shouldBe` Right (Just "3.4.5") + + describe "fetchTrueModuleVersion (empty repo)" $ do + it "returns RegistryNotFound when nothing recognizable is present" $ + withSystemTempDirectory "seihou-rv-empty" $ \dir -> do + result <- fetchTrueModuleVersion dir (ModuleName "demo") + case result of + Left (RegistryNotFound _) -> pure () + other -> expectationFailure ("expected RegistryNotFound, got " <> show other) + +-- ---------------------------------------------------------------------------- +-- Fixture helpers +-- ---------------------------------------------------------------------------- + +writeModuleDhall :: FilePath -> Text -> Maybe Text -> IO () +writeModuleDhall path name mver = + TIO.writeFile path (moduleDhallBody name mver) + +moduleDhallBody :: Text -> Maybe Text -> Text +moduleDhallBody name mver = + T.unlines + [ "{ name = \"" <> name <> "\"", + ", version = " <> optText mver, + ", 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", + ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }", + "}" + ] + +registryDhall :: Text -> Maybe Text -> Text -> Text +registryDhall name mver path = + T.unlines + [ "{ repoName = \"Test\"", + ", repoDescription = None Text", + ", modules =", + " [ { name = \"" <> name <> "\"", + " , version = " <> optText mver, + " , path = \"" <> path <> "\"", + " , description = None Text", + " , tags = [] : List Text", + " }", + " ]", + "}" + ] + +optText :: Maybe Text -> Text +optText Nothing = "None Text" +optText (Just v) = "Some \"" <> v <> "\"" diff --git a/test/Seihou/CLI/RunBlueprintRefusalSpec.hs b/test/Seihou/CLI/RunBlueprintRefusalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/RunBlueprintRefusalSpec.hs @@ -0,0 +1,36 @@ +module Seihou.CLI.RunBlueprintRefusalSpec (tests) where + +import Data.Text qualified as T +import Seihou.CLI.Shared (formatBlueprintRefusal) +import Seihou.Core.Types (ModuleName (..)) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.RunBlueprintRefusal" spec + +spec :: Spec +spec = do + describe "formatBlueprintRefusal" $ do + it "names the blueprint that was attempted" $ do + let msg = formatBlueprintRefusal (ModuleName "my-blueprint") + T.isInfixOf "'my-blueprint' is a blueprint" msg `shouldBe` True + + it "describes that blueprints aren't modules or recipes" $ do + let msg = formatBlueprintRefusal (ModuleName "x") + T.isInfixOf "not a module or recipe" msg `shouldBe` True + + it "tells the user how to invoke the blueprint via the agent runner" $ do + let msg = formatBlueprintRefusal (ModuleName "payments-service") + T.isInfixOf "seihou agent run payments-service" msg `shouldBe` True + + it "is rendered as a single multi-line string (one '[error]' prefix at runtime)" $ do + -- The Logger interpreter prefixes each logError call with + -- "[error] ". The refusal body must therefore be emitted as a + -- single string with newlines so only the first line carries the + -- prefix. Verify the message contains newline separators rather + -- than being a list of independent strings. + let msg = formatBlueprintRefusal (ModuleName "a") + lns = T.splitOn "\n" msg + length lns `shouldBe` 3 diff --git a/test/Seihou/CLI/SavePromptedSpec.hs b/test/Seihou/CLI/SavePromptedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/SavePromptedSpec.hs @@ -0,0 +1,184 @@ +module Seihou.CLI.SavePromptedSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Seihou.CLI.SavePrompted (collectPromptedValues, offerSavePrompted) +import Seihou.Composition.Instance (primaryInstance) +import Seihou.Core.Types +import Seihou.Effect.ConfigWriterPure (ConfigWriterState (..), emptyConfigWriterState, runConfigWriterPure) +import Seihou.Effect.ConsolePure (ConsoleState (..), runConsolePure) +import Seihou.Prelude (runEff) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.SavePrompted" spec + +mkDecl :: Text -> VarDecl +mkDecl n = + VarDecl + { name = VarName n, + type_ = VTText, + default_ = Nothing, + description = Nothing, + required = True, + validation = Nothing + } + +mkResolved :: VarSource -> Text -> VarDecl -> ResolvedVar +mkResolved src val decl = + ResolvedVar + { value = VText val, + source = src, + decl = decl + } + +spec :: Spec +spec = do + describe "collectPromptedValues" $ do + it "extracts variables with FromPrompt source" $ do + let decl = mkDecl "project.name" + resolved = + Map.singleton (primaryInstance (ModuleName "mod1")) $ + Map.singleton (VarName "project.name") (mkResolved FromPrompt "my-app" decl) + result = collectPromptedValues resolved Map.empty + result `shouldBe` [(VarName "project.name", "my-app", Nothing)] + + it "ignores variables from non-prompt sources" $ do + let decl = mkDecl "license" + resolved = + Map.singleton (primaryInstance (ModuleName "mod1")) $ + Map.fromList + [ (VarName "license", mkResolved FromGlobalConfig "MIT" decl), + (VarName "project.name", mkResolved FromCLI "foo" (mkDecl "project.name")) + ] + result = collectPromptedValues resolved Map.empty + result `shouldBe` [] + + it "skips values already in local config with the same value" $ do + let decl = mkDecl "project.name" + resolved = + Map.singleton (primaryInstance (ModuleName "mod1")) $ + Map.singleton (VarName "project.name") (mkResolved FromPrompt "my-app" decl) + localConfig = Map.singleton (VarName "project.name") "my-app" + result = collectPromptedValues resolved localConfig + result `shouldBe` [] + + it "includes values that differ from local config with existing value" $ do + let decl = mkDecl "project.name" + resolved = + Map.singleton (primaryInstance (ModuleName "mod1")) $ + Map.singleton (VarName "project.name") (mkResolved FromPrompt "new-app" decl) + localConfig = Map.singleton (VarName "project.name") "old-app" + result = collectPromptedValues resolved localConfig + result `shouldBe` [(VarName "project.name", "new-app", Just "old-app")] + + it "deduplicates across modules" $ do + let decl = mkDecl "project.name" + resolved = + Map.fromList + [ ( primaryInstance (ModuleName "mod1"), + Map.singleton (VarName "project.name") (mkResolved FromPrompt "app1" decl) + ), + ( primaryInstance (ModuleName "mod2"), + Map.singleton (VarName "project.name") (mkResolved FromPrompt "app2" decl) + ) + ] + result = collectPromptedValues resolved Map.empty + length result `shouldBe` 1 + + it "handles multiple prompted variables" $ do + let resolved = + Map.singleton (primaryInstance (ModuleName "mod1")) $ + Map.fromList + [ (VarName "license", mkResolved FromPrompt "MIT" (mkDecl "license")), + (VarName "project.name", mkResolved FromPrompt "my-app" (mkDecl "project.name")) + ] + result = collectPromptedValues resolved Map.empty + length result `shouldBe` 2 + + it "returns empty list when no prompted values exist" $ do + let resolved = + Map.singleton (primaryInstance (ModuleName "mod1")) $ + Map.singleton (VarName "x") (mkResolved FromDefault "val" (mkDecl "x")) + result = collectPromptedValues resolved Map.empty + result `shouldBe` [] + + describe "offerSavePrompted" $ do + let entries = + [ (VarName "project.name", "my-app", Nothing), + (VarName "license", "MIT", Nothing) + ] + + it "saves values when user confirms with 'y'" $ do + (((), cwState), _consoleSt) <- + runEff $ + runConsolePure ["y"] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted Nothing True entries + cwState.cwLocal `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")] + + it "does not save when user declines with 'n'" $ do + (((), cwState), _consoleSt) <- + runEff $ + runConsolePure ["n"] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted Nothing True entries + cwState.cwLocal `shouldBe` Map.empty + + it "saves without asking when --save-prompted (Just True)" $ do + (((), cwState), consoleSt) <- + runEff $ + runConsolePure [] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted (Just True) True entries + cwState.cwLocal `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")] + -- Should not contain the confirmation prompt + any (T.isInfixOf "Save prompted values") consoleSt.consoleOutputs `shouldBe` False + + it "skips entirely when --no-save-prompted (Just False)" $ do + (((), cwState), consoleSt) <- + runEff $ + runConsolePure [] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted (Just False) True entries + cwState.cwLocal `shouldBe` Map.empty + consoleSt.consoleOutputs `shouldBe` [] + + it "skips in non-interactive mode when no flag given" $ do + (((), cwState), _consoleSt) <- + runEff $ + runConsolePure [] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted Nothing False entries + cwState.cwLocal `shouldBe` Map.empty + + it "shows overwrite note for existing values" $ do + let entriesWithOverwrite = + [ (VarName "project.name", "new-app", Just "old-app") + ] + ((_result, _cwState), consoleSt) <- + runEff $ + runConsolePure ["y"] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted Nothing True entriesWithOverwrite + any (T.isInfixOf "overwrites current") consoleSt.consoleOutputs `shouldBe` True + + it "does nothing when entries list is empty" $ do + (((), cwState), consoleSt) <- + runEff $ + runConsolePure [] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted Nothing True [] + cwState.cwLocal `shouldBe` Map.empty + consoleSt.consoleOutputs `shouldBe` [] + + it "displays confirmation message after saving" $ do + (((), _cwState), consoleSt) <- + runEff $ + runConsolePure ["y"] $ + runConfigWriterPure emptyConfigWriterState $ + offerSavePrompted Nothing True entries + any (T.isInfixOf "Saved 2 value(s)") consoleSt.consoleOutputs `shouldBe` True diff --git a/test/Seihou/CLI/StatusSpec.hs b/test/Seihou/CLI/StatusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/StatusSpec.hs @@ -0,0 +1,255 @@ +module Seihou.CLI.StatusSpec (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) +import Seihou.CLI.StatusRender (formatStatus) +import Seihou.CLI.VersionCompare + ( OutdatedEntry (..), + OutdatedStatus (..), + ) +import Seihou.Core.Migration + ( Migration (..), + MigrationOp (..), + MigrationPlan (..), + ) +import Seihou.Core.Types + ( AppliedBlueprint (..), + AppliedModule (..), + Manifest (..), + ModuleName (..), + emptyParentVars, + ) +import Seihou.Core.Version qualified +import Seihou.Manifest.Types (emptyManifest) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.StatusRender" spec + +fixedTime :: UTCTime +fixedTime = + parseTimeOrError + True + defaultTimeLocale + "%Y-%m-%dT%H:%M:%SZ" + "2026-04-15T10:00:00Z" + +mkApplied :: Text -> Maybe Text -> AppliedModule +mkApplied name mver = + AppliedModule + { name = ModuleName name, + parentVars = emptyParentVars, + source = "/installed/" <> T.unpack name, + moduleVersion = mver, + appliedAt = fixedTime, + removal = Nothing + } + +mkManifest :: [AppliedModule] -> Manifest +mkManifest mods = + (emptyManifest fixedTime) + { modules = mods, + files = Map.empty + } + +-- | Build a 'MigrationPlan' fixture for use with formatStatus. +mkPlan :: Text -> Text -> Text -> Int -> MigrationPlan +mkPlan modName from to nSteps = + MigrationPlan + { planModule = modName, + planFrom = parseV from, + planTo = parseV to, + planSteps = replicate nSteps (Migration from to [DeleteFile "x"]) + } + +parseV :: Text -> Seihou.Core.Version.Version +parseV t = case Seihou.Core.Version.parseVersion t of + Just v -> v + Nothing -> error ("test fixture: unparseable version " <> T.unpack t) + +mkEntry :: Text -> Maybe Text -> Maybe Text -> OutdatedStatus -> OutdatedEntry +mkEntry name inst avail status = + OutdatedEntry + { moduleName = name, + installedVersion = inst, + availableVersion = avail, + status = status + } + +mkBlueprint :: + Text -> + Maybe Text -> + [Text] -> + Bool -> + Maybe Text -> + AppliedBlueprint +mkBlueprint name mver baselines noBL prompt = + AppliedBlueprint + { name = ModuleName name, + blueprintVersion = mver, + appliedAt = fixedTime, + baselineModules = map ModuleName baselines, + noBaseline = noBL, + userPrompt = prompt, + agentSessionId = Nothing + } + +withManifestBlueprint :: Maybe AppliedBlueprint -> Manifest -> Manifest +withManifestBlueprint mb m = m {blueprint = mb} + +spec :: Spec +spec = describe "formatStatus" $ do + describe "blueprint provenance" $ do + it "renders a populated blueprint with version, two baselines, and prompt" $ do + let manifest = + withManifestBlueprint + ( Just $ + mkBlueprint + "payments-service" + (Just "0.3.1") + ["nix-flake", "haskell-base"] + False + (Just "set this up for a payments microservice") + ) + (mkManifest []) + out = formatStatus False manifest [] Nothing [] + out `shouldSatisfy` T.isInfixOf "Blueprint: payments-service v0.3.1 (applied" + out `shouldSatisfy` T.isInfixOf " Baseline: nix-flake, haskell-base" + out `shouldSatisfy` T.isInfixOf " Prompt: \"set this up for a payments microservice\"" + + it "renders --no-baseline as the dedicated placeholder" $ do + let manifest = + withManifestBlueprint + ( Just $ + mkBlueprint "lone-blueprint" Nothing [] True Nothing + ) + (mkManifest []) + out = formatStatus False manifest [] Nothing [] + out `shouldSatisfy` T.isInfixOf "Blueprint: lone-blueprint (applied" + out `shouldSatisfy` T.isInfixOf " Baseline: (none -- --no-baseline)" + out `shouldNotSatisfy` T.isInfixOf " Prompt:" + + it "omits the Prompt line when no positional prompt was supplied" $ do + let manifest = + withManifestBlueprint + ( Just $ + mkBlueprint + "payments-service" + (Just "0.3.1") + ["nix-flake"] + False + Nothing + ) + (mkManifest []) + out = formatStatus False manifest [] Nothing [] + out `shouldSatisfy` T.isInfixOf "Blueprint: payments-service v0.3.1 (applied" + out `shouldSatisfy` T.isInfixOf " Baseline: nix-flake" + out `shouldNotSatisfy` T.isInfixOf " Prompt:" + + it "omits the entire blueprint section when manifest.blueprint is Nothing" $ do + let manifest = withManifestBlueprint Nothing (mkManifest []) + out = formatStatus False manifest [] Nothing [] + out `shouldNotSatisfy` T.isInfixOf "Blueprint: " + out `shouldNotSatisfy` T.isInfixOf " Baseline:" + + it "renders an empty-baseline (no --no-baseline) blueprint with the (none declared) placeholder" $ do + let manifest = + withManifestBlueprint + (Just $ mkBlueprint "pure-prompt" Nothing [] False Nothing) + (mkManifest []) + out = formatStatus False manifest [] Nothing [] + out `shouldSatisfy` T.isInfixOf "Blueprint: pure-prompt (applied" + out `shouldSatisfy` T.isInfixOf " Baseline: (none declared)" + + it "all modules clean: no remediation, no Recommended actions block" $ do + let am = mkApplied "demo" (Just "1.0.0") + manifest = mkManifest [am] + entries = Just [mkEntry "demo" (Just "1.0.0") (Just "1.0.0") UpToDate] + out = formatStatus False manifest [] entries [] + out `shouldSatisfy` T.isInfixOf "demo" + out `shouldSatisfy` T.isInfixOf "up to date" + out `shouldNotSatisfy` T.isInfixOf "Run: seihou" + out `shouldNotSatisfy` T.isInfixOf "Recommended actions" + out `shouldNotSatisfy` T.isInfixOf "Pending migration" + + it "outdated only (no migration declared): per-row upgrade hint and summary entry" $ do + let am = mkApplied "demo" (Just "0.1.0") + manifest = mkManifest [am] + entries = Just [mkEntry "demo" (Just "0.1.0") (Just "0.3.0") OutdatedSt] + out = formatStatus False manifest [] entries [] + out `shouldSatisfy` T.isInfixOf "outdated: 0.3.0 available" + out `shouldSatisfy` T.isInfixOf "Run: seihou upgrade demo" + out `shouldSatisfy` T.isInfixOf "Recommended actions:" + out `shouldSatisfy` T.isInfixOf " seihou upgrade demo" + out `shouldNotSatisfy` T.isInfixOf "Pending migration" + + it "pending migration (full chain): per-row migrate hint and summary" $ do + let am = mkApplied "demo" (Just "1.0.0") + manifest = mkManifest [am] + plan = mkPlan "demo" "1.0.0" "2.0.0" 1 + out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] + out `shouldSatisfy` T.isInfixOf "Pending migration: 1.0.0 -> 2.0.0 (1 step(s))" + out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Recommended actions:" + out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + out `shouldNotSatisfy` T.isInfixOf "seihou upgrade" + + it "outdated + pending migration: single migrate hint, no upgrade hint" $ do + let am = mkApplied "demo" (Just "0.1.0") + manifest = mkManifest [am] + plan = mkPlan "demo" "0.1.0" "0.3.0" 6 + entries = Just [mkEntry "demo" (Just "0.1.0") (Just "0.3.0") OutdatedSt] + out = formatStatus False manifest [] entries [(ModuleName "demo", plan)] + out `shouldSatisfy` T.isInfixOf "outdated: 0.3.0 available" + out `shouldSatisfy` T.isInfixOf "Pending migration: 0.1.0 -> 0.3.0 (6 step(s))" + out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldNotSatisfy` T.isInfixOf "seihou upgrade demo" + out `shouldSatisfy` T.isInfixOf "Recommended actions:" + out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + + -- Master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0, + -- declared [0.1.0 → 0.2.0]. The chain reaches 0.2 via ops; the + -- supplied target is 0.3, so planTo = 0.3. Status surfaces the + -- single in-window step and points at `seihou migrate demo` as the + -- remediation. + it "partial-cover plan: chain reaches an intermediate version, target is the user's installed copy" $ do + let am = mkApplied "demo" (Just "0.1.0") + manifest = mkManifest [am] + plan = mkPlan "demo" "0.1.0" "0.3.0" 1 + out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] + out `shouldSatisfy` T.isInfixOf "Pending migration: 0.1.0 -> 0.3.0 (1 step(s))" + out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Recommended actions:" + out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + -- Doomed vocabulary is gone from status output. + out `shouldNotSatisfy` T.isInfixOf "Blocked" + out `shouldNotSatisfy` T.isInfixOf "no migration declared from" + out `shouldNotSatisfy` T.isInfixOf "bump through" + + -- A module that has a version gap but no in-window declared + -- migration still surfaces a pending advisory; the row reports + -- 0 step(s) so the user knows `seihou migrate` will only advance + -- the manifest. + it "renders empty-steps plan with a 0-step pending row" $ do + let am = mkApplied "demo" (Just "0.2.0") + manifest = mkManifest [am] + plan = + MigrationPlan + { planModule = "demo", + planFrom = parseV "0.2.0", + planTo = parseV "0.3.0", + planSteps = [] + } + out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)] + out `shouldSatisfy` T.isInfixOf "Pending migration: 0.2.0 -> 0.3.0 (0 step(s))" + out `shouldSatisfy` T.isInfixOf "Run: seihou migrate demo" + out `shouldSatisfy` T.isInfixOf "Recommended actions:" + out `shouldSatisfy` T.isInfixOf " seihou migrate demo" + -- The doomed vocabulary stays out of the rendered status. + out `shouldNotSatisfy` T.isInfixOf "Blocked" + out `shouldNotSatisfy` T.isInfixOf "--bump-only" + out `shouldNotSatisfy` T.isInfixOf "[blocked]" diff --git a/test/Seihou/CLI/UpgradeSpec.hs b/test/Seihou/CLI/UpgradeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/CLI/UpgradeSpec.hs @@ -0,0 +1,36 @@ +module Seihou.CLI.UpgradeSpec (tests) where + +import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.CLI.Upgrade" spec + +spec :: Spec +spec = do + describe "compareVersions" $ do + it "returns Unversioned when both versions are Nothing" $ + compareVersions Nothing Nothing `shouldBe` Unversioned + + it "returns Unversioned when installed version is Nothing" $ + compareVersions Nothing (Just "1.0") `shouldBe` Unversioned + + it "returns Unversioned when available version is Nothing" $ + compareVersions (Just "1.0") Nothing `shouldBe` Unversioned + + it "returns OutdatedSt when available version is newer" $ + compareVersions (Just "1.0") (Just "2.0") `shouldBe` OutdatedSt + + it "returns UpToDate when installed version is newer" $ + compareVersions (Just "2.0") (Just "1.0") `shouldBe` UpToDate + + it "returns UpToDate when versions are equal" $ + compareVersions (Just "1.0") (Just "1.0") `shouldBe` UpToDate + + it "returns Unversioned when version strings are unparseable" $ + compareVersions (Just "abc") (Just "def") `shouldBe` Unversioned + + it "returns Unversioned when one version is unparseable" $ + compareVersions (Just "1.0") (Just "abc") `shouldBe` Unversioned diff --git a/test/Seihou/FzfSpec.hs b/test/Seihou/FzfSpec.hs new file mode 100644 --- /dev/null +++ b/test/Seihou/FzfSpec.hs @@ -0,0 +1,182 @@ +module Seihou.FzfSpec (tests) where + +import Data.Text qualified as T +import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..)) +import Seihou.Core.Types +import Seihou.Effect.Fzf (selectOne) +import Seihou.Effect.FzfInterp (runFzfPure) +import Seihou.Fzf + ( Candidate (..), + FzfOpts, + FzfResult (..), + optsToArgs, + withAnsi, + withHeader, + withHeight, + withNoSort, + withPreview, + withPrompt, + ) +import Seihou.Fzf.Selector.Module (formatModuleCandidate, formatRunnableCandidate) +import Seihou.Prelude +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = testSpec "Seihou.Fzf" spec + +spec :: Spec +spec = do + describe "optsToArgs" $ do + it "produces empty args for mempty" $ do + optsToArgs mempty `shouldBe` [] + + it "produces --prompt flag" $ do + optsToArgs (withPrompt "test> ") `shouldBe` ["--prompt", "test> "] + + it "produces --header flag" $ do + optsToArgs (withHeader "Pick one") `shouldBe` ["--header", "Pick one"] + + it "produces --height flag" $ do + optsToArgs (withHeight "40%") `shouldBe` ["--height", "40%"] + + it "produces --ansi flag" $ do + optsToArgs withAnsi `shouldBe` ["--ansi"] + + it "produces --no-sort flag" $ do + optsToArgs withNoSort `shouldBe` ["--no-sort"] + + it "produces --preview flag" $ do + optsToArgs (withPreview "cat {}") `shouldBe` ["--preview", "cat {}"] + + it "combines options with <>" $ do + let opts = withPrompt "p> " <> withHeight "50%" <> withAnsi + optsToArgs opts `shouldBe` ["--prompt", "p> ", "--height", "50%", "--ansi"] + + describe "FzfOpts Monoid" $ do + it "mempty is left identity" $ do + let opts = withPrompt "test> " + optsToArgs (mempty <> opts) `shouldBe` optsToArgs opts + + it "mempty is right identity" $ do + let opts = withPrompt "test> " + optsToArgs (opts <> mempty) `shouldBe` optsToArgs opts + + it "right-biases Maybe fields" $ do + let a = withPrompt "first> " + b = withPrompt "second> " + optsToArgs (a <> b) `shouldBe` ["--prompt", "second> "] + + it "sticky-true for Bool fields" $ do + let opts = withAnsi <> mempty + optsToArgs opts `shouldBe` ["--ansi"] + + describe "runFzfPure" $ do + it "selects candidate at given index" $ do + let candidates = + [ Candidate "alpha" ("a" :: Text), + Candidate "beta" "b", + Candidate "gamma" "c" + ] + result <- runEff $ runFzfPure 1 $ selectOne mempty candidates + case result of + FzfSelected val -> val `shouldBe` "b" + _ -> expectationFailure "expected FzfSelected" + + it "returns FzfNoMatch for negative index" $ do + let candidates = [Candidate "alpha" ("a" :: Text)] + result <- runEff $ runFzfPure (-1) $ selectOne mempty candidates + case result of + FzfNoMatch -> pure () + _ -> expectationFailure "expected FzfNoMatch" + + it "returns FzfNoMatch for out-of-bounds index" $ do + let candidates = [Candidate "alpha" ("a" :: Text)] + result <- runEff $ runFzfPure 5 $ selectOne mempty candidates + case result of + FzfNoMatch -> pure () + _ -> expectationFailure "expected FzfNoMatch" + + it "returns FzfNoMatch for empty candidates" $ do + result <- runEff $ runFzfPure 0 $ selectOne mempty ([] :: [Candidate Text]) + case result of + FzfNoMatch -> pure () + _ -> expectationFailure "expected FzfNoMatch" + + describe "formatModuleCandidate" $ do + it "returns Just for a valid module" $ do + let dm = validModule "test-mod" "A test module" SourceUser + case formatModuleCandidate dm of + Just c -> do + c.candidateValue `shouldBe` ModuleName "test-mod" + T.isInfixOf "test-mod" c.candidateDisplay `shouldBe` True + T.isInfixOf "[user]" c.candidateDisplay `shouldBe` True + Nothing -> expectationFailure "expected Just" + + it "returns Nothing for a failed module" $ do + let dm = + DiscoveredModule + { discoveredResult = Left (ModuleNotFound (ModuleName "bad") []), + discoveredSource = SourceProject, + discoveredDir = "/tmp/bad" + } + case formatModuleCandidate dm of + Nothing -> pure () + Just _ -> expectationFailure "expected Nothing" + + it "includes description when present" $ do + let dm = validModule "mod" "My description" SourceInstalled + case formatModuleCandidate dm of + Just c -> T.isInfixOf "My description" c.candidateDisplay `shouldBe` True + Nothing -> expectationFailure "expected Just" + + it "tags source correctly" $ do + let dmProject = validModule "m" "d" SourceProject + dmUser = validModule "m" "d" SourceUser + dmInstalled = validModule "m" "d" SourceInstalled + case (formatModuleCandidate dmProject, formatModuleCandidate dmUser, formatModuleCandidate dmInstalled) of + (Just p, Just u, Just i) -> do + T.isInfixOf "[project]" p.candidateDisplay `shouldBe` True + T.isInfixOf "[user]" u.candidateDisplay `shouldBe` True + T.isInfixOf "[installed]" i.candidateDisplay `shouldBe` True + _ -> expectationFailure "expected all Just" + + describe "formatRunnableCandidate" $ do + it "tags prompt candidates with [prompt]" $ do + let dr = + DiscoveredRunnable + { drName = "review-changes", + drDescription = Just "Review current changes", + drKind = KindPrompt, + drSource = SourceProject, + drDir = "/tmp/review-changes", + drIsError = False, + drError = Nothing + } + case formatRunnableCandidate dr of + Just c -> T.isInfixOf "[prompt]" c.candidateDisplay `shouldBe` True + Nothing -> expectationFailure "expected Just" + +-- | Helper to create a valid discovered module for testing. +validModule :: String -> String -> ModuleSource -> DiscoveredModule +validModule name desc src = + DiscoveredModule + { discoveredResult = + Right + Module + { name = ModuleName (T.pack name), + version = Nothing, + description = Just (T.pack desc), + vars = [], + exports = [], + prompts = [], + steps = [], + commands = [], + dependencies = [], + removal = Nothing, + migrations = [] + }, + discoveredSource = src, + discoveredDir = "/tmp/" ++ name + }