From c9892970cb1e0fe921683ffe063b8b37a673bb9e Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 03:24:37 +0000 Subject: [PATCH 01/25] Add PLAN-Integration: consumer patterns, agent discoverability, SageFs Survey of Xantham's scripts and Build/Program.fs: shared boilerplate that Baked prefab stages could absorb, API traps, machine-readable output and exit codes for agents, and what must change for pipelines to run inside a long-lived SageFs FSI session (argv-free invoke, console and cancellation hygiene). Records consumer-side findings separately. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- notes/PLAN-Integration.md | 301 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 301 insertions(+) create mode 100644 notes/PLAN-Integration.md diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md new file mode 100644 index 0000000..d27e52e --- /dev/null +++ b/notes/PLAN-Integration.md @@ -0,0 +1,301 @@ +# PLAN-Integration + +Findings from a survey of how Partas.Build is used in practice, and the design that follows. Drafted +2026-09-24. **Status: proposal — nothing here is implemented.** + +Companion to `PLAN-Discoverability.md`, which responded to `FEEDBACK-Xantham.md` (a report written against +0.3.0). This document starts from the consumers' *code* instead of a written report, and adds a third axis the +earlier plans do not cover: running builds inside a long-lived F# host, specifically SageFs. + +Three axes, in priority order: + +1. **Usability**: the boilerplate every consumer rewrites, and the API traps they fall into. +2. **Agent discoverability**: what an agent can learn by running a command, as opposed to reading docs. +3. **SageFs integration**: making a pipeline safe and useful to invoke repeatedly from a warm FSI session. + +## 1. Consumers surveyed + +| Consumer | Form | Partas.Build version | +|---|---|---| +| Xantham `build.fsx` | `dotnet fsi` script, `#r "nuget: …"` | 0.4.0-alpha.3 | +| Xantham `tools/generate-wire.fsx`, `tools/xantham-fixtures.fsx` | `dotnet fsi` scripts, invoked from `build.fsx` as child processes | 0.3.0 | +| Xantham `tools/workspace.fsx` | `#load`-only helper | — | +| `Build/Program.fs` (this repo) | project reference | current | +| `Partas.Build.ExternalAnnotations` / `Partas.ExternalAnnotations.Tool` | library stages + dotnet tool | current | + +The library is at 0.6.5. Xantham has not upgraded, so several of its workarounds are already solved upstream +(`Cmd.argWhenSome`/`argIf`, `mapFromAmong`, the renamed Baked API). Upgrading is the cheapest item in this +plan; it is listed under §6 because it is Xantham's to do. + +## 2. Patterns common to every consumer + +Established by reading the consumers, not by inference. + +### Hand-rolled in both `Build/Program.fs` and Xantham `build.fsx` + +| Pattern | Xantham | Partas.Build | +|---|---|---| +| Restore: `dotnet restore ` + `dotnet tool restore`, gated on `--quick` | `build.fsx:177-189` | `Program.fs:96-103` | +| Clean: `bin` directories through Fake `Shell.cleanDirs` | `build.fsx:204-220` | `Program.fs:104-119` (plus `*.nupkg`) | +| `--quick`/`-q`, `--skip-tests`, `--watch` option declarations | `build.fsx` `Options` | `Program.fs` `Options` | +| Configuration defaulting to Release: `InputSpec.ofInput \|> InputSpec.map (Option.defaultValue "Release")` | `build.fsx:78-81` | `Program.fs:55-58` | +| Build/pack per project: `dotnet build {p} -c {config} -v q`, `dotnet pack --no-build --no-restore -o bin` | `build.fsx:222-238, 531-553` | `Program.fs:122-146` | +| Run an Expecto suite | hard-coded `bin/{config}/net10.0/{Name}.dll` (`build.fsx:397-419`) — breaks on a TFM change | `dotnet run --no-build -- --summary --sequenced` | +| NuGet push: local feed vs nuget.org, `--skip-duplicate`, `bin/*.nupkg` | `build.fsx:555-568` | `Program.fs:147-168` | +| Docs: `dotnet run --project -- watch\|build` | `build.fsx:240-267` | `Program.fs:208-218` | +| Split src/test projects by string-matching the path | `build.fsx:54-55` | `Program.fs:62-72` | + +### Constructs recurring across consumers + +- **`if` inside a stage to choose its shape** (docs watch vs build, `npm ci` vs `npm install`): the known + "custom operations cannot sit under `if`/`match`" limitation, worked around by building a `Cmd` first. +- **`when' (not quick)`** is the most common condition by far. It reports no reason under `--explain`. +- **Loops generating stages**: `for project in projects do stage $"pack-{project.Name}" { … }`. +- **`open Partas.Build.Internal`** in consumer code (`Program.fs:18`, `xantham-fixtures.fsx:113`) and in the + docs pages (`docs/content/index.fsx:50`, `docs/content/Build/*.fsx`). Task 14b of + `PLAN-Discoverability-Tasks.md` is still open. +- **Raw `printfn` inside steps**, bypassing `quiet` and capture: Xantham `findings`, `generate-wire.fsx`, + `workspace.fsx`, and **Baked's own `bumpImpl`** in `src/Partas.Build.Baked/SemVer.fs`. +- **Side effects while binding inputs**: Xantham's `Workspace.ensureTsc` runs inside `input { }` before + `return` — it sets process environment variables and prints, and so runs under `--help` and `--explain`. + +### Unused by every consumer + +`onFailure`, `retry`, `timeout`, `continueStageOnFailure`, producers/`consumes`. Xantham also never uses +`pipeline` or `description`. The execution model of `PLAN-Execution.md` has no consumer yet; its first real +user will likely be whatever §3.1's prefab stages need. + +## 3. Usability + +### 3.1 Prefab stages in Baked + +Every row of the first table in §2 becomes a function in `Partas.Build.Baked`, taking `InputSpec`s so it +composes with the consumer's own options: + +| Proposed | Absorbs | +|---|---| +| `Baked.Common.quick`, `skipTests`, `watch` | the three duplicated option declarations | +| `Baked.Dotnet.configOrRelease : InputSpec` | the `ofInput \|> map (defaultValue "Release")` chain | +| `Baked.Stages.restore (sln)` | restore + tool restore, skipped by `quick` | +| `Baked.Stages.clean (dirs)` | Fake `Shell.cleanDirs`; removes the Fake dependency and its `FakeExecutionContext` setup (`Program.fs:21-22`) | +| `Baked.Stages.build (projects)`, `pack (projects, outDir)` | per-project build/pack under `parallel'` | +| `Baked.Stages.expecto (project, filter)` | resolves the test executable through MSBuild `TargetPath` or `dotnet run --no-build`, never a hand-built path; passes `--summary` under `--ci` and captures output there | +| `Baked.Stages.nugetPush (key, source, glob)` | built on `whenSome` + `runSensitive`, so the key is always masked and never read through `.Value` | +| `Baked.Stages.fantomas`, `npmInstall` | format and npm install | + +`nugetPush` is the most important of these: Xantham's hand-written push (§6) leaks the key into the local log. + +Open question: whether prefabs are functions returning `InputSpec` or records with overridable +fields (W12 in `FEEDBACK-Xantham.md`, deferred). Functions first; records only if a consumer needs to patch +one prefab field. + +### 3.2 API traps + +- **`run (fun ctx -> "…")` executes the returned string as a command line** (`StageSettings.fs:363`). A lambda + written to return a message becomes a process launch. Rename to `runLine`, or mark the `string`-returning + overload `[]` in favour of `run (fun ctx -> cmd …)`. Check that the rename does not disturb the + `FS0041` balance recorded in CLAUDE.md for `run (build, buildStep)`. +- **Duplicate names**: `Input.desc`/`Input.description` (`Inputs.fs:209,215`) and `input`/`inputs` + (`Builders/Inputs.fs:61,64`). Consumers mix them. Keep one of each, `[]` the other. +- **`when' bool` carries no reason.** Add `when' (reason: string, cond: bool)` or a `whenNotFlag` for the + `when' (not quick)` idiom, so `--explain` names the flag that skipped the stage. +- **`printfn` in Baked**: replace with `StageContext.writeLine`. + +### 3.3 Finish Task 14b + +`StageContext`, `PipelineContext` and `CommandSpec` still live in `Partas.Build.Internal`. Acceptance criterion +6 of `PLAN-Discoverability.md` (no consumer signature needs `Internal`) is unmet. Move the types, or add public +aliases under `Partas.Build`, then remove `open Partas.Build.Internal` from `Build/Program.fs` and the docs +pages as the check. + +## 4. Agent discoverability + +`PLAN-Discoverability.md`'s principle stands: an agent will run a command before it reads a document. The +commands exist (`--help`, `--explain`, `--version`, the summary table). Their output is for a human. + +### 4.1 Machine-readable output + +Everything an agent can observe is text or a Spectre table, and `Summary.render` elides cells to fit the +console width. Add `--format json` (name open) on every command: + +- **`--explain --format json`**: the resolved stage tree, step labels, skip reasons, producers. +- **The run result**: `PipelineContext.Reports` (`ScopeReports`) and `Timings` already hold everything; they + only need a serializer. Emit on stdout at the end of the run, or to a file named by `--report `, so it + does not interleave with step output. +- **`--schema`** (or a hidden `describe` command): the command tree with every option's name, aliases, type, + default, choices and description. System.CommandLine has this information; it is only rendered as help. + +### 4.2 Exit codes + +Today a parse/validation error and a stage failure both exit 1 (`Command.fs:93-110`). Proposed: `0` success, +`1` stage failure, `2` usage/validation error, `130` cancelled. An agent can then tell "I called it wrong" from +"the build is broken" without parsing stderr. + +### 4.3 `--explain` without side effects + +Rendering evaluates every `IsActive`: `whenBranch` starts `git`, and `whenStage` runs its condition stage — +twice, per the handoff's deferred findings. There is also no exception guard. Proposed: a static mode (default +under `--format json`) that reports a structured condition as `unevaluated: whenBranch "main"` instead of +running it, and a guard that renders a failed condition as its exception message. + +### 4.4 XML ``s + +There are none in `src` (Task 15's audit was never done). Priority targets: the `run` overloads, `input { }`, +`whenSome`, `Cmd.argWhenSome`/`argIf`, `stage`/`pipeline`/`command`. These are what an agent hovers or greps. + +### 4.5 Point agents at what exists + +Neither Xantham's `AGENTS.md` nor its `.claude/rules` mention `--help` or `--explain`, and Xantham gives no +command a `description`. + +- Ship an agent snippet with the package (a `SKILL.md` or an `AGENTS.md` block under `docs/static/`, linked from + `llms.txt`): "run ` --explain` before invoking; `--help` is generated from the stages and is + authoritative". +- Promote the undescribed-command list printed under `--explain` to a warning on every run, or at least under + `--ci`. +- Check whether `llms-full.txt` survived the move from fsdocs to Nacara; it is not in `docs/static`. + +## 5. SageFs integration + +SageFs (https://github.com/WillEhrendreich/SageFs) is a long-running F# Interactive daemon: one worker process +per session holding a warm `FsiEvaluationSession` over a loaded project, with hot reload, live testing and an +MCP server. Agents evaluate code through `send_fsharp_code`. It has **no plugin mechanism** — its MCP tools are +fixed — so the integration surface is F# code evaluated in a session, plus the per-session startup script +`.SageFs/init.fsx` (or `.SageFsrc`), run at the end of warm-up. + +The payoff is large for fsi-script consumers: a full Xantham build today cold-compiles five `dotnet fsi` +processes (`build.fsx` plus four `run "dotnet fsi tools/… -- …"` steps), each with its own NuGet resolution. +A warm session pays that once. + +### 5.1 Host behaviour that matters + +From SageFs's source (`SageFs.Core/AppState.fs`, `Features/LiveTestingExecutors.fs`, `docs/`): + +- **stdout**: each eval swaps `Console.Out` for a `StringWriter`, restores it afterwards, and strips all ANSI + sequences from what it captured. +- **Cancellation**: `cancel_eval` calls `Thread.Interrupt()` on the eval thread. No `CancellationToken` is + signalled. A thread blocked in `Async.RunSynchronously` receives `ThreadInterruptedException`. +- **Statics** live for the life of the worker; only `hard_reset_fsi_session` resets them. There is no + `[]` and no meaningful argv. +- **Live testing** discovers Expecto tests, with a 5 s default per-test timeout; a timed-out test reports as + Skipped. + +### 5.2 What breaks in Partas.Build today + +| Hazard | Where | Effect in a warm session | +|---|---|---| +| `rootCommandOfScript` is a module-level value calling `Args.script ()` | `Command.fs:599` | argv read once at module initialisation, and it is the host's argv | +| `Console.InputEncoding`/`OutputEncoding` set on every run | `Conductors.Runners.fs:629-630` | process-global mutation per eval; setting `InputEncoding` can throw without an attached console on Windows | +| Spectre `AnsiConsole` global | `Conductors.fs:396,504,534-549` | **unverified**: the singleton may bind to the `Console.Out` current at first use, i.e. the first eval's `StringWriter`, and write into a dead writer thereafter. Spike before designing around it. | +| Environment snapshot in `PipelineContext.create` | `Conductors.fs:420` | a pipeline value bound at load time keeps the environment as it was then | +| Mutable `Timings`/`Reports`/`Producers` on the pipeline value, cleared per run | `Conductors.Runners.fs:631-635` | two concurrent runs of the same value race | +| Cancellation only through `CancellationToken` | `Process.fs` (`CmdRunner`) | `cancel_eval`'s `Thread.Interrupt` reaches no token: child process trees are orphaned | +| No structured result from the public API | `RootCommandBuilder.Run` returns `int` | an agent in the session gets an exit code and scraped, ANSI-stripped text | + +### 5.3 Proposed changes + +1. **`Command.invoke`**: an argv-free entry point for hosts. + + ```fsharp + type RunResult = { ExitCode: int; Reports: ScopeReports; Timings: StageTiming list } + Command.invoke : args: string list -> ?output: TextWriter -> ?cancellationToken: CancellationToken + -> RootCommandBuilder/CommandSpec -> RunResult + ``` + + It parses `args`, runs, and returns the structured result that §4.1 serializes. `RootCommandBuilder.Run` + becomes `invoke` plus `ExitCode`. + +2. **`rootCommandOfScript` stops capturing argv at module initialisation**: a function, or a builder whose + `Run` reads `Args.script ()` when invoked. + +3. **Console hygiene**: set the encodings only when output is not redirected and only once per process; build + the Spectre console per run from the current `Console.Out` (or the `output` passed to `invoke`), if §5.2's + spike confirms the singleton problem. + +4. **Bridge `Thread.Interrupt` to cancellation**: `invoke` runs the pipeline on a worker and waits; if the + waiting thread receives `ThreadInterruptedException`, it cancels the run's `CancellationTokenSource`, which + reuses the existing process-tree kill (registration-based, per CLAUDE.md), then rethrows. Test: interrupt a + thread running a `sleep` stage and assert no surviving process, mirroring the existing `cmd` test. + +5. **Environment read at run time**: `PipelineContext.run` refreshes the ambient environment it starts from, + keeping the pipeline's own `envVars` on top. + +6. **A reentrancy guard**: a run of a pipeline value already running either fails fast or runs against a copy + of the mutable collections. + +### 5.4 Consumer-side pattern (docs, not library code) + +Document the shape for an fsi-script build that is SageFs-friendly: + +- Split `build.fsx` into `build.defs.fsx` (options, stages, the `rootCommand` value, no side effects) and a + thin `build.fsx` that `#load`s it and calls `exit (… )`. +- `.SageFs/init.fsx` `#load`s `build.defs.fsx` and binds `let build args = Command.invoke args Build.root`. + An agent then calls `build ["test"; "--quick"]` through `send_fsharp_code` and reads a `RunResult`. +- Mount other scripts' commands by `#load` + `addCommand` instead of `run "dotnet fsi …"` (the W1 answer in + `PLAN-Discoverability.md` §2 already says this works). +- Tag this repo's process-spawning tests (the `cmd` suite, `CompilerProbe`) so SageFs live testing classifies + them as Integration rather than timing them out at 5 s. + +### 5.5 Out of scope + +A SageFs plugin or MCP tool of our own: SageFs composes its providers statically and has no runtime extension +point. If that changes, `--schema` (§4.1) and `Command.invoke` (§5.3) are the pieces such a tool would wrap. + +## 6. Findings in consumers (not this repo's to fix) + +Recorded so they are not lost; each belongs to its own repository. + +**Xantham** + +- **Tool scripts swallow failures.** `tools/generate-wire.fsx:308` and `tools/xantham-fixtures.fsx:186` end in + a bare `rootCommand … { }` with no `exit (…)`, so the exit code is discarded and `build.fsx`'s + `run "dotnet fsi tools/…"` steps succeed when the tool failed. Verified in source. +- **`publish` leaks the NuGet key** (`build.fsx:555-567`): plain `run $"… -k {apiKey.Value} …"` under + `when' apiKey.IsSome`; should be `whenSome` + `runSensitive` (or §3.1's `nugetPush`). `failIfIgnored` fires + only after restore → pack have run. +- **Version drift**: 0.4.0-alpha.3 / 0.3.0 against 0.6.5. +- `build.fsx:354-361` runs `powershell Move-Item/Remove-Item`; not portable to Linux CI. +- `build.fsx:232-236` has two equivalent branches, one evaluating `projects[0]` at construction time. +- `.github/workflows/push_master.yml` path filters exclude `*.fsx` and `build.fsx`: CI never runs on a build + change. `docs.yml` builds Release, then runs `build.fsx -- docs`, which cleans and rebuilds. +- A non-quick run always runs `format` (`dotnet fantomas .`), rewriting the working tree — hostile to an agent + that runs `test` to check its work. Separate `--no-format` from `--quick`. + +**This repo, outside the library** + +- `.mcp.json` points `fslangmcp` at `Partas.Testing.slnx`; the solution is `Partas.Build.slnx`. +- `Build/Program.fs:38-41` declares `formatFiles` and never uses it. +- `Program.fs:197,201` uses `Cmd.ofString $"""… {if ci then "--summary" else null} …"""`; `Cmd.argIf` is the + intended form. +- `PLAN-Execution.md`'s header still reads "implementation not started". + +## 7. Order of work + +| # | Item | Axis | Size | +|---|---|---|---| +| 1 | `.mcp.json`, `printfn` in Baked, `Cmd.argIf` in `Program.fs` | hygiene | trivial | +| 2 | Task 14b: no consumer needs `Internal` | usability | medium | +| 3 | `run (fun _ -> string)` rename/obsolete; `desc`/`input` duplicates | usability | small | +| 4 | Exit codes (§4.2) | discoverability | small | +| 5 | `Command.invoke` + `RunResult` (§5.3.1) | SageFs, discoverability | medium | +| 6 | JSON for `--explain`, the run result, `--schema` (§4.1) — serializes 5's result | discoverability | medium | +| 7 | Console hygiene, argv capture, env at run time (§5.3.2-5.3.5) — after the Spectre spike | SageFs | medium | +| 8 | Thread-interrupt bridge + no-orphan test (§5.3.4) | SageFs | medium | +| 9 | Baked prefab stages (§3.1), `Build/Program.fs` rewritten on them as the acceptance test | usability | large | +| 10 | Side-effect-free `--explain` (§4.3) | discoverability | medium | +| 11 | XML ``s, agent snippet, consumer pattern docs (§4.4, §4.5, §5.4) | discoverability | medium | + +`Build/Program.fs` stays the acceptance test, as in `PLAN.md`: items 2, 3 and 9 are done when it compiles +without `open Partas.Build.Internal` and without the hand-rolled rows of §2's first table. + +## 8. Open questions + +1. JSON flag naming: `--format json` on every command, or `--json`? Does it collide with a consumer's own option + (System.CommandLine rejects duplicate aliases at construction)? +2. Should §4.1's run result go to stdout or only to `--report `? Stdout is simpler for agents but mixes with + step output that is not captured. +3. Prefab stages as functions or records (§3.1, W12). +4. Does `Command.invoke` take the `RootCommandBuilder` result, the `CommandSpec`, or both — and does it live in + `Partas.Build` or a separate `Partas.Build.Hosting` namespace? +5. Is the Spectre singleton hazard (§5.2) real? Spike: create `AnsiConsole` under one `Console.SetOut`, swap, + write again, and see where the text lands. From 6c55e98909d16e26b204ceb30b704fc7593c734c Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 10:43:57 +0000 Subject: [PATCH 02/25] Add exit code categories and an argv-free Command.invoke returning RunResult MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements PLAN-Integration §4.2 and §5.3.1. - Exit codes: 0 success (help, --version, --explain), 1 stage failure, 2 usage error (parse error, missing subcommand, failed dependency validation), 130 cancelled; named by the ExitCode module. - Command.root { ... } builds a RootCommandDefinition without parsing or running; Command.invoke args / RootCommandDefinition.Invoke(args, ?output, ?error, ?cancellationToken) parse, run and return a RunResult (ExitCode, RunOutcome, a PipelineRun per pipeline with its ScopeReport and StageTiming snapshots). rootCommand's Run goes through Invoke, so the exit-code mapping lives in one place. - PipelineContext.runWith links an external cancellation token into the pipeline's timeout source; run is runWith CancellationToken.None. - --explain, the timing summary, the grouping --explain and the dependency diagnostic write to the invocation configuration's Output/Error instead of Console. - Records the §8 Q4 decision and section statuses in PLAN-Integration. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 22 ++- docs/content/Build/composition.fsx | 1 + .../computation-expression-operations.fsx | 1 + docs/content/Build/index.fsx | 31 ++++ .../external-annotations-api.fsx | 1 + docs/content/index.fsx | 31 ++++ notes/PLAN-Integration.md | 33 +++- src/Partas.Build/Builders/Command.fs | 174 +++++++++++++++--- src/Partas.Build/Conductors.Runners.fs | 27 ++- src/Partas.Build/Explain.fs | 2 +- src/Partas.Build/Partas.Build.fsproj | 1 + src/Partas.Build/RunResult.fs | 74 ++++++++ tests/Partas.Build.Tests/CommandTests.fs | 158 ++++++++++++++++ tests/Partas.Build.Tests/DependencyTests.fs | 2 +- tests/Partas.Build.Tests/ParallelismTests.fs | 2 +- 15 files changed, 519 insertions(+), 41 deletions(-) create mode 100644 src/Partas.Build/RunResult.fs diff --git a/CLAUDE.md b/CLAUDE.md index 1819b06..4820515 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -38,7 +38,7 @@ Fast inner loop while working on the library only: `dotnet build src/Partas.Buil ## Current state (verify before assuming) -- Phases 0-7 of `notes/PLAN.md` are done: `dotnet build src/Partas.Build` is clean and `dotnet run --project Build.fsproj -- test` is green (433 Expecto tests across four suites — 291 in `tests/Partas.Build.Tests`, one file per layer, plus 65 in `tests/Partas.Build.ExternalAnnotations.Tests`, 74 in `tests/Partas.ExternalAnnotations.Tests` and 3 in `tests/Partas.Build.Cmd.NetStandard.Tests`; the `test` stage also runs `tests/Partas.Build.CompilerProbe` in both Debug and Release, 11 tests each). The `Build/` CLI is written against the library: a breaking change breaks it first. +- Phases 0-7 of `notes/PLAN.md` are done: `dotnet build src/Partas.Build` is clean and `dotnet run --project Build.fsproj -- test` is green (443 Expecto tests across four suites — 301 in `tests/Partas.Build.Tests`, one file per layer, plus 65 in `tests/Partas.Build.ExternalAnnotations.Tests`, 74 in `tests/Partas.ExternalAnnotations.Tests` and 3 in `tests/Partas.Build.Cmd.NetStandard.Tests`; the `test` stage also runs `tests/Partas.Build.CompilerProbe` in both Debug and Release, 11 tests each). The `Build/` CLI is written against the library: a breaking change breaks it first. - The DSL exists end to end: `inputs` (`Builders/Inputs.fs`), `stage` (`Builders/Stage.fs`), `pipeline` (`Builders/Pipeline.fs`), `command`/`rootCommand` (`Builders/Command.fs`). A stage that declares an input turns its pipeline into an `InputSpec`, and the command registers whatever those specs declare. Conditions are in `Builders/Conditions.fs` — `whenAll`/`whenAny`/`whenNot`/`whenEnv`/`whenStage` plus the `when'`/`whenEnvVar`/`whenBranch`/`when{Windows,Linux,OSX}` operations on `StageBuilder`. - A command carries `PipelineDefaults: BuildPipeline` and takes the pipeline-level operations itself (`workingDir`, `envVars`, the three timeouts, `acceptExitCodes`, the output operations, `noPrefixForStep`/`noStdRedirectForStep`, `runBeforeEachStage`/`runAfterEachStage`, `post`, `verbosity`/`verbose`/`quiet`), each one built through `CommandBuilderBase.MapPipelineDefault`. They are **defaults, not overrides**: `PipelineContext.applyDefaults` copies a setting across only where the pipeline left it at the value `PipelineContext.create` gave it, so a pipeline that sets the same thing wins. See *Command defaults* below. - `run`/`runSensitive` start real processes through `CmdRunner` (`Process.fs`). A `Cmd`, defined in `src/Partas.Build.Cmd/Program.fs`, keeps the executable and its arguments apart all the way to `ProcessStartInfo.ArgumentList`, so the platform does the escaping. Interpolate through the `cmd` helper — `run (cmd $"dotnet build {project}")`. `run $"..."` binds to the `string` overload and flattens the holes; `runSensitive $"..."` takes the `FormattableString` directly and masks every hole as `***`. There is no `Fake.Core.Process` dependency; `notes/PLAN.md`'s *The command runner* records why. @@ -47,7 +47,7 @@ Fast inner loop while working on the library only: `dotnet build src/Partas.Buil ## Architecture notes -Compile order in `Partas.Build.fsproj` matters (F#): `System.CommandLine/Aliases.fs` → `System.CommandLine/Inputs.fs` → `Exceptions.fs` → `Output.fs` → `Environment.fs` → `Timing.fs` → `Producer.fs` → `Failures.fs` → `Conductors.fs` → `Conductors.Runners.fs` → `Process.fs` → `Operations.fs` → `Dependencies.fs` → `DependencyPlan.fs` → `ExecutionState.fs` → `Builders/StageSettings.fs` → `Builders/Stage.fs` → `Builders/Conditions.fs` → `Builders/PipelineSettings.fs` → `Builders/Pipeline.fs` → `Builders/Inputs.fs` → `Explain.fs` → `Summary.fs` → `Builders/Command.fs`. The batteries-included layer is its own project, `src/Partas.Build.Baked`. +Compile order in `Partas.Build.fsproj` matters (F#): `System.CommandLine/Aliases.fs` → `System.CommandLine/Inputs.fs` → `Exceptions.fs` → `Output.fs` → `Environment.fs` → `Timing.fs` → `Producer.fs` → `Failures.fs` → `Conductors.fs` → `Conductors.Runners.fs` → `Process.fs` → `Operations.fs` → `Dependencies.fs` → `DependencyPlan.fs` → `ExecutionState.fs` → `Builders/StageSettings.fs` → `Builders/Stage.fs` → `Builders/Conditions.fs` → `Builders/PipelineSettings.fs` → `Builders/Pipeline.fs` → `Builders/Inputs.fs` → `Explain.fs` → `Summary.fs` → `RunResult.fs` → `Builders/Command.fs`. The batteries-included layer is its own project, `src/Partas.Build.Baked`. `Explain.fs` renders the resolved stage tree `--explain` prints, as text only, independent of the console and any stage sink — a stage that silences or captures its output is still described in full. It compiles before @@ -123,6 +123,24 @@ line already carries. `Summary.render` sizes its three columns to the ambient co fit — the middle of a stage name, the end of an outcome — so the table is one row per stage at any width, and the `Depth` indent survives an 80-column CI log. +`RunResult.fs` holds what a command invocation answers, and the exit codes it ends with: `ExitCode.Success` +(0 — help, `--version` and `--explain` included), `Failure` (1, a stage failed), `UsageError` (2 — a parse +error, a missing subcommand, a failed `DependencyPlan.validate`) and `Cancelled` (130). `RunResult` carries the +code, its `RunOutcome`, and a `PipelineRun` per pipeline started — its `ScopeReports.stages` and ordered +`StageTimings`, snapshotted in `runReportingTimings`'s `finally` so a later run of the same pipeline value +leaves an earlier result intact. `Command.root { … }` builds a `RootCommandDefinition` (the `rootCommand` +operations, via the shared `RootCommandBuilderBase.Define`) without parsing or running; `Command.invoke args` +and `RootCommandDefinition.Invoke(args, ?output, ?error, ?cancellationToken)` parse and run it, and +`RootCommandBuilder.Run` is `Define` + `Invoke` + `.ExitCode`, so the exit-code mapping lives in `Invoke` alone: +a parse result whose `Action` is System.CommandLine's `ParseErrorAction` becomes 2 there, whatever the action +returned. The command action finds its invocation's state — the cancellation token and the `PipelineRun` +collector — in a `ConditionalWeakTable` keyed by the `ParseResult`; a parse result invoked directly through +System.CommandLine has none, runs uncancellable, and still gets 2 for a failed dependency validation (the +action returns it) but 1 for a parse error (System.CommandLine's own). The token reaches the engine through +`PipelineContext.runWith`, which links it into the pipeline's own timeout source. `output` replaces the +invocation configuration's `Output`/`Error`, which is where help, parse errors, `--explain`, the timing summary +and the dependency diagnostic go; stage output still goes to Spectre's ambient console. + `src/Partas.Build.Cmd` (`Program.fs`, `Execution.fs`) is the process layer, defining `Cmd` and compiling before `Partas.Build`. `src/Partas.Build.Baked` is the batteries-included layer over the library: ready-made `Input.*`/`Argument.*` definitions diff --git a/docs/content/Build/composition.fsx b/docs/content/Build/composition.fsx index d524bf6..384fa41 100644 --- a/docs/content/Build/composition.fsx +++ b/docs/content/Build/composition.fsx @@ -44,6 +44,7 @@ order: 3 #load "../../../src/Partas.Build/Builders/Inputs.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" +#load "../../../src/Partas.Build/RunResult.fs" #load "../../../src/Partas.Build/Builders/Command.fs" #load "../../../src/Partas.Build.Baked/Program.fs" #load "../../../src/Partas.Build.Baked/Common.fs" diff --git a/docs/content/Build/computation-expression-operations.fsx b/docs/content/Build/computation-expression-operations.fsx index 1f70598..84ac893 100644 --- a/docs/content/Build/computation-expression-operations.fsx +++ b/docs/content/Build/computation-expression-operations.fsx @@ -43,6 +43,7 @@ order: 4 #load "../../../src/Partas.Build/Builders/Inputs.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" +#load "../../../src/Partas.Build/RunResult.fs" #load "../../../src/Partas.Build/Builders/Command.fs" #load "../../../src/Partas.Build.Baked/Program.fs" #load "../../../src/Partas.Build.Baked/Common.fs" diff --git a/docs/content/Build/index.fsx b/docs/content/Build/index.fsx index 9a47f1d..b8cd001 100644 --- a/docs/content/Build/index.fsx +++ b/docs/content/Build/index.fsx @@ -42,6 +42,7 @@ order: 0 #load "../../../src/Partas.Build/Builders/Inputs.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" +#load "../../../src/Partas.Build/RunResult.fs" #load "../../../src/Partas.Build/Builders/Command.fs" #load "../../../src/Partas.Build.Baked/Program.fs" #load "../../../src/Partas.Build.Baked/Common.fs" @@ -72,6 +73,7 @@ automatic validation and help. | Pipeline | `pipeline "name" { }` | `PipelineContext` or `InputSpec` | | Command | `command "name" { }` | `System.CommandLine.Command` | | Root | `rootCommand argv { }` | `int` exit code — **it runs immediately** | +| Hosted root | `Command.root { }` | `RootCommandDefinition` — runs on each `Command.invoke args` | ## A first pipeline *) @@ -278,6 +280,35 @@ let main argv = A command with no pipelines is a grouping node: it gets no action, so System.CommandLine reports the missing subcommand and prints help instead of succeeding silently. +The exit code tells a mistaken invocation from a broken build: `0` success (help, `--version` and `--explain` +included), `1` a stage failed, `2` the command line did not parse or validate — an unknown option, a missing +subcommand, a producer arrangement dependency validation rejects — and `130` the run was cancelled. The +`ExitCode` module names the four. + +### Invoking from a host + +`rootCommand` reads its arguments once and runs at construction. A long-lived host — an F# interactive +session, a test — builds the root once with `Command.root`, which takes every `rootCommand` operation and runs +nothing, then invokes it as often as it likes. `Command.invoke` answers a `RunResult`: the exit code, its +`RunOutcome`, and each pipeline run's `ScopeReport`s and `StageTiming`s. +*) + +let root = + Command.root { + description "My build" + addCommands [ buildCommand ] + } + +let buildQuick () = + let result = root |> Command.invoke [ "build"; "--quick"; "true" ] + printfn "%d failure(s)" result.Failures.Length + result.ExitCode + +(** +`root.Invoke(args, output = writer, cancellationToken = token)` sends help, `--explain`, the timing summary and +parse errors to `writer` instead of the console, and cancels the running pipeline — its processes with it — +when `token` fires. + ## Composition ### Stages nest diff --git a/docs/content/external-annotations/external-annotations-api.fsx b/docs/content/external-annotations/external-annotations-api.fsx index a5557cb..be3ab1d 100644 --- a/docs/content/external-annotations/external-annotations-api.fsx +++ b/docs/content/external-annotations/external-annotations-api.fsx @@ -42,6 +42,7 @@ index: 2 #load "../../../src/Partas.Build/Builders/Inputs.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" +#load "../../../src/Partas.Build/RunResult.fs" #load "../../../src/Partas.Build/Builders/Command.fs" #load "../../../src/Partas.Build.Baked/Program.fs" #load "../../../src/Partas.Build.Baked/Common.fs" diff --git a/docs/content/index.fsx b/docs/content/index.fsx index bcb2fe3..517e01f 100644 --- a/docs/content/index.fsx +++ b/docs/content/index.fsx @@ -41,6 +41,7 @@ order: 0 #load "../../src/Partas.Build/Builders/Inputs.fs" #load "../../src/Partas.Build/Explain.fs" #load "../../src/Partas.Build/Summary.fs" +#load "../../src/Partas.Build/RunResult.fs" #load "../../src/Partas.Build/Builders/Command.fs" #load "../../src/Partas.Build.Baked/Program.fs" #load "../../src/Partas.Build.Baked/Common.fs" @@ -73,6 +74,7 @@ automatic validation and help. | Pipeline | `pipeline "name" { }` | `PipelineContext` or `InputSpec` | | Command | `command "name" { }` | `System.CommandLine.Command` | | Root | `rootCommand argv { }` | `int` exit code — **it runs immediately** | +| Hosted root | `Command.root { }` | `RootCommandDefinition` — runs on each `Command.invoke args` | ## A first pipeline *) @@ -279,6 +281,35 @@ let main argv = A command with no pipelines is a grouping node: it gets no action, so System.CommandLine reports the missing subcommand and prints help instead of succeeding silently. +The exit code tells a mistaken invocation from a broken build: `0` success (help, `--version` and `--explain` +included), `1` a stage failed, `2` the command line did not parse or validate — an unknown option, a missing +subcommand, a producer arrangement dependency validation rejects — and `130` the run was cancelled. The +`ExitCode` module names the four. + +### Invoking from a host + +`rootCommand` reads its arguments once and runs at construction. A long-lived host — an F# interactive +session, a test — builds the root once with `Command.root`, which takes every `rootCommand` operation and runs +nothing, then invokes it as often as it likes. `Command.invoke` answers a `RunResult`: the exit code, its +`RunOutcome`, and each pipeline run's `ScopeReport`s and `StageTiming`s. +*) + +let root = + Command.root { + description "My build" + addCommands [ buildCommand ] + } + +let buildQuick () = + let result = root |> Command.invoke [ "build"; "--quick"; "true" ] + printfn "%d failure(s)" result.Failures.Length + result.ExitCode + +(** +`root.Invoke(args, output = writer, cancellationToken = token)` sends help, `--explain`, the timing summary and +parse errors to `writer` instead of the console, and cancels the running pipeline — its processes with it — +when `token` fires. + ## Composition ### Stages nest diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index d27e52e..2212274 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -1,7 +1,7 @@ # PLAN-Integration Findings from a survey of how Partas.Build is used in practice, and the design that follows. Drafted -2026-09-24. **Status: proposal — nothing here is implemented.** +2026-09-24. **Status: proposal, partly implemented — see the status line under each section.** Companion to `PLAN-Discoverability.md`, which responded to `FEEDBACK-Xantham.md` (a report written against 0.3.0). This document starts from the consumers' *code* instead of a written report, and adds a third axis the @@ -131,6 +131,13 @@ Today a parse/validation error and a stage failure both exit 1 (`Command.fs:93-1 `1` stage failure, `2` usage/validation error, `130` cancelled. An agent can then tell "I called it wrong" from "the build is broken" without parsing stderr. +**Status: implemented on claude/partas-build-patterns-jgrwr0-int-core.** `ExitCode.Success`/`Failure`/`UsageError`/`Cancelled` in `RunResult.fs`. +Usage errors are a System.CommandLine parse error (unknown option, missing subcommand, failed validator) and a +failed `DependencyPlan.validate`. The parse-error mapping lives in `RootCommandDefinition.Invoke`, the one path +`rootCommand` and `Command.invoke` share; a subcommand invoked straight through System.CommandLine +(`cmd.Parse(…).Invoke()`, as many tests do) still exits 1 on a parse error, since System.CommandLine's own +`ParseErrorAction` answers it — but 2 on a failed dependency validation, which the command action returns. + ### 4.3 `--explain` without side effects Rendering evaluates every `IsActive`: `whenBranch` starts `git`, and `whenStage` runs its condition stage — @@ -205,6 +212,25 @@ From SageFs's source (`SageFs.Core/AppState.fs`, `Features/LiveTestingExecutors. It parses `args`, runs, and returns the structured result that §4.1 serializes. `RootCommandBuilder.Run` becomes `invoke` plus `ExitCode`. + **Status: implemented on claude/partas-build-patterns-jgrwr0-int-core.** Deviations from the sketch above: + + - `invoke` takes a `RootCommandDefinition`, built by `Command.root { … }` — `rootCommand`'s operations, no + argv, nothing parsed or run at construction (§8 Q4). `Command.invoke : string seq -> RootCommandDefinition + -> RunResult` is the common case; the optional parameters live on the method + `RootCommandDefinition.Invoke(args, ?output, ?error, ?cancellationToken)`, since a let-bound function takes + none. `RootCommandBuilder.Run` is `Define` + `Invoke` + `.ExitCode`. + - `RunResult = { ExitCode; Outcome: RunOutcome; Pipelines: PipelineRun list }`, with `Reports`/`Timings`/ + `Failures` members flattening across pipelines. A command runs several pipelines, and `ScopeReports`/ + `StageTimings` are the mutable per-pipeline collectors a second run clears, so each `PipelineRun` holds an + immutable snapshot (`ScopeReport list`, pre-ordered `StageTiming list`) taken as the pipeline finishes. + - `output` reaches what goes through System.CommandLine's `InvocationConfiguration` — help, `--version`, + parse errors — plus `--explain`, the timing summary and the dependency diagnostic, which now write there + too. Stage output still goes to Spectre's ambient console: rerouting it is §5.3.3's. + - `cancellationToken` reaches the engine through the new `PipelineContext.runWith`, which links it into the + pipeline's own timeout source; a cancelled invocation exits 130 and starts no further pipeline. The + `Thread.Interrupt` bridge (§5.3.4) is the seam left: it needs only to cancel a source whose token it passes + to `Invoke`. + 2. **`rootCommandOfScript` stops capturing argv at module initialisation**: a function, or a builder whose `Run` reads `Args.script ()` when invoked. @@ -297,5 +323,10 @@ without `open Partas.Build.Internal` and without the hand-rolled rows of §2's f 3. Prefab stages as functions or records (§3.1, W12). 4. Does `Command.invoke` take the `RootCommandBuilder` result, the `CommandSpec`, or both — and does it live in `Partas.Build` or a separate `Partas.Build.Hosting` namespace? + **Decided:** neither. `rootCommand args { … }` runs at construction and `CommandSpec` lives in `Internal`, so + `invoke` takes a third value, the `RootCommandDefinition` that `Command.root { … }` builds. It lives in + `Partas.Build` (the `CommandBuilder` auto-open module, beside `Command.pipeline`), with `RunResult`, + `RunOutcome`, `PipelineRun` and `ExitCode` in `Partas.Build` too: one entry point does not warrant a + namespace, and none of it needs `open Partas.Build.Internal`. 5. Is the Spectre singleton hazard (§5.2) real? Spike: create `AnsiConsole` under one `Console.SetOut`, swap, write again, and see where the text lands. diff --git a/src/Partas.Build/Builders/Command.fs b/src/Partas.Build/Builders/Command.fs index a42d2fa..019670b 100644 --- a/src/Partas.Build/Builders/Command.fs +++ b/src/Partas.Build/Builders/Command.fs @@ -6,6 +6,8 @@ open System.IO open System.CommandLine open System.CommandLine.Help open System.CommandLine.Invocation +open System.Runtime.CompilerServices +open System.Threading open Partas.Build open Partas.Build.Internal @@ -64,53 +66,80 @@ let private register (command: Command) (input: ActionInput) = /// Prints the tree the command's pipelines resolve to under , then the invocation /// paths still missing a description. Materialising a pipeline runs its stage builders, never its steps. -let private explain (command: Command) (pipelines: PipelineContext list) = +let private explain (output: TextWriter) (command: Command) (pipelines: PipelineContext list) = pipelines |> Explain.ofPipelines command - |> Console.Out.WriteLine + |> output.WriteLine - 0 + ExitCode.Success + +/// The state an invocation through RootCommandDefinition.Invoke shares with the command action it reaches. +[] +type private InvocationState(cancellationToken: CancellationToken) = + let pipelines = ResizeArray() + member _.CancellationToken = cancellationToken + member _.Record(run: PipelineRun) = lock pipelines (fun () -> pipelines.Add run) + member _.Pipelines = lock pipelines (fun () -> List.ofSeq pipelines) + +/// The invocation state of each parse result an invocation is running. A parse result invoked directly through +/// System.CommandLine has none, and runs uncancellable with its pipeline runs unrecorded. +let private invocations = ConditionalWeakTable() /// Runs and prints what each of its stages took. /// /// A run that failed prints the table too, with the stage that failed in it. A quiet pipeline prints none, and /// so does a run of a single stage, whose wall time is the pipeline's own. /// -let private runReportingTimings (pipeline: PipelineContext) = +let private runReportingTimings (output: TextWriter) (state: InvocationState voption) (pipeline: PipelineContext) = + let cancellationToken = state |> ValueOption.map _.CancellationToken |> ValueOption.defaultValue CancellationToken.None try - PipelineContext.run pipeline + PipelineContext.runWith cancellationToken pipeline finally + let timings = StageTimings.ordered pipeline.Timings + state |> ValueOption.iter (fun state -> + state.Record { Name = pipeline.Name; Reports = ScopeReports.stages pipeline.Reports; Timings = timings }) + let verbosity = defaultValueArg pipeline.Verbosity Verbosity.Default let timings = StageTimings.ordered pipeline.Timings match timings with | [] | [ _ ] -> () | _ when verbosity.IsQuiet -> () - | timings -> Summary.render timings |> Console.Out.WriteLine + | timings -> Summary.render timings |> output.WriteLine /// Reads each pipeline out of the parse result and runs it, in declaration order. Producer work is placed into /// the pipelines that run, after the whole invocation validates and never on the way to --explain. /// The runner has already reported the failure by the time it raises, so this only maps it to an exit code. let private invoke (command: Command) (spec: CommandSpec) (parseResult: ParseResult) = + let state = + match invocations.TryGetValue parseResult with + | true, state -> ValueSome state + | false, _ -> ValueNone + + let configuration = parseResult.InvocationConfiguration let pipelines = spec.Pipelines |> List.map (fun pipeline -> pipeline.Read parseResult) match DependencyPlan.validate pipelines with | Error message -> - Console.Error.WriteLine message - 1 - | Ok _ when Explain.option.GetValue parseResult -> explain command pipelines + configuration.Error.WriteLine message + ExitCode.UsageError + | Ok _ when Explain.option.GetValue parseResult -> explain configuration.Output command pipelines | Ok plan -> let scheduled = ExecutionSchedule.schedule parseResult plan pipelines let executed = ResizeArray() try try for pipeline in scheduled do - executed.Add pipeline - runReportingTimings pipeline - - 0 + match state with + | ValueSome state when state.CancellationToken.IsCancellationRequested -> + raise (PipelineCancelledException "Cancelled by the invocation") + | _ -> + executed.Add pipeline + runReportingTimings configuration.Output state pipeline + + ExitCode.Success with - | :? PipelineFailedException -> 1 - | :? PipelineCancelledException -> 130 + | :? PipelineFailedException -> ExitCode.Failure + | :? PipelineCancelledException -> ExitCode.Cancelled finally // Consolidate only pipelines that ran, respecting each pipeline's reporting destination. @@ -556,8 +585,78 @@ type CommandBuilder(name: string) = member this.Run(stages: CommandStages): Command = this.Run(addPipeline (pipelineOfCommandStages stages)) -/// Builds the root command and runs it against args, returning the process exit code. -type RootCommandBuilder(args: string array) = +/// A root command, built and ready to parse and run any number of argument lists. +/// +/// Built by Command.root { … }, which takes every operation rootCommand takes. Parsing and running +/// happen only in Invoke, never at construction, so the value can be bound once in a long-lived host +/// and invoked repeatedly. Invocations of one value run one at a time: a pipeline value holds the collectors of +/// its current run. +/// +[] +type RootCommandDefinition + internal (command: RootCommand, parserConfiguration: ParserConfiguration voption, invocationConfiguration: InvocationConfiguration voption) = + + /// The System.CommandLine command the definition parses against. + member _.Command = command + + /// Parses , runs what they select, and returns the structured result. + /// The arguments, without the executable or script name. + /// + /// Receives help, --version, --explain and the timing summary, and — unless + /// is given — parse and validation errors. Defaults to the + /// invocationConfiguration the root was built with, else the console. Stage output continues to + /// follow each stage's own output setting. + /// + /// Receives parse and validation errors. + /// + /// Cancels the running pipeline as its own timeout would, killing the process tree of any step + /// running, and prevents the remaining pipelines from starting. The result is then Cancelled. + /// + member _.Invoke(args: string seq, ?output: TextWriter, ?error: TextWriter, ?cancellationToken: CancellationToken): RunResult = + let args = Array.ofSeq args + + let parseResult = + match parserConfiguration with + | ValueSome config -> command.Parse(args, config) + | ValueNone -> command.Parse args + + let state = InvocationState(defaultArg cancellationToken CancellationToken.None) + invocations.Add(parseResult, state) + + let configuration = + match output, error with + | None, None -> invocationConfiguration + | _ -> + let configuration = InvocationConfiguration() + + invocationConfiguration + |> ValueOption.iter (fun given -> + configuration.EnableDefaultExceptionHandler <- given.EnableDefaultExceptionHandler + configuration.ProcessTerminationTimeout <- given.ProcessTerminationTimeout + configuration.Output <- given.Output + configuration.Error <- given.Error) + + output |> Option.iter (fun output -> configuration.Output <- output; configuration.Error <- output) + error |> Option.iter (fun error -> configuration.Error <- error) + ValueSome configuration + + let exitCode = + try + match configuration with + | ValueSome config -> parseResult.Invoke config + | ValueNone -> parseResult.Invoke() + finally + invocations.Remove parseResult |> ignore + + let exitCode = + match parseResult.Action with + | :? ParseErrorAction -> ExitCode.UsageError + | _ -> exitCode + + { ExitCode = exitCode; Outcome = RunOutcome.ofExitCode exitCode; Pipelines = state.Pipelines } + +/// The operations only a root command takes. +type RootCommandBuilderBase() = inherit CommandBuilderBase() /// Configures System.CommandLine's parser behavior. @@ -585,24 +684,31 @@ type RootCommandBuilder(args: string array) = ([] build: BuildCommand, name: string): BuildCommand = build >> fun cmd -> { cmd with DisplayName = ValueSome name } - member this.Run(stages: CommandStages): int = this.Run(addPipeline (pipelineOfCommandStages stages)) - - member _.Run(build: BuildCommand): int = + // Not `inline`: it applies the `BuildCommand` function (`FS1118` in Release). + member _.Define(build: BuildCommand): RootCommandDefinition = let spec = CommandSpec.create "" |> build - let root = applyTo (RootCommand()) spec + let root = RootCommand() + applyTo root spec |> ignore let displayName = spec.DisplayName |> ValueOption.orElse (Args.scriptName ()) displayName |> ValueOption.iter (nameHelpOutput root) nameVersionOutput root displayName + RootCommandDefinition(root, spec.ParserConfiguration, spec.InvocationConfiguration) - let parseResult = - match spec.ParserConfiguration with - | ValueSome config -> root.Parse(args, config) - | ValueNone -> root.Parse args +/// Builds a root command without running it; see RootCommandDefinition. +type RootCommandDefinitionBuilder() = + inherit RootCommandBuilderBase() - match spec.InvocationConfiguration with - | ValueSome config -> parseResult.Invoke config - | ValueNone -> parseResult.Invoke() + member this.Run(build: BuildCommand): RootCommandDefinition = this.Define build + member this.Run(stages: CommandStages): RootCommandDefinition = this.Define(addPipeline (pipelineOfCommandStages stages)) + +/// Builds the root command and runs it against args, returning the process exit code. +/// The exit code is ExitCode's: Command.root { … } with Command.invoke args is the same run returning the whole RunResult. +type RootCommandBuilder(args: string array) = + inherit RootCommandBuilderBase() + + member this.Run(build: BuildCommand): int = this.Define(build).Invoke(args).ExitCode + member this.Run(stages: CommandStages): int = this.Run(addPipeline (pipelineOfCommandStages stages)) module Command = /// @@ -610,6 +716,18 @@ module Command = /// let pipeline = PipelineBuilder(null) + /// + /// Builds a root command without parsing or running anything: rootCommand's operations, returning a + /// RootCommandDefinition for Command.invoke. + /// + let root = RootCommandDefinitionBuilder() + + /// + /// Parses against , runs what they select, and returns the + /// structured result. RootCommandDefinition.Invoke takes an output writer and a cancellation token. + /// + let invoke (args: string seq) (root: RootCommandDefinition) : RunResult = root.Invoke args + let inline command name = CommandBuilder name let inline rootCommand args = RootCommandBuilder args diff --git a/src/Partas.Build/Conductors.Runners.fs b/src/Partas.Build/Conductors.Runners.fs index f895341..35f9f7e 100644 --- a/src/Partas.Build/Conductors.Runners.fs +++ b/src/Partas.Build/Conductors.Runners.fs @@ -620,14 +620,17 @@ module PipelineContext = let runStages (ctx: PipelineContext) (cancelToken: CancellationToken) (stages: StageContext seq) = runStagesWithFailFast ctx false cancelToken stages - /// Runs every stage of and raises on failure or cancellation. + /// + /// Runs every stage of under , and raises on + /// failure or cancellation. + /// /// - /// Skips DependencyPlan.validate: the command path validates placement before this runs and never - /// reaches it for --explain, but a caller invoking this directly gets no such check, and an - /// arrangement DependencyPlan.validate would reject — a producer placed under a parallel' or - /// shuffleExecuteSequence scope, say — runs instead of failing at validation. + /// A cancellation of acts as the pipeline's own timeout does: the + /// stages observe a cancellation, a process started by a step is killed with its tree, and the run raises + /// . Skips DependencyPlan.validate, + /// as run does. /// - let rec run (this: PipelineContext) = + let runWith (cancellationToken: CancellationToken) (this: PipelineContext) = Console.InputEncoding <- Encoding.UTF8 Console.OutputEncoding <- Encoding.UTF8 StageTimings.clear this.Timings @@ -648,7 +651,8 @@ module PipelineContext = let sw = Stopwatch.StartNew() let pipelineExns = ResizeArray() - use cts = new CancellationTokenSource(timeoutForPipeline) + use cts = CancellationTokenSource.CreateLinkedTokenSource cancellationToken + cts.CancelAfter timeoutForPipeline let mutable hasErrors = false // Once per failed run, after every stage of it has reported to its own handlers. The failure the @@ -754,3 +758,12 @@ module PipelineContext = | failure :: _ -> raise (PipelineFailedException(message, FailureCause.toException failure.Cause)) | [] -> raise (PipelineFailedException message) + /// Runs every stage of and raises on failure or cancellation. + /// + /// Skips DependencyPlan.validate: the command path validates placement before this runs and never + /// reaches it for --explain, but a caller invoking this directly gets no such check, and an + /// arrangement DependencyPlan.validate would reject — a producer placed under a parallel' or + /// shuffleExecuteSequence scope, say — runs instead of failing at validation. + /// + let run (this: PipelineContext) = runWith CancellationToken.None this + diff --git a/src/Partas.Build/Explain.fs b/src/Partas.Build/Explain.fs index fe8852c..a32ac7b 100644 --- a/src/Partas.Build/Explain.fs +++ b/src/Partas.Build/Explain.fs @@ -184,5 +184,5 @@ module Explain = option.Action <- { new SynchronousCommandLineAction() with member _.Invoke(parseResult: ParseResult) = - Console.Out.WriteLine (ofSubcommands parseResult.CommandResult.Command) + parseResult.InvocationConfiguration.Output.WriteLine (ofSubcommands parseResult.CommandResult.Command) 0 }) diff --git a/src/Partas.Build/Partas.Build.fsproj b/src/Partas.Build/Partas.Build.fsproj index b9c2313..28fb40b 100644 --- a/src/Partas.Build/Partas.Build.fsproj +++ b/src/Partas.Build/Partas.Build.fsproj @@ -40,6 +40,7 @@ + diff --git a/src/Partas.Build/RunResult.fs b/src/Partas.Build/RunResult.fs new file mode 100644 index 0000000..24632c2 --- /dev/null +++ b/src/Partas.Build/RunResult.fs @@ -0,0 +1,74 @@ +namespace Partas.Build + +/// The process exit codes a command invocation ends with. +/// +/// UsageError covers every failure to parse or validate the command line, dependency validation included, +/// and guarantees no stage ran. +/// +[] +module ExitCode = + /// Every pipeline succeeded, or the invocation printed help, a version or an --explain tree. + [] + let Success = 0 + + /// A stage failed. + [] + let Failure = 1 + + /// The command line did not parse or validate, or the pipelines it selects failed dependency validation. + [] + let UsageError = 2 + + /// The run was cancelled, by a timeout of the pipeline or by the invocation's cancellation token. + [] + let Cancelled = 130 + +/// The category of an invocation's result; ExitCode carries the corresponding code. +[] +type RunOutcome = + /// Exit code 0. + | Succeeded + /// Exit code 1, or any code outside the categories below. + | Failed + /// Exit code 2. + | UsageError + /// Exit code 130. + | Cancelled + +module RunOutcome = + let ofExitCode (exitCode: int) = + match exitCode with + | ExitCode.Success -> RunOutcome.Succeeded + | ExitCode.UsageError -> RunOutcome.UsageError + | ExitCode.Cancelled -> RunOutcome.Cancelled + | _ -> RunOutcome.Failed + +/// A pipeline run by an invocation, as its scopes reported themselves. +type PipelineRun = { + Name: string + /// The scopes recorded at pipeline level, in the order they finished, each carrying its nested scopes. + Reports: ScopeReport list + /// Every stage the run finished, in pre-order. + Timings: StageTiming list +} + +/// The structured result of one command invocation. +/// +/// Pipelines holds the pipelines the invocation started, in the order they ran, including one that failed +/// or was cancelled. It is empty for an invocation that ran nothing: help, a version, --explain, or a +/// usage error. +/// +type RunResult = { + ExitCode: int + Outcome: RunOutcome + Pipelines: PipelineRun list +} with + + /// The pipeline-level reports of every pipeline run, in run order. + member this.Reports = this.Pipelines |> List.collect _.Reports + + /// The stage timings of every pipeline run, in run order. + member this.Timings = this.Pipelines |> List.collect _.Timings + + /// Every failure recorded by the run, absorbed failures among them, in pre-order. + member this.Failures = this.Reports |> List.collect ScopeReport.failures diff --git a/tests/Partas.Build.Tests/CommandTests.fs b/tests/Partas.Build.Tests/CommandTests.fs index c6de05d..399c5fc 100644 --- a/tests/Partas.Build.Tests/CommandTests.fs +++ b/tests/Partas.Build.Tests/CommandTests.fs @@ -424,3 +424,161 @@ let defaultsTests = Expect.equal described.Description "restore + build" "the command keeps its own description" } ] + +/// A root whose one pipeline records the configuration it ran with, and fails under --fail. +let private recordingRoot (seen: ResizeArray) = + let config = Input.option "--configuration" |> Input.def "Debug" + let fail = Input.option "--fail" |> Input.def false + + let compile = input { + let! cfg = config + and! fail = fail + return stage "compile" { + run (fun (_: StageContext) -> + seen.Add cfg + if fail then failwith "compile failed") + } + } + + Command.root { + pipeline "build" { + quiet + stage "restore" { run noop } + compile + } + } + +[] +let invocation = + testList "invocation" [ + test "a passing run exits zero and returns its reports and timings" { + let result = Helpers.quietly (fun () -> recordingRoot (ResizeArray()) |> Command.invoke [ "--configuration"; "Release" ]) + + Expect.equal result.ExitCode ExitCode.Success "a passing run exits zero" + Expect.equal result.Outcome RunOutcome.Succeeded "the outcome names the category" + Expect.equal [ for run in result.Pipelines -> run.Name ] [ "build" ] "the one pipeline that ran is recorded" + Expect.equal [ for timing in result.Timings -> timing.Name ] [ "restore"; "compile" ] "each stage has its timing" + Expect.equal [ for report in result.Reports -> report.Name, report.Outcome ] + [ "restore", StageOutcome.Succeeded; "compile", StageOutcome.Succeeded ] + "each stage has its report" + Expect.isEmpty result.Failures "a passing run records no failure" + } + + test "a failing run exits one and its reports carry the failure" { + let result = Helpers.quietly (fun () -> recordingRoot (ResizeArray()) |> Command.invoke [ "--fail"; "true" ]) + + Expect.equal result.ExitCode ExitCode.Failure "a stage failure exits one" + Expect.equal result.Outcome RunOutcome.Failed "the outcome names the category" + Expect.equal [ for timing in result.Timings -> timing.Name ] [ "restore"; "compile" ] "the failed stage is timed too" + + let compile = result.Reports |> List.find (fun report -> report.Name = "compile") + Expect.isTrue compile.Outcome.IsFailed "the failed stage reports itself failed" + Expect.isNonEmpty result.Failures "the failure is readable off the result" + } + + test "one definition invoked twice with different arguments runs each set once" { + let seen = ResizeArray() + let root = recordingRoot seen + + let first = Helpers.quietly (fun () -> root |> Command.invoke [ "--configuration"; "Release" ]) + let second = Helpers.quietly (fun () -> root |> Command.invoke [ "--configuration"; "Debug"; "--fail"; "true" ]) + + Expect.sequenceEqual seen [ "Release"; "Debug" ] "each invocation reads its own arguments" + Expect.equal first.ExitCode ExitCode.Success "the first invocation passes" + Expect.equal second.ExitCode ExitCode.Failure "the second invocation fails" + Expect.equal first.Timings.Length 2 "the first result keeps its own run" + Expect.equal second.Timings.Length 2 "the second result holds its own run, not the first one's too" + Expect.isEmpty first.Failures "a later failing run leaves an earlier result untouched" + } + + test "a parse error exits two and runs nothing" { + let seen = ResizeArray() + use output = new StringWriter() + let result = (recordingRoot seen).Invoke([ "--no-such-option" ], output = output) + + Expect.equal result.ExitCode ExitCode.UsageError "an unknown option is a usage error" + Expect.equal result.Outcome RunOutcome.UsageError "the outcome names the category" + Expect.isEmpty result.Pipelines "no pipeline ran" + Expect.isEmpty seen "no stage ran" + Expect.stringContains (output.ToString()) "--no-such-option" "the parse error reaches the given writer" + } + + test "a missing subcommand exits two" { + let root = Command.root { addCommand (command "build" { stage "one" { run noop } }) } + use output = new StringWriter() + + Expect.equal (root.Invoke([], output = output)).ExitCode ExitCode.UsageError "a grouping root without a subcommand is a usage error" + } + + test "rootCommand exits two on a parse error" { + use output = new StringWriter() + let exitCode = + rootCommand [| "--no-such-option" |] { + invocationConfiguration (InvocationConfiguration(Output = output, Error = output)) + stage "one" { run noop } + } + + Expect.equal exitCode ExitCode.UsageError "rootCommand shares the invocation's exit codes" + } + + test "a rejected dependency arrangement exits two" { + let source = Producer.define "compile" (InputSpec.ret ()) DependencySpec.empty (fun _ _ -> Operation.ret 42) + let root = Command.root { + pipeline "work" { + Stage.consuming "use" (DependencySpec.require source) (fun (_: int) -> Operation.ret ()) + Producer.stage source + } + } + use output = new StringWriter() + + let result = root.Invoke([], output = output) + Expect.equal result.ExitCode ExitCode.UsageError "dependency validation is a usage error" + Expect.isEmpty result.Pipelines "no pipeline ran" + Expect.isNonEmpty (output.ToString()) "the diagnostic reaches the given writer" + } + + test "a cancelled invocation exits 130" { + let root = Command.root { + pipeline "slow" { + quiet + stage "sleep" { run (fun (_: StageContext) -> async { do! Async.Sleep 30000 }) } + } + } + use cts = new Threading.CancellationTokenSource(TimeSpan.FromMilliseconds 300.) + let watch = Diagnostics.Stopwatch.StartNew() + + let result = Helpers.quietly (fun () -> root.Invoke([], cancellationToken = cts.Token)) + + Expect.equal result.ExitCode ExitCode.Cancelled "cancellation exits 130" + Expect.equal result.Outcome RunOutcome.Cancelled "the outcome names the category" + Expect.isLessThan watch.Elapsed (TimeSpan.FromSeconds 20.) "the token cut the sleeping stage short" + Expect.equal result.Pipelines.Length 1 "the cancelled pipeline is still recorded" + } + + test "an invocation already cancelled runs nothing" { + let seen = ResizeArray() + use cts = new Threading.CancellationTokenSource() + cts.Cancel() + + let result = (recordingRoot seen).Invoke([], cancellationToken = cts.Token) + + Expect.equal result.ExitCode ExitCode.Cancelled "a cancelled token exits 130" + Expect.isEmpty seen "no stage ran" + Expect.isEmpty result.Pipelines "no pipeline started" + } + + test "help and --explain write to the given output and exit zero" { + let root = recordingRoot (ResizeArray()) + use help = new StringWriter() + use explained = new StringWriter() + + let helpResult = root.Invoke([ "--help" ], output = help) + let explainResult = root.Invoke([ "--explain" ], output = explained) + + Expect.equal helpResult.ExitCode ExitCode.Success "help exits zero" + Expect.stringContains (help.ToString()) "--configuration" "help reaches the given writer" + Expect.equal explainResult.ExitCode ExitCode.Success "--explain exits zero" + Expect.stringContains (explained.ToString()) "compile" "the explained tree reaches the given writer" + Expect.isEmpty explainResult.Pipelines "--explain runs no pipeline" + } + ] diff --git a/tests/Partas.Build.Tests/DependencyTests.fs b/tests/Partas.Build.Tests/DependencyTests.fs index dfc322f..d8fc1ca 100644 --- a/tests/Partas.Build.Tests/DependencyTests.fs +++ b/tests/Partas.Build.Tests/DependencyTests.fs @@ -117,7 +117,7 @@ let tests = } } - Expect.equal (built.Parse("").Invoke()) 1 "validation fails invocation" + Expect.equal (built.Parse("").Invoke()) ExitCode.UsageError "validation fails invocation as a usage error" Expect.isFalse ran "even earlier work waits for whole-plan validation" } diff --git a/tests/Partas.Build.Tests/ParallelismTests.fs b/tests/Partas.Build.Tests/ParallelismTests.fs index ec1254c..4d7bc85 100644 --- a/tests/Partas.Build.Tests/ParallelismTests.fs +++ b/tests/Partas.Build.Tests/ParallelismTests.fs @@ -247,7 +247,7 @@ let tests = } } - Expect.equal (built.Parse("").Invoke()) 1 "an unresolved dependency inside a parallel scope is rejected" + Expect.equal (built.Parse("").Invoke()) ExitCode.UsageError "an unresolved dependency inside a parallel scope is rejected" Expect.equal executions.Value 0 "the rejected arrangement runs no producer" Expect.isEmpty ran "the rejection precedes every stage of the invocation" } From 4c64bb7b9c32430025d839935333b558ac57dc2a Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 10:55:02 +0000 Subject: [PATCH 03/25] Correct RootCommandDefinition doc: concurrent invocations are unsupported The remarks read as a serialisation guarantee that Invoke does not enforce. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- src/Partas.Build/Builders/Command.fs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Partas.Build/Builders/Command.fs b/src/Partas.Build/Builders/Command.fs index 019670b..9055a64 100644 --- a/src/Partas.Build/Builders/Command.fs +++ b/src/Partas.Build/Builders/Command.fs @@ -589,8 +589,7 @@ type CommandBuilder(name: string) = /// /// Built by Command.root { … }, which takes every operation rootCommand takes. Parsing and running /// happen only in Invoke, never at construction, so the value can be bound once in a long-lived host -/// and invoked repeatedly. Invocations of one value run one at a time: a pipeline value holds the collectors of -/// its current run. +/// and invoked repeatedly, one invocation after another. Concurrent invocations of one value are unsupported. /// [] type RootCommandDefinition From f9d20e40a6ad918a837ed7881e61ed34ce650256 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 10:54:03 +0000 Subject: [PATCH 04/25] Reach every consumer-named model type from Partas.Build (Task 14b) An [] ConsumerTypes module abbreviates StageContext, PipelineContext, CommandSpec, StageParent, RuntimeContext, StepIndex and the Build* aliases, and the public StageContext module re-exports writeLine, getOutput, getVerbosity and getNamePath. The docs pages drop `open Partas.Build.Internal`, and ConsumerSurfaceTests compiles consumer-style code without it. Baked's bump stage reports through StageContext.writeLine instead of printfn, so quiet and captured stages route it; BakedTests covers it. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 4 +- docs/content/Build/composition.fsx | 1 - .../computation-expression-operations.fsx | 1 - docs/content/Build/index.fsx | 1 - docs/content/index.fsx | 1 - notes/HANDOFF-Discoverability.md | 2 +- src/Partas.Build.Baked/SemVer.fs | 8 +- src/Partas.Build/Conductors.fs | 38 ++++++ tests/Partas.Build.Tests/BakedTests.fs | 36 ++++++ .../ConsumerSurfaceTests.fs | 109 ++++++++++++++++++ .../Partas.Build.Tests.fsproj | 3 + 11 files changed, 193 insertions(+), 11 deletions(-) create mode 100644 tests/Partas.Build.Tests/BakedTests.fs create mode 100644 tests/Partas.Build.Tests/ConsumerSurfaceTests.fs diff --git a/CLAUDE.md b/CLAUDE.md index 4820515..459335e 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -152,7 +152,7 @@ The core model, once a single `Types.fs`, is split by responsibility and compile 1. `Exceptions.fs` (`Partas.Build.ErrorHandling`) — pipeline exceptions, `FailureCause`, `StepOutcome`. 2. `Output.fs` (`Partas.Build.OutputHandling`) — `OutputCapture`, `StageOutput`, markup. 3. `Environment.fs`, `Timing.fs`, `Producer.fs` (`Partas.Build`) — `EnvArg`; `StageTimings`; `ProducerId`/`ProducerRef`/`ProducerValues` and the `ExecutionState` type. -4. `Conductors.fs` — `Partas.Build.Internal` first: `StageContext`, `PipelineContext`, `CommandSpec`. `Step` is `StepFn | Operation | StepOfStage`: a nested stage *is* one step of its parent, and stages nest arbitrarily. `StageParent` links a stage to a parent stage or the pipeline. The file ends in `Partas.Build` with the `StageContext` lookups that need `FsToolkit`/`HttpClient`. +4. `Conductors.fs` — `Partas.Build.Internal` first: `StageContext`, `PipelineContext`, `CommandSpec`. `Step` is `StepFn | Operation | StepOfStage`: a nested stage *is* one step of its parent, and stages nest arbitrarily. `StageParent` links a stage to a parent stage or the pipeline. The file ends in `Partas.Build` with the `ConsumerTypes` module — `[]` abbreviations of every model type a consumer names in a signature (`StageContext`, `PipelineContext`, `CommandSpec`, `StageParent`, `RuntimeContext`, `StepIndex`, the `Build*` aliases) — and the `StageContext` lookups that need `FsToolkit`/`HttpClient`, plus the consumer-facing re-exports `writeLine`/`getOutput`/`getVerbosity`/`getNamePath`. A consumer never needs `open Partas.Build.Internal`; `tests/Partas.Build.Tests/ConsumerSurfaceTests.fs` compiles without it and must keep doing so. 5. `Conductors.Runners.fs` (`Partas.Build.Internal.Runners`) — the execution engine (`StageContext.run`, `PipelineContext.run`). The `Build*` function aliases (`BuildStage`, `BuildStep`, `BuildStageIsActive`, …) no longer take an `ActionContext`: stages are pure, and the aliases match Fun.Build's originals except that Fun.Build declares them as delegates where this port uses plain function types. That difference has one mechanical consequence: **do not mark a CE entry member `inline` when it applies a `Build*` alias**, or Release builds fail with `FS1118` (Debug compiles fine). `Run` members are the usual offenders. `run (build: BuildStage, buildStep: StageContext -> BuildStep)` on `StageBuilder` stays non-generic: generalizing it ties it against the flexible-signature `run (step)` overload under `FS0041` at four existing call sites (`PLAN-Execution.md`'s T8 section). Being non-generic, it composes the alias itself, so that member must also stay non-`inline`. `FS1114` ("marked inline but was not bound in optimization environment") is the failure mode of forwarding one generic member to another sibling overload rather than building its step directly — moving the shared builder settings hit it in both Debug and Release, not only in Release like `FS1118`. @@ -216,6 +216,6 @@ a patch bump move it breaks anything not rebuilt in the same pass with `Could no - `.editorconfig` sets Stroustrup style, `max_line_length=150`, `fsharp_space_before_uppercase_invocation=true`. No fantomas tool is installed (`.config/dotnet-tools.json` declares no tools at all) and there is no `format`/`lint` command — match surrounding style manually. - Prefer `voption`/`ValueOption` and `[]` DUs in the library: a departure from the ported Fun.Build code. -- Public API goes in `[]` modules under `Partas.Build`; the model and engine stay in `Partas.Build.Internal`. +- Public API goes in `[]` modules under `Partas.Build`; the model and engine stay in `Partas.Build.Internal`. A model type that appears in a public signature gets an abbreviation in `ConsumerTypes` (`Conductors.fs`), and a lookup a step needs gets a re-export in the public `StageContext` module. - Console output is Spectre.Console throughout, with GitHub Actions `::error title=...::` fallbacks when `GITHUB_ENV` is present (see `printError` in both context modules). - The Nacara site (`docs/Site.fs`, `docs/docs.fsproj`) publishes every page under `docs/content/` and `docs/blog/`, plus the generated API reference, so internal working documents belong in `notes/` (as the `PLAN*.md` files do), not under `docs/`. diff --git a/docs/content/Build/composition.fsx b/docs/content/Build/composition.fsx index 384fa41..b4a37ed 100644 --- a/docs/content/Build/composition.fsx +++ b/docs/content/Build/composition.fsx @@ -54,7 +54,6 @@ order: 3 open Partas.Build -open Partas.Build.Internal (** # Composing reusable blocks diff --git a/docs/content/Build/computation-expression-operations.fsx b/docs/content/Build/computation-expression-operations.fsx index 84ac893..bb589eb 100644 --- a/docs/content/Build/computation-expression-operations.fsx +++ b/docs/content/Build/computation-expression-operations.fsx @@ -55,7 +55,6 @@ order: 4 open System.Threading open Partas.Build -open Partas.Build.Internal (** # Computation Expression Operations diff --git a/docs/content/Build/index.fsx b/docs/content/Build/index.fsx index b8cd001..44fa905 100644 --- a/docs/content/Build/index.fsx +++ b/docs/content/Build/index.fsx @@ -51,7 +51,6 @@ order: 0 #load "../../../src/Partas.Build.Baked/SemVer.fs" open Partas.Build -open Partas.Build.Internal (** diff --git a/docs/content/index.fsx b/docs/content/index.fsx index 517e01f..b45e363 100644 --- a/docs/content/index.fsx +++ b/docs/content/index.fsx @@ -50,7 +50,6 @@ order: 0 #load "../../src/Partas.Build.Baked/SemVer.fs" open Partas.Build -open Partas.Build.Internal (** diff --git a/notes/HANDOFF-Discoverability.md b/notes/HANDOFF-Discoverability.md index c3e88be..0bbf1dc 100644 --- a/notes/HANDOFF-Discoverability.md +++ b/notes/HANDOFF-Discoverability.md @@ -88,7 +88,7 @@ keeping on this task. | 12 | Per-stage timing summary | complete, one fix round | | 13 | `retry` on a stage | complete, two fix rounds | | 14 | Buffered output under `parallel'` | two fix rounds committed; **round-2 re-review partial** | -| 14b | No consumer signature needs an `Internal` type | not started; brief written | +| 14b | No consumer signature needs an `Internal` type | done — see `PLAN-Integration.md` §3.3 | | 15 | Documentation second pass | not started | | 16 | Verification against the acceptance criteria | not started | diff --git a/src/Partas.Build.Baked/SemVer.fs b/src/Partas.Build.Baked/SemVer.fs index c6a0ce5..1165f4d 100644 --- a/src/Partas.Build.Baked/SemVer.fs +++ b/src/Partas.Build.Baked/SemVer.fs @@ -199,12 +199,12 @@ module Stages = return stage "bump" { when' (not ci) - run (fun (_: Internal.StageContext) -> + run (fun (ctx: StageContext) -> projects |> List.map (fun project -> match Version.IO.bumpVersion project bump with | Ok (previous, next) -> - printfn $"%s{project}: %s{previous} -> %s{next}" + StageContext.writeLine ctx StdStream.Out $"%s{project}: %s{previous} -> %s{next}" Ok() | Error error -> Error $"%s{project}: %s{error.Message}" ) @@ -220,7 +220,7 @@ module Stages = /// /// The input spec for the project path(s) to bump. /// - let bumpArgument (projects: InputSpec): InputSpec = + let bumpArgument (projects: InputSpec): InputSpec = bumpImpl (InputSpec.ofInput bump.argument |> InputSpec.map (Option.defaultValue Patch)) projects /// @@ -230,7 +230,7 @@ module Stages = /// /// The input spec for the project path(s) to bump. /// - let bumpOption (projects: InputSpec): InputSpec = + let bumpOption (projects: InputSpec): InputSpec = input { let! bump = bump.option and! bumpImpl = diff --git a/src/Partas.Build/Conductors.fs b/src/Partas.Build/Conductors.fs index ee6cd8a..dc2daf6 100644 --- a/src/Partas.Build/Conductors.fs +++ b/src/Partas.Build/Conductors.fs @@ -645,6 +645,26 @@ open Partas.Build.Internal open System.Net.Http open Output +/// The model types a consumer names in a signature, reachable from Partas.Build. +/// +/// Each is an abbreviation of the type of the same name in Partas.Build.Internal, and is interchangeable +/// with it. The modules of functions over these types (StageContext.create, PipelineContext.run, …) +/// stay in Partas.Build.Internal; the consumer-facing lookups are in Partas.Build.StageContext. +/// +[] +module ConsumerTypes = + [] type stepIndex = Internal.stepIndex + type StepIndex = Internal.StepIndex + type StageContext = Internal.StageContext + type PipelineContext = Internal.PipelineContext + type CommandSpec = Internal.CommandSpec + type StageParent = Internal.StageParent + type RuntimeContext = Internal.RuntimeContext + type BuildStage = Internal.BuildStage + type BuildStep = Internal.BuildStep + type BuildPipeline = Internal.BuildPipeline + type BuildCommand = Internal.BuildCommand + module StageContext = /// The inputs stage and the stages nested under it declare, deduplicated. /// @@ -671,6 +691,24 @@ module StageContext = | Some pipeline -> ExecutionState.values pipeline.Producers | None -> ProducerValues.empty + /// Writes one line of step output to the stage's sink: the console, a capture, a redirect, or + /// nowhere for a silenced stage. + /// + /// The routed counterpart of printfn inside a step. A bare printfn reaches the console whatever + /// the stage's output setting is. + /// + let writeLine (ctx: StageContext) (stream: StdStream) (line: string) = StageContext.writeLine ctx stream line + + /// Where the stage's step output goes, from the nearest declaration walking upward. + /// ValueNone is StageOutput.Console. + let getOutput (ctx: StageContext) = StageContext.getOutput ctx + + /// The verbosity in effect for the stage. + let getVerbosity (ctx: StageContext) = StageContext.getVerbosity ctx + + /// The /-separated names of the stages enclosing the stage, outermost first, ending in its own. + let getNamePath (ctx: StageContext) = StageContext.getNamePath ctx + let rec getStageLevel (ctx: StageContext) = StageContext.mapStageParentContext 0 (getStageLevel >> (+) 1) ctx let rec getWorkingDir (ctx: StageContext) = diff --git a/tests/Partas.Build.Tests/BakedTests.fs b/tests/Partas.Build.Tests/BakedTests.fs new file mode 100644 index 0000000..135b0ba --- /dev/null +++ b/tests/Partas.Build.Tests/BakedTests.fs @@ -0,0 +1,36 @@ +/// The ready-made stages of Partas.Build.Baked, run through a command the way a consumer runs them. +module Partas.Build.Tests.BakedTests + +open System.IO +open Expecto +open Partas.Build + +[] +let tests = + testList "baked" [ + test "bump reports each project through the stage's output" { + let directory = Directory.CreateTempSubdirectory "partas-build-bump" + + try + let project = Path.Combine(directory.FullName, "Bumped.fsproj") + File.WriteAllText(project, """1.2.3""") + let lines = ResizeArray() + + let built = + command "bump" { + pipeline "bump" { + quiet + stage "outer" { + outputTo (StageOutput.Redirect(fun _ line -> lines.Add line)) + Baked.SemVer.Stages.bumpArgument (InputSpec.ret [ project ]) + } + } + } + + Expect.equal (built.Parse("minor --ci false").Invoke()) 0 "the bump should succeed" + Expect.sequenceEqual lines [ $"{project}: 1.2.3 -> 1.3.0" ] "the report should reach the stage's redirect" + Expect.stringContains (File.ReadAllText project) "1.3.0" "the project file should carry the new version" + finally + directory.Delete true + } + ] diff --git a/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs b/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs new file mode 100644 index 0000000..63ac876 --- /dev/null +++ b/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs @@ -0,0 +1,109 @@ +/// +/// The surface a consumer writes against, compiled without open Partas.Build.Internal. +/// +/// +/// The file compiling is the first assertion: every annotation below names its type through Partas.Build. +/// Keep Partas.Build.Internal out of this file's opens and out of its qualified names. +/// +module Partas.Build.Tests.ConsumerSurfaceTests + +open System.CommandLine +open Expecto +open Partas.Build + +let private quick = Input.option "--quick" + +let private writing (name: string) : InputSpec = input { + let! quick = quick + return stage name { + when' (not quick) + run (fun (ctx: StageContext) -> StageContext.writeLine ctx StdStream.Out $"ran {ctx.Name}") + } +} + +let private parentName (ctx: StageContext) = + match ctx.ParentContext with + | ValueSome(StageParent.Pipeline pipeline) -> pipeline.Name + | ValueSome(StageParent.Stage parent) -> parent.Name + | ValueNone -> "" + +let private recording (seen: ResizeArray) : Operation = { + Execute = fun (context: RuntimeContext) -> async { seen.Add $"{context.Stage.Name}#{int context.StepIndex}" } +} + +let private renamed: BuildStage = fun (ctx: StageContext) -> { ctx with Name = ctx.Name + "!" } + +let private withDescription: BuildCommand = fun (spec: CommandSpec) -> { spec with Description = ValueSome "described" } + +let private invoke (built: Command) (commandLine: string) = built.Parse(commandLine).Invoke() + +[] +let tests = + testList "consumer surface" [ + test "a stage factory typed through Partas.Build runs and routes its output" { + let lines = ResizeArray() + + let built = + command "build" { + pipeline "build" { + quiet + stage "outer" { + outputTo (StageOutput.Redirect(fun _ line -> lines.Add line)) + writing "inner" + } + } + } + + Expect.equal (invoke built "") 0 "the pipeline should succeed" + Expect.sequenceEqual lines [ "ran inner" ] "writeLine should reach the stage's redirect" + } + + test "a stage's parent is matched through StageParent" { + let seen = ResizeArray() + + let built = + command "build" { + pipeline "the-pipeline" { + quiet + stage "outer" { + run (fun (ctx: StageContext) -> seen.Add(parentName ctx)) + stage "inner" { run (fun (ctx: StageContext) -> seen.Add(parentName ctx)) } + } + } + } + + Expect.equal (invoke built "") 0 "the pipeline should succeed" + Expect.sequenceEqual seen [ "the-pipeline"; "outer" ] "each stage should see its own parent" + } + + test "an operation reads its RuntimeContext" { + let seen = ResizeArray() + + let built = + command "build" { + pipeline "build" { + stage "op" { + echo "first" + runOperation (recording seen) + } + } + } + + Expect.equal (invoke built "") 0 "the pipeline should succeed" + Expect.sequenceEqual seen [ "op#1" ] "the operation should see its stage and step index" + } + + test "the Build aliases and CommandSpec are nameable" { + let stage = renamed (stage "compile" { echo "compiling" }) + Expect.equal stage.Name "compile!" "a BuildStage should apply to a StageContext" + + let spec: CommandSpec = withDescription { Name = "c"; DisplayName = ValueNone; Description = ValueNone + PipelineDefaults = id; Aliases = []; Hidden = false; ExtraInputs = [] + Pipelines = []; SubCommands = []; ParserConfiguration = ValueNone + InvocationConfiguration = ValueNone } + Expect.equal spec.Description (ValueSome "described") "a BuildCommand should apply to a CommandSpec" + + let pipelineSpec: InputSpec = pipeline "p" { writing "compile" } + Expect.isNonEmpty pipelineSpec.Inputs "the pipeline should declare the stage's --quick" + } + ] diff --git a/tests/Partas.Build.Tests/Partas.Build.Tests.fsproj b/tests/Partas.Build.Tests/Partas.Build.Tests.fsproj index 20ade4c..23844d2 100644 --- a/tests/Partas.Build.Tests/Partas.Build.Tests.fsproj +++ b/tests/Partas.Build.Tests/Partas.Build.Tests.fsproj @@ -23,6 +23,8 @@ + + @@ -38,6 +40,7 @@ + From 41069b5ee21f37e38e38fdad9051fe49c5a3bc2f Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 10:54:03 +0000 Subject: [PATCH 05/25] =?UTF-8?q?Hygiene=20from=20PLAN-Integration=20?= =?UTF-8?q?=C2=A77=20row=201?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Build/Program.fs: drop `open Partas.Build.Internal`, build the Expecto arguments with Cmd.argIf/Cmd.args instead of a null-holed Cmd.ofString, remove the unused formatFiles glob. - .mcp.json: point fslangmcp at Partas.Build.slnx. - PLAN-Execution.md: status header reflects the implementation. - PLAN-Integration.md: record what is implemented and how it was verified. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- .mcp.json | 2 +- Build/Program.fs | 17 +++++++++-------- notes/PLAN-Execution.md | 2 +- notes/PLAN-Integration.md | 25 ++++++++++++++++++++++--- 4 files changed, 33 insertions(+), 13 deletions(-) diff --git a/.mcp.json b/.mcp.json index 05ffffb..3ddcf81 100644 --- a/.mcp.json +++ b/.mcp.json @@ -3,7 +3,7 @@ "fslangmcp": { "type": "stdio", "command": "fslangmcp", - "args": ["--project", "Partas.Testing.slnx"], + "args": ["--project", "Partas.Build.slnx"], "env": {} } } diff --git a/Build/Program.fs b/Build/Program.fs index a5daefa..a7b9a8e 100644 --- a/Build/Program.fs +++ b/Build/Program.fs @@ -15,7 +15,6 @@ open Fake.Core.Context open Fake.IO open Fake.IO.Globbing.Operators open Partas.Build -open Partas.Build.Internal open Partas.TypeProvider.BuildHelper let execContext = FakeExecutionContext.Create false "build.fsx" [] @@ -35,11 +34,6 @@ type Repo = let private root = Repo.FileSystem.``.``.ToString() -let formatFiles = - !! "**/*.fs" - -- "**/obj/**/*.*" - -- "**/AssemblyInfo.fs" - module Options = let quick = Input.option "--quick" @@ -186,6 +180,13 @@ module Tests = projects } } + + /// The arguments every Expecto suite takes after --; --summary only under --ci. + let private expectoArgs (ci: bool) (command: Cmd) = + command + |> Cmd.argIf ci [ "--summary" ] + |> Cmd.args [ "--colours"; "256"; "--sequenced" ] + let execute = input { let! skipTests = Options.skipTests and! config = Options.config @@ -202,11 +203,11 @@ module Tests = Repo.Project.``Partas.Build.Tests``.Path Repo.Project.``Partas.ExternalAnnotations.Tests``.Path ] do stage $"test {project}" { - run (Cmd.ofString $"""dotnet run --project {project} --no-build -c {config} -- {if ci then "--summary" else null} --colours 256 --sequenced""") + run (cmd $"dotnet run --project {project} --no-build -c {config} --" |> expectoArgs ci) } // Runs in both configurations regardless of `--configuration`: Release is what catches FS1118. for probeConfig in [ "Debug"; "Release" ] do stage $"compiler probe ({probeConfig})" { - run (Cmd.ofString $"""dotnet run --project {Repo.Project.``Partas.Build.CompilerProbe``.Path} -c {probeConfig} -- {if ci then "--summary" else null} --colours 256 --sequenced""") + run (cmd $"dotnet run --project {Repo.Project.``Partas.Build.CompilerProbe``.Path} -c {probeConfig} --" |> expectoArgs ci) } } } diff --git a/notes/PLAN-Execution.md b/notes/PLAN-Execution.md index 5068768..0fa935e 100644 --- a/notes/PLAN-Execution.md +++ b/notes/PLAN-Execution.md @@ -1,6 +1,6 @@ # Typed execution, producer dependencies, and failure handling -- Status: behavioral decisions agreed; implementation not started. +- Status: implemented. The *Implemented surface* sections below record what shipped; CLAUDE.md's architecture notes describe the current model. - Date: 2026-09-17. - Implementation checklist: [PLAN-Execution-Tasks.md](PLAN-Execution-Tasks.md). - Input-model prerequisite: [PLAN.md](PLAN.md), especially verified findings and the prescribed composition workaround. diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 2212274..41648a0 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -99,7 +99,8 @@ one prefab field. (`Builders/Inputs.fs:61,64`). Consumers mix them. Keep one of each, `[]` the other. - **`when' bool` carries no reason.** Add `when' (reason: string, cond: bool)` or a `whenNotFlag` for the `when' (not quick)` idiom, so `--explain` names the flag that skipped the stage. -- **`printfn` in Baked**: replace with `StageContext.writeLine`. +- **`printfn` in Baked**: replace with `StageContext.writeLine`. **Status: implemented on `claude/partas-build-patterns-jgrwr0-int-usability`** + (`bumpImpl`; the only `printfn` in Baked), with a test in `tests/Partas.Build.Tests/BakedTests.fs`. ### 3.3 Finish Task 14b @@ -108,6 +109,19 @@ one prefab field. aliases under `Partas.Build`, then remove `open Partas.Build.Internal` from `Build/Program.fs` and the docs pages as the check. +**Status: implemented on `claude/partas-build-patterns-jgrwr0-int-usability`.** Public aliases, not a move: an +`[] module ConsumerTypes` at the end of `Conductors.fs` abbreviates `StageContext`, `PipelineContext`, +`CommandSpec`, `StageParent`, `RuntimeContext`, `StepIndex`/`stepIndex` and the `Build*` aliases. Moving the +records would change their full names, a binary break for already-compiled consumers; an abbreviation erases to the +same type, so code that opens `Internal` is unaffected. Compiler-established: record construction annotated as +`CommandSpec`, `{ ctx with … }`, matching the struct DU `StageParent.Pipeline` and `Operation` over +`RuntimeContext` all work through the abbreviations (`tests/Partas.Build.Tests/ConsumerSurfaceTests.fs`, which +opens only `Partas.Build`). The `StageContext` functions a step calls (`writeLine`, `getOutput`, `getVerbosity`, +`getNamePath`) lived only in `Internal`'s module; the public `Partas.Build.StageContext` module re-exports them. +`open Partas.Build.Internal` is gone from `Build/Program.fs`, `docs/content/index.fsx` and +`docs/content/Build/*.fsx`; the docs pages type-check under `dotnet fsi`. `Build/Program.fs` was compiled as a +scratch copy with the `Repo` type provider stubbed (the provider does not load in the container that did the work). + ## 4. Agent discoverability `PLAN-Discoverability.md`'s principle stands: an agent will run a command before it reads a document. The @@ -295,12 +309,17 @@ Recorded so they are not lost; each belongs to its own repository. intended form. - `PLAN-Execution.md`'s header still reads "implementation not started". +**Status: all four implemented on `claude/partas-build-patterns-jgrwr0-int-usability`.** `Program.fs` builds the Expecto arguments through +`cmd $"… --" |> Cmd.argIf ci [ "--summary" ] |> Cmd.args [ … ]`. `PLAN-Execution-Tasks.md`'s own "Planning +only" status line and its unchecked T4/T5 boxes are equally stale and were left alone: whether each box is done +needs checking against the code. + ## 7. Order of work | # | Item | Axis | Size | |---|---|---|---| -| 1 | `.mcp.json`, `printfn` in Baked, `Cmd.argIf` in `Program.fs` | hygiene | trivial | -| 2 | Task 14b: no consumer needs `Internal` | usability | medium | +| 1 | `.mcp.json`, `printfn` in Baked, `Cmd.argIf` in `Program.fs` — **done** | hygiene | trivial | +| 2 | Task 14b: no consumer needs `Internal` — **done** | usability | medium | | 3 | `run (fun _ -> string)` rename/obsolete; `desc`/`input` duplicates | usability | small | | 4 | Exit codes (§4.2) | discoverability | small | | 5 | `Command.invoke` + `RunResult` (§5.3.1) | SageFs, discoverability | medium | From 59cb334e6f3aafe2be84352842b0d8b3cfd9bff5 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 10:59:49 +0000 Subject: [PATCH 06/25] Abbreviate BuildStageIsActive and BuildConditions in ConsumerTypes Public condition functions return BuildStageIsActive, so a consumer writing a reusable condition in the same style can name it without opening Internal. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- notes/PLAN-Integration.md | 2 +- src/Partas.Build/Conductors.fs | 2 ++ tests/Partas.Build.Tests/ConsumerSurfaceTests.fs | 14 ++++++++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 41648a0..5279c21 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -111,7 +111,7 @@ pages as the check. **Status: implemented on `claude/partas-build-patterns-jgrwr0-int-usability`.** Public aliases, not a move: an `[] module ConsumerTypes` at the end of `Conductors.fs` abbreviates `StageContext`, `PipelineContext`, -`CommandSpec`, `StageParent`, `RuntimeContext`, `StepIndex`/`stepIndex` and the `Build*` aliases. Moving the +`CommandSpec`, `StageParent`, `RuntimeContext`, `StepIndex`/`stepIndex` and every `Build*` alias (`BuildStageIsActive` and `BuildConditions` included). Moving the records would change their full names, a binary break for already-compiled consumers; an abbreviation erases to the same type, so code that opens `Internal` is unaffected. Compiler-established: record construction annotated as `CommandSpec`, `{ ctx with … }`, matching the struct DU `StageParent.Pipeline` and `Operation` over diff --git a/src/Partas.Build/Conductors.fs b/src/Partas.Build/Conductors.fs index dc2daf6..d9eeaf8 100644 --- a/src/Partas.Build/Conductors.fs +++ b/src/Partas.Build/Conductors.fs @@ -662,6 +662,8 @@ module ConsumerTypes = type RuntimeContext = Internal.RuntimeContext type BuildStage = Internal.BuildStage type BuildStep = Internal.BuildStep + type BuildStageIsActive = Internal.BuildStageIsActive + type BuildConditions = Internal.BuildConditions type BuildPipeline = Internal.BuildPipeline type BuildCommand = Internal.BuildCommand diff --git a/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs b/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs index 63ac876..9dc92ae 100644 --- a/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs +++ b/tests/Partas.Build.Tests/ConsumerSurfaceTests.fs @@ -35,6 +35,10 @@ let private renamed: BuildStage = fun (ctx: StageContext) -> { ctx with Name = c let private withDescription: BuildCommand = fun (spec: CommandSpec) -> { spec with Description = ValueSome "described" } +let private whenNamed (name: string) : BuildStageIsActive = fun (ctx: StageContext) -> ctx.Name = name + +let private withNamed: BuildConditions = fun conditions -> conditions @ [ whenNamed "gated" ] + let private invoke (built: Command) (commandLine: string) = built.Parse(commandLine).Invoke() [] @@ -106,4 +110,14 @@ let tests = let pipelineSpec: InputSpec = pipeline "p" { writing "compile" } Expect.isNonEmpty pipelineSpec.Inputs "the pipeline should declare the stage's --quick" } + + test "a condition typed as BuildStageIsActive composes into whenAll" { + let gated = stage "gated" { whenAll { whenNamed "gated" }; echo "gated" } + let other = stage "other" { whenAll { whenNamed "gated" }; echo "other" } + Expect.isTrue (gated.IsActive gated) "the named condition should hold for its stage" + Expect.isFalse (other.IsActive other) "the named condition should fail for another stage" + + let conditions = withNamed [] + Expect.equal conditions.Length 1 "a BuildConditions should apply to a condition list" + } ] From d5a79a30c8986267c68c8066d61bc80790ff644a Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 12:11:11 +0000 Subject: [PATCH 07/25] Add --json, --report and --schema, and a static side-effect-free --explain MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit PLAN-Integration §4.1 and §4.3. - MachineOutput.fs: `--json` and `--schema` on every command, `--report ` on every command that runs pipelines, each skipped when the command already declares the name or an alias. `--schema` prints the command tree as JSON: options with aliases, type, default, accepted values, description, arity. - Under `--json`, `--explain` prints the stage tree as JSON (statically), and a run prints its RunResult as one line of JSON in place of the timing table; `--report` writes it indented to a file. Every document carries formatVersion 1. System.Text.Json is referenced on netstandard2.0 only. - Explain builds a model (ExplainedPipeline/Stage/Step/Condition) under an ExplainMode. It walks StageContext.Conditions instead of calling IsActive, so each condition runs at most once (a failing `when' stage` ran twice) and a throwing condition renders as its message. ExplainMode.Static leaves conditions marked Conditions.effectful unevaluated: whenBranch(es), whenStage / `when' stage`, and whenAll/whenAny/whenNot over any of them. - Conditions.whenBranches takes #seq, keeping the call a plain application the mark survives. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 42 +- docs/content/Build/CAPABILITIES.md | 14 + docs/content/Build/composition.fsx | 1 + .../computation-expression-operations.fsx | 1 + docs/content/Build/index.fsx | 1 + .../external-annotations-api.fsx | 1 + docs/content/index.fsx | 1 + notes/PLAN-Integration.md | 40 +- src/Partas.Build/Builders/Command.fs | 120 ++++-- src/Partas.Build/Builders/Conditions.fs | 78 +++- src/Partas.Build/Explain.fs | 389 +++++++++++++++--- src/Partas.Build/MachineOutput.fs | 266 ++++++++++++ src/Partas.Build/Partas.Build.fsproj | 6 + src/Partas.Build/RunResult.fs | 117 ++++++ .../CommandTests.fs | 11 +- tests/Partas.Build.Tests/CommandTests.fs | 146 ++++++- tests/Partas.Build.Tests/CompositionTests.fs | 4 +- tests/Partas.Build.Tests/ExplainTests.fs | 150 +++++++ 18 files changed, 1246 insertions(+), 142 deletions(-) create mode 100644 src/Partas.Build/MachineOutput.fs diff --git a/CLAUDE.md b/CLAUDE.md index 459335e..65501b1 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -47,19 +47,42 @@ Fast inner loop while working on the library only: `dotnet build src/Partas.Buil ## Architecture notes -Compile order in `Partas.Build.fsproj` matters (F#): `System.CommandLine/Aliases.fs` → `System.CommandLine/Inputs.fs` → `Exceptions.fs` → `Output.fs` → `Environment.fs` → `Timing.fs` → `Producer.fs` → `Failures.fs` → `Conductors.fs` → `Conductors.Runners.fs` → `Process.fs` → `Operations.fs` → `Dependencies.fs` → `DependencyPlan.fs` → `ExecutionState.fs` → `Builders/StageSettings.fs` → `Builders/Stage.fs` → `Builders/Conditions.fs` → `Builders/PipelineSettings.fs` → `Builders/Pipeline.fs` → `Builders/Inputs.fs` → `Explain.fs` → `Summary.fs` → `RunResult.fs` → `Builders/Command.fs`. The batteries-included layer is its own project, `src/Partas.Build.Baked`. +Compile order in `Partas.Build.fsproj` matters (F#): `System.CommandLine/Aliases.fs` → `System.CommandLine/Inputs.fs` → `Exceptions.fs` → `Output.fs` → `Environment.fs` → `Timing.fs` → `Producer.fs` → `Failures.fs` → `Conductors.fs` → `Conductors.Runners.fs` → `Process.fs` → `Operations.fs` → `Dependencies.fs` → `DependencyPlan.fs` → `ExecutionState.fs` → `Builders/StageSettings.fs` → `Builders/Stage.fs` → `Builders/Conditions.fs` → `Builders/PipelineSettings.fs` → `Builders/Pipeline.fs` → `Builders/Inputs.fs` → `Builders/Dependencies.fs` → `MachineOutput.fs` → `Explain.fs` → `Summary.fs` → `RunResult.fs` → `Builders/Command.fs`. The batteries-included layer is its own project, `src/Partas.Build.Baked`. -`Explain.fs` renders the resolved stage tree `--explain` prints, as text only, independent of the console and -any stage sink — a stage that silences or captures its output is still described in full. It compiles before +`Explain.fs` renders the resolved stage tree `--explain` prints, as text or JSON, independent of the console and +any stage sink — a stage that silences or captures its output is still described in full. `Explain.explain mode` +builds the model (`ExplainedPipeline`/`ExplainedStage`/`ExplainedStep`/`ExplainedCondition`); `renderWith` and +`toJson` render it. It compiles before `Builders/Command.fs`, whose `applyTo` registers the flag on every command and prints what the renderer returns. It depends on nothing beyond the core model and the `Input.*` combinators. A command that runs pipelines gets `Explain.option` and reads it in its own action. A grouping command gets `Explain.groupingOption`, which carries the rendering — a list of the subcommands it dispatches to — on the option's own `Action`: such a command has no action of its own, and adding one would displace System.CommandLine's "Required command was not provided.". -Rendering evaluates every stage's `IsActive`, so a `whenBranch` starts `git` and a `whenStage` runs its condition -stage. `StageContext.Conditions` lets a skip name the condition that caused it: `addPredicateBecause` writes it -alongside `IsActive`. The structured conditions in `Builders/Conditions.fs` supply a reason; `when'` supplies -none, since a `bool` argument carries no reason to report. +Rendering never calls `IsActive`: it walks `StageContext.Conditions` — `addPredicateBecause` is the single writer +of both, so the list conjoins to `IsActive` — calling each condition at most once, stopping at the first that fails +or throws, and rendering a throw as its message (`condition failed: …`) instead of crashing. Under +`ExplainMode.Evaluated` (text `--explain`) a `whenBranch` starts `git` and a `whenStage` runs its condition stage, +once. Under `ExplainMode.Static` (`--explain --json`) a condition marked `Conditions.effectful` is reported +`unevaluated` with its description and left uncalled. The mark is the condition's runtime type, +`EffectfulCondition` (an `FSharpFunc` subclass), not a closure-keyed table: the optimiser copies a closure it +inlines, and an eta-expansion at a call site that coerces an argument (`whenBranches ["main"]` against a +`string seq` parameter) wraps it, so `whenBranches` takes `#seq` to keep the call a plain application. +`whenBranches`, `whenStageSucceeds` (`when' stage`, `whenStage`) are marked; `whenAll`/`whenAny`/`whenNot` mark +their result when any child is marked (`Conditions.combined`). A condition wrapped in an unmarked lambda is +evaluated. `StageContext.Conditions` also lets a skip name the condition that caused it. The structured +conditions in `Builders/Conditions.fs` supply a reason; `when'` supplies none, since a `bool` argument carries +no reason to report. + +`MachineOutput.fs` holds the machine-readable flags and the command-tree schema. `applyTo` registers `--json` and +`--schema` on every command and `--report ` on a command that runs pipelines, each through `reserve`, which +skips a flag whose name or alias the command already declares (the consumer's option wins; System.CommandLine +would reject the duplicate). `--schema` carries its action on the option, like `Explain.groupingOption`, and +prints `MachineOutput.schema` of the parsed command. Under `--json`, `--explain` prints `Explain.toJson` (static) +and a run prints `RunResult.toJson false` as one line after the run, in place of the timing table; `--report` +writes the indented form to a file. Both are written for every outcome the command action reaches, a failed +dependency validation included, but not for a System.CommandLine parse error. JSON is written with +`Utf8JsonWriter` by hand, not reflection serialization: every document carries `formatVersion` +(`MachineOutput.FormatVersion`). `System.Text.Json` is a package reference on `netstandard2.0` only. `Failures.fs` holds what a scope reports about itself, apart from what it prints. A `ScopeReport` carries three fields: `Outcome` (the scope's own `StageOutcome`), `Propagates` (whether that failure fails the scope @@ -135,7 +158,8 @@ and `RootCommandDefinition.Invoke(args, ?output, ?error, ?cancellationToken)` pa a parse result whose `Action` is System.CommandLine's `ParseErrorAction` becomes 2 there, whatever the action returned. The command action finds its invocation's state — the cancellation token and the `PipelineRun` collector — in a `ConditionalWeakTable` keyed by the `ParseResult`; a parse result invoked directly through -System.CommandLine has none, runs uncancellable, and still gets 2 for a failed dependency validation (the +System.CommandLine has none (the action makes a local, uncancellable one so `--json`/`--report` still see its +runs), and still gets 2 for a failed dependency validation (the action returns it) but 1 for a parse error (System.CommandLine's own). The token reaches the engine through `PipelineContext.runWith`, which links it into the pipeline's own timeout source. `output` replaces the invocation configuration's `Output`/`Error`, which is where help, parse errors, `--explain`, the timing summary @@ -146,7 +170,7 @@ and the dependency diagnostic go; stage output still goes to Spectre's ambient c `src/Partas.Build.Baked` is the batteries-included layer over the library: ready-made `Input.*`/`Argument.*` definitions for the options every build CLI ends up wanting (`--configuration`, `--nuget-key`, `--project`, `--ci`, a version bump), the semver arithmetic in `Version`, and `IO.writeVersion`/`IO.bumpVersion` for editing a project file's -``. It is the only place in the library that writes to disk. +``. It is the only place in the library that writes to disk, apart from the result file `--report` names. The core model, once a single `Types.fs`, is split by responsibility and compiles in this order: 1. `Exceptions.fs` (`Partas.Build.ErrorHandling`) — pipeline exceptions, `FailureCause`, `StepOutcome`. diff --git a/docs/content/Build/CAPABILITIES.md b/docs/content/Build/CAPABILITIES.md index a86d652..842d99c 100644 --- a/docs/content/Build/CAPABILITIES.md +++ b/docs/content/Build/CAPABILITIES.md @@ -328,6 +328,20 @@ become one implicit pipeline carrying the command's name and description. `Comma pipeline written out, for when it needs pipeline-level settings. `pipeline "name" { }` is for several pipelines under one command, or a pipeline that needs its own name. +## Flags every command carries + +| Flag | What it does | +|---|---| +| `--explain` | Prints the resolved stage tree and runs nothing. A grouping command lists its subcommands | +| `--json` | With `--explain`, prints the tree as JSON, leaving `whenBranch` and `whenStage` conditions unevaluated. On a run, prints the run result — each stage's outcome, failures and timing — as one line of JSON after the run, in place of the timing table | +| `--report ` | Writes the run result as JSON to a file. Only on commands that run pipelines | +| `--schema` | Prints the command, its options (name, aliases, type, default, accepted values, description) and its subcommands as JSON, and runs nothing | + +A command that declares one of these names itself keeps its own option. Every JSON document carries +`formatVersion`. Text `--explain` evaluates every condition, running a `whenStage` condition stage once; a +condition that throws is shown with its message. `Conditions.effectful description condition` marks a +condition of your own so the JSON form leaves it unevaluated too. + ## Condition builders `whenAll { }`, `whenAny { }` and `whenNot { }` take these. Each yields a single condition to a stage. An empty diff --git a/docs/content/Build/composition.fsx b/docs/content/Build/composition.fsx index b4a37ed..79986cc 100644 --- a/docs/content/Build/composition.fsx +++ b/docs/content/Build/composition.fsx @@ -42,6 +42,7 @@ order: 3 #load "../../../src/Partas.Build/Builders/PipelineSettings.fs" #load "../../../src/Partas.Build/Builders/Pipeline.fs" #load "../../../src/Partas.Build/Builders/Inputs.fs" +#load "../../../src/Partas.Build/MachineOutput.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" #load "../../../src/Partas.Build/RunResult.fs" diff --git a/docs/content/Build/computation-expression-operations.fsx b/docs/content/Build/computation-expression-operations.fsx index bb589eb..7f7863e 100644 --- a/docs/content/Build/computation-expression-operations.fsx +++ b/docs/content/Build/computation-expression-operations.fsx @@ -41,6 +41,7 @@ order: 4 #load "../../../src/Partas.Build/Builders/PipelineSettings.fs" #load "../../../src/Partas.Build/Builders/Pipeline.fs" #load "../../../src/Partas.Build/Builders/Inputs.fs" +#load "../../../src/Partas.Build/MachineOutput.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" #load "../../../src/Partas.Build/RunResult.fs" diff --git a/docs/content/Build/index.fsx b/docs/content/Build/index.fsx index 44fa905..924e866 100644 --- a/docs/content/Build/index.fsx +++ b/docs/content/Build/index.fsx @@ -40,6 +40,7 @@ order: 0 #load "../../../src/Partas.Build/Builders/PipelineSettings.fs" #load "../../../src/Partas.Build/Builders/Pipeline.fs" #load "../../../src/Partas.Build/Builders/Inputs.fs" +#load "../../../src/Partas.Build/MachineOutput.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" #load "../../../src/Partas.Build/RunResult.fs" diff --git a/docs/content/external-annotations/external-annotations-api.fsx b/docs/content/external-annotations/external-annotations-api.fsx index be3ab1d..2290ad9 100644 --- a/docs/content/external-annotations/external-annotations-api.fsx +++ b/docs/content/external-annotations/external-annotations-api.fsx @@ -40,6 +40,7 @@ index: 2 #load "../../../src/Partas.Build/Builders/PipelineSettings.fs" #load "../../../src/Partas.Build/Builders/Pipeline.fs" #load "../../../src/Partas.Build/Builders/Inputs.fs" +#load "../../../src/Partas.Build/MachineOutput.fs" #load "../../../src/Partas.Build/Explain.fs" #load "../../../src/Partas.Build/Summary.fs" #load "../../../src/Partas.Build/RunResult.fs" diff --git a/docs/content/index.fsx b/docs/content/index.fsx index b45e363..1dce042 100644 --- a/docs/content/index.fsx +++ b/docs/content/index.fsx @@ -39,6 +39,7 @@ order: 0 #load "../../src/Partas.Build/Builders/PipelineSettings.fs" #load "../../src/Partas.Build/Builders/Pipeline.fs" #load "../../src/Partas.Build/Builders/Inputs.fs" +#load "../../src/Partas.Build/MachineOutput.fs" #load "../../src/Partas.Build/Explain.fs" #load "../../src/Partas.Build/Summary.fs" #load "../../src/Partas.Build/RunResult.fs" diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 5279c21..4066f45 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -139,6 +139,26 @@ console width. Add `--format json` (name open) on every command: - **`--schema`** (or a hidden `describe` command): the command tree with every option's name, aliases, type, default, choices and description. System.CommandLine has this information; it is only rendered as help. +**Status: implemented on claude/partas-build-patterns-jgrwr0-json.** `MachineOutput.fs`, `Explain.toJson`, +`RunResult.toJson`. Decisions and deviations: + +- The flag is `--json` (§8 Q1), a plain `bool`, on every command; `--schema` is on every command and prints the + subtree rooted at the command it is given to; `--report ` is on every command that runs pipelines. + A command that already declares one of these names or aliases keeps its own option and goes without the + library's (`reserve` in `Builders/Command.fs`): collision is resolved at construction, silently, rather than + by System.CommandLine rejecting a duplicate. +- The run result goes to stdout under `--json` *and* to a file under `--report` (§8 Q2): stdout as one line of + compact JSON after the run, replacing the timing table, so a reader takes the last line; the file indented. + Stage output is untouched, since capturing it is the stage's setting. +- Every document carries `formatVersion: 1`. JSON is written with `Utf8JsonWriter` directly rather than by + reflection over the F# records, which do not serialize `voption`/DUs usefully. `System.Text.Json` is a package + reference (8.0.5) on `netstandard2.0` only; `net8.0`/`net10.0` use the shared framework's. +- `choices` is what System.CommandLine offers for completion: `acceptOnlyFromAmong`, `mapFromAmong`, + `addCompletions` and enums all appear there; booleans list none. A default whose factory reads its parse is + reported absent. +- Not covered: a System.CommandLine parse error (unknown option, missing subcommand) happens before any command + action, so it writes no JSON — the exit code (2) is the machine-readable part. + ### 4.2 Exit codes Today a parse/validation error and a stage failure both exit 1 (`Command.fs:93-110`). Proposed: `0` success, @@ -159,6 +179,18 @@ twice, per the handoff's deferred findings. There is also no exception guard. Pr under `--format json`) that reports a structured condition as `unevaluated: whenBranch "main"` instead of running it, and a guard that renders a failed condition as its exception message. +**Status: implemented on claude/partas-build-patterns-jgrwr0-json.** `ExplainMode.Evaluated | Static`; +`--explain` (text) stays evaluated, `--explain --json` is static; `Explain.renderWith`/`toJson` take the mode. +The double evaluation was confirmed — `status` called `IsActive`, then `skipReason` re-ran each reasoned +condition of a skipped stage, so a failing `when' stage` ran its condition stage twice — and is fixed: explain +walks `StageContext.Conditions` itself, each condition at most once, short-circuiting as `IsActive` does. That +changes one edge: the skip reason is now the *first* failing condition's (possibly none), where it used to be the +first failing condition that carried a reason. A throwing condition renders `condition failed: ` +(JSON `status: "error"`). Side-effecting conditions are recognised by a marker type, `EffectfulCondition`, made +through the public `Conditions.effectful description condition` so consumers can mark their own; a closure-keyed +weak table was tried first and lost the mark to inlining and to call-site eta-expansion (see CLAUDE.md). +`Conditions.whenBranches` now takes `#seq` for the same reason — source-compatible, binary-breaking. + ### 4.4 XML ``s There are none in `src` (Task 15's audit was never done). Priority targets: the `run` overloads, `input { }`, @@ -323,11 +355,11 @@ needs checking against the code. | 3 | `run (fun _ -> string)` rename/obsolete; `desc`/`input` duplicates | usability | small | | 4 | Exit codes (§4.2) | discoverability | small | | 5 | `Command.invoke` + `RunResult` (§5.3.1) | SageFs, discoverability | medium | -| 6 | JSON for `--explain`, the run result, `--schema` (§4.1) — serializes 5's result | discoverability | medium | +| 6 | JSON for `--explain`, the run result, `--schema` (§4.1) — serializes 5's result — **done** | discoverability | medium | | 7 | Console hygiene, argv capture, env at run time (§5.3.2-5.3.5) — after the Spectre spike | SageFs | medium | | 8 | Thread-interrupt bridge + no-orphan test (§5.3.4) | SageFs | medium | | 9 | Baked prefab stages (§3.1), `Build/Program.fs` rewritten on them as the acceptance test | usability | large | -| 10 | Side-effect-free `--explain` (§4.3) | discoverability | medium | +| 10 | Side-effect-free `--explain` (§4.3) — **done** | discoverability | medium | | 11 | XML ``s, agent snippet, consumer pattern docs (§4.4, §4.5, §5.4) | discoverability | medium | `Build/Program.fs` stays the acceptance test, as in `PLAN.md`: items 2, 3 and 9 are done when it compiles @@ -337,8 +369,12 @@ without `open Partas.Build.Internal` and without the hand-rolled rows of §2's f 1. JSON flag naming: `--format json` on every command, or `--json`? Does it collide with a consumer's own option (System.CommandLine rejects duplicate aliases at construction)? + **Decided:** `--json`. `--format` is a likely name for a consumer's own code-formatting option; a bare flag + also needs no value parsing. A command that declares either name keeps its own and goes without the library's. 2. Should §4.1's run result go to stdout or only to `--report `? Stdout is simpler for agents but mixes with step output that is not captured. + **Decided:** both. `--json` puts it on stdout as the last line, one line of compact JSON; `--report ` + writes it, indented, to a file, with or without `--json`. 3. Prefab stages as functions or records (§3.1, W12). 4. Does `Command.invoke` take the `RootCommandBuilder` result, the `CommandSpec`, or both — and does it live in `Partas.Build` or a separate `Partas.Build.Hosting` namespace? diff --git a/src/Partas.Build/Builders/Command.fs b/src/Partas.Build/Builders/Command.fs index 9055a64..cdc11a2 100644 --- a/src/Partas.Build/Builders/Command.fs +++ b/src/Partas.Build/Builders/Command.fs @@ -65,10 +65,10 @@ let private register (command: Command) (input: ActionInput) = | Context | Injection _ -> () /// Prints the tree the command's pipelines resolve to under , then the invocation -/// paths still missing a description. Materialising a pipeline runs its stage builders, never its steps. -let private explain (output: TextWriter) (command: Command) (pipelines: PipelineContext list) = - pipelines - |> Explain.ofPipelines command +/// paths still missing a description: as JSON, evaluated statically, under --json. Materialising a pipeline +/// runs its stage builders, never its steps. +let private explain (output: TextWriter) (asJson: bool) (command: Command) (pipelines: PipelineContext list) = + if asJson then Explain.toJson ExplainMode.Static command pipelines else Explain.ofPipelines command pipelines |> output.WriteLine ExitCode.Success @@ -82,78 +82,104 @@ type private InvocationState(cancellationToken: CancellationToken) = member _.Pipelines = lock pipelines (fun () -> List.ofSeq pipelines) /// The invocation state of each parse result an invocation is running. A parse result invoked directly through -/// System.CommandLine has none, and runs uncancellable with its pipeline runs unrecorded. +/// System.CommandLine has none, and runs uncancellable. let private invocations = ConditionalWeakTable() -/// Runs and prints what each of its stages took. +/// Runs , records it, and prints what each of its stages took. /// /// A run that failed prints the table too, with the stage that failed in it. A quiet pipeline prints none, and -/// so does a run of a single stage, whose wall time is the pipeline's own. +/// so does a run of a single stage, whose wall time is the pipeline's own, and a run under --json, whose +/// result carries the timings. /// -let private runReportingTimings (output: TextWriter) (state: InvocationState voption) (pipeline: PipelineContext) = - let cancellationToken = state |> ValueOption.map _.CancellationToken |> ValueOption.defaultValue CancellationToken.None +let private runReportingTimings (output: TextWriter) (asJson: bool) (state: InvocationState) (pipeline: PipelineContext) = try - PipelineContext.runWith cancellationToken pipeline + PipelineContext.runWith state.CancellationToken pipeline finally let timings = StageTimings.ordered pipeline.Timings - state |> ValueOption.iter (fun state -> - state.Record { Name = pipeline.Name; Reports = ScopeReports.stages pipeline.Reports; Timings = timings }) + state.Record { Name = pipeline.Name; Reports = ScopeReports.stages pipeline.Reports; Timings = timings } let verbosity = defaultValueArg pipeline.Verbosity Verbosity.Default let timings = StageTimings.ordered pipeline.Timings match timings with | [] | [ _ ] -> () - | _ when verbosity.IsQuiet -> () + | _ when verbosity.IsQuiet || asJson -> () | timings -> Summary.render timings |> output.WriteLine +/// Writes the result of a command action: to the output as one line under --json, and indented to the file +/// --report names. +let private reportResult (output: TextWriter) (parseResult: ParseResult) (exitCode: int) (runs: PipelineRun list) = + let result = { ExitCode = exitCode; Outcome = RunOutcome.ofExitCode exitCode; Pipelines = runs } + + if MachineOutput.isSet MachineOutput.json parseResult then + output.WriteLine(RunResult.toJson false result) + + match MachineOutput.tryValue MachineOutput.report parseResult with + | Some path when not (String.IsNullOrWhiteSpace path) -> + let path = Path.GetFullPath path + let directory = Path.GetDirectoryName path + if not (String.IsNullOrEmpty directory) then Directory.CreateDirectory directory |> ignore + File.WriteAllText(path, RunResult.toJson true result) + | _ -> () + + exitCode + /// Reads each pipeline out of the parse result and runs it, in declaration order. Producer work is placed into /// the pipelines that run, after the whole invocation validates and never on the way to --explain. /// The runner has already reported the failure by the time it raises, so this only maps it to an exit code. let private invoke (command: Command) (spec: CommandSpec) (parseResult: ParseResult) = + // Parse results invoked straight through System.CommandLine get a state of their own, so that `--json` and + // `--report` see the pipelines they ran. let state = match invocations.TryGetValue parseResult with - | true, state -> ValueSome state - | false, _ -> ValueNone + | true, state -> state + | false, _ -> InvocationState CancellationToken.None let configuration = parseResult.InvocationConfiguration + let asJson = MachineOutput.isSet MachineOutput.json parseResult let pipelines = spec.Pipelines |> List.map (fun pipeline -> pipeline.Read parseResult) match DependencyPlan.validate pipelines with | Error message -> configuration.Error.WriteLine message - ExitCode.UsageError - | Ok _ when Explain.option.GetValue parseResult -> explain configuration.Output command pipelines + reportResult configuration.Output parseResult ExitCode.UsageError [] + | Ok _ when MachineOutput.isSet Explain.option parseResult -> explain configuration.Output asJson command pipelines | Ok plan -> let scheduled = ExecutionSchedule.schedule parseResult plan pipelines let executed = ResizeArray() - try + let exitCode = try - for pipeline in scheduled do - match state with - | ValueSome state when state.CancellationToken.IsCancellationRequested -> - raise (PipelineCancelledException "Cancelled by the invocation") - | _ -> + try + for pipeline in scheduled do + if state.CancellationToken.IsCancellationRequested then + raise (PipelineCancelledException "Cancelled by the invocation") + executed.Add pipeline - runReportingTimings configuration.Output state pipeline - - ExitCode.Success - with - | :? PipelineFailedException -> ExitCode.Failure - | :? PipelineCancelledException -> ExitCode.Cancelled - - finally - // Consolidate only pipelines that ran, respecting each pipeline's reporting destination. - executed - |> Seq.filter (fun pipeline -> GitHubActions.isEnabled pipeline.EnvVars) - |> Seq.groupBy (fun pipeline -> Map.tryFind "GITHUB_STEP_SUMMARY" pipeline.EnvVars) - |> Seq.iter (fun (_, pipelines) -> - let pipelines = Seq.toList pipelines - let allTimings = - pipelines - |> List.choose (fun pipeline -> - let timings = StageTimings.ordered pipeline.Timings - if timings.IsEmpty then None else Some (pipeline.Name, timings)) - Summary.appendGitHub pipelines.Head.EnvVars allTimings) + runReportingTimings configuration.Output asJson state pipeline + + ExitCode.Success + with + | :? PipelineFailedException -> ExitCode.Failure + | :? PipelineCancelledException -> ExitCode.Cancelled + + finally + // Consolidate only pipelines that ran, respecting each pipeline's reporting destination. + executed + |> Seq.filter (fun pipeline -> GitHubActions.isEnabled pipeline.EnvVars) + |> Seq.groupBy (fun pipeline -> Map.tryFind "GITHUB_STEP_SUMMARY" pipeline.EnvVars) + |> Seq.iter (fun (_, pipelines) -> + let pipelines = Seq.toList pipelines + let allTimings = + pipelines + |> List.choose (fun pipeline -> + let timings = StageTimings.ordered pipeline.Timings + if timings.IsEmpty then None else Some (pipeline.Name, timings)) + Summary.appendGitHub pipelines.Head.EnvVars allTimings) + + reportResult configuration.Output parseResult exitCode state.Pipelines + +/// Registers an option the library adds to every command, unless the command declares its name or an alias itself. +let private reserve (command: Command) (input: ActionInput) = + if not (MachineOutput.isTaken command input) then register command input /// Applies a finished spec to a command, registering the options its pipelines declared. let private applyTo (command: Command) (spec: CommandSpec) = @@ -176,11 +202,15 @@ let private applyTo (command: Command) (spec: CommandSpec) = // lets System.CommandLine report the missing subcommand and print help, rather than succeeding silently, // so its `--explain` carries its own rendering — the subcommands it dispatches to. if spec.Pipelines.IsEmpty then - register command Explain.groupingOption + reserve command Explain.groupingOption else - register command Explain.option + reserve command Explain.option + reserve command MachineOutput.report command.SetAction (Func(invoke command spec)) + reserve command MachineOutput.json + reserve command MachineOutput.schemaOption + command /// Rewrites a root command's --help output to call it instead of diff --git a/src/Partas.Build/Builders/Conditions.fs b/src/Partas.Build/Builders/Conditions.fs index 8e15e49..e3849c8 100644 --- a/src/Partas.Build/Builders/Conditions.fs +++ b/src/Partas.Build/Builders/Conditions.fs @@ -15,6 +15,13 @@ type private EBAttribute = EditorBrowsableAttribute let [] private never = EditorBrowsableState.Never let [] private advanced = EditorBrowsableState.Advanced +/// A condition that performs IO or runs work to answer, made by Conditions.effectful. +[] +type EffectfulCondition(description: string, condition: BuildStageIsActive) = + inherit FSharpFunc() + member _.Description = description + override _.Invoke(ctx: StageContext) = condition ctx + /// The leaf conditions, as plain StageContext -> bool functions. /// /// Fun.Build's originals branch on Mode to double as help and verification printers. That mode is not @@ -22,6 +29,33 @@ let [] private advanced = EditorBrowsableState.Advanced /// under Mode.Execution. /// module Conditions = + /// Marks as performing IO or running work to answer, described by + /// . + /// + /// A static --explain reports a marked condition as unevaluated, under its description, and leaves it + /// uncalled. The mark belongs to the returned function value: a lambda calling it is unmarked unless marked + /// itself. whenAll, whenAny and whenNot mark their result when any condition in them is marked. + /// + let effectful (description: string) (condition: BuildStageIsActive): BuildStageIsActive = + unbox (box (EffectfulCondition(description, condition))) + + /// The description of when it is marked effectful. + let tryEffect (condition: BuildStageIsActive): string voption = + match box condition with + | :? EffectfulCondition as condition -> ValueSome condition.Description + | _ -> ValueNone + + /// , marked effectful when any of is, + /// described as over the marked conditions' descriptions. + let combined (name: string) (conditions: BuildStageIsActive list) (condition: BuildStageIsActive): BuildStageIsActive = + match conditions |> List.choose (tryEffect >> ValueOption.toOption) with + | [] -> condition + | described -> + let others = conditions.Length - described.Length + let described = String.Join("; ", described) + if others = 0 then effectful $"%s{name} {{ %s{described} }}" condition + else effectful $"%s{name} {{ %s{described}; %i{others} more }}" condition + let whenPlatform (platform: OSPlatform): BuildStageIsActive = fun _ -> RuntimeInformation.IsOSPlatform platform let whenEnvArg (info: EnvArg): BuildStageIsActive = fun ctx -> @@ -36,18 +70,23 @@ module Conditions = /// The branch is read with git branch --show-current in the stage's working directory. // TODO Phase 6: retarget onto the `Cmd` runner once it exists, so this inherits env vars and cancellation too. - let whenBranches (branches: string seq): BuildStageIsActive = fun ctx -> - try - let startInfo = ProcessStartInfo("git", "branch --show-current", RedirectStandardOutput = true) - startInfo.StandardOutputEncoding <- Text.Encoding.UTF8 - StageContext.getWorkingDir ctx |> ValueOption.iter (fun dir -> startInfo.WorkingDirectory <- dir) - use proc = Process.Start startInfo - let branch = proc.StandardOutput.ReadLine() - proc.WaitForExit() - Seq.contains branch branches - with ex -> - AnsiConsole.MarkupLineInterpolated $"[red]Run git to get branch info failed: {ex.Message}[/]" - false + let whenBranches (branches: #seq): BuildStageIsActive = + let branches = List.ofSeq branches + + let isOnBranch (ctx: StageContext) = + try + let startInfo = ProcessStartInfo("git", "branch --show-current", RedirectStandardOutput = true) + startInfo.StandardOutputEncoding <- Text.Encoding.UTF8 + StageContext.getWorkingDir ctx |> ValueOption.iter (fun dir -> startInfo.WorkingDirectory <- dir) + use proc = Process.Start startInfo + let branch = proc.StandardOutput.ReadLine() + proc.WaitForExit() + List.contains branch branches + with ex -> + AnsiConsole.MarkupLineInterpolated $"[red]Run git to get branch info failed: {ex.Message}[/]" + false + + effectful $"""whenBranch %s{String.Join(", ", branches)}""" isOnBranch let whenBranch (branch: string) = whenBranches [ branch ] @@ -58,9 +97,12 @@ module Conditions = /// , the policy-folded outcome — a condition stage carrying /// continueStageOnFailure reports itself as succeeded even where it failed. /// - let whenStageSucceeds (stage: StageContext): BuildStageIsActive = fun ctx -> - let stage = { stage with ParentContext = ValueSome(StageParent.Stage ctx) } - StageContext.run stage StageIndex.Condition CancellationToken.None |> ScopeReport.continues + let whenStageSucceeds (stage: StageContext): BuildStageIsActive = + let succeeds (ctx: StageContext) = + let stage = { stage with ParentContext = ValueSome(StageParent.Stage ctx) } + StageContext.run stage StageIndex.Condition CancellationToken.None |> ScopeReport.continues + + effectful $"whenStage %s{stage.Name}" succeeds /// The text --explain prints against a stage each of the conditions above turned off. /// @@ -202,7 +244,7 @@ type WhenAnyBuilder() = [] member _.Run(build: BuildConditions): BuildStageIsActive = let conditions = build [] - fun ctx -> conditions |> List.exists (fun condition -> condition ctx) + Conditions.combined "whenAny" conditions (fun ctx -> conditions |> List.exists (fun condition -> condition ctx)) [] type WhenAllBuilder() = @@ -210,7 +252,7 @@ type WhenAllBuilder() = [] member _.Run(build: BuildConditions): BuildStageIsActive = let conditions = build [] - fun ctx -> conditions |> List.forall (fun condition -> condition ctx) + Conditions.combined "whenAll" conditions (fun ctx -> conditions |> List.forall (fun condition -> condition ctx)) [] type WhenNotBuilder() = @@ -218,7 +260,7 @@ type WhenNotBuilder() = [] member _.Run(build: BuildConditions): BuildStageIsActive = let conditions = build [] - fun ctx -> conditions |> List.forall (fun condition -> not (condition ctx)) + Conditions.combined "whenNot" conditions (fun ctx -> conditions |> List.forall (fun condition -> not (condition ctx))) /// Describes one environment variable, in place of a wall of `whenEnvVar` overloads. [] diff --git a/src/Partas.Build/Explain.fs b/src/Partas.Build/Explain.fs index a32ac7b..2530dc8 100644 --- a/src/Partas.Build/Explain.fs +++ b/src/Partas.Build/Explain.fs @@ -3,18 +3,88 @@ namespace Partas.Build open System open System.CommandLine open System.CommandLine.Invocation +open System.Text.Json open Partas.Build.Internal -/// The resolved stage tree of a set of pipelines, as text. +/// How --explain answers a condition that performs IO or runs work to answer. +[] +type ExplainMode = + /// Every condition is called, whenBranch starting git and whenStage running its stage. + | Evaluated + /// A condition marked Conditions.effectful is reported unevaluated and left uncalled; every other + /// condition is called. + | Static + +/// The answer --explain records for one condition of a stage. +[] +type ExplainedConditionState = + | Held + | Failed + /// Marked effectful and left uncalled by a static explanation. + | Unevaluated + /// The condition raised an exception. + | Threw of message: string + /// An earlier condition failed or threw, and the stage's IsActive stops at it. + | NotReached + +/// One condition of a stage, as --explain answered it. +type ExplainedCondition = { + /// The text attributing a skip to the condition. + Reason: string voption + /// The description the condition is marked effectful with. + Effect: string voption + State: ExplainedConditionState +} + +/// Whether a stage would run, as its conditions answered. +[] +type ExplainedStatus = + | Active + /// A condition failed; reason is that condition's own. + | Skipped of reason: string voption + /// Every evaluated condition held, and the conditions listed were left uncalled. + | Unevaluated of effects: string list + /// A condition raised an exception with this message. + | Errored of message: string + +/// A stage as --explain describes it. +type ExplainedStage = { + Name: string + /// The producer the stage declares. + Produces: string voption + /// The producers the stage requires. + Needs: string list + Status: ExplainedStatus + Conditions: ExplainedCondition list + Steps: ExplainedStep list +} + +/// A step as --explain describes it; index counts from one. +/// A label is the step's log form, with every secret masked. +and [] ExplainedStep = + | Step of index: int * label: string voption + | Operation of index: int * label: string voption + | Stage of index: int * stage: ExplainedStage + +/// A pipeline as --explain describes it. +type ExplainedPipeline = { + Name: string + Description: string voption + Stages: ExplainedStage list + Post: ExplainedStage list +} + +/// The resolved stage tree of a set of pipelines, as text or JSON. /// /// Every option a command registers is readable without a ParseResult, so a pipeline can be materialised /// from one and inspected before any step runs. That is what --explain prints. /// -/// Rendering evaluates each stage's IsActive, and a condition may perform read-only IO to answer: -/// whenBranch starts git, and whenStage runs its condition stage in full, side effects -/// included. A skipped stage has its recorded conditions evaluated a second time to attribute the skip, so -/// those conditions run twice. Step functions and producer callbacks are never invoked: a producer appears by -/// name, read off the declaration. +/// A stage's conditions are called in declaration order, each at most once, and stop at the first that fails or +/// throws, as the stage's IsActive does; a condition that throws is reported with its message. +/// Under ExplainMode.Evaluated a condition may perform IO to answer: whenBranch starts git, +/// and whenStage runs its condition stage in full, side effects included. ExplainMode.Static leaves +/// those uncalled. Step functions and producer callbacks are never invoked: a producer appears by name, read +/// off the declaration. /// /// module Explain = @@ -32,86 +102,297 @@ module Explain = let [] private trunk = "│ " let [] private gap = " " - /// The reason of the first recorded condition that is both false and carries one. - let private skipReason (stage: StageContext) = - stage.Conditions - |> List.tryPick (fun condition -> - match condition.Reason with - | ValueSome reason when not (condition.Predicate stage) -> Some reason - | _ -> None) - - /// The producer a stage declares and the producers it requires, by name. - /// Read off the declarations alone: a producer's callback stays uninvoked. - let private dependencies (stage: StageContext) = + let private exceptionMessage (error: exn) = + match error with + | :? Reflection.TargetInvocationException as error when not (isNull error.InnerException) -> error.InnerException.Message + | error -> error.Message + + /// The answer of each condition of , and the status they give the stage. + let private answer (mode: ExplainMode) (stage: StageContext) = + let mutable stopped = false + + let conditions = + stage.Conditions + |> List.map (fun condition -> + let effect = Conditions.tryEffect condition.Predicate + + let state = + if stopped then ExplainedConditionState.NotReached + else + match mode, effect with + | ExplainMode.Static, ValueSome _ -> ExplainedConditionState.Unevaluated + | _ -> + try + if condition.Predicate stage then ExplainedConditionState.Held + else + stopped <- true + ExplainedConditionState.Failed + with error -> + stopped <- true + ExplainedConditionState.Threw(exceptionMessage error) + + { Reason = condition.Reason; Effect = effect; State = state }) + + let status = + conditions + |> List.tryPick (fun condition -> + match condition.State with + | ExplainedConditionState.Failed -> Some(ExplainedStatus.Skipped condition.Reason) + | ExplainedConditionState.Threw message -> Some(ExplainedStatus.Errored message) + | _ -> None) + |> Option.defaultWith (fun () -> + match + conditions + |> List.filter (fun condition -> condition.State = ExplainedConditionState.Unevaluated) + |> List.choose (fun condition -> ValueOption.toOption condition.Effect) + with + | [] -> ExplainedStatus.Active + | effects -> ExplainedStatus.Unevaluated effects) + + conditions, status + + let rec private explainStage (mode: ExplainMode) (stage: StageContext) : ExplainedStage = + let conditions, status = answer mode stage + + { + Name = stage.Name + Produces = stage.Producer |> ValueOption.map _.Name + Needs = stage.Requires |> List.map _.Name + Status = status + Conditions = conditions + Steps = + stage.Steps + |> List.mapi (fun index step -> + match step with + | Step.StepOfStage subStage -> + ExplainedStep.Stage(index + 1, explainStage mode { subStage with ParentContext = ValueSome(StageParent.Stage stage) }) + | Step.StepFn(label, _) -> ExplainedStep.Step(index + 1, label) + | Step.Operation(label, _) -> ExplainedStep.Operation(index + 1, label)) + } + + /// The tree of , with each stage's conditions answered under + /// . + let explain (mode: ExplainMode) (pipelines: PipelineContext list) : ExplainedPipeline list = + // Stages are re-parented onto the pipeline as they are run, and settings resolve by walking that link, + // so a condition reads the same working directory and env vars here as it would under `PipelineContext.run`. + let stages (pipeline: PipelineContext) (stages: StageContext list) = + stages |> List.map (fun stage -> explainStage mode { stage with ParentContext = ValueSome(StageParent.Pipeline pipeline) }) + + pipelines + |> List.map (fun pipeline -> { + Name = pipeline.Name + Description = pipeline.Description + Stages = stages pipeline pipeline.Stages + Post = stages pipeline pipeline.PostStages + }) + + /// The parenthesised suffix naming the producer a stage declares and the producers it requires. + let private dependencies (stage: ExplainedStage) = [ - match stage.Producer with - | ValueSome producer -> $"produces %s{producer.Name}" + match stage.Produces with + | ValueSome producer -> $"produces %s{producer}" | ValueNone -> () - match stage.Requires with + match stage.Needs with | [] -> () - | required -> required |> List.map _.Name |> String.concat ", " |> sprintf "needs %s" + | required -> required |> String.concat ", " |> sprintf "needs %s" ] |> function | [] -> "" | parts -> parts |> String.concat "; " |> sprintf " (%s)" - let private status (stage: StageContext) = - if stage.IsActive stage then "" - else - match skipReason stage with - | Some reason -> $" (skipped: %s{reason})" - | None -> " (skipped)" + let private status (stage: ExplainedStage) = + match stage.Status with + | ExplainedStatus.Active -> "" + | ExplainedStatus.Skipped(ValueSome reason) -> $" (skipped: %s{reason})" + | ExplainedStatus.Skipped ValueNone -> " (skipped)" + | ExplainedStatus.Unevaluated effects -> $""" (unevaluated: %s{String.Join("; ", effects)})""" + | ExplainedStatus.Errored message -> $" (condition failed: %s{message})" /// The tree of , one line per stage and per step. /// /// Text only: rendering writes nothing anywhere. A stage's output sink governs that stage's execution /// output, and a description of what the stage would do is not that. /// - let render (pipelines: PipelineContext list) = + let renderWith (mode: ExplainMode) (pipelines: PipelineContext list) = let lines = ResizeArray() - let rec renderStage (prefix: string) (isLast: bool) (stage: StageContext) = + let rec renderStage (prefix: string) (isLast: bool) (stage: ExplainedStage) = lines.Add $"""%s{prefix}%s{if isLast then lastBranch else branch}%s{stage.Name}%s{dependencies stage}%s{status stage}""" let childPrefix = prefix + (if isLast then gap else trunk) let lastIndex = stage.Steps.Length - 1 stage.Steps - |> List.iteri (fun index step -> - let isLast = index = lastIndex + |> List.iteri (fun position step -> + let isLast = position = lastIndex match step with - | Step.StepOfStage subStage -> - renderStage childPrefix isLast { subStage with ParentContext = ValueSome(StageParent.Stage stage) } - | Step.StepFn(label, _) - | Step.Operation(label, _) -> + | ExplainedStep.Stage(_, subStage) -> renderStage childPrefix isLast subStage + | ExplainedStep.Step(index, label) + | ExplainedStep.Operation(index, label) -> let text = match label with | ValueSome label -> $"$ %s{label}" - | ValueNone -> $"step %i{index + 1}" + | ValueNone -> $"step %i{index}" lines.Add $"""%s{childPrefix}%s{if isLast then lastBranch else branch}%s{text}""") - // Stages are re-parented onto the pipeline as they are run, and settings resolve by walking that link, - // so a condition reads the same working directory and env vars here as it would under `PipelineContext.run`. - let adopt (pipeline: PipelineContext) (stages: StageContext list) = - stages |> List.map (fun stage -> { stage with ParentContext = ValueSome(StageParent.Pipeline pipeline) }) - - let renderStages (stages: StageContext list) = + let renderStages (stages: ExplainedStage list) = let lastIndex = stages.Length - 1 stages |> List.iteri (fun index stage -> renderStage "" (index = lastIndex) stage) - pipelines + explain mode pipelines |> List.iteri (fun index pipeline -> if index > 0 then lines.Add "" lines.Add pipeline.Name - renderStages (adopt pipeline pipeline.Stages) + renderStages pipeline.Stages - if not pipeline.PostStages.IsEmpty then + if not pipeline.Post.IsEmpty then lines.Add "post" - renderStages (adopt pipeline pipeline.PostStages)) + renderStages pipeline.Post) String.Join(Environment.NewLine, lines) + /// The tree of , one line per stage and per step, with every condition + /// evaluated. + let render (pipelines: PipelineContext list) = renderWith ExplainMode.Evaluated pipelines + + let private modeName (mode: ExplainMode) = + match mode with + | ExplainMode.Evaluated -> "evaluated" + | ExplainMode.Static -> "static" + + let private writeCondition (writer: Utf8JsonWriter) (condition: ExplainedCondition) = + writer.WriteStartObject() + + let state, error = + match condition.State with + | ExplainedConditionState.Held -> "held", ValueNone + | ExplainedConditionState.Failed -> "failed", ValueNone + | ExplainedConditionState.Unevaluated -> "unevaluated", ValueNone + | ExplainedConditionState.Threw message -> "threw", ValueSome message + | ExplainedConditionState.NotReached -> "notReached", ValueNone + + writer.WriteString("state", state) + MachineOutput.writeOptionalString writer "reason" condition.Reason + MachineOutput.writeOptionalString writer "effect" condition.Effect + MachineOutput.writeOptionalString writer "error" error + writer.WriteEndObject() + + let rec private writeStage (writer: Utf8JsonWriter) (stage: ExplainedStage) = + writer.WriteStartObject() + writer.WriteString("name", stage.Name) + + match stage.Status with + | ExplainedStatus.Active -> + writer.WriteString("status", "active") + writer.WriteNull "reason" + | ExplainedStatus.Skipped reason -> + writer.WriteString("status", "skipped") + MachineOutput.writeOptionalString writer "reason" reason + | ExplainedStatus.Unevaluated effects -> + writer.WriteString("status", "unevaluated") + writer.WriteString("reason", String.Join("; ", effects)) + | ExplainedStatus.Errored message -> + writer.WriteString("status", "error") + writer.WriteString("reason", message) + + MachineOutput.writeOptionalString writer "produces" stage.Produces + MachineOutput.writeStrings writer "needs" stage.Needs + + writer.WriteStartArray "conditions" + for condition in stage.Conditions do + writeCondition writer condition + writer.WriteEndArray() + + writer.WriteStartArray "steps" + for step in stage.Steps do + writer.WriteStartObject() + + match step with + | ExplainedStep.Step(index, label) -> + writer.WriteNumber("index", index) + writer.WriteString("kind", "step") + MachineOutput.writeOptionalString writer "label" label + | ExplainedStep.Operation(index, label) -> + writer.WriteNumber("index", index) + writer.WriteString("kind", "operation") + MachineOutput.writeOptionalString writer "label" label + | ExplainedStep.Stage(index, subStage) -> + writer.WriteNumber("index", index) + writer.WriteString("kind", "stage") + writer.WriteNull "label" + writer.WritePropertyName "stage" + writeStage writer subStage + + writer.WriteEndObject() + writer.WriteEndArray() + + writer.WriteEndObject() + + let private writeStages (writer: Utf8JsonWriter) (name: string) (stages: ExplainedStage list) = + writer.WriteStartArray name + for stage in stages do + writeStage writer stage + writer.WriteEndArray() + + /// The invocation path of and of each of its subcommands, where the + /// command carries no description. + let undescribed (command: Command) = + let rec walk (parentPath: string) (command: Command) = [ + let path = if String.IsNullOrEmpty parentPath then command.Name else $"%s{parentPath} %s{command.Name}" + if String.IsNullOrWhiteSpace command.Description then path + for subCommand in command.Subcommands do + yield! walk path subCommand + ] + + walk "" command + + /// The tree of , run by , as an indented JSON + /// document. + let toJson (mode: ExplainMode) (command: Command) (pipelines: PipelineContext list) = + let explained = explain mode pipelines + + MachineOutput.document true (fun writer -> + writer.WriteStartObject() + writer.WriteNumber("formatVersion", MachineOutput.FormatVersion) + writer.WriteString("command", command.Name) + writer.WriteString("mode", modeName mode) + + writer.WriteStartArray "pipelines" + for pipeline in explained do + writer.WriteStartObject() + writer.WriteString("name", pipeline.Name) + MachineOutput.writeOptionalString writer "description" pipeline.Description + writeStages writer "stages" pipeline.Stages + writeStages writer "post" pipeline.Post + writer.WriteEndObject() + writer.WriteEndArray() + + MachineOutput.writeStrings writer "undescribedCommands" (undescribed command) + writer.WriteEndObject()) + + /// The immediate subcommands of , as an indented JSON document. + let subcommandsToJson (command: Command) = + MachineOutput.document true (fun writer -> + writer.WriteStartObject() + writer.WriteNumber("formatVersion", MachineOutput.FormatVersion) + writer.WriteString("command", command.Name) + writer.WriteStartArray "pipelines" + writer.WriteEndArray() + + writer.WriteStartArray "subcommands" + for subCommand in command.Subcommands do + writer.WriteStartObject() + writer.WriteString("name", subCommand.Name) + MachineOutput.writeStrings writer "aliases" subCommand.Aliases + MachineOutput.writeOptionalString writer "description" ( + if String.IsNullOrWhiteSpace subCommand.Description then ValueNone else ValueSome subCommand.Description) + writer.WriteEndObject() + writer.WriteEndArray() + + MachineOutput.writeStrings writer "undescribedCommands" (undescribed command) + writer.WriteEndObject()) + /// The immediate subcommands of with their descriptions, as text. /// What a command that runs no pipeline of its own would do: dispatch to one of these. let subcommands (command: Command) = @@ -131,18 +412,6 @@ module Explain = String.Join(Environment.NewLine, lines) - /// The invocation path of and of each of its subcommands, where the - /// command carries no description. - let undescribed (command: Command) = - let rec walk (parentPath: string) (command: Command) = [ - let path = if String.IsNullOrEmpty parentPath then command.Name else $"%s{parentPath} %s{command.Name}" - if String.IsNullOrWhiteSpace command.Description then path - for subCommand in command.Subcommands do - yield! walk path subCommand - ] - - walk "" command - /// followed by the invocation paths under that still /// carry no description. let private report (command: Command) (body: string) = @@ -184,5 +453,7 @@ module Explain = option.Action <- { new SynchronousCommandLineAction() with member _.Invoke(parseResult: ParseResult) = - parseResult.InvocationConfiguration.Output.WriteLine (ofSubcommands parseResult.CommandResult.Command) + let command = parseResult.CommandResult.Command + let text = if MachineOutput.isSet MachineOutput.json parseResult then subcommandsToJson command else ofSubcommands command + parseResult.InvocationConfiguration.Output.WriteLine text 0 }) diff --git a/src/Partas.Build/MachineOutput.fs b/src/Partas.Build/MachineOutput.fs new file mode 100644 index 0000000..7fb5334 --- /dev/null +++ b/src/Partas.Build/MachineOutput.fs @@ -0,0 +1,266 @@ +namespace Partas.Build + +open System +open System.Collections +open System.IO +open System.Text +open System.Text.Encodings.Web +open System.Text.Json +open System.CommandLine +open System.CommandLine.Completions +open System.CommandLine.Invocation + +/// The options selecting machine-readable output, and the JSON description of a command tree. +/// +/// Every command registers --json and --schema; a command that runs pipelines also registers +/// --report. A command that already declares one of these names, or an alias of one, keeps its own option +/// and goes without the library's. +/// +/// Under --json, --explain writes its tree as one JSON document, evaluated statically, and a run +/// writes its RunResult as one line of compact JSON, the last line the run writes to the invocation's +/// output, in place of the timing table. Step output is unaffected, and still reaches the console unless the +/// stage captures or silences it: a consumer reading stdout reads the last line, or reads --report. +/// +/// +module MachineOutput = + /// The version of every JSON document the library writes. + /// Incremented on a change that renames or removes a property, or changes a property's type. + [] + let FormatVersion = 1 + + /// A JSON document written by , as text. + let document (indented: bool) (write: Utf8JsonWriter -> unit) = + use stream = new MemoryStream() + + do + let options = JsonWriterOptions(Indented = indented, Encoder = JavaScriptEncoder.UnsafeRelaxedJsonEscaping) + use writer = new Utf8JsonWriter(stream, options) + write writer + writer.Flush() + + Encoding.UTF8.GetString(stream.ToArray()) + + /// Writes as a JSON string, or null for ValueNone. + let writeOptionalString (writer: Utf8JsonWriter) (name: string) (value: string voption) = + match value with + | ValueSome value -> writer.WriteString(name, value) + | ValueNone -> writer.WriteNull name + + /// Writes as a JSON array of strings. + let writeStrings (writer: Utf8JsonWriter) (name: string) (values: string seq) = + writer.WriteStartArray name + for value in values do + writer.WriteStringValue value + writer.WriteEndArray() + + let private optionalText (text: string) = if String.IsNullOrWhiteSpace text then ValueNone else ValueSome text + + /// The JSON type name of , with an F# option read as the type it wraps. + let rec private typeName (valueType: Type) = + if valueType.IsGenericType && valueType.GetGenericTypeDefinition() = typedefof> then + typeName (valueType.GetGenericArguments()[0]) + elif valueType.IsGenericType && valueType.GetGenericTypeDefinition() = typedefof> then + typeName (valueType.GetGenericArguments()[0]) + elif valueType = typeof then "boolean" + elif valueType = typeof then "string" + elif valueType = typeof then "string" + elif valueType.IsEnum then "enum" + elif + [ typeof; typeof; typeof; typeof; typeof; typeof ] + |> List.contains valueType + then "integer" + elif [ typeof; typeof; typeof ] |> List.contains valueType then "number" + elif valueType = typeof then "file" + elif valueType = typeof then "directory" + elif valueType = typeof then "path" + elif valueType.IsArray then typeName (valueType.GetElementType()) + "[]" + elif valueType <> typeof && typeof.IsAssignableFrom valueType && valueType.IsGenericType then + typeName (valueType.GetGenericArguments()[0]) + "[]" + else valueType.Name + + /// Writes a default value: an F# option as its content or null, a sequence as an array, and anything + /// without a JSON counterpart as its ToString. + let rec private writeValue (writer: Utf8JsonWriter) (value: obj) = + match value with + | null -> writer.WriteNullValue() + | :? bool as value -> writer.WriteBooleanValue value + | :? string as value -> writer.WriteStringValue value + | :? int as value -> writer.WriteNumberValue value + | :? int64 as value -> writer.WriteNumberValue value + | :? float as value -> writer.WriteNumberValue value + | :? decimal as value -> writer.WriteNumberValue value + | :? FileSystemInfo as value -> writer.WriteStringValue(value.ToString()) + | :? Enum as value -> writer.WriteStringValue(value.ToString()) + | _ -> + let valueType = value.GetType() + + if valueType.IsGenericType && valueType.GetGenericTypeDefinition() = typedefof> then + writeValue writer (valueType.GetProperty("Value").GetValue value) + elif valueType.IsGenericType && valueType.GetGenericTypeDefinition() = typedefof> then + match valueType.GetProperty("IsSome").GetValue value with + | :? bool as isSome when isSome -> writeValue writer (valueType.GetProperty("Value").GetValue value) + | _ -> writer.WriteNullValue() + else + match value with + | :? IEnumerable as values -> + writer.WriteStartArray() + for value in values do + writeValue writer value + writer.WriteEndArray() + | _ -> writer.WriteStringValue(value.ToString()) + + /// The default of a symbol, evaluated without a parse: a factory that reads the parse it is given fails, and + /// its default is reported absent. + let private tryDefault (hasDefault: bool) (getDefault: unit -> obj) = + if not hasDefault then ValueNone + else + try ValueSome(getDefault ()) with _ -> ValueNone + + /// The values a symbol lists for completion, which include those acceptOnlyFromAmong and + /// mapFromAmong restrict it to. A boolean lists none. + let private choices (valueType: Type) (complete: unit -> CompletionItem seq) = + if valueType = typeof || valueType = typeof then [] + else + try complete () |> Seq.map _.Label |> Seq.distinct |> List.ofSeq with _ -> [] + + let private writeArity (writer: Utf8JsonWriter) (arity: ArgumentArity) = + writer.WriteStartObject "arity" + writer.WriteNumber("min", arity.MinimumNumberOfValues) + + // System.CommandLine's "unbounded" is a large finite number. + if arity.MaximumNumberOfValues >= ArgumentArity.ZeroOrMore.MaximumNumberOfValues then writer.WriteNull "max" + else writer.WriteNumber("max", arity.MaximumNumberOfValues) + + writer.WriteEndObject() + + let private writeDefault (writer: Utf8JsonWriter) (value: obj voption) = + match value with + | ValueSome value -> + writer.WriteBoolean("hasDefault", true) + writer.WritePropertyName "default" + writeValue writer value + | ValueNone -> + writer.WriteBoolean("hasDefault", false) + writer.WriteNull "default" + + let private writeOption (writer: Utf8JsonWriter) (option: Option) = + writer.WriteStartObject() + writer.WriteString("name", option.Name) + writeStrings writer "aliases" option.Aliases + writeOptionalString writer "description" (optionalText option.Description) + writer.WriteString("type", typeName option.ValueType) + writer.WriteString("clrType", option.ValueType.FullName) + writer.WriteBoolean("required", option.Required) + writer.WriteBoolean("hidden", option.Hidden) + writer.WriteBoolean("recursive", option.Recursive) + writeArity writer option.Arity + writeDefault writer (tryDefault option.HasDefaultValue option.GetDefaultValue) + writeStrings writer "choices" (choices option.ValueType (fun () -> option.GetCompletions CompletionContext.Empty)) + writer.WriteEndObject() + + let private writeArgument (writer: Utf8JsonWriter) (argument: Argument) = + writer.WriteStartObject() + writer.WriteString("name", argument.Name) + writeOptionalString writer "description" (optionalText argument.Description) + writer.WriteString("type", typeName argument.ValueType) + writer.WriteString("clrType", argument.ValueType.FullName) + writer.WriteBoolean("hidden", argument.Hidden) + writeArity writer argument.Arity + writeDefault writer (tryDefault argument.HasDefaultValue argument.GetDefaultValue) + writeStrings writer "choices" (choices argument.ValueType (fun () -> argument.GetCompletions CompletionContext.Empty)) + writer.WriteEndObject() + + let rec private writeCommand (writer: Utf8JsonWriter) (command: Command) = + writer.WriteStartObject() + writer.WriteString("name", command.Name) + writeStrings writer "aliases" command.Aliases + writeOptionalString writer "description" (optionalText command.Description) + writer.WriteBoolean("hidden", command.Hidden) + writer.WriteBoolean("runsPipelines", not (isNull command.Action)) + + writer.WriteStartArray "options" + for option in command.Options do + writeOption writer option + writer.WriteEndArray() + + writer.WriteStartArray "arguments" + for argument in command.Arguments do + writeArgument writer argument + writer.WriteEndArray() + + writer.WriteStartArray "subcommands" + for subCommand in command.Subcommands do + writeCommand writer subCommand + writer.WriteEndArray() + + writer.WriteEndObject() + + /// and every command under it, with each option and argument it takes, + /// as an indented JSON document. + /// + /// Each option lists its name, aliases, description, type, whether it is required, hidden or recursive, its + /// arity, its default and the values it is restricted to. runsPipelines is false for a command + /// that only dispatches to its subcommands. + /// + let schema (command: Command) = + document true (fun writer -> + writer.WriteStartObject() + writer.WriteNumber("formatVersion", FormatVersion) + writer.WritePropertyName "command" + writeCommand writer command + writer.WriteEndObject()) + + /// The --json flag. + let json: ActionInput = + Input.option "--json" + |> Input.desc "Write JSON instead of text: the --explain tree, or the run result as the last line of output" + |> Input.def false + + /// The --report option: a file the run result is written to as JSON. + /// Written once the command's pipelines finish, whether they succeeded or not, and never under --explain. + let report: ActionInput = + Input.optionMaybe "--report" + |> Input.desc "Write the run result as JSON to this file" + |> Input.helpName "path" + + /// The --schema flag, which prints schema for the command it is given to, and exits. + let schemaOption: ActionInput = + Input.option "--schema" + |> Input.desc "Print this command, its options and its subcommands as JSON, and exit" + |> Input.def false + |> Input.editOption (fun option -> + option.Action <- + { new SynchronousCommandLineAction() with + member _.Invoke(parseResult: ParseResult) = + parseResult.InvocationConfiguration.Output.WriteLine(schema parseResult.CommandResult.Command) + 0 }) + + /// Whether is registered on the parsed command and given on the command line + /// or by default as true. + let isSet (input: ActionInput) (parseResult: ParseResult) = + match input.Source with + | ParsedOption option -> + match parseResult.GetResult option with + | null -> false + | _ -> input.GetValue parseResult + | _ -> false + + /// The value of when it is registered on the parsed command. + let tryValue (input: ActionInput<'T option>) (parseResult: ParseResult) = + match input.Source with + | ParsedOption option -> + match parseResult.GetResult option with + | null -> None + | _ -> input.GetValue parseResult + | _ -> None + + /// Whether already declares the name or an alias of . + let isTaken (command: Command) (input: ActionInput) = + match input.Source with + | ParsedOption option -> + let names = Seq.append [ option.Name ] option.Aliases |> Set.ofSeq + command.Options + |> Seq.exists (fun existing -> + not (obj.ReferenceEquals(existing, option)) + && (names.Contains existing.Name || existing.Aliases |> Seq.exists names.Contains)) + | _ -> false diff --git a/src/Partas.Build/Partas.Build.fsproj b/src/Partas.Build/Partas.Build.fsproj index 28fb40b..ed632d3 100644 --- a/src/Partas.Build/Partas.Build.fsproj +++ b/src/Partas.Build/Partas.Build.fsproj @@ -38,6 +38,7 @@ + @@ -64,6 +65,11 @@ + + + + + diff --git a/src/Partas.Build/RunResult.fs b/src/Partas.Build/RunResult.fs index 24632c2..079b2ee 100644 --- a/src/Partas.Build/RunResult.fs +++ b/src/Partas.Build/RunResult.fs @@ -1,5 +1,8 @@ namespace Partas.Build +open System +open System.Text.Json + /// The process exit codes a command invocation ends with. /// /// UsageError covers every failure to parse or validate the command line, dependency validation included, @@ -72,3 +75,117 @@ type RunResult = { /// Every failure recorded by the run, absorbed failures among them, in pre-order. member this.Failures = this.Reports |> List.collect ScopeReport.failures + +module RunResult = + let private outcomeName (outcome: RunOutcome) = + match outcome with + | RunOutcome.Succeeded -> "succeeded" + | RunOutcome.Failed -> "failed" + | RunOutcome.UsageError -> "usageError" + | RunOutcome.Cancelled -> "cancelled" + + let private writeStageOutcome (writer: Utf8JsonWriter) (outcome: StageOutcome) = + match outcome with + | StageOutcome.Succeeded -> + writer.WriteString("outcome", "succeeded") + writer.WriteNull "error" + | StageOutcome.Skipped -> + writer.WriteString("outcome", "skipped") + writer.WriteNull "error" + | StageOutcome.Failed error -> + writer.WriteString("outcome", "failed") + writer.WriteString("error", error) + + let private writeCause (writer: Utf8JsonWriter) (cause: FailureCause) = + writer.WriteStartObject "cause" + + match cause with + | FailureCause.Command(command, exitCode, _) -> + writer.WriteString("kind", "command") + writer.WriteString("command", command) + writer.WriteNumber("exitCode", exitCode) + | FailureCause.Start(executable, error) -> + writer.WriteString("kind", "start") + writer.WriteString("executable", executable) + writer.WriteString("exceptionType", error.GetType().FullName) + | FailureCause.Raised error -> + writer.WriteString("kind", "raised") + writer.WriteString("exceptionType", error.GetType().FullName) + | FailureCause.TimedOut -> writer.WriteString("kind", "timedOut") + | FailureCause.Reported _ -> writer.WriteString("kind", "reported") + + writer.WriteString("message", FailureCause.describe cause) + writer.WriteEndObject() + + let rec private writeReport (writer: Utf8JsonWriter) (report: ScopeReport) = + writer.WriteStartObject() + writer.WriteString("name", report.Name) + writer.WriteString("address", ScopeAddress.text report.Address) + + writer.WriteStartArray "path" + for ordinal in report.Address.Path do + writer.WriteNumberValue ordinal + writer.WriteEndArray() + + writeStageOutcome writer report.Outcome + writer.WriteBoolean("propagates", report.Propagates) + + writer.WriteStartArray "failures" + for failure in report.Failures do + writer.WriteStartObject() + + if failure.Index = StepFailure.NoStep then writer.WriteNull "step" + else writer.WriteNumber("step", failure.Index) + + MachineOutput.writeOptionalString writer "label" failure.Label + writeCause writer failure.Cause + writer.WriteEndObject() + writer.WriteEndArray() + + writer.WriteStartArray "nested" + for nested in report.Nested do + writeReport writer nested + writer.WriteEndArray() + + writer.WriteEndObject() + + let private writeTiming (writer: Utf8JsonWriter) (timing: StageTiming) = + writer.WriteStartObject() + writer.WriteString("name", timing.Name) + writer.WriteNumber("depth", timing.Depth) + writer.WriteNumber("elapsedMs", Math.Round(timing.Elapsed.TotalMilliseconds, 3)) + writeStageOutcome writer timing.Outcome + writer.WriteEndObject() + + /// as a JSON document, one line long unless . + /// + /// Each pipeline carries its reports, nested as the scopes nest, and its timings in pre-order. A failure's + /// step counts from zero and is null for a cause no step produced. A command's line is its log + /// form, with every secret masked. + /// + let toJson (indented: bool) (result: RunResult) = + MachineOutput.document indented (fun writer -> + writer.WriteStartObject() + writer.WriteNumber("formatVersion", MachineOutput.FormatVersion) + writer.WriteNumber("exitCode", result.ExitCode) + writer.WriteString("outcome", outcomeName result.Outcome) + + writer.WriteStartArray "pipelines" + for pipeline in result.Pipelines do + writer.WriteStartObject() + writer.WriteString("name", pipeline.Name) + + writer.WriteStartArray "reports" + for report in pipeline.Reports do + writeReport writer report + writer.WriteEndArray() + + writer.WriteStartArray "timings" + for timing in pipeline.Timings do + writeTiming writer timing + writer.WriteEndArray() + + writer.WriteEndObject() + writer.WriteEndArray() + + writer.WriteEndObject()) diff --git a/tests/Partas.Build.ExternalAnnotations.Tests/CommandTests.fs b/tests/Partas.Build.ExternalAnnotations.Tests/CommandTests.fs index 1267744..eb12d4d 100644 --- a/tests/Partas.Build.ExternalAnnotations.Tests/CommandTests.fs +++ b/tests/Partas.Build.ExternalAnnotations.Tests/CommandTests.fs @@ -17,8 +17,9 @@ open Expecto open Partas.Build.ExternalAnnotations open Partas.Build.ExternalAnnotationsTests.Helpers -/// The option names a finished command registered. Partas.Build puts --explain on every command -/// that runs a pipeline, so it appears here beside the ones the stages asked for. +/// The option names a finished command registered. Partas.Build puts --explain, --json, +/// --report and --schema on every command that runs a pipeline, so they appear here beside the +/// ones the stages asked for. let private optionsOf (command: Command) = [ for option in command.Options -> option.Name ] |> List.sort @@ -46,7 +47,7 @@ let tests = test "registers exactly what its stage reads" { Expect.equal (optionsOf generateCommand) - [ "--assembly"; "--attribute"; "--explain"; "--output"; "--strict" ] + [ "--assembly"; "--attribute"; "--explain"; "--json"; "--output"; "--report"; "--schema"; "--strict" ] "the options" } @@ -62,7 +63,7 @@ let tests = } test "registers exactly what its stage reads" { - Expect.equal (optionsOf verifyCommand) [ "--explain"; "--min-members"; "--package" ] "the options" + Expect.equal (optionsOf verifyCommand) [ "--explain"; "--json"; "--min-members"; "--package"; "--report"; "--schema" ] "the options" } test "rejects an option belonging to another command" { @@ -77,7 +78,7 @@ let tests = } test "registers exactly what its stage reads" { - Expect.equal (optionsOf initCommand) [ "--annotations-tool"; "--directory"; "--explain"; "--force" ] "the options" + Expect.equal (optionsOf initCommand) [ "--annotations-tool"; "--directory"; "--explain"; "--force"; "--json"; "--report"; "--schema" ] "the options" } ] diff --git a/tests/Partas.Build.Tests/CommandTests.fs b/tests/Partas.Build.Tests/CommandTests.fs index 399c5fc..cd6b303 100644 --- a/tests/Partas.Build.Tests/CommandTests.fs +++ b/tests/Partas.Build.Tests/CommandTests.fs @@ -5,6 +5,7 @@ open System.IO open System.Reflection open System.CommandLine open System.CommandLine.Invocation +open System.Text.Json open Expecto open Partas.Build open Partas.Build.Internal @@ -18,9 +19,9 @@ let private options () = Input.option "--verbose" |> Input.def false /// The command's own options, minus the `--help` System.CommandLine adds to every command and the -/// `--explain` the library adds to every command that runs a pipeline. +/// `--explain`, `--json`, `--report` and `--schema` the library adds to every command that runs a pipeline. let private declared (command: Command) = - optionNames command |> List.filter (fun name -> name <> "--help" && name <> "--explain") + optionNames command |> List.filter (fun name -> not (List.contains name [ "--help"; "--explain"; "--json"; "--report"; "--schema" ])) [] let tests = @@ -582,3 +583,144 @@ let invocation = Expect.isEmpty explainResult.Pipelines "--explain runs no pipeline" } ] + +let private property (name: string) (element: JsonElement) = element.GetProperty name +let private items (element: JsonElement) = [ for item in element.EnumerateArray() -> item ] +let private named (name: string) (elements: JsonElement list) = + elements |> List.find (fun element -> (element |> property "name").GetString() = name) + +/// A root whose one pipeline runs a stage that passes and a stage that fails, loud enough to print a timing table. +let private failingRoot () = + Command.root { + pipeline "build" { + stage "restore" { run noop } + stage "compile" { run (fun (_: StageContext) -> failwith "compile failed") } + } + } + +[] +let machineOutputTests = + testList "machine output" [ + test "--json writes the run result as the only line of the invocation's output" { + use output = new StringWriter() + let result = Helpers.quietly (fun () -> (failingRoot ()).Invoke([ "--json" ], output = output)) + + let lines = output.ToString().Split([| '\n' |], StringSplitOptions.RemoveEmptyEntries) + Expect.equal lines.Length 1 "the result replaces the timing table, on one line" + + let document = JsonDocument.Parse(lines[0]).RootElement + Expect.equal ((document |> property "exitCode").GetInt32()) result.ExitCode "the exit code matches the result" + Expect.equal ((document |> property "outcome").GetString()) "failed" "the outcome is named" + + let pipeline = document |> property "pipelines" |> items |> List.exactlyOne + Expect.equal ((pipeline |> property "name").GetString()) "build" "the pipeline is named" + Expect.equal [ for timing in pipeline |> property "timings" |> items -> (timing |> property "name").GetString() ] [ "restore"; "compile" ] "every stage is timed" + + let compile = pipeline |> property "reports" |> items |> named "compile" + Expect.equal ((compile |> property "outcome").GetString()) "failed" "the failed stage reports itself failed" + Expect.isTrue ((compile |> property "propagates").GetBoolean()) "and fails the pipeline" + let failure = compile |> property "failures" |> items |> List.exactlyOne + Expect.equal ((failure |> property "step").GetInt32()) 0 "the failing step is indexed from zero" + Expect.equal ((failure |> property "cause" |> property "kind").GetString()) "raised" "the cause is classified" + Expect.stringContains ((failure |> property "cause" |> property "message").GetString()) "compile failed" "and described" + } + + test "--json keeps a failed command's secret out of the result" { + let key = "super-secret-key" + let root = Command.root { + pipeline "publish" { stage "push" { run (Helpers.ProcessFixture.command [ "no-such-mode" ] |> Cmd.secretArg key) } } + } + use output = new StringWriter() + + let result = Helpers.quietly (fun () -> root.Invoke([ "--json" ], output = output)) + let json = output.ToString() + + Expect.equal result.ExitCode ExitCode.Failure "the command fails" + Expect.isFalse (json.Contains key) "the secret stays out of the result" + let cause = (JsonDocument.Parse json).RootElement |> property "pipelines" |> items |> List.exactlyOne |> property "reports" |> items |> named "push" |> property "failures" |> items |> List.exactlyOne |> property "cause" + Expect.isNonEmpty ((cause |> property "message").GetString()) "the failure is described" + } + + test "--report writes the run result to a file and nothing to the output" { + let path = Path.Combine(Path.GetTempPath(), $"partas-build-report-{Guid.NewGuid():N}", "result.json") + use output = new StringWriter() + + try + let result = Helpers.quietly (fun () -> (recordingRoot (ResizeArray())).Invoke([ "--report"; path ], output = output)) + + Expect.equal result.ExitCode ExitCode.Success "the run passes" + Expect.equal (output.ToString()) "" "the report stays out of the output" + let document = JsonDocument.Parse(File.ReadAllText path).RootElement + Expect.equal ((document |> property "outcome").GetString()) "succeeded" "the file holds the result" + Expect.equal (document |> property "pipelines" |> items |> List.exactlyOne |> property "timings" |> items |> List.length) 2 "with every stage it ran" + finally + if Directory.Exists(Path.GetDirectoryName path) then Directory.Delete(Path.GetDirectoryName path, true) + } + + test "--schema describes the command tree with types, defaults and choices, and runs nothing" { + let seen = ResizeArray() + let configuration = + Input.option "--configuration" + |> Input.alias "-c" + |> Input.desc "The build configuration" + |> Input.def "Release" + |> Input.acceptOnlyFromAmong [ "Debug"; "Release" ] + + let build = command "build" { + description "builds" + input { + let! cfg = configuration + return stage "compile" { run (fun (_: StageContext) -> seen.Add cfg) } + } + } + + let root = Command.root { description "the root"; addCommand build } + use output = new StringWriter() + + let result = root.Invoke([ "--schema" ], output = output) + + Expect.equal result.ExitCode ExitCode.Success "the schema exits zero" + Expect.isEmpty seen "and runs nothing" + let document = JsonDocument.Parse(output.ToString()).RootElement + let rootCommand = document |> property "command" + Expect.isFalse ((rootCommand |> property "runsPipelines").GetBoolean()) "the root only dispatches" + let buildCommand = rootCommand |> property "subcommands" |> items |> named "build" + Expect.equal ((buildCommand |> property "description").GetString()) "builds" "a subcommand carries its description" + Expect.isTrue ((buildCommand |> property "runsPipelines").GetBoolean()) "and says it runs pipelines" + + let option = buildCommand |> property "options" |> items |> named "--configuration" + Expect.equal [ for alias in option |> property "aliases" |> items -> alias.GetString() ] [ "-c" ] "aliases are listed" + Expect.equal ((option |> property "type").GetString()) "string" "the type is named" + Expect.equal ((option |> property "description").GetString()) "The build configuration" "the description is carried" + Expect.isTrue ((option |> property "hasDefault").GetBoolean()) "the default is reported" + Expect.equal ((option |> property "default").GetString()) "Release" "with its value" + Expect.equal [ for choice in option |> property "choices" |> items -> choice.GetString() ] [ "Debug"; "Release" ] "the accepted values are listed" + Expect.isFalse ((option |> property "required").GetBoolean()) "an option with a default is not required" + + use subOutput = new StringWriter() + root.Invoke([ "build"; "--schema" ], output = subOutput) |> ignore + let subDocument = JsonDocument.Parse(subOutput.ToString()).RootElement + Expect.equal ((subDocument |> property "command" |> property "name").GetString()) "build" "a subcommand's schema starts at the subcommand" + } + + test "a command that declares --json keeps its own option" { + let seen = ResizeArray() + let json = Input.option "--json" |> Input.def "" + + let built = command "emit" { + input { + let! path = json + return stage "write" { run (fun (_: StageContext) -> seen.Add path) } + } + } + + let jsonOptions = built.Options |> Seq.filter (fun option -> option.Name = "--json") |> List.ofSeq + Expect.equal jsonOptions.Length 1 "the library's flag gives way" + Expect.equal (List.exactlyOne jsonOptions).ValueType typeof "the consumer's option stays" + + let code = Helpers.quietly (fun () -> built.Parse("--json out.json").Invoke()) + Expect.equal code 0 "the command still runs" + Expect.equal (List.ofSeq seen) [ "out.json" ] "and reads its own option" + } + ] + diff --git a/tests/Partas.Build.Tests/CompositionTests.fs b/tests/Partas.Build.Tests/CompositionTests.fs index e7afe62..58979d8 100644 --- a/tests/Partas.Build.Tests/CompositionTests.fs +++ b/tests/Partas.Build.Tests/CompositionTests.fs @@ -36,10 +36,10 @@ let private countingBlock (reads: int ref) name (config: ActionInput) = } /// The command's own options, minus the `--help` System.CommandLine adds to every command and the -/// `--explain` the library adds to every command that runs a pipeline. +/// `--explain`, `--json`, `--report` and `--schema` the library adds to every command that runs a pipeline. let private declared (command: Command) = [ for option in command.Options -> option.Name ] - |> List.filter (fun name -> name <> "--help" && name <> "--explain") + |> List.filter (fun name -> not (List.contains name [ "--help"; "--explain"; "--json"; "--report"; "--schema" ])) [] let tests = diff --git a/tests/Partas.Build.Tests/ExplainTests.fs b/tests/Partas.Build.Tests/ExplainTests.fs index ae44a0e..b4fcc83 100644 --- a/tests/Partas.Build.Tests/ExplainTests.fs +++ b/tests/Partas.Build.Tests/ExplainTests.fs @@ -2,6 +2,7 @@ open System open System.IO +open System.Text.Json open Expecto open Partas.Build open Partas.Build.Internal @@ -18,6 +19,22 @@ let private capturingOut (fn: unit -> 'T) = finally Console.SetOut original +/// Invokes on with its output captured, and answers the +/// exit code alongside the output parsed as one JSON document. +let private invokeJson (command: System.CommandLine.Command) (commandLine: string) = + use output = new StringWriter() + let exitCode = command.Parse(commandLine).Invoke(System.CommandLine.InvocationConfiguration(Output = output)) + exitCode, JsonDocument.Parse(output.ToString()).RootElement.Clone() + +let private property (name: string) (element: JsonElement) = element.GetProperty name + +let private items (element: JsonElement) = [ for item in element.EnumerateArray() -> item ] + +let private stageNamed (name: string) (pipeline: JsonElement) = + pipeline |> property "stages" |> items |> List.find (fun stage -> (stage |> property "name").GetString() = name) + +let private text (element: JsonElement) = element.GetString() + [] let tests = testList "explain" [ @@ -170,4 +187,137 @@ let tests = Expect.stringContains printed "child" "the subcommand is named" Expect.stringContains printed "does the thing" "with its description" } + test "explain --json describes stages, steps, skips and dependencies as one document" { + let source = Producer.define "compile" (InputSpec.ret ()) DependencySpec.empty (fun _ _ -> Operation.ret 42) + + let built = + command "build" { + description "builds" + pipeline "p" { + stage "restore" { run "dotnet restore Foo.slnx" } + stage "guarded" { whenEnvVar "PARTAS_BUILD_EXPLAIN_UNSET"; run "dotnet --version" } + Producer.stage source + Stage.consuming "pack" (DependencySpec.require source) (fun (_: int) -> Operation.ret ()) + } + } + + let code, document = invokeJson built "--explain --json" + + Expect.equal code 0 "explain exits zero" + Expect.equal (document |> property "command" |> text) "build" "the command is named" + Expect.equal (document |> property "mode" |> text) "static" "JSON explain is static by default" + let pipeline = document |> property "pipelines" |> items |> List.exactlyOne + Expect.equal (pipeline |> property "name" |> text) "p" "the pipeline is named" + + let restore = stageNamed "restore" pipeline + Expect.equal (restore |> property "status" |> text) "active" "an unconditional stage is active" + let step = restore |> property "steps" |> items |> List.exactlyOne + Expect.equal (step |> property "kind" |> text) "step" "a command step is a step" + Expect.equal (step |> property "label" |> text) "dotnet restore Foo.slnx" "with its command line as its label" + Expect.equal ((step |> property "index").GetInt32()) 1 "indexed from one" + + let guarded = stageNamed "guarded" pipeline + Expect.equal (guarded |> property "status" |> text) "skipped" "a failed pure condition is evaluated even statically" + Expect.equal (guarded |> property "reason" |> text) "env var PARTAS_BUILD_EXPLAIN_UNSET is unset" "and names itself" + let condition = guarded |> property "conditions" |> items |> List.exactlyOne + Expect.equal (condition |> property "state" |> text) "failed" "the condition records its answer" + + Expect.equal (stageNamed "compile" pipeline |> property "produces" |> text) "compile" "the producer stage says what it declares" + Expect.equal [ for need in stageNamed "pack" pipeline |> property "needs" |> items -> text need ] [ "compile" ] "the consumer names its needs" + } + + test "explain --json masks a secret in a step's label" { + let key = "super-secret-key" + let built = command "publish" { pipeline "p" { stage "push" { runSensitive $"dotnet nuget push pkg -k {key}" } } } + + use output = new StringWriter() + built.Parse("--explain --json").Invoke(System.CommandLine.InvocationConfiguration(Output = output)) |> ignore + let json = output.ToString() + + Expect.isFalse (json.Contains key) "the JSON form is as safe as the text form" + Expect.stringContains json "***" "the hole is masked, not omitted" + JsonDocument.Parse json |> ignore + } + + test "static explain runs no condition stage and reports it unevaluated" { + let mutable ran = 0 + let probe = stage "probe" { run (fun (_: StageContext) -> ran <- ran + 1) } + + let built = + command "build" { + pipeline "p" { + stage "viaOperation" { when' probe; run "dotnet --version" } + stage "viaBuilder" { whenStage "inline-probe" { run (fun (_: StageContext) -> ran <- ran + 1) }; run "dotnet --version" } + stage "viaWhenAll" { whenAll { when' probe; envVar "PATH" }; run "dotnet --version" } + stage "onBranch" { whenBranch "main"; run "dotnet --version" } + } + } + + let code, document = invokeJson built "--explain --json" + let rendered = Explain.renderWith ExplainMode.Static [ pipeline "p" { stage "s" { when' probe; run "dotnet --version" } } ] + + Expect.equal code 0 "explain exits zero" + Expect.equal ran 0 "no condition stage ran" + Expect.stringContains rendered "(unevaluated: whenStage probe)" "the text form names the condition left uncalled" + + let pipeline = document |> property "pipelines" |> items |> List.exactlyOne + + for name, effect in + [ "viaOperation", "whenStage probe" + "viaBuilder", "whenStage inline-probe" + "viaWhenAll", "whenAll { whenStage probe; 1 more }" + "onBranch", "whenBranch main" ] do + let explained = stageNamed name pipeline + Expect.equal (explained |> property "status" |> text) "unevaluated" $"%s{name} is unevaluated" + let condition = explained |> property "conditions" |> items |> List.exactlyOne + Expect.equal (condition |> property "state" |> text) "unevaluated" $"%s{name}'s condition is unevaluated" + Expect.equal (condition |> property "effect" |> text) effect $"%s{name}'s condition is described" + } + + test "evaluated explain runs a failing condition stage once" { + let mutable ran = 0 + let probe = stage "probe" { run (fun (_: StageContext) -> ran <- ran + 1; failwith "not today") } + let built = pipeline "p" { stage "guarded" { when' probe; run "dotnet --version" } } + + let rendered = Helpers.quietly (fun () -> Explain.render [ built ]) + + Expect.equal ran 1 "the skip is attributed without evaluating the condition again" + Expect.stringContains rendered "(skipped: condition stage probe failed)" "the skip still names its condition" + } + + test "explain renders a condition that throws as its message" { + let throwing: BuildStageIsActive = fun _ -> failwith "no answer" + let built = pipeline "p" { stage "fragile" { throwing; run "dotnet --version" }; stage "after" { run "dotnet --info" } } + + let rendered = Explain.render [ built ] + let json = Explain.toJson ExplainMode.Evaluated (System.CommandLine.Command "c") [ built ] + let fragile = JsonDocument.Parse(json).RootElement |> property "pipelines" |> items |> List.exactlyOne |> stageNamed "fragile" + + Expect.stringContains rendered "fragile (condition failed: no answer)" "the failure is rendered against its stage" + Expect.stringContains rendered "after" "and the stages after it are still described" + Expect.equal (fragile |> property "status" |> text) "error" "the JSON form reports the error" + Expect.equal (fragile |> property "reason" |> text) "no answer" "with its message" + } + + test "explain stops at the first condition that fails, as IsActive does" { + let mutable reached = false + let later: BuildStageIsActive = fun _ -> reached <- true; true + let built = pipeline "p" { stage "s" { when' false; later; run "dotnet --version" } } + + Explain.render [ built ] |> ignore + + Expect.isFalse reached "a condition after a failed one is not called" + } + + test "explain --json on a command with no pipelines lists its subcommands" { + let child = command "child" { description "does the thing"; pipeline "p" { stage "s" { run (fun (_: StageContext) -> ()) } } } + let built = command "group" { description "groups"; addCommand child } + + let code, document = invokeJson built "--explain --json" + + Expect.equal code 0 "explain exits zero" + let subcommand = document |> property "subcommands" |> items |> List.exactlyOne + Expect.equal (subcommand |> property "name" |> text) "child" "the subcommand is named" + Expect.equal (subcommand |> property "description" |> text) "does the thing" "with its description" + } ] From 54a456f97d848592b6ef10b450c5a6b36bc9b4c1 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 12:49:00 +0000 Subject: [PATCH 08/25] Declare a reserved option once and count JSON step positions from zero A stage that reads MachineOutput.json or MachineOutput.report registers the option through its pipeline's inputs; reserve now treats that same instance as taken, so --help and --schema list it once. The explain document's step `index` now counts from zero, matching the run result's `step` and `path`. The text form still prints an unlabelled step as `step 1`. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- notes/PLAN-Integration.md | 7 ++++++- src/Partas.Build/Explain.fs | 11 ++++++----- src/Partas.Build/MachineOutput.fs | 4 +--- tests/Partas.Build.Tests/CommandTests.fs | 22 ++++++++++++++++++++++ tests/Partas.Build.Tests/ExplainTests.fs | 2 +- 5 files changed, 36 insertions(+), 10 deletions(-) diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 4066f45..56cbbf5 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -146,7 +146,12 @@ console width. Add `--format json` (name open) on every command: subtree rooted at the command it is given to; `--report ` is on every command that runs pipelines. A command that already declares one of these names or aliases keeps its own option and goes without the library's (`reserve` in `Builders/Command.fs`): collision is resolved at construction, silently, rather than - by System.CommandLine rejecting a duplicate. + by System.CommandLine rejecting a duplicate. A stage that reads the library's own `MachineOutput.json` or + `MachineOutput.report` registers it through its pipeline's inputs; `reserve` then finds it taken and the command + declares it once. +- Every step position in the JSON counts from zero: `index` in the explain document, `step` and `path` in the + run result, so a failure maps onto the explained step directly. The text form of `--explain` still prints an + unlabelled step as `step 1`. - The run result goes to stdout under `--json` *and* to a file under `--report` (§8 Q2): stdout as one line of compact JSON after the run, replacing the timing table, so a reader takes the last line; the file indented. Stage output is untouched, since capturing it is the stage's setting. diff --git a/src/Partas.Build/Explain.fs b/src/Partas.Build/Explain.fs index 2530dc8..5d6c72b 100644 --- a/src/Partas.Build/Explain.fs +++ b/src/Partas.Build/Explain.fs @@ -59,7 +59,8 @@ type ExplainedStage = { Steps: ExplainedStep list } -/// A step as --explain describes it; index counts from one. +/// A step as --explain describes it; index counts from zero, as a run result's step and +/// path do. /// A label is the step's log form, with every secret masked. and [] ExplainedStep = | Step of index: int * label: string voption @@ -165,9 +166,9 @@ module Explain = |> List.mapi (fun index step -> match step with | Step.StepOfStage subStage -> - ExplainedStep.Stage(index + 1, explainStage mode { subStage with ParentContext = ValueSome(StageParent.Stage stage) }) - | Step.StepFn(label, _) -> ExplainedStep.Step(index + 1, label) - | Step.Operation(label, _) -> ExplainedStep.Operation(index + 1, label)) + ExplainedStep.Stage(index, explainStage mode { subStage with ParentContext = ValueSome(StageParent.Stage stage) }) + | Step.StepFn(label, _) -> ExplainedStep.Step(index, label) + | Step.Operation(label, _) -> ExplainedStep.Operation(index, label)) } /// The tree of , with each stage's conditions answered under @@ -233,7 +234,7 @@ module Explain = let text = match label with | ValueSome label -> $"$ %s{label}" - | ValueNone -> $"step %i{index}" + | ValueNone -> $"step %i{index + 1}" lines.Add $"""%s{childPrefix}%s{if isLast then lastBranch else branch}%s{text}""") let renderStages (stages: ExplainedStage list) = diff --git a/src/Partas.Build/MachineOutput.fs b/src/Partas.Build/MachineOutput.fs index 7fb5334..76eb730 100644 --- a/src/Partas.Build/MachineOutput.fs +++ b/src/Partas.Build/MachineOutput.fs @@ -260,7 +260,5 @@ module MachineOutput = | ParsedOption option -> let names = Seq.append [ option.Name ] option.Aliases |> Set.ofSeq command.Options - |> Seq.exists (fun existing -> - not (obj.ReferenceEquals(existing, option)) - && (names.Contains existing.Name || existing.Aliases |> Seq.exists names.Contains)) + |> Seq.exists (fun existing -> names.Contains existing.Name || existing.Aliases |> Seq.exists names.Contains) | _ -> false diff --git a/tests/Partas.Build.Tests/CommandTests.fs b/tests/Partas.Build.Tests/CommandTests.fs index cd6b303..4f4ec63 100644 --- a/tests/Partas.Build.Tests/CommandTests.fs +++ b/tests/Partas.Build.Tests/CommandTests.fs @@ -722,5 +722,27 @@ let machineOutputTests = Expect.equal code 0 "the command still runs" Expect.equal (List.ofSeq seen) [ "out.json" ] "and reads its own option" } + + test "a stage that reads the library's --json registers it once" { + let seen = ResizeArray() + + let built = command "emit" { + input { + let! json = MachineOutput.json + return stage "write" { run (fun (_: StageContext) -> seen.Add json) } + } + } + + Expect.equal (optionNames built |> List.filter ((=) "--json")) [ "--json" ] "the flag is declared once" + + use output = new StringWriter() + built.Parse("--schema").Invoke(InvocationConfiguration(Output = output)) |> ignore + let options = JsonDocument.Parse(output.ToString()).RootElement |> property "command" |> property "options" |> items + let jsonEntries = options |> List.filter (fun option -> (option |> property "name").GetString() = "--json") + Expect.equal jsonEntries.Length 1 "and described once" + + Helpers.quietly (fun () -> built.Parse("--json").Invoke()) |> ignore + Expect.equal (List.ofSeq seen) [ true ] "the stage reads the flag" + } ] diff --git a/tests/Partas.Build.Tests/ExplainTests.fs b/tests/Partas.Build.Tests/ExplainTests.fs index b4fcc83..abb44da 100644 --- a/tests/Partas.Build.Tests/ExplainTests.fs +++ b/tests/Partas.Build.Tests/ExplainTests.fs @@ -214,7 +214,7 @@ let tests = let step = restore |> property "steps" |> items |> List.exactlyOne Expect.equal (step |> property "kind" |> text) "step" "a command step is a step" Expect.equal (step |> property "label" |> text) "dotnet restore Foo.slnx" "with its command line as its label" - Expect.equal ((step |> property "index").GetInt32()) 1 "indexed from one" + Expect.equal ((step |> property "index").GetInt32()) 0 "indexed from zero, as a run result's step is" let guarded = stageNamed "guarded" pipeline Expect.equal (guarded |> property "status" |> text) "skipped" "a failed pure condition is evaluated even statically" From 56fa8f63dc93ae7526730006464bbf2561a621a1 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 13:06:41 +0000 Subject: [PATCH 09/25] Mask the default of a sensitive option in --schema Input.sensitive marks an option or argument as carrying a secret; --schema writes its present default as "***" and reports "sensitive": true. Baked.NuGet.apiKey, whose default is read from NUGET_API_KEY, is marked. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 4 +++ notes/PLAN-Integration.md | 4 +++ src/Partas.Build.Baked/NuGet.fs | 1 + src/Partas.Build/MachineOutput.fs | 25 +++++++++++--- src/Partas.Build/System.CommandLine/Inputs.fs | 24 ++++++++++++++ tests/Partas.Build.Tests/CommandTests.fs | 33 +++++++++++++++++++ 6 files changed, 86 insertions(+), 5 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 65501b1..27ef572 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -83,6 +83,10 @@ writes the indented form to a file. Both are written for every outcome the comma dependency validation included, but not for a System.CommandLine parse error. JSON is written with `Utf8JsonWriter` by hand, not reflection serialization: every document carries `formatVersion` (`MachineOutput.FormatVersion`). `System.Text.Json` is a package reference on `netstandard2.0` only. +`Input.sensitive` marks an option or argument as carrying a secret, recorded against the `Symbol` in a +`ConditionalWeakTable` in `Inputs.fs` (System.CommandLine has no property bag); `--schema` writes a marked +symbol's present default as `"***"` alongside `"sensitive": true`. `Baked.NuGet.apiKey` is marked, since its +default is read from `NUGET_API_KEY`. Text `--help` still prints the default. `Failures.fs` holds what a scope reports about itself, apart from what it prints. A `ScopeReport` carries three fields: `Outcome` (the scope's own `StageOutcome`), `Propagates` (whether that failure fails the scope diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 56cbbf5..3494dd5 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -161,6 +161,10 @@ console width. Add `--format json` (name open) on every command: - `choices` is what System.CommandLine offers for completion: `acceptOnlyFromAmong`, `mapFromAmong`, `addCompletions` and enums all appear there; booleans list none. A default whose factory reads its parse is reported absent. +- A default can be a secret (`Baked.NuGet.apiKey` defaults to `NUGET_API_KEY`). `Input.sensitive` marks the + option; `--schema` then writes `"sensitive": true` and a present default as `"***"` (`null` stays `null`, so a + consumer can still tell a secret is configured). Masking is opt-in: a default is a plain value, and nothing on + it says where it came from. Text `--help` still prints the default, as it did before this branch. - Not covered: a System.CommandLine parse error (unknown option, missing subcommand) happens before any command action, so it writes no JSON — the exit code (2) is the machine-readable part. diff --git a/src/Partas.Build.Baked/NuGet.fs b/src/Partas.Build.Baked/NuGet.fs index d3e886e..66b98cd 100644 --- a/src/Partas.Build.Baked/NuGet.fs +++ b/src/Partas.Build.Baked/NuGet.fs @@ -12,6 +12,7 @@ let apiKey = Input.desc "NuGet API key" >> Input.helpName "APIKEY" >> Input.arity Arity.ExactlyOne + >> Input.sensitive >> Input.def ( try let result = System.Environment.GetEnvironmentVariable "NUGET_API_KEY" diff --git a/src/Partas.Build/MachineOutput.fs b/src/Partas.Build/MachineOutput.fs index 76eb730..fa217ec 100644 --- a/src/Partas.Build/MachineOutput.fs +++ b/src/Partas.Build/MachineOutput.fs @@ -133,12 +133,26 @@ module MachineOutput = writer.WriteEndObject() - let private writeDefault (writer: Utf8JsonWriter) (value: obj voption) = + /// Whether is null, None or ValueNone. + let private isAbsent (value: obj) = + match value with + | null -> true + | _ -> + let valueType = value.GetType() + + valueType.IsGenericType + && valueType.GetGenericTypeDefinition() = typedefof> + && not (valueType.GetProperty("IsSome").GetValue value :?> bool) + + /// Writes the default, with a present default of a sensitive symbol written as "***". + let private writeDefault (writer: Utf8JsonWriter) (sensitive: bool) (value: obj voption) = + writer.WriteBoolean("sensitive", sensitive) + match value with | ValueSome value -> writer.WriteBoolean("hasDefault", true) writer.WritePropertyName "default" - writeValue writer value + if sensitive && not (isAbsent value) then writer.WriteStringValue "***" else writeValue writer value | ValueNone -> writer.WriteBoolean("hasDefault", false) writer.WriteNull "default" @@ -154,7 +168,7 @@ module MachineOutput = writer.WriteBoolean("hidden", option.Hidden) writer.WriteBoolean("recursive", option.Recursive) writeArity writer option.Arity - writeDefault writer (tryDefault option.HasDefaultValue option.GetDefaultValue) + writeDefault writer (Input.isSensitive option) (tryDefault option.HasDefaultValue option.GetDefaultValue) writeStrings writer "choices" (choices option.ValueType (fun () -> option.GetCompletions CompletionContext.Empty)) writer.WriteEndObject() @@ -166,7 +180,7 @@ module MachineOutput = writer.WriteString("clrType", argument.ValueType.FullName) writer.WriteBoolean("hidden", argument.Hidden) writeArity writer argument.Arity - writeDefault writer (tryDefault argument.HasDefaultValue argument.GetDefaultValue) + writeDefault writer (Input.isSensitive argument) (tryDefault argument.HasDefaultValue argument.GetDefaultValue) writeStrings writer "choices" (choices argument.ValueType (fun () -> argument.GetCompletions CompletionContext.Empty)) writer.WriteEndObject() @@ -199,7 +213,8 @@ module MachineOutput = /// as an indented JSON document. /// /// Each option lists its name, aliases, description, type, whether it is required, hidden or recursive, its - /// arity, its default and the values it is restricted to. runsPipelines is false for a command + /// arity, its default and the values it is restricted to. The default of a symbol marked by + /// Input.sensitive is written as "***". runsPipelines is false for a command /// that only dispatches to its subcommands. /// let schema (command: Command) = diff --git a/src/Partas.Build/System.CommandLine/Inputs.fs b/src/Partas.Build/System.CommandLine/Inputs.fs index 5d6ef43..74ba4ff 100644 --- a/src/Partas.Build/System.CommandLine/Inputs.fs +++ b/src/Partas.Build/System.CommandLine/Inputs.fs @@ -436,6 +436,30 @@ module Input = ) let mapFromMany<'T> choices action: ActionInput<'T list> = mapFromManyWith StringComparer.Ordinal choices action + let private sensitiveSymbols = System.Runtime.CompilerServices.ConditionalWeakTable() + + let private markSensitive (symbol: Symbol) = + lock sensitiveSymbols (fun () -> + match sensitiveSymbols.TryGetValue symbol with + | true, _ -> () + | false, _ -> sensitiveSymbols.Add(symbol, obj ())) + + /// Marks an option or argument as carrying a secret. + /// + /// --schema writes the default of a marked symbol as "***" and reports it "sensitive": true. + /// Text --help still prints the default. + /// + let sensitive (input: ActionInput<'T>) = + input + |> editOption (fun o -> markSensitive o) + |> editArgument (fun a -> markSensitive a) + + /// Whether is marked by sensitive. + let isSensitive (symbol: Symbol) = + match sensitiveSymbols.TryGetValue symbol with + | true, _ -> true + | false, _ -> false + /// Hides an option or argument from the help output. let hidden (input: ActionInput<'T>) = input diff --git a/tests/Partas.Build.Tests/CommandTests.fs b/tests/Partas.Build.Tests/CommandTests.fs index 4f4ec63..ce615b8 100644 --- a/tests/Partas.Build.Tests/CommandTests.fs +++ b/tests/Partas.Build.Tests/CommandTests.fs @@ -703,6 +703,39 @@ let machineOutputTests = Expect.equal ((subDocument |> property "command" |> property "name").GetString()) "build" "a subcommand's schema starts at the subcommand" } + test "--schema masks the default of a sensitive option" { + let key = Input.option "--key" |> Input.def "SEKRIT-123" |> Input.sensitive + let token = Input.optionMaybe "--token" |> Input.sensitive + let plain = Input.option "--plain" |> Input.def "visible" + + let built = command "publish" { + input { + let! key = key + and! token = token + and! plain = plain + return stage "push" { run (fun (_: StageContext) -> ignore (key, token, plain)) } + } + } + + use output = new StringWriter() + built.Parse("--schema").Invoke(InvocationConfiguration(Output = output)) |> ignore + let text = output.ToString() + Expect.isFalse (text.Contains "SEKRIT-123") "the secret is absent from the document" + + let options = JsonDocument.Parse(text).RootElement |> property "command" |> property "options" |> items + let keyOption = options |> named "--key" + Expect.isTrue ((keyOption |> property "sensitive").GetBoolean()) "the option is reported sensitive" + Expect.isTrue ((keyOption |> property "hasDefault").GetBoolean()) "it still reports a default" + Expect.equal ((keyOption |> property "default").GetString()) "***" "written masked" + + let tokenOption = options |> named "--token" + Expect.equal ((tokenOption |> property "default").ValueKind) JsonValueKind.Null "an absent default stays null" + + let plainOption = options |> named "--plain" + Expect.isFalse ((plainOption |> property "sensitive").GetBoolean()) "an unmarked option is not sensitive" + Expect.equal ((plainOption |> property "default").GetString()) "visible" "and its default is written" + } + test "a command that declares --json keeps its own option" { let seen = ResizeArray() let json = Input.option "--json" |> Input.def "" From 19b2de54c8dfe4959ab405caf5013fbd3ad99c15 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 11:52:05 +0000 Subject: [PATCH 10/25] Make the library safe in a long-lived host: console, argv, environment, reentrancy, interrupts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements PLAN-Integration §5.3.2-§5.3.6 and answers §8 Q5. - Spike (§8 Q5): Spectre's static AnsiConsole stays bound to the Console.Out current at its first use; without a terminal every console reports width -1 and renders nothing. Recorded in the plan. - Terminal.fs is the only route to the console: Terminal.ansi () rebinds AnsiConsole.Console when Console.Out changes (an explicit assignment is kept), falls back to 80 columns, and under Terminal.withOutput (an AsyncLocal run writer) writes plain text to that writer. Invoke's output now receives the run's console output, child processes included. - Console encodings are set at most once per process, only for a stream that is not redirected, and never throw. - rootCommandOfScript reads argv when the command runs: RootCommandBuilder takes unit -> string array, with an array constructor for rootCommand. - PipelineContext.create starts EnvVars empty; runWith layers the pipeline's own variables over the environment as the run starts. applyDefaults' per-key rule follows. - runWith fails fast with InvalidOperationException on a concurrent second run of one pipeline value; PipelineContext.withRunState gives a copy that runs independently. - RootCommandDefinition.Invoke runs on a worker; a ThreadInterruptedException on the waiting thread cancels the invocation's token source, killing the process tree through the existing registration, then rethrows. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f Fix host-safety review findings: refused runs, run writer threading, cts disposal - A command invocation refused a running pipeline value no longer records or prints the other run's reports and timings: runReportingTimings enters the reentrancy guard before the try whose finally reads the collections, and runs through the new internal PipelineContext.runEntered. - Terminal.withOutput installs the caller's writer through TextWriter.Synchronized, since parallel' stages and a redirected child's reader callbacks write to it concurrently. - runInterruptibly disposes the linked CancellationTokenSource in a finally, so failed or interrupted invocations leave no registration on the caller's token. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 35 ++++++-- notes/PLAN-Integration.md | 64 +++++++++++++- src/Partas.Build/Builders/Command.fs | 74 +++++++++++++--- src/Partas.Build/Builders/Conditions.fs | 4 +- src/Partas.Build/Conductors.Runners.fs | 58 ++++++++---- src/Partas.Build/Conductors.fs | 65 ++++++++------ src/Partas.Build/Partas.Build.fsproj | 3 +- src/Partas.Build/Process.fs | 5 +- src/Partas.Build/Summary.fs | 2 +- src/Partas.Build/Terminal.fs | 100 +++++++++++++++++++++ tests/Partas.Build.Tests/CmdTests.fs | 28 ++++++ tests/Partas.Build.Tests/CommandTests.fs | 78 ++++++++++++++++- tests/Partas.Build.Tests/OutputTests.fs | 78 +++++++++++++++++ tests/Partas.Build.Tests/PipelineTests.fs | 102 ++++++++++++++++++++++ 14 files changed, 626 insertions(+), 70 deletions(-) create mode 100644 src/Partas.Build/Terminal.fs diff --git a/CLAUDE.md b/CLAUDE.md index 27ef572..c00c034 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -1,4 +1,4 @@ -# CLAUDE.md +# CLAUDE.md This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. @@ -47,7 +47,7 @@ Fast inner loop while working on the library only: `dotnet build src/Partas.Buil ## Architecture notes -Compile order in `Partas.Build.fsproj` matters (F#): `System.CommandLine/Aliases.fs` → `System.CommandLine/Inputs.fs` → `Exceptions.fs` → `Output.fs` → `Environment.fs` → `Timing.fs` → `Producer.fs` → `Failures.fs` → `Conductors.fs` → `Conductors.Runners.fs` → `Process.fs` → `Operations.fs` → `Dependencies.fs` → `DependencyPlan.fs` → `ExecutionState.fs` → `Builders/StageSettings.fs` → `Builders/Stage.fs` → `Builders/Conditions.fs` → `Builders/PipelineSettings.fs` → `Builders/Pipeline.fs` → `Builders/Inputs.fs` → `Builders/Dependencies.fs` → `MachineOutput.fs` → `Explain.fs` → `Summary.fs` → `RunResult.fs` → `Builders/Command.fs`. The batteries-included layer is its own project, `src/Partas.Build.Baked`. +Compile order in `Partas.Build.fsproj` matters (F#): `System.CommandLine/Aliases.fs` → `System.CommandLine/Inputs.fs` → `Exceptions.fs` → `Output.fs` → `Terminal.fs` → `Annotations.fs` → `Environment.fs` → `Timing.fs` → `Producer.fs` → `Failures.fs` → `Conductors.fs` → `Conductors.Runners.fs` → `Process.fs` → `Operations.fs` → `Dependencies.fs` → `DependencyPlan.fs` → `ExecutionState.fs` → `Builders/StageSettings.fs` → `Builders/Stage.fs` → `Builders/Conditions.fs` → `Builders/PipelineSettings.fs` → `Builders/Pipeline.fs` → `Builders/Inputs.fs` → `Builders/Dependencies.fs` → `MachineOutput.fs` → `Explain.fs` → `Summary.fs` → `RunResult.fs` → `Builders/Command.fs`. The batteries-included layer is its own project, `src/Partas.Build.Baked`. `Explain.fs` renders the resolved stage tree `--explain` prints, as text or JSON, independent of the console and any stage sink — a stage that silences or captures its output is still described in full. `Explain.explain mode` @@ -167,7 +167,32 @@ runs), and still gets 2 for a failed dependency validation (the action returns it) but 1 for a parse error (System.CommandLine's own). The token reaches the engine through `PipelineContext.runWith`, which links it into the pipeline's own timeout source. `output` replaces the invocation configuration's `Output`/`Error`, which is where help, parse errors, `--explain`, the timing summary -and the dependency diagnostic go; stage output still goes to Spectre's ambient console. +and the dependency diagnostic go, and becomes the run writer (`Terminal.withOutput`, below) for everything the +run sends to the console. `Invoke` runs the parse-and-invoke on a `LongRunning` task and waits on it: a +`ThreadInterruptedException` on the waiting thread (SageFs's `cancel_eval` is `Thread.Interrupt`) cancels the +invocation's own linked `CancellationTokenSource` — reaching the registration-based process-tree kill through +the same token chain as `cancellationToken` — waits up to five seconds for the run to wind down, and rethrows. +`rootCommandOfScript` is `RootCommandBuilder Args.script`: the builder's primary constructor takes a +`unit -> string array` read once per `Run`, so argv is read when the command runs, never at module +initialisation; `rootCommand` is annotated `string array` to keep the array constructor's overload unambiguous. + +`Terminal.fs` (`Partas.Build.Internal.Terminal`) is the only route to the console. Spectre's static +`AnsiConsole` binds to the `Console.Out` current at its first use and keeps writing there after a host swaps +`Console.Out` (spike in `PLAN-Integration.md` §8 Q5), so the library never calls `AnsiConsole.*` directly: +`Terminal.ansi ()` answers `AnsiConsole.Console`, rebinding it to the current `Console.Out` when `Console.Out` +changed since the last call and nothing else replaced `AnsiConsole.Console` meanwhile (an explicit assignment, +as the tests' `capturingOut` makes, is kept). Under `Terminal.withOutput writer` — an `AsyncLocal`, so it flows +into the thread-pool work the run starts — `ansi ()` is a plain (no ANSI, no colour) console over `writer`, +`Terminal.out ()` (where a `Console`-sink step line goes) is `writer`, and `CmdRunner.outputPolicy` redirects a +`Console`-sink child, which would otherwise inherit the real stdout. A console whose writer has no terminal +reports width `-1` and renders nothing, so `ansi`/`plain` give it `FallbackWidth` (80). `Terminal.ensureUtf8` +sets the console encodings at most once per process, skips a redirected stream, and swallows a failure. + +`PipelineContext.create` starts `EnvVars` empty: it holds the variables the pipeline sets. `runWith` layers +them over `PipelineContext.ambientEnvironment ()` read as the run starts, so a variable set after the pipeline +value was built is visible to its steps. `runWith` also refuses a second concurrent run of one pipeline value +(identity: the `ScopeReports` a value and its record copies share) with an `InvalidOperationException` before +touching anything; `PipelineContext.withRunState` gives a copy collections of its own that runs independently. `src/Partas.Build.Cmd` (`Program.fs`, `Execution.fs`) is the process layer, defining `Cmd` and compiling before `Partas.Build`. @@ -202,7 +227,7 @@ a `voption` setting transfers only when the pipeline left it `ValueNone`; `PostS declared none; `AcceptableExitCodes` only while the pipeline is still on `set [0]`; the hooks and `Verify` only while they are still the `noStageHook`/`alwaysVerify` values `create` installed, so those are named module-level bindings rather than inline `ignore` — reference equality is the test; and `EnvVars` per key, -since a pipeline's map starts as the whole ambient environment. `NoPrefixForStep`/`NoStdRedirectForStep` are +a default key applying wherever the pipeline did not set that key itself. `NoPrefixForStep`/`NoStdRedirectForStep` are plain bools with no unset state, so a pipeline setting one to the value it already had is indistinguishable from not setting it at all — the single known gap. @@ -245,5 +270,5 @@ a patch bump move it breaks anything not rebuilt in the same pass with `Could no - `.editorconfig` sets Stroustrup style, `max_line_length=150`, `fsharp_space_before_uppercase_invocation=true`. No fantomas tool is installed (`.config/dotnet-tools.json` declares no tools at all) and there is no `format`/`lint` command — match surrounding style manually. - Prefer `voption`/`ValueOption` and `[]` DUs in the library: a departure from the ported Fun.Build code. - Public API goes in `[]` modules under `Partas.Build`; the model and engine stay in `Partas.Build.Internal`. A model type that appears in a public signature gets an abbreviation in `ConsumerTypes` (`Conductors.fs`), and a lookup a step needs gets a re-export in the public `StageContext` module. -- Console output is Spectre.Console throughout, with GitHub Actions `::error title=...::` fallbacks when `GITHUB_ENV` is present (see `printError` in both context modules). +- Console output uses `Terminal.ansi ()`, which follows the invocation writer, with GitHub Actions `::error title=...::` fallbacks when `GITHUB_ENV` is present (see `printError` in both context modules). - The Nacara site (`docs/Site.fs`, `docs/docs.fsproj`) publishes every page under `docs/content/` and `docs/blog/`, plus the generated API reference, so internal working documents belong in `notes/` (as the `PLAN*.md` files do), not under `docs/`. diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 3494dd5..f47a0ae 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -248,7 +248,7 @@ From SageFs's source (`SageFs.Core/AppState.fs`, `Features/LiveTestingExecutors. |---|---|---| | `rootCommandOfScript` is a module-level value calling `Args.script ()` | `Command.fs:599` | argv read once at module initialisation, and it is the host's argv | | `Console.InputEncoding`/`OutputEncoding` set on every run | `Conductors.Runners.fs:629-630` | process-global mutation per eval; setting `InputEncoding` can throw without an attached console on Windows | -| Spectre `AnsiConsole` global | `Conductors.fs:396,504,534-549` | **unverified**: the singleton may bind to the `Console.Out` current at first use, i.e. the first eval's `StringWriter`, and write into a dead writer thereafter. Spike before designing around it. | +| Spectre `AnsiConsole` global | `Conductors.fs:396,504,534-549` | **confirmed** (§8 Q5): the singleton binds to the `Console.Out` current at first use, i.e. the first eval's `StringWriter`, and writes into a dead writer thereafter. | | Environment snapshot in `PipelineContext.create` | `Conductors.fs:420` | a pipeline value bound at load time keeps the environment as it was then | | Mutable `Timings`/`Reports`/`Producers` on the pipeline value, cleared per run | `Conductors.Runners.fs:631-635` | two concurrent runs of the same value race | | Cancellation only through `CancellationToken` | `Process.fs` (`CmdRunner`) | `cancel_eval`'s `Thread.Interrupt` reaches no token: child process trees are orphaned | @@ -289,21 +289,77 @@ From SageFs's source (`SageFs.Core/AppState.fs`, `Features/LiveTestingExecutors. 2. **`rootCommandOfScript` stops capturing argv at module initialisation**: a function, or a builder whose `Run` reads `Args.script ()` when invoked. + **Status: implemented on claude/partas-build-patterns-jgrwr0-host.** `RootCommandBuilder`'s primary constructor takes `unit -> string array`, + called once per `Run`; `new(args: string array)` keeps `rootCommand argv { … }`, and `rootCommandOfScript` + is `RootCommandBuilder Args.script`, still a value, so `rootCommandOfScript { … }` is unchanged. `rootCommand` + gained a `string array` annotation: with two constructors, the unannotated inline `RootCommandBuilder args` + is `FS0041`. + 3. **Console hygiene**: set the encodings only when output is not redirected and only once per process; build the Spectre console per run from the current `Console.Out` (or the `output` passed to `invoke`), if §5.2's spike confirms the singleton problem. + **Status: implemented on claude/partas-build-patterns-jgrwr0-host.** The spike confirmed the hazard (§8 Q5). `Terminal.fs` is now the only route to + the console. Deviations: + + - Not a console *per run* but one per `Console.Out`: `Terminal.ansi ()` rebinds `AnsiConsole.Console` to the + current `Console.Out` whenever `Console.Out` changed since its last call, which covers a writer swapped + between runs and one swapped mid-run. It keeps a console something else assigned to `AnsiConsole.Console` + since the last call (a user's, or the tests' `capturingOut`). Residual gap: when the first call the + library ever makes finds a static console created earlier under a different `Console.Out` (another + library used `AnsiConsole` in a previous SageFs eval), it keeps that console until `Console.Out` next + changes. + - `invoke`'s `output`, when given, is an `AsyncLocal` run writer (`Terminal.withOutput`): the pipeline's own + lines, `Console`-sink step lines, and — by forcing redirection in `CmdRunner.outputPolicy` — a + `Console`-sink child process's output go there, as plain text. `withOutput` wraps the writer in + `TextWriter.Synchronized`: `parallel'` stages and a redirected child's two reader callbacks write to it at + once, and a caller's `StringWriter` is not thread-safe. + - Found by the spike: without a terminal (SageFs's worker, a CI container) Spectre reports width `-1` and + `MarkupLine` renders nothing at all, while tables and rules throw "Console width must be greater than + zero". The library's consoles fall back to 80 columns (`Terminal.FallbackWidth`), and `Summary.render` + sizes to `Terminal.width ()`. + - `ensureUtf8` sets each encoding at most once per process, only for a stream that is not redirected, and + swallows a failure. Setting `OutputEncoding` does not replace a `Console.Out` installed by `SetOut`. + 4. **Bridge `Thread.Interrupt` to cancellation**: `invoke` runs the pipeline on a worker and waits; if the waiting thread receives `ThreadInterruptedException`, it cancels the run's `CancellationTokenSource`, which reuses the existing process-tree kill (registration-based, per CLAUDE.md), then rethrows. Test: interrupt a thread running a `sleep` stage and assert no surviving process, mirroring the existing `cmd` test. + **Status: implemented on claude/partas-build-patterns-jgrwr0-host.** `RootCommandDefinition.Invoke` runs parse-and-invoke on a `LongRunning` + task; the calling thread waits. On `ThreadInterruptedException` it cancels a `CancellationTokenSource` + linked from the caller's `cancellationToken` (the one the invocation state carries), waits up to five + seconds for the run to wind down, and rethrows; `Invoke` then returns no `RunResult`. The cmd test tracks the + sleep processes it started by id and ignores zombies: in this container nothing reaps an orphaned grandchild, + so a killed `sleep` lingers `` and the existing count-based no-survivor tests fail here on the base + branch too. The linked source is disposed in a `finally`, so a failed or interrupted invocation leaves no + registration on a caller's long-lived token. + 5. **Environment read at run time**: `PipelineContext.run` refreshes the ambient environment it starts from, keeping the pipeline's own `envVars` on top. + **Status: implemented on claude/partas-build-patterns-jgrwr0-host.** `PipelineContext.create` now starts `EnvVars` empty — the variables the + pipeline sets — and `runWith` layers them over the environment read as the run starts. `applyDefaults`' + per-key rule becomes "a default key applies where the pipeline did not set that key", which also closes the + old gap where a pipeline setting a key to its ambient value was indistinguishable from not setting it. + Outside a run, `StageContext.tryGetEnvVar` (the `Partas.Build` one) falls back to the process environment + and `PipelineContext.printError` checks it for `GITHUB_ENV`, since the pipeline's map no longer holds it. + 6. **A reentrancy guard**: a run of a pipeline value already running either fails fast or runs against a copy of the mutable collections. + **Status: implemented on claude/partas-build-patterns-jgrwr0-host.** Fail fast: `runWith` raises `InvalidOperationException` naming the pipeline, + before clearing anything, when the same value (identified by the `ScopeReports` its record copies share) is + already running. `PipelineContext.withRunState` gives a copy fresh collections that runs alongside. The + command path does not isolate automatically: tests and callers read `pipeline.Reports` off the value a + command ran, and `ExecutionSchedule.schedule` closes over `pipeline.Producers`, so a copy would have to be + taken before scheduling and would hide the run from those readers. Two concurrent invocations reaching the + same pipeline value therefore fail the second (System.CommandLine's exception handler, exit 1); an + input-aware pipeline builds a fresh value per invocation and is unaffected. The command path enters the + guard (`PipelineContext.Running.enter`) before the `try` whose `finally` records the run into the + `RunResult` and prints the timing summary, then runs through `runEntered`: a refused invocation records no + pipeline run and prints nothing of the run holding the value. + ### 5.4 Consumer-side pattern (docs, not library code) Document the shape for an fsi-script build that is SageFs-friendly: @@ -394,3 +450,9 @@ without `open Partas.Build.Internal` and without the hand-rolled rows of §2's f namespace, and none of it needs `open Partas.Build.Internal`. 5. Is the Spectre singleton hazard (§5.2) real? Spike: create `AnsiConsole` under one `Console.SetOut`, swap, write again, and see where the text lands. + **Answered: yes.** Spectre.Console 0.57.2, net10.0: with `Console.SetOut a`, `AnsiConsole.MarkupLine "first"`, + then `Console.SetOut b`, `AnsiConsole.MarkupLine "second"` and `Console.WriteLine "plain"`, `a` held + `first\nsecond\n` and `b` held only `plain\n` — the static console stays on the writer current at its first + use. The same spike showed that with no terminal attached, every Spectre console reports width `-1` and + renders `MarkupLine` as nothing, the real stdout included; under a pseudo-terminal it is 80. Addressed in + §5.3.3. diff --git a/src/Partas.Build/Builders/Command.fs b/src/Partas.Build/Builders/Command.fs index cdc11a2..af8a0ab 100644 --- a/src/Partas.Build/Builders/Command.fs +++ b/src/Partas.Build/Builders/Command.fs @@ -92,8 +92,10 @@ let private invocations = ConditionalWeakTable() /// result carries the timings. /// let private runReportingTimings (output: TextWriter) (asJson: bool) (state: InvocationState) (pipeline: PipelineContext) = + // Entered outside the `try`: a run refused here must not record or print the collections of the run holding it. + use _running = PipelineContext.Running.enter pipeline try - PipelineContext.runWith state.CancellationToken pipeline + PipelineContext.runEntered state.CancellationToken pipeline finally let timings = StageTimings.ordered pipeline.Timings state.Record { Name = pipeline.Name; Reports = ScopeReports.stages pipeline.Reports; Timings = timings } @@ -615,11 +617,42 @@ type CommandBuilder(name: string) = member this.Run(stages: CommandStages): Command = this.Run(addPipeline (pipelineOfCommandStages stages)) +/// How long an interrupted invocation waits for its run to wind down before the interrupt propagates. +let private interruptGracePeriod = TimeSpan.FromSeconds 5. + +/// Runs on a thread of its own, the calling thread waiting for its result. +/// +/// A reaching the waiting thread cancels +/// , waits up to interruptGracePeriod for to return, and +/// propagates to the caller. An exception raised by propagates as itself. +/// +let private runInterruptibly (cts: CancellationTokenSource) (fn: unit -> 'T) : 'T = + let worker = + Tasks.Task.Factory.StartNew( + Func<'T> fn, CancellationToken.None, Tasks.TaskCreationOptions.LongRunning, Tasks.TaskScheduler.Default) + + try + try + worker.Wait() + with + | :? ThreadInterruptedException -> + cts.Cancel() + (try worker.Wait interruptGracePeriod |> ignore with _ -> ()) + reraise () + | :? AggregateException as ex when ex.InnerExceptions.Count = 1 -> + Runtime.ExceptionServices.ExceptionDispatchInfo.Capture(ex.InnerException).Throw() + + worker.Result + finally + cts.Dispose() + /// A root command, built and ready to parse and run any number of argument lists. /// /// Built by Command.root { … }, which takes every operation rootCommand takes. Parsing and running /// happen only in Invoke, never at construction, so the value can be bound once in a long-lived host -/// and invoked repeatedly, one invocation after another. Concurrent invocations of one value are unsupported. +/// and invoked repeatedly. A pipeline value runs one run at a time: an invocation reaching a pipeline value that +/// a concurrent invocation is running fails with an , reported +/// as System.CommandLine reports an exception. /// [] type RootCommandDefinition @@ -633,23 +666,30 @@ type RootCommandDefinition /// /// Receives help, --version, --explain and the timing summary, and — unless /// is given — parse and validation errors. Defaults to the - /// invocationConfiguration the root was built with, else the console. Stage output continues to - /// follow each stage's own output setting. + /// invocationConfiguration the root was built with, else the console. When given, it also receives + /// everything the run writes to the console, as plain text: the pipeline's own lines, and the output of every + /// stage whose output setting is the console, child processes included. /// /// Receives parse and validation errors. /// /// Cancels the running pipeline as its own timeout would, killing the process tree of any step /// running, and prevents the remaining pipelines from starting. The result is then Cancelled. /// + /// + /// The invocation runs on a thread of its own while the calling thread waits. Thread.Interrupt on the + /// calling thread cancels the run as would, then raises + /// from Invoke. + /// member _.Invoke(args: string seq, ?output: TextWriter, ?error: TextWriter, ?cancellationToken: CancellationToken): RunResult = let args = Array.ofSeq args + let cts = CancellationTokenSource.CreateLinkedTokenSource(defaultArg cancellationToken CancellationToken.None) let parseResult = match parserConfiguration with | ValueSome config -> command.Parse(args, config) | ValueNone -> command.Parse args - let state = InvocationState(defaultArg cancellationToken CancellationToken.None) + let state = InvocationState cts.Token invocations.Add(parseResult, state) let configuration = @@ -669,7 +709,7 @@ type RootCommandDefinition error |> Option.iter (fun error -> configuration.Error <- error) ValueSome configuration - let exitCode = + let invokeParsed () = try match configuration with | ValueSome config -> parseResult.Invoke config @@ -677,6 +717,12 @@ type RootCommandDefinition finally invocations.Remove parseResult |> ignore + let exitCode = + runInterruptibly cts (fun () -> + match output with + | Some writer -> Terminal.withOutput writer invokeParsed + | None -> invokeParsed ()) + let exitCode = match parseResult.Action with | :? ParseErrorAction -> ExitCode.UsageError @@ -733,10 +779,13 @@ type RootCommandDefinitionBuilder() = /// Builds the root command and runs it against args, returning the process exit code. /// The exit code is ExitCode's: Command.root { … } with Command.invoke args is the same run returning the whole RunResult. -type RootCommandBuilder(args: string array) = +/// Called once per Run, as the command runs. +type RootCommandBuilder(readArgs: unit -> string array) = inherit RootCommandBuilderBase() - member this.Run(build: BuildCommand): int = this.Define(build).Invoke(args).ExitCode + new(args: string array) = RootCommandBuilder(fun () -> args) + + member this.Run(build: BuildCommand): int = this.Define(build).Invoke(readArgs ()).ExitCode member this.Run(stages: CommandStages): int = this.Run(addPipeline (pipelineOfCommandStages stages)) module Command = @@ -758,8 +807,11 @@ module Command = let invoke (args: string seq) (root: RootCommandDefinition) : RunResult = root.Invoke args let inline command name = CommandBuilder name -let inline rootCommand args = RootCommandBuilder args +let inline rootCommand (args: string array) = RootCommandBuilder args /// The root command over the running script's own arguments. -/// rootCommandOfScript { … } is rootCommand (Args.script ()) { … }. -let rootCommandOfScript = RootCommandBuilder(Args.script ()) +/// +/// rootCommandOfScript { … } is rootCommand (Args.script ()) { … }, with the arguments read as the +/// command runs rather than when the module initialises. +/// +let rootCommandOfScript = RootCommandBuilder Args.script diff --git a/src/Partas.Build/Builders/Conditions.fs b/src/Partas.Build/Builders/Conditions.fs index e3849c8..c2d117d 100644 --- a/src/Partas.Build/Builders/Conditions.fs +++ b/src/Partas.Build/Builders/Conditions.fs @@ -1,4 +1,4 @@ -[] +[] module Partas.Build.ConditionsBuilder open System @@ -83,7 +83,7 @@ module Conditions = proc.WaitForExit() List.contains branch branches with ex -> - AnsiConsole.MarkupLineInterpolated $"[red]Run git to get branch info failed: {ex.Message}[/]" + Terminal.ansi().MarkupLineInterpolated $"[red]Run git to get branch info failed: {ex.Message}[/]" false effectful $"""whenBranch %s{String.Join(", ", branches)}""" isOnBranch diff --git a/src/Partas.Build/Conductors.Runners.fs b/src/Partas.Build/Conductors.Runners.fs index 35f9f7e..eb4dd3a 100644 --- a/src/Partas.Build/Conductors.Runners.fs +++ b/src/Partas.Build/Conductors.Runners.fs @@ -371,7 +371,7 @@ module StageContext = $"{escapedPrefix} raised an exception." |> Markup.red |> printn - AnsiConsole.WriteException ex + Terminal.ansi().WriteException ex // The exception is evidence of the attempt; whether it also reaches the // enclosing scope is `ContinueStageOnFailure`'s to say. evidence @@ -426,7 +426,7 @@ module StageContext = $"{buildCurrentStepPrefix stage |> Markup.escape}> stage's step failed." |> Markup.red |> printn - AnsiConsole.WriteException ex + Terminal.ansi().WriteException ex // Which token fired decides this, and only the runner holds them: `cts` is the budget this // stage was given and each `StepBudget.expiry` the budget it gave one of its steps, so an @@ -600,7 +600,23 @@ module StageContext = return isSuccess } module PipelineContext = - open System.Text + /// The pipelines running, keyed by the ScopeReports a pipeline value and its copies share. + module internal Running = + let private running = System.Runtime.CompilerServices.ConditionalWeakTable() + + let enter (pipeline: PipelineContext) : IDisposable = + lock running (fun () -> + match running.TryGetValue pipeline.Reports with + | true, _ -> + let name = if String.IsNullOrEmpty pipeline.Name then "(unnamed)" else pipeline.Name + raise ( + InvalidOperationException( + $"Pipeline '%s{name}' is already running. A pipeline value runs one run at a time; " + + "run a copy from PipelineContext.withRunState to run it concurrently.")) + | false, _ -> running.Add(pipeline.Reports, null)) + + { new IDisposable with + member _.Dispose() = lock running (fun () -> running.Remove pipeline.Reports |> ignore) } let runStagesWithFailFast (ctx: PipelineContext) (failFast: bool) (cancelToken: CancellationToken) (stages: StageContext seq) = let stages = @@ -620,19 +636,10 @@ module PipelineContext = let runStages (ctx: PipelineContext) (cancelToken: CancellationToken) (stages: StageContext seq) = runStagesWithFailFast ctx false cancelToken stages - /// - /// Runs every stage of under , and raises on - /// failure or cancellation. - /// - /// - /// A cancellation of acts as the pipeline's own timeout does: the - /// stages observe a cancellation, a process started by a step is killed with its tree, and the run raises - /// . Skips DependencyPlan.validate, - /// as run does. - /// - let runWith (cancellationToken: CancellationToken) (this: PipelineContext) = - Console.InputEncoding <- Encoding.UTF8 - Console.OutputEncoding <- Encoding.UTF8 + /// Runs as runWith does, the caller holding Running.enter for it. + let internal runEntered (cancellationToken: CancellationToken) (this: PipelineContext) = + Terminal.ensureUtf8 () + let this = { this with EnvVars = Map.foldBack Map.add this.EnvVars (PipelineContext.ambientEnvironment ()) } StageTimings.clear this.Timings ScopeReports.clear this.Reports // Execution state is invocation-local: a second run of the same pipeline value executes its @@ -758,6 +765,25 @@ module PipelineContext = | failure :: _ -> raise (PipelineFailedException(message, FailureCause.toException failure.Cause)) | [] -> raise (PipelineFailedException message) + /// + /// Runs every stage of under , and raises on + /// failure or cancellation. + /// + /// + /// A cancellation of acts as the pipeline's own timeout does: the + /// stages observe a cancellation, a process started by a step is killed with its tree, and the run raises + /// . Skips DependencyPlan.validate, + /// as run does. + /// The stages read the process environment as it is when the run starts, with the pipeline's own + /// EnvVars over it. + /// A pipeline value runs one run at a time: starting a second while the first is running raises + /// before anything runs. A copy from + /// PipelineContext.withRunState runs independently. + /// + let runWith (cancellationToken: CancellationToken) (this: PipelineContext) = + use _running = Running.enter this + runEntered cancellationToken this + /// Runs every stage of and raises on failure or cancellation. /// /// Skips DependencyPlan.validate: the command path validates placement before this runs and never diff --git a/src/Partas.Build/Conductors.fs b/src/Partas.Build/Conductors.fs index d9eeaf8..cb5abde 100644 --- a/src/Partas.Build/Conductors.fs +++ b/src/Partas.Build/Conductors.fs @@ -1,4 +1,4 @@ -namespace Partas.Build.Internal +namespace Partas.Build.Internal open System open System.CommandLine @@ -128,6 +128,11 @@ and PipelineContext = { Description: string voption Verbosity: Verbosity voption Verify: PipelineContext -> bool + /// The environment variables the pipeline sets. + /// + /// Empty for a new pipeline. A run layers these over the process environment as it is when the run starts, + /// and the stages of the run read the combined map here. + /// EnvVars: Map AcceptableExitCodes: Set Timeout: TimeSpan voption @@ -334,7 +339,7 @@ module StageContext = |> ValueOption.defaultWith (fun () -> match getOutput ctx with // Both streams merged onto stdout, as they were before there was anywhere else to put them. - | ValueNone | ValueSome StageOutput.Console -> Console.WriteLine line + | ValueNone | ValueSome StageOutput.Console -> Terminal.out().WriteLine line | ValueSome StageOutput.Silent -> () | ValueSome(StageOutput.Captured capture) -> OutputCapture.add stream line capture | ValueSome(StageOutput.Redirect write) -> write stream line @@ -407,21 +412,23 @@ module PipelineContext = /// The `Verify` a freshly created pipeline carries. Named for the same reason as `noStageHook`. let internal alwaysVerify: PipelineContext -> bool = fun _ -> true + /// The process environment as it is at the moment of the call. + let ambientEnvironment () : Map = + seq { + for key in Environment.GetEnvironmentVariables().Keys -> + try + string key, Environment.GetEnvironmentVariable(string key) + with _ -> string key, "" + } + |> Map.ofSeq + let create (name: string): PipelineContext = - let envVars = - seq { - for key in Environment.GetEnvironmentVariables().Keys -> - try - string key, Environment.GetEnvironmentVariable(string key) - with _ -> string key, "" - } - |> Map.ofSeq { Name = name Description = ValueNone Verbosity = ValueNone Verify = alwaysVerify - EnvVars = envVars + EnvVars = Map.empty AcceptableExitCodes = set [ 0 ] Timeout = ValueNone TimeoutForStep = ValueNone @@ -444,8 +451,8 @@ module PipelineContext = /// /// A command's pipeline-level operations are *defaults*, not overrides: whatever the pipeline set for /// itself wins. "Left alone" is decided against a pristine `PipelineContext.create`, which is the only - /// baseline available once a pipeline is a finished value - `ValueNone` for the optional settings, the - /// ambient environment for `EnvVars`, `set [0]` for the exit codes, `noStageHook` for the hooks, and the + /// baseline available once a pipeline is a finished value - `ValueNone` for the optional settings, no key for + /// `EnvVars`, `set [0]` for the exit codes, `noStageHook` for the hooks, and the /// record's own literals for the flags. Stages are never touched. /// let applyDefaults (defaults: BuildPipeline) (ctx: PipelineContext): PipelineContext = @@ -469,15 +476,11 @@ module PipelineContext = orDefaultIfUntouched ctx.NoStdRedirectForStep pristine.NoStdRedirectForStep defaulted.NoStdRedirectForStep AcceptableExitCodes = orDefaultIfUntouched ctx.AcceptableExitCodes pristine.AcceptableExitCodes defaulted.AcceptableExitCodes - // Per key, since the pipeline's map starts as the whole ambient environment: a key the pipeline - // did not touch still reads back whatever the process was started with. + // Per key: a key the pipeline set itself keeps the pipeline's value. EnvVars = defaulted.EnvVars |> Map.fold - (fun envVars key value -> - if Map.tryFind key ctx.EnvVars = Map.tryFind key pristine.EnvVars - then Map.add key value envVars - else envVars) + (fun envVars key value -> if Map.containsKey key ctx.EnvVars then envVars else Map.add key value envVars) ctx.EnvVars PostStages = if List.isEmpty ctx.PostStages then defaulted.PostStages else ctx.PostStages RunBeforeEachStage = @@ -487,6 +490,11 @@ module PipelineContext = Verify = if obj.ReferenceEquals(ctx.Verify, alwaysVerify) then defaulted.Verify else ctx.Verify } + /// with empty Timings, Reports and Producers of its own. + /// A run of the result records nothing into the collections of . + let withRunState (ctx: PipelineContext): PipelineContext = + { ctx with Timings = StageTimings.create (); Reports = ScopeReports.create (); Producers = ExecutionState.create () } + let printError (ctx: PipelineContext) (msg: string) = { Annotation.error msg with Title = ValueSome ("[PIPELINE] " + ctx.Name) } |> WorkflowCommands.writeAnnotation ctx.EnvVars @@ -517,12 +525,12 @@ module Output = static member inline getVerbosity (verbosity: Verbosity) = verbosity static member inline getVerbosity (stageContext: StageContext) = StageContext.getVerbosity stageContext static member inline getVerbosity (pipelineContext: PipelineContext) = defaultValueArg pipelineContext.Verbosity Verbosity.Default - static member inline write(str: Rule): unit = AnsiConsole.Write(str) - static member inline write(str: FigletText): unit = AnsiConsole.Write(str) - static member inline write(str: string): unit = AnsiConsole.Markup(str) - static member inline writen(renderable: Rule) = AnsiConsole.Write(renderable); AnsiConsole.WriteLine() - static member inline writen(renderable: FigletText) = AnsiConsole.Write(renderable); AnsiConsole.WriteLine() - static member inline writen(str: string) = AnsiConsole.MarkupLine(str) + static member write(str: Rule): unit = Terminal.ansi().Write(str) + static member write(str: FigletText): unit = Terminal.ansi().Write(str) + static member write(str: string): unit = Terminal.ansi().Markup(str) + static member writen(renderable: Rule) = let console = Terminal.ansi () in console.Write(renderable); console.WriteLine() + static member writen(renderable: FigletText) = let console = Terminal.ansi () in console.Write(renderable); console.WriteLine() + static member writen(str: string) = Terminal.ansi().MarkupLine(str) let inline getVerbosity value = ((^T or SRTPHelper):(static member getVerbosity: ^T -> Verbosity) value) type private Printable<^T when (^T or SRTPHelper):(static member write: ^T -> unit) and (^T or SRTPHelper):(static member writen: ^T -> unit)> = ^T let inline print (message: ^T when Printable<^T>) = ((^T or SRTPHelper):(static member write: ^T -> unit) message) @@ -531,9 +539,9 @@ module Output = let inline nprintn value (message: ^T when Printable<^T>) = if (getVerbosity value).IsQuiet |> not then printn message let inline vprint value (message: ^T when Printable<^T>) = if (getVerbosity value).IsVerbose then print message let inline vprintn value (message: ^T when Printable<^T>) = if (getVerbosity value).IsVerbose then printn message - let inline line () = AnsiConsole.WriteLine() - let inline vline value = if (getVerbosity value).IsVerbose then AnsiConsole.WriteLine() - let inline nline value = if (getVerbosity value).IsQuiet |> not then AnsiConsole.WriteLine() + let inline line () = Terminal.ansi().WriteLine() + let inline vline value = if (getVerbosity value).IsVerbose then Terminal.ansi().WriteLine() + let inline nline value = if (getVerbosity value).IsQuiet |> not then Terminal.ansi().WriteLine() let inline withVerbose fn value = if (getVerbosity value).IsVerbose then fn() let inline withNormal fn value = if (getVerbosity value).IsQuiet |> not then fn() @@ -758,6 +766,7 @@ module StageContext = (_.EnvVars >> Map.tryFind key >> ValueOption.ofOption) (tryGetEnvVar >> fun fn -> fn key) ) + |> ValueOption.orElseWith (fun _ -> System.Environment.GetEnvironmentVariable key |> ValueOption.ofObj) let inline getEnvVar (ctx: StageContext) (key: string) = tryGetEnvVar ctx key |> ValueOption.defaultValue "" diff --git a/src/Partas.Build/Partas.Build.fsproj b/src/Partas.Build/Partas.Build.fsproj index ed632d3..33bdf62 100644 --- a/src/Partas.Build/Partas.Build.fsproj +++ b/src/Partas.Build/Partas.Build.fsproj @@ -1,4 +1,4 @@ - + net10.0;net8.0;netstandard2.0 @@ -18,6 +18,7 @@ + diff --git a/src/Partas.Build/Process.fs b/src/Partas.Build/Process.fs index c474596..37fcb01 100644 --- a/src/Partas.Build/Process.fs +++ b/src/Partas.Build/Process.fs @@ -32,7 +32,8 @@ module CmdRunner = /// Where a streamed step's lines go, given the stage's output settings. /// /// Redirection costs the child's colours, so it is only worth it when the output has to be prefixed — - /// or when the stage has said it goes somewhere that is not the console, which cannot be done without it — + /// or when the stage has said it goes somewhere that is not the console, or the console is a run writer set by + /// Terminal.withOutput, neither of which an inherited stream reaches — /// or when a step buffer is in play, since buffering a line is impossible without first receiving it here. /// noStdRedirectForStep is the explicit opt out and wins over all three: it makes capture impossible, by /// design. @@ -40,7 +41,7 @@ module CmdRunner = let outputPolicy (ctx: StageContext) (escapedPrefix: string) = let toConsole = match StageContext.getOutput ctx with - | ValueNone | ValueSome StageOutput.Console -> true + | ValueNone | ValueSome StageOutput.Console -> (Terminal.runWriter ()).IsNone | _ -> false let noPrefix = String.IsNullOrEmpty escapedPrefix diff --git a/src/Partas.Build/Summary.fs b/src/Partas.Build/Summary.fs index 28c1e7c..79f0595 100644 --- a/src/Partas.Build/Summary.fs +++ b/src/Partas.Build/Summary.fs @@ -106,7 +106,7 @@ module Summary = Out = AnsiConsoleOutput writer) |> AnsiConsole.Create - let width = AnsiConsole.Profile.Width + let width = Partas.Build.Internal.Terminal.width () console.Profile.Width <- width console.Write (table width timings) writer.ToString().TrimEnd() diff --git a/src/Partas.Build/Terminal.fs b/src/Partas.Build/Terminal.fs new file mode 100644 index 0000000..3f706a4 --- /dev/null +++ b/src/Partas.Build/Terminal.fs @@ -0,0 +1,100 @@ +/// The console the library writes to, resolved at the moment of writing. +/// +/// Spectre's static AnsiConsole binds to the Console.Out current when it is first used, and keeps +/// writing there after a host swaps Console.Out for another writer. Every write the library makes goes +/// through ansi or out instead, which follow the current writer. +/// +module Partas.Build.Internal.Terminal + +open System +open System.IO +open System.Runtime.CompilerServices +open System.Text +open System.Threading +open Spectre.Console + +/// The width a console takes when its writer reports none, as a writer without a terminal does. +[] +let FallbackWidth = 80 + +let private runOutput = AsyncLocal() +let private plainConsoles = ConditionalWeakTable() +let private gate = obj () +let mutable private lastConsole: IAnsiConsole = null +let mutable private lastOut: TextWriter = null + +let private withWidth (console: IAnsiConsole) = + if console.Profile.Width <= 0 then console.Profile.Width <- FallbackWidth + console + +/// A console over that writes plain text: no ANSI sequences, no colour. +let plain (writer: TextWriter) : IAnsiConsole = + AnsiConsoleSettings(Ansi = AnsiSupport.No, ColorSystem = ColorSystemSupport.NoColors, Out = AnsiConsoleOutput writer) + |> AnsiConsole.Create + |> withWidth + +/// The writer set by withOutput for the current run, if any. +let runWriter () : TextWriter voption = + match runOutput.Value with + | null -> ValueNone + | writer -> ValueSome writer + +/// The writer step output and console lines go to: the run's writer, else the current Console.Out. +let out () : TextWriter = + match runOutput.Value with + | null -> Console.Out + | writer -> writer + +/// The Spectre console the library renders to. +/// +/// Under withOutput, a plain console over that writer. Otherwise AnsiConsole.Console, rebound to +/// the current Console.Out when Console.Out has changed since the last call and nothing else has +/// replaced AnsiConsole.Console in the meantime; a console assigned explicitly is kept. A console whose +/// writer reports no width is given FallbackWidth. +/// +let ansi () : IAnsiConsole = + match runOutput.Value with + | null -> + lock gate (fun () -> + let current = Console.Out + let console = AnsiConsole.Console + + let console = + if isNull lastConsole || not (obj.ReferenceEquals(console, lastConsole)) || obj.ReferenceEquals(current, lastOut) then + console + else + let rebound = AnsiConsole.Create(AnsiConsoleSettings(Out = AnsiConsoleOutput current)) + AnsiConsole.Console <- rebound + rebound + + lastConsole <- console + lastOut <- current + withWidth console) + | writer -> plainConsoles.GetValue(writer, ConditionalWeakTable<_, _>.CreateValueCallback plain) + +/// The width of ansi (). +let width () = (ansi ()).Profile.Width + +/// Runs with as the run's writer. +/// +/// The setting flows to the work starts, across threads, and ends when it returns. Writes +/// reach through a synchronised wrapper, one at a time. +/// +let withOutput (writer: TextWriter) (fn: unit -> 'T) : 'T = + let previous = runOutput.Value + runOutput.Value <- TextWriter.Synchronized writer + try fn () finally runOutput.Value <- previous + +let private encodingSet = ref 0 + +/// Sets the console's input and output encodings to UTF-8, at most once per process. +/// +/// A redirected stream keeps its encoding. A failure to set either encoding — a process with no console +/// attached — leaves it as it was. +/// +let ensureUtf8 () = + if Interlocked.CompareExchange(&encodingSet.contents, 1, 0) = 0 then + if not Console.IsOutputRedirected then + try Console.OutputEncoding <- Encoding.UTF8 with _ -> () + if not Console.IsInputRedirected then + try Console.InputEncoding <- Encoding.UTF8 with _ -> () diff --git a/tests/Partas.Build.Tests/CmdTests.fs b/tests/Partas.Build.Tests/CmdTests.fs index d5ddfed..4fa963a 100644 --- a/tests/Partas.Build.Tests/CmdTests.fs +++ b/tests/Partas.Build.Tests/CmdTests.fs @@ -213,6 +213,34 @@ let tests = Expect.isEmpty skipped.Secrets "and marks nothing secret" } + test "interrupting the thread waiting on an invocation kills the process and everything it started" { + // Tracked by process id rather than by count: other processes on the machine may run the same command. + // A killed grandchild lingers as a zombie where nothing reaps orphans, as in some containers. + let isZombie (proc: Process) = + try (System.IO.File.ReadAllText $"/proc/%i{proc.Id}/stat").Split(')').[1].TrimStart().StartsWith "Z" + with _ -> false + let sleepIds () = + set [ for proc in Process.GetProcessesByName sleepProcessName do if not (isZombie proc) then proc.Id ] + let before = sleepIds () + let root = Command.root { pipeline "interrupted" { quiet; stage "sleep" { run sleeps } } } + let raised: exn ref = ref null + let invoking = Thread(fun () -> try root.Invoke([]) |> ignore with ex -> raised.Value <- ex) + invoking.Start() + + let watch = Stopwatch.StartNew() + while Set.isEmpty (sleepIds () - before) && watch.ElapsedMilliseconds < 20000L do + Thread.Sleep 50 + let started = sleepIds () - before + Expect.isNonEmpty started "the stage should have started its child" + + invoking.Interrupt() + Expect.isTrue (invoking.Join(System.TimeSpan.FromSeconds 20.)) "the interrupted invocation should return" + Expect.isTrue (raised.Value :? ThreadInterruptedException) $"the interrupt should propagate; got %A{raised.Value}" + + Thread.Sleep 1500 + Expect.isEmpty (Set.intersect started (sleepIds ())) "the interrupt should kill the whole tree, as a cancellation does" + } + // Pins the legacy contract the typed executor (PLAN-Execution C02) deliberately leaves alone: a command // cancelled through the token its author passed to `run` is a successful step, and only the ambient // stage timeout turns a kill into a failure. diff --git a/tests/Partas.Build.Tests/CommandTests.fs b/tests/Partas.Build.Tests/CommandTests.fs index ce615b8..e2dfe2d 100644 --- a/tests/Partas.Build.Tests/CommandTests.fs +++ b/tests/Partas.Build.Tests/CommandTests.fs @@ -197,9 +197,9 @@ let tests = // RootCommandBuilder keeps args in a private field with no public accessor; comparing that field // is the only way to assert the delegation without running against the test host's own argv, // which the task notes warn against relying on. - let argsField = typeof.GetField("args", BindingFlags.NonPublic ||| BindingFlags.Instance) - let captured = argsField.GetValue(rootCommandOfScript) :?> string array - Expect.equal captured (Args.script ()) "rootCommandOfScript captures Args.script ()" + let argsField = typeof.GetField("readArgs", BindingFlags.NonPublic ||| BindingFlags.Instance) + let readArgs = argsField.GetValue(rootCommandOfScript) :?> (unit -> string array) + Expect.equal (readArgs ()) (Args.script ()) "rootCommandOfScript reads Args.script ()" } test "Args.take takes everything after the first separator" { @@ -568,6 +568,78 @@ let invocation = Expect.isEmpty result.Pipelines "no pipeline started" } + test "an invocation's output receives what the run writes to the console, as plain text" { + let root = Command.root { + pipeline "routed" { + stage "child" { run (Cmd.ofList "dotnet" [ "--version" ]) } + stage "line" { run (fun (ctx: StageContext) -> StageContext.writeLine ctx StdStream.Out "from-a-step") } + } + } + use output = new StringWriter() + + let result, console = Helpers.capturingOut (fun () -> root.Invoke([], output = output)) + let written = output.ToString() + + Expect.equal result.ExitCode ExitCode.Success "the run passes" + Expect.stringContains written "from-a-step" "a step's console line reaches the given writer" + Expect.stringContains written "PIPELINE routed is finished" "the pipeline's own lines reach it too" + Expect.isTrue + (Text.RegularExpressions.Regex.IsMatch(written, @"(?m)^\d+\.\d+\.\d+")) + $"a child process's output reaches it; got:\n{written}" + Expect.isFalse (written.Contains "\u001b") "the writer receives plain text" + Expect.isFalse (console.Contains "from-a-step") "the console receives none of it" + } + + test "a root command builder over a function reads its arguments as it runs" { + let reads = ref 0 + let builder = RootCommandBuilder(fun () -> reads.Value <- reads.Value + 1; [| "--no-such-option" |]) + Expect.equal reads.Value 0 "constructing the builder reads nothing" + + use output = new StringWriter() + let exitCode = + builder { + invocationConfiguration (InvocationConfiguration(Output = output, Error = output)) + stage "one" { run noop } + } + + Expect.equal reads.Value 1 "running the command reads the arguments once" + Expect.equal exitCode ExitCode.UsageError "and parses what the function answered" + } + + test "an invocation refused a running pipeline records and prints nothing of the run holding it" { + use started = new Threading.ManualResetEventSlim false + use release = new Threading.ManualResetEventSlim false + let root = Command.root { + pipeline "shared" { + stage "stage-alpha" { + run (fun (_: StageContext) -> + started.Set() + release.Wait(TimeSpan.FromSeconds 30.) |> ignore) + } + stage "stage-beta" { run noop } + } + } + use firstOutput = new StringWriter() + use secondOutput = new StringWriter() + let first = Threading.Tasks.Task.Run(fun () -> root.Invoke([], output = firstOutput)) + + try + Expect.isTrue (started.Wait(TimeSpan.FromSeconds 30.)) "the first invocation reaches its stage" + let second = root.Invoke([], output = secondOutput) + + Expect.notEqual second.ExitCode ExitCode.Success "the refused invocation fails" + Expect.isEmpty second.Pipelines "the refused invocation records no pipeline run" + Expect.isFalse + (secondOutput.ToString().Contains "stage-alpha") + $"the refused invocation prints nothing of the other run; got:\n{secondOutput}" + finally + release.Set() + + Expect.isTrue (first.Wait(TimeSpan.FromSeconds 30.)) "the first invocation finishes" + Expect.equal first.Result.ExitCode ExitCode.Success "the first invocation is undisturbed" + Expect.equal [ for timing in first.Result.Timings -> timing.Name ] [ "stage-alpha"; "stage-beta" ] "and records its own run" + } + test "help and --explain write to the given output and exit zero" { let root = recordingRoot (ResizeArray()) use help = new StringWriter() diff --git a/tests/Partas.Build.Tests/OutputTests.fs b/tests/Partas.Build.Tests/OutputTests.fs index 6b19f9a..290a453 100644 --- a/tests/Partas.Build.Tests/OutputTests.fs +++ b/tests/Partas.Build.Tests/OutputTests.fs @@ -240,3 +240,81 @@ let tests = Expect.isTrue (OutputCapture.isEmpty capture) "the child wrote straight to the console" } ] + +[] +let terminal = + testList "terminal" [ + test "the library's console follows Console.Out after it changes" { + let original = System.Console.Out + let originalAnsi = AnsiConsole.Console + use first = new StringWriter() + use second = new StringWriter() + + try + Terminal.ansi () |> ignore + System.Console.SetOut first + Terminal.ansi().WriteLine "to-the-first" + System.Console.SetOut second + Terminal.ansi().WriteLine "to-the-second" + finally + System.Console.SetOut original + AnsiConsole.Console <- originalAnsi + + Expect.stringContains (first.ToString()) "to-the-first" "the first write lands in the writer current at the time" + Expect.isFalse ((first.ToString()).Contains "to-the-second") "the second write leaves the first writer alone" + Expect.stringContains (second.ToString()) "to-the-second" "and lands in the writer current at the time" + } + + test "a console assigned to AnsiConsole.Console is kept" { + let originalAnsi = AnsiConsole.Console + use recorded = new StringWriter() + + try + Terminal.ansi () |> ignore + AnsiConsole.Console <- Terminal.plain recorded + Terminal.ansi().WriteLine "assigned" + finally + AnsiConsole.Console <- originalAnsi + + Expect.stringContains (recorded.ToString()) "assigned" "an explicit assignment wins over Console.Out" + } + + test "a console over a writer without a terminal renders at the fallback width" { + use writer = new StringWriter() + let console = Terminal.plain writer + console.Write(Rule "rule") + + Expect.isGreaterThan console.Profile.Width 0 "the console has a positive width" + Expect.stringContains (writer.ToString()) "rule" "and renders what it is given" + } + + test "withOutput sends console lines to its writer, across threads" { + use writer = new StringWriter() + let ctx = StageContext.create "routed" + + Terminal.withOutput writer (fun () -> + System.Threading.Tasks.Task.Run(fun () -> StageContext.writeLine ctx StdStream.Out "from-another-thread").Wait() + Terminal.ansi().WriteLine "from-spectre") + + Expect.stringContains (writer.ToString()) "from-another-thread" "a line written on another thread reaches the run writer" + Expect.stringContains (writer.ToString()) "from-spectre" "so does Spectre output" + Expect.isTrue (Terminal.runWriter ()).IsNone "the setting ends with the function" + } + + test "withOutput serialises concurrent writes to its writer" { + use writer = new StringWriter() + let ctx = StageContext.create "concurrent" + let count = 4000 + + Terminal.withOutput writer (fun () -> + System.Threading.Tasks.Parallel.For(0, count, fun i -> StageContext.writeLine ctx StdStream.Out $"line-%05d{i}") |> ignore) + + let lines = writer.ToString().Split('\n', System.StringSplitOptions.RemoveEmptyEntries) |> Array.map _.TrimEnd('\r') + Expect.equal (Set.ofArray lines).Count count "every line arrives whole, once" + } + + test "ensureUtf8 never throws, however often it is called" { + Terminal.ensureUtf8 () + Terminal.ensureUtf8 () + } + ] diff --git a/tests/Partas.Build.Tests/PipelineTests.fs b/tests/Partas.Build.Tests/PipelineTests.fs index fd8358d..9d3c01f 100644 --- a/tests/Partas.Build.Tests/PipelineTests.fs +++ b/tests/Partas.Build.Tests/PipelineTests.fs @@ -364,3 +364,105 @@ let tests = expectOneImplementation [ "description"; "onFailure"; "post"; "runAfterEachStage"; "runBeforeEachStage" ] } ] + +[] +let runs = + testList "pipeline run" [ + test "a step reads an environment variable set after the pipeline value was built" { + let seen = ResizeArray() + let late = $"PARTAS_BUILD_LATE_{System.Guid.NewGuid():N}" + let changed = $"PARTAS_BUILD_CHANGED_{System.Guid.NewGuid():N}" + System.Environment.SetEnvironmentVariable(changed, "before") + + let built = + pipeline "environment" { + quiet + stage "read" { + run (fun (ctx: StageContext) -> + seen.Add (StageContext.getEnvVar ctx late) + seen.Add (StageContext.getEnvVar ctx changed) + seen.Add (StageContext.buildEnvVars ctx |> Map.tryFind changed |> Option.defaultValue "")) + } + } + + try + System.Environment.SetEnvironmentVariable(late, "late") + System.Environment.SetEnvironmentVariable(changed, "after") + quietly (fun () -> PipelineContext.run built) + finally + System.Environment.SetEnvironmentVariable(late, null) + System.Environment.SetEnvironmentVariable(changed, null) + + Expect.sequenceEqual seen [ "late"; "after"; "after" ] + "the run starts from the environment as it is when the run starts, for lookups and child processes alike" + } + + test "a pipeline's own environment variables sit over the process environment" { + let seen = ResizeArray() + let name = $"PARTAS_BUILD_OWN_{System.Guid.NewGuid():N}" + + let built = + pipeline "environment" { + quiet + envVars [ name, "pipeline" ] + stage "read" { run (fun (ctx: StageContext) -> seen.Add (StageContext.getEnvVar ctx name)) } + } + + try + System.Environment.SetEnvironmentVariable(name, "process") + quietly (fun () -> PipelineContext.run built) + finally + System.Environment.SetEnvironmentVariable(name, null) + + Expect.sequenceEqual seen [ "pipeline" ] "the pipeline's value wins over the process's" + } + + test "a second concurrent run of one pipeline value fails fast, and a copy runs alongside" { + // One capture around the whole test: the runs on other threads write to the console it installs. + quietly (fun () -> + use started = new System.Threading.ManualResetEventSlim false + use release = new System.Threading.ManualResetEventSlim false + let ran = ResizeArray() + + let built = + pipeline "reentrant" { + quiet + stage "block" { + run (fun (_: StageContext) -> + lock ran (fun () -> ran.Add "block") + started.Set() + release.Wait(System.TimeSpan.FromSeconds 30.) |> ignore) + } + } + + let firstError: exn ref = ref null + let first = + System.Threading.Thread(fun () -> + try PipelineContext.run built with ex -> firstError.Value <- ex) + first.Start() + + try + Expect.isTrue (started.Wait(System.TimeSpan.FromSeconds 30.)) "the first run reaches its stage" + + let second = Expect.throwsC (fun () -> PipelineContext.run built) id + Expect.isTrue (second :? System.InvalidOperationException) $"the second run raises InvalidOperationException; got {second.GetType().Name}" + Expect.stringContains second.Message "reentrant" "the message names the pipeline" + + let copy = PipelineContext.withRunState built + let copyRun = System.Threading.Tasks.Task.Run(fun () -> PipelineContext.run copy) + release.Set() + Expect.isTrue (copyRun.Wait(System.TimeSpan.FromSeconds 30.)) "the copy runs to completion" + Expect.equal (StageTimings.ordered copy.Timings).Length 1 "the copy records into its own collections" + finally + release.Set() + first.Join() + + Expect.isNull firstError.Value "the first run is undisturbed by the rejected second" + Expect.equal (StageTimings.ordered built.Timings).Length 1 "the first run records its own stage alone" + Expect.equal (List.ofSeq ran) [ "block"; "block" ] "the rejected run ran nothing" + + PipelineContext.run built + Expect.equal ran.Count 3 "the value runs again once the first run has finished" + ) + } + ] From 11d9c122557fe5ae02b5815b583ed1be3f8a0b85 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 13:37:57 +0000 Subject: [PATCH 11/25] Keep each Console.Out writer's console; pin the test host's console to stdout Terminal.ansi() rebinding to the current Console.Out routed library output through Expecto's FuncTextWriter. On Unix the runtime locks Console.Out for every terminal write, while Expecto's writer takes Expecto's lock first, so a pipeline thread and Expecto's logger took the two locks in opposite orders and the Release suite could hang under a pseudo-terminal. - Terminal.ansi() remembers the console each Console.Out writer was first seen with, so a writer restored after a swap gets its console back instead of a new console over itself. - The test host pins AnsiConsole.Console to the real stdout before Expecto installs its writer. - Document the hazard and the host-side remedies in Terminal.fs, CLAUDE.md and PLAN-Integration.md. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 8 ++++++- notes/PLAN-Integration.md | 10 ++++++++ src/Partas.Build/Terminal.fs | 32 ++++++++++++++++++++----- tests/Partas.Build.Tests/Main.fs | 10 +++++++- tests/Partas.Build.Tests/OutputTests.fs | 26 ++++++++++++++++++++ 5 files changed, 78 insertions(+), 8 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index c00c034..52e8677 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -181,7 +181,13 @@ initialisation; `rootCommand` is annotated `string array` to keep the array cons `Console.Out` (spike in `PLAN-Integration.md` §8 Q5), so the library never calls `AnsiConsole.*` directly: `Terminal.ansi ()` answers `AnsiConsole.Console`, rebinding it to the current `Console.Out` when `Console.Out` changed since the last call and nothing else replaced `AnsiConsole.Console` meanwhile (an explicit assignment, -as the tests' `capturingOut` makes, is kept). Under `Terminal.withOutput writer` — an `AsyncLocal`, so it flows +as the tests' `capturingOut` makes, is kept). Each `Console.Out` writer keeps the console it was first seen +with, so restoring a writer restores its console. Writing through a host's `Console.Out` can deadlock: on Unix +the runtime locks `Console.Out` for every terminal write, and Expecto's `Console.Out` takes Expecto's lock before +writing to the terminal, so a pipeline thread and Expecto's logger take the two locks in opposite orders under a +pseudo-terminal. `tests/Partas.Build.Tests/Main.fs` therefore pins `AnsiConsole.Console` to the real stdout +before Expecto starts; a host with the same kind of writer passes `output` to `invoke` or pins the console the +same way. Under `Terminal.withOutput writer` — an `AsyncLocal`, so it flows into the thread-pool work the run starts — `ansi ()` is a plain (no ANSI, no colour) console over `writer`, `Terminal.out ()` (where a `Console`-sink step line goes) is `writer`, and `CmdRunner.outputPolicy` redirects a `Console`-sink child, which would otherwise inherit the real stdout. A console whose writer has no terminal diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index f47a0ae..112968b 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -309,6 +309,16 @@ From SageFs's source (`SageFs.Core/AppState.fs`, `Features/LiveTestingExecutors. library ever makes finds a static console created earlier under a different `Console.Out` (another library used `AnsiConsole` in a previous SageFs eval), it keeps that console until `Console.Out` next changes. + - Found in review: following `Console.Out` can deadlock under a host whose `Console.Out` takes a lock of its + own and then writes to the real terminal. On Unix the runtime locks `Console.Out` for every terminal write, + so Expecto's logger (Expecto lock, then `Console.Out`) and a pipeline thread writing through Expecto's + `FuncTextWriter` (`Console.Out`, then Expecto lock) invert. The Release suite under a pseudo-terminal hung + in 3 of 7 runs. `Console.WriteLine` from any second thread carries the same hazard, so the library cannot + remove it while it follows `Console.Out`; SageFs's `StringWriter`s are not exposed. Two changes: each + `Console.Out` writer keeps the console it was first seen with (a writer restored after a swap gets its + console back rather than a new one over itself), and the test host pins `AnsiConsole.Console` to the real + stdout before Expecto starts. A host with a writer like Expecto's passes `output` to `invoke` or pins the + console the same way. - `invoke`'s `output`, when given, is an `AsyncLocal` run writer (`Terminal.withOutput`): the pipeline's own lines, `Console`-sink step lines, and — by forcing redirection in `CmdRunner.outputPolicy` — a `Console`-sink child process's output go there, as plain text. `withOutput` wraps the writer in diff --git a/src/Partas.Build/Terminal.fs b/src/Partas.Build/Terminal.fs index 3f706a4..0cb0651 100644 --- a/src/Partas.Build/Terminal.fs +++ b/src/Partas.Build/Terminal.fs @@ -19,6 +19,7 @@ let FallbackWidth = 80 let private runOutput = AsyncLocal() let private plainConsoles = ConditionalWeakTable() +let private boundConsoles = ConditionalWeakTable() let private gate = obj () let mutable private lastConsole: IAnsiConsole = null let mutable private lastOut: TextWriter = null @@ -47,10 +48,20 @@ let out () : TextWriter = /// The Spectre console the library renders to. /// -/// Under withOutput, a plain console over that writer. Otherwise AnsiConsole.Console, rebound to -/// the current Console.Out when Console.Out has changed since the last call and nothing else has -/// replaced AnsiConsole.Console in the meantime; a console assigned explicitly is kept. A console whose -/// writer reports no width is given FallbackWidth. +/// +/// Under withOutput, a plain console over that writer. Otherwise AnsiConsole.Console, rebound when +/// Console.Out has changed since the last call and nothing else has replaced AnsiConsole.Console in +/// the meantime; a console assigned explicitly is kept. Each Console.Out writer keeps the console it was +/// first seen with, compared by reference as read from Console.Out: a writer that becomes current again gets +/// that console back, and a writer never seen before gets a new console over it. A console whose writer reports +/// no width is given FallbackWidth. +/// +/// +/// A host that installs a Console.Out which takes a lock of its own and then writes to the process's real +/// terminal can deadlock against the .NET runtime, which locks Console.Out for every terminal write on +/// Unix; Console.WriteLine from a second thread is exposed in the same way. Such a host passes an +/// output writer to invoke, or assigns AnsiConsole.Console before the first run. +/// /// let ansi () : IAnsiConsole = match runOutput.Value with @@ -60,10 +71,19 @@ let ansi () : IAnsiConsole = let console = AnsiConsole.Console let console = - if isNull lastConsole || not (obj.ReferenceEquals(console, lastConsole)) || obj.ReferenceEquals(current, lastOut) then + if isNull lastConsole || not (obj.ReferenceEquals(console, lastConsole)) then + boundConsoles.Remove current |> ignore + boundConsoles.Add(current, console) + console + elif obj.ReferenceEquals(current, lastOut) then console else - let rebound = AnsiConsole.Create(AnsiConsoleSettings(Out = AnsiConsoleOutput current)) + let rebound = + boundConsoles.GetValue( + current, + ConditionalWeakTable<_, _>.CreateValueCallback(fun writer -> + AnsiConsole.Create(AnsiConsoleSettings(Out = AnsiConsoleOutput writer))) + ) AnsiConsole.Console <- rebound rebound diff --git a/tests/Partas.Build.Tests/Main.fs b/tests/Partas.Build.Tests/Main.fs index c3d8808..702df27 100644 --- a/tests/Partas.Build.Tests/Main.fs +++ b/tests/Partas.Build.Tests/Main.fs @@ -1,6 +1,14 @@ module Partas.Build.Tests.Main +open System open Expecto +open Spectre.Console [] -let main argv = runTestsInAssemblyWithCLIArgs [] argv \ No newline at end of file +let main argv = + // Expecto installs a Console.Out that takes Expecto's lock and then writes to the terminal; on Unix, the + // runtime locks Console.Out for every terminal write. Library output written through that Console.Out acquires + // the two locks in the reverse order of Expecto's logger and deadlocks under a pseudo-terminal, so the + // library's console is pinned to the process's stdout before Expecto starts. + AnsiConsole.Console <- AnsiConsole.Create(AnsiConsoleSettings(Out = AnsiConsoleOutput Console.Out)) + runTestsInAssemblyWithCLIArgs [] argv diff --git a/tests/Partas.Build.Tests/OutputTests.fs b/tests/Partas.Build.Tests/OutputTests.fs index 290a453..83ec05d 100644 --- a/tests/Partas.Build.Tests/OutputTests.fs +++ b/tests/Partas.Build.Tests/OutputTests.fs @@ -265,6 +265,32 @@ let terminal = Expect.stringContains (second.ToString()) "to-the-second" "and lands in the writer current at the time" } + test "a Console.Out that becomes current again gets its first console back" { + let original = System.Console.Out + let originalAnsi = AnsiConsole.Console + use host = new StringWriter() + use hostRecorded = new StringWriter() + use swapped = new StringWriter() + + try + System.Console.SetOut host + // SetOut wraps a writer on every call; a host restores the wrapper it read from Console.Out. + let hostOut = System.Console.Out + AnsiConsole.Console <- Terminal.plain hostRecorded + Terminal.ansi () |> ignore + System.Console.SetOut swapped + Terminal.ansi().WriteLine "to-the-swapped" + System.Console.SetOut hostOut + Terminal.ansi().WriteLine "back-to-the-host" + finally + System.Console.SetOut original + AnsiConsole.Console <- originalAnsi + + Expect.stringContains (swapped.ToString()) "to-the-swapped" "the swapped writer receives the write made while it is current" + Expect.stringContains (hostRecorded.ToString()) "back-to-the-host" "the restored writer gets the console it was first seen with" + Expect.equal (host.ToString()) "" "the restored writer's own text is untouched" + } + test "a console assigned to AnsiConsole.Console is kept" { let originalAnsi = AnsiConsole.Console use recorded = new StringWriter() From df2f3e9c93c8fb71ba8f976ab1bddd0aefb0f0e9 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 11:15:21 +0000 Subject: [PATCH 12/25] =?UTF-8?q?Close=20the=20PLAN-Integration=20=C2=A73.?= =?UTF-8?q?2=20API=20traps?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - `runLine` runs a command line derived from the stage context (string, Async/Task, and their option forms). The same six `run` overloads are now []: a lambda returning a message would start a process. `run`'s overload set is otherwise unchanged, so the FS0041 balance around `run (build, buildStep)` holds (spiked over every call-site shape; CompilerProbe Debug and Release). - `Input.desc` is [] in favour of `Input.description`; `inputs` already was, in favour of `input`. Usages in src/, Build/, Partas.Build.ExternalAnnotations/, README and docs/content migrated. - `when' value "reason"` on `stage` (and its InputSpec mirror) records the reason through addPredicateBecause, so --explain prints `(skipped: --quick is set)`. Build/Program.fs gives each `when'` one. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- Build/Program.fs | 24 +++---- CLAUDE.md | 6 +- Partas.Build.ExternalAnnotations/Library.fs | 18 +++--- README.md | 6 +- docs/content/Build/CAPABILITIES.md | 9 +-- docs/content/Build/composition.fsx | 6 +- .../computation-expression-operations.fsx | 31 +++++---- docs/content/Build/index.fsx | 7 ++- docs/content/index.fsx | 7 ++- notes/PLAN-Integration.md | 23 ++++++- src/Partas.Build.Baked/Common.fs | 2 +- src/Partas.Build.Baked/NuGet.fs | 2 +- src/Partas.Build.Baked/SemVer.fs | 2 +- src/Partas.Build/Builders/Conditions.fs | 27 +++++++- src/Partas.Build/Builders/StageSettings.fs | 63 +++++++++++++++++++ src/Partas.Build/Explain.fs | 2 +- src/Partas.Build/System.CommandLine/Inputs.fs | 4 +- tests/Partas.Build.CompilerProbe/Probe.fs | 4 +- tests/Partas.Build.Tests/CmdTests.fs | 40 +++++++++++- tests/Partas.Build.Tests/ConditionsTests.fs | 9 +++ tests/Partas.Build.Tests/ExplainTests.fs | 29 +++++++++ 21 files changed, 256 insertions(+), 65 deletions(-) diff --git a/Build/Program.fs b/Build/Program.fs index a7b9a8e..aa32778 100644 --- a/Build/Program.fs +++ b/Build/Program.fs @@ -1,4 +1,4 @@ -/// +/// /// The build CLI, written against Partas.Build itself. /// /// A step is a stage of a pipeline, and a stage that needs a flag binds it in an @@ -38,17 +38,17 @@ module Options = let quick = Input.option "--quick" |> Input.alias "-q" - |> Input.desc "Skips restores, installations, formatting etc" + |> Input.description "Skips restores, installations, formatting etc" let skipTests = Input.option "--skip-tests" - |> Input.desc "Skips running tests" + |> Input.description "Skips running tests" let nugetSource = Input.option "--nuget-source" |> Input.def "https://api.nuget.org/v3/index.json" - |> Input.desc "NuGet feed URL for authenticated publishing" + |> Input.description "NuGet feed URL for authenticated publishing" let watch = Input.option "--watch" - |> Input.desc "Runs the operation in watch mode." + |> Input.description "Runs the operation in watch mode." let config = Baked.Dotnet.config.option @@ -82,7 +82,7 @@ module Project = Input.option "--project" |> Input.alias "-p" |> Input.arity Arity.OneOrMore - |> Input.desc "The project(s) to target" + |> Input.description "The project(s) to target" |> Input.allowMultipleArgumentsPerToken |> Input.mapFromManyWith StringComparer.OrdinalIgnoreCase [ yield! allProjects @@ -94,7 +94,7 @@ module Prelude = let restore = input { let! quick = Options.quick return stage "restore" { - when' (not quick) + when' (not quick) "--quick is set" run "dotnet tool restore --verbosity q" run (cmd $"dotnet restore {Repo.Project.SolutionFile}") } @@ -103,7 +103,7 @@ module Prelude = let! quick = Options.quick return stage "clean" { - when' (not quick) + when' (not quick) "--quick is set" run (fun (_: StageContext) -> Repo.VirtualFileSystem.bin.``.``.EnumerateFiles("*.nupkg", SearchOption.AllDirectories) @@ -148,7 +148,7 @@ module ProjectManagement = and! project = project return stage $"publish {project}" { stage "local publish" { - when' key.IsNone + when' key.IsNone "a NuGet API key is set" echo "Publishing to local feed" run $"dotnet nuget push {project} --source local --skip-duplicate" } @@ -176,7 +176,7 @@ module Tests = |> List.map (_.Path >> InputSpec.ret >> ProjectManagement.build) |> InputSpec.sequence return stage "build tests" { - when' (not skipTests) + when' (not skipTests) "--skip-tests is set" projects } } @@ -192,7 +192,7 @@ module Tests = and! config = Options.config and! ci = Baked.Common.isCI return stage "test" { - when' (not skipTests) + when' (not skipTests) "--skip-tests is set" // Expecto reports assertions on stdout; keep them visible in CI and uploaded logs. outputTo StageOutput.Console // Commands exercised by tests must not append fixture reports to the real job summary. @@ -235,7 +235,7 @@ module Documentation = let llms = input { let! watch = Options.watch return stage "llms" { - when' (not watch) + when' (not watch) "--watch is set" run (fun ctx -> let header = File.ReadAllText(Path.Combine(root, "docs", "static", "llms.txt")).TrimEnd() for name in [ "llms.txt"; "llms-full.txt" ] do diff --git a/CLAUDE.md b/CLAUDE.md index 52e8677..7a9ce8a 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -8,7 +8,7 @@ This file provides guidance to Claude Code (claude.ai/code) when working with co `notes/PLAN-Execution.md` and its checklist `notes/PLAN-Execution-Tasks.md` own the current execution model: typed producers and `consumes`, failure handlers, the scope reports, and the shared `StageSettingsBuilder`/`PipelineSettingsBuilder`. -The one-line version: input collection is **applicative**, not monadic. `InputSpec<'T> = { Inputs: ActionInput list; Read: ParseResult -> 'T }` makes the input set readable without a `ParseResult`, breaking the circularity between registering options and binding their values. Stages are pure (no `ActionContext`); binding happens in an `inputs { let! … and! … return … }` CE, and pipelines/commands harvest `.Inputs` upward. +The one-line version: input collection is **applicative**, not monadic. `InputSpec<'T> = { Inputs: ActionInput list; Read: ParseResult -> 'T }` makes the input set readable without a `ParseResult`, breaking the circularity between registering options and binding their values. Stages are pure (no `ActionContext`); binding happens in an `input { let! … and! … return … }` CE (`inputs` is its obsolete second name), and pipelines/commands harvest `.Inputs` upward. ## Commands @@ -41,7 +41,7 @@ Fast inner loop while working on the library only: `dotnet build src/Partas.Buil - Phases 0-7 of `notes/PLAN.md` are done: `dotnet build src/Partas.Build` is clean and `dotnet run --project Build.fsproj -- test` is green (443 Expecto tests across four suites — 301 in `tests/Partas.Build.Tests`, one file per layer, plus 65 in `tests/Partas.Build.ExternalAnnotations.Tests`, 74 in `tests/Partas.ExternalAnnotations.Tests` and 3 in `tests/Partas.Build.Cmd.NetStandard.Tests`; the `test` stage also runs `tests/Partas.Build.CompilerProbe` in both Debug and Release, 11 tests each). The `Build/` CLI is written against the library: a breaking change breaks it first. - The DSL exists end to end: `inputs` (`Builders/Inputs.fs`), `stage` (`Builders/Stage.fs`), `pipeline` (`Builders/Pipeline.fs`), `command`/`rootCommand` (`Builders/Command.fs`). A stage that declares an input turns its pipeline into an `InputSpec`, and the command registers whatever those specs declare. Conditions are in `Builders/Conditions.fs` — `whenAll`/`whenAny`/`whenNot`/`whenEnv`/`whenStage` plus the `when'`/`whenEnvVar`/`whenBranch`/`when{Windows,Linux,OSX}` operations on `StageBuilder`. - A command carries `PipelineDefaults: BuildPipeline` and takes the pipeline-level operations itself (`workingDir`, `envVars`, the three timeouts, `acceptExitCodes`, the output operations, `noPrefixForStep`/`noStdRedirectForStep`, `runBeforeEachStage`/`runAfterEachStage`, `post`, `verbosity`/`verbose`/`quiet`), each one built through `CommandBuilderBase.MapPipelineDefault`. They are **defaults, not overrides**: `PipelineContext.applyDefaults` copies a setting across only where the pipeline left it at the value `PipelineContext.create` gave it, so a pipeline that sets the same thing wins. See *Command defaults* below. -- `run`/`runSensitive` start real processes through `CmdRunner` (`Process.fs`). A `Cmd`, defined in `src/Partas.Build.Cmd/Program.fs`, keeps the executable and its arguments apart all the way to `ProcessStartInfo.ArgumentList`, so the platform does the escaping. Interpolate through the `cmd` helper — `run (cmd $"dotnet build {project}")`. `run $"..."` binds to the `string` overload and flattens the holes; `runSensitive $"..."` takes the `FormattableString` directly and masks every hole as `***`. There is no `Fake.Core.Process` dependency; `notes/PLAN.md`'s *The command runner* records why. +- `run`/`runSensitive` start real processes through `CmdRunner` (`Process.fs`). A `Cmd`, defined in `src/Partas.Build.Cmd/Program.fs`, keeps the executable and its arguments apart all the way to `ProcessStartInfo.ArgumentList`, so the platform does the escaping. Interpolate through the `cmd` helper — `run (cmd $"dotnet build {project}")`. `run $"..."` binds to the `string` overload and flattens the holes; `runSensitive $"..."` takes the `FormattableString` directly and masks every hole as `***`. A function returning a command line is `runLine (fun ctx -> "...")`; the `run` overloads over `StageContext -> string` (and its `Async`/`Task`/`option` forms) are `[]`, since a lambda returning a message would start a process. `runLine` is a separate name, so the `run` overload set — and the `FS0041` balance below — is unchanged. There is no `Fake.Core.Process` dependency; `notes/PLAN.md`'s *The command runner* records why. - Fun.Build's `Mode` (`Execution | CommandHelp | Verification`) has **not** been ported. `PipelineContext.Verify` is a placeholder and `buildPipelineVerification` is commented out. `CommandHelp` is redundant: System.CommandLine generates help. Whether `Verification` survives is an open question in `notes/PLAN.md`. - `PipelineContext.run` is complete enough to execute stages, post stages, timeouts, parallelism and cancellation. @@ -250,7 +250,7 @@ Overload resolution in these builders fails in ways that are invisible by inspec `Build/Program.fs` is the whole CLI — repository paths, options, stages and commands in one file. Repository paths come from `Partas.TypeProvider.BuildHelper` (`type Repo = BuildHelperProvider<...>`, with `Repo.FileSystem` and `Repo.VirtualFileSystem` for the real and virtual file systems), so a renamed project breaks compilation instead of failing mid-release. A new packable project goes in `Project.allProjects`, which is both what `bump` can version and what `pack` packs; `Repo.Project..Path` is a compile-time constant, while `PackageId`/`AssemblyName`/`Version` are MSBuild evaluations that shell out to `dotnet msbuild -getProperty`, so keep those off any path that runs before parsing. -Since Phase 7 the CLI is written against Partas.Build (`Build.fsproj` has a project reference to `src/Partas.Build`), so it doubles as the design's acceptance test. A step is a stage; a stage that needs a flag binds it in `inputs { let! quick = Options.quick ... return stage "..." { when' (not quick); run (cmd $"dotnet ...") } }`, and the command registers it by running the pipeline that contains it. The CLI has no per-command option lists and no process wrappers. Custom operations cannot sit under an `if`/`match`, so a stage that branches builds a `Cmd` first and runs it unconditionally, and a stage that exists only when an option was supplied is yielded through `whenSome` — `ProjectManagement.publish` yields its `nuget publish` stage that way, so the stage closes over the key rather than reaching for `key.Value` under a `when'`. +Since Phase 7 the CLI is written against Partas.Build (`Build.fsproj` has a project reference to `src/Partas.Build`), so it doubles as the design's acceptance test. A step is a stage; a stage that needs a flag binds it in `input { let! quick = Options.quick ... return stage "..." { when' (not quick) "--quick is set"; run (cmd $"dotnet ...") } }`, and the command registers it by running the pipeline that contains it. The CLI has no per-command option lists and no process wrappers. Custom operations cannot sit under an `if`/`match`, so a stage that branches builds a `Cmd` first and runs it unconditionally, and a stage that exists only when an option was supplied is yielded through `whenSome` — `ProjectManagement.publish` yields its `nuget publish` stage that way, so the stage closes over the key rather than reaching for `key.Value` under a `when'`. The four Expecto suites run `--sequenced`. Each drives real pipelines, and a pipeline writes to one process-wide console and holds a thread in `Async.RunSynchronously` for the length of every stage — run in parallel on a two-core runner, that yields a log whose lines belong to no test in particular, with enough blocked workers that the thread pool grows one thread at a time. `Tests.execute` captures the suites' output when `--ci` is set, so a green CI run says nothing and a red one lifts the whole failure into the annotation; locally it stays live. `Tests.execute` also runs `tests/Partas.Build.CompilerProbe` twice, once per configuration, regardless of `--configuration`. Release catches an `inline` member that applies a `Build*` alias (`FS1118`), which a Debug build compiles clean. diff --git a/Partas.Build.ExternalAnnotations/Library.fs b/Partas.Build.ExternalAnnotations/Library.fs index ca87b48..5c65715 100644 --- a/Partas.Build.ExternalAnnotations/Library.fs +++ b/Partas.Build.ExternalAnnotations/Library.fs @@ -58,30 +58,30 @@ module ExternalAnnotations = module Options = let strict = Input.option "--strict" - |> Input.desc "Fail when any member is skipped, rather than warning and continuing" + |> Input.description "Fail when any member is skipped, rather than warning and continuing" let annotationsTool = Input.optionMaybe "--annotations-tool" |> Input.arity Arity.ExactlyOne - |> Input.desc "Command that generates annotations during pack, e.g. 'dotnet partas-annotations'" + |> Input.description "Command that generates annotations during pack, e.g. 'dotnet partas-annotations'" |> Input.helpName "COMMAND" let force = Input.option "--force" - |> Input.desc "Overwrite an existing Directory.Build.targets" + |> Input.description "Overwrite an existing Directory.Build.targets" let assembly = Input.option "--assembly" |> Input.required |> Input.acceptLegalFilePathsOnly - |> Input.desc "Assembly to scan for annotations" + |> Input.description "Assembly to scan for annotations" |> Input.helpName "PATH" let output = Input.option "--output" |> Input.required |> Input.acceptLegalFilePathsOnly - |> Input.desc "Annotations file to write" + |> Input.description "Annotations file to write" |> Input.helpName "PATH" let attribute = @@ -89,28 +89,28 @@ module ExternalAnnotations = |> Input.def [||] |> Input.arity Arity.ZeroOrMore |> Input.allowMultipleArgumentsPerToken - |> Input.desc + |> Input.description "Collect only these attributes, by simple name; the default is every JetBrains.Annotations attribute" |> Input.helpName "NAME" let minMembers = Input.option "--min-members" |> Input.def 0 - |> Input.desc "Fail when any assembly's sidecar annotates fewer members than this" + |> Input.description "Fail when any assembly's sidecar annotates fewer members than this" |> Input.helpName "N" let package = Input.option "--package" |> Input.required |> Input.acceptLegalFilePathsOnly - |> Input.desc "The .nupkg to check" + |> Input.description "The .nupkg to check" |> Input.helpName "PATH" let directory = Input.option "--directory" |> Input.def "." |> Input.acceptLegalFilePathsOnly - |> Input.desc "Directory to write Directory.Build.targets into" + |> Input.description "Directory to write Directory.Build.targets into" |> Input.helpName "PATH" /// diff --git a/README.md b/README.md index ff1f8d3..e7e510f 100644 --- a/README.md +++ b/README.md @@ -54,7 +54,7 @@ module Options = let quick = Input.option "--quick" |> Input.alias "-q" - |> Input.desc "Skip restores and cleaning" + |> Input.description "Skip restores and cleaning" let config = Input.option "--configuration" @@ -62,14 +62,14 @@ module Options = |> Input.def "Release" |> Input.helpName "Debug|Release" |> Input.acceptOnlyFromAmong [ "Debug"; "Release" ] - |> Input.desc "Build configuration" + |> Input.description "Build configuration" module Stages = let restore = input { let! quick = Options.quick return stage "restore" { - when' (not quick) + when' (not quick) "--quick is set" // the reason --explain prints when the stage is skipped run "dotnet restore" } } diff --git a/docs/content/Build/CAPABILITIES.md b/docs/content/Build/CAPABILITIES.md index 842d99c..d6e1be0 100644 --- a/docs/content/Build/CAPABILITIES.md +++ b/docs/content/Build/CAPABILITIES.md @@ -97,12 +97,13 @@ Available inside `stage`, and inside `whenStage`, which accepts everything `stag | Operation | What it does | |---|---| -| `run` | Adds a step. Takes a literal command line, a `Cmd`, or a function of the `StageContext` returning `unit`, `int`, `Result`, a `Cmd`, an `Async<_>` or a `Task<_>` of any of those, optionally wrapped in `option` | +| `run` | Adds a step. Takes a literal command line, a `Cmd`, or a function of the `StageContext` returning `unit`, `int`, `Result`, a `Cmd`, an `Async<_>` or a `Task<_>` of any of those, optionally wrapped in `option`. A function returning a `string` is obsolete: use `runLine` | +| `runLine` | Adds a step that runs the command line a function of the `StageContext` returns (`string`, `Async` or `Task`, optionally wrapped in `option`). The line is split on whitespace, honouring quotes | | `runSensitive` | Adds a step from an interpolated command line with every hole masked as `***` wherever the library prints it | | `runOperation` | Adds a step from an `Operation`, with an optional label for `--explain`. Runs under the stage's working directory, environment, acceptable exit codes and output routing | | `runHttpHealthCheck` | Adds a step that polls a URL until it answers or the stage is cancelled | | `echo` | Adds a step that prints a message through the stage's output sink | -| `when'` | Runs the stage only when a `bool` holds, or only when a given `StageContext` succeeds | +| `when'` | Runs the stage only when a `bool` holds, or only when a given `StageContext` succeeds. `when' (not quick) "--quick is set"` gives `--explain` the reason it prints against the skipped stage | | `whenEnvVar` | Runs the stage only when an environment variable is set, or set to a given value; also takes an `EnvArg` | | `whenBranch` / `whenBranches` | Runs the stage only on the named git branch. Reads `git branch --show-current` in the stage's working directory; a missing git evaluates false rather than throwing | | `whenWindows` / `whenLinux` / `whenOSX` | Runs the stage only on that platform. Pass `false` to invert | @@ -382,7 +383,7 @@ Shaping combinators, all `ActionInput<'T> -> ActionInput<'T>` and all pipeable: | Function | What it does | |---------------------------------------------------------------------|---------------------------------------------------------------------------------------------------------------------------| | `Input.alias` / `Input.aliases` | Adds alternative names. Options only | -| `Input.description`, `Input.desc` | The help text | +| `Input.description` (`Input.desc` is obsolete) | The help text | | `Input.helpName` | The value placeholder in help — `` | | `Input.defaultValue`, `Input.def` | The value used when the token is absent | | `Input.defaultValueFactory` | The same, computed from the `ArgumentResult` | @@ -428,7 +429,7 @@ let build (projects: InputSpec) = input { | `InputSpec.union` | Concatenates input lists, keeping the first occurrence of each | The `input { let! … and! … return … }` CE is the usual way to build one; `inputs` is the same builder under -a second name (`src/Partas.Build/Builders/Inputs.fs` binds both). It is applicative: bind every source +an obsolete second name (`src/Partas.Build/Builders/Inputs.fs` binds both). It is applicative: bind every source in a single `let!`/`and!` group. A sequential second `let!` is a compile error (`FS0708`): the input set must be readable before anything is parsed. An `input { }` nested inside another's `return` produces an `InputSpec>`, which nothing accepts — pass the *source* in as an `InputSpec` instead. diff --git a/docs/content/Build/composition.fsx b/docs/content/Build/composition.fsx index 79986cc..692e52c 100644 --- a/docs/content/Build/composition.fsx +++ b/docs/content/Build/composition.fsx @@ -82,7 +82,7 @@ module Options = let quick = Input.option "--quick" |> Input.alias "-q" - |> Input.desc "Skip restores and cleaning" + |> Input.description "Skip restores and cleaning" let verbose = Input.option "--verbose" |> Input.alias "-v" @@ -263,7 +263,7 @@ items` does the same over a mapping. These are the two functions to reach for wh A wrapper can bind flags the wrapped blocks know nothing about, alongside the sequenced blocks: *) -let skipTests = Input.option "--skip-tests" |> Input.desc "Build the tests but do not run them" +let skipTests = Input.option "--skip-tests" |> Input.description "Build the tests but do not run them" let testGroup (blocks: InputSpec list) = input { let! stages = InputSpec.sequence blocks @@ -472,7 +472,7 @@ module Options = Input.option "--target" |> Input.mapFromAmong [ "node", "node"; "browser", "browser" ] |> Input.def "node" - |> Input.desc "Runtime the wire layer is generated for" + |> Input.description "Runtime the wire layer is generated for" module Stages = let generate layer = input { diff --git a/docs/content/Build/computation-expression-operations.fsx b/docs/content/Build/computation-expression-operations.fsx index 7f7863e..832443b 100644 --- a/docs/content/Build/computation-expression-operations.fsx +++ b/docs/content/Build/computation-expression-operations.fsx @@ -125,31 +125,36 @@ let _ = stage "stage" { run (fun _ -> task { do () }) (** +#### `runLine` + +A function returning a command line is `runLine`, not `run`. `run (fun ctx -> "...")` still compiles, marked +obsolete: a lambda written to return a message would otherwise start a process. The line is split on whitespace, +honouring quotes; build a `Cmd` with `cmd $"..."` to keep each interpolation hole as one argument. + ##### `commandFn: StageContext -> string` ##### `commandFn: StageContext -> Async` ##### `commandFn: StageContext -> Task` *) - run (fun _ -> "dotnet build") - run (fun _ -> async { return "dotnet build" }) - run (fun _ -> task { return "dotnet build" }) + runLine (fun _ -> "dotnet build") + runLine (fun _ -> async { return "dotnet build" }) + runLine (fun _ -> task { return "dotnet build" }) // With CancellationToken - run (fun _ -> "dotnet build") CancellationToken.None - run (fun _ -> async { return "dotnet build" }) CancellationToken.None - run (fun _ -> task { return "dotnet build" }) CancellationToken.None + runLine (fun _ -> "dotnet build") CancellationToken.None + runLine (fun _ -> async { return "dotnet build" }) CancellationToken.None + runLine (fun _ -> task { return "dotnet build" }) CancellationToken.None (** ##### `commandMaybeFn: StageContext -> string option` ##### `commandMaybeFn: StageContext -> Async` ##### `commandMaybeFn: StageContext -> Task` *) - // todo - overloads without CancellationToken should not require explicit typing - run (fun _ -> Some "dotnet build") - run (fun _ -> async { return Option.None }) - run (fun _ -> task { return Some "dotnet build" }) + runLine (fun _ -> Some "dotnet build") + runLine (fun _ -> async { return Option.None }) + runLine (fun _ -> task { return Some "dotnet build" }) // With CancellationToken - run (fun _ -> Some "dotnet build") CancellationToken.None - run (fun _ -> async { return Some "dotnet build" }) CancellationToken.None - run (fun _ -> task { return Some "dotnet build" }) CancellationToken.None + runLine (fun _ -> Some "dotnet build") CancellationToken.None + runLine (fun _ -> async { return Some "dotnet build" }) CancellationToken.None + runLine (fun _ -> task { return Some "dotnet build" }) CancellationToken.None (** diff --git a/docs/content/Build/index.fsx b/docs/content/Build/index.fsx index 924e866..51b1cff 100644 --- a/docs/content/Build/index.fsx +++ b/docs/content/Build/index.fsx @@ -69,7 +69,7 @@ automatic validation and help. |---|---|---| | Step | `run`, `echo`, … | one action inside a stage | | Stage | `stage "name" { }` | `StageContext` | -| Inputs | `inputs { }` | `InputSpec<'T>` | +| Inputs | `input { }` | `InputSpec<'T>` | | Pipeline | `pipeline "name" { }` | `PipelineContext` or `InputSpec` | | Command | `command "name" { }` | `System.CommandLine.Command` | | Root | `rootCommand argv { }` | `int` exit code — **it runs immediately** | @@ -193,6 +193,9 @@ let combined = `when'` also accepts a whole `StageContext`. It runs for real, side effects and console output included, and its success is the answer. +A `bool` carries no reason, so `--explain` prints a stage it turns off as `(skipped)`. Name the reason as a second +argument, `when' (not quick) "--quick is set"`, and `--explain` prints `(skipped: --quick is set)`. + ## Inputs A stage that needs a CLI flag binds it in an `input` CE. It is then lifted into any command that asks for it, @@ -203,7 +206,7 @@ module Options = let quick = Input.option "--quick" |> Input.alias "-q" - |> Input.desc "Skip restores and cleaning" + |> Input.description "Skip restores and cleaning" let config = Input.option "--configuration" diff --git a/docs/content/index.fsx b/docs/content/index.fsx index 1dce042..97e5de7 100644 --- a/docs/content/index.fsx +++ b/docs/content/index.fsx @@ -70,7 +70,7 @@ automatic validation and help. |---|---|---| | Step | `run`, `echo`, … | one action inside a stage | | Stage | `stage "name" { }` | `StageContext` | -| Inputs | `inputs { }` | `InputSpec<'T>` | +| Inputs | `input { }` | `InputSpec<'T>` | | Pipeline | `pipeline "name" { }` | `PipelineContext` or `InputSpec` | | Command | `command "name" { }` | `System.CommandLine.Command` | | Root | `rootCommand argv { }` | `int` exit code — **it runs immediately** | @@ -194,6 +194,9 @@ let combined = `when'` also accepts a whole `StageContext`. It runs for real, side effects and console output included, and its success is the answer. +A `bool` carries no reason, so `--explain` prints a stage it turns off as `(skipped)`. Name the reason as a second +argument, `when' (not quick) "--quick is set"`, and `--explain` prints `(skipped: --quick is set)`. + ## Inputs A stage that needs a CLI flag binds it in an `input` CE. It is then lifted into any command that asks for it, @@ -204,7 +207,7 @@ module Options = let quick = Input.option "--quick" |> Input.alias "-q" - |> Input.desc "Skip restores and cleaning" + |> Input.description "Skip restores and cleaning" let config = Input.option "--configuration" diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 112968b..0f354cb 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -95,10 +95,31 @@ one prefab field. written to return a message becomes a process launch. Rename to `runLine`, or mark the `string`-returning overload `[]` in favour of `run (fun ctx -> cmd …)`. Check that the rename does not disturb the `FS0041` balance recorded in CLAUDE.md for `run (build, buildStep)`. + **Status: implemented on `claude/partas-build-patterns-jgrwr0-api-traps`.** Both: the six `run` overloads over + `StageContext -> string`, `Async`, `Task` and their `option` forms are `[]` (they keep + working), and `runLine` carries the same six under a name that says what the string is. The `option` forms are + included, a deviation from the plan's "the `string`-returning overload": `fun _ -> Some "…"` is the same trap. + `runLine` is a separate operation, so `run`'s overload set is unchanged and the `FS0041` balance with it; + compiler-established in a scratch project over every call-site shape (annotated and bare lambdas, each return + type, `fun _ -> None`, `fun ctx -> failwith …`, the `BuildStep`-returning lambda, a `runLine` after an + input-declaring sub-stage) and by `tests/Partas.Build.CompilerProbe` in Debug and Release. `Obsolete` does not + take part in overload resolution: the warning fires only where an obsolete overload is the one chosen. No + project in the repository sets `TreatWarningsAsErrors`; the call sites were migrated anyway. - **Duplicate names**: `Input.desc`/`Input.description` (`Inputs.fs:209,215`) and `input`/`inputs` (`Builders/Inputs.fs:61,64`). Consumers mix them. Keep one of each, `[]` the other. + **Status: implemented on `claude/partas-build-patterns-jgrwr0-api-traps`.** `Input.description` and `input` are + kept: `description` matches System.CommandLine's `Description` and the `description` operation of `command` and + `pipeline`; `inputs` was already `[]`. Every `Input.desc` in `src/`, `Build/`, `Partas.Build.ExternalAnnotations/`, + `README.md` and `docs/content/` now reads `Input.description`. Deviation: `docs/blog/` and `notes/` keep + `Input.desc` — they are dated records of the API at the time they were written. - **`when' bool` carries no reason.** Add `when' (reason: string, cond: bool)` or a `whenNotFlag` for the `when' (not quick)` idiom, so `--explain` names the flag that skipped the stage. + **Status: implemented on `claude/partas-build-patterns-jgrwr0-api-traps`.** `when' value "reason"` on `stage` + (and its `InputSpec` mirror), recorded through `addPredicateBecause`: `when' (not quick) "--quick is set"` renders + as `(skipped: --quick is set)`. Deviation: the condition comes first, so a reason is appended to an existing + `when'` rather than wrapped around it; CE custom operations take their arguments space-separated, so the plan's + tupled `when' (reason, cond)` was never the call-site shape. `ConditionsBuilder`'s `when'` is unchanged: a + `whenAll`/`whenAny`/`whenNot` records no per-leaf reason. `Build/Program.fs` gives every `when'` a reason. - **`printfn` in Baked**: replace with `StageContext.writeLine`. **Status: implemented on `claude/partas-build-patterns-jgrwr0-int-usability`** (`bumpImpl`; the only `printfn` in Baked), with a test in `tests/Partas.Build.Tests/BakedTests.fs`. @@ -427,7 +448,7 @@ needs checking against the code. |---|---|---|---| | 1 | `.mcp.json`, `printfn` in Baked, `Cmd.argIf` in `Program.fs` — **done** | hygiene | trivial | | 2 | Task 14b: no consumer needs `Internal` — **done** | usability | medium | -| 3 | `run (fun _ -> string)` rename/obsolete; `desc`/`input` duplicates | usability | small | +| 3 | `run (fun _ -> string)` rename/obsolete; `desc`/`input` duplicates — **done** | usability | small | | 4 | Exit codes (§4.2) | discoverability | small | | 5 | `Command.invoke` + `RunResult` (§5.3.1) | SageFs, discoverability | medium | | 6 | JSON for `--explain`, the run result, `--schema` (§4.1) — serializes 5's result — **done** | discoverability | medium | diff --git a/src/Partas.Build.Baked/Common.fs b/src/Partas.Build.Baked/Common.fs index a0351f3..2dc91aa 100644 --- a/src/Partas.Build.Baked/Common.fs +++ b/src/Partas.Build.Baked/Common.fs @@ -5,7 +5,7 @@ open Partas.Build let isCI = Input.option "--ci" - |> Input.desc "Indicates that the build is running in a CI environment; defaults to true if environment variables indicate so" + |> Input.description "Indicates that the build is running in a CI environment; defaults to true if environment variables indicate so" |> Input.def ( let vars = System.Environment.GetEnvironmentVariables() vars.Contains "CI" diff --git a/src/Partas.Build.Baked/NuGet.fs b/src/Partas.Build.Baked/NuGet.fs index 66b98cd..a84794d 100644 --- a/src/Partas.Build.Baked/NuGet.fs +++ b/src/Partas.Build.Baked/NuGet.fs @@ -9,7 +9,7 @@ let apiKey = |> BuildOptionInput.withAlias "k" |> BuildOption.createMaybe |> BuildOption.map ( - Input.desc "NuGet API key" + Input.description "NuGet API key" >> Input.helpName "APIKEY" >> Input.arity Arity.ExactlyOne >> Input.sensitive diff --git a/src/Partas.Build.Baked/SemVer.fs b/src/Partas.Build.Baked/SemVer.fs index 1165f4d..a210d19 100644 --- a/src/Partas.Build.Baked/SemVer.fs +++ b/src/Partas.Build.Baked/SemVer.fs @@ -23,7 +23,7 @@ let bump = BuildOptionInput.create "bump" |> BuildOption.createMaybe |> BuildOption.map ( - Input.desc "Bump version by type. Defaults to patch. [major|minor|patch|alpha|beta|rc|preview|]" + Input.description "Bump version by type. Defaults to patch. [major|minor|patch|alpha|beta|rc|preview|]" >> Input.helpName "BUMP_TYPE" >> Input.customParser ( fun result -> diff --git a/src/Partas.Build/Builders/Conditions.fs b/src/Partas.Build/Builders/Conditions.fs index c2d117d..69b7cd6 100644 --- a/src/Partas.Build/Builders/Conditions.fs +++ b/src/Partas.Build/Builders/Conditions.fs @@ -128,7 +128,7 @@ let inline private addCondition ([] build: BuildConditions) (condition: Bui /// Collects conditions for whenAll, whenAny and whenNot. /// /// There is no cmdArg operation: System.CommandLine owns arguments now, so a stage that wants to branch on -/// a flag binds it in an inputs CE and tests the bound value with when'. +/// a flag binds it in an input CE and tests the bound value with when'. /// [] type ConditionsBuilder() = @@ -152,7 +152,7 @@ type ConditionsBuilder() = /// Adds a literal boolean condition to the builder. /// /// - /// The value is typically a boolean bound by an enclosing inputs CE. + /// The value is typically a boolean bound by an enclosing input CE. /// [] member inline _.when'([] build: BuildConditions, value: bool) = addCondition build (fun _ -> value) @@ -307,12 +307,26 @@ type StageBuilder with /// Sets whether the stage is active using a literal boolean condition. /// /// - /// The value is typically a boolean bound by an enclosing inputs CE. + /// The value is typically a boolean bound by an enclosing input CE. /// /// [] member inline _.when'([] build: BuildStage, value: bool) = StageContext.buildStageIsActive build (fun _ -> value) + /// Sets whether the stage is active using a literal boolean condition, and names the reason + /// --explain prints when the condition is false. + /// + /// + /// when' (not quick) "--quick is set" renders a skipped stage as (skipped: --quick is set). + /// + /// + /// + /// The condition. + /// The text --explain prints against the stage when is false. + [] + member inline _.when'([] build: BuildStage, value: bool, skipReason: string) = + StageContext.buildStageIsActiveBecause (ValueSome skipReason) build (fun _ -> value) + /// Runs a stage as a condition and uses its success as the activation answer. /// /// @@ -439,6 +453,13 @@ type StageBuilder with (spec: InputSpec, value: bool): InputSpec = InputSpec.map (fun (build: BuildStage) -> this.when'(build, value)) spec + /// The InputSpec mirror of the operation of the same name. + /// + [] member inline this. + when' + (spec: InputSpec, value: bool, skipReason: string): InputSpec + = InputSpec.map (fun (build: BuildStage) -> this.when'(build, value, skipReason)) spec + /// The InputSpec mirror of the operation of the same name. /// [] member inline this. diff --git a/src/Partas.Build/Builders/StageSettings.fs b/src/Partas.Build/Builders/StageSettings.fs index dbfc8cf..3198641 100644 --- a/src/Partas.Build/Builders/StageSettings.fs +++ b/src/Partas.Build/Builders/StageSettings.fs @@ -359,6 +359,7 @@ type StageSettingsBuilder() = /// Adds a step that runs a command line derived from the stage context. /// The command line string is split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [ cmd $\"...\")` to run a prepared command, or `echo` to print a message.")>] [] member inline _.run(state: ^State, step: StageContext -> string, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -368,6 +369,7 @@ type StageSettingsBuilder() = /// Adds a step that runs a command line asynchronously derived from the stage context. /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [ cmd $\"...\")` to run a prepared command, or `echo` to print a message.")>] [] member inline _.run(state: ^State, step: StageContext -> Async, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -377,6 +379,7 @@ type StageSettingsBuilder() = /// Adds a step that runs a command line derived from the stage context by a task. /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [ cmd $\"...\")` to run a prepared command, or `echo` to print a message.")>] [] member inline _.run(state: ^State, step: StageContext -> Task, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -394,6 +397,7 @@ type StageSettingsBuilder() = /// Adds a step that runs a command line derived from the stage context, or no step at all. /// The command line string is split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [ cmd $\"...\")` to run a prepared command, or `echo` to print a message.")>] [] member inline _.run(state: ^State, step: StageContext -> string option, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -403,6 +407,7 @@ type StageSettingsBuilder() = /// Adds a step that runs a command line asynchronously derived from the stage context, or no step at all. /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [ cmd $\"...\")` to run a prepared command, or `echo` to print a message.")>] [] member inline _.run(state: ^State, step: StageContext -> Async, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -412,6 +417,7 @@ type StageSettingsBuilder() = /// Adds a step that runs a command line derived from the stage context by a task, or no step at all. /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [ cmd $\"...\")` to run a prepared command, or `echo` to print a message.")>] [] member inline _.run(state: ^State, step: StageContext -> Task, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -475,6 +481,63 @@ type StageSettingsBuilder() = let cancellationToken = defaultArg cancellationToken CancellationToken.None { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.stepResultOption (buildCmd >> Async.singleton) cancellationToken) ] }) state + // ================================================================= + // runLine: a command line derived from the stage context + // ================================================================= + + /// Adds a step that runs the command line derived from the stage context. + /// The command line string is split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [] + member inline _.runLine(state: ^State, step: StageContext -> string, ?cancellationToken: CancellationToken): ^State = + StageMap.mapStage (fun ctx -> + let cancellationToken = defaultArg cancellationToken CancellationToken.None + let buildCmd ctx = Cmd.ofString (step ctx) |> Async.singleton + { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.step buildCmd cancellationToken) ] }) state + + /// Adds a step that runs the command line asynchronously derived from the stage context. + /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [] + member inline _.runLine(state: ^State, step: StageContext -> Async, ?cancellationToken: CancellationToken): ^State = + StageMap.mapStage (fun ctx -> + let cancellationToken = defaultArg cancellationToken CancellationToken.None + let buildCmd ctx = step ctx |> Async.map Cmd.ofString + { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.step buildCmd cancellationToken) ] }) state + + /// Adds a step that runs the command line derived from the stage context by a task. + /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [] + member inline _.runLine(state: ^State, step: StageContext -> Task, ?cancellationToken: CancellationToken): ^State = + StageMap.mapStage (fun ctx -> + let cancellationToken = defaultArg cancellationToken CancellationToken.None + let buildCmd ctx = step ctx |> Task.map Cmd.ofString |> Async.AwaitTask + { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.step buildCmd cancellationToken) ] }) state + + /// Adds a step that runs the command line derived from the stage context, or no step at all. + /// The command line string is split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [] + member inline _.runLine(state: ^State, step: StageContext -> string option, ?cancellationToken: CancellationToken): ^State = + StageMap.mapStage (fun ctx -> + let cancellationToken = defaultArg cancellationToken CancellationToken.None + let buildCmd ctx = step ctx |> Option.map Cmd.ofString |> Async.singleton + { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.stepOption buildCmd cancellationToken) ] }) state + + /// Adds a step that runs the command line asynchronously derived from the stage context, or no step at all. + /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [] + member inline _.runLine(state: ^State, step: StageContext -> Async, ?cancellationToken: CancellationToken): ^State = + StageMap.mapStage (fun ctx -> + let cancellationToken = defaultArg cancellationToken CancellationToken.None + let buildCmd ctx = step ctx |> Async.map (Option.map Cmd.ofString) + { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.stepOption buildCmd cancellationToken) ] }) state + + /// Adds a step that runs the command line derived from the stage context by a task, or no step at all. + /// The command line string is computed asynchronously and split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + [] + member inline _.runLine(state: ^State, step: StageContext -> Task, ?cancellationToken: CancellationToken): ^State = + StageMap.mapStage (fun ctx -> + let cancellationToken = defaultArg cancellationToken CancellationToken.None + let buildCmd ctx = step ctx |> Task.map (Option.map Cmd.ofString) |> Async.AwaitTask + { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.stepOption buildCmd cancellationToken) ] }) state /// Adds a step with flexible signature support. /// [] diff --git a/src/Partas.Build/Explain.fs b/src/Partas.Build/Explain.fs index 5d6c72b..70e2eb7 100644 --- a/src/Partas.Build/Explain.fs +++ b/src/Partas.Build/Explain.fs @@ -437,7 +437,7 @@ module Explain = let private declare () = Input.option "--explain" - |> Input.desc "Print the resolved stage tree and exit, running nothing" + |> Input.description "Print the resolved stage tree and exit, running nothing" |> Input.def false /// The flag as registered on a command that runs pipelines, whose own action reads it. diff --git a/src/Partas.Build/System.CommandLine/Inputs.fs b/src/Partas.Build/System.CommandLine/Inputs.fs index 74ba4ff..ab2ae5e 100644 --- a/src/Partas.Build/System.CommandLine/Inputs.fs +++ b/src/Partas.Build/System.CommandLine/Inputs.fs @@ -211,8 +211,8 @@ module Input = |> editOption (fun o -> o.Description <- description) |> editArgument (fun a -> a.Description <- description) - /// An alias for `description` to set the description of the input. - let desc = description + [] + let desc (description': string) (input: ActionInput<'T>) = description description' input /// Sets the default value of an option or argument. let defaultValue (defaultValue: 'T) (input: ActionInput<'T>) = diff --git a/tests/Partas.Build.CompilerProbe/Probe.fs b/tests/Partas.Build.CompilerProbe/Probe.fs index 135ae09..a588d41 100644 --- a/tests/Partas.Build.CompilerProbe/Probe.fs +++ b/tests/Partas.Build.CompilerProbe/Probe.fs @@ -192,13 +192,13 @@ let private tests = testList "compiler probe" [ // No annotation on any binding: the functions below are what fixes the type. let plain = stage "plain" { run touch } - let derived = stage "derived" { run (fun (_: StageContext) -> "dotnet --version") } + let derived = stage "derived" { runLine (fun (_: StageContext) -> "dotnet --version") } let prepared = stage "prepared" { run (fun (_: StageContext) -> Cmd.create "dotnet" "--version") } let awaited = stage "awaited" { run (fun (_: StageContext) -> async { return Cmd.create "dotnet" "--version" }) } let reported = stage "reported" { run (fun (_: StageContext) -> Ok(Cmd.create "dotnet" "--version"): Result) } let indexed = stage "indexed" { run (fun (_: StageContext) (_: StageContext) (_: StepIndex) -> async { return Ok(): Result }) } let before = stage "before" { run touch; child "a" } - let after = stage "after" { child "b"; run (fun (_: StageContext) -> Some "dotnet --version") } + let after = stage "after" { child "b"; runLine (fun (_: StageContext) -> Some "dotnet --version") } let around = stage "around" { run touch; child "c"; run (fun (_: StageContext) -> async { return 0 }) } Expect.equal (requiresStage plain) "plain" "a flexible step leaves a stage a StageContext" diff --git a/tests/Partas.Build.Tests/CmdTests.fs b/tests/Partas.Build.Tests/CmdTests.fs index 4fa963a..508494f 100644 --- a/tests/Partas.Build.Tests/CmdTests.fs +++ b/tests/Partas.Build.Tests/CmdTests.fs @@ -3,6 +3,7 @@ module Partas.Build.Tests.CmdTests open System.Diagnostics open System.Runtime.InteropServices open System.Threading +open System.Threading.Tasks open Expecto open Partas.Build open Partas.Build.Internal @@ -151,8 +152,8 @@ let tests = stage "exeAndArgs" { run "dotnet" "--version" } stage "commandLine" { run succeeds } stage "prepared" { run (cmd $"dotnet --version") } - stage "fromContext" { run (fun (_: StageContext) -> succeeds) } - stage "fromContextAsync" { run (fun (_: StageContext) -> async { return succeeds }) } + stage "fromContext" { runLine (fun (_: StageContext) -> succeeds) } + stage "fromContextAsync" { runLine (fun (_: StageContext) -> async { return succeeds }) } stage "buildsACmd" { run (fun (_: StageContext) -> Cmd.ofString succeeds) } stage "sensitive" { runSensitive $"dotnet --version" } } @@ -160,6 +161,41 @@ let tests = Expect.isTrue (runs built) "each overload should run its command" } + test "every runLine overload reaches the process" { + let built = + pipeline "lines" { + stage "line" { runLine (fun _ -> succeeds) } + stage "lineAsync" { runLine (fun _ -> async { return succeeds }) } + stage "lineTask" { runLine (fun _ -> Task.FromResult succeeds) } + stage "lineOption" { runLine (fun _ -> Some succeeds) } + stage "lineAsyncOption" { runLine (fun _ -> async { return Some succeeds }) } + stage "lineTaskOption" { runLine (fun _ -> Task.FromResult(Some succeeds)) } + } + + Expect.isTrue (runs built) "each overload should run its command line" + } + + test "runLine fails the stage on a failing command line" { + Expect.isFalse (runs (pipeline "bad" { stage "bad" { runLine (fun _ -> fails) } })) "the line runs as a process" + } + + test "runLine adds no step when the derived line is None" { + let built = pipeline "none" { stage "none" { runLine (fun (_: StageContext) -> (None: string option)) } } + Expect.isTrue (runs built) "an absent line is not a failure" + } + +#nowarn "44" + test "the obsolete string-returning run overloads still run their command line" { + let built = + pipeline "obsolete" { + stage "fromContext" { run (fun (_: StageContext) -> succeeds) } + stage "fromContextOption" { run (fun (_: StageContext) -> Some succeeds) } + } + + Expect.isTrue (runs built) "the obsolete overloads keep working" + } +#warnon "44" + test "a stage timeout kills the process and everything it started" { let before = sleepsAlive () let watch = Stopwatch.StartNew() diff --git a/tests/Partas.Build.Tests/ConditionsTests.fs b/tests/Partas.Build.Tests/ConditionsTests.fs index b3bcb07..a63e72f 100644 --- a/tests/Partas.Build.Tests/ConditionsTests.fs +++ b/tests/Partas.Build.Tests/ConditionsTests.fs @@ -152,6 +152,15 @@ let tests = Expect.isFalse (isActive debug) "the stage should be inactive otherwise" } + test "a when' with a reason conjoins like a bare when'" { + let on = stage "on" { when' true "never printed"; run noop } + let off = stage "off" { when' true "first"; when' false "second"; run noop } + + Expect.isTrue (isActive on) "a true condition leaves the stage active" + Expect.isFalse (isActive off) "a false condition turns the stage off" + Expect.equal [ for c in off.Conditions -> c.Reason ] [ ValueSome "first"; ValueSome "second" ] "each reason is recorded" + } + test "the runner skips an inactive stage" { let ran = ResizeArray() diff --git a/tests/Partas.Build.Tests/ExplainTests.fs b/tests/Partas.Build.Tests/ExplainTests.fs index abb44da..2bf308c 100644 --- a/tests/Partas.Build.Tests/ExplainTests.fs +++ b/tests/Partas.Build.Tests/ExplainTests.fs @@ -111,6 +111,35 @@ let tests = Expect.isFalse (text.Contains "skipped:") "a bool argument leaves nothing to report" } + test "explain reports the reason a when' names" { + let built = pipeline "p" { stage "off" { when' false "the flag is off"; run "dotnet --version" } } + + let text = Explain.render [ built ] + + Expect.stringContains text "off (skipped: the flag is off)" "the reason is printed against the stage" + } + + test "explain prints the reason of a when' over a bound flag when the command is invoked" { + let quick = Input.option "--quick" + + let built = + command "build" { + pipeline "p" { + input { + let! quick = quick + return stage "restore" { when' (not quick) "--quick is set"; run "dotnet restore" } + } + } + } + + let code, printed = capturingOut (fun () -> built.Parse("--explain --quick").Invoke()) + let _, unset = capturingOut (fun () -> built.Parse("--explain").Invoke()) + + Expect.equal code 0 "explain exits zero" + Expect.stringContains printed "restore (skipped: --quick is set)" "the flag that skipped the stage is named" + Expect.isFalse (unset.Contains "skipped") "a true condition prints no reason" + } + test "a command that runs a pipeline registers --explain" { let built = command "build" { pipeline "p" { stage "s" { run (fun (_: StageContext) -> ()) } } } From 6c36beffd73de7cf0c19083b1ed09705542faec2 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 11:58:11 +0000 Subject: [PATCH 13/25] Reword when' skip-reason xmldoc as a contract Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- src/Partas.Build/Builders/Conditions.fs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Partas.Build/Builders/Conditions.fs b/src/Partas.Build/Builders/Conditions.fs index 69b7cd6..95b7b7b 100644 --- a/src/Partas.Build/Builders/Conditions.fs +++ b/src/Partas.Build/Builders/Conditions.fs @@ -313,8 +313,8 @@ type StageBuilder with [] member inline _.when'([] build: BuildStage, value: bool) = StageContext.buildStageIsActive build (fun _ -> value) - /// Sets whether the stage is active using a literal boolean condition, and names the reason - /// --explain prints when the condition is false. + /// Sets whether the stage is active from a literal boolean condition; is + /// reported by --explain against an inactive stage. /// /// /// when' (not quick) "--quick is set" renders a skipped stage as (skipped: --quick is set). @@ -322,7 +322,7 @@ type StageBuilder with /// /// /// The condition. - /// The text --explain prints against the stage when is false. + /// The reason reported by --explain when is false. [] member inline _.when'([] build: BuildStage, value: bool, skipReason: string) = StageContext.buildStageIsActiveBecause (ValueSome skipReason) build (fun _ -> value) From 0334f13d539cd9973f6b8d8ee1799931727ed4d6 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 11:28:59 +0000 Subject: [PATCH 14/25] =?UTF-8?q?Add=20Baked=20prefab=20stages=20and=20reb?= =?UTF-8?q?uild=20Build/Program.fs=20on=20them=20(PLAN-Integration=20?= =?UTF-8?q?=C2=A73.1)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Partas.Build.Baked gains Common.quick/skipTests/watch, Dotnet.configOrRelease, and Stages: restore, clean, build, pack, expecto, nugetPush, fantomas and npmInstall, each a function answering InputSpec with a ...With counterpart taking its options as InputSpecs (PLAN §8 Q3: functions). Skips carry an --explain reason. clean is a System.IO glob clean (Clean.fs), so Build/Program.fs and Build.fsproj no longer need Fake. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- Build.fsproj | 6 - Build/Program.fs | 155 +++---------- CLAUDE.md | 16 +- notes/PLAN-Integration.md | 26 +++ src/Partas.Build.Baked/Clean.fs | 109 ++++++++++ src/Partas.Build.Baked/Common.fs | 16 ++ src/Partas.Build.Baked/Dotnet.fs | 5 + .../Partas.Build.Baked.fsproj | 2 + src/Partas.Build.Baked/Stages.fs | 197 +++++++++++++++++ tests/Partas.Build.Tests/BakedTests.fs | 204 ++++++++++++++++++ 10 files changed, 599 insertions(+), 137 deletions(-) create mode 100644 src/Partas.Build.Baked/Clean.fs create mode 100644 src/Partas.Build.Baked/Stages.fs diff --git a/Build.fsproj b/Build.fsproj index 583cbcd..6da58bc 100644 --- a/Build.fsproj +++ b/Build.fsproj @@ -26,13 +26,7 @@ `Update` modifies the existing implicit reference instead of adding a duplicate (which would trigger NU1504). --> - - - - - - diff --git a/Build/Program.fs b/Build/Program.fs index aa32778..1b27dfe 100644 --- a/Build/Program.fs +++ b/Build/Program.fs @@ -11,15 +11,9 @@ module Build open System open System.IO -open Fake.Core.Context -open Fake.IO -open Fake.IO.Globbing.Operators open Partas.Build open Partas.TypeProvider.BuildHelper -let execContext = FakeExecutionContext.Create false "build.fsx" [] -setExecutionContext (RuntimeContext.Fake execContext) - [] let __REPOSITORY_DIRECTORY__ = __SOURCE_DIRECTORY__ @@ -35,25 +29,10 @@ type Repo = let private root = Repo.FileSystem.``.``.ToString() module Options = - let quick = - Input.option "--quick" - |> Input.alias "-q" - |> Input.description "Skips restores, installations, formatting etc" - let skipTests = - Input.option "--skip-tests" - |> Input.description "Skips running tests" let nugetSource = Input.option "--nuget-source" |> Input.def "https://api.nuget.org/v3/index.json" |> Input.description "NuGet feed URL for authenticated publishing" - let watch = - Input.option "--watch" - |> Input.description "Runs the operation in watch mode." - - let config = - Baked.Dotnet.config.option - |> InputSpec.ofInput - |> InputSpec.map (Option.defaultValue "Release") module Project = let projects = Repo.Project.AllProjects() @@ -91,123 +70,49 @@ module Project = /// Stages every command opens with. All are skipped by --quick. module Prelude = - let restore = input { - let! quick = Options.quick - return stage "restore" { - when' (not quick) "--quick is set" - run "dotnet tool restore --verbosity q" - run (cmd $"dotnet restore {Repo.Project.SolutionFile}") - } - } - let clean = input { - let! quick = Options.quick - - return stage "clean" { - when' (not quick) "--quick is set" - - run (fun (_: StageContext) -> - Repo.VirtualFileSystem.bin.``.``.EnumerateFiles("*.nupkg", SearchOption.AllDirectories) - |> Seq.iter (_.ToString() >> Shell.rm) - !! "**/**/bin" - ++ Repo.VirtualFileSystem.tmp.ToString() - -- Repo.VirtualFileSystem.bin.ToString() - |> Shell.cleanDirs - ) - } - } + let restore = Baked.Stages.restore Repo.Project.SolutionFile + /// Empties every bin directory except the root's, and deletes the packages in the root's. + let clean = Baked.Stages.clean [ "**/bin"; "!bin"; "tmp" ] [ "bin/**/*.nupkg" ] module ProjectManagement = - let build (project: InputSpec) = input { - let! config = Options.config - and! project = project - return stage $"build {project}" { - run (cmd $"dotnet build {project} -c {config}") - } - } - let buildAll = stage "build" { - parallel' - for _, project in Project.allProjects do - build (InputSpec.ret project) - } + let private packages = Repo.VirtualFileSystem.bin.ToString() - let pack (project: InputSpec) = input { - let! project = project - return stage $"pack {project}" { - run (cmd $"dotnet pack {project} --no-restore -o {Repo.VirtualFileSystem.bin.ToString()}") - } - } - let packAll = stage "pack" { - parallel' - for _, project in Project.allProjects do - InputSpec.ret project - |> pack - } - let publish (project: InputSpec) = input { - let! key = Baked.NuGet.apiKey.option - and! source = Options.nugetSource - and! project = project - return stage $"publish {project}" { - stage "local publish" { - when' key.IsNone "a NuGet API key is set" - echo "Publishing to local feed" - run $"dotnet nuget push {project} --source local --skip-duplicate" - } - whenSome key (fun key -> - stage "nuget publish" { - echo $"Publishing to {source}" - runSensitive - $"dotnet nuget push {project} --source {source} --api-key {key} --skip-duplicate" - }) - } - } - let publishAll = stage "publish" { - Path.Combine(Repo.VirtualFileSystem.bin.ToString(), "*.nupkg") - |> InputSpec.ret - |> publish - } + let buildAll = Baked.Stages.build (Project.allProjects |> List.map snd) + let packAll = Baked.Stages.pack packages (Project.allProjects |> List.map snd) + let publishAll = Baked.Stages.nugetPushWith Baked.NuGet.apiKey (InputSpec.ofInput Options.nugetSource) (Path.Combine(packages, "*.nupkg")) let bumpArgument = Baked.SemVer.Stages.bumpArgument (InputSpec.ofInput Project.target) module Tests = - let buildAll = input { - let! skipTests = Options.skipTests - and! projects = - Project.testProjects - |> List.map (_.Path >> InputSpec.ret >> ProjectManagement.build) - |> InputSpec.sequence - return stage "build tests" { - when' (not skipTests) "--skip-tests is set" - projects - } - } + /// Builds the test projects one at a time; skipped by --skip-tests. + let buildAll = + Baked.Stages.buildWith Baked.Dotnet.configOrRelease (Project.testProjects |> List.map _.Path) + |> InputSpec.map (fun build -> { StageContext.toggleParallel false build with Name = "build tests" }) + |> InputSpec.map2 (fun skipTests -> StageContext.addPredicateBecause (ValueSome "--skip-tests is set") (fun _ -> not skipTests)) + (InputSpec.ofInput Baked.Common.skipTests) - /// The arguments every Expecto suite takes after --; --summary only under --ci. - let private expectoArgs (ci: bool) (command: Cmd) = - command - |> Cmd.argIf ci [ "--summary" ] - |> Cmd.args [ "--colours"; "256"; "--sequenced" ] + let private expectoArguments = [ "--colours"; "256"; "--sequenced" ] let execute = input { - let! skipTests = Options.skipTests - and! config = Options.config + let! skipTests = Baked.Common.skipTests and! ci = Baked.Common.isCI + and! suites = + [ Repo.Project.``Partas.Build.Cmd.NetStandard.Tests``.Path + Repo.Project.``Partas.Build.ExternalAnnotations.Tests``.Path + Repo.Project.``Partas.Build.Tests``.Path + Repo.Project.``Partas.ExternalAnnotations.Tests``.Path ] + |> InputSpec.traverse (fun project -> Baked.Stages.expecto project expectoArguments) return stage "test" { when' (not skipTests) "--skip-tests is set" - // Expecto reports assertions on stdout; keep them visible in CI and uploaded logs. - outputTo StageOutput.Console - // Commands exercised by tests must not append fixture reports to the real job summary. envVars [ "GITHUB_STEP_SUMMARY", "" ] - for project in [ - Repo.Project.``Partas.Build.Cmd.NetStandard.Tests``.Path - Repo.Project.``Partas.Build.ExternalAnnotations.Tests``.Path - Repo.Project.``Partas.Build.Tests``.Path - Repo.Project.``Partas.ExternalAnnotations.Tests``.Path - ] do stage $"test {project}" { - run (cmd $"dotnet run --project {project} --no-build -c {config} --" |> expectoArgs ci) - } - // Runs in both configurations regardless of `--configuration`: Release is what catches FS1118. + suites |> InputSpec.map (List.map (fun suite -> { suite with Output = ValueSome StageOutput.Console })) + // Built by the run, in both configurations regardless of `--configuration`: Release is what catches FS1118. for probeConfig in [ "Debug"; "Release" ] do stage $"compiler probe ({probeConfig})" { - run (cmd $"dotnet run --project {Repo.Project.``Partas.Build.CompilerProbe``.Path} -c {probeConfig} --" |> expectoArgs ci) + run ( + cmd $"dotnet run --project {Repo.Project.``Partas.Build.CompilerProbe``.Path} -c {probeConfig} --" + |> Cmd.argIf ci [ "--summary" ] + |> Cmd.args expectoArguments + ) } } } @@ -215,7 +120,7 @@ module Tests = module Documentation = /// Serves under --watch, builds otherwise. let generate = input { - let! watch = Options.watch + let! watch = Baked.Common.watch and! noHotReload = Input.option "--no-hot-reload" return stage "docs" { run ( @@ -233,7 +138,7 @@ module Documentation = /// Written for fsdocs, which generated both files at the site root as a link inventory under such a heading. /// let llms = input { - let! watch = Options.watch + let! watch = Baked.Common.watch return stage "llms" { when' (not watch) "--watch is set" run (fun ctx -> diff --git a/CLAUDE.md b/CLAUDE.md index 7a9ce8a..886ada8 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -203,9 +203,13 @@ touching anything; `PipelineContext.withRunState` gives a copy collections of it `src/Partas.Build.Cmd` (`Program.fs`, `Execution.fs`) is the process layer, defining `Cmd` and compiling before `Partas.Build`. `src/Partas.Build.Baked` is the batteries-included layer over the library: ready-made `Input.*`/`Argument.*` definitions -for the options every build CLI ends up wanting (`--configuration`, `--nuget-key`, `--project`, `--ci`, a version -bump), the semver arithmetic in `Version`, and `IO.writeVersion`/`IO.bumpVersion` for editing a project file's -``. It is the only place in the library that writes to disk, apart from the result file `--report` names. +for the options every build CLI ends up wanting (`--configuration` and `Dotnet.configOrRelease`, `--nuget-key`, +`--project`, `--ci`, `--quick`, `--skip-tests`, `--watch`, a version bump), the semver arithmetic in `Version`, and +`IO.writeVersion`/`IO.bumpVersion` for editing a project file's ``. It is the only place in the library that +writes to disk. `Stages.fs` holds the prefab stages (`restore`, `clean`, `build`, `pack`, `expecto`, `nugetPush`, +`fantomas`, `npmInstall`): functions answering `InputSpec` that read Baked's own options, each with a +`…With` counterpart taking those options as `InputSpec`s. A skip carries a reason for `--explain`. `Clean.fs` is the +glob matcher behind `clean`, on `System.IO` alone. The core model, once a single `Types.fs`, is split by responsibility and compiles in this order: 1. `Exceptions.fs` (`Partas.Build.ErrorHandling`) — pipeline exceptions, `FailureCause`, `StepOutcome`. @@ -250,11 +254,11 @@ Overload resolution in these builders fails in ways that are invisible by inspec `Build/Program.fs` is the whole CLI — repository paths, options, stages and commands in one file. Repository paths come from `Partas.TypeProvider.BuildHelper` (`type Repo = BuildHelperProvider<...>`, with `Repo.FileSystem` and `Repo.VirtualFileSystem` for the real and virtual file systems), so a renamed project breaks compilation instead of failing mid-release. A new packable project goes in `Project.allProjects`, which is both what `bump` can version and what `pack` packs; `Repo.Project..Path` is a compile-time constant, while `PackageId`/`AssemblyName`/`Version` are MSBuild evaluations that shell out to `dotnet msbuild -getProperty`, so keep those off any path that runs before parsing. -Since Phase 7 the CLI is written against Partas.Build (`Build.fsproj` has a project reference to `src/Partas.Build`), so it doubles as the design's acceptance test. A step is a stage; a stage that needs a flag binds it in `input { let! quick = Options.quick ... return stage "..." { when' (not quick) "--quick is set"; run (cmd $"dotnet ...") } }`, and the command registers it by running the pipeline that contains it. The CLI has no per-command option lists and no process wrappers. Custom operations cannot sit under an `if`/`match`, so a stage that branches builds a `Cmd` first and runs it unconditionally, and a stage that exists only when an option was supplied is yielded through `whenSome` — `ProjectManagement.publish` yields its `nuget publish` stage that way, so the stage closes over the key rather than reaching for `key.Value` under a `when'`. +Since Phase 7 the CLI is written against Partas.Build (`Build.fsproj` has a project reference to `src/Partas.Build`), so it doubles as the design's acceptance test. A step is a stage; a stage that needs a flag binds it in `inputs { let! quick = Baked.Common.quick ... return stage "..." { when' (not quick); run (cmd $"dotnet ...") } }`, and the command registers it by running the pipeline that contains it. The CLI has no per-command option lists and no process wrappers. Custom operations cannot sit under an `if`/`match`, so a stage that branches builds a `Cmd` first and runs it unconditionally, and a stage that exists only when an option was supplied is yielded through `whenSome` — `Baked.Stages.nugetPush`, which `ProjectManagement.publishAll` uses, matches on the key the same way, so the stage closes over the key rather than reaching for `key.Value` under a `when'`. Restore, clean, build, pack, the Expecto suites and the push are Baked prefabs (`notes/PLAN-Integration.md` §3.1); the CLI keeps only what is its own — the compiler probe, the docs stages, `bump`'s project list. -The four Expecto suites run `--sequenced`. Each drives real pipelines, and a pipeline writes to one process-wide console and holds a thread in `Async.RunSynchronously` for the length of every stage — run in parallel on a two-core runner, that yields a log whose lines belong to no test in particular, with enough blocked workers that the thread pool grows one thread at a time. `Tests.execute` captures the suites' output when `--ci` is set, so a green CI run says nothing and a red one lifts the whole failure into the annotation; locally it stays live. `Tests.execute` also runs `tests/Partas.Build.CompilerProbe` twice, once per configuration, regardless of `--configuration`. Release catches an `inline` member that applies a `Build*` alias (`FS1118`), which a Debug build compiles clean. +The four Expecto suites run `--sequenced`. Each drives real pipelines, and a pipeline writes to one process-wide console and holds a thread in `Async.RunSynchronously` for the length of every stage — run in parallel on a two-core runner, that yields a log whose lines belong to no test in particular, with enough blocked workers that the thread pool grows one thread at a time. `Baked.Stages.expecto` captures each suite's output when `--ci` is set, so a green CI run says nothing and a red one lifts the whole failure into the annotation; locally it stays live. `Tests.execute` also runs `tests/Partas.Build.CompilerProbe` twice, once per configuration, regardless of `--configuration`. Release catches an `inline` member that applies a `Build*` alias (`FS1118`), which a Debug build compiles clean. -Fake survives only where it is better than a process call: `!!` and `Shell.cleanDirs` for the clean. Everything else is a `run` step. +There is no Fake dependency: the clean is `Baked.Stages.clean`, over `System.IO`. Everything else is a `run` step. ### Versioning diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 0f354cb..8666500 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -89,6 +89,32 @@ Open question: whether prefabs are functions returning `InputSpec` fields (W12 in `FEEDBACK-Xantham.md`, deferred). Functions first; records only if a consumer needs to patch one prefab field. +**Status: implemented on `claude/partas-build-patterns-jgrwr0-baked-stages`.** `src/Partas.Build.Baked/Stages.fs` +(`module Partas.Build.Baked.Stages`) and `Clean.fs`; `Common.quick`/`skipTests`/`watch` and `Dotnet.configOrRelease`. +Tests in `tests/Partas.Build.Tests/BakedTests.fs` resolve each prefab against parsed options and walk the +`StageContext` (names, step labels with the key masked, skip reasons, parallelism); only `clean` runs, on a temp +tree. `Build/Program.fs` now takes restore, clean, build, pack, the four Expecto suites and the push from Baked, +and has no Fake dependency (the `Fake.*` package references are gone from `Build.fsproj`). Q3 (§8) is decided: +**functions**. Each prefab reads Baked's own options, and a `…With` counterpart takes each of those options as an +`InputSpec`, so a consumer with its own `--fast` or configuration option composes without a record. The result is +an ordinary `StageContext`, so renaming it, toggling its parallelism or adding a condition is an `InputSpec.map` +(`Program.fs`'s `Tests.buildAll` does all three). Deviations from the table: + +- `clean (directories, files)` takes glob patterns relative to the stage's working directory, `!` excluding + (`[ "**/bin"; "!bin"; "tmp" ]`). A wildcard-free directory is created if missing, as Fake's `cleanDirs` did. The + walk skips `.git` and `node_modules` (Fake's `**/bin` also emptied `node_modules//bin`). +- `pack` runs `dotnet pack -c --no-build --no-restore`, where `Program.fs` rebuilt each project in the + default configuration, in parallel over shared references. +- `expecto (project, arguments)` takes the suite's arguments instead of a filter, and is skipped by `--skip-tests`. +- `nugetPush` matches on the key rather than going through `whenSome`, since the keyless case yields the + local-feed push instead of nothing. The key is bound by the pattern and added through `Cmd.secretOption`. +- `npmInstall` runs `npm ci` under `--ci` and `npm install` otherwise, with `--prefix ` so a relative + directory resolves against the pipeline's working directory. +- Skips carry an `--explain` reason (`--quick is set`) through `StageContext.addPredicateBecause`, pending §3.2's + `when'` with a reason. +- Left hand-rolled in `Program.fs`: the compiler probe (it must build, in both configurations, so a `--no-build` + suite does not fit), the docs stages, and the outer `test` stage's own `--skip-tests` guard over the probe. + ### 3.2 API traps - **`run (fun ctx -> "…")` executes the returned string as a command line** (`StageSettings.fs:363`). A lambda diff --git a/src/Partas.Build.Baked/Clean.fs b/src/Partas.Build.Baked/Clean.fs new file mode 100644 index 0000000..96363c7 --- /dev/null +++ b/src/Partas.Build.Baked/Clean.fs @@ -0,0 +1,109 @@ +/// Emptying directories and deleting files by glob, relative to a root directory. +/// +/// A pattern is a /-separated path relative to the root. ** matches any number of directories, +/// * any run of characters within one segment, ? one character. A pattern starting with ! +/// excludes what it matches. Matching is case-insensitive on Windows and case-sensitive elsewhere. +/// The walk skips .git and node_modules. +/// +module Partas.Build.Baked.Clean + +open System +open System.IO +open System.Runtime.InteropServices +open System.Text.RegularExpressions + +let private ignoreCase = RuntimeInformation.IsOSPlatform OSPlatform.Windows + +let private pruned = set [ ".git"; "node_modules" ] + +let private segments (path: string) = + path.Replace('\\', '/').Split([| '/' |], StringSplitOptions.RemoveEmptyEntries) + |> Array.filter ((<>) ".") + |> List.ofArray + +let private isWildcard (pattern: string) = pattern.IndexOfAny [| '*'; '?' |] >= 0 + +let private segmentMatcher (segment: string) = + let options = if ignoreCase then RegexOptions.IgnoreCase else RegexOptions.None + let regex = Regex("^" + Regex.Escape(segment).Replace(@"\*", ".*").Replace(@"\?", ".") + "$", options) + fun (segment: string) -> regex.IsMatch segment + +/// Whether , relative to the root, is matched by . +let isMatch (pattern: string) (path: string) = + let rec go (pattern: string list) (path: string list) = + match pattern, path with + | [], [] -> true + | [ "**" ], _ -> true + | "**" :: rest, _ -> go rest path || (match path with [] -> false | _ :: tail -> go pattern tail) + | segment :: rest, head :: tail -> segmentMatcher segment head && go rest tail + | _ -> false + go (segments pattern) (segments path) + +type private Patterns = { Include: string list; Exclude: string list } + +let private partition (patterns: string list) = + let exclude, include' = patterns |> List.partition _.StartsWith("!") + { Include = include'; Exclude = exclude |> List.map _.Substring(1) } + +let private matchesAny patterns path = patterns |> List.exists (fun pattern -> isMatch pattern path) + +/// Every directory below root, relative to it, depth first. `descend` decides whether the walk enters one. +let rec private walkDirectories (root: string) (relative: string) (descend: string -> bool) = seq { + for directory in Directory.EnumerateDirectories(Path.Combine(root, relative)) do + let name = Path.GetFileName directory + if not (pruned.Contains name) then + let path = if relative = "" then name else relative + "/" + name + yield path + if descend path then yield! walkDirectories root path descend +} + +let private empty (directory: string) = + for file in Directory.EnumerateFiles(directory, "*", SearchOption.AllDirectories) do + File.SetAttributes(file, FileAttributes.Normal) + for file in Directory.GetFiles directory do + File.Delete file + for child in Directory.GetDirectories directory do + Directory.Delete(child, true) + +/// The directories below that select, relative to it. +/// The result holds no directory nested inside another selected directory. +let directories (root: string) (patterns: string list) = + let patterns = partition patterns + let selected path = matchesAny patterns.Include path && not (matchesAny patterns.Exclude path) + let literals = patterns.Include |> List.filter (isWildcard >> not) |> List.map (segments >> String.concat "/") + let found = + if patterns.Include |> List.exists isWildcard && Directory.Exists root then + walkDirectories root "" (fun path -> not (matchesAny patterns.Include path)) + |> Seq.filter selected + |> List.ofSeq + else [] + (literals |> List.filter (matchesAny patterns.Exclude >> not)) @ found |> List.distinct + +/// The files below that select, relative to it. +let files (root: string) (patterns: string list) = + let patterns = partition patterns + if patterns.Include.IsEmpty || not (Directory.Exists root) then [] else + let inDirectory (relative: string) = + Directory.EnumerateFiles(Path.Combine(root, relative)) + |> Seq.map (fun file -> if relative = "" then Path.GetFileName file else relative + "/" + Path.GetFileName file) + Seq.append (inDirectory "") (walkDirectories root "" (fun _ -> true) |> Seq.collect inDirectory) + |> Seq.filter (fun path -> matchesAny patterns.Include path && not (matchesAny patterns.Exclude path)) + |> List.ofSeq + +/// Empties the directories select and deletes the files +/// select, and answers the relative paths of both. +/// +/// A directory pattern without wildcards names a directory to create if it is missing, and to empty otherwise. +/// A directory is emptied rather than deleted. +/// +let run (root: string) (directoryPatterns: string list) (filePatterns: string list) = + let deleted = files root filePatterns + for file in deleted do + let path = Path.Combine(root, file) + File.SetAttributes(path, FileAttributes.Normal) + File.Delete path + let emptied = directories root directoryPatterns + for directory in emptied do + let path = Path.Combine(root, directory) + if Directory.Exists path then empty path else Directory.CreateDirectory path |> ignore + emptied, deleted diff --git a/src/Partas.Build.Baked/Common.fs b/src/Partas.Build.Baked/Common.fs index 2dc91aa..33c2fae 100644 --- a/src/Partas.Build.Baked/Common.fs +++ b/src/Partas.Build.Baked/Common.fs @@ -15,3 +15,19 @@ let isCI = || vars.Contains "GITLAB_CI" || vars.Contains "GITHUB_ACTIONS" ) + +/// `--quick`/`-q`: skips restores, installations, cleaning and formatting. +let quick = + Input.option "--quick" + |> Input.alias "-q" + |> Input.desc "Skips restores, installations, cleaning and formatting" + +/// `--skip-tests`: skips building and running the test suites. +let skipTests = + Input.option "--skip-tests" + |> Input.desc "Skips building and running the test suites" + +/// `--watch`: runs the operation in watch mode. +let watch = + Input.option "--watch" + |> Input.desc "Runs the operation in watch mode" diff --git a/src/Partas.Build.Baked/Dotnet.fs b/src/Partas.Build.Baked/Dotnet.fs index 0733fb7..99fa3d6 100644 --- a/src/Partas.Build.Baked/Dotnet.fs +++ b/src/Partas.Build.Baked/Dotnet.fs @@ -14,3 +14,8 @@ let config = "debug", Some "Debug" "d", Some "Debug" ]) + +/// The `--configuration` option's value, `Release` when it is omitted. +let configOrRelease: InputSpec = + InputSpec.ofInput config.option + |> InputSpec.map (Option.defaultValue "Release") diff --git a/src/Partas.Build.Baked/Partas.Build.Baked.fsproj b/src/Partas.Build.Baked/Partas.Build.Baked.fsproj index a03e14d..23f576f 100644 --- a/src/Partas.Build.Baked/Partas.Build.Baked.fsproj +++ b/src/Partas.Build.Baked/Partas.Build.Baked.fsproj @@ -17,6 +17,8 @@ + + diff --git a/src/Partas.Build.Baked/Stages.fs b/src/Partas.Build.Baked/Stages.fs new file mode 100644 index 0000000..8a4f50a --- /dev/null +++ b/src/Partas.Build.Baked/Stages.fs @@ -0,0 +1,197 @@ +/// Ready-made stages for the steps every .NET build CLI repeats. +/// +/// Each prefab is a function answering an InputSpec<StageContext>, which a pipeline, a +/// command or an enclosing stage yields directly and whose options reach the command's +/// --help. A prefab reads Baked's own options (, +/// , , +/// , ); +/// its …With counterpart takes each of those as an InputSpec instead, for a consumer with options +/// of its own. A skip condition carries a reason for --explain, naming the option when the spec reads +/// exactly one. +/// +/// A prefab's stage is an ordinary StageContext: InputSpec.map over it to rename it +/// ({ s with Name = … }), to toggle its parallelism (StageContext.toggleParallel) or to add a +/// condition (StageContext.addPredicateBecause). +/// +/// +module Partas.Build.Baked.Stages + +open System.IO +open Partas.Build + +/// The text --explain shows for a stage skipped because read true. +let private skipReason (skip: InputSpec) = + match skip.Inputs |> List.map _.Source with + | [ ParsedOption option ] -> $"%s{option.Name} is set" + | _ -> "its skip condition holds" + +/// Binds and skips the stage answers when it reads true. +let private skippedBy (skip: InputSpec) (spec: InputSpec) : InputSpec = + let reason = ValueSome (skipReason skip) + InputSpec.map2 (fun skipped stage -> StageContext.addPredicateBecause reason (fun _ -> not skipped) stage) skip spec + +let private quick = InputSpec.ofInput Common.quick +let private skipTests = InputSpec.ofInput Common.skipTests +let private ci = InputSpec.ofInput Common.isCI + +/// A stage's name for a project: the file name without its extension. +let private projectName (project: string) = Path.GetFileNameWithoutExtension project + +/// restore: dotnet tool restore, then dotnet restore of +/// ; skipped when reads true. +let restoreWith (skip: InputSpec) (solution: string) = + stage "restore" { + run (cmd $"dotnet tool restore --verbosity q") + run (cmd $"dotnet restore {solution}") + } + |> InputSpec.ret + |> skippedBy skip + +/// , skipped by --quick. +let restore (solution: string) = restoreWith quick solution + +/// clean: empties the directories select and deletes the files +/// select, both relative to the stage's working directory; skipped when +/// reads true. +/// +/// Patterns follow : [ "**/bin"; "!bin"; "tmp" ] empties every +/// bin directory except the root's, and creates or empties tmp. The step's label, shown by +/// --explain, lists the patterns. +/// +let cleanWith (skip: InputSpec) (directories: string list) (files: string list) = + let label = + [ if not directories.IsEmpty then "empty " + String.concat " " directories + if not files.IsEmpty then "delete " + String.concat " " files ] + |> String.concat "; " + let step (ctx: StageContext) (_: StepIndex) = async { + let root = StageContext.getWorkingDir ctx |> ValueOption.defaultWith Directory.GetCurrentDirectory + let emptied, deleted = Clean.run root directories files + StageContext.writeLine ctx StdStream.Out $"emptied %d{emptied.Length} directories, deleted %d{deleted.Length} files under %s{root}" + return Ok () + } + stage "clean" { () } + |> StageContext.addLabelledStepFn label step + |> InputSpec.ret + |> skippedBy skip + +/// , skipped by --quick. +let clean (directories: string list) (files: string list) = cleanWith quick directories files + +/// build: one dotnet build <project> -c <configuration> sub-stage per +/// project, run under parallel'. +let buildWith (configuration: InputSpec) (projects: string list) = input { + let! configuration = configuration + return stage "build" { + parallel' + for project in projects do + stage $"build %s{projectName project}" { run (cmd $"dotnet build {project} -c {configuration}") } + } +} + +/// in the --configuration, Release +/// by default. +let build (projects: string list) = buildWith Dotnet.configOrRelease projects + +/// pack: one dotnet pack --no-build --no-restore sub-stage per project, writing to +/// , run under parallel'. +/// Packs what a build in the same configuration left behind. +let packWith (configuration: InputSpec) (outDir: string) (projects: string list) = input { + let! configuration = configuration + return stage "pack" { + parallel' + for project in projects do + stage $"pack %s{projectName project}" { + run (cmd $"dotnet pack {project} -c {configuration} --no-build --no-restore -o {outDir}") + } + } +} + +/// in the --configuration, Release +/// by default. +let pack (outDir: string) (projects: string list) = packWith Dotnet.configOrRelease outDir projects + +/// test <project>: runs an already built Expecto suite through +/// dotnet run --no-build, passing after --; skipped when +/// reads true. +/// +/// MSBuild resolves the test assembly, so a change of target framework or output path needs no change here. +/// When reads true, the suite also takes --summary and its output is +/// captured: a passing run prints nothing, and a failing one carries the whole output in its error. +/// +let expectoWith (skip: InputSpec) (configuration: InputSpec) (isCI: InputSpec) (project: string) (arguments: string list) = + input { + let! configuration = configuration + and! isCI = isCI + return + stage $"test %s{projectName project}" { + run ( + cmd $"dotnet run --project {project} --no-build -c {configuration} --" + |> Cmd.argIf isCI [ "--summary" ] + |> Cmd.args arguments + ) + } + |> StageContext.setOutput (if isCI then ValueSome (StageOutput.Captured (OutputCapture.create ())) else ValueNone) + } + |> skippedBy skip + +/// in the --configuration, skipped by +/// --skip-tests, summarised and captured under --ci. +let expecto (project: string) (arguments: string list) = expectoWith skipTests Dotnet.configOrRelease ci project arguments + +/// push: dotnet nuget push <packages> --skip-duplicate, to +/// with the key when reads one, and to +/// otherwise. +/// +/// The key is a secret argument of the command: every printed form of the step, --explain included, +/// shows it as ***. is passed through for dotnet nuget push to expand, +/// so bin/*.nupkg pushes every package there. +/// +let nugetPushWith (apiKey: InputSpec) (localSource: string) (source: string) (packages: string) = input { + let! apiKey = apiKey + return stage "push" { + match apiKey with + | Some key -> + stage "push to source" { + run ( + cmd $"dotnet nuget push {packages} --source {source}" + |> Cmd.secretOption "--api-key" key + |> Cmd.arg "--skip-duplicate" + ) + } + | None -> stage "push to local feed" { run (cmd $"dotnet nuget push {packages} --source {localSource} --skip-duplicate") } + } +} + +/// with the --nuget-key option +/// (NUGET_API_KEY by default), pushing to nuget.org, or to the NuGet source named local without a +/// key. +let nugetPush (packages: string) = + nugetPushWith (InputSpec.ofInput NuGet.apiKey.option) "local" "https://api.nuget.org/v3/index.json" packages + +/// format: dotnet fantomas over , only checking them when +/// is set; skipped when reads true. +/// Fantomas is expected as a local tool, restored by restore. +let fantomasWith (skip: InputSpec) (check: bool) (paths: string list) = + stage "format" { + run (cmd $"dotnet fantomas" |> Cmd.argIf check [ "--check" ] |> Cmd.args paths) + } + |> InputSpec.ret + |> skippedBy skip + +/// , rewriting the files, skipped by +/// --quick. +let fantomas (paths: string list) = fantomasWith quick false paths + +/// npm install: installs the packages of through +/// npm ci when reads true and npm install otherwise; skipped when +/// reads true. +let npmInstallWith (skip: InputSpec) (isCI: InputSpec) (directory: string) = + input { + let! isCI = isCI + return stage "npm install" { run (cmd $"""npm {if isCI then "ci" else "install"} --prefix {directory}""") } + } + |> skippedBy skip + +/// , npm ci under --ci, skipped by +/// --quick. +let npmInstall (directory: string) = npmInstallWith quick ci directory diff --git a/tests/Partas.Build.Tests/BakedTests.fs b/tests/Partas.Build.Tests/BakedTests.fs index 135b0ba..d7b902c 100644 --- a/tests/Partas.Build.Tests/BakedTests.fs +++ b/tests/Partas.Build.Tests/BakedTests.fs @@ -4,6 +4,38 @@ module Partas.Build.Tests.BakedTests open System.IO open Expecto open Partas.Build +open Partas.Build.Internal +open Partas.Build.Tests.Helpers + +/// The stage a prefab answers for , parsed against the options the prefab declares. +let private resolve (commandLine: string) (spec: InputSpec) = spec.Read (parse spec.Inputs commandLine) + +let private subStages (stage: StageContext) = [ + for step in stage.Steps do + match step with + | Step.StepOfStage child -> child + | _ -> () +] + +let private labels (stage: StageContext) = [ + for step in stage.Steps do + match step with + | Step.StepFn(ValueSome label, _) + | Step.Operation(ValueSome label, _) -> label + | _ -> () +] + +let private reasons (stage: StageContext) = stage.Conditions |> List.choose (_.Reason >> ValueOption.toOption) + +let private isActive (stage: StageContext) = stage.IsActive stage + +let private tempTree (files: string list) = + let directory = Directory.CreateTempSubdirectory "partas-build-clean" + for file in files do + let path = Path.Combine(directory.FullName, file) + Directory.CreateDirectory(Path.GetDirectoryName path) |> ignore + File.WriteAllText(path, "") + directory [] let tests = @@ -33,4 +65,176 @@ let tests = finally directory.Delete true } + + test "prefabs compose inside a command, which registers their options" { + let built = + command "ci" { + pipeline "ci" { + quiet + Baked.Stages.restore "Repo.slnx" + Baked.Stages.clean [ "tmp-never-created" ] [] + Baked.Stages.expecto "tests/T/T.fsproj" [] + } + } + let exitCode = quietly (fun () -> built.Parse("--quick true --skip-tests true --ci false").Invoke()) + Expect.equal exitCode 0 "every prefab is skipped, and the options parse" + } + + testList "options" [ + test "quick, skipTests and watch declare their options" { + Expect.sequenceEqual + (inputNames [ Baked.Common.quick; Baked.Common.skipTests; Baked.Common.watch ]) + [ "--quick"; "--skip-tests"; "--watch" ] + "each flag should declare its option" + } + test "the configuration defaults to Release" { + let spec = Baked.Dotnet.configOrRelease + Expect.equal (spec.Read (parse spec.Inputs "")) "Release" "an omitted configuration should read Release" + Expect.equal (spec.Read (parse spec.Inputs "-c d")) "Debug" "a supplied configuration should be read" + } + ] + + testList "restore" [ + test "restores tools, then the solution" { + let stage = Baked.Stages.restore "Repo.slnx" |> resolve "" + Expect.equal stage.Name "restore" "the stage name" + Expect.sequenceEqual (labels stage) [ "dotnet tool restore --verbosity q"; "dotnet restore Repo.slnx" ] "the steps" + Expect.isTrue (isActive stage) "the stage runs without --quick" + } + test "is skipped by --quick, naming it" { + let stage = Baked.Stages.restore "Repo.slnx" |> resolve "--quick true" + Expect.isFalse (isActive stage) "the stage is skipped under --quick" + Expect.sequenceEqual (reasons stage) [ "--quick is set" ] "--explain names the option" + } + test "the With variant takes the consumer's own flag" { + let own = Input.option "--fast" + let spec = Baked.Stages.restoreWith (InputSpec.ofInput own) "Repo.slnx" + Expect.sequenceEqual (inputNames spec.Inputs) [ "--fast" ] "only the consumer's flag is declared" + Expect.isFalse (resolve "--fast true" spec |> isActive) "the consumer's flag skips the stage" + } + ] + + testList "clean" [ + test "the step's label lists its patterns" { + let stage = Baked.Stages.clean [ "**/bin"; "!bin" ] [ "bin/*.nupkg" ] |> resolve "" + Expect.sequenceEqual (labels stage) [ "empty **/bin !bin; delete bin/*.nupkg" ] "the label" + Expect.isFalse (Baked.Stages.clean [ "tmp" ] [] |> resolve "-q true" |> isActive) "--quick skips the clean" + } + test "empties the selected directories and deletes the selected files, under the working directory" { + let directory = + tempTree [ "bin/keep.dll"; "bin/a.nupkg"; "bin/sub/b.nupkg"; "src/A/bin/Debug/A.dll"; "src/B/bin/B.dll" + "src/B/obj/B.dll"; "node_modules/pkg/bin/tool.js" ] + try + let root = directory.FullName + let clean = + Baked.Stages.clean [ "**/bin"; "!bin"; "tmp" ] [ "bin/**/*.nupkg" ] + |> resolve "" + |> StageContext.setWorkingDir (ValueSome root) + Expect.isOk (quietly (fun () -> runStage clean)) "the clean should succeed" + let exists (path: string) = File.Exists(Path.Combine(root, path)) + Expect.isTrue (exists "bin/keep.dll") "the excluded root bin keeps its other files" + Expect.isFalse (exists "bin/a.nupkg" || exists "bin/sub/b.nupkg") "the packages are deleted" + Expect.isFalse (exists "src/A/bin/Debug/A.dll" || exists "src/B/bin/B.dll") "nested bin directories are emptied" + Expect.isTrue (Directory.Exists(Path.Combine(root, "src/A/bin"))) "an emptied directory remains" + Expect.isTrue (exists "src/B/obj/B.dll") "an unselected directory is untouched" + Expect.isTrue (exists "node_modules/pkg/bin/tool.js") "node_modules is not walked" + Expect.isTrue (Directory.Exists(Path.Combine(root, "tmp"))) "a literal directory is created" + finally + directory.Delete true + } + test "glob matching" { + Expect.isTrue (Baked.Clean.isMatch "**/bin" "bin") "** matches no directories" + Expect.isTrue (Baked.Clean.isMatch "**/bin" "a/b/bin") "** matches several directories" + Expect.isFalse (Baked.Clean.isMatch "*/bin" "a/b/bin") "* stays within a segment" + Expect.isTrue (Baked.Clean.isMatch "bin/*.nupkg" "bin/A.1.0.0.nupkg") "* matches within a segment" + Expect.isFalse (Baked.Clean.isMatch "bin/*.nupkg" "bin/A.snupkg.txt") "the extension must match" + } + ] + + testList "build and pack" [ + test "build runs one sub-stage per project in parallel, in the configuration" { + let stage = Baked.Stages.build [ "src/A/A.fsproj"; "src/B/B.fsproj" ] |> resolve "" + Expect.equal stage.Name "build" "the stage name" + Expect.equal (stage.IsParallel stage) (ValueSome -1) "the projects build in parallel" + Expect.sequenceEqual (subStages stage |> List.map _.Name) [ "build A"; "build B" ] "a sub-stage per project" + Expect.sequenceEqual + (subStages stage |> List.collect labels) + [ "dotnet build src/A/A.fsproj -c Release"; "dotnet build src/B/B.fsproj -c Release" ] + "Release by default" + let debug = Baked.Stages.build [ "src/A/A.fsproj" ] |> resolve "--configuration debug" + Expect.sequenceEqual (subStages debug |> List.collect labels) [ "dotnet build src/A/A.fsproj -c Debug" ] "the configuration" + } + test "pack packs the built output without rebuilding" { + let stage = Baked.Stages.pack "bin" [ "src/A/A.fsproj" ] |> resolve "" + Expect.equal (stage.IsParallel stage) (ValueSome -1) "the projects pack in parallel" + Expect.sequenceEqual + (subStages stage |> List.collect labels) + [ "dotnet pack src/A/A.fsproj -c Release --no-build --no-restore -o bin" ] + "the pack step" + } + ] + + testList "expecto" [ + test "runs the suite through dotnet run, locally on the console" { + let stage = Baked.Stages.expecto "tests/T/T.fsproj" [ "--sequenced" ] |> resolve "--ci false" + Expect.equal stage.Name "test T" "the stage name" + Expect.sequenceEqual + (labels stage) + [ "dotnet run --project tests/T/T.fsproj --no-build -c Release -- --sequenced" ] + "the MSBuild-resolved suite, without --summary" + Expect.isTrue stage.Output.IsNone "local output is inherited" + Expect.isTrue (isActive stage) "the suite runs" + } + test "summarises and captures under --ci" { + let stage = Baked.Stages.expecto "tests/T/T.fsproj" [] |> resolve "--ci true" + Expect.sequenceEqual (labels stage) [ "dotnet run --project tests/T/T.fsproj --no-build -c Release -- --summary" ] "--summary" + Expect.isTrue (match stage.Output with ValueSome(StageOutput.Captured _) -> true | _ -> false) "the output is captured" + } + test "is skipped by --skip-tests" { + let stage = Baked.Stages.expecto "tests/T/T.fsproj" [] |> resolve "--skip-tests true --ci false" + Expect.isFalse (isActive stage) "the suite is skipped" + Expect.sequenceEqual (reasons stage) [ "--skip-tests is set" ] "--explain names the option" + } + ] + + testList "nugetPush" [ + test "pushes to nuget.org with the key masked" { + let spec = Baked.Stages.nugetPush "bin/*.nupkg" + let stage = spec |> resolve "--nuget-key hunter2" + Expect.equal stage.Name "push" "the stage name" + Expect.sequenceEqual (subStages stage |> List.map _.Name) [ "push to source" ] "only the source push" + let label = subStages stage |> List.collect labels |> List.exactlyOne + Expect.equal + label + "dotnet nuget push bin/*.nupkg --source https://api.nuget.org/v3/index.json --api-key *** --skip-duplicate" + "the key is masked" + Expect.isFalse (label.Contains "hunter2") "the key never reaches the label" + } + test "pushes to the local feed without a key" { + let spec = Baked.Stages.nugetPushWith (InputSpec.ret None) "local" "https://example.test/v3/index.json" "bin/*.nupkg" + let stage = spec |> resolve "" + Expect.sequenceEqual (subStages stage |> List.map _.Name) [ "push to local feed" ] "only the local push" + Expect.sequenceEqual + (subStages stage |> List.collect labels) + [ "dotnet nuget push bin/*.nupkg --source local --skip-duplicate" ] + "the local push" + } + ] + + testList "fantomas and npm" [ + test "fantomas formats the paths, skipped by --quick" { + let stage = Baked.Stages.fantomas [ "src"; "tests" ] |> resolve "" + Expect.sequenceEqual (labels stage) [ "dotnet fantomas src tests" ] "the format step" + Expect.sequenceEqual + (Baked.Stages.fantomasWith (InputSpec.ret false) true [ "src" ] |> resolve "" |> labels) + [ "dotnet fantomas --check src" ] + "the check step" + Expect.isFalse (Baked.Stages.fantomas [ "src" ] |> resolve "--quick true" |> isActive) "--quick skips formatting" + } + test "npmInstall runs npm ci under --ci and npm install otherwise" { + Expect.sequenceEqual (Baked.Stages.npmInstall "docs" |> resolve "--ci true" |> labels) [ "npm ci --prefix docs" ] "CI" + Expect.sequenceEqual (Baked.Stages.npmInstall "docs" |> resolve "--ci false" |> labels) [ "npm install --prefix docs" ] "local" + Expect.isFalse (Baked.Stages.npmInstall "docs" |> resolve "--ci false -q true" |> isActive) "--quick skips the install" + } + ] ] From 79da81f529c272c65235cad3f9164725a08f3a5b Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 12:05:21 +0000 Subject: [PATCH 15/25] Omit nested directories from Clean.directories; restate expectoWith's remark Clean.directories now drops any selected directory nested inside another selected one, literal or matched, so Clean.run no longer empties a parent and then re-creates a literal child under it. The doc remark states that contract; a test covers literal-under-match, literal-under-literal, match-under-literal and a shared name prefix. expectoWith's remark states what runs the suite instead of arguing for it. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- src/Partas.Build.Baked/Clean.fs | 11 +++++++++-- src/Partas.Build.Baked/Stages.fs | 3 ++- tests/Partas.Build.Tests/BakedTests.fs | 11 +++++++++++ 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/src/Partas.Build.Baked/Clean.fs b/src/Partas.Build.Baked/Clean.fs index 96363c7..2fd3ffc 100644 --- a/src/Partas.Build.Baked/Clean.fs +++ b/src/Partas.Build.Baked/Clean.fs @@ -66,7 +66,10 @@ let private empty (directory: string) = Directory.Delete(child, true) /// The directories below that select, relative to it. -/// The result holds no directory nested inside another selected directory. +/// +/// The result holds only the outermost selected directories: a selected directory nested inside another selected +/// directory, literal or matched, is omitted. +/// let directories (root: string) (patterns: string list) = let patterns = partition patterns let selected path = matchesAny patterns.Include path && not (matchesAny patterns.Exclude path) @@ -77,7 +80,11 @@ let directories (root: string) (patterns: string list) = |> Seq.filter selected |> List.ofSeq else [] - (literals |> List.filter (matchesAny patterns.Exclude >> not)) @ found |> List.distinct + let comparison = if ignoreCase then StringComparison.OrdinalIgnoreCase else StringComparison.Ordinal + let candidates = (literals |> List.filter (matchesAny patterns.Exclude >> not)) @ found |> List.distinct + let isNested (path: string) = + candidates |> List.exists (fun (outer: string) -> path.StartsWith(outer + "/", comparison)) + candidates |> List.filter (isNested >> not) /// The files below that select, relative to it. let files (root: string) (patterns: string list) = diff --git a/src/Partas.Build.Baked/Stages.fs b/src/Partas.Build.Baked/Stages.fs index 8a4f50a..fcaf1df 100644 --- a/src/Partas.Build.Baked/Stages.fs +++ b/src/Partas.Build.Baked/Stages.fs @@ -114,7 +114,8 @@ let pack (outDir: string) (projects: string list) = packWith Dotnet.configOrRele /// dotnet run --no-build, passing after --; skipped when /// reads true. /// -/// MSBuild resolves the test assembly, so a change of target framework or output path needs no change here. +/// The suite runs through dotnet run --no-build --project: the test assembly is the one MSBuild resolves for +/// in . /// When reads true, the suite also takes --summary and its output is /// captured: a passing run prints nothing, and a failing one carries the whole output in its error. /// diff --git a/tests/Partas.Build.Tests/BakedTests.fs b/tests/Partas.Build.Tests/BakedTests.fs index d7b902c..3b4b037 100644 --- a/tests/Partas.Build.Tests/BakedTests.fs +++ b/tests/Partas.Build.Tests/BakedTests.fs @@ -142,6 +142,17 @@ let tests = finally directory.Delete true } + test "a selected directory nested inside another selected directory is omitted" { + let directory = tempTree [ "src/A/bin/A.dll"; "a/b/c.txt" ] + try + let root = directory.FullName + Expect.sequenceEqual (Baked.Clean.directories root [ "**/bin"; "src/A/bin/keep" ]) [ "src/A/bin" ] "literal under a match" + Expect.sequenceEqual (Baked.Clean.directories root [ "a"; "a/b" ]) [ "a" ] "literal under a literal" + Expect.sequenceEqual (Baked.Clean.directories root [ "src"; "**/bin" ]) [ "src" ] "match under a literal" + Expect.sequenceEqual (Baked.Clean.directories root [ "ab"; "a" ]) [ "ab"; "a" ] "a shared prefix is not nesting" + finally + directory.Delete true + } test "glob matching" { Expect.isTrue (Baked.Clean.isMatch "**/bin" "bin") "** matches no directories" Expect.isTrue (Baked.Clean.isMatch "**/bin" "a/b/bin") "** matches several directories" From bc117532c0ed71fb72e9d9c0737e76b93b6423d9 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 12:51:23 +0000 Subject: [PATCH 16/25] Stop Clean from following symbolic links A linked directory is neither walked nor selected, a literal directory reached through a link is dropped, and emptying a directory removes the links in it without touching their targets. Previously **/bin could empty a directory outside the root, and a cyclic link made the walk recurse without end. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 3 +- notes/PLAN-Integration.md | 5 ++- src/Partas.Build.Baked/Clean.fs | 52 +++++++++++++++++--------- tests/Partas.Build.Tests/BakedTests.fs | 23 ++++++++++++ 4 files changed, 63 insertions(+), 20 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 886ada8..4b47082 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -209,7 +209,8 @@ for the options every build CLI ends up wanting (`--configuration` and `Dotnet.c writes to disk. `Stages.fs` holds the prefab stages (`restore`, `clean`, `build`, `pack`, `expecto`, `nugetPush`, `fantomas`, `npmInstall`): functions answering `InputSpec` that read Baked's own options, each with a `…With` counterpart taking those options as `InputSpec`s. A skip carries a reason for `--explain`. `Clean.fs` is the -glob matcher behind `clean`, on `System.IO` alone. +glob matcher behind `clean`, on `System.IO` alone; it never follows a symbolic link, so everything it deletes lies +under its root. The core model, once a single `Types.fs`, is split by responsibility and compiles in this order: 1. `Exceptions.fs` (`Partas.Build.ErrorHandling`) — pipeline exceptions, `FailureCause`, `StepOutcome`. diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index 8666500..e82797d 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -102,7 +102,10 @@ an ordinary `StageContext`, so renaming it, toggling its parallelism or adding a - `clean (directories, files)` takes glob patterns relative to the stage's working directory, `!` excluding (`[ "**/bin"; "!bin"; "tmp" ]`). A wildcard-free directory is created if missing, as Fake's `cleanDirs` did. The - walk skips `.git` and `node_modules` (Fake's `**/bin` also emptied `node_modules//bin`). + walk skips `.git` and `node_modules` (Fake's `**/bin` also emptied `node_modules//bin`). Links are never + followed: a linked directory is neither walked nor selected, a literal through a link is dropped, and emptying a + directory removes the links in it without touching their targets (Fake's glob followed them, so `**/bin` could + empty a directory outside the repository). - `pack` runs `dotnet pack -c --no-build --no-restore`, where `Program.fs` rebuilt each project in the default configuration, in parallel over shared references. - `expecto (project, arguments)` takes the suite's arguments instead of a filter, and is skipped by `--skip-tests`. diff --git a/src/Partas.Build.Baked/Clean.fs b/src/Partas.Build.Baked/Clean.fs index 2fd3ffc..1bfc54d 100644 --- a/src/Partas.Build.Baked/Clean.fs +++ b/src/Partas.Build.Baked/Clean.fs @@ -4,6 +4,9 @@ /// * any run of characters within one segment, ? one character. A pattern starting with ! /// excludes what it matches. Matching is case-insensitive on Windows and case-sensitive elsewhere. /// The walk skips .git and node_modules. +/// Symbolic links and other reparse points are never followed: a linked directory is neither walked nor selected, +/// and emptying a directory removes the links inside it, leaving their targets intact. Every path read or deleted +/// lies under the root. /// module Partas.Build.Baked.Clean @@ -47,28 +50,40 @@ let private partition (patterns: string list) = let private matchesAny patterns path = patterns |> List.exists (fun pattern -> isMatch pattern path) -/// Every directory below root, relative to it, depth first. `descend` decides whether the walk enters one. +let private isLink (entry: FileSystemInfo) = + entry.Attributes.HasFlag FileAttributes.ReparsePoint + +/// Whether `relative`, or a directory on the way to it from root, is a link. +let private throughLink (root: string) (relative: string) = + segments relative + |> List.scan (fun path segment -> Path.Combine(path, segment)) root + |> List.tail + |> List.exists (fun path -> Directory.Exists path && isLink (DirectoryInfo path)) + +/// Every directory below root, relative to it, depth first, excluding links. `descend` decides whether the walk enters one. let rec private walkDirectories (root: string) (relative: string) (descend: string -> bool) = seq { - for directory in Directory.EnumerateDirectories(Path.Combine(root, relative)) do - let name = Path.GetFileName directory - if not (pruned.Contains name) then - let path = if relative = "" then name else relative + "/" + name + for directory in DirectoryInfo(Path.Combine(root, relative)).EnumerateDirectories() do + if not (pruned.Contains directory.Name || isLink directory) then + let path = if relative = "" then directory.Name else relative + "/" + directory.Name yield path if descend path then yield! walkDirectories root path descend } -let private empty (directory: string) = - for file in Directory.EnumerateFiles(directory, "*", SearchOption.AllDirectories) do - File.SetAttributes(file, FileAttributes.Normal) - for file in Directory.GetFiles directory do - File.Delete file - for child in Directory.GetDirectories directory do - Directory.Delete(child, true) +/// Deletes the contents of `directory`. A link is removed itself; its target is left intact. +let rec private empty (directory: DirectoryInfo) = + for entry in directory.EnumerateFileSystemInfos() do + match entry with + | :? DirectoryInfo as child when not (isLink child) -> + empty child + child.Delete() + | _ -> + if not (isLink entry) then entry.Attributes <- FileAttributes.Normal + entry.Delete() /// The directories below that select, relative to it. /// /// The result holds only the outermost selected directories: a selected directory nested inside another selected -/// directory, literal or matched, is omitted. +/// directory, literal or matched, is omitted. A literal directory that is a link, or lies beneath one, is omitted. /// let directories (root: string) (patterns: string list) = let patterns = partition patterns @@ -81,7 +96,8 @@ let directories (root: string) (patterns: string list) = |> List.ofSeq else [] let comparison = if ignoreCase then StringComparison.OrdinalIgnoreCase else StringComparison.Ordinal - let candidates = (literals |> List.filter (matchesAny patterns.Exclude >> not)) @ found |> List.distinct + let literals = literals |> List.filter (fun path -> not (matchesAny patterns.Exclude path || throughLink root path)) + let candidates = literals @ found |> List.distinct let isNested (path: string) = candidates |> List.exists (fun (outer: string) -> path.StartsWith(outer + "/", comparison)) candidates |> List.filter (isNested >> not) @@ -106,11 +122,11 @@ let files (root: string) (patterns: string list) = let run (root: string) (directoryPatterns: string list) (filePatterns: string list) = let deleted = files root filePatterns for file in deleted do - let path = Path.Combine(root, file) - File.SetAttributes(path, FileAttributes.Normal) - File.Delete path + let file = FileInfo(Path.Combine(root, file)) + if not (isLink file) then file.Attributes <- FileAttributes.Normal + file.Delete() let emptied = directories root directoryPatterns for directory in emptied do let path = Path.Combine(root, directory) - if Directory.Exists path then empty path else Directory.CreateDirectory path |> ignore + if Directory.Exists path then empty (DirectoryInfo path) else Directory.CreateDirectory path |> ignore emptied, deleted diff --git a/tests/Partas.Build.Tests/BakedTests.fs b/tests/Partas.Build.Tests/BakedTests.fs index 3b4b037..23d298f 100644 --- a/tests/Partas.Build.Tests/BakedTests.fs +++ b/tests/Partas.Build.Tests/BakedTests.fs @@ -153,6 +153,29 @@ let tests = finally directory.Delete true } + test "links are removed without following them" { + let outside = tempTree [ "bin/important.txt"; "bin/a.nupkg"; "secret.nupkg" ] + let directory = tempTree [ "bin/own.dll"; "src/A/A.fs" ] + try + let root = directory.FullName + let link (path: string) (target: string) = Directory.CreateSymbolicLink(Path.Combine(root, path), target) |> ignore + link "link" outside.FullName + link "bin/inner" outside.FullName + link "src/loop" root + File.CreateSymbolicLink(Path.Combine(root, "src/A/linked.nupkg"), Path.Combine(outside.FullName, "secret.nupkg")) + |> ignore + let emptied, deleted = Baked.Clean.run root [ "**/bin"; "link/bin" ] [ "**/*.nupkg" ] + Expect.sequenceEqual emptied [ "bin" ] "a linked directory is neither walked nor selected" + Expect.sequenceEqual deleted [ "src/A/linked.nupkg" ] "a linked file is selected by its own path" + let intact (path: string) = File.Exists(Path.Combine(outside.FullName, path)) + Expect.isTrue (intact "bin/important.txt" && intact "bin/a.nupkg" && intact "secret.nupkg") "the link targets are intact" + Expect.isFalse (Directory.Exists(Path.Combine(root, "bin/inner"))) "a link inside an emptied directory is removed" + Expect.isFalse (File.Exists(Path.Combine(root, "bin/own.dll"))) "the directory itself is emptied" + Expect.isTrue (File.Exists(Path.Combine(root, "src/A/A.fs"))) "an unselected file is untouched" + finally + directory.Delete true + outside.Delete true + } test "glob matching" { Expect.isTrue (Baked.Clean.isMatch "**/bin" "bin") "** matches no directories" Expect.isTrue (Baked.Clean.isMatch "**/bin" "a/b/bin") "** matches several directories" From 89f85acbbc7529fa926c921506833a56a46c77b5 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 13:48:53 +0000 Subject: [PATCH 17/25] Migrate merged code off Input.desc; read --json's result from the last output line - Baked/Common.fs and MachineOutput.fs used the now-obsolete `Input.desc` (the json and baked-stages branches predate api-traps' obsoletion); both use `Input.description`, and the build is warning-free again. Common.fs's `--ci` line had lost api-traps' migration in the baked-stages merge. - The machine-output tests assumed the given `output` writer receives only the JSON. Since host routes the run's own console lines to that writer too, they now read the result from the last line, as the documented `--json` contract states, and check `--report` keeps the JSON (not every line) out of the output. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- src/Partas.Build.Baked/Common.fs | 6 +++--- src/Partas.Build/MachineOutput.fs | 6 +++--- tests/Partas.Build.Tests/CommandTests.fs | 15 ++++++++------- 3 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Partas.Build.Baked/Common.fs b/src/Partas.Build.Baked/Common.fs index 33c2fae..7834a1f 100644 --- a/src/Partas.Build.Baked/Common.fs +++ b/src/Partas.Build.Baked/Common.fs @@ -20,14 +20,14 @@ let isCI = let quick = Input.option "--quick" |> Input.alias "-q" - |> Input.desc "Skips restores, installations, cleaning and formatting" + |> Input.description "Skips restores, installations, cleaning and formatting" /// `--skip-tests`: skips building and running the test suites. let skipTests = Input.option "--skip-tests" - |> Input.desc "Skips building and running the test suites" + |> Input.description "Skips building and running the test suites" /// `--watch`: runs the operation in watch mode. let watch = Input.option "--watch" - |> Input.desc "Runs the operation in watch mode" + |> Input.description "Runs the operation in watch mode" diff --git a/src/Partas.Build/MachineOutput.fs b/src/Partas.Build/MachineOutput.fs index fa217ec..f4443bb 100644 --- a/src/Partas.Build/MachineOutput.fs +++ b/src/Partas.Build/MachineOutput.fs @@ -228,20 +228,20 @@ module MachineOutput = /// The --json flag. let json: ActionInput = Input.option "--json" - |> Input.desc "Write JSON instead of text: the --explain tree, or the run result as the last line of output" + |> Input.description "Write JSON instead of text: the --explain tree, or the run result as the last line of output" |> Input.def false /// The --report option: a file the run result is written to as JSON. /// Written once the command's pipelines finish, whether they succeeded or not, and never under --explain. let report: ActionInput = Input.optionMaybe "--report" - |> Input.desc "Write the run result as JSON to this file" + |> Input.description "Write the run result as JSON to this file" |> Input.helpName "path" /// The --schema flag, which prints schema for the command it is given to, and exits. let schemaOption: ActionInput = Input.option "--schema" - |> Input.desc "Print this command, its options and its subcommands as JSON, and exit" + |> Input.description "Print this command, its options and its subcommands as JSON, and exit" |> Input.def false |> Input.editOption (fun option -> option.Action <- diff --git a/tests/Partas.Build.Tests/CommandTests.fs b/tests/Partas.Build.Tests/CommandTests.fs index e2dfe2d..ec36fd1 100644 --- a/tests/Partas.Build.Tests/CommandTests.fs +++ b/tests/Partas.Build.Tests/CommandTests.fs @@ -673,14 +673,15 @@ let private failingRoot () = [] let machineOutputTests = testList "machine output" [ - test "--json writes the run result as the only line of the invocation's output" { + test "--json writes the run result as the last line of the invocation's output" { use output = new StringWriter() let result = Helpers.quietly (fun () -> (failingRoot ()).Invoke([ "--json" ], output = output)) + // The given output also receives the run's own console lines; the result follows them, on one line. let lines = output.ToString().Split([| '\n' |], StringSplitOptions.RemoveEmptyEntries) - Expect.equal lines.Length 1 "the result replaces the timing table, on one line" + Expect.isFalse (output.ToString().Contains "Outcome") "the result replaces the timing table" - let document = JsonDocument.Parse(lines[0]).RootElement + let document = JsonDocument.Parse(Array.last lines).RootElement Expect.equal ((document |> property "exitCode").GetInt32()) result.ExitCode "the exit code matches the result" Expect.equal ((document |> property "outcome").GetString()) "failed" "the outcome is named" @@ -705,10 +706,10 @@ let machineOutputTests = use output = new StringWriter() let result = Helpers.quietly (fun () -> root.Invoke([ "--json" ], output = output)) - let json = output.ToString() + let json = output.ToString().Split([| '\n' |], StringSplitOptions.RemoveEmptyEntries) |> Array.last Expect.equal result.ExitCode ExitCode.Failure "the command fails" - Expect.isFalse (json.Contains key) "the secret stays out of the result" + Expect.isFalse (output.ToString().Contains key) "the secret stays out of the output and the result" let cause = (JsonDocument.Parse json).RootElement |> property "pipelines" |> items |> List.exactlyOne |> property "reports" |> items |> named "push" |> property "failures" |> items |> List.exactlyOne |> property "cause" Expect.isNonEmpty ((cause |> property "message").GetString()) "the failure is described" } @@ -721,7 +722,7 @@ let machineOutputTests = let result = Helpers.quietly (fun () -> (recordingRoot (ResizeArray())).Invoke([ "--report"; path ], output = output)) Expect.equal result.ExitCode ExitCode.Success "the run passes" - Expect.equal (output.ToString()) "" "the report stays out of the output" + Expect.isFalse (output.ToString().Contains "formatVersion") "the report stays out of the output" let document = JsonDocument.Parse(File.ReadAllText path).RootElement Expect.equal ((document |> property "outcome").GetString()) "succeeded" "the file holds the result" Expect.equal (document |> property "pipelines" |> items |> List.exactlyOne |> property "timings" |> items |> List.length) 2 "with every stage it ran" @@ -734,7 +735,7 @@ let machineOutputTests = let configuration = Input.option "--configuration" |> Input.alias "-c" - |> Input.desc "The build configuration" + |> Input.description "The build configuration" |> Input.def "Release" |> Input.acceptOnlyFromAmong [ "Debug"; "Release" ] From 6d0e8f775a95eb9278de1331bc7ab7a3337846f6 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 13:51:42 +0000 Subject: [PATCH 18/25] Record the integration roll-up in PLAN-Integration and CLAUDE.md MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit §7 rows 1-10 are done on this branch; the status header and a note under §7 say what the merges decided. CLAUDE.md's test count reflects the merged suite (362 in Partas.Build.Tests). Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- CLAUDE.md | 2 +- notes/PLAN-Integration.md | 28 ++++++++++++++++++++++------ 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 4b47082..00bc931 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -38,7 +38,7 @@ Fast inner loop while working on the library only: `dotnet build src/Partas.Buil ## Current state (verify before assuming) -- Phases 0-7 of `notes/PLAN.md` are done: `dotnet build src/Partas.Build` is clean and `dotnet run --project Build.fsproj -- test` is green (443 Expecto tests across four suites — 301 in `tests/Partas.Build.Tests`, one file per layer, plus 65 in `tests/Partas.Build.ExternalAnnotations.Tests`, 74 in `tests/Partas.ExternalAnnotations.Tests` and 3 in `tests/Partas.Build.Cmd.NetStandard.Tests`; the `test` stage also runs `tests/Partas.Build.CompilerProbe` in both Debug and Release, 11 tests each). The `Build/` CLI is written against the library: a breaking change breaks it first. +- Phases 0-7 of `notes/PLAN.md` are done: `dotnet build src/Partas.Build` is clean and `dotnet run --project Build.fsproj -- test` is green (504 Expecto tests across four suites — 362 in `tests/Partas.Build.Tests`, one file per layer, plus 65 in `tests/Partas.Build.ExternalAnnotations.Tests`, 74 in `tests/Partas.ExternalAnnotations.Tests` and 3 in `tests/Partas.Build.Cmd.NetStandard.Tests`; the `test` stage also runs `tests/Partas.Build.CompilerProbe` in both Debug and Release, 11 tests each). The `Build/` CLI is written against the library: a breaking change breaks it first. - The DSL exists end to end: `inputs` (`Builders/Inputs.fs`), `stage` (`Builders/Stage.fs`), `pipeline` (`Builders/Pipeline.fs`), `command`/`rootCommand` (`Builders/Command.fs`). A stage that declares an input turns its pipeline into an `InputSpec`, and the command registers whatever those specs declare. Conditions are in `Builders/Conditions.fs` — `whenAll`/`whenAny`/`whenNot`/`whenEnv`/`whenStage` plus the `when'`/`whenEnvVar`/`whenBranch`/`when{Windows,Linux,OSX}` operations on `StageBuilder`. - A command carries `PipelineDefaults: BuildPipeline` and takes the pipeline-level operations itself (`workingDir`, `envVars`, the three timeouts, `acceptExitCodes`, the output operations, `noPrefixForStep`/`noStdRedirectForStep`, `runBeforeEachStage`/`runAfterEachStage`, `post`, `verbosity`/`verbose`/`quiet`), each one built through `CommandBuilderBase.MapPipelineDefault`. They are **defaults, not overrides**: `PipelineContext.applyDefaults` copies a setting across only where the pipeline left it at the value `PipelineContext.create` gave it, so a pipeline that sets the same thing wins. See *Command defaults* below. - `run`/`runSensitive` start real processes through `CmdRunner` (`Process.fs`). A `Cmd`, defined in `src/Partas.Build.Cmd/Program.fs`, keeps the executable and its arguments apart all the way to `ProcessStartInfo.ArgumentList`, so the platform does the escaping. Interpolate through the `cmd` helper — `run (cmd $"dotnet build {project}")`. `run $"..."` binds to the `string` overload and flattens the holes; `runSensitive $"..."` takes the `FormattableString` directly and masks every hole as `***`. A function returning a command line is `runLine (fun ctx -> "...")`; the `run` overloads over `StageContext -> string` (and its `Async`/`Task`/`option` forms) are `[]`, since a lambda returning a message would start a process. `runLine` is a separate name, so the `run` overload set — and the `FS0041` balance below — is unchanged. There is no `Fake.Core.Process` dependency; `notes/PLAN.md`'s *The command runner* records why. diff --git a/notes/PLAN-Integration.md b/notes/PLAN-Integration.md index e82797d..ea9d6fb 100644 --- a/notes/PLAN-Integration.md +++ b/notes/PLAN-Integration.md @@ -1,7 +1,8 @@ # PLAN-Integration Findings from a survey of how Partas.Build is used in practice, and the design that follows. Drafted -2026-09-24. **Status: proposal, partly implemented — see the status line under each section.** +2026-09-24. **Status: §3-§5.3 and §6 implemented, and rolled up on `claude/partas-build-patterns-jgrwr0-integration` +(see the status line under each section, and §7); §4.4, §4.5 and §5.4 (§7 row 11) remain.** Companion to `PLAN-Discoverability.md`, which responded to `FEEDBACK-Xantham.md` (a report written against 0.3.0). This document starts from the consumers' *code* instead of a written report, and adds a third axis the @@ -478,18 +479,33 @@ needs checking against the code. | 1 | `.mcp.json`, `printfn` in Baked, `Cmd.argIf` in `Program.fs` — **done** | hygiene | trivial | | 2 | Task 14b: no consumer needs `Internal` — **done** | usability | medium | | 3 | `run (fun _ -> string)` rename/obsolete; `desc`/`input` duplicates — **done** | usability | small | -| 4 | Exit codes (§4.2) | discoverability | small | -| 5 | `Command.invoke` + `RunResult` (§5.3.1) | SageFs, discoverability | medium | +| 4 | Exit codes (§4.2) — **done** | discoverability | small | +| 5 | `Command.invoke` + `RunResult` (§5.3.1) — **done** | SageFs, discoverability | medium | | 6 | JSON for `--explain`, the run result, `--schema` (§4.1) — serializes 5's result — **done** | discoverability | medium | -| 7 | Console hygiene, argv capture, env at run time (§5.3.2-5.3.5) — after the Spectre spike | SageFs | medium | -| 8 | Thread-interrupt bridge + no-orphan test (§5.3.4) | SageFs | medium | -| 9 | Baked prefab stages (§3.1), `Build/Program.fs` rewritten on them as the acceptance test | usability | large | +| 7 | Console hygiene, argv capture, env at run time (§5.3.2-5.3.5) — after the Spectre spike — **done** | SageFs | medium | +| 8 | Thread-interrupt bridge + no-orphan test (§5.3.4) — **done** | SageFs | medium | +| 9 | Baked prefab stages (§3.1), `Build/Program.fs` rewritten on them as the acceptance test — **done** | usability | large | | 10 | Side-effect-free `--explain` (§4.3) — **done** | discoverability | medium | | 11 | XML ``s, agent snippet, consumer pattern docs (§4.4, §4.5, §5.4) | discoverability | medium | `Build/Program.fs` stays the acceptance test, as in `PLAN.md`: items 2, 3 and 9 are done when it compiles without `open Partas.Build.Internal` and without the hand-rolled rows of §2's first table. +**Status: rows 1-10 rolled up on `claude/partas-build-patterns-jgrwr0-integration`**, merged in the order +int-core, int-usability, json, host, api-traps, baked-stages (int-core and int-usability are the shared bases the +others branch from). Integration decisions: + +- `runReportingTimings` takes json's `--json` flag and always-present `InvocationState` together with host's + `PipelineContext.Running.enter`/`runEntered` reentrancy guard; `whenBranches` keeps int-usability's + `effectful` marking and prints through host's `Terminal.ansi ()`. +- Code from json and baked-stages that used `Input.desc` (obsolete since api-traps) uses `Input.description`. +- `--json` with an `output` writer given to `Invoke`: host routes the run's console lines to that writer as + well, so the run result is its *last* line rather than its only one — the contract §4.1 already states for + stdout. The json tests read the last line accordingly. +- `Build/Program.fs` is baked-stages' prefab rewrite with api-traps' `when'` skip reasons. It was compiled from a + scratch copy with `Repo` stubbed (the type provider cannot load in the container), and `test --explain` and + `publish --explain --json` were run against the stub. + ## 8. Open questions 1. JSON flag naming: `--format json` on every command, or `--json`? Does it collide with a consumer's own option From abe7e80d93e16623665b1962eeefde3ef0a40470 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 14:19:01 +0000 Subject: [PATCH 19/25] Load Terminal.fs in the docs pages; label the process tests as integration The four .fsx pages under docs/content #load the library in compile order and stopped type-checking when Terminal.fs joined it. They load it now, and Baked's Clean.fs and Stages.fs too. The cmd, operations and CompilerTests lists end in testLabel "integration", which SageFs live testing reads from the test name to run them on demand. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- docs/content/Build/composition.fsx | 3 +++ docs/content/Build/computation-expression-operations.fsx | 3 +++ docs/content/Build/index.fsx | 3 +++ docs/content/index.fsx | 3 +++ tests/Partas.Build.Tests/CmdTests.fs | 2 ++ tests/Partas.Build.Tests/CompilerTests.fs | 2 ++ tests/Partas.Build.Tests/ExecutionTests.fs | 2 ++ 7 files changed, 18 insertions(+) diff --git a/docs/content/Build/composition.fsx b/docs/content/Build/composition.fsx index 692e52c..029a3d9 100644 --- a/docs/content/Build/composition.fsx +++ b/docs/content/Build/composition.fsx @@ -23,6 +23,7 @@ order: 3 #load "../../../src/Partas.Build/System.CommandLine/Inputs.fs" #load "../../../src/Partas.Build/Exceptions.fs" #load "../../../src/Partas.Build/Output.fs" +#load "../../../src/Partas.Build/Terminal.fs" #load "../../../src/Partas.Build/Annotations.fs" #load "../../../src/Partas.Build/Environment.fs" #load "../../../src/Partas.Build/Timing.fs" @@ -52,6 +53,8 @@ order: 3 #load "../../../src/Partas.Build.Baked/NuGet.fs" #load "../../../src/Partas.Build.Baked/Dotnet.fs" #load "../../../src/Partas.Build.Baked/SemVer.fs" +#load "../../../src/Partas.Build.Baked/Clean.fs" +#load "../../../src/Partas.Build.Baked/Stages.fs" open Partas.Build diff --git a/docs/content/Build/computation-expression-operations.fsx b/docs/content/Build/computation-expression-operations.fsx index 832443b..c3fb884 100644 --- a/docs/content/Build/computation-expression-operations.fsx +++ b/docs/content/Build/computation-expression-operations.fsx @@ -22,6 +22,7 @@ order: 4 #load "../../../src/Partas.Build/System.CommandLine/Inputs.fs" #load "../../../src/Partas.Build/Exceptions.fs" #load "../../../src/Partas.Build/Output.fs" +#load "../../../src/Partas.Build/Terminal.fs" #load "../../../src/Partas.Build/Annotations.fs" #load "../../../src/Partas.Build/Environment.fs" #load "../../../src/Partas.Build/Timing.fs" @@ -51,6 +52,8 @@ order: 4 #load "../../../src/Partas.Build.Baked/NuGet.fs" #load "../../../src/Partas.Build.Baked/Dotnet.fs" #load "../../../src/Partas.Build.Baked/SemVer.fs" +#load "../../../src/Partas.Build.Baked/Clean.fs" +#load "../../../src/Partas.Build.Baked/Stages.fs" diff --git a/docs/content/Build/index.fsx b/docs/content/Build/index.fsx index 51b1cff..3b730ea 100644 --- a/docs/content/Build/index.fsx +++ b/docs/content/Build/index.fsx @@ -21,6 +21,7 @@ order: 0 #load "../../../src/Partas.Build/System.CommandLine/Inputs.fs" #load "../../../src/Partas.Build/Exceptions.fs" #load "../../../src/Partas.Build/Output.fs" +#load "../../../src/Partas.Build/Terminal.fs" #load "../../../src/Partas.Build/Annotations.fs" #load "../../../src/Partas.Build/Environment.fs" #load "../../../src/Partas.Build/Timing.fs" @@ -50,6 +51,8 @@ order: 0 #load "../../../src/Partas.Build.Baked/NuGet.fs" #load "../../../src/Partas.Build.Baked/Dotnet.fs" #load "../../../src/Partas.Build.Baked/SemVer.fs" +#load "../../../src/Partas.Build.Baked/Clean.fs" +#load "../../../src/Partas.Build.Baked/Stages.fs" open Partas.Build diff --git a/docs/content/index.fsx b/docs/content/index.fsx index 97e5de7..6c9c16d 100644 --- a/docs/content/index.fsx +++ b/docs/content/index.fsx @@ -20,6 +20,7 @@ order: 0 #load "../../src/Partas.Build/System.CommandLine/Inputs.fs" #load "../../src/Partas.Build/Exceptions.fs" #load "../../src/Partas.Build/Output.fs" +#load "../../src/Partas.Build/Terminal.fs" #load "../../src/Partas.Build/Annotations.fs" #load "../../src/Partas.Build/Environment.fs" #load "../../src/Partas.Build/Timing.fs" @@ -49,6 +50,8 @@ order: 0 #load "../../src/Partas.Build.Baked/NuGet.fs" #load "../../src/Partas.Build.Baked/Dotnet.fs" #load "../../src/Partas.Build.Baked/SemVer.fs" +#load "../../src/Partas.Build.Baked/Clean.fs" +#load "../../src/Partas.Build.Baked/Stages.fs" open Partas.Build diff --git a/tests/Partas.Build.Tests/CmdTests.fs b/tests/Partas.Build.Tests/CmdTests.fs index 508494f..0059737 100644 --- a/tests/Partas.Build.Tests/CmdTests.fs +++ b/tests/Partas.Build.Tests/CmdTests.fs @@ -294,3 +294,5 @@ let tests = Expect.equal (sleepsAlive ()) before "the caller's token should kill the whole tree, as the timeout does" } ] + // SageFs live testing classifies a test whose full name contains "integration" as Integration, run on demand. + |> testLabel "integration" diff --git a/tests/Partas.Build.Tests/CompilerTests.fs b/tests/Partas.Build.Tests/CompilerTests.fs index 955bb14..fe85b03 100644 --- a/tests/Partas.Build.Tests/CompilerTests.fs +++ b/tests/Partas.Build.Tests/CompilerTests.fs @@ -57,3 +57,5 @@ let tests = mustNotCompile "UnsupportedSettingState" "FS0001" mustNotCompile "UnsupportedPipelineState" "FS0001" ] + // SageFs live testing classifies a test whose full name contains "integration" as Integration, run on demand. + |> testLabel "integration" diff --git a/tests/Partas.Build.Tests/ExecutionTests.fs b/tests/Partas.Build.Tests/ExecutionTests.fs index 7759e12..3af5502 100644 --- a/tests/Partas.Build.Tests/ExecutionTests.fs +++ b/tests/Partas.Build.Tests/ExecutionTests.fs @@ -391,3 +391,5 @@ let operations = Expect.stringContains (Explain.render [ unlabelled ]) "step 1" "an unlabelled operation is described by its index" } ] + // SageFs live testing classifies a test whose full name contains "integration" as Integration, run on demand. + |> testLabel "integration" From c814fa7b289a6c049b6c5d1c126d55ca2fe544d6 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 24 Sep 2026 14:19:10 +0000 Subject: [PATCH 20/25] Add XML examples to the entry points agents reach first blocks on the run overloads, runLine, runSensitive, input, whenSome, cmd, Cmd.argIf/argWhenSome, stage, pipeline, command, rootCommand, rootCommandOfScript, Command.root/invoke, RootCommandDefinition.Invoke, RunResult and its JSON form, the --json flag and Baked.Stages. The run (string) remark claimed an interpolated string keeps each hole one argument; it binds to the string overload and is re-split, and the remark now says so. AGENTS-snippet.md is packed into the Partas.Build package root. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_015LK3n2hgMAMxKAmuKyZL8f --- docs/static/AGENTS-snippet.md | 63 +++++++++++++++++ src/Partas.Build.Baked/Stages.fs | 36 ++++++++++ src/Partas.Build.Cmd/Program.fs | 19 ++++++ src/Partas.Build/Builders/Command.fs | 78 ++++++++++++++++++++++ src/Partas.Build/Builders/Conditions.fs | 16 +++++ src/Partas.Build/Builders/Inputs.fs | 21 ++++++ src/Partas.Build/Builders/Pipeline.fs | 16 +++++ src/Partas.Build/Builders/Stage.fs | 16 +++++ src/Partas.Build/Builders/StageSettings.fs | 58 +++++++++++++++- src/Partas.Build/MachineOutput.fs | 12 ++++ src/Partas.Build/Partas.Build.fsproj | 2 + src/Partas.Build/RunResult.fs | 25 +++++++ 12 files changed, 360 insertions(+), 2 deletions(-) create mode 100644 docs/static/AGENTS-snippet.md diff --git a/docs/static/AGENTS-snippet.md b/docs/static/AGENTS-snippet.md new file mode 100644 index 0000000..b39509f --- /dev/null +++ b/docs/static/AGENTS-snippet.md @@ -0,0 +1,63 @@ +# Partas.Build: instructions for coding agents + +Paste this block into a repository's `AGENTS.md`, `CLAUDE.md` or `.claude/rules/` when its build is written with +[Partas.Build](https://shayanhabibi.github.io/Partas.Build/). Replace `` with how the repository runs its +build: `dotnet fsi build.fsx --`, `dotnet run --project Build.fsproj --`, or the name of a tool. The same file ships +at the root of the `Partas.Build` package (`~/.nuget/packages/partas.build//AGENTS-snippet.md`). + +--- + +## Running the build + +The build is a command-line program. Ask it what it does instead of reading its source. + +1. ` --help` lists the commands. ` --help` lists the options that command accepts. + The help is generated from the stages the command runs, so it is complete and current: an option absent from + it does not exist for that command. +2. ` [options] --explain` prints the stages and steps the command would run with those options, + and which stages are skipped and why. It runs nothing. Run it before a command you have not run before, and + whenever an option's effect is unclear. +3. ` [options] --explain --json` prints the same tree as JSON. Conditions with side effects + (a `git` branch check, a condition stage) are reported as `"status": "unevaluated"` rather than run. +4. ` --schema` prints the command, its options (name, aliases, type, default, choices) and its + subcommands as JSON. A secret default prints as `"***"`. + +## Exit codes + +| Code | Meaning | What to do | +|---|---|---| +| `0` | Success; also `--help`, `--version`, `--explain`, `--schema` | Nothing | +| `1` | A stage failed, or the build raised an exception | Fix the code or the environment; read the run result for which step | +| `2` | Usage error: unknown option, missing command, failed validation, or an unsatisfiable stage dependency. No stage ran | Fix the command line; check ` --help` | +| `130` | Cancelled: the pipeline's own timeout expired, Ctrl+C, or the caller cancelled the run. A stage's timeout is a failure (`1`) | Rerun, or raise the timeout | + +## Reading the result of a run + +Add `--json` to a run. The stages print as they otherwise would; the timing table is replaced by the run result, +which is the **last line** of output, one line of JSON: + +```json +{"formatVersion":1,"exitCode":1,"outcome":"failed","pipelines":[{"name":"test", + "reports":[{"name":"unit","address":"unit","path":[0],"outcome":"failed","error":"Exit code not acceptable.", + "propagates":true,"failures":[{"step":0,"label":"dotnet test","cause":{"kind":"reported", + "message":"Exit code not acceptable."}}],"nested":[]}], + "timings":[{"name":"unit","depth":0,"elapsedMs":90.7,"outcome":"failed","error":"Exit code not acceptable."}]}]} +``` + +- `outcome` is `succeeded`, `failed`, `usageError` or `cancelled`, matching the exit code. +- `pipelines[].reports` holds one report per stage, nested as the stages nest (`nested`). A report's `outcome` is + `succeeded`, `skipped` or `failed`; `propagates: false` marks a failure the build tolerated. +- `failures[].step` counts from zero and matches `index` in the `--explain --json` tree of the same stage; + `label` is the step's command line with secrets masked. `cause.kind` is `command`, `start` (the executable + could not be started), `raised` (an exception), `timedOut` or `reported`. +- `timings` lists every stage that finished, in order, with its `depth` and `elapsedMs`. + +`--report ` writes the same document, indented, to a file, with or without `--json`. Take the result from +there when the run's output is long or interleaved. + +## Rules + +- Do not guess option names; read ` --help`. +- Do not edit the build to skip a failing stage. Read the failing step's `label` and `cause`, and fix the cause. +- A command listed under "Commands with no description" in `--explain` output has no help text; read its stages + with `--explain` before running it. diff --git a/src/Partas.Build.Baked/Stages.fs b/src/Partas.Build.Baked/Stages.fs index fcaf1df..2ec32d5 100644 --- a/src/Partas.Build.Baked/Stages.fs +++ b/src/Partas.Build.Baked/Stages.fs @@ -14,6 +14,34 @@ /// condition (StageContext.addPredicateBecause). /// /// +/// +/// A whole build CLI. test --help lists --quick, --configuration, --skip-tests and +/// --ci; publish --help lists --configuration and --nuget-key: +/// +/// open Partas.Build.Baked +/// +/// let projects = [ "src/MyLib/MyLib.fsproj" ] +/// +/// rootCommandOfScript { +/// command "test" { +/// Command.pipeline { +/// Stages.restore "MyLib.slnx" +/// Stages.clean [ "**/bin" ] [ "*.nupkg" ] +/// Stages.build projects +/// Stages.expecto "tests/MyLib.Tests/MyLib.Tests.fsproj" [ "--sequenced" ] +/// } +/// } +/// command "publish" { +/// Command.pipeline { +/// Stages.build projects +/// Stages.pack "bin" projects +/// Stages.nugetPush "bin/*.nupkg" +/// } +/// } +/// } +/// |> exit +/// +/// module Partas.Build.Baked.Stages open System.IO @@ -119,6 +147,14 @@ let pack (outDir: string) (projects: string list) = packWith Dotnet.configOrRele /// When reads true, the suite also takes --summary and its output is /// captured: a passing run prints nothing, and a failing one carries the whole output in its error. /// +/// +/// A suite skipped by a consumer's own --fast flag instead of --skip-tests: +/// +/// let fast = Input.option<bool> "--fast" |> InputSpec.ofInput +/// +/// Stages.expectoWith fast Dotnet.configOrRelease (InputSpec.ofInput Common.isCI) "tests/Unit/Unit.fsproj" [] +/// +/// let expectoWith (skip: InputSpec) (configuration: InputSpec) (isCI: InputSpec) (project: string) (arguments: string list) = input { let! configuration = configuration diff --git a/src/Partas.Build.Cmd/Program.fs b/src/Partas.Build.Cmd/Program.fs index 4afb4ef..3bbd2a3 100644 --- a/src/Partas.Build.Cmd/Program.fs +++ b/src/Partas.Build.Cmd/Program.fs @@ -136,6 +136,13 @@ module Cmd = /// cmd and unquoted strings, losing the exact quoting cmd exists to provide. Three /// optional flags become eight branches. This fixes that. /// + /// + /// + /// cmd $"dotnet test -c {configuration}" + /// |> Cmd.argIf ci [ "--logger"; "trx" ] + /// |> Cmd.argIf quiet [ "-v"; "q" ] + /// + /// let argIf (condition: bool) (values: string list) (cmd: Cmd) = if condition then args values cmd else cmd /// Appends arguments rendered from the given value, only when it is Some. @@ -143,6 +150,12 @@ module Cmd = /// Parallels Option patterns like iter and map, avoiding the need to lift /// Option.iter around the whole command line. /// + /// + /// + /// cmd $"dotnet build" + /// |> Cmd.argWhenSome framework (fun tfm -> [ "--framework"; tfm ]) + /// + /// let argWhenSome (value: 'a option) (render: 'a -> string list) (cmd: Cmd) = match value with | Some value -> args (render value) cmd @@ -292,4 +305,10 @@ module CmdHelpers = /// cmd has no such competition. runSensitive has none either, which is why it takes the /// interpolated string directly. /// + /// + /// + /// let project = "src/My Lib/MyLib.fsproj" + /// let build = cmd $"dotnet build {project} -c Release" // dotnet, build, src/My Lib/MyLib.fsproj, -c, Release + /// + /// let inline cmd (command: FormattableString) = Cmd.ofFormattable false command diff --git a/src/Partas.Build/Builders/Command.fs b/src/Partas.Build/Builders/Command.fs index af8a0ab..f34b30a 100644 --- a/src/Partas.Build/Builders/Command.fs +++ b/src/Partas.Build/Builders/Command.fs @@ -680,6 +680,15 @@ type RootCommandDefinition /// calling thread cancels the run as would, then raises /// from Invoke. /// + /// + /// Everything the run prints, the JSON run result last, collected in a writer: + /// + /// use cts = new CancellationTokenSource(TimeSpan.FromMinutes 10.) + /// let log = new StringWriter() + /// let result = root.Invoke([ "test"; "--json" ], output = log, cancellationToken = cts.Token) + /// let json = log.ToString().TrimEnd().Split('\n') |> Array.last // = RunResult.toJson false result + /// + /// member _.Invoke(args: string seq, ?output: TextWriter, ?error: TextWriter, ?cancellationToken: CancellationToken): RunResult = let args = Array.ofSeq args let cts = CancellationTokenSource.CreateLinkedTokenSource(defaultArg cancellationToken CancellationToken.None) @@ -798,15 +807,74 @@ module Command = /// Builds a root command without parsing or running anything: rootCommand's operations, returning a /// RootCommandDefinition for Command.invoke. /// + /// + /// A definition bound once, and run from a script's entry point or from a long-lived session: + /// + /// let root = Command.root { + /// description "The repository's build" + /// command "build" { build } + /// command "test" { build; test } + /// } + /// + /// exit (Command.invoke (Args.script ()) root).ExitCode + /// + /// let root = RootCommandDefinitionBuilder() /// /// Parses against , runs what they select, and returns the /// structured result. RootCommandDefinition.Invoke takes an output writer and a cancellation token. /// + /// + /// + /// let result = Command.invoke [ "test"; "--quick" ] root + /// + /// match result.Outcome with + /// | RunOutcome.Succeeded -> printfn "%d stages" result.Timings.Length + /// | RunOutcome.UsageError -> printfn "bad arguments" + /// | RunOutcome.Failed + /// | RunOutcome.Cancelled -> + /// for failure in result.Failures do + /// printfn "%s" (FailureCause.describe failure.Cause) + /// + /// let invoke (args: string seq) (root: RootCommandDefinition) : RunResult = root.Invoke args +/// Builds a named subcommand from the stages and pipelines it runs. +/// +/// The command's options are the inputs its stages declare, plus --help, --explain, --json +/// and --schema, and --report when it runs pipelines. Stages yielded straight into it form one +/// implicit pipeline named after the command. +/// +/// +/// +/// command "test" { +/// description "Builds and runs the tests" +/// timeout 1800 +/// stage "build" { run "dotnet build" } +/// stage "test" { run "dotnet test --no-build" } +/// } +/// +/// let inline command name = CommandBuilder name + +/// Builds the root command, parses against it, runs what they select, and +/// returns the exit code. +/// +/// It runs as it is constructed. Command.root builds the same command without running it, for a caller +/// that invokes it repeatedly or reads the whole RunResult. +/// +/// +/// +/// [<EntryPoint>] +/// let main argv = +/// rootCommand argv { +/// description "The repository's build" +/// command "build" { build } +/// command "test" { build; test } +/// } +/// +/// let inline rootCommand (args: string array) = RootCommandBuilder args /// The root command over the running script's own arguments. @@ -814,4 +882,14 @@ let inline rootCommand (args: string array) = RootCommandBuilder args /// rootCommandOfScript { … } is rootCommand (Args.script ()) { … }, with the arguments read as the /// command runs rather than when the module initialises. /// +/// +/// The last expression of a build.fsx run as dotnet fsi build.fsx -- test --quick: +/// +/// rootCommandOfScript { +/// command "build" { build } +/// command "test" { build; test } +/// } +/// |> exit +/// +/// let rootCommandOfScript = RootCommandBuilder Args.script diff --git a/src/Partas.Build/Builders/Conditions.fs b/src/Partas.Build/Builders/Conditions.fs index 95b7b7b..246b644 100644 --- a/src/Partas.Build/Builders/Conditions.fs +++ b/src/Partas.Build/Builders/Conditions.fs @@ -553,6 +553,22 @@ module ValueConditions = /// The absent case is an empty list, not an inactive stage requiring a name. /// /// + /// + /// The push stage exists only when a key was given, and closes over the key itself: + /// + /// let apiKey = Input.optionMaybe<string> "--api-key" + /// + /// let publish = input { + /// let! key = apiKey + /// return pipeline "publish" { + /// stage "pack" { run "dotnet pack -o bin" } + /// whenSome key (fun key -> stage "push" { + /// run (cmd $"dotnet nuget push bin/*.nupkg" |> Cmd.secretOption "--api-key" key) + /// }) + /// } + /// } + /// + /// let whenSome (value: 'a option) (build: 'a -> StageContext): StageContext list = match value with | Some value -> [ build value ] diff --git a/src/Partas.Build/Builders/Inputs.fs b/src/Partas.Build/Builders/Inputs.fs index 1f3f081..78cbed5 100644 --- a/src/Partas.Build/Builders/Inputs.fs +++ b/src/Partas.Build/Builders/Inputs.fs @@ -58,6 +58,27 @@ type InputsBuilder() = [] member inline _.ReturnFrom(spec: InputSpec<'T>): InputSpec<'T> = spec +/// Binds CLI inputs to a value — usually a stage or a pipeline — whose inputs a command registers. +/// +/// Every source is bound in one let!/and! group. The result is an InputSpec: yielded into a +/// stage, pipeline or command, its options appear in that command's --help. +/// +/// +/// +/// module Options = +/// let configuration = Input.option<string> "--configuration" |> Input.alias "-c" |> Input.def "Release" +/// let quick = Input.option<bool> "--quick" |> Input.alias "-q" +/// +/// let build = input { +/// let! configuration = Options.configuration +/// and! quick = Options.quick +/// return stage "build" { +/// when' (not quick) "--quick is set" +/// run (cmd $"dotnet build -c {configuration}") +/// } +/// } +/// +/// let input = InputsBuilder() [] diff --git a/src/Partas.Build/Builders/Pipeline.fs b/src/Partas.Build/Builders/Pipeline.fs index 975fb6e..00bb222 100644 --- a/src/Partas.Build/Builders/Pipeline.fs +++ b/src/Partas.Build/Builders/Pipeline.fs @@ -143,4 +143,20 @@ type PipelineBuilder(name: string) = /// let internal pipelineOfStages (stages: StageContext seq): PipelineContext = finish null (addStages stages) +/// Builds a named pipeline: stages run in order, under the settings the pipeline gives them. +/// +/// Run it through a command, which registers the CLI inputs its stages declare, or directly with +/// PipelineContext.run when it declares none. +/// +/// +/// +/// pipeline "ci" { +/// workingDir __SOURCE_DIRECTORY__ +/// timeout 600 +/// stage "restore" { run "dotnet restore" } +/// stage "build" { run "dotnet build --no-restore" } +/// post [ stage "report" { echo "done" } ] +/// } +/// +/// let inline pipeline name = PipelineBuilder(name) diff --git a/src/Partas.Build/Builders/Stage.fs b/src/Partas.Build/Builders/Stage.fs index 49e7b43..f4c3f3a 100644 --- a/src/Partas.Build/Builders/Stage.fs +++ b/src/Partas.Build/Builders/Stage.fs @@ -200,4 +200,20 @@ type StageBuilder(name: string) = (spec: InputSpec, buildStep: StageContext -> BuildStep): InputSpec = InputSpec.map (fun (build: BuildStage) -> this.run(build, buildStep)) spec +/// Builds a named stage: settings, conditions, steps and nested stages, run in the order written. +/// +/// The result is a StageContext, or an InputSpec<StageContext> when a nested stage declares +/// CLI inputs. Either is yielded into a pipeline, a command or another stage. +/// +/// +/// +/// stage "build" { +/// workingDir "src" +/// whenBranch "main" +/// run "dotnet restore" +/// run (cmd $"dotnet build -c {configuration}") +/// stage "docs" { run "dotnet run --project docs" } +/// } +/// +/// let inline stage name = StageBuilder(name) diff --git a/src/Partas.Build/Builders/StageSettings.fs b/src/Partas.Build/Builders/StageSettings.fs index 3198641..a5aa3bc 100644 --- a/src/Partas.Build/Builders/StageSettings.fs +++ b/src/Partas.Build/Builders/StageSettings.fs @@ -319,9 +319,21 @@ type StageSettingsBuilder() = /// Adds a step that runs a whole command line. /// /// The line is split on whitespace, honouring " and ': convenient, but lossy for anything with - /// awkward quoting. Interpolate instead — run $"dotnet build {project}" — and each hole becomes exactly - /// one argument, whatever it contains. + /// awkward quoting. An interpolated string binds to this overload too, so its holes are flattened into the line + /// and split with it. Wrap it in cmd — run (cmd $"dotnet build {project}") — and each hole becomes + /// exactly one argument, whatever it contains. /// + /// + /// + /// let project = "src/My Lib/MyLib.fsproj" + /// + /// stage "build" { + /// run "dotnet --info" // dotnet, --info + /// run $"dotnet build {project}" // dotnet, build, src/My, Lib/MyLib.fsproj + /// run (cmd $"dotnet build {project}") // dotnet, build, src/My Lib/MyLib.fsproj + /// } + /// + /// [] member inline _.run(state: ^State, command: string, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -332,6 +344,17 @@ type StageSettingsBuilder() = /// Adds a step that runs a prepared command. /// Pair with cmd to keep interpolation holes intact: run (cmd $"dotnet build {project}"). + /// + /// A flag added only on CI, without duplicating the command line: + /// + /// stage "test" { + /// run ( + /// cmd $"dotnet test -c {configuration}" + /// |> Cmd.argIf ci [ "--logger"; "trx" ] + /// ) + /// } + /// + /// [] member inline _.run(state: ^State, command: Cmd, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -349,6 +372,14 @@ type StageSettingsBuilder() = /// F# applies it only while one overload is in play, so a mirrored pair would reject runSensitive $"...". /// /// + /// + /// + /// stage "push" { + /// // Runs with the key; the log, --explain and the JSON run result show "--api-key ***". + /// runSensitive $"dotnet nuget push bin/*.nupkg --api-key {apiKey}" + /// } + /// + /// [] member inline _.runSensitive(state: ^State, command: FormattableString, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -389,6 +420,13 @@ type StageSettingsBuilder() = /// Adds a step that runs a prepared command derived from the stage context. /// Use this overload when the command is built dynamically. Pair with cmd to keep interpolation holes as single arguments. + /// + /// + /// stage "pack" { + /// run (fun ctx -> cmd $"dotnet pack -o {ctx.Name}-out") + /// } + /// + /// [] member inline _.run(state: ^State, buildCmd: StageContext -> Cmd, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -487,6 +525,14 @@ type StageSettingsBuilder() = /// Adds a step that runs the command line derived from the stage context. /// The command line string is split on whitespace, honouring quotes. Use run (cmd $"...") to preserve interpolation holes as single arguments. + /// + /// The string runs as a command; to print a message, use echo. + /// + /// stage "restore" { + /// runLine (fun ctx -> $"dotnet restore {ctx.Name}.slnx") + /// } + /// + /// [] member inline _.runLine(state: ^State, step: StageContext -> string, ?cancellationToken: CancellationToken): ^State = StageMap.mapStage (fun ctx -> @@ -540,6 +586,14 @@ type StageSettingsBuilder() = { ctx with Steps = ctx.Steps @ [ Step.StepFn(ValueNone, CmdRunner.stepOption buildCmd cancellationToken) ] }) state /// Adds a step with flexible signature support. /// + /// + /// + /// stage "check" { + /// run (fun ctx -> if System.IO.File.Exists "global.json" then 0 else 1) + /// run (fun ctx -> async { do! Async.Sleep 100 }) + /// } + /// + /// [] member inline _.run(state: ^State, step): ^State = StageMap.mapStage (fun ctx -> diff --git a/src/Partas.Build/MachineOutput.fs b/src/Partas.Build/MachineOutput.fs index f4443bb..c58482a 100644 --- a/src/Partas.Build/MachineOutput.fs +++ b/src/Partas.Build/MachineOutput.fs @@ -226,6 +226,18 @@ module MachineOutput = writer.WriteEndObject()) /// The --json flag. + /// + /// Every command takes it. With --explain, the tree is printed as a JSON document and no condition with + /// a side effect is evaluated; on a run, the run result is printed as the last line of output, one line of + /// compact JSON, in place of the timing table. + /// + /// + /// + /// dotnet fsi build.fsx -- test --explain --json # the stage tree, statically + /// dotnet fsi build.fsx -- test --json | tail -n 1 # the run result + /// dotnet fsi build.fsx -- test --schema # the command, its options and subcommands + /// + /// let json: ActionInput = Input.option "--json" |> Input.description "Write JSON instead of text: the --explain tree, or the run result as the last line of output" diff --git a/src/Partas.Build/Partas.Build.fsproj b/src/Partas.Build/Partas.Build.fsproj index 33bdf62..70d6e8b 100644 --- a/src/Partas.Build/Partas.Build.fsproj +++ b/src/Partas.Build/Partas.Build.fsproj @@ -45,6 +45,8 @@ + + - 0.7.0 + 0.8.0 0.0.0.0