packages feed

keiro-dsl (empty) → 0.2.0.0

raw patch · 165 files changed

+19113/−0 lines, 165 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, containers, directory, effectful-core, filepath, hasql-transaction, hspec, keiki, keiro, keiro-dsl, keiro-pgmq, kiroku-store, megaparsec, optparse-applicative, parser-combinators, pgmq-config, pgmq-core, prettyprinter, process, shibuya-core, text, time, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,179 @@+# Changelog++All notable changes to `keiro-dsl` are recorded here. The format follows+[Keep a Changelog](https://keepachangelog.com/), and the package follows the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [Unreleased]++_No unreleased changes._++## 0.2.0.0 — 2026-07-13++### Breaking Changes++- The process `saga` clause is now `saga <Aggregate> category "<camelCase>"`,+  replacing `saga <Aggregate> stream="<prefix>-" <> correlationId`. Categories are+  validated (`SagaCategoryIllegal`) against the same rules as+  `Keiro.Stream.category`: non-empty, not `$all`, no `-` (Kiroku's category/id+  boundary), no whitespace or control characters, and no `:` (reserved for the+  `wf:<name>` workflow stream family). Generated process and router fills now+  build saga streams with `entityStream` and a typed category constant instead of+  splicing a string prefix.+- `process` nodes must now declare node-level `rejected => <policy>` and+  `poison => <policy>` clauses (`halt`, `deadLetter`, or `skip`), and every timer+  `fire` disposition must carry an `on-ambiguous` arm alongside `on-ok`,+  `on-reject`, `on-error`, and `not-mine`. Mapping `on-ambiguous => Fired` is+  rejected (`AmbiguousMarkedBenign`): `CommandAmbiguous` means several aggregate+  edges matched, and is never a benign success.+- Identifier lexemes are restricted to ASCII, and the validator now enforces+  per-category Haskell hygiene: constructor-position names must be+  constructor-safe (`IdentNotConstructorSafe`), no identifier may be a Haskell+  keyword (`IdentHaskellKeyword`), and generated vertex constructors may not+  collide (`VertexCtorCollision`). Specs that previously scaffolded to+  uncompilable Haskell are now rejected at `check`.+- All numeric literal sites parse through `Integer` and fail with a positioned+  diagnostic when the value exceeds `maxBound :: Int`, instead of silently+  wrapping. `maxBound` itself still parses exactly.+- Duplicate singleton blocks and duplicate `goto` clauses are reported at their+  second occurrence rather than being silently accepted with a last-one-wins+  reading; a missing `goto` is now anchored to its transition.+- `Text` registers require a quoted initial, and a register whose type is an enum+  or the aggregate's vertex type must start at a declared constructor or state.+  The scaffolder refuses the run rather than emitting a broken initial.+- Validation is substantially stricter, so specs that checked under 0.1.0.0 may+  now be rejected: duplicate node, command, event, enum-constructor, enum-wire and+  id-prefix names; dangling aggregate, projection, timer, workflow, signal and+  operation references; non-total or unresolved `rule` domains; duplicate workflow+  replay labels; incomplete or shadowed disposition tables; duplicate and dangling+  status-map keys; emit/intake topic-affinity mismatch; workqueue+  `queueRef`/table/DLQ divergence; unresolved dispatch dedup queues and fields;+  invalid process timer ceilings; and write targets that are not registers.+- `keiro-dsl scaffold` now plans the entire module set before writing any byte,+  and refuses the run on module-path collisions, self-firewall breaches, or+  unlowerable spec content. It also refuses to overwrite a file on a `Generated`+  path that lacks the `@generated` banner; pass the new+  `--force-generated-overwrite` flag to override.+- `keiro-dsl diff` gained a `WARNING:` tier, and its change lines now read+  `<node> <facet> <subject>: <detail>` rather than always saying `event`. Only+  `BREAKING:` changes exit non-zero.++### New Features++- Added a first-class `readmodel` node declaring `table`, `schema`, a typed+  `columns` block, `version`, captured `shape`, `consistency`, `scope`, `feed`+  (`inline` or `subscription`), and `subscription`. The validator owns a closed+  column-type vocabulary (`text`, `int`, `bigint`, `bool`, `timestamptz`, `jsonb`,+  `numeric`), detects shape-hash drift against the declared columns, rejects+  `Strong` + `inline` (no subscription worker advances the cursor a strong read+  waits on), rejects `scope` without `Strong`, and rejects an `inline` model that+  no aggregate projection feeds. `scaffold` emits `ReadModel` and `ReadModelTable`+  generated modules plus `ReadModelHoles`. Aggregate `projection` consistency is+  now optional and must agree with the read-model node when one exists; a+  projection with no `readmodel` node warns that registration, schema identity,+  and rebuild helpers are unavailable.+- Query operations and PGMQ dispatch source/dedup read-model references now+  actually resolve against declared nodes — these were explicitly deferred no-ops+  in 0.1.0.0. Query `consistency` must be `Strong`, `Eventual`, or `PositionWait`,+  and a dispatch dedup field must be a column of the named model.+- Added the `router` node for stateless content-based routing: `input`, `key`,+  `resolve stable via read-model <name> row { ... }` (or `via hole`), `target`,+  `projections`, `dispatch-each`, a runtime-owned `dispatch-id` strategy keyed on+  target stream name and occurrence, and node-level `rejected`/`poison` policies.+  Validation resolves the target aggregate, its command and command fields, the+  key field, and the read-model reference, and confines dispatch bindings to the+  `input.` and `resolved.` scopes plus quoted literals. `scaffold` emits+  `Router`/`RouterHarness` generated modules with `RouterHoles`/`RouterValue`+  stubs, and `keiro-dsl new router` prints a starter.+- Added node-level `rejected` and `poison` worker policies on `process` and+  `router` nodes, reconciled against the per-dispatch `on-failed` arms: a dispatch+  declaring `DeadLetter` under a node that does not is a `PolicyContradiction`,+  divergent `on-failed` actions within one node are rejected because the runtime+  applies a single `RejectedCommandPolicy` to the whole failure group, and an+  unacknowledged `rejected => deadLetter` warns.+- Added aggregate `snapshot every <n>` / `snapshot on-terminal` with a captured+  `state-codec version=<n> shape-hash="..."` fixture, lowered into the generated+  aggregate modules and pinned against the live runtime. Intervals below 1, and+  empty or zero-version codec fixtures, are rejected.+- Added workqueue `ordering` (`unordered`, `fifo-throughput`, `fifo-round-robin`),+  `group key from <field> via <fn>`, and provisioning (standard, `unlogged`,+  partitioned). The validator rejects FIFO without a group key, a group key+  without FIFO, and an empty partition spec, and flags unlogged durability; the+  generated `QueuePolicy` is pinned to the live pgmq configuration types.+- Added intake `persist = full-envelope | dedupe-only`, lowered to the live+  `InboxPersistence` value and wired through `runInboxTransactionWith`.+- Added a durable-workflow evolution surface: guarded `patch <id> { ... }` blocks+  and a terminal `continueAsNew <SeedType>`, lowered into the workflow run+  options. Duplicate and malformed patch ids, and a non-terminal `continueAsNew`,+  are rejected.+- Added a `partial` token on `status-map`, so an intentionally incomplete+  event-to-status mapping is expressible instead of failing the totality rule.+- Publisher backoff accepts optional `max=` and `multiplier=`, and exponential+  backoff now lowers to `ExponentialBackoff ExponentialBackoffOptions{..}` with+  faithful duration units.+- Rebuilt `diff` on an exhaustive node-family registry: every `Node` constructor+  either has a differ or carries a recorded out-of-scope rationale, so a new node+  kind can no longer be silently treated as safe. Classification now covers+  aggregate decode evolution through command indirection (field type, removal,+  wire spelling, enum add/drop, schema-version regression, old-anchored upcaster+  continuity, undeprecation), contract topic/schema-version/discriminator/field/+  event changes, workqueue payload, identity, ordering and provisioning changes,+  process input and timer-window changes, intake decode posture, dedupe identity+  and persistence, emit mapping and ordering, publisher policy, workflow shape,+  body, patch and continue-as-new seed changes, read-model+  version/shape/feed/consistency evolution, projection and id-prefix re-keying,+  router stable-name changes, and dispatch retargeting.+- `scaffold` now writes a versioned per-context record+  (`keiro-dsl-scaffold-record.<context>.txt`) and reports still-present modules+  made stale by node, layout, or `--module-root` changes. It never deletes+  generated or hand-owned files.+- Diagnostics carry row-level source locations, so validator-owned rows+  (dispositions, status maps, timers, dispatches) are anchored precisely instead+  of at the enclosing node.++### Bug Fixes++- String literals now decode and re-render the closed DSL escape set, so topics,+  emit maps, and quoted field bindings survive a parse/pretty-print round trip+  instead of being corrupted.+- The scaffolder escapes payload literal splices, closing a template-injection+  path where a quoted spec literal could break out of the generated Haskell+  string. Its status-map and harness lowering is now total.+- Generated `Stream` and stream-category imports are emitted in the+  repository-standard post-qualified (`ImportQualifiedPost`) form.+- The self-firewall is derived from Keiki's exported surface as a single+  token-aware scan, rather than a hand-maintained substring list that both missed+  operators and produced false positives.++### Other Changes++- Added conformance suites that round-trip every node family, compile every+  `keiro-dsl new <kind>` starter, cold-start the new read-model, router, snapshot,+  queue-ordering, and workflow-rotation surfaces, and exercise the generated+  read-model and router modules against the live runtime.+- Test fixtures and conformance corpora resolve from either the package root or+  the repository root.++## 0.1.0.0 — 2026-07-05++Initial Hackage release.++### Breaking Changes++- Renamed the typed-spec file extension from `.kdsl` to `.keiro` before the first+  public release.++### New Features++- Added grammar, parser, pretty-printer, validator, diff engine, scaffold+  generator, harness emitter, and CLI for typed `.keiro` service specs.+- Added aggregate, process manager, durable timer, integration contract, inbox,+  publisher, PGMQ workqueue, workflow, and operation nodes.+- Added configurable module placement, build-wiring manifests, self-firewall+  checks, post-scaffold reports, per-iteration ergonomics, and `new <kind>`+  starter skeletons.+- Generated validated event streams compatible with Keiro's command boundaries.++### Bug Fixes++- Tolerated formatter comma style in scaffold conformance tests.
+ app/Main.hs view
@@ -0,0 +1,190 @@+{- | The @keiro-dsl@ command-line tool. EP-1 ships the @parse@ and @check@+subcommands; a later milestone adds @scaffold@ to the same+optparse-applicative command tree.+-}+module Main (main) where++import Control.Monad (when)+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Keiro.Dsl.Diff (Change (..), ChangeKind (..), diffSpecs, isBreaking)+import Keiro.Dsl.Grammar (Placement (..), Spec (..))+import Keiro.Dsl.Parser (parseSpec)+import Keiro.Dsl.PrettyPrint (renderSpec)+import Keiro.Dsl.Scaffold (Context (..))+import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffold, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.Skeleton (skeletonFor)+import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec)+import Options.Applicative+import System.Directory (canonicalizePath)+import System.Exit (ExitCode (..), exitFailure)+import System.FilePath (makeRelative, takeDirectory)+import System.IO (hPutStrLn, stderr)+import System.Process (readProcessWithExitCode)++data Command+    = Parse FilePath+    | Check FilePath Bool+    | Scaffold FilePath FilePath (Maybe String) Bool Bool+    | Diff FilePath String+    | New String++main :: IO ()+main = run =<< execParser opts+  where+    opts =+        info+            (commands <**> helper)+            (fullDesc <> progDesc "keiro-dsl: a typed-specification toolchain for keiro services")++commands :: Parser Command+commands =+    subparser+        ( command+            "parse"+            (info (Parse <$> fileArg <**> helper) (progDesc "Parse a .keiro file and pretty-print it back"))+            <> command+                "check"+                (info (Check <$> fileArg <*> emitSwitch <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error"))+            <> command+                "scaffold"+                (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))+            <> command+                "diff"+                (info (Diff <$> fileArg <*> sinceOpt <**> helper) (progDesc "Classify spec changes since a git ref as ADDITIVE/WARNING/BREAKING over the decode and identity surface; exit non-zero on any BREAKING change"))+            <> command+                "new"+                (info (New <$> kindArg <**> helper) (progDesc "Print a minimal valid .keiro skeleton for a node kind (aggregate, process, router, contract, intake, emit, publisher, workqueue, dispatch, workflow, operation)"))+        )++outOpt :: Parser FilePath+outOpt = strOption (long "out" <> metavar "DIR" <> help "Output directory for the scaffolded modules")++moduleRootOpt :: Parser String+moduleRootOpt = strOption (long "module-root" <> metavar "PREFIX" <> help "Namespace prefix for emitted modules, e.g. Acme or Acme.Services (overrides the spec's module clause)")++collocateSwitch :: Parser Bool+collocateSwitch = switch (long "collocate" <> help "Place the generated layer as a leaf under the domain (<Ctx>.<Node>.Generated) instead of a parallel Generated.* tree")++forceGeneratedOverwriteSwitch :: Parser Bool+forceGeneratedOverwriteSwitch = switch (long "force-generated-overwrite" <> help "Overwrite a Generated path even when the existing file lacks the @generated banner")++emitSwitch :: Parser Bool+emitSwitch = switch (long "emit" <> help "On success, pretty-print the parsed spec to stdout (folds parse + check into one call)")++sinceOpt :: Parser String+sinceOpt = strOption (long "since" <> metavar "GIT-REF" <> help "Git ref to diff the spec against (e.g. HEAD, a tag, a branch)")++fileArg :: Parser FilePath+fileArg = argument str (metavar "FILE" <> help "Path to a .keiro spec (use /dev/stdin for stdin)")++kindArg :: Parser String+kindArg = argument str (metavar "KIND" <> help "Node kind to scaffold a starter spec for")++run :: Command -> IO ()+run (Parse fp) = do+    input <- TIO.readFile fp+    case parseSpec fp input of+        Left err -> do+            hPutStrLn stderr (T.unpack err)+            exitFailure+        Right spec -> TIO.putStrLn (renderSpec spec)+run (Check fp emit) = do+    input <- TIO.readFile fp+    case parseSpec fp input of+        Left err -> do+            hPutStrLn stderr (T.unpack err)+            exitFailure+        Right spec -> do+            let diags = validateSpec spec+            mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags+            if any ((== Error) . severity) diags+                then exitFailure+                else+                    if emit+                        then TIO.putStrLn (renderSpec spec)+                        else putStrLn "OK"+run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite) = do+    input <- TIO.readFile fp+    case parseSpec fp input of+        Left err -> do+            hPutStrLn stderr (T.unpack err)+            exitFailure+        Right spec -> do+            -- Validation gate: never scaffold an invalid spec. Abort on any+            -- error-severity diagnostic before writing a single module.+            let diags = validateSpec spec+            mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags+            when (any ((== Error) . severity) diags) exitFailure+            let ctx = mkContext cliRoot cliCollocate spec+            case planScaffold ctx spec of+                Left refusals -> do+                    mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)+                    exitFailure+                Right modules -> do+                    result <- executeScaffold out forceGeneratedOverwrite fp ctx spec modules+                    case result of+                        Left refusals -> do+                            mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)+                            exitFailure+                        Right report -> mapM_ (TIO.hPutStrLn stderr) (renderScaffoldReport report)+run (New kind) =+    case skeletonFor (T.pack kind) of+        Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure+        Right skel -> TIO.putStr skel+run (Diff fp ref) = do+    -- Resolve the spec to a repo-relative path so `git show <ref>:<relpath>` works.+    let dir = takeDirectory fp+    rootRes <- git dir ["rev-parse", "--show-toplevel"]+    case rootRes of+        Left err -> hPutStrLn stderr err >> exitFailure+        Right rootRaw -> do+            let repoRoot = trim rootRaw+            absFp <- canonicalizePath fp+            let relPath = makeRelative repoRoot absFp+            oldRes <- git repoRoot ["show", ref <> ":" <> relPath]+            case oldRes of+                Left err -> hPutStrLn stderr ("git show " <> ref <> ":" <> relPath <> " failed:\n" <> err) >> exitFailure+                Right oldText -> do+                    newText <- TIO.readFile fp+                    case (,) <$> parseSpec (ref <> ":" <> relPath) (T.pack oldText) <*> parseSpec fp newText of+                        Left perr -> hPutStrLn stderr (T.unpack perr) >> exitFailure+                        Right (oldSpec, newSpec) -> do+                            let changes = diffSpecs oldSpec newSpec+                            mapM_ (putStrLn . renderChange) changes+                            if any isBreaking changes then exitFailure else pure ()++renderChange :: Change -> String+renderChange c = case c of+    Additive k -> "ADDITIVE: " <> body k+    Advisory k -> "WARNING: " <> body k <> codeSuffix k+    Breaking k -> "BREAKING: " <> body k <> codeSuffix k+  where+    body k = T.unpack (ckNode k) <> " " <> T.unpack (ckFacet k) <> " " <> T.unpack (ckSubject k) <> ": " <> T.unpack (ckDetail k)+    codeSuffix k = maybe "" (\dc -> " [" <> show dc <> "]") (ckCode k)++-- | Run git in a directory, returning trimmed stdout or stderr.+git :: FilePath -> [String] -> IO (Either String String)+git dir args = do+    (ec, out, err) <- readProcessWithExitCode "git" (["-C", dir] <> args) ""+    pure $ case ec of+        ExitSuccess -> Right out+        ExitFailure _ -> Left (if null err then out else err)++trim :: String -> String+trim = f . f where f = reverse . dropWhile (`elem` (" \t\r\n" :: String))++{- | Fold the spec's @module@/@layout@ clauses with the CLI overrides to a+'Context'. Precedence is CLI flag > spec clause > built-in default.+-}+mkContext :: Maybe String -> Bool -> Spec -> Context+mkContext cliRoot cliCollocate spec =+    Context+        { contextName = specContext spec+        , moduleRoot = maybe (fromMaybe "" (specModuleRoot spec)) T.pack cliRoot+        , placement =+            if cliCollocate+                then CollocatedLeaf+                else fromMaybe GeneratedPrefix (specLayout spec)+        }
+ keiro-dsl.cabal view
@@ -0,0 +1,583 @@+cabal-version:   3.0+name:            keiro-dsl+version:         0.2.0.0+synopsis:        Typed specification toolchain for keiro services+description:+  keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro+  service: a parser + checker + scaffolder + harness emitter. It emits the+  symbol-free deterministic layer plus typed holes, never a keiki symbolic+  operator (the firewall invariant).++license:         BSD-3-Clause+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+copyright:       2026 Nadeem Bitar+category:        Development+build-type:      Simple+tested-with:     GHC >=9.12 && <9.13+extra-doc-files: CHANGELOG.md++common warnings+  ghc-options: -Wall++common shared+  default-language:   GHC2024+  default-extensions:+    LambdaCase+    OverloadedStrings++library+  import:          warnings, shared+  hs-source-dirs:  src+  exposed-modules:+    Keiro.Dsl.Diff+    Keiro.Dsl.Grammar+    Keiro.Dsl.Harness+    Keiro.Dsl.Manifest+    Keiro.Dsl.Parser+    Keiro.Dsl.PrettyPrint+    Keiro.Dsl.ReadModelShape+    Keiro.Dsl.Scaffold+    Keiro.Dsl.ScaffoldRecord+    Keiro.Dsl.ScaffoldRun+    Keiro.Dsl.Skeleton+    Keiro.Dsl.Validate++  build-depends:+    , base                >=4.21 && <5+    , containers          >=0.6+    , directory           >=1.3+    , filepath            >=1.4+    , megaparsec          >=9.6+    , parser-combinators  >=1.3+    , prettyprinter       >=1.7+    , text                >=2.1++executable keiro-dsl+  import:         warnings, shared+  hs-source-dirs: app+  main-is:        Main.hs+  build-depends:+    , base                  >=4.21 && <5+    , directory             >=1.3+    , filepath              >=1.4+    , keiro-dsl+    , optparse-applicative  >=0.18+    , process               >=1.6+    , text                  >=2.1++test-suite keiro-dsl-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  build-depends:+    , base        >=4.21 && <5+    , containers  >=0.6+    , directory   >=1.3+    , filepath    >=1.4+    , hspec       >=2.11+    , keiro-dsl+    , QuickCheck  >=2.14+    , text        >=2.1++-- Conformance: proves the scaffolded Generated modules plus a hand-filled+-- Holes.hs compile against keiki/keiro and that the filled transducer passes+-- keiki's validator and the codec round-trips. The Generated.* modules under+-- test/conformance/ are byte-identical to `keiro-dsl scaffold` output (pinned+-- by the scaffold-conformance test in keiro-dsl-test).+test-suite keiro-dsl-conformance+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.Reservation.Codec+    Generated.HospitalCapacity.Reservation.Domain+    Generated.HospitalCapacity.Reservation.EventStream+    Generated.HospitalCapacity.Reservation.Harness+    Generated.HospitalCapacity.Reservation.Projection+    HospitalCapacity.Reservation.Holes++  build-depends:+    , aeson  >=2.2+    , base   >=4.21 && <5+    , keiki  >=0.2  && <0.3+    , keiro+    , text   >=2.1++-- EP-109 M2: snapshot-enabled aggregate scaffolding compiled against the live+-- defaultStateCodec and stream-construction guards, with the captured codec+-- identity checked against keiki's regFileShapeHash.+test-suite keiro-dsl-conformance-snapshot+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-snapshot+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.Reservation.Codec+    Generated.HospitalCapacity.Reservation.Domain+    Generated.HospitalCapacity.Reservation.EventStream+    HospitalCapacity.Reservation.Holes++  build-depends:+    , aeson  >=2.2+    , base   >=4.21 && <5+    , keiki  >=0.2  && <0.3+    , keiro+    , text   >=2.1++-- EP-106 M6: every distinct `new <kind>` skeleton is scaffolded into this+-- committed tree. Compiling the union proves a starter that passes `check`+-- cannot emit syntactically or type-invalid Haskell.+test-suite keiro-dsl-conformance-skeletons+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-skeletons+  main-is:        Main.hs+  other-modules:+    SkelAggregate.Generated.MyService.Thing.Codec+    SkelAggregate.Generated.MyService.Thing.Domain+    SkelAggregate.Generated.MyService.Thing.EventStream+    SkelAggregate.Generated.MyService.Thing.Harness+    SkelAggregate.Generated.MyService.Thing.Projection+    SkelAggregate.MyService.Thing.Holes+    SkelContract.Generated.MyService.MyContract.Contract+    SkelEmit.Generated.MyService.MyContract.Contract+    SkelEmit.Generated.MyService.ThingPublisher.Publisher+    SkelIntake.Generated.MyService.MyContract.Contract+    SkelIntake.Generated.MyService.ThingInbox.Inbox+    SkelProcess.Generated.MyService.Hospital.Codec+    SkelProcess.Generated.MyService.Hospital.Domain+    SkelProcess.Generated.MyService.Hospital.EventStream+    SkelProcess.Generated.MyService.Hospital.Harness+    SkelProcess.Generated.MyService.Hospital.Projection+    SkelProcess.Generated.MyService.HospitalSurge.Process+    SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness+    SkelProcess.Generated.MyService.Surge.Codec+    SkelProcess.Generated.MyService.Surge.Domain+    SkelProcess.Generated.MyService.Surge.EventStream+    SkelProcess.Generated.MyService.Surge.Harness+    SkelProcess.Generated.MyService.Surge.Projection+    SkelProcess.MyService.Hospital.Holes+    SkelProcess.MyService.HospitalSurge.ProcessHoles+    SkelProcess.MyService.Surge.Holes+    SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModel+    SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelHarness+    SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable+    SkelQueue.Generated.MyService.Reservation_work.Queue+    SkelQueue.Generated.MyService.Reservation_work.QueuePolicy+    SkelQueue.Generated.MyService.Transfer_decisions.ReadModel+    SkelQueue.Generated.MyService.Transfer_decisions.ReadModelHarness+    SkelQueue.Generated.MyService.Transfer_decisions.ReadModelTable+    SkelQueue.MyService.Accepted_transfer_needs.ReadModelHoles+    SkelQueue.MyService.Transfer_decisions.ReadModelHoles+    SkelRouter.Generated.MyService.Page.Codec+    SkelRouter.Generated.MyService.Page.Domain+    SkelRouter.Generated.MyService.Page.EventStream+    SkelRouter.Generated.MyService.Page.Harness+    SkelRouter.Generated.MyService.Page.Projection+    SkelRouter.Generated.MyService.PagingRouter.Router+    SkelRouter.Generated.MyService.PagingRouter.RouterHarness+    SkelRouter.MyService.Page.Holes+    SkelRouter.MyService.PagingRouter.RouterHoles+    SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowFacts+    SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowRuntime++  build-depends:+    , aeson              >=2.2+    , base               >=4.21 && <5+    , containers+    , effectful-core+    , hasql-transaction+    , keiki              >=0.2  && <0.3+    , keiro+    , keiro-pgmq+    , kiroku-store+    , shibuya-core+    , text               >=2.1+    , time+    , uuid++-- EP-7 cold-start: a fresh `subscription` aggregate authored from only the skill+-- notation, scaffolded + hand-filled, compiling against keiki/keiro with a green+-- spec-derived harness — proof the authoring loop closes on a non-corpus spec.+test-suite keiro-dsl-conformance-coldstart+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-coldstart+  main-is:        Main.hs+  other-modules:+    Billing.Subscription.Holes+    Generated.Billing.Subscription.Codec+    Generated.Billing.Subscription.Domain+    Generated.Billing.Subscription.EventStream+    Generated.Billing.Subscription.Harness+    Generated.Billing.Subscription.Projection++  build-depends:+    , aeson  >=2.2+    , base   >=4.21 && <5+    , keiki  >=0.2  && <0.3+    , keiro+    , text   >=2.1++-- Contract codec conformance (EP-4): the scaffolded self-contained contract+-- payload ADT + codec, compiled + round-tripped per event type.+test-suite keiro-dsl-conformance-contract+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-contract+  main-is:        Main.hs+  other-modules:  Generated.HospitalCapacity.Emergency.Contract+  build-depends:+    , aeson  >=2.2+    , base   >=4.21 && <5+    , text   >=2.1++-- EP-4 intake runtime conformance: the scaffolded Inbox disposition + dedupe+-- policy compiled against the LIVE Keiro.Inbox.Types (InboxResult / dedupe).+test-suite keiro-dsl-conformance-intake-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-intake-runtime+  main-is:        Main.hs+  other-modules:  Generated.HospitalCapacity.IncidentInbox.Inbox+  build-depends:+    , base   >=4.21 && <5+    , keiro++-- EP-4 M5 full-service conformance: a complete integration service — scaffolded+-- inbox dedupe + a filled inbox transaction runner and outbox IntegrationProducer+-- — compiled against the live keiro runtime (Inbox / Outbox / Kiroku.Store).+test-suite keiro-dsl-conformance-intake-full+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-intake-full+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.IncidentInbox.Inbox+    HospitalCapacity.IncidentInbox.Integration++  build-depends:+    , base               >=4.21 && <5+    , effectful-core+    , hasql-transaction+    , keiro+    , kiroku-store       >=0.3  && <0.4++-- EP-4 publisher runtime conformance: the scaffolded Publisher config compiled+-- against the LIVE Keiro.Outbox.Types (OrderingPolicy / BackoffSchedule).+test-suite keiro-dsl-conformance-publisher-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-publisher-runtime+  main-is:        Main.hs+  other-modules:  Generated.HospitalCapacity.HospitalPublisher.Publisher+  build-depends:+    , base   >=4.21 && <5+    , keiro++-- pgmq Job codec conformance (EP-5): the scaffolded self-contained Job payload+-- record + field->wire codec, compiled + round-tripped.+test-suite keiro-dsl-conformance-queue+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-queue+  main-is:        Main.hs+  other-modules:  Generated.HospitalCapacity.Reservation_work.Queue+  build-depends:+    , aeson  >=2.2+    , base   >=4.21 && <5+    , text   >=2.1++-- EP-5 pgmq runtime conformance: the scaffolded QueuePolicy (RetryPolicy ++-- JobOutcome disposition) compiled against the LIVE Keiro.PGMQ.Job runtime.+test-suite keiro-dsl-conformance-queue-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-queue-runtime+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.Reservation_work.Queue+    Generated.HospitalCapacity.Reservation_work.QueuePolicy++  build-depends:+    , aeson        >=2.2+    , base         >=4.21 && <5+    , keiro-dsl+    , keiro-pgmq+    , pgmq-config+    , pgmq-core+    , text         >=2.1++-- EP-107 read-model runtime conformance: the scaffolded ReadModel record,+-- registration/rebuild helpers, AsyncProjection, facts harness, and a filled+-- qualified-table query compiled against the live Keiro.ReadModel API.+test-suite keiro-dsl-conformance-readmodel-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-readmodel-runtime+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.Transfer_decisions.ReadModel+    Generated.HospitalCapacity.Transfer_decisions.ReadModelHarness+    Generated.HospitalCapacity.Transfer_decisions.ReadModelTable+    HospitalCapacity.Transfer_decisions.ReadModelHoles++  build-depends:+    , base               >=4.21 && <5+    , effectful-core+    , hasql-transaction+    , keiro+    , kiroku-store+    , text               >=2.1++-- EP-5 M5 full-service conformance: a complete pgmq dispatch service — scaffolded+-- Job codec + retry policy + a filled worker handler assembled into a live+-- Keiro.PGMQ.Job.Job value — compiled against keiro-pgmq.+test-suite keiro-dsl-conformance-dispatch-full+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-dispatch-full+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.Reservation_work.Queue+    Generated.HospitalCapacity.Reservation_work.QueuePolicy+    HospitalCapacity.ReservationWork.WorkqueueJob++  build-depends:+    , aeson           >=2.2+    , base            >=4.21 && <5+    , effectful-core+    , keiro-pgmq+    , text            >=2.1++-- Workflow facts harness (EP-6): the scaffolded self-contained WorkflowFacts+-- module asserted against a hand-written expectation (mutation-pinnable).+test-suite keiro-dsl-conformance-workflow+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-workflow+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.HospitalTransferReservation.WorkflowFacts++  build-depends:  base >=4.21 && <5++-- EP-6 workflow runtime conformance: the scaffolded WorkflowRuntime+-- (WorkflowName + awakeable-id derivation) compiled against the LIVE+-- Keiro.Workflow; pins the await<->signal id match over deterministicAwakeableId.+test-suite keiro-dsl-conformance-workflow-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-workflow-runtime+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime++  build-depends:+    , base        >=4.21 && <5+    , containers+    , keiro+    , text        >=2.1++-- EP-3 M5 full-service conformance: a complete process service — the scaffolded+-- Surge (saga) + Hospital (target) aggregates with filled transducers, plus a+-- filled ProcessManager handle — compiled against the live keiro/keiki runtime.+test-suite keiro-dsl-conformance-process-full+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-process-full+  main-is:        Main.hs+  other-modules:+    Generated.SurgeDemo.Hospital.Codec+    Generated.SurgeDemo.Hospital.Domain+    Generated.SurgeDemo.Hospital.EventStream+    Generated.SurgeDemo.Hospital.Projection+    Generated.SurgeDemo.Surge.Codec+    Generated.SurgeDemo.Surge.Domain+    Generated.SurgeDemo.Surge.EventStream+    Generated.SurgeDemo.Surge.Projection+    Generated.SurgeDemo.SurgeFlow.Process+    SurgeDemo.Hospital.Holes+    SurgeDemo.Surge.Holes+    SurgeDemo.SurgeFlow.Manager++  build-depends:+    , aeson         >=2.2+    , base          >=4.21 && <5+    , keiki         >=0.2  && <0.3+    , keiro+    , shibuya-core+    , text          >=2.1+    , time          >=1.12+    , uuid          >=1.3++-- EP-6 M5 full-service conformance: a complete durable workflow — scaffolded+-- WorkflowRuntime + a filled ordered step/await body — compiled against the+-- live Keiro.Workflow effect.+test-suite keiro-dsl-conformance-workflow-full+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-workflow-full+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime+    HospitalCapacity.HospitalTransferReservation.WorkflowBody++  build-depends:+    , aeson           >=2.2+    , base            >=4.21 && <5+    , containers+    , effectful-core+    , keiro+    , text            >=2.1++-- EP-3 process runtime conformance: the scaffolded Process module's+-- deterministic wiring (timer-request builder + fire disposition) compiled+-- against the LIVE keiro runtime (Keiro.Timer / Keiro.Command), not just text.+test-suite keiro-dsl-conformance-process-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-process-runtime+  main-is:        Main.hs+  other-modules:  Generated.HospitalCapacity.HospitalSurge.Process+  build-depends:+    , aeson         >=2.2+    , base          >=4.21 && <5+    , keiro+    , keiro-dsl+    , shibuya-core+    , text          >=2.1+    , time          >=1.12+    , uuid          >=1.3++-- EP-108 router runtime conformance: generated policy lowering and the live+-- target-keyed deterministic id contract.+test-suite keiro-dsl-conformance-router-runtime+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-router-runtime+  main-is:        Main.hs+  other-modules:+    Generated.IncidentPaging.PagingRouter.Router+    Generated.IncidentPaging.PagingRouter.RouterHarness++  build-depends:+    , base          >=4.21 && <5+    , keiro+    , kiroku-store+    , shibuya-core+    , text          >=2.1+    , uuid          >=1.3++-- EP-108 generated router-facts harness with hand-written expectations.+test-suite keiro-dsl-conformance-router+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-router+  main-is:        Main.hs+  other-modules:  Generated.IncidentPaging.PagingRouter.RouterHarness+  build-depends:  base >=4.21 && <5++-- EP-108 filled-router conformance: scaffolded Page aggregate plus a filled+-- resolver and Router value compiled against the live API.+test-suite keiro-dsl-conformance-router-full+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-router-full+  main-is:        Main.hs+  other-modules:+    Generated.IncidentPaging.Page.Codec+    Generated.IncidentPaging.Page.Domain+    Generated.IncidentPaging.Page.EventStream+    Generated.IncidentPaging.PagingRouter.Router+    Generated.IncidentPaging.PagingRouter.RouterHarness+    IncidentPaging.Page.Holes+    IncidentPaging.PagingRouter.RouterValue++  build-depends:+    , aeson           >=2.2+    , base            >=4.21 && <5+    , effectful-core+    , keiki           >=0.2  && <0.3+    , keiro+    , shibuya-core+    , text            >=2.1++-- MP-15/EP-110 M6 cold-start: a fresh agent, given only the authoring skill+-- and feature sentence, produced this aggregate + readmodel + router service.+-- The component compiles generated output and hand-owned fills together and+-- runs the aggregate, readmodel, router-policy, and live Router assertions.+test-suite keiro-dsl-conformance-newsurface+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-newsurface+  main-is:        Main.hs+  other-modules:+    Generated.TransferRouting.Hospital.Codec+    Generated.TransferRouting.Hospital.Domain+    Generated.TransferRouting.Hospital.EventStream+    Generated.TransferRouting.Hospital.Harness+    Generated.TransferRouting.Hospital.Projection+    Generated.TransferRouting.Hospital_load.ReadModel+    Generated.TransferRouting.Hospital_load.ReadModelHarness+    Generated.TransferRouting.Hospital_load.ReadModelTable+    Generated.TransferRouting.HospitalTransferRouter.Router+    Generated.TransferRouting.HospitalTransferRouter.RouterHarness+    TransferRouting.Hospital.Holes+    TransferRouting.Hospital_load.ReadModelHoles+    TransferRouting.HospitalTransferRouter.RouterHoles+    TransferRouting.HospitalTransferRouter.RouterValue++  build-depends:+    , aeson              >=2.2+    , base               >=4.21 && <5+    , effectful-core+    , hasql-transaction+    , keiki              >=0.2  && <0.3+    , keiro+    , kiroku-store+    , shibuya-core+    , text               >=2.1++-- Process-manager facts harness (EP-3 M4): the self-contained, firewall-clean+-- ProcessHarness module scaffolded from hospital-surge.keiro, compiled + run to+-- prove the scaffolder lowered the spec's deterministic process/timer decisions+-- faithfully. (The runtime-coupled Process/ProcessHoles modules are emitted to+-- disk but not in this component; their live conformance is the M5 step.)+test-suite keiro-dsl-conformance-process+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-process+  main-is:        Main.hs+  other-modules:  Generated.HospitalCapacity.HospitalSurge.ProcessHarness+  build-depends:+    , base  >=4.21 && <5+    , text  >=2.1++-- Conformance for the evolved (v2) Reservation aggregate: proves the scaffolded+-- Codec schemaVersion=2 + upcasters wiring compiles and that the filled upcaster+-- migrates a v1-tagged payload through the chain (the harness "upcaster wired"+-- assertion). These sources are raw `keiro-dsl scaffold` output of+-- reservation-v2.keiro plus a hand-filled Holes.hs.+test-suite keiro-dsl-conformance-v2+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-v2+  main-is:        Main.hs+  other-modules:+    Generated.HospitalCapacity.Reservation.Codec+    Generated.HospitalCapacity.Reservation.Domain+    Generated.HospitalCapacity.Reservation.EventStream+    Generated.HospitalCapacity.Reservation.Harness+    Generated.HospitalCapacity.Reservation.Projection+    HospitalCapacity.Reservation.Holes++  build-depends:+    , aeson  >=2.2+    , base   >=4.21 && <5+    , keiki  >=0.2  && <0.3+    , keiro+    , text   >=2.1
+ src/Keiro/Dsl/Diff.hs view
@@ -0,0 +1,1195 @@+{- | The spec evolution differ. 'diffSpecs' compares an /old/ and a /new/ 'Spec'+and classifies changes over the persisted decode and identity surfaces.++Changes are __ADDITIVE__ when they preserve stored data, __WARNING__ when they+change forward behaviour without invalidating persisted data, and __BREAKING__+when stored payloads may stop decoding or persisted identities may be re-keyed.+The @diff --since@ CLI exits non-zero only when a breaking change is present.++Every 'Node' constructor maps to a 'NodeFamily', and 'familyRegistry' contains+exactly one entry for each family.  A family is either handled by an explicit+differ or carries a non-empty out-of-scope rationale.  This makes omissions+visible when the grammar grows instead of silently treating new node kinds as+safe.+-}+module Keiro.Dsl.Diff (+    Change (..),+    ChangeKind (..),+    isBreaking,+    isAdvisory,+    diffSpecs,+    DiffEnv (..),+    NodeFamily (..),+    familyOf,+    FamilyDiff (..),+    familyRegistry,+    Paired (..),+    pairByName,+    readModelDiff,+    classifyWorkflowBody,+) where++import Data.List (find, (\\))+import Data.Maybe (isJust, isNothing, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)+import Keiro.Dsl.Validate (DiagnosticCode (..))++-- | A classified spec change.+data Change+    = Additive ChangeKind+    | Advisory ChangeKind+    | Breaking ChangeKind+    deriving stock (Eq, Show)++data ChangeKind = ChangeKind+    { ckNode :: !Name+    , ckFacet :: !Text+    , ckSubject :: !Text+    , ckCode :: !(Maybe DiagnosticCode)+    , ckDetail :: !Text+    }+    deriving stock (Eq, Show)++isBreaking :: Change -> Bool+isBreaking (Breaking _) = True+isBreaking (Additive _) = False+isBreaking (Advisory _) = False++isAdvisory :: Change -> Bool+isAdvisory (Advisory _) = True+isAdvisory (Additive _) = False+isAdvisory (Breaking _) = False++-- | Both specs supplied to a node-family differ, always old then new.+data DiffEnv = DiffEnv+    { deOld :: !Spec+    , deNew :: !Spec+    }+    deriving stock (Eq, Show)++-- | The closed set of node families currently present in 'Node'.+data NodeFamily+    = FamAggregate+    | FamProcess+    | FamRouter+    | FamContract+    | FamIntake+    | FamEmit+    | FamPublisher+    | FamWorkqueue+    | FamPgmqDispatch+    | FamReadModel+    | FamWorkflow+    | FamOperation+    deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | Total by construction: one explicit arm per 'Node' constructor.+familyOf :: Node -> NodeFamily+familyOf (NAggregate _) = FamAggregate+familyOf (NProcess _) = FamProcess+familyOf (NRouter _) = FamRouter+familyOf (NContract _) = FamContract+familyOf (NIntake _) = FamIntake+familyOf (NEmit _) = FamEmit+familyOf (NPublisher _) = FamPublisher+familyOf (NWorkqueue _) = FamWorkqueue+familyOf (NPgmqDispatch _) = FamPgmqDispatch+familyOf (NReadModel _) = FamReadModel+familyOf (NWorkflow _) = FamWorkflow+familyOf (NOperation _) = FamOperation++-- | A family either has a differ or an explicit reason it is not compared.+data FamilyDiff+    = DiffFamily (DiffEnv -> [Change])+    | OutOfDiffScope Text++-- | Pair the old and new declarations of one node family by stable name.+data Paired n = Paired+    { prMatched :: ![(n, n)]+    , prAdded :: ![n]+    , prRemoved :: ![n]+    }+    deriving stock (Eq, Show)++pairByName :: (Node -> Maybe n) -> (n -> Name) -> DiffEnv -> Paired n+pairByName project nameOf env =+    Paired+        { prMatched =+            [ (oldNode, newNode)+            | newNode <- newNodes+            , Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]+            ]+        , prAdded =+            [ newNode+            | newNode <- newNodes+            , isNothing (find ((== nameOf newNode) . nameOf) oldNodes)+            ]+        , prRemoved =+            [ oldNode+            | oldNode <- oldNodes+            , isNothing (find ((== nameOf oldNode) . nameOf) newNodes)+            ]+        }+  where+    oldNodes = mapMaybe project (specNodes (deOld env))+    newNodes = mapMaybe project (specNodes (deNew env))++{- | Registry invariant: every 'Node' constructor maps to a family via the+total 'familyOf' case, and every family occurs exactly once here.  The unit+suite enforces registry coverage and non-empty out-of-scope rationales.+-}+familyRegistry :: [(NodeFamily, FamilyDiff)]+familyRegistry =+    [ (FamAggregate, DiffFamily aggregateDiff)+    , (FamProcess, DiffFamily processDiff)+    , (FamRouter, DiffFamily routerDiff)+    , (FamContract, DiffFamily contractDiff)+    , (FamIntake, DiffFamily intakeDiff)+    , (FamEmit, DiffFamily emitDiff)+    , (FamPublisher, DiffFamily publisherDiff)+    , (FamWorkqueue, DiffFamily workqueueDiff)+    , (FamPgmqDispatch, DiffFamily pgmqDispatchDiff)+    , (FamReadModel, DiffFamily readModelDiff)+    , (FamWorkflow, DiffFamily workflowDiff)+    , (FamOperation, OutOfDiffScope "operations own no persisted decode or identity surface; their references and workflow signal/await pairing are single-spec validation concerns")+    ]++diffSpecs :: Spec -> Spec -> [Change]+diffSpecs old new =+    sharedDeclarationDiff env+        ++ concatMap (runFamily env . snd) familyRegistry+  where+    env = DiffEnv old new++runFamily :: DiffEnv -> FamilyDiff -> [Change]+runFamily env (DiffFamily f) = f env+runFamily _ (OutOfDiffScope _) = []++-- Rules are intentionally outside the decode/identity axes: they alter guard+-- behaviour but neither interpret stored bytes nor derive persisted keys.+-- Shared id and enum declarations become diffed in Milestones 2 and 4.+sharedDeclarationDiff :: DiffEnv -> [Change]+sharedDeclarationDiff env = enumDiff env ++ idDiff env++nodeAggregate :: Node -> Maybe Aggregate+nodeAggregate (NAggregate a) = Just a+nodeAggregate _ = Nothing++nodeProcess :: Node -> Maybe ProcessNode+nodeProcess (NProcess process) = Just process+nodeProcess _ = Nothing++nodeRouter :: Node -> Maybe RouterNode+nodeRouter (NRouter router) = Just router+nodeRouter _ = Nothing++nodeContract :: Node -> Maybe ContractNode+nodeContract (NContract contract) = Just contract+nodeContract _ = Nothing++nodeIntake :: Node -> Maybe IntakeNode+nodeIntake (NIntake intake) = Just intake+nodeIntake _ = Nothing++nodeEmit :: Node -> Maybe EmitNode+nodeEmit (NEmit emit) = Just emit+nodeEmit _ = Nothing++nodePublisher :: Node -> Maybe PublisherNode+nodePublisher (NPublisher publisher) = Just publisher+nodePublisher _ = Nothing++nodeWorkqueue :: Node -> Maybe WorkqueueNode+nodeWorkqueue (NWorkqueue workqueue) = Just workqueue+nodeWorkqueue _ = Nothing++nodePgmqDispatch :: Node -> Maybe PgmqDispatchNode+nodePgmqDispatch (NPgmqDispatch dispatch) = Just dispatch+nodePgmqDispatch _ = Nothing++nodeReadModel :: Node -> Maybe ReadModelNode+nodeReadModel (NReadModel readModel) = Just readModel+nodeReadModel _ = Nothing++nodeWorkflow :: Node -> Maybe WorkflowNode+nodeWorkflow (NWorkflow workflow) = Just workflow+nodeWorkflow _ = Nothing++{- | Router identity is replay-sensitive: the stable name and key feed every+target-keyed dispatch id, and the target selects the persisted stream family.+-}+routerDiff :: DiffEnv -> [Change]+routerDiff env =+    concatMap (uncurry routerPairDiff) (prMatched paired)+        ++ [additive (rtId router) "router" (rtId router) "new router declaration" | router <- prAdded paired]+        ++ [breaking (rtId router) "router-identity" (rtId router) RouterStableNameChanged "router removed while replayable source events may still derive target-keyed dispatch ids from its stable identity" | router <- prRemoved paired]+  where+    paired = pairByName nodeRouter rtId env++routerPairDiff :: RouterNode -> RouterNode -> [Change]+routerPairDiff oldRouter newRouter = stableName ++ keyDerivation ++ target+  where+    nodeName = rtId newRouter+    stableName =+        [ breaking nodeName "router-stable-name" nodeName RouterStableNameChanged $+            "router stable name changed from '" <> rtName oldRouter <> "' to '" <> rtName newRouter <> "'; every deterministicRouterCommandId is re-keyed, so redelivery can duplicate the full resolved fan-out"+        | rtName oldRouter /= rtName newRouter+        ]+    keyDerivation =+        [ breaking nodeName "router-key" (corrField (rtKey newRouter)) DerivedIdentityChanged "router key field or derivation changed; replay derives different target dispatch ids"+        | rtKey oldRouter /= rtKey newRouter+        ]+    target =+        [ breaking nodeName "router-target" (rtTarget newRouter) DerivedIdentityChanged "router target aggregate changed; replay addresses a different persisted stream family"+        | rtTarget oldRouter /= rtTarget newRouter+        ]++readModelDiff :: DiffEnv -> [Change]+readModelDiff env =+    concatMap (uncurry (readModelPairDiff env)) (prMatched paired)+        ++ concatMap addedReadModelDiff (prAdded paired)+        ++ concatMap removedReadModelDiff (prRemoved paired)+  where+    paired = pairByName nodeReadModel rmName env++readModelPairDiff :: DiffEnv -> ReadModelNode -> ReadModelNode -> [Change]+readModelPairDiff env oldReadModel newReadModel =+    versionChanges+        ++ shapeChanges+        ++ identityChanges+        ++ feedChanges+        ++ consistencyChanges+        ++ scopeChanges+  where+    nodeName = rmName newReadModel+    versionChanges+        | rmVersion newReadModel < rmVersion oldReadModel =+            [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel))+            ]+        | rmVersion newReadModel > rmVersion oldReadModel =+            [ additive nodeName "read-model-version" nodeName ("version increased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel) <> "; register and rebuild the new shape before serving it")+            ]+        | otherwise = []+    oldShape = (rmColumns oldReadModel, rmShape oldReadModel)+    newShape = (rmColumns newReadModel, rmShape newReadModel)+    shapeChanges =+        [ breaking nodeName "read-model-shape" nodeName ReadModelShapeChangedWithoutBump ("declared columns or captured shape hash changed at version " <> tInt (rmVersion newReadModel) <> "; bump version and rebuild")+        | oldShape /= newShape+        , rmVersion oldReadModel == rmVersion newReadModel+        ]+    oldRegistry = registryNameFor (specContext (deOld env)) oldReadModel+    newRegistry = registryNameFor (specContext (deNew env)) newReadModel+    oldSubscription = subscriptionNameFor (specContext (deOld env)) oldReadModel+    newSubscription = subscriptionNameFor (specContext (deNew env)) newReadModel+    identityChanges =+        [ breaking nodeName "read-model-identity" nodeName DerivedIdentityChanged ("registry name changed '" <> oldRegistry <> "' -> '" <> newRegistry <> "'; the old registration row is orphaned")+        | oldRegistry /= newRegistry+        ]+            ++ [ breaking nodeName "read-model-table" nodeName DerivedIdentityChanged ("qualified table changed '" <> qualifiedIdentity oldReadModel <> "' -> '" <> qualifiedIdentity newReadModel <> "'; existing data remains under the old identity")+               | (rmSchema oldReadModel, rmTable oldReadModel) /= (rmSchema newReadModel, rmTable newReadModel)+               ]+            ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity")+               | oldSubscription /= newSubscription+               ]+    feedChanges =+        [ breaking nodeName "read-model-feed" nodeName ReadModelFeedChanged ("feed changed " <> renderFeed (rmFeed oldReadModel) <> " -> " <> renderFeed (rmFeed newReadModel) <> "; projection wiring and rebuild identities changed")+        | rmFeed oldReadModel /= rmFeed newReadModel+        ]+    consistencyChanges = case (rmConsistency oldReadModel, rmConsistency newReadModel) of+        (Strong, Eventual) ->+            [breaking nodeName "read-model-consistency" nodeName ReadModelConsistencyWeakened "default consistency changed Strong -> Eventual; callers lose the cursor-wait guarantee"]+        (Eventual, Strong) ->+            [additive nodeName "read-model-consistency" nodeName "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"]+        _ -> []+    oldScope = effectiveScope (rmScope oldReadModel)+    newScope = effectiveScope (rmScope newReadModel)+    scopeChanges+        | oldScope == newScope = []+        | scopeStrengthened oldScope newScope =+            [additive nodeName "read-model-scope" nodeName ("Strong scope widened " <> renderScope oldScope <> " -> " <> renderScope newScope)]+        | otherwise =+            [breaking nodeName "read-model-scope" nodeName ReadModelConsistencyWeakened ("Strong scope changed " <> renderScope oldScope <> " -> " <> renderScope newScope <> "; callers no longer wait on the same event surface")]++addedReadModelDiff :: ReadModelNode -> [Change]+addedReadModelDiff readModel =+    [additive (rmName readModel) "read-model" (rmName readModel) "new read model"]++removedReadModelDiff :: ReadModelNode -> [Change]+removedReadModelDiff readModel =+    [breaking (rmName readModel) "read-model-identity" (rmName readModel) DerivedIdentityChanged "read model removed while registered metadata, data, subscription cursors, and callers may remain"]++qualifiedIdentity :: ReadModelNode -> Text+qualifiedIdentity readModel = rmSchema readModel <> "." <> rmTable readModel++renderFeed :: RmFeed -> Text+renderFeed RmInline = "inline"+renderFeed RmSubscription = "subscription"++effectiveScope :: Maybe RmScope -> RmScope+effectiveScope Nothing = RmEntireLog+effectiveScope (Just scope) = scope++scopeStrengthened :: RmScope -> RmScope -> Bool+scopeStrengthened (RmCategory _) RmEntireLog = True+scopeStrengthened _ _ = False++renderScope :: RmScope -> Text+renderScope RmEntireLog = "entire-log"+renderScope (RmCategory categoryName) = "category '" <> categoryName <> "'"++aggregateDiff :: DiffEnv -> [Change]+aggregateDiff env =+    concatMap (uncurry aggregatePairDiff) (prMatched paired)+        ++ concatMap addedAggregateDiff (prAdded paired)+        ++ concatMap removedAggregateDiff (prRemoved paired)+  where+    paired = pairByName nodeAggregate aggName env++aggregatePairDiff :: Aggregate -> Aggregate -> [Change]+aggregatePairDiff oldAgg newAgg =+    concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg)+        ++ removedEvents oldAgg newAgg+        ++ wireDiff oldAgg newAgg+        ++ projectionDiff oldAgg newAgg++addedAggregateDiff :: Aggregate -> [Change]+addedAggregateDiff newAgg =+    [ additive (aggName newAgg) "event" (evName e) "new event type (new aggregate)"+    | e <- aggEvents newAgg+    ]++removedAggregateDiff :: Aggregate -> [Change]+removedAggregateDiff oldAgg =+    [ breaking (aggName oldAgg) "event" (evName e) EvtRemovedNotDeprecated "aggregate removed; its event tags are no longer decodable"+    | e <- aggEvents oldAgg+    ]++-- | Per-event classification for an event present in the new aggregate.+eventDiff :: Aggregate -> Aggregate -> Event -> [Change]+eventDiff oldAgg newAgg e =+    case find ((== evName e) . evName) (aggEvents oldAgg) of+        Nothing ->+            [additive (aggName newAgg) "event" (evName e) "new event type"]+        Just oldE+            | evVersion e > evVersion oldE ->+                if evVersion e == evVersion oldE + 1 && evUpcastFrom e `hasSource` evVersion oldE+                    then [additive (aggName newAgg) "event" (evName e) ("new version v" <> tInt (evVersion e) <> " with upcaster from v" <> tInt (evVersion oldE))]+                    else+                        [ breaking+                            (aggName newAgg)+                            "event"+                            (evName e)+                            EvtVersionMissingUpcaster+                            ( "version changed from v"+                                <> tInt (evVersion oldE)+                                <> " to v"+                                <> tInt (evVersion e)+                                <> " without the required contiguous upcaster from v"+                                <> tInt (evVersion oldE)+                            )+                        ]+            | evVersion e < evVersion oldE ->+                [breaking (aggName newAgg) "event" (evName e) EvtVersionDecreased ("version decreased from v" <> tInt (evVersion oldE) <> " to v" <> tInt (evVersion e))]+            | otherwise ->+                sameVersionEventDiff oldAgg newAgg oldE e++{- | Events present in the old aggregate but absent in the new one. Removing a+tag entirely is breaking; keeping it as a deprecated event is safe.+-}+removedEvents :: Aggregate -> Aggregate -> [Change]+removedEvents oldAgg newAgg =+    [ breaking (aggName newAgg) "event" (evName oldE) EvtRemovedNotDeprecated "event removed entirely; keep it as a 'deprecated event' so old payloads still decode"+    | oldE <- aggEvents oldAgg+    , isNothing (find ((== evName oldE) . evName) (aggEvents newAgg))+    ]++hasSource :: Maybe (Int, Hole) -> Int -> Bool+hasSource (Just (m, _)) n = m == n+hasSource Nothing _ = False++eventFieldSigs :: Aggregate -> Event -> [(Name, Maybe Name)]+eventFieldSigs agg e = case evBody e of+    EventFields fs -> map fieldSig fs+    EventFromCommand cn ->+        maybe [] (map fieldSig . cmdFields) (find ((== cn) . cmdName) (aggCommands agg))+  where+    fieldSig f = (fieldName f, fieldType f)++sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change]+sameVersionEventDiff oldAgg newAgg oldE newE =+    addedChanges+        ++ removedChanges+        ++ typeChanges+        ++ deprecationChanges+  where+    oldFields = eventFieldSigs oldAgg oldE+    newFields = eventFieldSigs newAgg newE+    oldNames = map fst oldFields+    newNames = map fst newFields+    added = newNames \\ oldNames+    removed = oldNames \\ newNames+    changed =+        [ (field, oldType, newType)+        | (field, oldType) <- oldFields+        , Just newType <- [lookup field newFields]+        , oldType /= newType+        ]+    addedChanges =+        [ breaking (aggName newAgg) "event" (evName newE) EvtFieldAddedWithoutBump ("field(s) " <> commas added <> " added at the same version v" <> tInt (evVersion newE) <> " without a version bump or upcaster")+        | not (null added)+        ]+    removedChanges =+        [ breaking (aggName newAgg) "event" (evName newE) EvtFieldRemovedSameVersion ("field(s) " <> commas removed <> " removed at the same version v" <> tInt (evVersion newE))+        | not (null removed)+        ]+    typeChanges =+        [ breaking+            (aggName newAgg)+            "event-field"+            (evName newE <> "." <> field)+            EvtFieldTypeChanged+            ("type changed " <> renderFieldType oldType <> " -> " <> renderFieldType newType <> " at the same version v" <> tInt (evVersion newE))+        | (field, oldType, newType) <- changed+        ]+    deprecationChanges+        | not (evDeprecated oldE) && evDeprecated newE =+            [additive (aggName newAgg) "event" (evName newE) "event deprecated (still decodable)"]+        | evDeprecated oldE && not (evDeprecated newE) =+            [advisory (aggName newAgg) "event" (evName newE) EventUndeprecated "event returned to the write surface; old payloads remain decodable but new writes resume"]+        | otherwise = []++renderFieldType :: Maybe Name -> Text+renderFieldType Nothing = "(declared)"+renderFieldType (Just name) = name++wireDiff :: Aggregate -> Aggregate -> [Change]+wireDiff oldAgg newAgg+    | effectiveWire (aggWire oldAgg) == effectiveWire (aggWire newAgg) = []+    | otherwise =+        [ breaking+            (aggName newAgg)+            "wire"+            (aggName newAgg)+            WireSpecChanged+            ("effective wire convention changed " <> renderWire (effectiveWire (aggWire oldAgg)) <> " -> " <> renderWire (effectiveWire (aggWire newAgg)))+        ]++effectiveWire :: Maybe WireSpec -> (Text, Text)+effectiveWire Nothing = ("ctorName", "camelCase")+effectiveWire (Just w) = (wireKind w, wireFields w)++renderWire :: (Text, Text) -> Text+renderWire (kindName, fieldNames) = "kind=" <> kindName <> ", fields=" <> fieldNames++projectionDiff :: Aggregate -> Aggregate -> [Change]+projectionDiff oldAggregate newAggregate+    | projectionSurface (aggProjection oldAggregate) == projectionSurface (aggProjection newAggregate) = []+    | otherwise =+        [ advisory+            (aggName newAggregate)+            "projection"+            (aggName newAggregate)+            ProjectionChanged+            "projection table, consistency, key, or status mapping changed; coordinate the read-model migration"+        ]++projectionSurface :: Maybe ProjectionSpec -> Maybe (Name, Maybe Consistency, Name, Maybe Mapping)+projectionSurface projection = do+    value <- projection+    pure (projTable value, projConsistency value, projKey value, projStatusMap value)++idDiff :: DiffEnv -> [Change]+idDiff env =+    concatMap (uncurry idPairDiff) (prMatched paired)+        ++ concatMap addedIdDiff (prAdded paired)+        ++ concatMap removedIdDiff (prRemoved paired)+  where+    paired = pairDeclarations idName (specIds (deOld env)) (specIds (deNew env))++idPairDiff :: IdDecl -> IdDecl -> [Change]+idPairDiff oldId newId =+    [ breaking (idName newId) "id-prefix" (idName newId) IdPrefixChanged ("prefix changed '" <> idPrefix oldId <> "' -> '" <> idPrefix newId <> "'; stored and newly minted ids no longer share an identity domain")+    | idPrefix oldId /= idPrefix newId+    ]++addedIdDiff :: IdDecl -> [Change]+addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) "new id declaration"]++removedIdDiff :: IdDecl -> [Change]+removedIdDiff declaration = [breaking (idName declaration) "id-prefix" (idName declaration) IdPrefixChanged "id declaration removed; persisted ids still use its prefix"]++enumDiff :: DiffEnv -> [Change]+enumDiff env =+    concatMap (uncurry (enumPairDiff (deOld env))) (prMatched paired)+        ++ concatMap addedEnumDiff (prAdded paired)+        ++ concatMap (removedEnumDiff (deOld env)) (prRemoved paired)+  where+    paired = pairDeclarations enumName (specEnums (deOld env)) (specEnums (deNew env))++enumPairDiff :: Spec -> EnumDecl -> EnumDecl -> [Change]+enumPairDiff oldSpec oldEnum newEnum =+    [ breaking (enumName newEnum) "enum-constructor" ctor EnumCtorRemoved ("constructor removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName oldEnum))+    | (ctor, wire) <- enumCtors oldEnum+    , isNothing (lookup ctor (enumCtors newEnum))+    ]+        ++ [ breaking (enumName newEnum) "enum-constructor" ctor EnumWireSpellingChanged ("wire spelling changed '" <> oldWire <> "' -> '" <> newWire <> "'; stored values using the old spelling no longer decode" <> enumUsageSuffix oldSpec (enumName oldEnum))+           | (ctor, oldWire) <- enumCtors oldEnum+           , Just newWire <- [lookup ctor (enumCtors newEnum)]+           , oldWire /= newWire+           ]+        ++ [ additive (enumName newEnum) "enum-constructor" ctor ("new constructor with wire spelling '" <> wire <> "'")+           | (ctor, wire) <- enumCtors newEnum+           , isNothing (lookup ctor (enumCtors oldEnum))+           ]++addedEnumDiff :: EnumDecl -> [Change]+addedEnumDiff enumDecl =+    [additive (enumName enumDecl) "enum-constructor" ctor ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl]++removedEnumDiff :: Spec -> EnumDecl -> [Change]+removedEnumDiff oldSpec enumDecl =+    [ breaking (enumName enumDecl) "enum-constructor" ctor EnumCtorRemoved ("enum removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName enumDecl))+    | (ctor, wire) <- enumCtors enumDecl+    ]++enumUsageSuffix :: Spec -> Name -> Text+enumUsageSuffix spec enumType = case enumUsages spec enumType of+    [] -> ""+    usages -> "; used by " <> commas usages++enumUsages :: Spec -> Name -> [Text]+enumUsages spec enumType =+    [aggName agg <> ".reg." <> regName reg | agg <- aggregates, reg <- aggRegs agg, regType reg == enumType]+        ++ [ aggName agg <> ".event." <> evName event <> "." <> field+           | agg <- aggregates+           , event <- aggEvents agg+           , (field, Just fieldTypeName) <- eventFieldSigs agg event+           , fieldTypeName == enumType+           ]+  where+    aggregates = [agg | NAggregate agg <- specNodes spec]++pairDeclarations :: (n -> Name) -> [n] -> [n] -> Paired n+pairDeclarations nameOf oldNodes newNodes =+    Paired+        { prMatched =+            [ (oldNode, newNode)+            | newNode <- newNodes+            , Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]+            ]+        , prAdded = [newNode | newNode <- newNodes, isNothing (find ((== nameOf newNode) . nameOf) oldNodes)]+        , prRemoved = [oldNode | oldNode <- oldNodes, isNothing (find ((== nameOf oldNode) . nameOf) newNodes)]+        }++contractDiff :: DiffEnv -> [Change]+contractDiff env =+    concatMap (uncurry contractPairDiff) (prMatched paired)+        ++ concatMap addedContractDiff (prAdded paired)+        ++ concatMap removedContractDiff (prRemoved paired)+  where+    paired = pairByName nodeContract ctrName env++contractPairDiff :: ContractNode -> ContractNode -> [Change]+contractPairDiff oldContract newContract =+    schemaChanges+        ++ discriminatorChanges+        ++ topicChanges+        ++ concatMap eventPairChanges matchedEvents+        ++ concatMap addedEventChanges addedEvents+        ++ concatMap removedEventChanges removedEvents'+  where+    schemaChanges =+        [ breaking+            (ctrName newContract)+            "schema-version"+            (ctrName newContract)+            ContractSchemaVersionDecreased+            ("schemaVersion decreased from " <> tInt (ctrSchemaVersion oldContract) <> " to " <> tInt (ctrSchemaVersion newContract))+        | ctrSchemaVersion newContract < ctrSchemaVersion oldContract+        ]+    discriminatorChanges =+        [ breaking+            (ctrName newContract)+            "discriminator"+            (ctrName newContract)+            ContractDiscriminatorChanged+            ("discriminator changed " <> ctrDiscriminator oldContract <> " -> " <> ctrDiscriminator newContract)+        | ctrDiscriminator oldContract /= ctrDiscriminator newContract+        ]+    topicChanges = contractTopicDiff oldContract newContract+    eventPairs = pairDeclarations ceName (ctrEvents oldContract) (ctrEvents newContract)+    matchedEvents = prMatched eventPairs+    addedEvents = prAdded eventPairs+    removedEvents' = prRemoved eventPairs+    eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent+    addedEventChanges event =+        [additive (ctrName newContract) "contract-event" (ceName event) "new contract event"]+    removedEventChanges event =+        [breaking (ctrName newContract) "contract-event" (ceName event) ContractEventRemoved "contract event removed; existing cross-service payloads no longer have a declared decoder"]++addedContractDiff :: ContractNode -> [Change]+addedContractDiff contract =+    [additive (ctrName contract) "contract-event" (ceName event) "new event in a new contract" | event <- ctrEvents contract]++removedContractDiff :: ContractNode -> [Change]+removedContractDiff contract =+    [breaking (ctrName contract) "contract-event" (ceName event) ContractEventRemoved "contract removed; its cross-service event decoder is no longer declared" | event <- ctrEvents contract]++contractTopicDiff :: ContractNode -> ContractNode -> [Change]+contractTopicDiff oldContract newContract =+    [ breaking+        (ctrName newContract)+        "contract-topic"+        alias+        ContractTopicChanged+        ("topic alias removed; previous topic was '" <> oldTopic <> "'")+    | (alias, oldTopic) <- ctrTopics oldContract+    , isNothing (lookup alias (ctrTopics newContract))+    ]+        ++ [ breaking+                (ctrName newContract)+                "contract-topic"+                alias+                ContractTopicChanged+                ("real topic changed '" <> oldTopic <> "' -> '" <> newTopic <> "'")+           | (alias, oldTopic) <- ctrTopics oldContract+           , Just newTopic <- [lookup alias (ctrTopics newContract)]+           , oldTopic /= newTopic+           ]+        ++ [ additive (ctrName newContract) "contract-topic" alias ("new topic alias for '" <> topic <> "'")+           | (alias, topic) <- ctrTopics newContract+           , isNothing (lookup alias (ctrTopics oldContract))+           ]++contractEventDiff :: ContractNode -> ContractNode -> ContractEvent -> ContractEvent -> [Change]+contractEventDiff oldContract newContract oldEvent newEvent =+    topicAliasChange+        ++ removedFieldChanges+        ++ changedFieldChanges+        ++ addedFieldChanges+  where+    fieldPairs = pairDeclarations cfName (ceFields oldEvent) (ceFields newEvent)+    topicAliasChange =+        [ breaking+            (ctrName newContract)+            "contract-topic"+            (ceName newEvent)+            ContractTopicChanged+            ("event topic alias changed " <> ceTopic oldEvent <> " -> " <> ceTopic newEvent)+        | ceTopic oldEvent /= ceTopic newEvent+        ]+    removedFieldChanges =+        [ breaking (ctrName newContract) "contract-field" (ceName newEvent <> "." <> cfName field) ContractFieldChanged "field removed; existing messages still carry the old contract shape"+        | field <- prRemoved fieldPairs+        ]+    changedFieldChanges =+        [ breaking+            (ctrName newContract)+            "contract-field"+            (ceName newEvent <> "." <> cfName newField)+            ContractFieldChanged+            ("field type changed " <> renderContractType (cfType oldField) <> " -> " <> renderContractType (cfType newField))+        | (oldField, newField) <- prMatched fieldPairs+        , cfType oldField /= cfType newField+        ]+    addedFieldChanges =+        [ if ctrSchemaVersion newContract > ctrSchemaVersion oldContract+            then advisory (ctrName newContract) "contract-field" subject ContractSchemaVersionBumped ("field added with schemaVersion bump " <> tInt (ctrSchemaVersion oldContract) <> " -> " <> tInt (ctrSchemaVersion newContract) <> "; coordinate the cross-service rollout")+            else breaking (ctrName newContract) "contract-field" subject ContractFieldChanged "field added without a schemaVersion bump; older in-flight messages do not contain it"+        | field <- prAdded fieldPairs+        , let subject = ceName newEvent <> "." <> cfName field+        ]++renderContractType :: ContractType -> Text+renderContractType (CTypeId prefix) = "typeid '" <> prefix <> "'"+renderContractType CText = "text"+renderContractType CInt = "int"++workqueueDiff :: DiffEnv -> [Change]+workqueueDiff env =+    concatMap (uncurry workqueuePairDiff) (prMatched paired)+        ++ concatMap addedWorkqueueDiff (prAdded paired)+        ++ concatMap removedWorkqueueDiff (prRemoved paired)+  where+    paired = pairByName nodeWorkqueue wqName env++workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+workqueuePairDiff oldQueue newQueue =+    concatMap pairedFieldDiff (prMatched fields)+        ++ concatMap addedFieldDiff (prAdded fields)+        ++ concatMap removedFieldDiff (prRemoved fields)+        ++ queueIdentityDiff oldQueue newQueue+        ++ queuePolicyDiff oldQueue newQueue+  where+    -- wqPayloadName is a generated Haskell type name, not a wire-visible name.+    fields = pairDeclarations wqfName (wqPayload oldQueue) (wqPayload newQueue)+    pairedFieldDiff (oldField, newField)+        | wqfWire oldField /= wqfWire newField = [payloadBreaking newField ("wire name changed '" <> wqfWire oldField <> "' -> '" <> wqfWire newField <> "'")]+        | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> wqfType oldField <> " -> " <> wqfType newField)]+        | not (wqfRequired oldField) && wqfRequired newField = [payloadBreaking newField "field changed from optional to required; queued jobs may omit it"]+        | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) "field changed from required to optional"]+        | otherwise = []+    addedFieldDiff field+        | wqfRequired field = [payloadBreaking field "new required field; queued jobs do not contain it"]+        | otherwise = [additive (wqName newQueue) "payload-field" (wqfName field) "new optional field"]+    removedFieldDiff field = [payloadBreaking field "field removed; queued jobs still contain the old payload shape"]+    payloadBreaking field detail = breaking (wqName newQueue) "payload-field" (wqfName field) WqPayloadFieldChanged detail++addedWorkqueueDiff :: WorkqueueNode -> [Change]+addedWorkqueueDiff queue =+    [additive (wqName queue) "payload-field" (wqfName field) "field belongs to a new workqueue payload" | field <- wqPayload queue]++removedWorkqueueDiff :: WorkqueueNode -> [Change]+removedWorkqueueDiff queue =+    [breaking (wqName queue) "payload-field" (wqfName field) WqPayloadFieldChanged "workqueue removed while persisted jobs may still carry this payload" | field <- wqPayload queue]+        ++ [breaking (wqName queue) "queue-identity" (wqName queue) QueueIdentityChanged "workqueue removed; its physical queue, DLQ, and pgmq table may still hold state"]++queueIdentityDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+queueIdentityDiff oldQueue newQueue =+    [ breaking+        (wqName newQueue)+        "queue-identity"+        (wqName newQueue)+        QueueIdentityChanged+        "logical, physical, DLQ, or table name changed; queued jobs and dispatch dedupe records remain under the old identity"+    | queueIdentity oldQueue /= queueIdentity newQueue+    ]++queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text)+queueIdentity queue = (wqLogical queue, wqPhysical queue, wqDlq queue, wqTable queue)++queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey+  where+    nodeName = wqName newQueue+    ordering =+        [ breaking nodeName "queue-ordering" nodeName WqOrderingChanged $+            "ordering changed " <> renderWqOrdering (wqOrdering oldQueue) <> " -> " <> renderWqOrdering (wqOrdering newQueue) <> "; consumers were written against the old delivery-order contract"+        | wqOrdering oldQueue /= wqOrdering newQueue+        ]+    provision =+        [ breaking nodeName "queue-provision" nodeName WqProvisionChanged $+            "provision changed " <> renderWqProvision (wqProvision oldQueue) <> " -> " <> renderWqProvision (wqProvision newQueue) <> "; provisioning is create-time only, so migrate the existing queue operationally before changing the spec"+        | wqProvision oldQueue /= wqProvision newQueue+        ]+    groupKey =+        [ breaking nodeName "queue-group-key" nodeName WqGroupKeyChanged $+            "group key derivation changed " <> renderWqGroupKey (wqGroupKey oldQueue) <> " -> " <> renderWqGroupKey (wqGroupKey newQueue) <> "; FIFO messages are re-partitioned across durable ordering groups"+        | wqGroupKey oldQueue /= wqGroupKey newQueue+        ]++renderWqOrdering :: WqOrdering -> Text+renderWqOrdering WqUnordered = "unordered"+renderWqOrdering WqFifoThroughput = "fifo-throughput"+renderWqOrdering WqFifoRoundRobin = "fifo-roundrobin"++renderWqProvision :: WqProvision -> Text+renderWqProvision WqStandard = "standard"+renderWqProvision WqUnlogged = "unlogged"+renderWqProvision (WqPartitioned interval duration) = "partitioned(interval=" <> interval <> ", retention=" <> duration <> ")"++renderWqGroupKey :: Maybe WqGroupKey -> Text+renderWqGroupKey Nothing = "none"+renderWqGroupKey (Just groupKey) =+    gkField groupKey+        <> " via "+        <> gkVia groupKey+        <> maybe "" (" fixture " <>) (gkFixture groupKey)++processDiff :: DiffEnv -> [Change]+processDiff env =+    concatMap (uncurry processPairDiff) (prMatched paired)+        ++ concatMap addedProcessDiff (prAdded paired)+        ++ concatMap removedProcessDiff (prRemoved paired)+  where+    paired = pairByName nodeProcess procId env++processPairDiff :: ProcessNode -> ProcessNode -> [Change]+processPairDiff oldProcess newProcess =+    concatMap pairedFieldDiff (prMatched fields)+        ++ map (fieldChange "field added; source events at the old shape cannot populate it") (prAdded fields)+        ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields)+        ++ processIdentityDiff oldProcess newProcess+        ++ processTimerWindowDiff oldProcess newProcess+  where+    -- inName is a generated Haskell type name; the wire shape is inFields.+    fields = pairDeclarations fieldName (inFields (procInput oldProcess)) (inFields (procInput newProcess))+    pairedFieldDiff (oldField, newField)+        | fieldType oldField /= fieldType newField = [fieldChange ("type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField)) newField]+        | otherwise = []+    fieldChange detail field = breaking (procId newProcess) "input-field" (fieldName field) ProcessInputChanged (detail <> "; version the source event before changing process input")++addedProcessDiff :: ProcessNode -> [Change]+addedProcessDiff process =+    [additive (procId process) "input-field" (fieldName field) "field belongs to a new process input" | field <- inFields (procInput process)]++removedProcessDiff :: ProcessNode -> [Change]+removedProcessDiff process =+    [breaking (procId process) "input-field" (fieldName field) ProcessInputChanged "process removed while persisted source events may still require this input decoder" | field <- inFields (procInput process)]+        ++ [breaking (procId process) "derived-identity" (procId process) DerivedIdentityChanged "process removed while persisted saga, dispatch, and timer identities may still exist"]++processIdentityDiff :: ProcessNode -> ProcessNode -> [Change]+processIdentityDiff oldProcess newProcess =+    [ breaking+        (procId newProcess)+        "derived-identity"+        (procId newProcess)+        DerivedIdentityChanged+        "process name, correlation derivation, saga stream category, timer id prefix, or fired-event-id prefix changed; replays and retries no longer derive the persisted identity"+    | processIdentity oldProcess /= processIdentity newProcess+    ]++processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Text)+processIdentity process =+    ( procName process+    , corrField (procCorrelate process)+    , corrVia (procCorrelate process)+    , sagaCategory (procSaga process)+    , idePrefix (tmId (procTimer process))+    , idePrefix (fireFiredEventId (tmFire (procTimer process)))+    )++processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change]+processTimerWindowDiff oldProcess newProcess =+    [ advisory+        (procId newProcess)+        "timer"+        (tmName (procTimer newProcess))+        TimerWindowChanged+        ( "fireAt source/window changed "+            <> renderFireAt (tmFireAt (procTimer oldProcess))+            <> " -> "+            <> renderFireAt (tmFireAt (procTimer newProcess))+            <> "; already-scheduled timers keep their persisted deadline"+        )+    | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess)+    ]++renderFireAt :: FireAtExpr -> Text+renderFireAt expression = "input." <> faField expression <> " + " <> faWindow expression++workflowDiff :: DiffEnv -> [Change]+workflowDiff env =+    concatMap (uncurry workflowPairDiff) (prMatched paired)+        ++ concatMap addedWorkflowDiff (prAdded paired)+        ++ concatMap removedWorkflowDiff (prRemoved paired)+  where+    paired = pairByName nodeWorkflow wfId env++workflowPairDiff :: WorkflowNode -> WorkflowNode -> [Change]+workflowPairDiff oldWorkflow newWorkflow =+    inputChanges+        ++ outputChanges+        ++ classifyWorkflowBody oldWorkflow newWorkflow+        ++ workflowIdentityDiff oldWorkflow newWorkflow+  where+    fields = pairDeclarations fieldName (wfInputFields oldWorkflow) (wfInputFields newWorkflow)+    inputChanges =+        [workflowShape field "input field added; journaled inputs at the old shape do not contain it" | field <- prAdded fields]+            ++ [workflowShape field "input field removed; journaled inputs still contain the old shape" | field <- prRemoved fields]+            ++ [ workflowShape newField ("input field type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField))+               | (oldField, newField) <- prMatched fields+               , fieldType oldField /= fieldType newField+               ]+    outputChanges =+        [ breaking (wfId newWorkflow) "workflow-output" (wfOutput newWorkflow) WorkflowShapeChanged ("output type changed " <> wfOutput oldWorkflow <> " -> " <> wfOutput newWorkflow <> "; persisted outcomes may no longer decode")+        | wfOutput oldWorkflow /= wfOutput newWorkflow+        ]+    workflowShape field detail = breaking (wfId newWorkflow) "workflow-input" (fieldName field) WorkflowShapeChanged detail++addedWorkflowDiff :: WorkflowNode -> [Change]+addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) "new workflow"]++removedWorkflowDiff :: WorkflowNode -> [Change]+removedWorkflowDiff workflow = [breaking (wfId workflow) "workflow" (wfId workflow) WorkflowShapeChanged "workflow removed while in-flight journals and outcomes may still require its decoder"]++workflowIdentityDiff :: WorkflowNode -> WorkflowNode -> [Change]+workflowIdentityDiff oldWorkflow newWorkflow =+    [ breaking+        (wfId newWorkflow)+        "workflow-name"+        (wfId newWorkflow)+        WorkflowStableNameChanged+        ("stable name changed '" <> wfStable oldWorkflow <> "' -> '" <> wfStable newWorkflow <> "'; in-flight journals remain under the old stream name")+    | wfStable oldWorkflow /= wfStable newWorkflow+    ]+        ++ [ breaking+                (wfId newWorkflow)+                "derived-identity"+                (wfId newWorkflow)+                DerivedIdentityChanged+                "workflow id source field or derivation changed; journal and deterministic child/step identities no longer coalesce with persisted executions"+           | (wfIdField oldWorkflow, wfIdVia oldWorkflow) /= (wfIdField newWorkflow, wfIdVia newWorkflow)+           ]++intakeDiff :: DiffEnv -> [Change]+intakeDiff env =+    concatMap (uncurry intakePairDiff) (prMatched paired)+        ++ concatMap addedIntakeDiff (prAdded paired)+        ++ concatMap removedIntakeDiff (prRemoved paired)+  where+    paired = pairByName nodeIntake inkName env++intakePairDiff :: IntakeNode -> IntakeNode -> [Change]+intakePairDiff oldIntake newIntake =+    [ breaking+        (inkName newIntake)+        "dedupe-identity"+        (inkName newIntake)+        DedupeIdentityChanged+        "dedupe key or policy changed; redelivered messages no longer match their persisted dedupe record"+    | (inkDedupeKey oldIntake, inkDedupePolicy oldIntake) /= (inkDedupeKey newIntake, inkDedupePolicy newIntake)+    ]+        ++ [ advisory+                (inkName newIntake)+                "decode-posture"+                (inkName newIntake)+                DecodePostureChanged+                "envelope/body decode posture changed; future messages are accepted or rejected differently"+           | inkDecode oldIntake /= inkDecode newIntake+           ]+        ++ [ advisory+                (inkName newIntake)+                "inbox-persistence"+                (inkName newIntake)+                IntakePersistenceChanged+                ("success-path envelope persistence changed " <> renderInkPersist (inkPersist oldIntake) <> " -> " <> renderInkPersist (inkPersist newIntake) <> "; existing rows are unchanged while future successful rows retain a different envelope shape")+           | inkPersist oldIntake /= inkPersist newIntake+           ]++renderInkPersist :: InkPersist -> Text+renderInkPersist InkPersistFull = "full-envelope"+renderInkPersist InkPersistDedupeOnly = "dedupe-only"++addedIntakeDiff :: IntakeNode -> [Change]+addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) "new intake"]++removedIntakeDiff :: IntakeNode -> [Change]+removedIntakeDiff intake = [breaking (inkName intake) "dedupe-identity" (inkName intake) DedupeIdentityChanged "intake removed while persisted dedupe records and redeliveries may remain"]++emitDiff :: DiffEnv -> [Change]+emitDiff env =+    concatMap (uncurry emitPairDiff) (prMatched paired)+        ++ concatMap addedEmitDiff (prAdded paired)+        ++ concatMap removedEmitDiff (prRemoved paired)+  where+    paired = pairByName nodeEmit emName env++emitPairDiff :: EmitNode -> EmitNode -> [Change]+emitPairDiff oldEmit newEmit =+    [ breaking+        (emName newEmit)+        "derived-identity"+        "messageId"+        DerivedIdentityChanged+        "messageId derive prefix changed; outbox retries no longer coalesce with persisted messages"+    | emMessageId oldEmit /= emMessageId newEmit+    ]+        ++ [ breaking+                (emName newEmit)+                "derived-identity"+                "idempotencyKey"+                DerivedIdentityChanged+                "idempotencyKey derive prefix changed; downstream dedupe no longer matches persisted messages"+           | emIdempotencyKey oldEmit /= emIdempotencyKey newEmit+           ]+        ++ [ advisory+                (emName newEmit)+                "emit-mapping"+                (emName newEmit)+                EmitMappingChanged+                "emit key, status discriminant, mapping rows, or explicit skip posture changed"+           | emitMapping oldEmit /= emitMapping newEmit+           ]++emitMapping :: EmitNode -> (Name, Name, [EmitMapRow], Bool)+emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit)++addedEmitDiff :: EmitNode -> [Change]+addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) "new emit mapping"]++removedEmitDiff :: EmitNode -> [Change]+removedEmitDiff emit = [breaking (emName emit) "derived-identity" (emName emit) DerivedIdentityChanged "emit removed while persisted outbox identities may still retry"]++publisherDiff :: DiffEnv -> [Change]+publisherDiff env =+    concatMap (uncurry publisherPairDiff) (prMatched paired)+        ++ concatMap addedPublisherDiff (prAdded paired)+        ++ concatMap removedPublisherDiff (prRemoved paired)+  where+    paired = pairByName nodePublisher pubName env++publisherPairDiff :: PublisherNode -> PublisherNode -> [Change]+publisherPairDiff oldPublisher newPublisher =+    -- maxAttempts/backoff are retry tuning, not persisted decode or identity.+    [ breaking+        (pubName newPublisher)+        "derived-identity"+        "outboxId"+        DerivedIdentityChanged+        "stable outbox-id source field changed; retries no longer coalesce with persisted outbox rows"+    | pubOutboxField oldPublisher /= pubOutboxField newPublisher+    ]+        ++ [ advisory+                (pubName newPublisher)+                "publisher-policy"+                (pubName newPublisher)+                PublisherPolicyChanged+                ("ordering changed " <> pubOrdering oldPublisher <> " -> " <> pubOrdering newPublisher)+           | pubOrdering oldPublisher /= pubOrdering newPublisher+           ]++addedPublisherDiff :: PublisherNode -> [Change]+addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) "new publisher"]++removedPublisherDiff :: PublisherNode -> [Change]+removedPublisherDiff publisher = [breaking (pubName publisher) "derived-identity" (pubName publisher) DerivedIdentityChanged "publisher removed while persisted outbox rows may still require its stable identity"]++pgmqDispatchDiff :: DiffEnv -> [Change]+pgmqDispatchDiff env =+    concatMap (uncurry pgmqDispatchPairDiff) (prMatched paired)+        ++ concatMap addedPgmqDispatchDiff (prAdded paired)+        ++ concatMap removedPgmqDispatchDiff (prRemoved paired)+  where+    paired = pairByName nodePgmqDispatch pdName env++pgmqDispatchPairDiff :: PgmqDispatchNode -> PgmqDispatchNode -> [Change]+pgmqDispatchPairDiff oldDispatch newDispatch =+    [ breaking+        (pdName newDispatch)+        "dedupe-identity"+        (pdName newDispatch)+        DedupeIdentityChanged+        "dispatch dedupe key/read-model/queue surface changed; prior enqueue records no longer match"+    | dispatchDedupe oldDispatch /= dispatchDedupe newDispatch+    ]+        ++ [ advisory+                (pdName newDispatch)+                "retarget"+                (pdName newDispatch)+                DispatchRetargeted+                "source read model or target queue changed; future fan-out is routed differently"+           | dispatchTargets oldDispatch /= dispatchTargets newDispatch+           ]++dispatchDedupe :: PgmqDispatchNode -> (Name, Name, Text, Name, Text)+dispatchDedupe dispatch =+    ( pdDedupKey dispatch+    , pdDedupReadModel dispatch+    , pdDedupReadModelField dispatch+    , pdDedupQueue dispatch+    , pdDedupQueueField dispatch+    )++dispatchTargets :: PgmqDispatchNode -> (Name, Name)+dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch)++addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]+addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) "new pgmq dispatch"]++removedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]+removedPgmqDispatchDiff dispatch = [breaking (pdName dispatch) "dedupe-identity" (pdName dispatch) DedupeIdentityChanged "dispatch removed while persisted queue and read-model dedupe records may remain"]++{- | Classify the runtime's sanctioned workflow-evolution mechanisms before+falling back to the conservative unguarded-body rule.+-}+classifyWorkflowBody :: WorkflowNode -> WorkflowNode -> [Change]+classifyWorkflowBody oldWorkflow newWorkflow+    | oldBody == newBody = []+    | not (null removedPatchIds) = map removedPatch removedPatchIds+    | Just (oldSeedType, newSeedType) <- changedSeed =+        [ breaking nodeName "workflow-continue-as-new" nodeName WorkflowContinueSeedChanged $+            "continueAsNew seed type changed " <> oldSeedType <> " -> " <> newSeedType <> "; the next generation's restoreSeed must decode the seed written by the previous generation"+        ]+    | safeAdditions =+        map addedPatch newPatchIds+            ++ [ additive nodeName "workflow-continue-as-new" seedType "terminal continueAsNew is additive; old generations carry no rotation marker"+               | Just seedType <- [appendedSeed]+               ]+    | otherwise =+        [ breaking+            nodeName+            "workflow-body"+            nodeName+            WorkflowBodyChanged+            "workflow body labels, kinds, result types, or order changed without a new patch guard; wrap a cross-cutting change in patch, or rename the replay label for one changed step"+        ]+  where+    nodeName = wfId newWorkflow+    oldBody = normaliseWorkflowBody (wfBody oldWorkflow)+    newBody = normaliseWorkflowBody (wfBody newWorkflow)+    oldPatchIds = workflowBodyPatchIds oldBody+    newPatchIdsAll = workflowBodyPatchIds newBody+    newPatchIds = newPatchIdsAll \\ oldPatchIds+    removedPatchIds = oldPatchIds \\ newPatchIdsAll+    oldSeed = terminalContinueSeed oldBody+    newSeed = terminalContinueSeed newBody+    changedSeed = case (oldSeed, newSeed) of+        (Just oldSeedType, Just newSeedType)+            | oldSeedType /= newSeedType -> Just (oldSeedType, newSeedType)+        _ -> Nothing+    appendedSeed = case (oldSeed, newSeed) of+        (Nothing, Just seedType) -> Just seedType+        _ -> Nothing+    strippedNewBody = stripNewPatches newPatchIds newBody+    comparableNewBody = case appendedSeed of+        Just _ -> dropTerminalContinue strippedNewBody+        Nothing -> strippedNewBody+    safeAdditions =+        (not (null newPatchIds) || isJust appendedSeed)+            && comparableNewBody == oldBody+    removedPatch patchId =+        breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch"+    addedPatch patchId =+        additive nodeName "workflow-patch" patchId "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"++normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem]+normaliseWorkflowBody = map go+  where+    go (WfStep label result _) = WfStep label result noLoc+    go (WfAwait label result _) = WfAwait label result noLoc+    go (WfSleep label delay _) = WfSleep label delay noLoc+    go (WfChild label via result _) = WfChild label via result noLoc+    go (WfPatch patchId items _) = WfPatch patchId (normaliseWorkflowBody items) noLoc+    go (WfContinueAsNew seedType _) = WfContinueAsNew seedType noLoc++workflowBodyPatchIds :: [WfBodyItem] -> [Name]+workflowBodyPatchIds = concatMap go+  where+    go (WfPatch patchId items _) = patchId : workflowBodyPatchIds items+    go _ = []++stripNewPatches :: [Name] -> [WfBodyItem] -> [WfBodyItem]+stripNewPatches newPatchIds = concatMap go+  where+    go (WfPatch patchId _ _) | patchId `elem` newPatchIds = []+    go (WfPatch patchId items loc) = [WfPatch patchId (stripNewPatches newPatchIds items) loc]+    go item = [item]++terminalContinueSeed :: [WfBodyItem] -> Maybe Name+terminalContinueSeed items = case reverse items of+    WfContinueAsNew seedType _ : _ -> Just seedType+    _ -> Nothing++dropTerminalContinue :: [WfBodyItem] -> [WfBodyItem]+dropTerminalContinue items = case reverse items of+    WfContinueAsNew{} : rest -> reverse rest+    _ -> items++additive :: Name -> Text -> Text -> Text -> Change+additive n facet subj detail = Additive (ChangeKind n facet subj Nothing detail)++breaking :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change+breaking n facet subj c detail = Breaking (ChangeKind n facet subj (Just c) detail)++advisory :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change+advisory n facet subj c detail = Advisory (ChangeKind n facet subj (Just c) detail)++commas :: [Text] -> Text+commas = T.intercalate ", "++tInt :: Int -> Text+tInt = T.pack . show
+ src/Keiro/Dsl/Grammar.hs view
@@ -0,0 +1,997 @@+{- | The abstract syntax of the keiro DSL (@.keiro@) — the shared engine type that+every later vertical (EP-2…EP-6) extends additively. EP-1 defines the shared+declarations, the 'Expr' sublanguage, the eight hole-kind types, and the+'Aggregate' node. New node families add a 'Node' constructor here in lockstep+with their parser, validator, and scaffold cases.+-}+module Keiro.Dsl.Grammar (+    -- * Names and source locations+    Name,+    Loc (..),+    noLoc,++    -- * Shared declarations+    IdDecl (..),+    EnumDecl (..),+    RuleDecl (..),++    -- * The eight hole-kind types+    Derivation (..),+    DerivStrategy (..),+    Disposition (..),+    DispAction (..),+    Mapping (..),+    EnvelopeBinding (..),+    EnvelopeLayer (..),++    -- * The Expr sublanguage+    Expr (..),+    CmpOp (..),+    Atom (..),++    -- * The aggregate node+    RegInitial (..),+    RegDecl (..),+    StateDecl (..),+    Field (..),+    Command (..),+    Event (..),+    EventBody (..),+    Hole (..),+    Transition (..),+    WireSpec (..),+    ProjectionSpec (..),+    Consistency (..),+    SnapPolicy (..),+    SnapshotSpec (..),+    Aggregate (..),++    -- * The process + timer nodes (EP-3)+    FieldBinding (..),+    InputDecl (..),+    CorrelateDecl (..),+    SagaRef (..),+    Disp (..),+    DispatchDisposition (..),+    AdvanceNode (..),+    DispatchNode (..),+    HandleNode (..),+    IdExpr (..),+    IdStrategy (..),+    FireAtExpr (..),+    FireOutcome (..),+    FireDisposition (..),+    FireNode (..),+    TimerNode (..),+    PolicyChoice (..),+    ProcessNode (..),++    -- * The router node (EP-108)+    ResolveSource (..),+    ResolveDecl (..),+    RouterDispatchNode (..),+    RouterNode (..),++    -- * The integration contract node (EP-4)+    ContractType (..),+    ContractField (..),+    ContractEvent (..),+    ContractNode (..),++    -- * The integration intake (inbox) node (EP-4)+    WireSource (..),+    BindRow (..),+    InboxAction (..),+    DispositionRow (..),+    DecodeSpec (..),+    InkPersist (..),+    IntakeNode (..),++    -- * The integration emit/publisher nodes (EP-4)+    DeriveSpec (..),+    EmitMapRow (..),+    EmitNode (..),+    BackoffSpec (..),+    PublisherNode (..),++    -- * The pgmq workqueue/dispatch nodes (EP-5)+    WqField (..),+    WqDispRow (..),+    WqOrdering (..),+    WqGroupKey (..),+    WqProvision (..),+    WorkqueueNode (..),+    PgmqDispatchNode (..),++    -- * Read-model nodes (EP-107)+    RmColumn (..),+    RmFeed (..),+    RmScope (..),+    ReadModelNode (..),++    -- * The workflow/operation nodes (EP-6)+    WfBodyItem (..),+    WorkflowNode (..),+    OperationShape (..),+    OperationNode (..),++    -- * Top level+    Placement (..),+    Node (..),+    Spec (..),+)+where++import Data.Text (Text)+import GHC.Generics (Generic)++{- | An identifier in the notation: a type name, register name, command/event+name, state name, enum constructor, etc. Always a non-empty 'Text'.+-}+type Name = Text++{- | A source line number, attached to declarations so the validator can emit+line-numbered diagnostics. Its 'Eq' instance deliberately ignores the line+value: two ASTs that differ only in source position are considered equal, so+the @parse . pretty == id@ round-trip property holds without the+pretty-printer having to reproduce exact line numbers.+-}+newtype Loc = Loc {unLoc :: Int}+    deriving stock (Show)++instance Eq Loc where+    _ == _ = True++-- | A placeholder location used by generators and pretty-print round-trips.+noLoc :: Loc+noLoc = Loc 0++{- | @id TransferReservationId prefix=rsv@ — declares an id newtype over 'Text'+and its prefix tag.+-}+data IdDecl = IdDecl+    { idName :: !Name+    , idPrefix :: !Text+    , idLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | @enum PatientAcuity { RedTag=red … }@ — a closed enumeration; each+constructor carries its wire spelling (the right-hand side of @=@).+-}+data EnumDecl = EnumDecl+    { enumName :: !Name+    , enumCtors :: ![(Name, Text)]+    , enumLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | @rule lifeCriticalOverride : PatientAcuity -> Bool@ with an @ex@ line of+@Ctor => bool ; …@ — a total function from an enum to a value, used as a+derived atom inside guards.+-}+data RuleDecl = RuleDecl+    { ruleName :: !Name+    , ruleDomain :: !Name+    , ruleCodomain :: !Name+    , ruleCases :: ![(Name, Expr)]+    , ruleLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- The eight hole-kind types. EP-1 only exercises hole-kinds 1–3 against the+-- aggregate vertical; the rest exist so EP-3…EP-6 reuse the same types.++{- | Hole-kind 1: a deterministic id/string derivation. Opaque strategies must+carry a captured @fixture@ (not a prose rule) so two agents re-derive them+identically.+-}+data Derivation = Derivation+    { derivStrategy :: !DerivStrategy+    , derivFixture :: !(Maybe Text)+    }+    deriving stock (Eq, Show, Generic)++data DerivStrategy = UuidV5 | SuffixSplice+    deriving stock (Eq, Show, Generic)++{- | Hole-kind 2: a failure→action table. Carries the two dangerous inversions a+@duplicate@/@rejected replay@ being treated as success and a+@previously-failed@ being dead-lettered rather than retried (enforced by+EP-4's validator rules).+-}+newtype Disposition = Disposition+    { dispCases :: [(Name, DispAction)]+    }+    deriving stock (Eq, Show, Generic)++data DispAction = AckOk | Retry !Int | DeadLetter !Text+    deriving stock (Eq, Show, Generic)++{- | Hole-kind 3: an explicit value→value table that is not an identity echo+(e.g. an event name → projection status). @mapPartial@ records whether the+spec author explicitly marked the table partial over its domain.+-}+data Mapping = Mapping+    { mapPairs :: ![(Name, Name)]+    , mapPartial :: !Bool+    }+    deriving stock (Eq, Show, Generic)++{- | Hole-kind 4: which layer carries each envelope field, and whether the two+are cross-checked. Defined here for reuse; exercised by EP-4.+-}+data EnvelopeBinding = EnvelopeBinding+    { envField :: !Name+    , envLayer :: !EnvelopeLayer+    , envCrossChecked :: !Bool+    }+    deriving stock (Eq, Show, Generic)++data EnvelopeLayer = KafkaHeader | JsonBody+    deriving stock (Eq, Show, Generic)++{- | The @Expr@ sublanguage used by @guard@ clauses and the right-hand side of+@write@ clauses. An infix expression over 'Atom's; operators in precedence+order are @||@ (lowest), @&&@, then the relational comparisons.+-}+data Expr+    = EOr !Expr !Expr+    | EAnd !Expr !Expr+    | ECmp !CmpOp !Expr !Expr+    | EAtom !Atom+    deriving stock (Eq, Show, Generic)++data CmpOp = OpEq | OpNeq | OpLt | OpLe | OpGt | OpGe+    deriving stock (Eq, Show, Generic)++{- | An atom is either a bare boolean literal (@true@/@false@) or a name. Names+are kept syntactically neutral: at parse time an identifier is+indistinguishable between a register, a command field, an enum constructor,+and a rule, so the validator's scope-check (M2) resolves which one each+'AName' is against the declared sets. This keeps the parser honest and the+round-trip exact.+-}+data Atom+    = AName !Name+    | ABool !Bool+    deriving stock (Eq, Show, Generic)++{- | @name Type = initial@ — a named register with its declared type and the+initial value (an identifier: a literal like @placeholder@, an enum+constructor, or a state name).+-}+data RegInitial+    = RegInitBare !Text+    | RegInitText !Text+    deriving stock (Eq, Show, Generic)++data RegDecl = RegDecl+    { regName :: !Name+    , regType :: !Name+    , regInitial :: !RegInitial+    , regLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | One entry in a @states@ list. @stTerminal@ is set when the name carries a+trailing @!@ (no outgoing transitions allowed). The first 'StateDecl' in an+aggregate's list is its initial state.+-}+data StateDecl = StateDecl+    { stName :: !Name+    , stTerminal :: !Bool+    , stLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | A command/event field. A bare name (@fieldType = Nothing@) reuses the+field's declared type elsewhere; @name:Type@ gives an explicit type.+-}+data Field = Field+    { fieldName :: !Name+    , fieldType :: !(Maybe Name)+    }+    deriving stock (Eq, Show, Generic)++-- | @command Name { field … }@ — a command constructor.+data Command = Command+    { cmdName :: !Name+    , cmdFields :: ![Field]+    , cmdLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | @event Name { … }@ or @event Name = fields(Command)@. EP-2 (evolution) adds+the version/upcaster/deprecation fields: an unversioned event is @evVersion = 1@,+@evUpcastFrom = Nothing@, @evDeprecated = False@, reproducing the EP-1 surface.+These fields live on the shared 'Event' so every node family's events inherit+schema-versioning for free.+-}+data Event = Event+    { evName :: !Name+    , evBody :: !EventBody+    , evVersion :: !Int+    -- ^ The schema version of this event shape. Default 1; written @vN@ for N>1.+    , evUpcastFrom :: !(Maybe (Int, Hole))+    {- ^ The source version this shape migrates /from/, paired with the upcaster+    hole. @Just (n-1, …)@ for a @vN@ shape; 'Nothing' for v1.+    -}+    , evDeprecated :: !Bool+    {- ^ Retired from the write path (no transition may @emit@ it) but still+    decodable from the log.+    -}+    , evLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++data EventBody+    = EventFields ![Field]+    | EventFromCommand !Name+    deriving stock (Eq, Show, Generic)++{- | A spec hole: an unfilled placeholder ('Hole', written @HOLE@ in the+notation) or a value the author supplied inline ('Filled').+-}+data Hole = Hole | Filled !Text+    deriving stock (Eq, Show, Generic)++{- | A transition @Src -- Command --> clauses@. Clauses may be written+indentation-stacked or @;@-separated on one line.+-}+data Transition = Transition+    { tSource :: !Name+    , tCommand :: !Name+    , tGuard :: !(Maybe Expr)+    , tWrites :: ![(Name, Expr)]+    , tEmits :: ![Name]+    , tGoto :: !Name+    , tLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | @wire kind=ctorName fields=camelCase schemaVersion=1@ — how events+serialize.+-}+data WireSpec = WireSpec+    { wireKind :: !Text+    , wireFields :: !Text+    , wireSchemaVersion :: !Int+    }+    deriving stock (Eq, Show, Generic)++{- | @projection table consistency=… key=… status-map { … }@ — the read-model+projection and its event→status 'Mapping' (hole-kind 3).+-}+data ProjectionSpec = ProjectionSpec+    { projTable :: !Name+    , projConsistency :: !(Maybe Consistency)+    , projKey :: !Name+    , projStatusMap :: !(Maybe Mapping)+    , projLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++data Consistency = Strong | Eventual+    deriving stock (Eq, Show, Generic)++-- | A generated aggregate snapshot policy supported by the notation.+data SnapPolicy = SnapEvery !Int | SnapOnTerminal+    deriving stock (Eq, Show, Generic)++-- | Snapshot policy plus the captured live state-codec identity.+data SnapshotSpec = SnapshotSpec+    { snapPolicy :: !SnapPolicy+    , snapCodecVersion :: !Int+    , snapShapeHash :: !Text+    , snapLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | An @aggregate@ node: a consistency boundary whose state is rebuilt by+replaying events.+-}+data Aggregate = Aggregate+    { aggName :: !Name+    , aggRegs :: ![RegDecl]+    , aggStates :: ![StateDecl]+    , aggCommands :: ![Command]+    , aggEvents :: ![Event]+    , aggTransitions :: ![Transition]+    , aggWire :: !(Maybe WireSpec)+    , aggProjection :: !(Maybe ProjectionSpec)+    , aggSnapshot :: !(Maybe SnapshotSpec)+    , aggLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-3: process manager + durable timer nodes.++{- | A @field@ or @field=value@ binding inside a command\/payload field list.+A bare field reuses the input field of the same name; @name=value@ binds it to+an expression (kept as raw text, e.g. @timerId=timer.id@).+-}+data FieldBinding = FieldBinding+    { fbName :: !Name+    , fbValue :: !(Maybe Text)+    }+    deriving stock (Eq, Show, Generic)++{- | @input SurgeInput { hospitalId … observedAt:Time }@ — the process's incoming+event shape (one field must be a @:Time@ field used by the timer deadline).+-}+data InputDecl = InputDecl+    { inName :: !Name+    , inFields :: ![Field]+    }+    deriving stock (Eq, Show, Generic)++{- | @correlate input.hospitalId via idText@ — the correlation key (hole-kind 1+derivation + hole-kind 4 field-source).+-}+data CorrelateDecl = CorrelateDecl+    { corrField :: !Name+    , corrVia :: !Name+    }+    deriving stock (Eq, Show, Generic)++{- | @saga Surge category \"hospitalSurge\"@ — the saga's own aggregate plus+the validated stream category used with @Keiro.Stream.entityStream@.  For a+correlation id @c@, the saga stream is @<category>-<c>@.+-}+data SagaRef = SagaRef+    { sagaAgg :: !Name+    , sagaCategory :: !Text+    }+    deriving stock (Eq, Show, Generic)++-- | A command dispatch outcome action.+data Disp = DAckOk | DRetry | DDeadLetter !Text+    deriving stock (Eq, Show, Generic)++{- | The complete dispatch disposition table (every arm mandatory; the+@on-duplicate AckOk@ benign inversion is explicit). Named to avoid clashing+with the hole-kind 'Disposition'.+-}+data DispatchDisposition = DispatchDisposition+    { onAppended :: !Disp+    , onDuplicate :: !Disp+    , onFailed :: !Disp+    }+    deriving stock (Eq, Show, Generic)++-- | @advance NoteSurgeThreshold { … }@ — the self-command that advances the saga.+data AdvanceNode = AdvanceNode+    { advCommand :: !Name+    , advFields :: ![FieldBinding]+    }+    deriving stock (Eq, Show, Generic)++-- | @dispatch Hospital\@input.hospitalId ActivateSurge { … } on-appended … on-duplicate … on-failed …@.+data DispatchNode = DispatchNode+    { dispTarget :: !Name+    , dispKey :: !Text+    , dispCommand :: !Name+    , dispFields :: ![FieldBinding]+    , dispDisposition :: !DispatchDisposition+    , dispLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | The @on <Input>@ reaction: a self-advance, zero or more dispatches, and a+@schedule@ of the timer.+-}+data HandleNode = HandleNode+    { hOn :: !Name+    , hAdvance :: !AdvanceNode+    , hDispatch :: ![DispatchNode]+    , hSchedule :: !Name+    }+    deriving stock (Eq, Show, Generic)++-- | A deterministic id derivation: @uuidv5 \"prefix:\" <> correlationId@.+data IdExpr = IdExpr+    { ideStrategy :: !IdStrategy+    , idePrefix :: !Text+    }+    deriving stock (Eq, Show, Generic)++data IdStrategy = UuidV5Id+    deriving stock (Eq, Show, Generic)++{- | @fireAt input.observedAt + 5m@ — an injected timestamp field plus a window.+There is no clock-sampling constructor, so the no-wall-clock rule holds by+construction.+-}+data FireAtExpr = FireAtExpr+    { faField :: !Name+    , faWindow :: !Text+    }+    deriving stock (Eq, Show, Generic)++data FireOutcome = OFired | ORetry+    deriving stock (Eq, Show, Generic)++{- | The complete timer-fire disposition table; @on-reject OFired@ is the benign+inversion (a CommandRejected means \"already applied\" = success).+-}+data FireDisposition = FireDisposition+    { onOk :: !FireOutcome+    , onReject :: !FireOutcome+    , onAmbiguous :: !FireOutcome+    , onError :: !FireOutcome+    , notMine :: !FireOutcome+    }+    deriving stock (Eq, Show, Generic)++-- | @fire dispatch Surge\@correlationId MarkSurgeTimerFired { … } fired-event-id … on-ok …@.+data FireNode = FireNode+    { fireTarget :: !Name+    , fireKey :: !Text+    , fireCommand :: !Name+    , fireFields :: ![FieldBinding]+    , fireFiredEventId :: !IdExpr+    , fireDisposition :: !FireDisposition+    }+    deriving stock (Eq, Show, Generic)++-- | A nested @timer@ sub-node of a process.+data TimerNode = TimerNode+    { tmName :: !Name+    , tmId :: !IdExpr+    , tmFireAt :: !FireAtExpr+    , tmPayload :: ![FieldBinding]+    , tmFire :: !FireNode+    , tmDecodeUnknown :: !Name+    , tmMaxAttempts :: !Int+    , tmDeadLetter :: !Text+    , tmLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- | A node-level worker policy lowered to the runtime worker options.+data PolicyChoice = PolHalt | PolDeadLetter | PolSkip+    deriving stock (Eq, Show, Generic)++{- | A @process@ (process manager / saga) node. The dispatch-id strategy is fixed+(runtime-owned uuidv5), so it is implicit in the AST and always rendered.+-}+data ProcessNode = ProcessNode+    { procId :: !Name+    -- ^ The block identifier (@process HospitalSurge@), used for module names.+    , procName :: !Text+    -- ^ The define-once ProcessManager @name@ (@name \"hospital-surge\"@).+    , procInput :: !InputDecl+    , procCorrelate :: !CorrelateDecl+    , procSaga :: !SagaRef+    , procTarget :: !Name+    , procProjections :: ![Name]+    , procHandle :: !HandleNode+    , procRejected :: !PolicyChoice+    , procPoison :: !PolicyChoice+    , procTimer :: !TimerNode+    , procLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-108: stateless, effectful content-based routing.++data ResolveSource = ResolveReadModel !Name | ResolveHole+    deriving stock (Eq, Show, Generic)++data ResolveDecl = ResolveDecl+    { rvSource :: !ResolveSource+    , rvRow :: ![Name]+    , rvLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++data RouterDispatchNode = RouterDispatchNode+    { rdCommand :: !Name+    , rdFields :: ![FieldBinding]+    , rdDisposition :: !DispatchDisposition+    , rdLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | A stateless router. Its fixed dispatch-id strategy is runtime-owned, and+the mandatory @stable@ token on the resolve clause is an author acknowledgement+that retry attempts accumulate the union of resolved target identities.+-}+data RouterNode = RouterNode+    { rtId :: !Name+    , rtName :: !Text+    , rtInput :: !InputDecl+    , rtKey :: !CorrelateDecl+    , rtResolve :: !ResolveDecl+    , rtTarget :: !Name+    , rtProjections :: ![Name]+    , rtDispatch :: !RouterDispatchNode+    , rtRejected :: !PolicyChoice+    , rtPoison :: !PolicyChoice+    , rtLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-4: the cross-service @contract@ (shared Kafka message schema, define-once).++-- | A contract field type: @typeid \"inc\"@, @text@, or @int@.+data ContractType = CTypeId !Text | CText | CInt+    deriving stock (Eq, Show, Generic)++data ContractField = ContractField+    { cfName :: !Name+    , cfType :: !ContractType+    }+    deriving stock (Eq, Show, Generic)++-- | @event <Name> on <topicAlias> { field: type … }@ within a contract.+data ContractEvent = ContractEvent+    { ceName :: !Name+    , ceTopic :: !Name+    , ceFields :: ![ContractField]+    }+    deriving stock (Eq, Show, Generic)++{- | A @contract@ node: the shared cross-service message schema, declared once+and referenced by both producer (@emit@) and consumer (@intake@). EP-5's+pgmq @dispatch@ also couples to it.+-}+data ContractNode = ContractNode+    { ctrName :: !Name+    , ctrSchemaVersion :: !Int+    , ctrDiscriminator :: !Name+    , ctrTopics :: ![(Name, Text)]+    -- ^ (topic alias, real Kafka topic string)+    , ctrEvents :: ![ContractEvent]+    , ctrLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-4: the @intake@ (Kafka consumer / inbox) node.++-- | Where an envelope field is read from on the wire.+data WireSource+    = SrcHeader !Text+    | SrcBody+    | SrcKafkaKey+    | SrcKafkaCursor+    deriving stock (Eq, Show, Generic)++-- | One envelope-binding row: @bind <field> from <source> [required] [cross-check body]@.+data BindRow = BindRow+    { brField :: !Name+    , brSource :: !WireSource+    , brRequired :: !Bool+    , brCrossCheck :: !Bool+    }+    deriving stock (Eq, Show, Generic)++{- | An inbox outcome action. The dangerous defaults the validator guards: a+@duplicate@\/@previouslyFailed@ must not be 'IRetry'; @decodeFailed@ must not+be an unbounded 'IRetry'.+-}+data InboxAction+    = IAckOk+    | -- | @retry <window>@, e.g. @retry 5s@+      IRetry !Text+    | IDeadLetter !(Maybe Text)+    deriving stock (Eq, Show, Generic)++-- | One row of the mandatory, complete inbox disposition table.+data DispositionRow = DispositionRow+    { drOutcome :: !Name+    , drAction :: !InboxAction+    , drLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- | The body decode-strictness decision (hole-kind 6).+data DecodeSpec = DecodeSpec+    { decEnvelope :: !Text+    -- ^ the envelope policy text, e.g. @strict-required lenient-optional@+    , decBodyStrict :: !Bool+    , decBodySchemaVersion :: !Int+    }+    deriving stock (Eq, Show, Generic)++-- | How much of a successfully processed envelope the inbox retains.+data InkPersist = InkPersistFull | InkPersistDedupeOnly+    deriving stock (Eq, Show, Generic)++{- | An @intake@ (Kafka consumer / inbox) node. The runtime-config @consumer@+block (brokers/groupId/offsetReset) is hole-kind 8, delegated to deployment+and not modelled here.+-}+data IntakeNode = IntakeNode+    { inkName :: !Name+    , inkContract :: !Name+    , inkTopic :: !Name+    , inkAccept :: ![Name]+    , inkBinds :: ![BindRow]+    , inkDedupeKey :: !Name+    , inkDedupePolicy :: !Name+    , inkPersist :: !InkPersist+    , inkDecode :: !DecodeSpec+    , inkDisposition :: ![DispositionRow]+    , inkLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-4: the @emit@ (outbox mapping) and @publisher@ nodes.++-- | A deterministic id derivation hole: @derive [\"prefix\"] hole@.+newtype DeriveSpec = DeriveSpec {dsPrefix :: Maybe Text}+    deriving stock (Eq, Show, Generic)++-- | One @\"value\" => EventType@ row of an emit's status mapping.+data EmitMapRow = EmitMapRow+    { emrValue :: !Text+    , emrEvent :: !Name+    , emrLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | An @emit@ (outbox) node: maps a private status discriminant to contract+event types, with a mandatory explicit @_ => skip@ catch-all.+-}+data EmitNode = EmitNode+    { emName :: !Name+    , emContract :: !Name+    , emTopic :: !Name+    , emSource :: !Text+    , emKey :: !Name+    , emDiscriminant :: !Name+    , emMap :: ![EmitMapRow]+    , emSkip :: !Bool+    -- ^ whether the explicit @_ => skip@ catch-all is present+    , emMessageId :: !DeriveSpec+    , emIdempotencyKey :: !DeriveSpec+    , emLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- | @backoff <kind> <window>@, e.g. @backoff constant 2s@.+data BackoffSpec = BackoffSpec+    { boKind :: !Name+    , boWindow :: !Text+    , boMax :: !(Maybe Text)+    , boMultiplier :: !(Maybe Text)+    }+    deriving stock (Eq, Show, Generic)++-- | A @publisher@ node: the at-least-once publishing policy for an emit's topic.+data PublisherNode = PublisherNode+    { pubName :: !Name+    , pubEmit :: !Name+    , pubOrdering :: !Name+    , pubMaxAttempts :: !Int+    , pubBackoff :: !BackoffSpec+    , pubOutboxField :: !Name+    -- ^ @outboxId stable from <field>@: retries coalesce on (source, this field)+    , pubLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-5: the pgmq @workqueue@ + @dispatch@ nodes.++-- | One @field -> \"wire_name\" type required@ row of a workqueue payload.+data WqField = WqField+    { wqfName :: !Name+    , wqfWire :: !Text+    , wqfType :: !Name+    , wqfRequired :: !Bool+    }+    deriving stock (Eq, Show, Generic)++{- | One row of a workqueue's consumer @JobOutcome@ disposition (reusing+'InboxAction': @retry <window>@ \/ @deadLetter@).+-}+data WqDispRow = WqDispRow+    { wqdOutcome :: !Name+    , wqdAction :: !InboxAction+    , wqdLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- | The queue's semantic delivery-order contract.+data WqOrdering = WqUnordered | WqFifoThroughput | WqFifoRoundRobin+    deriving stock (Eq, Show, Generic)++-- | A FIFO message-group key derived from one payload field.+data WqGroupKey = WqGroupKey+    { gkField :: !Name+    , gkVia :: !Name+    , gkFixture :: !(Maybe Text)+    }+    deriving stock (Eq, Show, Generic)++-- | The PostgreSQL storage shape provisioned for a queue.+data WqProvision+    = WqStandard+    | WqUnlogged+    | WqPartitioned !Text !Text+    deriving stock (Eq, Show, Generic)++{- | A pgmq @workqueue@ node. The @derive@ trio (physical\/dlq\/table) is a+/captured fixture/ (hole-kind 1): the validator re-derives the physical name+from @logical@ and flags any divergence (the drift hazard at the dedup site).+-}+data WorkqueueNode = WorkqueueNode+    { wqName :: !Name+    , wqLogical :: !Text+    , wqPhysical :: !Text+    , wqDlq :: !Text+    , wqTable :: !Text+    , wqOrdering :: !WqOrdering+    , wqGroupKey :: !(Maybe WqGroupKey)+    , wqProvision :: !WqProvision+    , wqPayloadName :: !Name+    , wqPayload :: ![WqField]+    , wqMaxRetries :: !Int+    , wqDelay :: !Text+    , wqDlqOn :: !Bool+    , wqDisposition :: ![WqDispRow]+    , wqLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | A pgmq @dispatch@ node: a read-model→enqueue coupling with a fan-out hole+and a dedup check (one arm of which is a raw-SQL hole).+-}+data PgmqDispatchNode = PgmqDispatchNode+    { pdName :: !Name+    , pdSourceReadModel :: !Name+    , pdSourceKey :: !Name+    , pdFanoutBody :: !Name+    , pdDedupKey :: !Name+    , pdDedupReadModel :: !Name+    , pdDedupReadModelField :: !Text+    , pdDedupQueue :: !Name+    , pdDedupQueueField :: !Text+    , pdEnqueueTo :: !Name+    , pdLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-107: first-class read-model declarations.++-- | One declared SQL column. The validator owns the closed type vocabulary.+data RmColumn = RmColumn+    { rmcName :: !Text+    , rmcType :: !Text+    , rmcRequired :: !Bool+    }+    deriving stock (Eq, Show, Generic)++-- | Whether the model is fed in a command transaction or by a subscription.+data RmFeed = RmInline | RmSubscription+    deriving stock (Eq, Show, Generic)++-- | Which event-log head a strong read waits for.+data RmScope = RmEntireLog | RmCategory !Text+    deriving stock (Eq, Show, Generic)++{- | A registered, versioned SQL read model. Columns define its shape identity;+the runtime table remains owned by codd migrations rather than the DSL.+-}+data ReadModelNode = ReadModelNode+    { rmName :: !Name+    , rmTable :: !Text+    , rmSchema :: !Text+    , rmColumns :: ![RmColumn]+    , rmVersion :: !Int+    , rmShape :: !Text+    , rmConsistency :: !Consistency+    , rmScope :: !(Maybe RmScope)+    , rmFeed :: !RmFeed+    , rmSubscription :: !(Maybe Text)+    , rmLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- EP-6: the durable @workflow@ + @operation@ nodes.++{- | One ordered item of a workflow body. Replay matches on the label, not the+position. (Positional constructors avoid partial record fields.)+-}+data WfBodyItem+    = -- | @step <label> -> <ResultType>@+      WfStep !Name !Name !Loc+    | -- | @await <label> -> <ResultType>@+      WfAwait !Name !Name !Loc+    | -- | @sleep <label> after <injected-delay-field>@ (TIME INJECTED)+      WfSleep !Name !Name !Loc+    | -- | @child <label> id input via <childIdFn> -> <ResultType>@+      WfChild !Name !Name !Name !Loc+    | -- | @patch <patch-id> { <items> }@ — guard items behind a durable patch.+      WfPatch !Name ![WfBodyItem] !Loc+    | -- | @continueAsNew <SeedType>@ — rotate after the terminal top-level item.+      WfContinueAsNew !Name !Loc+    deriving stock (Eq, Show, Generic)++-- | A durable @workflow@ node.+data WorkflowNode = WorkflowNode+    { wfId :: !Name+    -- ^ block identifier (e.g. @HospitalTransferReservation@)+    , wfStable :: !Text+    -- ^ the stable @name "…"@ (journal stream + every deterministic id)+    , wfInput :: !Name+    , wfInputFields :: ![Field]+    , wfOutput :: !Name+    , wfIdField :: !(Maybe Name)+    -- ^ @id from input.<field>@; 'Nothing' for @id from input@+    , wfIdVia :: !Name+    , wfBody :: ![WfBodyItem]+    , wfLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++-- | The four operation shapes.+data OperationShape+    = -- | @command on <Agg> stream from <field> via <fn> project [ … ]@+      CommandOp !Name !Name !Name ![Name]+    | -- | @query <ReadModel> input <T> result <Type> consistency <C>@+      QueryOp !Name !Name !Text !Name+    | -- | @signal <label> of <Workflow> key from <field> via <fn> value <T>@+      SignalOp !Name !Name !Name !Name !Name+    | -- | @run <Workflow> input <T> outcome -> <Result>@+      RunOp !Name !Name !Name+    deriving stock (Eq, Show, Generic)++data OperationNode = OperationNode+    { opName :: !Name+    , opShape :: !OperationShape+    , opLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++{- | A top-level node. EP-1 defines 'NAggregate'; EP-3 adds 'NProcess'; EP-4 adds+'NContract'\/'NIntake'\/'NEmit'\/'NPublisher'; EP-5 adds 'NWorkqueue'\/+'NPgmqDispatch'; EP-6 adds 'NWorkflow'\/'NOperation'; EP-107 adds+'NReadModel'.+-}+data Node+    = NAggregate Aggregate+    | NProcess ProcessNode+    | NRouter RouterNode+    | NContract ContractNode+    | NIntake IntakeNode+    | NEmit EmitNode+    | NPublisher PublisherNode+    | NWorkqueue WorkqueueNode+    | NPgmqDispatch PgmqDispatchNode+    | NReadModel ReadModelNode+    | NWorkflow WorkflowNode+    | NOperation OperationNode+    deriving stock (Eq, Show, Generic)++{- | The module-placement style for a scaffolded service. 'GeneratedPrefix' is+the historical default — @\<root\>.Generated.\<Ctx\>.\<Node\>@ for the generated+layer, holes at @\<root\>.\<Ctx\>.\<Node\>@. 'CollocatedLeaf' places the+generated layer as a leaf under the domain — @\<root\>.\<Ctx\>.\<Node\>.Generated@+— so it sits next to hand-written domain code (holes still at+@\<root\>.\<Ctx\>.\<Node\>@). Defined here (not in "Keiro.Dsl.Scaffold") so the+'Spec' AST can carry an author's standing choice; 'Keiro.Dsl.Scaffold'+re-exports it.+-}+data Placement+    = GeneratedPrefix+    | CollocatedLeaf+    deriving stock (Eq, Show, Generic)++{- | A whole @.keiro@ file: one context name, an optional module-placement+override (the @module@/@layout@ clauses), the shared id/enum/rule declarations,+and the list of nodes. 'specModuleRoot' and 'specLayout' are 'Nothing' when the+spec omits the clauses, reproducing the historical default.+-}+data Spec = Spec+    { specContext :: !Name+    , specModuleRoot :: !(Maybe Text)+    , specLayout :: !(Maybe Placement)+    , specIds :: ![IdDecl]+    , specEnums :: ![EnumDecl]+    , specRules :: ![RuleDecl]+    , specNodes :: ![Node]+    }+    deriving stock (Eq, Show, Generic)
+ src/Keiro/Dsl/Harness.hs view
@@ -0,0 +1,493 @@+{- | The harness engine. From an aggregate spec it emits a @-- \@generated@ test+module that __pins the filled holes' behaviour__ — the project's actual+determinism guarantee, since the scaffolder no longer produces the transducer+body by construction. The emitted module exposes @harnessAssertions ::+[(String, Bool)]@, a list of labelled checks a driver runs (failing on any+@False@, naming the assertion). The checks are:++  1. keiki's @validateTransducer defaultValidationOptions@ on the filled+     transducer is empty (no hidden inputs / nondeterminism / dead edges);+  2. a /clock-free/ assertion baked from the spec (TIME IS INJECTED, NOT+     SAMPLED) — @False@ would mean a guard\/write sampled a wall clock;+  3. a golden wire round-trip per event (@decode . encode == id@);+  4. a behavioural /accept/ check per transition out of the initial state:+     stepping a sample command lands on the declared @goto@ vertex. This is the+     check a wrong guard fails — flipping @./=@ to @.==@ in the filled body turns+     it red while leaving the scaffold untouched.+-}+module Keiro.Dsl.Harness (+    harnessFor,+    harnessProcess,+    harnessRouter,+    harnessReadModel,+    harnessWorkflow,+) where++import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.ReadModelShape (deriveShapeHash, registryNameFor, subscriptionNameFor)+import Keiro.Dsl.Scaffold++{- | Emit the harness test module for one aggregate. Like 'scaffoldAggregate',+it takes the 'Spec' for the shared id\/enum declarations.+-}+harnessFor :: Context -> Spec -> Aggregate -> [ScaffoldModule]+harnessFor ctx spec agg =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/Harness.hs")+        , moduleText = emitHarness a+        , kind = Generated+        , origin = "aggregate " <> aggName agg <> locSuffix (aggLoc agg)+        }+    ]+  where+    a = resolveAgg ctx spec agg++{- | Emit a self-contained, firewall-clean facts harness for a process manager,+pinning the spec's deterministic decisions: the time-injection formula, the+deterministic timer-id and fired-event-id derivation strings, the runtime-owned+dispatch-id (no user id), and the dispatch\/fire disposition tables (incl. the+@on-reject => Fired@ benign inversion). It exposes+@processHarnessFacts :: [(String, Bool)]@ over pure values, so it compiles and+runs without the effectful\/hasql runtime. (Behavioural conformance of the+/filled/ ProcessManager against the live runtime is the M5 step.)+-}+harnessProcess :: Context -> ProcessNode -> [ScaffoldModule]+harnessProcess ctx p =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/ProcessHarness.hs")+        , moduleText = emitProcessHarness genPrefix p+        , kind = Generated+        , origin = "process " <> procId p <> locSuffix (procLoc p)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (procId p)++{- | Emit runtime-free facts for a router's identity, resolution, dispatch,+and worker-policy decisions. A hand-written conformance driver owns the+expected values so a spec mutation turns one focused assertion red.+-}+harnessRouter :: Context -> RouterNode -> [ScaffoldModule]+harnessRouter ctx router =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/RouterHarness.hs")+        , moduleText = emitRouterHarness genPrefix router+        , kind = Generated+        , origin = "router " <> rtId router <> locSuffix (rtLoc router)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (rtId router)++emitRouterHarness :: Text -> RouterNode -> Text+emitRouterHarness genPrefix router =+    nl+        [ generatedBanner+        , "module " <> genPrefix <> ".RouterHarness (routerHarnessValues) where"+        , ""+        , "routerHarnessValues :: [(String, String)]"+        , "routerHarnessValues ="+        , "  [ (\"routerName\", " <> hs (rtName router) <> ")"+        , "  , (\"keyField\", " <> hs (corrField (rtKey router)) <> ")"+        , "  , (\"resolveSource\", " <> hs resolveSource <> ")"+        , "  , (\"resolveRow\", " <> hs (T.intercalate "," (rvRow (rtResolve router))) <> ")"+        , "  , (\"dispatchCommand\", " <> hs (rdCommand dispatch) <> ")"+        , "  , (\"dispatchIdInputs\", \"(name, key, sourceEventId, targetStreamName, occurrence)\")"+        , "  , (\"onDuplicate\", " <> hs (showDisp (onDuplicate disposition)) <> ")"+        , "  , (\"onFailed\", " <> hs (showDisp (onFailed disposition)) <> ")"+        , "  , (\"rejectedPolicy\", " <> hs (showPolicy (rtRejected router)) <> ")"+        , "  , (\"poisonPolicy\", " <> hs (showPolicy (rtPoison router)) <> ")"+        , "  ]"+        ]+  where+    hs = tshow+    dispatch = rtDispatch router+    disposition = rdDisposition dispatch+    resolveSource = case rvSource (rtResolve router) of+        ResolveReadModel name -> "read-model " <> name+        ResolveHole -> "hole"++{- | Emit runtime-free facts for a read-model node. Each row records the value+expected directly from the notation next to the value produced by the shared+derivation helpers. Committed conformance expectations pin the lowered values,+while a shape-fixture drift makes the generated harness itself fail.+-}+harnessReadModel :: Context -> ReadModelNode -> [ScaffoldModule]+harnessReadModel ctx readModel =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/ReadModelHarness.hs")+        , moduleText = emitReadModelHarness genPrefix ctx readModel+        , kind = Generated+        , origin = "readmodel " <> rmName readModel <> locSuffix (rmLoc readModel)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (pascal (rmName readModel))++emitReadModelHarness :: Text -> Context -> ReadModelNode -> Text+emitReadModelHarness genPrefix ctx readModel =+    nl+        [ generatedBanner+        , "module " <> genPrefix <> ".ReadModelHarness (readModelFacts, runReadModelFacts) where"+        , ""+        , "-- | (fact, expected from notation, actual shared derivation/lowering)."+        , "readModelFacts :: [(String, String, String)]"+        , "readModelFacts ="+        , "  [ (\"registryName\", " <> tshow expectedRegistry <> ", " <> tshow actualRegistry <> ")"+        , "  , (\"subscriptionName\", " <> tshow expectedSubscription <> ", " <> tshow actualSubscription <> ")"+        , "  , (\"shapeHash\", " <> tshow (rmShape readModel) <> ", " <> tshow (deriveShapeHash readModel) <> ")"+        , "  , (\"asyncProjectionName\", " <> tshow expectedAsync <> ", " <> tshow actualAsync <> ")"+        , "  , (\"consistency\", " <> tshow consistency <> ", " <> tshow consistency <> ")"+        , "  , (\"strongScope\", " <> tshow scope <> ", " <> tshow scope <> ")"+        , "  ]"+        , ""+        , "runReadModelFacts :: IO Bool"+        , "runReadModelFacts = do"+        , "  let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]"+        , "  mapM_ (\\(fact, expected, actual) -> putStrLn (\"FAIL  \" <> fact <> \" expected=\" <> show expected <> \" actual=\" <> show actual)) failures"+        , "  pure (null failures)"+        ]+  where+    expectedRegistry = contextName ctx <> "-" <> T.replace "_" "-" (rmName readModel)+    actualRegistry = registryNameFor (contextName ctx) readModel+    expectedSubscription = case rmSubscription readModel of+        Just name -> name+        Nothing -> expectedRegistry <> "-sub"+    actualSubscription = subscriptionNameFor (contextName ctx) readModel+    expectedAsync = case rmFeed readModel of+        RmInline -> "none"+        RmSubscription -> expectedRegistry <> "-async"+    actualAsync = case rmFeed readModel of+        RmInline -> "none"+        RmSubscription -> actualRegistry <> "-async"+    consistency = case rmConsistency readModel of+        Strong -> "Strong"+        Eventual -> "Eventual"+    scope = case rmScope readModel of+        Nothing -> "EntireLog"+        Just RmEntireLog -> "EntireLog"+        Just (RmCategory categoryName) -> "CategoryHead " <> categoryName++emitProcessHarness :: Text -> ProcessNode -> Text+emitProcessHarness genPrefix p =+    nl+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".ProcessHarness (processHarnessValues) where"+        , ""+        , "{- | (label, value): the spec's deterministic process/timer decisions,"+        , "lowered to plain values so a driver can assert them against a committed"+        , "expectation. The driver's expectation is hand-written (not generated), so a"+        , "spec change that alters a decision diverges from it and turns a specific"+        , "assertion red — the spec->behaviour pin. (Live-runtime behavioural"+        , "conformance of the filled ProcessManager is the M5 step.)"+        , "-}"+        , "processHarnessValues :: [(String, String)]"+        , "processHarnessValues ="+        , "  [ (\"fireAtField\", " <> hs (faField (tmFireAt timer)) <> ")"+        , "  , (\"timerIdPrefix\", " <> hs (idePrefix (tmId timer)) <> ")"+        , "  , (\"firedEventIdPrefix\", " <> hs (idePrefix (fireFiredEventId timer')) <> ")"+        , "  , (\"dispatchIdUserField\", \"none\")"+        , "  , (\"onReject\", " <> hs (showFireOutcome (onReject fd)) <> ")"+        , "  , (\"onAmbiguous\", " <> hs (showFireOutcome (onAmbiguous fd)) <> ")"+        , "  , (\"onFailed\", " <> hs (showDisp (onFailed (firstDispDisposition p))) <> ")"+        , "  , (\"rejectedPolicy\", " <> hs (showPolicy (procRejected p)) <> ")"+        , "  , (\"poisonPolicy\", " <> hs (showPolicy (procPoison p)) <> ")"+        , "  , (\"maxAttempts\", " <> hs (tInt (tmMaxAttempts timer)) <> ")"+        , "  ]"+        ]+  where+    timer = procTimer p+    timer' = tmFire timer+    fd = fireDisposition timer'+    hs = tshow++firstDispDisposition :: ProcessNode -> DispatchDisposition+firstDispDisposition p = case hDispatch (procHandle p) of+    (d : _) -> dispDisposition d+    [] -> DispatchDisposition DAckOk DAckOk DRetry++showFireOutcome :: FireOutcome -> Text+showFireOutcome OFired = "Fired"+showFireOutcome ORetry = "Retry"++showDisp :: Disp -> Text+showDisp DAckOk = "AckOk"+showDisp DRetry = "Retry"+showDisp (DDeadLetter _) = "DeadLetter"++showPolicy :: PolicyChoice -> Text+showPolicy PolHalt = "halt"+showPolicy PolDeadLetter = "deadLetter"+showPolicy PolSkip = "skip"++{- | A self-contained, firewall-clean facts harness for a durable workflow,+pinning the spec's deterministic decisions: the stable name, the WorkflowId+derivation, the ordered body (step/await/sleep/child by label), and the await+labels (whose ids the signal operations must match). Exposes+@workflowFacts :: [(String, String)]@ so a driver asserts them against a+hand-written expectation — a spec change (e.g. renaming an await label) diverges+and reddens a specific assertion. Workflows intentionally have no domain scaffold+or hole stub: their behaviour-bearing body remains hand-written, while these facts+and the live-runtime module pin its declared structure.+-}+harnessWorkflow :: Context -> WorkflowNode -> [ScaffoldModule]+harnessWorkflow ctx w =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowFacts.hs")+        , moduleText = emitWorkflowFacts genPrefix w+        , kind = Generated+        , origin = "workflow " <> wfId w <> locSuffix (wfLoc w)+        }+    , ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowRuntime.hs")+        , moduleText = emitWorkflowRuntime genPrefix w+        , kind = Generated+        , origin = "workflow " <> wfId w <> locSuffix (wfLoc w)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (wfId w)++locSuffix :: Loc -> Text+locSuffix loc = case unLoc loc of+    0 -> ""+    line -> " (line " <> tInt line <> ")"++emitWorkflowFacts :: Text -> WorkflowNode -> Text+emitWorkflowFacts genPrefix w =+    nl+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".WorkflowFacts (workflowFacts) where"+        , ""+        , "{- | (label, value): the workflow's deterministic decisions, pinned as pure"+        , "facts. A driver asserts them against a hand-written expectation, so a spec"+        , "change (e.g. renaming an await) reddens a specific assertion."+        , "-}"+        , "workflowFacts :: [(String, String)]"+        , "workflowFacts ="+        , "  [ (\"name\", " <> hs (wfStable w) <> ")"+        , "  , (\"idVia\", " <> hs (wfIdVia w) <> ")"+        , "  , (\"idField\", " <> hs (maybe "input" id (wfIdField w)) <> ")"+        , "  , (\"body\", " <> hs (T.intercalate "," (map bodyTag (wfBody w))) <> ")"+        , "  , (\"awaits\", " <> hs (T.intercalate "," (workflowAwaitLabels (wfBody w))) <> ")"+        , "  , (\"patches\", " <> hs (T.intercalate "," (workflowPatchIds (wfBody w))) <> ")"+        , "  ]"+        ]+  where+    hs = tshow+    bodyTag (WfStep l _ _) = "step:" <> l+    bodyTag (WfAwait l _ _) = "await:" <> l+    bodyTag (WfSleep l _ _) = "sleep:" <> l+    bodyTag (WfChild l _ _ _) = "child:" <> l+    bodyTag (WfPatch patchId items _) = "patch:" <> patchId <> "(" <> T.intercalate "," (map bodyTag items) <> ")"+    bodyTag (WfContinueAsNew seedType _) = "continueAsNew:" <> seedType++{- | Emit the workflow's deterministic id derivation compiled against the LIVE+@Keiro.Workflow@: the 'WorkflowName' and the awakeable-id function (the actual+'deterministicAwakeableId'). A signal operation deriving the SAME (name, id,+label) lands on the same 'AwakeableId' — so this module compiling + the+conformance comparing the two sides proves the await↔signal coupling holds over+the real runtime function, not just by label-string equality.+-}+emitWorkflowRuntime :: Text -> WorkflowNode -> Text+emitWorkflowRuntime genPrefix w =+    nl $+        [ "{-# LANGUAGE ImportQualifiedPost #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".WorkflowRuntime"+        , "  ( workflowName"+        , "  , awaitAwakeableId"+        , "  , awaitLabels"+        , "  , declaredPatches"+        , "  , declaredPatchStepNames"+        , "  , withDeclaredPatches"+        , "  ) where"+        , ""+        , "import Data.Set (Set)"+        , "import Data.Set qualified as Set"+        , "import Data.Text (Text)"+        , "import Keiro.Workflow (WorkflowRunOptions (..))"+        , "import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)"+        , "import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)"+        , ""+        , "workflowName :: WorkflowName"+        , "workflowName = WorkflowName " <> tshow (wfStable w)+        , ""+        , "-- The awakeable id an await allocates — the real deterministicAwakeableId."+        , "-- A signal op deriving the same (name, id, label) gets the same id."+        , "awaitAwakeableId :: WorkflowId -> Text -> AwakeableId"+        , "awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label"+        , ""+        , "awaitLabels :: [Text]"+        , "awaitLabels = [" <> T.intercalate ", " (map tshow (workflowAwaitLabels (wfBody w))) <> "]"+        , ""+        , "declaredPatches :: Set PatchId"+        , "declaredPatches = Set.fromList [" <> T.intercalate ", " ["PatchId " <> tshow patchId | patchId <- workflowPatchIds (wfBody w)] <> "]"+        , ""+        , "-- The journal keys the runtime records patch decisions under."+        , "declaredPatchStepNames :: [Text]"+        , "declaredPatchStepNames = map patchStepName (Set.toList declaredPatches)"+        , ""+        , "-- Activate exactly the patches declared by this spec for a workflow run."+        , "withDeclaredPatches :: WorkflowRunOptions -> WorkflowRunOptions"+        , "withDeclaredPatches opts = opts{activePatches = declaredPatches}"+        ]++workflowAwaitLabels :: [WfBodyItem] -> [Name]+workflowAwaitLabels = concatMap go+  where+    go (WfAwait label _ _) = [label]+    go (WfPatch _ items _) = workflowAwaitLabels items+    go _ = []++workflowPatchIds :: [WfBodyItem] -> [Name]+workflowPatchIds = concatMap go+  where+    go (WfPatch patchId items _) = patchId : workflowPatchIds items+    go _ = []++emitHarness :: Agg -> Text+emitHarness a =+    nl $+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where"+        , ""+        , "import " <> aGenPrefix a <> ".Domain"+        , "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> ")"+        , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst nm <> "Transducer)"+        , "import Keiki.Core (defaultValidationOptions, step, validateTransducer)"+        , codecDecodeRawImport+        , ""+        , "{- | (label, passed). A driver runs these and exits non-zero on any False,"+        , "naming the failing assertion. Filling a hole wrongly turns a specific"+        , "entry False; the scaffold cannot."+        , "-}"+        , "harnessAssertions :: [(String, Bool)]"+        , "harnessAssertions ="+        , "  [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))"+        , "  , (\"clock-free: spec samples no wall clock\", " <> clockFreeLit <> ")"+        ]+            ++ [ "  , (\"golden round-trip: " <> rcName e <> "\", roundTrips sampleEvent" <> rcName e <> ")"+               | e <- aEvents a+               ]+            ++ [ "  , (\"accepts " <> tCommand t <> " from " <> initialVertex a <> "\", accept" <> tCommand t <> ")"+               | t <- initialTransitions a+               ]+            ++ [ "  , (\"upcaster wired: a v" <> tInt m <> " " <> rcName e <> " payload decodes through the chain\", upcasts" <> rcName e <> ")"+               | e <- upcastEvents+               , Just m <- [rcUpcastFrom e]+               ]+            ++ [ "  ]"+               , ""+               , "roundTrips :: " <> nm <> "Event -> Bool"+               , "roundTrips e = parse" <> nm <> "Event (eventType " <> lowerFirst nm <> "Codec e) (encode" <> nm <> "Event e) == Right e"+               ]+            ++ concatMap (sampleEventDecl a) (aEvents a)+            ++ concatMap (acceptDecl a) (initialTransitions a)+            ++ concatMap (upcastDecl a) upcastEvents+  where+    nm = aName a+    -- Bake the clock-free result computed from the spec at scaffold time.+    clockFreeLit = if specIsClockFree a then "True" else "False"+    upcastEvents = [e | e <- aEvents a, rcUpcastFrom e /= Nothing]+    codecValueImport = ", " <> lowerFirst nm <> "Codec"+    codecDecodeRawImport =+        if null upcastEvents+            then "import Keiro.Codec (eventType)"+            else "import Keiro.Codec (EventType (..), decodeRaw, eventType)"++{- | A wiring-proof assertion: feed a current-shape payload tagged at the+upcaster's source version through @decodeRaw@, which runs the upcaster chain+then @decode@. Red while the upcaster hole returns @Left@; green once filled.+(The grammar records only the current event shape, not the per-version field+delta, so this proves the chain is wired and the hole must be filled rather+than re-deriving the exact old payload.)+-}+upcastDecl :: Agg -> ResolvedCtor -> [Text]+upcastDecl a e = case rcUpcastFrom e of+    Nothing -> []+    Just m ->+        [ ""+        , "upcasts" <> rcName e <> " :: Bool"+        , "upcasts" <> rcName e <> " ="+        , "  either (const False) (const True)"+        , "    (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " (encode" <> aName a <> "Event sampleEvent" <> rcName e <> "))"+        ]++tInt :: Int -> Text+tInt = T.pack . show++-- | Render a Text as a Haskell string literal (quoted, escaped).+tshow :: Text -> Text+tshow = T.pack . show++nl :: [Text] -> Text+nl = T.intercalate "\n"++specIsClockFree :: Agg -> Bool+specIsClockFree a = not (any transitionSamplesClock (aTransitions a))+  where+    clockAtoms = ["now", "currentTime", "wallClock", "today", "utcNow"]+    transitionSamplesClock t =+        let exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)+         in any (\e -> any (`elem` clockAtoms) (exprNames e)) exprs++exprNames :: Expr -> [Text]+exprNames (EOr x y) = exprNames x ++ exprNames y+exprNames (EAnd x y) = exprNames x ++ exprNames y+exprNames (ECmp _ x y) = exprNames x ++ exprNames y+exprNames (EAtom (AName n)) = [n]+exprNames (EAtom (ABool _)) = []++initialTransitions :: Agg -> [Transition]+initialTransitions a = case map stName (aStates a) of+    (s0 : _) -> [t | t <- aTransitions a, tSource t == s0]+    [] -> []++{- | @sampleEvent<Ctor> :: <Agg>Event@ — a sample built from per-field sample+values (enum→first constructor, Bool→False, id→placeholder, Text→\"sample\").+-}+sampleEventDecl :: Agg -> ResolvedCtor -> [Text]+sampleEventDecl a e =+    [ ""+    , "sampleEvent" <> rcName e <> " :: " <> aName a <> "Event"+    , "sampleEvent" <> rcName e <> " = " <> ctorExpr a e+    ]++acceptDecl :: Agg -> Transition -> [Text]+acceptDecl a t =+    [ ""+    , "accept" <> tCommand t <> " :: Bool"+    , "accept" <> tCommand t <> " ="+    , "  case step " <> lowerFirst (aName a) <> "Transducer (" <> initialVertex a <> ", initial" <> aName a <> "Regs) " <> cmdSample <> " of"+    , "    Just (v, _, _) -> v == " <> vertexCtor a (tGoto t)+    , "    Nothing -> False"+    ]+  where+    cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of+        (c : _) -> "(" <> ctorExpr a c <> ")"+        [] -> "(error \"no command\")"++-- | @(<Ctor> (<Ctor>Data v1 v2 …))@ with positional sample field values.+ctorExpr :: Agg -> ResolvedCtor -> Text+ctorExpr a rc =+    "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))"+  where+    args = T.concat [" " <> sampleValue a ty | (_, ty) <- rcFields rc]++sampleValue :: Agg -> Text -> Text+sampleValue a ty = case fieldCat a ty of+    IdCat -> "(" <> ty <> " \"sample\")"+    EnumCat -> maybe ("(error \"no enum ctor\")") id (firstEnumCtor a ty)+    OtherCat+        | ty == "Bool" -> "False"+        | ty == "Int" -> "0"+        | ty == "Text" -> "\"sample\""+        | ty == aVertexType a -> initialVertex a+        | otherwise -> "(error \"sample: unsupported type " <> ty <> "\")"
+ src/Keiro/Dsl/Manifest.hs view
@@ -0,0 +1,89 @@+{- | The build-wiring __manifest__: a Cabal-pasteable summary of what a+@scaffold@ run produced. @scaffold@ writes @.hs@ files but the consumer still+has to wire them into a Cabal stanza by hand — the @other-modules@ list and the+@build-depends@ implied by the node kinds. This module renders both as plain+text a human pastes into a @.cabal@ file (see @keiro-dsl/keiro-dsl.cabal@'s+conformance stanzas for the hand-maintained version this replaces).++The dependency set is a pure function of which 'Node' constructors occur in the+spec. The mapping is grounded in the existing per-suite @build-depends@ in+@keiro-dsl/keiro-dsl.cabal@:++  * aggregate           => aeson, keiki, keiro, text     (keiro-dsl-conformance)+  * process             => aeson, keiki, keiro, shibuya-core, text, time, uuid+                                                         (…-process-runtime)+  * contract            => aeson, text                   (…-contract)+  * intake/emit/publisher (full integration path)+                        => effectful-core, hasql-transaction, keiro, kiroku-store+                                                         (…-intake-full)+  * workqueue           => aeson, keiro-pgmq, text       (…-queue, …-queue-runtime)+  * dispatch            => aeson, effectful-core, keiro-pgmq, text+                                                         (…-dispatch-full)+  * workflow/operation  => containers, effectful-core, keiro, text+                            (…-workflow-full; facts and runtime wiring only,+                             with the body hand-owned)++@base@ is always present.+-}+module Keiro.Dsl.Manifest (+    renderManifest,+    manifestDependencies,+    moduleNameOf,+) where++import Data.List (nub, sort)+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.Scaffold (ScaffoldModule (..))++{- | Render a Cabal-pasteable manifest from the modules a scaffold run produced+plus the node kinds present (which imply the dependency set). The first argument+names the source spec (for the header comment).+-}+renderManifest :: Text -> [ScaffoldModule] -> Spec -> Text+renderManifest specName mods spec =+    T.unlines $+        [ "-- keiro-dsl build manifest for " <> specName+        , "-- Paste the two blocks below into the consuming Cabal stanza."+        , "-- The generated layer is overwritten on every scaffold; hole modules are"+        , "-- create-if-absent (filled by hand)."+        , ""+        , "other-modules:"+        ]+            ++ map ("    " <>) (sort (map (moduleNameOf . modulePath) mods))+            ++ [ ""+               , "build-depends:"+               ]+            ++ map ("    , " <>) (manifestDependencies spec)++{- | The dotted module name recovered from a 'ScaffoldModule' path: drop the+trailing @.hs@ and replace @/@ with @.@.+-}+moduleNameOf :: FilePath -> Text+moduleNameOf p = T.replace "/" "." (T.dropEnd 3 (T.pack p))++{- | The sorted, deduplicated dependency set implied by the node kinds present+in the spec. @base@ is always included.+-}+manifestDependencies :: Spec -> [Text]+manifestDependencies spec =+    sort (nub ("base" : concatMap depsForNode (specNodes spec)))++-- | The dependencies a single node kind implies (see the module header table).+depsForNode :: Node -> [Text]+depsForNode n = case n of+    NAggregate{} -> ["aeson", "keiki", "keiro", "text"]+    NProcess{} -> ["aeson", "keiki", "keiro", "shibuya-core", "text", "time", "uuid"]+    NRouter{} -> ["effectful-core", "keiro", "shibuya-core", "text"]+    NContract{} -> ["aeson", "text"]+    NIntake{} -> integration+    NEmit{} -> integration+    NPublisher{} -> integration+    NWorkqueue{} -> ["aeson", "keiro-pgmq", "text"]+    NPgmqDispatch{} -> ["aeson", "effectful-core", "keiro-pgmq", "text"]+    NReadModel{} -> ["effectful-core", "hasql-transaction", "keiro", "kiroku-store", "text"]+    NWorkflow{} -> ["containers", "effectful-core", "keiro", "text"]+    NOperation{} -> ["effectful-core", "keiro", "text"]+  where+    integration = ["effectful-core", "hasql-transaction", "keiro", "kiroku-store"]
+ src/Keiro/Dsl/Parser.hs view
@@ -0,0 +1,1543 @@+{- | The megaparsec parser for the keiro DSL. Turns @.keiro@ text into the typed+'Spec' AST. The notation is keyword-driven: newlines and @#@-comments are+whitespace, structure comes from keywords (@aggregate@, @regs@, @states@,+@command@, @event@, @wire@, @projection@) and the transition arrow+@Src -- Command --> clauses@. Guards and write right-hand sides are parsed as+a typed 'Expr' (never an opaque string) so the validator can scope-check them.+-}+module Keiro.Dsl.Parser (+    ParseError,+    parseSpec,+    parseSpecText,+)+where++import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)+import Data.Char (isAlpha, isAlphaNum, isAscii, isDigit, isUpper)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void (Void)+import Keiro.Dsl.Grammar+import Text.Megaparsec hiding (ParseError)+import Text.Megaparsec.Char (char, digitChar, letterChar, space1)+import Text.Megaparsec.Char.Lexer qualified as L++-- | A rendered, line-numbered parse error, ready to print to the user.+type ParseError = Text++type P = Parsec Void Text++{- | Parse a @.keiro@ source. The 'FilePath' is used only as the source name in+diagnostics (megaparsec's line/column reporting); it need not exist on disk.+This is the canonical signature shared across all keiro-dsl plans.+-}+parseSpec :: FilePath -> Text -> Either ParseError Spec+parseSpec src input =+    case runParser (sc *> pSpec <* eof) src input of+        Left bundle -> Left (T.pack (errorBundlePretty bundle))+        Right spec -> Right spec++-- | Convenience wrapper for callers without a source name (tests, stdin).+parseSpecText :: Text -> Either ParseError Spec+parseSpecText = parseSpec "<input>"++--------------------------------------------------------------------------------+-- Lexer+--------------------------------------------------------------------------------++-- | Space consumer: spaces, newlines, and @#@ line comments are all whitespace.+sc :: P ()+sc = L.space space1 (L.skipLineComment "#") empty++lexeme :: P a -> P a+lexeme = L.lexeme sc++symbol :: Text -> P Text+symbol = L.symbol sc++{- | A reserved keyword: the literal word not followed by an identifier+character (so @goto@ matches @goto@ but not @gotoX@).+-}+keyword :: Text -> P ()+keyword w = (lexeme . try) (string' w *> notFollowedBy (identChar <|> (char '-' *> identChar)))+  where+    string' = chunk++identChar :: P Char+identChar = asciiAlphaNum <|> char '_'++asciiLetter :: P Char+asciiLetter = satisfy (\c -> isAscii c && isAlpha c)++asciiUpper :: P Char+asciiUpper = satisfy (\c -> isAscii c && isUpper c)++asciiDigit :: P Char+asciiDigit = satisfy (\c -> isAscii c && isDigit c)++asciiAlphaNum :: P Char+asciiAlphaNum = satisfy (\c -> isAscii c && isAlphaNum c)++-- | Fail with the diagnostic caret placed at a previously captured offset.+failAt :: Int -> String -> P a+failAt offset message = region (setErrorOffset offset) (fail message)++{- | Parse a decimal as an unbounded Integer, then reject values that cannot be+represented as Int. Parsing L.decimal directly at Int silently wraps.+-}+boundedDecimal :: P Int+boundedDecimal = do+    offset <- getOffset+    value <- lexeme (L.decimal :: P Integer)+    checkedDecimal offset value++checkedDecimal :: Int -> Integer -> P Int+checkedDecimal offset value+    | value > fromIntegral (maxBound :: Int) =+        failAt+            offset+            ( "decimal literal "+                <> show value+                <> " is out of range (maximum "+                <> show (maxBound :: Int)+                <> ")"+            )+    | otherwise = pure (fromIntegral value)++{- | Words that may not be used as bare identifiers, because they introduce a+different construct and would otherwise be swallowed (e.g. @aggregate@ ending+one node and beginning the next).+-}+reservedWords :: [Text]+reservedWords =+    [ "context"+    , "module"+    , "layout"+    , "prefixed"+    , "collocated"+    , "id"+    , "enum"+    , "rule"+    , "ex"+    , "aggregate"+    , "regs"+    , "states"+    , "command"+    , "event"+    , "wire"+    , "projection"+    , "snapshot"+    , "category"+    , "guard"+    , "write"+    , "emit"+    , "goto"+    , "fields"+    , "status-map"+    , "true"+    , "false"+    , "deprecated"+    , "upcast"+    , "from"+    , "HOLE"+    , "process"+    , "router"+    , "dispatch-each"+    , "resolve"+    , "read-model"+    , "dispatch"+    , -- EP-4 integration: structural keywords never used as identifiers, so a+      -- list like @accept A B C@ stops at the next block keyword.+      "intake"+    , "contract"+    , "topic"+    , "accept"+    , "bind"+    , "dedupe"+    , "persist"+    , "decode"+    , "disposition"+    , "publisher"+    , "map"+    , -- EP-5 pgmq structural keywords.+      "workqueue"+    , "queue"+    , "payload"+    , "retry"+    , "fanout"+    , "dedup"+    , "enqueue"+    , "seenIn"+    , -- EP-6 workflow/operation: reserved so the multi-word result-type parse and+      -- node boundaries don't swallow the next block keyword.+      "workflow"+    , "operation"+    , "consistency"+    , "body"+    , "step"+    , "await"+    , "sleep"+    , "child"+    , "patch"+    , "continueAsNew"+    , -- EP-107 read-model structural words. Clause labels such as table and+      -- schema remain usable identifiers because their block parser consumes+      -- them with symbol-style matching.+      "readmodel"+    , "columns"+    , "feed"+    , "scope"+    , "shape"+    ]++{- | A CamelCase / snake_case identifier (no dashes): type names, register+names, command\/event\/state names, enum constructors, projection keys.+-}+ident :: P Name+ident = (lexeme . try) $ do+    c <- asciiLetter <|> char '_'+    cs <- many identChar+    let w = T.pack (c : cs)+    if w `elem` reservedWords+        then fail ("unexpected reserved word " <> T.unpack w)+        else pure w++{- | A wire-spelling token, which may contain dashes (@partial-divert@,+@hospital-capacity@). Used for the context name, id prefixes, enum wire+spellings, and status-map values.+-}+wireWord :: P Text+wireWord = lexeme $ do+    c <- asciiLetter <|> asciiDigit+    cs <- many (identChar <|> char '-')+    pure (T.pack (c : cs))++{- | Patch ids use wire-word spelling, but admit @:@ so the validator can emit+the domain-specific 'WorkflowPatchIdInvalid' diagnostic at the owning item.+-}+patchIdWord :: P Text+patchIdWord = lexeme $ do+    c <- asciiLetter <|> asciiDigit+    cs <- many (identChar <|> char '-' <|> char ':')+    pure (T.pack (c : cs))++getLoc :: P Loc+getLoc = (Loc . unPos . sourceLine) <$> getSourcePos++--------------------------------------------------------------------------------+-- Top level+--------------------------------------------------------------------------------++data TopItem+    = TIId IdDecl+    | TIEnum EnumDecl+    | TIRule RuleDecl+    | TINode Node++pSpec :: P Spec+pSpec = do+    keyword "context"+    ctx <- wireWord+    mroot <- optional pModuleClause+    mlayout <- optional pLayoutClause+    items <- many pTopItem+    pure+        Spec+            { specContext = ctx+            , specModuleRoot = mroot+            , specLayout = mlayout+            , specIds = [d | TIId d <- items]+            , specEnums = [d | TIEnum d <- items]+            , specRules = [d | TIRule d <- items]+            , specNodes = [n | TINode n <- items]+            }++-- | @module Acme.Services@ — the optional namespace-prefix clause.+pModuleClause :: P Text+pModuleClause = keyword "module" *> pModulePrefix++-- | @layout (prefixed|collocated)@ — the optional placement-style clause.+pLayoutClause :: P Placement+pLayoutClause =+    keyword "layout"+        *> choice+            [ GeneratedPrefix <$ keyword "prefixed"+            , CollocatedLeaf <$ keyword "collocated"+            ]++{- | A dotted module prefix: one-or-more PascalCase segments joined by dots,+e.g. @Acme@ or @Acme.Services@.+-}+pModulePrefix :: P Text+pModulePrefix = lexeme $ do+    seg0 <- pSeg+    segs <- many (char '.' *> pSeg)+    pure (T.intercalate "." (seg0 : segs))+  where+    pSeg = do+        c <- asciiUpper+        cs <- many identChar+        pure (T.pack (c : cs))++pTopItem :: P TopItem+pTopItem =+    choice+        [ TIId <$> pIdDecl+        , TIEnum <$> pEnumDecl+        , TIRule <$> pRuleDecl+        , TINode . NRouter <$> pRouter+        , TINode . NProcess <$> pProcess+        , TINode . NContract <$> pContract+        , TINode . NIntake <$> pIntake+        , TINode . NEmit <$> pEmit+        , TINode . NPublisher <$> pPublisher+        , TINode . NWorkqueue <$> pWorkqueue+        , TINode . NPgmqDispatch <$> pPgmqDispatch+        , TINode . NReadModel <$> pReadModel+        , TINode . NWorkflow <$> pWorkflow+        , TINode . NOperation <$> pOperation+        , TINode . NAggregate <$> pAggregate+        ]++pIdDecl :: P IdDecl+pIdDecl = do+    loc <- getLoc+    keyword "id"+    name <- ident+    _ <- symbol "prefix"+    _ <- symbol "="+    pfx <- wireWord+    pure IdDecl{idName = name, idPrefix = pfx, idLoc = loc}++pEnumDecl :: P EnumDecl+pEnumDecl = do+    loc <- getLoc+    keyword "enum"+    name <- ident+    ctors <- braces (many pEnumCtor)+    pure EnumDecl{enumName = name, enumCtors = ctors, enumLoc = loc}+  where+    pEnumCtor = do+        c <- ident+        _ <- symbol "="+        w <- wireWord+        pure (c, w)++pRuleDecl :: P RuleDecl+pRuleDecl = do+    loc <- getLoc+    keyword "rule"+    name <- ident+    _ <- symbol ":"+    dom <- ident+    _ <- symbol "->"+    cod <- ident+    keyword "ex"+    cases <- sepBy1 pCase (symbol ";")+    pure+        RuleDecl+            { ruleName = name+            , ruleDomain = dom+            , ruleCodomain = cod+            , ruleCases = cases+            , ruleLoc = loc+            }+  where+    pCase = do+        c <- ident+        _ <- symbol "=>"+        e <- pExpr+        pure (c, e)++--------------------------------------------------------------------------------+-- Aggregate node+--------------------------------------------------------------------------------++data BodyItem+    = BICommand Command+    | BIEvent Event+    | BIWire WireSpec+    | BIProjection ProjectionSpec+    | BISnapshot SnapshotSpec+    | BITransition Transition++pAggregate :: P Aggregate+pAggregate = do+    loc <- getLoc+    keyword "aggregate"+    name <- ident+    regs <- pRegsBlock+    states <- pStatesLine+    positionedItems <- many ((,) <$> getOffset <*> pBodyItem)+    let items = map snd positionedItems+        wireOffsets = [offset | (offset, BIWire _) <- positionedItems]+        projectionOffsets = [offset | (offset, BIProjection _) <- positionedItems]+        snapshotOffsets = [offset | (offset, BISnapshot _) <- positionedItems]+    case wireOffsets of+        _ : duplicateOffset : _ ->+            failAt duplicateOffset ("duplicate wire block in aggregate " <> T.unpack name <> " (only one is allowed)")+        _ -> pure ()+    case projectionOffsets of+        _ : duplicateOffset : _ ->+            failAt duplicateOffset ("duplicate projection block in aggregate " <> T.unpack name <> " (only one is allowed)")+        _ -> pure ()+    case snapshotOffsets of+        _ : duplicateOffset : _ ->+            failAt duplicateOffset ("duplicate snapshot block in aggregate " <> T.unpack name <> " (only one is allowed)")+        _ -> pure ()+    pure+        Aggregate+            { aggName = name+            , aggRegs = regs+            , aggStates = states+            , aggCommands = [c | BICommand c <- items]+            , aggEvents = [e | BIEvent e <- items]+            , aggTransitions = [t | BITransition t <- items]+            , aggWire = listToMaybe [w | BIWire w <- items]+            , aggProjection = listToMaybe [p | BIProjection p <- items]+            , aggSnapshot = listToMaybe [s | BISnapshot s <- items]+            , aggLoc = loc+            }+  where+    listToMaybe xs = case xs of (x : _) -> Just x; [] -> Nothing++pRegsBlock :: P [RegDecl]+pRegsBlock = do+    keyword "regs"+    many pRegDecl++pRegDecl :: P RegDecl+pRegDecl = do+    loc <- getLoc+    name <- ident+    ty <- ident+    _ <- symbol "="+    initial <- (RegInitText <$> stringLit) <|> (RegInitBare <$> (ident <|> signedDecimalText))+    pure RegDecl{regName = name, regType = ty, regInitial = initial, regLoc = loc}++pStatesLine :: P [StateDecl]+pStatesLine = do+    keyword "states"+    many pStateDecl+  where+    -- A state decl is an identifier with an optional terminal @!@. The+    -- @notFollowedBy@ lookahead stops the list before a transition whose source+    -- state would otherwise be swallowed as an extra state, e.g. when a+    -- transition directly follows the @states@ line with no command\/event+    -- between them. The @try@ backtracks so the identifier is left for+    -- 'pTransition'.+    pStateDecl = try $ do+        loc <- getLoc+        n <- ident+        term <- option False (True <$ symbol "!")+        notFollowedBy (symbol "--")+        pure StateDecl{stName = n, stTerminal = term, stLoc = loc}++pBodyItem :: P BodyItem+pBodyItem =+    choice+        [ BICommand <$> pCommand+        , BIEvent <$> pEvent+        , BIWire <$> pWire+        , BIProjection <$> pProjection+        , BISnapshot <$> pSnapshot+        , BITransition <$> pTransition+        ]++pSnapshot :: P SnapshotSpec+pSnapshot = do+    loc <- getLoc+    keyword "snapshot"+    policy <-+        choice+            [ SnapEvery <$> (keyword "every" *> boundedDecimal)+            , SnapOnTerminal <$ symbol "on-terminal"+            ]+    _ <- symbol "state-codec"+    _ <- symbol "version" *> symbol "="+    version <- boundedDecimal+    _ <- symbol "shape-hash" *> symbol "="+    hash <- stringLit+    pure SnapshotSpec{snapPolicy = policy, snapCodecVersion = version, snapShapeHash = hash, snapLoc = loc}++pCommand :: P Command+pCommand = do+    loc <- getLoc+    keyword "command"+    name <- ident+    fs <- braces (many pField)+    pure Command{cmdName = name, cmdFields = fs, cmdLoc = loc}++pField :: P Field+pField = do+    n <- ident+    mty <- optional (symbol ":" *> ident)+    pure Field{fieldName = n, fieldType = mty}++pEvent :: P Event+pEvent = do+    loc <- getLoc+    dep <- option False (True <$ keyword "deprecated")+    keyword "event"+    name <- ident+    ver <- option 1 pVersion+    body <-+        choice+            [ EventFromCommand <$> (symbol "=" *> keyword "fields" *> parens ident)+            , EventFields <$> braces (many pField)+            ]+    up <- optional pUpcast+    pure+        Event+            { evName = name+            , evBody = body+            , evVersion = ver+            , evUpcastFrom = up+            , evDeprecated = dep+            , evLoc = loc+            }+  where+    pUpcast = do+        keyword "upcast"+        keyword "from"+        m <- pVersion+        _ <- symbol "="+        keyword "HOLE"+        pure (m, Hole)++{- | A @vN@ schema-version token (e.g. @v2@). Fails (backtracking) on anything+that is not @v@ immediately followed by digits.+-}+pVersion :: P Int+pVersion = do+    offset <- getOffset+    value <- lexeme (try (char 'v' *> (L.decimal :: P Integer) <* notFollowedBy identChar))+    checkedDecimal offset value++pWire :: P WireSpec+pWire = do+    keyword "wire"+    _ <- symbol "kind"+    _ <- symbol "="+    k <- wireWord+    _ <- symbol "fields"+    _ <- symbol "="+    f <- wireWord+    _ <- symbol "schemaVersion"+    _ <- symbol "="+    v <- boundedDecimal+    pure WireSpec{wireKind = k, wireFields = f, wireSchemaVersion = v}++pProjection :: P ProjectionSpec+pProjection = do+    loc <- getLoc+    keyword "projection"+    table <- ident+    cons <- optional (symbol "consistency" *> symbol "=" *> pConsistency)+    _ <- symbol "key"+    _ <- symbol "="+    k <- ident+    sm <- optional pStatusMap+    pure+        ProjectionSpec+            { projTable = table+            , projConsistency = cons+            , projKey = k+            , projStatusMap = sm+            , projLoc = loc+            }+  where+    pConsistency =+        choice [Strong <$ keyword "Strong", Eventual <$ keyword "Eventual"]++pStatusMap :: P Mapping+pStatusMap = do+    keyword "status-map"+    partial <- option False (True <$ keyword "partial")+    pairs <- braces (many pPair)+    pure Mapping{mapPairs = pairs, mapPartial = partial}+  where+    pPair = do+        l <- ident+        _ <- symbol "=>"+        r <- wireWord+        pure (l, r)++--------------------------------------------------------------------------------+-- Integration contract (EP-4)+--------------------------------------------------------------------------------++pContract :: P ContractNode+pContract = do+    loc <- getLoc+    keyword "contract"+    nm <- ident+    _ <- symbol "{"+    keyword "schemaVersion"+    sv <- boundedDecimal+    keyword "discriminator"+    disc <- ident+    topics <- many pTopic+    events <- many pContractEvent+    _ <- symbol "}"+    pure+        ContractNode+            { ctrName = nm+            , ctrSchemaVersion = sv+            , ctrDiscriminator = disc+            , ctrTopics = topics+            , ctrEvents = events+            , ctrLoc = loc+            }+  where+    pTopic = do+        keyword "topic"+        alias <- ident+        t <- stringLit+        pure (alias, t)+    pContractEvent = do+        keyword "event"+        nm <- ident+        keyword "on"+        topicAlias <- ident+        fs <- braces (many pContractField)+        pure ContractEvent{ceName = nm, ceTopic = topicAlias, ceFields = fs}+    pContractField = do+        n <- ident+        _ <- symbol ":"+        ty <- pContractType+        _ <- optional (symbol ";")+        pure ContractField{cfName = n, cfType = ty}+    pContractType =+        choice+            [ CTypeId <$> (keyword "typeid" *> stringLit)+            , CText <$ keyword "text"+            , CInt <$ keyword "int"+            ]++pIntake :: P IntakeNode+pIntake = do+    loc <- getLoc+    keyword "intake"+    nm <- ident+    _ <- symbol "{"+    keyword "contract"+    ctr <- ident+    keyword "topic"+    tp <- ident+    keyword "accept"+    acc <- some ident+    binds <- many pBindRow+    keyword "dedupe"+    keyword "key"+    dk <- ident+    keyword "policy"+    dp <- ident+    persistence <-+        option InkPersistFull $+            keyword "persist"+                *> symbol "="+                *> choice+                    [ InkPersistFull <$ keyword "full-envelope"+                    , InkPersistDedupeOnly <$ keyword "dedupe-only"+                    ]+    dec <- pDecode+    disp <- pDisposition+    _ <- symbol "}"+    pure+        IntakeNode+            { inkName = nm+            , inkContract = ctr+            , inkTopic = tp+            , inkAccept = acc+            , inkBinds = binds+            , inkDedupeKey = dk+            , inkDedupePolicy = dp+            , inkPersist = persistence+            , inkDecode = dec+            , inkDisposition = disp+            , inkLoc = loc+            }+  where+    pBindRow = do+        keyword "bind"+        f <- ident+        keyword "from"+        src <- pWireSource+        req <- option False (True <$ keyword "required")+        xc <- option False (True <$ (keyword "cross-check" *> keyword "body"))+        pure BindRow{brField = f, brSource = src, brRequired = req, brCrossCheck = xc}+    pWireSource =+        choice+            [ SrcHeader <$> (keyword "header" *> stringLit)+            , SrcKafkaKey <$ keyword "kafka-key"+            , SrcKafkaCursor <$ keyword "kafka-cursor"+            , SrcBody <$ keyword "body"+            ]+    pDecode = do+        keyword "decode"+        _ <- symbol "{"+        keyword "envelope"+        env <- pEnvelopePolicy+        keyword "body"+        strict <- (True <$ keyword "strict") <|> (False <$ keyword "lenient")+        keyword "schemaVersion"+        _ <- symbol "=="+        v <- boundedDecimal+        _ <- symbol "}"+        pure DecodeSpec{decEnvelope = env, decBodyStrict = strict, decBodySchemaVersion = v}+    pEnvelopePolicy = do+        a <- wireWord+        b <- wireWord+        pure (a <> " " <> b)+    pDisposition = do+        keyword "disposition"+        rows <- braces (many pDispositionRow)+        pure rows+    pDispositionRow = do+        loc <- getLoc+        o <- ident+        _ <- symbol "=>"+        act <- pInboxAction+        pure DispositionRow{drOutcome = o, drAction = act, drLoc = loc}+    pInboxAction =+        choice+            [ IAckOk <$ keyword "ackOk"+            , IRetry <$> (keyword "retry" *> pWindow)+            , IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)+            ]++pEmit :: P EmitNode+pEmit = do+    loc <- getLoc+    keyword "emit"+    nm <- ident+    _ <- symbol "{"+    keyword "contract"+    ctr <- ident+    keyword "topic"+    tp <- ident+    keyword "source"+    src <- stringLit+    keyword "key"+    k <- ident+    keyword "map"+    disc <- ident+    (rows, skip) <- braces pMapRows+    keyword "messageId"+    mid <- pDerive+    keyword "idempotencyKey"+    idk <- pDerive+    _ <- symbol "}"+    pure+        EmitNode+            { emName = nm+            , emContract = ctr+            , emTopic = tp+            , emSource = src+            , emKey = k+            , emDiscriminant = disc+            , emMap = rows+            , emSkip = skip+            , emMessageId = mid+            , emIdempotencyKey = idk+            , emLoc = loc+            }+  where+    pMapRows = do+        rows <- many pMapRow+        skip <- option False (True <$ try (symbol "_" *> symbol "=>" *> keyword "skip"))+        pure (rows, skip)+    pMapRow = try $ do+        loc <- getLoc+        v <- stringLit+        _ <- symbol "=>"+        ev <- ident+        pure EmitMapRow{emrValue = v, emrEvent = ev, emrLoc = loc}+    pDerive = do+        keyword "derive"+        pfx <- optional stringLit+        keyword "hole"+        pure DeriveSpec{dsPrefix = pfx}++pPublisher :: P PublisherNode+pPublisher = do+    loc <- getLoc+    keyword "publisher"+    nm <- ident+    _ <- symbol "{"+    keyword "emit"+    em <- ident+    keyword "ordering"+    ord <- ident+    keyword "maxAttempts"+    ma <- boundedDecimal+    keyword "backoff"+    bk <- ident+    bw <- pWindow+    bm <- optional (keyword "max" *> symbol "=" *> pWindow)+    multiplier <- optional (keyword "multiplier" *> symbol "=" *> decimalText)+    keyword "outboxId"+    keyword "stable"+    keyword "from"+    obf <- ident+    _ <- symbol "}"+    pure+        PublisherNode+            { pubName = nm+            , pubEmit = em+            , pubOrdering = ord+            , pubMaxAttempts = ma+            , pubBackoff = BackoffSpec{boKind = bk, boWindow = bw, boMax = bm, boMultiplier = multiplier}+            , pubOutboxField = obf+            , pubLoc = loc+            }++pWorkqueue :: P WorkqueueNode+pWorkqueue = do+    loc <- getLoc+    keyword "workqueue"+    nm <- ident+    _ <- symbol "{"+    keyword "queue"+    _ <- symbol "logical" *> symbol "="+    logical <- stringLit+    keyword "derive"+    _ <- symbol "physical" *> symbol "="+    phys <- stringLit+    _ <- symbol "dlq" *> symbol "="+    dlqName <- stringLit+    _ <- symbol "table" *> symbol "="+    tbl <- stringLit+    ordering <- option WqUnordered pOrdering+    groupKey <- optional pGroupKey+    provision <- option WqStandard pProvision+    keyword "payload"+    pn <- ident+    fields <- braces (many pWqField)+    keyword "retry"+    _ <- symbol "maxRetries" *> symbol "="+    mr <- boundedDecimal+    _ <- symbol "delay" *> symbol "="+    dl <- pWindow+    _ <- symbol "dlq" *> symbol "="+    dlqOn <- (True <$ keyword "on") <|> (False <$ keyword "off")+    keyword "disposition"+    disp <- braces (many pWqDispRow)+    _ <- symbol "}"+    pure+        WorkqueueNode+            { wqName = nm+            , wqLogical = logical+            , wqPhysical = phys+            , wqDlq = dlqName+            , wqTable = tbl+            , wqOrdering = ordering+            , wqGroupKey = groupKey+            , wqProvision = provision+            , wqPayloadName = pn+            , wqPayload = fields+            , wqMaxRetries = mr+            , wqDelay = dl+            , wqDlqOn = dlqOn+            , wqDisposition = disp+            , wqLoc = loc+            }+  where+    pOrdering = do+        _ <- symbol "ordering"+        choice+            [ WqUnordered <$ symbol "unordered"+            , WqFifoThroughput <$ symbol "fifo-throughput"+            , WqFifoRoundRobin <$ symbol "fifo-roundrobin"+            ]+    pGroupKey = do+        _ <- symbol "group" *> symbol "key" *> symbol "from"+        field <- ident+        _ <- symbol "via"+        via <- ident+        fixture <- optional (symbol "fixture" *> stringLit)+        pure WqGroupKey{gkField = field, gkVia = via, gkFixture = fixture}+    pProvision = do+        _ <- symbol "provision"+        choice+            [ WqStandard <$ symbol "standard"+            , WqUnlogged <$ symbol "unlogged"+            , do+                _ <- symbol "partitioned" *> symbol "("+                _ <- symbol "interval" *> symbol "="+                interval <- stringLit+                _ <- symbol "," *> symbol "retention" *> symbol "="+                retention <- stringLit+                _ <- symbol ")"+                pure (WqPartitioned interval retention)+            ]+    pWqField = do+        n <- ident+        _ <- symbol "->"+        w <- stringLit+        ty <- ident+        req <- option False (True <$ keyword "required")+        pure WqField{wqfName = n, wqfWire = w, wqfType = ty, wqfRequired = req}+    pWqDispRow = do+        loc <- getLoc+        o <- ident+        _ <- symbol "->"+        act <- choice [IAckOk <$ keyword "ackOk", IRetry <$> (keyword "retry" *> pWindow), IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)]+        pure WqDispRow{wqdOutcome = o, wqdAction = act, wqdLoc = loc}++pReadModel :: P ReadModelNode+pReadModel = do+    loc <- getLoc+    keyword "readmodel"+    name <- ident+    _ <- symbol "{"+    _ <- symbol "table" *> symbol "="+    table <- stringLit+    _ <- symbol "schema" *> symbol "="+    schema <- stringLit+    _ <- symbol "columns"+    columns <- braces (many pColumn)+    _ <- symbol "version" *> symbol "="+    version <- boundedDecimal+    _ <- symbol "shape" *> symbol "="+    shape <- stringLit+    _ <- symbol "consistency" *> symbol "="+    consistency <- pConsistency+    scope <- optional (symbol "scope" *> symbol "=" *> pScope)+    _ <- symbol "feed" *> symbol "="+    feed <- pFeed+    subscription <- optional (symbol "subscription" *> symbol "=" *> stringLit)+    _ <- symbol "}"+    pure+        ReadModelNode+            { rmName = name+            , rmTable = table+            , rmSchema = schema+            , rmColumns = columns+            , rmVersion = version+            , rmShape = shape+            , rmConsistency = consistency+            , rmScope = scope+            , rmFeed = feed+            , rmSubscription = subscription+            , rmLoc = loc+            }+  where+    pColumn =+        RmColumn+            <$> wireWord+            <*> ident+            <*> option False (True <$ keyword "required")+    pConsistency = choice [Strong <$ keyword "Strong", Eventual <$ keyword "Eventual"]+    pScope =+        choice+            [ RmEntireLog <$ keyword "entire-log"+            , RmCategory <$> (keyword "category" *> stringLit)+            ]+    pFeed = choice [RmInline <$ keyword "inline", RmSubscription <$ keyword "subscription"]++pPgmqDispatch :: P PgmqDispatchNode+pPgmqDispatch = do+    loc <- getLoc+    keyword "dispatch"+    nm <- ident+    _ <- symbol "{"+    keyword "source"+    _ <- symbol "readModel" *> symbol "="+    srm <- ident+    _ <- symbol "key" *> symbol "="+    sk <- ident+    keyword "fanout"+    _ <- symbol "body" *> symbol "="+    fb <- ident+    keyword "dedup"+    _ <- symbol "key" *> symbol "="+    dk <- ident+    _ <- keyword "seenIn" *> symbol "readModel" *> symbol "="+    drm <- ident+    _ <- symbol "field" *> symbol "="+    drmf <- ident+    _ <- keyword "seenIn" *> symbol "queue" *> symbol "="+    dq <- ident+    _ <- symbol "field" *> symbol "="+    dqf <- ident+    keyword "enqueue"+    _ <- symbol "to" *> symbol "="+    enq <- ident+    _ <- symbol "}"+    pure+        PgmqDispatchNode+            { pdName = nm+            , pdSourceReadModel = srm+            , pdSourceKey = sk+            , pdFanoutBody = fb+            , pdDedupKey = dk+            , pdDedupReadModel = drm+            , pdDedupReadModelField = drmf+            , pdDedupQueue = dq+            , pdDedupQueueField = dqf+            , pdEnqueueTo = enq+            , pdLoc = loc+            }++pWorkflow :: P WorkflowNode+pWorkflow = do+    loc <- getLoc+    keyword "workflow"+    wid <- ident+    keyword "name"+    nm <- stringLit+    keyword "in"+    inTy <- ident+    inFields <- option [] (braces (many pField))+    keyword "out"+    outTy <- ident+    keyword "id"+    keyword "from"+    keyword "input"+    idField <- optional (symbol "." *> ident)+    keyword "via"+    idVia <- ident+    keyword "body"+    body <- many pWfBodyItem+    pure+        WorkflowNode+            { wfId = wid+            , wfStable = nm+            , wfInput = inTy+            , wfInputFields = inFields+            , wfOutput = outTy+            , wfIdField = idField+            , wfIdVia = idVia+            , wfBody = body+            , wfLoc = loc+            }+  where+    pWfBodyItem =+        choice+            [ do+                loc <- getLoc+                WfStep <$> (keyword "step" *> wireWord) <*> (symbol "->" *> ident) <*> pure loc+            , do+                loc <- getLoc+                WfAwait <$> (keyword "await" *> wireWord) <*> (symbol "->" *> ident) <*> pure loc+            , do+                loc <- getLoc+                WfSleep <$> (keyword "sleep" *> wireWord) <*> (keyword "after" *> ident) <*> pure loc+            , do+                loc <- getLoc+                WfChild+                    <$> (keyword "child" *> wireWord)+                    <*> (keyword "id" *> keyword "input" *> keyword "via" *> ident)+                    <*> (symbol "->" *> ident)+                    <*> pure loc+            , do+                loc <- getLoc+                WfPatch+                    <$> (keyword "patch" *> patchIdWord)+                    <*> braces (many pWfBodyItem)+                    <*> pure loc+            , do+                loc <- getLoc+                WfContinueAsNew <$> (keyword "continueAsNew" *> ident) <*> pure loc+            ]++pOperation :: P OperationNode+pOperation = do+    loc <- getLoc+    keyword "operation"+    nm <- ident+    shape <-+        choice+            [ pCommandOp+            , pQueryOp+            , pSignalOp+            , pRunOp+            ]+    pure OperationNode{opName = nm, opShape = shape, opLoc = loc}+  where+    pCommandOp = do+        keyword "command"+        keyword "on"+        agg <- ident+        _ <- keyword "stream" *> keyword "from"+        sf <- ident+        keyword "via"+        sv <- ident+        proj <- option [] (keyword "project" *> brackets (many ident))+        pure (CommandOp agg sf sv proj)+    pQueryOp = do+        keyword "query"+        rm <- ident+        keyword "input"+        inp <- ident+        keyword "result"+        res <- pTypeExpr+        cons <- option "Strong" (keyword "consistency" *> ident)+        pure (QueryOp rm inp res cons)+    pSignalOp = do+        keyword "signal"+        lbl <- wireWord+        keyword "of"+        wf <- ident+        _ <- keyword "key" *> keyword "from"+        kf <- ident+        keyword "via"+        kv <- ident+        keyword "value"+        val <- ident+        pure (SignalOp lbl wf kf kv val)+    pRunOp = do+        keyword "run"+        wf <- ident+        keyword "input"+        inp <- ident+        _ <- keyword "outcome" *> symbol "->"+        oc <- ident+        pure (RunOp wf inp oc)+    -- A result type expression, possibly multi-word like @Maybe TransferDecision@.+    pTypeExpr = do+        ws <- some ident+        pure (T.unwords ws)++--------------------------------------------------------------------------------+-- Process manager + durable timer (EP-3)+--------------------------------------------------------------------------------++pProcess :: P ProcessNode+pProcess = do+    loc <- getLoc+    keyword "process"+    pid <- ident+    keyword "name"+    nm <- stringLit+    inp <- pInputDecl+    corr <- pCorrelate+    saga <- pSaga+    keyword "target"+    tgt <- ident+    projs <- keyword "projections" *> brackets (many ident)+    handle <- pHandle+    _ <- optional pDispatchIdLine+    rejected <- pPolicyLine "rejected"+    poison <- pPolicyLine "poison"+    timer <- pTimerNode+    pure+        ProcessNode+            { procId = pid+            , procName = nm+            , procInput = inp+            , procCorrelate = corr+            , procSaga = saga+            , procTarget = tgt+            , procProjections = projs+            , procHandle = handle+            , procRejected = rejected+            , procPoison = poison+            , procTimer = timer+            , procLoc = loc+            }++pRouter :: P RouterNode+pRouter = do+    loc <- getLoc+    keyword "router"+    rid <- ident+    keyword "name"+    nm <- stringLit+    inp <- pInputDecl+    key <- pRouterKey+    resolved <- pResolveDecl+    keyword "target"+    target <- ident+    projections <- keyword "projections" *> brackets (many ident)+    dispatch <- pRouterDispatch+    pRouterDispatchIdLine+    rejected <- pPolicyLine "rejected"+    poison <- pPolicyLine "poison"+    pure+        RouterNode+            { rtId = rid+            , rtName = nm+            , rtInput = inp+            , rtKey = key+            , rtResolve = resolved+            , rtTarget = target+            , rtProjections = projections+            , rtDispatch = dispatch+            , rtRejected = rejected+            , rtPoison = poison+            , rtLoc = loc+            }++pRouterKey :: P CorrelateDecl+pRouterKey = do+    keyword "key"+    _ <- keyword "input" *> symbol "."+    field <- ident+    keyword "via"+    via <- ident+    pure CorrelateDecl{corrField = field, corrVia = via}++pResolveDecl :: P ResolveDecl+pResolveDecl = do+    loc <- getLoc+    keyword "resolve"+    keyword "stable"+    keyword "via"+    source <- choice [ResolveReadModel <$> (keyword "read-model" *> ident), ResolveHole <$ keyword "hole"]+    keyword "row"+    row <- braces (many ident)+    pure ResolveDecl{rvSource = source, rvRow = row, rvLoc = loc}++pRouterDispatch :: P RouterDispatchNode+pRouterDispatch = do+    loc <- getLoc+    keyword "dispatch-each"+    command <- ident+    fields <- braces (many pFieldBinding)+    disposition <-+        DispatchDisposition+            <$> (keyword "on-appended" *> pDisp)+            <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)+            <*> (symbol ";" *> keyword "on-failed" *> pDisp)+    pure RouterDispatchNode{rdCommand = command, rdFields = fields, rdDisposition = disposition, rdLoc = loc}++pRouterDispatchIdLine :: P ()+pRouterDispatchIdLine = do+    keyword "dispatch-id"+    _ <- symbol "strategy" *> symbol "=" *> keyword "uuidv5"+    _ <- symbol "from" *> symbol "=" *> parens fixedInputs+    pure ()+  where+    fixedInputs = do+        keyword "name"+        _ <- symbol ","+        keyword "key"+        _ <- symbol ","+        keyword "sourceEventId"+        _ <- symbol ","+        keyword "targetStreamName"+        _ <- symbol ","+        keyword "occurrence"++pPolicyLine :: Text -> P PolicyChoice+pPolicyLine clause = keyword clause *> symbol "=>" *> pPolicyChoice++pPolicyChoice :: P PolicyChoice+pPolicyChoice =+    choice+        [ PolHalt <$ keyword "halt"+        , PolDeadLetter <$ keyword "deadLetter"+        , PolSkip <$ keyword "skip"+        ]++pInputDecl :: P InputDecl+pInputDecl = do+    keyword "input"+    nm <- ident+    fs <- braces (many pField)+    pure InputDecl{inName = nm, inFields = fs}++pCorrelate :: P CorrelateDecl+pCorrelate = do+    keyword "correlate"+    _ <- keyword "input" *> symbol "."+    f <- ident+    keyword "via"+    v <- ident+    pure CorrelateDecl{corrField = f, corrVia = v}++pSaga :: P SagaRef+pSaga = do+    keyword "saga"+    agg <- ident+    keyword "category"+    categoryName <- stringLit+    pure SagaRef{sagaAgg = agg, sagaCategory = categoryName}++pHandle :: P HandleNode+pHandle = do+    keyword "on"+    onName <- ident+    adv <- pAdvance+    disps <- many pDispatch+    keyword "schedule"+    sched <- ident+    pure HandleNode{hOn = onName, hAdvance = adv, hDispatch = disps, hSchedule = sched}++pAdvance :: P AdvanceNode+pAdvance = do+    keyword "advance"+    cmd <- ident+    fs <- braces (many pFieldBinding)+    pure AdvanceNode{advCommand = cmd, advFields = fs}++pDispatch :: P DispatchNode+pDispatch = do+    loc <- getLoc+    keyword "dispatch"+    tgt <- ident+    _ <- symbol "@"+    key <- dottedRef+    cmd <- ident+    fs <- braces (many pFieldBinding)+    disp <-+        DispatchDisposition+            <$> (keyword "on-appended" *> pDisp)+            <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)+            <*> (symbol ";" *> keyword "on-failed" *> pDisp)+    pure DispatchNode{dispTarget = tgt, dispKey = key, dispCommand = cmd, dispFields = fs, dispDisposition = disp, dispLoc = loc}++pDisp :: P Disp+pDisp =+    choice+        [ DAckOk <$ keyword "AckOk"+        , DRetry <$ keyword "Retry"+        , DDeadLetter <$> (keyword "DeadLetter" *> stringLit)+        ]++-- The dispatch-id line is a fixed, runtime-owned strategy; parse and discard.+pDispatchIdLine :: P ()+pDispatchIdLine = do+    keyword "dispatch-id"+    _ <- symbol "strategy" *> symbol "=" *> ident+    _ <- symbol "from" *> symbol "=" *> parens (sepBy dottedRef (symbol ","))+    pure ()++pTimerNode :: P TimerNode+pTimerNode = do+    loc <- getLoc+    keyword "timer"+    nm <- ident+    tid <- keyword "id" *> pIdExpr+    fat <- keyword "fireAt" *> pFireAt+    pay <- keyword "payload" *> braces (many pFieldBinding)+    fire <- pFire+    _ <- keyword "decode" *> keyword "unknown-status" *> symbol "=>"+    unk <- ident+    keyword "max-attempts"+    ma <- boundedDecimal+    keyword "dead-letter"+    dl <- stringLit+    pure+        TimerNode+            { tmName = nm+            , tmId = tid+            , tmFireAt = fat+            , tmPayload = pay+            , tmFire = fire+            , tmDecodeUnknown = unk+            , tmMaxAttempts = ma+            , tmDeadLetter = dl+            , tmLoc = loc+            }++pIdExpr :: P IdExpr+pIdExpr = do+    keyword "uuidv5"+    pfx <- stringLit+    _ <- symbol "<>"+    _ <- ident -- correlationId (fixed)+    pure IdExpr{ideStrategy = UuidV5Id, idePrefix = pfx}++pFireAt :: P FireAtExpr+pFireAt = do+    _ <- keyword "input" *> symbol "."+    f <- ident+    _ <- symbol "+"+    w <- pWindow+    pure FireAtExpr{faField = f, faWindow = w}++pWindow :: P Text+pWindow = lexeme $ do+    ds <- some digitChar+    u <- choice [char 's', char 'm', char 'h'] <?> "time unit: s, m, or h"+    notFollowedBy letterChar <?> "time unit: s, m, or h"+    pure (T.pack (ds <> [u]))++decimalText :: P Text+decimalText = lexeme $ do+    whole <- some digitChar+    fractional <- optional (char '.' *> some digitChar)+    pure (T.pack (whole <> maybe "" ('.' :) fractional))++signedDecimalText :: P Text+signedDecimalText = lexeme $ do+    sign <- optional (char '-')+    digits <- some digitChar+    pure (T.pack (maybe "" pure sign <> digits))++pFire :: P FireNode+pFire = do+    keyword "fire"+    keyword "dispatch"+    tgt <- ident+    _ <- symbol "@"+    key <- dottedRef+    cmd <- ident+    fs <- braces (many pFieldBinding)+    fid <- keyword "fired-event-id" *> pIdExpr+    disp <-+        FireDisposition+            <$> (keyword "on-ok" *> pFireOutcome)+            <*> (symbol ";" *> keyword "on-reject" *> pFireOutcome)+            <*> (symbol ";" *> keyword "on-ambiguous" *> pFireOutcome)+            <*> (symbol ";" *> keyword "on-error" *> pFireOutcome)+            <*> (symbol ";" *> keyword "not-mine" *> pFireOutcome)+    pure FireNode{fireTarget = tgt, fireKey = key, fireCommand = cmd, fireFields = fs, fireFiredEventId = fid, fireDisposition = disp}++pFireOutcome :: P FireOutcome+pFireOutcome = choice [OFired <$ keyword "Fired", ORetry <$ keyword "Retry"]++pFieldBinding :: P FieldBinding+pFieldBinding = do+    n <- ident+    v <- optional (symbol "=" *> pBindingValue)+    pure FieldBinding{fbName = n, fbValue = v}++-- | A binding value: a quoted string (kept quoted) or a dotted reference.+pBindingValue :: P Text+pBindingValue = choice [quoted, dottedRef]+  where+    quoted = do+        s <- stringLit+        pure ("\"" <> s <> "\"")++{- | A dotted/plain reference token like @input.hospitalId@, @timer.id@,+@correlationId@.+-}+dottedRef :: P Text+dottedRef = lexeme $ do+    c <- asciiLetter+    cs <- many (asciiAlphaNum <|> char '_' <|> char '.')+    pure (T.pack (c : cs))++{- | A double-quoted string literal, returning raw (unescaped) inner text.+The surface syntax supports a closed escape set so unknown escapes remain+available for backward-compatible extensions.+-}+stringLit :: P Text+stringLit = lexeme $ do+    _ <- char '"'+    s <- many strChar+    _ <- char '"'+    pure (T.pack s)+  where+    strChar =+        choice+            [ char '\\' *> escapeCode+            , char '\n' *> fail "unescaped newline in string literal (write \\n)"+            , anySingleBut '"'+            ]+    escapeCode =+        choice+            [ '"' <$ char '"'+            , '\\' <$ char '\\'+            , '\n' <$ char 'n'+            , '\t' <$ char 't'+            , '\r' <$ char 'r'+            , anySingle >>= \c -> fail ("unknown escape sequence \\" <> [c] <> " in string literal")+            ]++brackets :: P a -> P a+brackets = between (symbol "[") (symbol "]")++--------------------------------------------------------------------------------+-- Transitions+--------------------------------------------------------------------------------++data Clause+    = CGuard Expr+    | CWrite Name Expr+    | CEmit Name+    | CGoto Name++pTransition :: P Transition+pTransition = do+    startOffset <- getOffset+    loc <- getLoc+    src <- ident+    _ <- symbol "--"+    cmd <- ident+    _ <- symbol "-->"+    positionedClauses <- many ((,) <$> getOffset <*> (pClause <* optional (symbol ";")))+    let clauses = map snd positionedClauses+        gotos = [(offset, target) | (offset, CGoto target) <- positionedClauses]+        transitionName = T.unpack src <> " -- " <> T.unpack cmd+    gt <- case gotos of+        [] -> failAt startOffset ("transition " <> transitionName <> " is missing a goto clause")+        [(_, target)] -> pure target+        (_, firstTarget) : (duplicateOffset, _) : _ ->+            failAt+                duplicateOffset+                ("duplicate goto clause (transition " <> transitionName <> " already declared goto " <> T.unpack firstTarget <> ")")+    let guards = [e | CGuard e <- clauses]+    pure+        Transition+            { tSource = src+            , tCommand = cmd+            , tGuard = case guards of [] -> Nothing; es -> Just (foldr1 EAnd es)+            , tWrites = [(r, e) | CWrite r e <- clauses]+            , tEmits = [n | CEmit n <- clauses]+            , tGoto = gt+            , tLoc = loc+            }++pClause :: P Clause+pClause =+    choice+        [ CGuard <$> (keyword "guard" *> pExpr)+        , (\r e -> CWrite r e) <$> (keyword "write" *> ident) <*> (symbol ":=" *> pExpr)+        , try $ do+            keyword "emit"+            eventName <- ident+            notFollowedBy (symbol "{")+            pure (CEmit eventName)+        , CGoto <$> (keyword "goto" *> ident)+        ]++--------------------------------------------------------------------------------+-- Expr sublanguage+--------------------------------------------------------------------------------++pExpr :: P Expr+pExpr = makeExprParser pTerm operatorTable++pTerm :: P Expr+pTerm =+    choice+        [ parens pExpr+        , EAtom . ABool <$> (True <$ keyword "true" <|> False <$ keyword "false")+        , EAtom . AName <$> ident+        ]++{- | Highest precedence first: relational comparisons bind tighter than @&&@,+which binds tighter than @||@.+-}+operatorTable :: [[Operator P Expr]]+operatorTable =+    [+        [ InfixN (ECmp OpLe <$ op "<=")+        , InfixN (ECmp OpGe <$ op ">=")+        , InfixN (ECmp OpEq <$ op "==")+        , InfixN (ECmp OpNeq <$ op "!=")+        , InfixN (ECmp OpLt <$ op "<")+        , InfixN (ECmp OpGt <$ op ">")+        ]+    , [InfixL (EAnd <$ op "&&")]+    , [InfixL (EOr <$ op "||")]+    ]+  where+    op s = symbol s++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++braces :: P a -> P a+braces = between (symbol "{") (symbol "}")++parens :: P a -> P a+parens = between (symbol "(") (symbol ")")
+ src/Keiro/Dsl/PrettyPrint.hs view
@@ -0,0 +1,635 @@+{- | Pretty-printer for the keiro DSL: renders a 'Spec' back to @.keiro@ text.+The layout need not be byte-identical to the original source (the parser+treats whitespace as insignificant), but it must round-trip:+@parseSpec (renderSpec s) == Right s@ modulo source locations. The only+subtle part is expression printing, which uses a @showsPrec@-style precedence+scheme so left-associative @&&@/@||@ and non-associative comparisons re-parse+to the identical AST.+-}+module Keiro.Dsl.PrettyPrint (+    renderSpec,+)+where++import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Prettyprinter+import Prettyprinter.Render.Text (renderStrict)++-- | Render a whole spec to text.+renderSpec :: Spec -> Text+renderSpec = renderStrict . layoutPretty opts . docSpec+  where+    opts = LayoutOptions{layoutPageWidth = Unbounded}++docSpec :: Spec -> Doc ann+docSpec s =+    vsep $+        ["context" <+> pretty (specContext s)]+            ++ maybe [] (\r -> ["module" <+> pretty r]) (specModuleRoot s)+            ++ maybe [] (\l -> ["layout" <+> docLayout l]) (specLayout s)+            ++ [mempty]+            ++ map docId (specIds s)+            ++ blankAfter (specIds s)+            ++ map docEnum (specEnums s)+            ++ blankAfter (specEnums s)+            ++ map docRule (specRules s)+            ++ blankAfter (specRules s)+            ++ map docNode (specNodes s)+  where+    blankAfter xs = if null xs then [] else [mempty]++docLayout :: Placement -> Doc ann+docLayout GeneratedPrefix = "prefixed"+docLayout CollocatedLeaf = "collocated"++docId :: IdDecl -> Doc ann+docId d = "id" <+> pretty (idName d) <+> ("prefix=" <> pretty (idPrefix d))++docEnum :: EnumDecl -> Doc ann+docEnum d =+    "enum" <+> pretty (enumName d) <+> braced (map ctor (enumCtors d))+  where+    ctor (c, w) = pretty c <> "=" <> pretty w++docRule :: RuleDecl -> Doc ann+docRule d =+    vsep+        [ "rule" <+> pretty (ruleName d) <+> ":" <+> pretty (ruleDomain d) <+> "->" <+> pretty (ruleCodomain d)+        , indent 2 ("ex" <+> hsep (punctuate " ;" (map cas (ruleCases d))))+        ]+  where+    cas (c, e) = pretty c <+> "=>" <+> docExpr 0 e++docNode :: Node -> Doc ann+docNode (NAggregate a) = docAggregate a+docNode (NProcess p) = docProcess p+docNode (NRouter r) = docRouter r+docNode (NContract c) = docContract c+docNode (NIntake i) = docIntake i+docNode (NEmit e) = docEmit e+docNode (NPublisher p) = docPublisher p+docNode (NWorkqueue w) = docWorkqueue w+docNode (NPgmqDispatch d) = docPgmqDispatch d+docNode (NReadModel r) = docReadModel r+docNode (NWorkflow w) = docWorkflow w+docNode (NOperation o) = docOperation o++docWorkflow :: WorkflowNode -> Doc ann+docWorkflow w =+    vsep $+        [ "workflow" <+> pretty (wfId w)+        , indent 2 ("name" <+> dquoted (wfStable w))+        , indent 2 ("in" <+> pretty (wfInput w) <> inFieldsDoc)+        , indent 2 ("out" <+> pretty (wfOutput w))+        , indent 2 ("id from input" <> maybe mempty (\f -> "." <> pretty f) (wfIdField w) <+> "via" <+> pretty (wfIdVia w))+        , indent 2 "body"+        ]+            ++ map (indent 4 . bodyItem) (wfBody w)+  where+    inFieldsDoc = case wfInputFields w of+        [] -> mempty+        fs -> " " <> braced (map docField fs)+    bodyItem (WfStep l r _) = "step" <+> pretty l <+> "->" <+> pretty r+    bodyItem (WfAwait l r _) = "await" <+> pretty l <+> "->" <+> pretty r+    bodyItem (WfSleep l a _) = "sleep" <+> pretty l <+> "after" <+> pretty a+    bodyItem (WfChild l v r _) = "child" <+> pretty l <+> "id input via" <+> pretty v <+> "->" <+> pretty r+    bodyItem (WfPatch patchId items _) =+        vsep $ ["patch" <+> pretty patchId <+> "{"] ++ map (indent 2 . bodyItem) items ++ ["}"]+    bodyItem (WfContinueAsNew seedType _) = "continueAsNew" <+> pretty seedType++docOperation :: OperationNode -> Doc ann+docOperation o =+    vsep $ ["operation" <+> pretty (opName o)] ++ map (indent 2) (shapeLines (opShape o))+  where+    shapeLines (CommandOp agg sf sv proj) =+        [ "command on" <+> pretty agg+        , indent 2 ("stream from" <+> pretty sf <+> "via" <+> pretty sv)+        ]+            ++ [indent 2 ("project" <+> bracketed (map pretty proj)) | not (null proj)]+    shapeLines (QueryOp rm inp res cons) =+        [ "query" <+> pretty rm+        , indent 2 ("input" <+> pretty inp)+        , indent 2 ("result" <+> pretty res)+        , indent 2 ("consistency" <+> pretty cons)+        ]+    shapeLines (SignalOp lbl wf kf kv val) =+        [ "signal" <+> pretty lbl <+> "of" <+> pretty wf+        , indent 2 ("key from" <+> pretty kf <+> "via" <+> pretty kv)+        , indent 2 ("value" <+> pretty val)+        ]+    shapeLines (RunOp wf inp oc) =+        [ "run" <+> pretty wf+        , indent 2 ("input" <+> pretty inp)+        , indent 2 ("outcome ->" <+> pretty oc)+        ]++docWorkqueue :: WorkqueueNode -> Doc ann+docWorkqueue w =+    vsep $+        [ "workqueue" <+> pretty (wqName w) <+> "{"+        , indent 2 ("queue logical =" <+> dquoted (wqLogical w))+        , indent 2 ("derive physical =" <+> dquoted (wqPhysical w))+        , indent 4 ("dlq =" <+> dquoted (wqDlq w))+        , indent 4 ("table =" <+> dquoted (wqTable w))+        ]+            ++ orderingLines+            ++ groupKeyLines+            ++ provisionLines+            ++ [indent 2 ("payload" <+> pretty (wqPayloadName w) <+> "{")]+            ++ map (indent 4 . field) (wqPayload w)+            ++ [ indent 2 "}"+               , indent 2 ("retry maxRetries =" <+> pretty (wqMaxRetries w) <+> "delay =" <+> pretty (wqDelay w) <+> "dlq =" <+> (if wqDlqOn w then "on" else "off"))+               , indent 2 "disposition {"+               ]+            ++ map (indent 4 . dispRow) (wqDisposition w)+            ++ [indent 2 "}", "}"]+  where+    orderingLines = case wqOrdering w of+        WqUnordered -> []+        WqFifoThroughput -> [indent 2 "ordering fifo-throughput"]+        WqFifoRoundRobin -> [indent 2 "ordering fifo-roundrobin"]+    groupKeyLines = case wqGroupKey w of+        Nothing -> []+        Just groupKey ->+            [ indent 2 $+                "group key from"+                    <+> pretty (gkField groupKey)+                    <+> "via"+                    <+> pretty (gkVia groupKey)+                    <> maybe mempty (\fixture -> " fixture " <> dquoted fixture) (gkFixture groupKey)+            ]+    provisionLines = case wqProvision w of+        WqStandard -> []+        WqUnlogged -> [indent 2 "provision unlogged"]+        WqPartitioned interval retention ->+            [indent 2 ("provision partitioned(interval=" <> dquoted interval <> ", retention=" <> dquoted retention <> ")")]+    field f = pretty (wqfName f) <+> "->" <+> dquoted (wqfWire f) <+> pretty (wqfType f) <> (if wqfRequired f then " required" else mempty)+    dispRow r = pretty (wqdOutcome r) <+> "->" <+> act (wqdAction r)+    act IAckOk = "ackOk"+    act (IRetry win) = "retry" <+> pretty win+    act (IDeadLetter Nothing) = "deadLetter"+    act (IDeadLetter (Just reason)) = "deadLetter" <+> dquoted reason++docPgmqDispatch :: PgmqDispatchNode -> Doc ann+docPgmqDispatch d =+    vsep+        [ "dispatch" <+> pretty (pdName d) <+> "{"+        , indent 2 ("source readModel =" <+> pretty (pdSourceReadModel d) <+> "key =" <+> pretty (pdSourceKey d))+        , indent 2 ("fanout body =" <+> pretty (pdFanoutBody d))+        , indent 2 ("dedup key =" <+> pretty (pdDedupKey d))+        , indent 4 ("seenIn readModel =" <+> pretty (pdDedupReadModel d) <+> "field =" <+> pretty (pdDedupReadModelField d))+        , indent 4 ("seenIn queue =" <+> pretty (pdDedupQueue d) <+> "field =" <+> pretty (pdDedupQueueField d))+        , indent 2 ("enqueue to =" <+> pretty (pdEnqueueTo d))+        , "}"+        ]++docReadModel :: ReadModelNode -> Doc ann+docReadModel readModel =+    vsep $+        [ "readmodel" <+> pretty (rmName readModel) <+> "{"+        , indent 2 ("table =" <+> dquoted (rmTable readModel))+        , indent 2 ("schema =" <+> dquoted (rmSchema readModel))+        , indent 2 "columns {"+        ]+            ++ map (indent 4 . docColumn) (rmColumns readModel)+            ++ [ indent 2 "}"+               , indent 2 ("version =" <+> pretty (rmVersion readModel))+               , indent 2 ("shape =" <+> dquoted (rmShape readModel))+               , indent 2 ("consistency =" <+> docConsistency (rmConsistency readModel))+               ]+            ++ maybe [] (pure . indent 2 . ("scope =" <+>) . docScope) (rmScope readModel)+            ++ [indent 2 ("feed =" <+> docFeed (rmFeed readModel))]+            ++ maybe [] (pure . indent 2 . ("subscription =" <+>) . dquoted) (rmSubscription readModel)+            ++ ["}"]+  where+    docColumn columnDecl =+        pretty (rmcName columnDecl)+            <+> pretty (rmcType columnDecl)+            <> if rmcRequired columnDecl then " required" else mempty+    docScope RmEntireLog = "entire-log"+    docScope (RmCategory categoryName) = "category" <+> dquoted categoryName+    docFeed RmInline = "inline"+    docFeed RmSubscription = "subscription"++docEmit :: EmitNode -> Doc ann+docEmit e =+    vsep $+        [ "emit" <+> pretty (emName e) <+> "{"+        , indent 2 ("contract" <+> pretty (emContract e))+        , indent 2 ("topic" <+> pretty (emTopic e))+        , indent 2 ("source" <+> dquoted (emSource e))+        , indent 2 ("key" <+> pretty (emKey e))+        , indent 2 ("map" <+> pretty (emDiscriminant e) <+> "{")+        ]+            ++ map (indent 4 . row) (emMap e)+            ++ [indent 4 "_ => skip" | emSkip e]+            ++ [ indent 2 "}"+               , indent 2 ("messageId" <+> docDerive (emMessageId e))+               , indent 2 ("idempotencyKey" <+> docDerive (emIdempotencyKey e))+               , "}"+               ]+  where+    row r = dquoted (emrValue r) <+> "=>" <+> pretty (emrEvent r)+    docDerive d = "derive" <> maybe mempty (\p -> " " <> dquoted p) (dsPrefix d) <+> "hole"++docPublisher :: PublisherNode -> Doc ann+docPublisher p =+    vsep+        [ "publisher" <+> pretty (pubName p) <+> "{"+        , indent 2 ("emit" <+> pretty (pubEmit p))+        , indent 2 ("ordering" <+> pretty (pubOrdering p))+        , indent 2 ("maxAttempts" <+> pretty (pubMaxAttempts p))+        , indent 2 (docBackoff (pubBackoff p))+        , indent 2 ("outboxId stable from" <+> pretty (pubOutboxField p))+        , "}"+        ]++docIntake :: IntakeNode -> Doc ann+docIntake i =+    vsep $+        [ "intake" <+> pretty (inkName i) <+> "{"+        , indent 2 ("contract" <+> pretty (inkContract i))+        , indent 2 ("topic" <+> pretty (inkTopic i))+        , indent 2 ("accept" <+> hsep (map pretty (inkAccept i)))+        ]+            ++ map (indent 2 . docBind) (inkBinds i)+            ++ [ indent 2 ("dedupe key" <+> pretty (inkDedupeKey i) <+> "policy" <+> pretty (inkDedupePolicy i))+               ]+            ++ [indent 2 "persist = dedupe-only" | inkPersist i == InkPersistDedupeOnly]+            ++ [ indent 2 (docDecode (inkDecode i))+               , indent 2 "disposition {"+               ]+            ++ map (indent 4 . docDispRow) (inkDisposition i)+            ++ [indent 2 "}", "}"]+  where+    docBind b =+        "bind"+            <+> pretty (brField b)+            <+> "from"+            <+> docSource (brSource b)+            <> (if brRequired b then " required" else mempty)+            <> (if brCrossCheck b then " cross-check body" else mempty)+    docSource (SrcHeader h) = "header" <+> dquoted h+    docSource SrcBody = "body"+    docSource SrcKafkaKey = "kafka-key"+    docSource SrcKafkaCursor = "kafka-cursor"+    docDecode d =+        vsep+            [ "decode {"+            , indent 2 ("envelope" <+> pretty (decEnvelope d))+            , indent 2 ("body" <+> (if decBodyStrict d then "strict" else "lenient") <+> "schemaVersion ==" <+> pretty (decBodySchemaVersion d))+            , "}"+            ]+    docDispRow r = pretty (drOutcome r) <+> "=>" <+> docAction (drAction r)+    docAction IAckOk = "ackOk"+    docAction (IRetry w) = "retry" <+> pretty w+    docAction (IDeadLetter Nothing) = "deadLetter"+    docAction (IDeadLetter (Just reason)) = "deadLetter" <+> dquoted reason++--------------------------------------------------------------------------------+-- Integration contract (EP-4)+--------------------------------------------------------------------------------++docContract :: ContractNode -> Doc ann+docContract c =+    vsep $+        [ "contract" <+> pretty (ctrName c) <+> "{"+        , indent 2 ("schemaVersion" <+> pretty (ctrSchemaVersion c))+        , indent 2 ("discriminator" <+> pretty (ctrDiscriminator c))+        ]+            ++ map (indent 2 . docTopic) (ctrTopics c)+            ++ map (indent 2 . docContractEvent) (ctrEvents c)+            ++ ["}"]+  where+    docTopic (alias, t) = "topic" <+> pretty alias <+> dquoted t+    docContractEvent e =+        vsep $+            ["event" <+> pretty (ceName e) <+> "on" <+> pretty (ceTopic e) <+> "{"]+                ++ map (indent 2 . docContractField) (ceFields e)+                ++ ["}"]+    docContractField f = pretty (cfName f) <> ":" <+> docContractType (cfType f)+    docContractType (CTypeId p) = "typeid" <+> dquoted p+    docContractType CText = "text"+    docContractType CInt = "int"++--------------------------------------------------------------------------------+-- Process + timer (EP-3)+--------------------------------------------------------------------------------++docProcess :: ProcessNode -> Doc ann+docProcess p =+    vsep+        [ "process" <+> pretty (procId p)+        , indent 2 ("name" <+> dquoted (procName p))+        , indent 2 (docInput (procInput p))+        , indent 2 (docCorrelate (procCorrelate p))+        , indent 2 (docSaga (procSaga p))+        , indent 2 ("target" <+> pretty (procTarget p))+        , indent 2 ("projections" <+> bracketed (map pretty (procProjections p)))+        , mempty+        , indent 2 (docHandle (procHandle p))+        , mempty+        , indent 2 "dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)"+        , indent 2 ("rejected =>" <+> docPolicyChoice (procRejected p))+        , indent 2 ("poison =>" <+> docPolicyChoice (procPoison p))+        , mempty+        , indent 2 (docTimer (procTimer p))+        ]++docRouter :: RouterNode -> Doc ann+docRouter r =+    vsep+        [ "router" <+> pretty (rtId r)+        , indent 2 ("name" <+> dquoted (rtName r))+        , indent 2 (docInput (rtInput r))+        , indent 2 (docRouterKey (rtKey r))+        , indent 2 (docResolve (rtResolve r))+        , indent 2 ("target" <+> pretty (rtTarget r))+        , indent 2 ("projections" <+> bracketed (map pretty (rtProjections r)))+        , indent 2 (docRouterDispatch (rtDispatch r))+        , indent 2 "dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)"+        , indent 2 ("rejected =>" <+> docPolicyChoice (rtRejected r))+        , indent 2 ("poison =>" <+> docPolicyChoice (rtPoison r))+        ]++docRouterKey :: CorrelateDecl -> Doc ann+docRouterKey key = "key" <+> ("input." <> pretty (corrField key)) <+> "via" <+> pretty (corrVia key)++docResolve :: ResolveDecl -> Doc ann+docResolve resolve =+    "resolve stable via"+        <+> source+        <+> "row"+        <+> braced (map pretty (rvRow resolve))+  where+    source = case rvSource resolve of+        ResolveReadModel name -> "read-model" <+> pretty name+        ResolveHole -> "hole"++docRouterDispatch :: RouterDispatchNode -> Doc ann+docRouterDispatch dispatch =+    vsep+        [ "dispatch-each" <+> pretty (rdCommand dispatch) <+> braced (map docFieldBinding (rdFields dispatch))+        , indent 2 (docDispDisposition (rdDisposition dispatch))+        ]++docPolicyChoice :: PolicyChoice -> Doc ann+docPolicyChoice PolHalt = "halt"+docPolicyChoice PolDeadLetter = "deadLetter"+docPolicyChoice PolSkip = "skip"++docInput :: InputDecl -> Doc ann+docInput i = "input" <+> pretty (inName i) <+> braced (map docField (inFields i))++docCorrelate :: CorrelateDecl -> Doc ann+docCorrelate c = "correlate" <+> ("input." <> pretty (corrField c)) <+> "via" <+> pretty (corrVia c)++docSaga :: SagaRef -> Doc ann+docSaga s = "saga" <+> pretty (sagaAgg s) <+> "category" <+> dquoted (sagaCategory s)++docHandle :: HandleNode -> Doc ann+docHandle h =+    vsep $+        ["on" <+> pretty (hOn h)]+            ++ [indent 2 (docAdvance (hAdvance h))]+            ++ map (indent 2 . docDispatch) (hDispatch h)+            ++ [indent 2 ("schedule" <+> pretty (hSchedule h))]++docAdvance :: AdvanceNode -> Doc ann+docAdvance a = "advance" <+> pretty (advCommand a) <+> braced (map docFieldBinding (advFields a))++docDispatch :: DispatchNode -> Doc ann+docDispatch d =+    vsep+        [ "dispatch" <+> (pretty (dispTarget d) <> "@" <> pretty (dispKey d)) <+> pretty (dispCommand d) <+> braced (map docFieldBinding (dispFields d))+        , indent 2 (docDispDisposition (dispDisposition d))+        ]++docDispDisposition :: DispatchDisposition -> Doc ann+docDispDisposition x =+    "on-appended" <+> docDisp (onAppended x) <+> ";" <+> "on-duplicate" <+> docDisp (onDuplicate x) <+> ";" <+> "on-failed" <+> docDisp (onFailed x)++docDisp :: Disp -> Doc ann+docDisp DAckOk = "AckOk"+docDisp DRetry = "Retry"+docDisp (DDeadLetter r) = "DeadLetter" <+> dquoted r++docTimer :: TimerNode -> Doc ann+docTimer t =+    vsep+        [ "timer" <+> pretty (tmName t)+        , indent 2 ("id" <+> docIdExpr (tmId t))+        , indent 2 ("fireAt" <+> docFireAt (tmFireAt t))+        , indent 2 ("payload" <+> braced (map docFieldBinding (tmPayload t)))+        , indent 2 (docFire (tmFire t))+        , indent 2 ("decode unknown-status =>" <+> pretty (tmDecodeUnknown t))+        , indent 2 ("max-attempts" <+> pretty (tmMaxAttempts t) <+> "dead-letter" <+> dquoted (tmDeadLetter t))+        ]++docIdExpr :: IdExpr -> Doc ann+docIdExpr e = "uuidv5" <+> dquoted (idePrefix e) <+> "<>" <+> "correlationId"++docFireAt :: FireAtExpr -> Doc ann+docFireAt f = ("input." <> pretty (faField f)) <+> "+" <+> pretty (faWindow f)++docFire :: FireNode -> Doc ann+docFire f =+    vsep+        [ "fire dispatch" <+> (pretty (fireTarget f) <> "@" <> pretty (fireKey f)) <+> pretty (fireCommand f) <+> braced (map docFieldBinding (fireFields f))+        , indent 2 ("fired-event-id" <+> docIdExpr (fireFiredEventId f))+        , indent 2 (docFireDisposition (fireDisposition f))+        ]++docFireDisposition :: FireDisposition -> Doc ann+docFireDisposition x =+    "on-ok"+        <+> docFireOutcome (onOk x)+        <+> ";"+        <+> "on-reject"+        <+> docFireOutcome (onReject x)+        <+> ";"+        <+> "on-ambiguous"+        <+> docFireOutcome (onAmbiguous x)+        <+> ";"+        <+> "on-error"+        <+> docFireOutcome (onError x)+        <+> ";"+        <+> "not-mine"+        <+> docFireOutcome (notMine x)++docFireOutcome :: FireOutcome -> Doc ann+docFireOutcome OFired = "Fired"+docFireOutcome ORetry = "Retry"++docFieldBinding :: FieldBinding -> Doc ann+docFieldBinding b = case fbValue b of+    Nothing -> pretty (fbName b)+    Just v -> pretty (fbName b) <> "=" <> docValue v+  where+    docValue v = case T.stripPrefix "\"" v >>= T.stripSuffix "\"" of+        Just rawInner -> dquoted rawInner+        Nothing -> pretty v++dquoted :: Text -> Doc ann+dquoted t = "\"" <> pretty (T.concatMap escapeChar t) <> "\""+  where+    escapeChar '"' = "\\\""+    escapeChar '\\' = "\\\\"+    escapeChar '\n' = "\\n"+    escapeChar '\t' = "\\t"+    escapeChar '\r' = "\\r"+    escapeChar c = T.singleton c++bracketed :: [Doc ann] -> Doc ann+bracketed [] = "[ ]"+bracketed ds = "[" <+> hsep ds <+> "]"++docAggregate :: Aggregate -> Doc ann+docAggregate a =+    vsep $+        [ "aggregate" <+> pretty (aggName a)+        , indent 2 "regs"+        , indent 4 (vsep (map docReg (aggRegs a)))+        , indent 2 ("states" <+> hsep (map docState (aggStates a)))+        , mempty+        ]+            ++ map (indent 2 . docCommand) (aggCommands a)+            ++ blank (aggCommands a)+            ++ map (indent 2 . docEvent) (aggEvents a)+            ++ blank (aggEvents a)+            ++ map (indent 2 . docTransition) (aggTransitions a)+            ++ blank (aggTransitions a)+            ++ maybe [] (\w -> [indent 2 (docWire w)]) (aggWire a)+            ++ maybe [] (\p -> [indent 2 (docProjection p)]) (aggProjection a)+            ++ maybe [] (\snapshot -> [indent 2 (docSnapshot snapshot)]) (aggSnapshot a)+  where+    blank xs = if null xs then [] else [mempty]++docSnapshot :: SnapshotSpec -> Doc ann+docSnapshot snapshot =+    vsep+        [ "snapshot" <+> policyDoc (snapPolicy snapshot)+        , indent 2 ("state-codec version=" <> pretty (snapCodecVersion snapshot) <+> "shape-hash=" <> dquoted (snapShapeHash snapshot))+        ]+  where+    policyDoc (SnapEvery interval) = "every" <+> pretty interval+    policyDoc SnapOnTerminal = "on-terminal"++docReg :: RegDecl -> Doc ann+docReg r = pretty (regName r) <+> pretty (regType r) <+> "=" <+> docRegInitial (regInitial r)++docRegInitial :: RegInitial -> Doc ann+docRegInitial (RegInitBare value) = pretty value+docRegInitial (RegInitText value) = dquoted value++docBackoff :: BackoffSpec -> Doc ann+docBackoff backoff =+    "backoff"+        <+> pretty (boKind backoff)+        <+> pretty (boWindow backoff)+        <+> maybe mempty (\window -> "max=" <> pretty window) (boMax backoff)+        <+> maybe mempty (\multiplier -> "multiplier=" <> pretty multiplier) (boMultiplier backoff)++docState :: StateDecl -> Doc ann+docState s = pretty (stName s) <> (if stTerminal s then "!" else mempty)++docCommand :: Command -> Doc ann+docCommand c = "command" <+> pretty (cmdName c) <+> braced (map docField (cmdFields c))++docField :: Field -> Doc ann+docField f = case fieldType f of+    Nothing -> pretty (fieldName f)+    Just ty -> pretty (fieldName f) <> ":" <> pretty ty++docEvent :: Event -> Doc ann+docEvent e =+    case evUpcastFrom e of+        Nothing -> line1+        Just (m, _) -> vsep [line1, indent 2 ("upcast from v" <> pretty m <+> "=" <+> "HOLE")]+  where+    kw = if evDeprecated e then "deprecated event" else "event"+    nameVer =+        pretty (evName e)+            <> (if evVersion e > 1 then " v" <> pretty (evVersion e) else mempty)+    bodyDoc = case evBody e of+        EventFromCommand cmd -> "=" <+> ("fields(" <> pretty cmd <> ")")+        EventFields fs -> braced (map docField fs)+    line1 = kw <+> nameVer <+> bodyDoc++docTransition :: Transition -> Doc ann+docTransition t =+    vsep $+        [pretty (tSource t) <+> "--" <+> pretty (tCommand t) <+> "-->"]+            ++ map (indent 2) clauses+  where+    clauses =+        maybe [] (\g -> ["guard" <+> docExpr 0 g]) (tGuard t)+            ++ map (\(r, e) -> "write" <+> pretty r <+> ":=" <+> docExpr 0 e) (tWrites t)+            ++ map (\ev -> "emit" <+> pretty ev) (tEmits t)+            ++ ["goto" <+> pretty (tGoto t)]++docWire :: WireSpec -> Doc ann+docWire w =+    "wire"+        <+> ("kind=" <> pretty (wireKind w))+        <+> ("fields=" <> pretty (wireFields w))+        <+> ("schemaVersion=" <> pretty (wireSchemaVersion w))++docProjection :: ProjectionSpec -> Doc ann+docProjection p =+    vsep $+        [ hsep $+            ["projection", pretty (projTable p)]+                ++ maybe [] (pure . ("consistency=" <>) . docConsistency) (projConsistency p)+                ++ ["key=" <> pretty (projKey p)]+        ]+            ++ maybe [] (\m -> [indent 2 (statusMapHead m <+> braced (map pair (mapPairs m)))]) (projStatusMap p)+  where+    statusMapHead m = if mapPartial m then "status-map partial" else "status-map"+    pair (l, r) = pretty l <> "=>" <> pretty r++docConsistency :: Consistency -> Doc ann+docConsistency Strong = "Strong"+docConsistency Eventual = "Eventual"++{- | @showsPrec@-style expression renderer. The 'Int' is the minimum precedence+allowed without parentheses in the current context. Precedence levels:+@||@ = 1, @&&@ = 2, comparisons = 3, atoms = 4.+-}+docExpr :: Int -> Expr -> Doc ann+docExpr ctx e = parensIf (precOf e < ctx) (body e)+  where+    body (EOr l r) = docExpr 1 l <+> "||" <+> docExpr 2 r+    body (EAnd l r) = docExpr 2 l <+> "&&" <+> docExpr 3 r+    body (ECmp op l r) = docExpr 4 l <+> docCmp op <+> docExpr 4 r+    body (EAtom a) = docAtom a++precOf :: Expr -> Int+precOf EOr{} = 1+precOf EAnd{} = 2+precOf ECmp{} = 3+precOf EAtom{} = 4++docCmp :: CmpOp -> Doc ann+docCmp OpEq = "=="+docCmp OpNeq = "!="+docCmp OpLt = "<"+docCmp OpLe = "<="+docCmp OpGt = ">"+docCmp OpGe = ">="++docAtom :: Atom -> Doc ann+docAtom (AName n) = pretty n+docAtom (ABool True) = "true"+docAtom (ABool False) = "false"++parensIf :: Bool -> Doc ann -> Doc ann+parensIf True d = "(" <> d <> ")"+parensIf False d = d++-- | @{ a b c }@ with single-space separation, or @{ }@ when empty.+braced :: [Doc ann] -> Doc ann+braced [] = "{ }"+braced ds = "{" <+> hsep ds <+> "}"
+ src/Keiro/Dsl/ReadModelShape.hs view
@@ -0,0 +1,81 @@+{- | Deterministic identities derived from a first-class read-model declaration.+The validator, scaffolder, harness, and differ share these functions so captured+fixtures and generated runtime values cannot silently disagree.+-}+module Keiro.Dsl.ReadModelShape (+    canonicalShape,+    deriveShapeHash,+    registryNameFor,+    subscriptionNameFor,+) where++import Data.Bits (shiftR, xor, (.&.), (.|.))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word64)+import Keiro.Dsl.Grammar (Name, ReadModelNode (..), RmColumn (..))+import Numeric (showHex)++-- | The ordered table-and-column identity hashed into 'deriveShapeHash'.+canonicalShape :: ReadModelNode -> Text+canonicalShape readModel =+    T.intercalate "|" (rmTable readModel : map columnSegment (rmColumns readModel))+  where+    columnSegment columnDecl =+        T.intercalate+            ":"+            [ rmcName columnDecl+            , rmcType columnDecl+            , if rmcRequired columnDecl then "req" else "null"+            ]++-- | A fixed-width FNV-1a-64 digest over the canonical shape's UTF-8 bytes.+deriveShapeHash :: ReadModelNode -> Text+deriveShapeHash readModel =+    "fnv1a:" <> T.justifyRight 16 '0' (T.pack (showHex digest ""))+  where+    digest = foldl' step offsetBasis (concatMap utf8Bytes (T.unpack (canonicalShape readModel)))+    step hash byte = (hash `xor` byte) * fnvPrime++-- | The runtime registry identity derived from context and notation name.+registryNameFor :: Name -> ReadModelNode -> Text+registryNameFor contextName readModel =+    contextName <> "-" <> T.replace "_" "-" (rmName readModel)++-- | The explicit subscription override or its deterministic default.+subscriptionNameFor :: Name -> ReadModelNode -> Text+subscriptionNameFor contextName readModel =+    fromMaybe (registryNameFor contextName readModel <> "-sub") (rmSubscription readModel)++offsetBasis :: Word64+offsetBasis = 0xcbf29ce484222325++fnvPrime :: Word64+fnvPrime = 0x100000001b3++{- | Encode one Unicode scalar value as UTF-8 bytes, represented as 'Word64'+values so the hash fold needs no bytestring package dependency.+-}+utf8Bytes :: Char -> [Word64]+utf8Bytes character+    | codePoint <= 0x7f = [byte codePoint]+    | codePoint <= 0x7ff =+        [ byte (0xc0 .|. (codePoint `shiftR` 6))+        , continuation codePoint+        ]+    | codePoint <= 0xffff =+        [ byte (0xe0 .|. (codePoint `shiftR` 12))+        , continuation (codePoint `shiftR` 6)+        , continuation codePoint+        ]+    | otherwise =+        [ byte (0xf0 .|. (codePoint `shiftR` 18))+        , continuation (codePoint `shiftR` 12)+        , continuation (codePoint `shiftR` 6)+        , continuation codePoint+        ]+  where+    codePoint = fromEnum character+    byte = fromIntegral+    continuation value = byte (0x80 .|. (value .&. 0x3f))
+ src/Keiro/Dsl/Scaffold.hs view
@@ -0,0 +1,2138 @@+{- | The scaffold engine. Given an 'Aggregate' (and a 'Context' naming the+service and output module-namespace root), it emits the __symbol-free+deterministic layer__ as @-- \@generated@ modules plus a single create-if-absent+@Holes.hs@ holding the typed holes a human or coding agent must fill.++The load-bearing invariant of this module is the __firewall__: no @Generated@+module ever contains a keiki symbolic operator (@./=@, @.==@, @.||@, @lit@,+@B.slot@, @B.requireGuard@). Those live only in the hand-owned @Holes.hs@. A+test ('Generated' text scan) enforces it.++Scope (EP-1, recorded in the plan's Decision Log): the scaffolder does /not/+emit the symbolic transducer body — that is the @buildTransducer@ hole in+@Holes.hs@, pinned by the harness. It also does not emit the read-model SQL+(the projection @apply@), which is a DB-coupled hole delegated to @codd@/the+agent; the @Generated@ Projection module emits only the deterministic+@InlineProjection@ wiring and the pure event→status mapping. The decode emitted+here is /strict/ (every field required); lenient\/optional decode is EP-4's+concern.+-}+module Keiro.Dsl.Scaffold (+    ScaffoldModule (..),+    ModuleKind (..),+    Context (..),+    Placement (..),+    defaultContext,+    genPrefixFor,+    holePrefixFor,+    scaffoldAggregate,+    scaffoldProcess,+    scaffoldRouter,+    scaffoldContract,+    scaffoldIntake,+    scaffoldPublisher,+    scaffoldWorkqueue,+    scaffoldReadModel,+    scaffoldRefusals,+    windowSeconds,++    -- * Firewall self-check (M3)+    FirewallSurface (..),+    firewallSurface,+    firewallBreaches,++    -- * Internal resolution, shared with "Keiro.Dsl.Harness"+    Agg (..),+    ResolvedCtor (..),+    resolveAgg,+    FieldCat (..),+    fieldCat,+    vertexCtor,+    initialVertex,+    firstEnumCtor,+    lowerFirst,+    pascal,+    pascalFromKebab,+    generatedBanner,+) where++import Data.Char (isAlpha, isAlphaNum, isUpper, toLower, toUpper)+import Data.List (find)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)+import Keiro.Dsl.Validate (sagaCategoryError)+import Text.Read (readMaybe)++{- | One emitted module: its on-disk path (relative to the scaffold @--out@+directory), its full text, and whether it is overwritten every run+('Generated') or written only when absent ('HoleStub').+-}+data ScaffoldModule = ScaffoldModule+    { modulePath :: !FilePath+    , moduleText :: !Text+    , kind :: !ModuleKind+    , origin :: !Text+    }+    deriving stock (Eq, Show)++data ModuleKind+    = -- | @-- \@generated@; overwritten on every scaffold.+      Generated+    | -- | Hand-owned; created only when absent, never overwritten.+      HoleStub+    deriving stock (Eq, Show)++{- | The threading context: the spec's @context@ name, the chosen output+module-namespace root, and the placement style. Extended additively (never+re-shaped) by later verticals.+-}+data Context = Context+    { contextName :: !Text+    , moduleRoot :: !Text+    -- ^ @""@ means no namespace prefix (the historical default).+    , placement :: !Placement+    -- ^ 'GeneratedPrefix' is the historical default.+    }+    deriving stock (Eq, Show)++{- | A context with today's default placement ('GeneratedPrefix', no root prefix)+for the given @context@ name. Callers that do not care about placement (the+@parse@ path, tests) build their context with this.+-}+defaultContext :: Text -> Context+defaultContext name = Context{contextName = name, moduleRoot = "", placement = GeneratedPrefix}++{- | The generated-layer namespace for a node, honouring the root prefix and the+placement style. The 'Text' argument is the already-pascalised node name (e.g.+@Reservation@, @HospitalSurge@). For 'GeneratedPrefix' this is+@\<root\>.Generated.\<Ctx\>.\<Node\>@ (identical to the historical layout); for+'CollocatedLeaf' it is @\<root\>.\<Ctx\>.\<Node\>.Generated@.+-}+genPrefixFor :: Context -> Text -> Text+genPrefixFor ctx node = case placement ctx of+    GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> "." <> node+    CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> "." <> node <> ".Generated"++{- | The hand-owned (hole) namespace for a node: @\<root\>.\<Ctx\>.\<Node\>@ —+the same for both placement styles (holes always sit beside the domain).+-}+holePrefixFor :: Context -> Text -> Text+holePrefixFor ctx node = rootPrefix ctx <> ctxPascalOf ctx <> "." <> node++-- | The root namespace prefix, dot-terminated, or @""@ when no root is set.+rootPrefix :: Context -> Text+rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "."++-- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@.+ctxPascalOf :: Context -> Text+ctxPascalOf = pascalFromKebab . contextName++--------------------------------------------------------------------------------+-- Firewall self-check (M3)+--------------------------------------------------------------------------------++{- | The canonical keiki surface forbidden in generated modules. Symbolic+operators are matched as maximal Haskell symbol tokens, identifiers as complete+tokens, qualifiers by their leading module alias, and imports structurally.+-}+data FirewallSurface = FirewallSurface+    { forbiddenSymbolic :: ![Text]+    , forbiddenIdents :: ![Text]+    , forbiddenQualifiers :: ![Text]+    , forbiddenImports :: ![Text]+    , restrictedImports :: ![(Text, [Text])]+    }+    deriving stock (Eq, Show)++firewallSurface :: FirewallSurface+firewallSurface =+    FirewallSurface+        { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"]+        , forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"]+        , forbiddenQualifiers = ["B"]+        , forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"]+        , -- Generated aggregate modules use the first two names; generated+          -- harnesses use the final three to validate and step filled holes.+          restrictedImports = [("Keiki.Core", ["RegFile", "HsPred", "defaultValidationOptions", "step", "validateTransducer"])]+        }++{- | Scan generated modules for firewall breaches, returning every offending+@(module path, token, 1-based line number)@. Only modules whose 'kind' is+'Generated' are scanned. Strings and comments are skipped, symbol runs use+maximal munch, and keiki imports are checked independently of token spelling.+-}+firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)]+firewallBreaches mods =+    [ (modulePath m, breach, n)+    | m <- mods+    , kind m == Generated+    , (n, line) <- zip [1 ..] (T.lines (moduleText m))+    , breach <- lineBreaches line+    ]++lineBreaches :: Text -> [Text]+lineBreaches line = case importModule line of+    Just _ -> importBreaches line+    Nothing -> tokenBreaches (codeTokens line)+  where+    tokenBreaches = mapMaybe breachFor+    breachFor (IdentToken ident)+        | ident `elem` forbiddenIdents firewallSurface = Just ident+    breachFor (QualifiedToken qualifier)+        | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*")+    breachFor (SymbolToken symbol)+        | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol+    breachFor _ = Nothing++data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text++codeTokens :: Text -> [CodeToken]+codeTokens = go . T.unpack+  where+    go [] = []+    go ('-' : '-' : _) = []+    go ('"' : rest) = go (dropString rest)+    go ('\'' : rest) = go (dropChar rest)+    go (c : rest)+        | isIdentStart c =+            let (identTail, afterIdent) = span isIdentContinue rest+                ident = T.pack (c : identTail)+             in case afterIdent of+                    '.' : next : more+                        | isUpper c && isIdentStart next ->+                            let (_member, afterMember) = span isIdentContinue more+                             in QualifiedToken ident : go afterMember+                    _ -> IdentToken ident : go afterIdent+        | isSymbolChar c =+            let (symbolTail, afterSymbol) = span isSymbolChar rest+             in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol+        | otherwise = go rest+    isIdentStart c = isAlpha c || c == '_'+    isIdentContinue c = isAlphaNum c || c == '_' || c == '\''+    isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String)+    dropString [] = []+    dropString ('\\' : _escaped : rest) = dropString rest+    dropString ('"' : rest) = rest+    dropString (_ : rest) = dropString rest+    dropChar [] = []+    dropChar ('\\' : _escaped : rest) = dropChar rest+    dropChar ('\'' : rest) = rest+    dropChar (_ : rest) = dropChar rest++importBreaches :: Text -> [Text]+importBreaches line = case importModule line of+    Nothing -> []+    Just imported+        | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported]+        | Just allowed <- lookup imported (restrictedImports firewallSurface)+        , not (hasAllowedExplicitImportList allowed line) ->+            ["import:" <> imported]+        | otherwise -> []++importModule :: Text -> Maybe Text+importModule line = case T.words (T.strip line) of+    "import" : rest -> find (T.isPrefixOf "Keiki.") rest+    _ -> Nothing++hasAllowedExplicitImportList :: [Text] -> Text -> Bool+hasAllowedExplicitImportList allowed line =+    case (T.breakOn "(" line, T.breakOnEnd ")" line) of+        ((_, open), (close, _))+            | not (T.null open) && not (T.null close) ->+                let inside = T.takeWhile (/= ')') (T.drop 1 open)+                    names = filter (not . T.null) (T.split (not . isAlphaNum) inside)+                 in all (`elem` allowed) names+        _ -> False++--------------------------------------------------------------------------------+-- Derived naming+--------------------------------------------------------------------------------++-- | Resolved, denormalized view of an aggregate used by every emitter.+data Agg = Agg+    { aContext :: !Context+    , aCtxPascal :: !Text+    , aName :: !Text+    , aLoc :: !Loc+    , aVertexType :: !Text+    , aIds :: ![IdDecl]+    , aEnums :: ![EnumDecl]+    , aRegs :: ![RegDecl]+    , aStates :: ![StateDecl]+    , aCommands :: ![ResolvedCtor]+    , aEvents :: ![ResolvedCtor]+    , aTransitions :: ![Transition]+    , aWire :: !WireSpec+    , aProjection :: !(Maybe ProjectionSpec)+    , aSnapshot :: !(Maybe SnapshotSpec)+    , aReadModels :: ![ReadModelNode]+    , aGenPrefix :: !Text+    -- ^ e.g. @Generated.HospitalCapacity.Reservation@+    , aHolePrefix :: !Text+    -- ^ e.g. @HospitalCapacity.Reservation@+    }++-- | A command or event constructor with its fully-resolved field types.+data ResolvedCtor = ResolvedCtor+    { rcName :: !Text+    , rcFields :: ![(Text, Text)]+    -- ^ (field name, resolved Haskell type)+    , rcVersion :: !Int+    -- ^ EP-2: schema version (1 for commands and unversioned events).+    , rcUpcastFrom :: !(Maybe Int)+    -- ^ EP-2: the source version this event migrates from (the upcaster step).+    }++defaultWire :: WireSpec+defaultWire = WireSpec{wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1}++resolveAgg :: Context -> Spec -> Aggregate -> Agg+resolveAgg ctx spec agg =+    Agg+        { aContext = ctx+        , aCtxPascal = ctxPascal+        , aName = nm+        , aLoc = aggLoc agg+        , aVertexType = vertexType+        , aIds = specIds spec+        , aEnums = specEnums spec+        , aRegs = aggRegs agg+        , aStates = aggStates agg+        , aCommands = map resolveCommand (aggCommands agg)+        , aEvents = map resolveEvent (aggEvents agg)+        , aTransitions = aggTransitions agg+        , aWire = fromMaybe defaultWire (aggWire agg)+        , aProjection = aggProjection agg+        , aSnapshot = aggSnapshot agg+        , aReadModels = [readModel | NReadModel readModel <- specNodes spec]+        , aGenPrefix = genPrefixFor ctx nm+        , aHolePrefix = holePrefixFor ctx nm+        }+  where+    nm = aggName agg+    ctxPascal = pascalFromKebab (contextName ctx)+    vertexType = nm <> "Vertex"+    commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg]+    resolveCommand c = (mkCtor (cmdName c) (cmdFields c)){rcVersion = 1, rcUpcastFrom = Nothing}+    resolveEvent e =+        (mkCtor (evName e) (eventFields e))+            { rcVersion = evVersion e+            , rcUpcastFrom = fst <$> evUpcastFrom e+            }+      where+        eventFields ev = case evBody ev of+            EventFields fs -> fs+            EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes)+    mkCtor cn fs =+        ResolvedCtor+            { rcName = cn+            , rcFields = map (\f -> (fieldName f, resolveFieldType f)) fs+            , rcVersion = 1+            , rcUpcastFrom = Nothing+            }+    regTypes = [(regName r, regType r) | r <- aggRegs agg]+    idNames = map idName (specIds spec)+    enumNames = map enumName (specEnums spec)+    -- A bare field reuses a register's type if one shares its name; else it+    -- Pascal-cases to a declared id/enum/vertex; else falls back to Text.+    resolveFieldType f = case fieldType f of+        Just ty -> ty+        Nothing ->+            let nme = fieldName f+                pas = pascal nme+             in case lookup nme regTypes of+                    Just ty -> ty+                    Nothing+                        | pas `elem` idNames -> pas+                        | pas `elem` enumNames -> pas+                        | pas == vertexType -> pas+                        | otherwise -> "Text"++--------------------------------------------------------------------------------+-- Entry point+--------------------------------------------------------------------------------++{- | Emit all modules for one aggregate. The 'Spec' is needed for the shared+id\/enum declarations.+-}+scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule]+scaffoldAggregate ctx spec agg =+    [ genModule a "Domain" (emitDomain a)+    , genModule a "Codec" (emitCodec a)+    , genModule a "EventStream" (emitEventStream a)+    , genModule a "Projection" (emitProjection a)+    , holeModule a (emitHoles a)+    ]+  where+    a = resolveAgg ctx spec agg++genModule :: Agg -> Text -> Text -> ScaffoldModule+genModule a name body =+    ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/" <> name <> ".hs")+        , moduleText = body+        , kind = Generated+        , origin = nodeOrigin "aggregate" (aName a) (aLoc a)+        }++holeModule :: Agg -> Text -> ScaffoldModule+holeModule a body =+    ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" (aHolePrefix a) <> "/" <> "Holes.hs")+        , moduleText = body+        , kind = HoleStub+        , origin = nodeOrigin "aggregate" (aName a) (aLoc a)+        }++--------------------------------------------------------------------------------+-- Integration contract (EP-4): a self-contained payload ADT + codec+--------------------------------------------------------------------------------++{- | Emit the deterministic, symbol-free contract layer: a payload ADT+(per-event records), the topic constants, the @messageType@ discriminator, and a+strict encode\/decode keyed by it. Self-contained (base\/text\/aeson), so it+compiles standalone — the cross-service schema both producer and consumer agree+on. No keiki symbolic operator (firewall holds).+-}+scaffoldContract :: Context -> ContractNode -> [ScaffoldModule]+scaffoldContract ctx c =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs")+        , moduleText = emitContractGen genPrefix c+        , kind = Generated+        , origin = nodeOrigin "contract" (ctrName c) (ctrLoc c)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (pascal (ctrName c))++emitContractGen :: Text -> ContractNode -> Text+emitContractGen genPrefix c =+    nl $+        [ "{-# LANGUAGE DuplicateRecordFields #-}"+        , "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".Contract"+        , "  ( " <> payloadTy <> " (..)"+        , nl ["  , " <> ceName e <> "Data (..)" | e <- ctrEvents c]+        , "  , messageTypeOf"+        , "  , encode" <> payloadTy+        , "  , parse" <> payloadTy+        , "  ) where"+        , ""+        , "import Data.Aeson (Value, object, withObject, (.:), (.=))"+        , "import Data.Aeson.Types (Parser, parseEither)"+        , "import Data.Text (Text)"+        , "import qualified Data.Text as T"+        , ""+        , "-- topic constants"+        ]+            ++ [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow t | (alias, t) <- ctrTopics c]+            ++ [ ""+               , "-- the closed payload set (discriminated by " <> tshow (ctrDiscriminator c) <> ")"+               ]+            ++ [emitPayloadAdt payloadTy (ctrEvents c)]+            ++ [ ""+               , "messageTypeOf :: " <> payloadTy <> " -> Text"+               , "messageTypeOf = \\case"+               ]+            ++ ["  " <> ceName e <> " {} -> " <> tshow (ceName e) | e <- ctrEvents c]+            ++ [ ""+               , "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value"+               , "encode" <> payloadTy <> " = \\case"+               ]+            ++ concatMap encodeArm (ctrEvents c)+            ++ [ ""+               , "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy+               , "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)"+               , "  where"+               , "    go o = do"+               , "      kind <- o .: " <> tshow (ctrDiscriminator c) <> " :: Parser Text"+               , "      case kind of"+               ]+            ++ concatMap decodeArm (ctrEvents c)+            ++ [ "        _ -> fail \"unknown message type\""+               , ""+               , "mapLeftText :: Either String b -> Either Text b"+               , "mapLeftText = either (Left . T.pack) Right"+               ]+  where+    payloadTy = pascal (ctrName c) <> "Payload"+    encodeArm e =+        [ "  " <> ceName e <> " payload ->"+        , "    object"+        ]+            ++ [lead i kv | (i, kv) <- zip [(0 :: Int) ..] ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : [tshow (cfName f) <> " .= payload." <> cfName f | f <- ceFields e])]+            ++ ["      ]"]+    lead 0 kv = "      [ " <> kv+    lead _ kv = "      , " <> kv+    decodeArm e =+        [ "        " <> tshow (ceName e) <> " ->"+        , "          " <> ceName e <> " <$> (" <> ceName e <> "Data" <> fieldApps (ceFields e) <> ")"+        ]+    fieldApps [] = ""+    fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (cfName f) | f <- fs]++emitPayloadAdt :: Text -> [ContractEvent] -> Text+emitPayloadAdt tyName events =+    sectionsOf [map dataRecord events, [sumDecl]]+  where+    hsType CText = "Text"+    hsType CInt = "Int"+    hsType (CTypeId _) = "Text"+    dataRecord e =+        "data "+            <> ceName e+            <> "Data = "+            <> ceName e+            <> "Data { "+            <> T.intercalate ", " [cfName f <> " :: !" <> hsType (cfType f) | f <- ceFields e]+            <> " }\n  deriving stock (Eq, Show)"+    arm e = ceName e <> " !" <> ceName e <> "Data"+    sumDecl = case events of+        [] -> "data " <> tyName <> " = " <> tyName <> "Empty\n  deriving stock (Eq, Show)"+        (e : es) ->+            nl $+                ["data " <> tyName <> " = " <> arm e]+                    ++ ["  | " <> arm e2 | e2 <- es]+                    ++ ["  deriving stock (Eq, Show)"]++--------------------------------------------------------------------------------+-- Integration intake (EP-4): inbox disposition vs the live Keiro.Inbox runtime+--------------------------------------------------------------------------------++{- | Emit the inbox node's deterministic disposition wiring compiled against the+LIVE @Keiro.Inbox.Types@: the dedupe policy (a real 'InboxDedupePolicy') and a+disposition function over the real @InboxResult@ (Processed\/Duplicate\/+InProgress\/PreviouslyFailed). This pins the dangerous inversions+(duplicate ⇒ ackOk, previouslyFailed ⇒ deadLetter) as compiled code over the+runtime types. The handler-level decode\/dedupe\/store failures are noted but not+part of @InboxResult@. Firewall holds (no keiki symbolic operator).+-}+scaffoldIntake :: Context -> IntakeNode -> [ScaffoldModule]+scaffoldIntake ctx i =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Inbox.hs")+        , moduleText = emitIntakeGen genPrefix i+        , kind = Generated+        , origin = nodeOrigin "intake" (inkName i) (inkLoc i)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (pascal (inkName i))++emitIntakeGen :: Text -> IntakeNode -> Text+emitIntakeGen genPrefix i =+    nl+        [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".Inbox"+        , "  ( InboxAck (..)"+        , "  , inboxDedupePolicy"+        , "  , inboxPersistence"+        , "  , inboxDisposition"+        , "  ) where"+        , ""+        , "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))"+        , ""+        , "-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy."+        , "inboxDedupePolicy :: InboxDedupePolicy"+        , "inboxDedupePolicy = " <> inkDedupePolicy i+        , ""+        , "{- | Success-path envelope retention passed to runInboxTransactionWith."+        , "Failures always retain their full operator-facing dead-letter envelope."+        , "Dedupe-only success rows decode with an empty payload."+        , "-}"+        , "inboxPersistence :: InboxPersistence"+        , "inboxPersistence = " <> persistenceCtor (inkPersist i)+        , ""+        , "-- The service's ack decision for each inbox classification."+        , "data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter"+        , "  deriving stock (Eq, Show)"+        , ""+        , "-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult."+        , "-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous"+        , "-- inversions the spec states explicitly."+        , "inboxDisposition :: InboxResult a -> InboxAck"+        , "inboxDisposition r = case r of"+        , "  InboxProcessed _ -> " <> ackFor "processed"+        , "  InboxDuplicate -> " <> ackFor "duplicate"+        , "  InboxInProgress -> " <> ackFor "inProgress"+        , "  InboxPreviouslyFailed _ -> " <> ackFor "previouslyFailed"+        , ""+        , "-- handler-level failures (not InboxResult): decodeFailed => "+            <> ackText "decodeFailed"+            <> ", dedupeFailed => "+            <> ackText "dedupeFailed"+            <> ", storeFailed => "+            <> ackText "storeFailed"+        ]+  where+    act o = lookup o [(drOutcome r, drAction r) | r <- inkDisposition i]+    ackFor o = case act o of+        Just IAckOk -> "InboxAckOk"+        Just (IRetry _) -> "InboxRetry"+        Just (IDeadLetter _) -> "InboxDeadLetter"+        Nothing -> "InboxRetry"+    ackText o = case act o of+        Just IAckOk -> "ackOk"+        Just (IRetry _) -> "retry"+        Just (IDeadLetter _) -> "deadLetter"+        Nothing -> "retry"+    persistenceCtor InkPersistFull = "PersistFullEnvelope"+    persistenceCtor InkPersistDedupeOnly = "PersistDedupeOnly"++--------------------------------------------------------------------------------+-- Integration publisher (EP-4): config vs the live Keiro.Outbox runtime+--------------------------------------------------------------------------------++{- | Emit the publisher's at-least-once policy compiled against the LIVE+@Keiro.Outbox.Types@: the ordering policy (a real 'OrderingPolicy'), the backoff+curve (a real 'BackoffSchedule'), and the max-attempts ceiling. Firewall holds.+-}+scaffoldPublisher :: Context -> PublisherNode -> [ScaffoldModule]+scaffoldPublisher ctx pb =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs")+        , moduleText = emitPublisherGen genPrefix pb+        , kind = Generated+        , origin = nodeOrigin "publisher" (pubName pb) (pubLoc pb)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (pascal (pubName pb))++emitPublisherGen :: Text -> PublisherNode -> Text+emitPublisherGen genPrefix pb =+    nl+        [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".Publisher"+        , "  ( publisherOrdering"+        , "  , publisherBackoff"+        , "  , publisherMaxAttempts"+        , "  ) where"+        , ""+        , "import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))"+        , ""+        , "publisherOrdering :: OrderingPolicy"+        , "publisherOrdering = " <> pubOrdering pb+        , ""+        , "publisherBackoff :: BackoffSchedule"+        , "publisherBackoff = " <> backoffExpr (pubBackoff pb)+        , ""+        , "publisherMaxAttempts :: Int"+        , "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb)+        ]+  where+    backoffExpr b = case boKind b of+        "constant" -> "ConstantBackoff " <> windowText (boWindow b)+        "exponential" ->+            "ExponentialBackoff ExponentialBackoffOptions { initial = "+                <> windowText (boWindow b)+                <> ", maxDelay = "+                <> maybe "0" windowText (boMax b)+                <> ", multiplier = "+                <> fromMaybe "0" (boMultiplier b)+                <> " }"+        _ -> "error \"keiro-dsl: unlowerable backoff kind\""++--------------------------------------------------------------------------------+-- pgmq workqueue (EP-5): a self-contained Job payload record + codec+--------------------------------------------------------------------------------++{- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the+field→wire-name JSON codec, and the captured physical\/dlq\/table name constants.+Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup+predicate are holes (not emitted). Firewall holds.+-}+scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule]+scaffoldWorkqueue ctx w =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs")+        , moduleText = emitWorkqueueGen genPrefix w+        , kind = Generated+        , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)+        }+    , ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs")+        , moduleText = emitQueuePolicy genPrefix w+        , kind = Generated+        , origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)+        }+    ]+  where+    genPrefix = genPrefixFor ctx (pascal (wqName w))++emitWorkqueueGen :: Text -> WorkqueueNode -> Text+emitWorkqueueGen genPrefix w =+    nl $+        [ "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".Queue"+        , "  ( " <> payloadTy <> " (..)"+        , "  , encode" <> payloadTy+        , "  , parse" <> payloadTy+        , "  , queuePhysical, queueDlq, queueTable"+        , groupKeyExport+        , "  ) where"+        , ""+        , "import Data.Aeson (Value, object, withObject, (.:), (.=))"+        , "import Data.Aeson.Types (parseEither)"+        , "import Data.Text (Text)"+        , "import qualified Data.Text as T"+        , ""+        , "queuePhysical, queueDlq, queueTable :: Text"+        , "queuePhysical = " <> tshow (wqPhysical w)+        , "queueDlq = " <> tshow (wqDlq w)+        , "queueTable = " <> tshow (wqTable w)+        , ""+        ]+            ++ groupKeyLines+            ++ [ "data " <> payloadTy <> " = " <> payloadTy+               , "  { " <> T.intercalate "\n  , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w]+               , "  }"+               , "  deriving stock (Eq, Show)"+               , ""+               , "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value"+               , "encode" <> payloadTy <> " p ="+               , "  object"+               ]+            ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)]+            ++ [ "    ]"+               , ""+               , "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy+               , "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)"+               , "  where"+               , "    go o = " <> payloadTy <> fieldApps (wqPayload w)+               , ""+               , "mapLeftText :: Either String b -> Either Text b"+               , "mapLeftText = either (Left . T.pack) Right"+               ]+  where+    payloadTy = wqPayloadName w+    groupKeyExport = case wqGroupKey w of+        Nothing -> ""+        Just groupKey+            | gkVia groupKey == "raw" -> "  , groupKeyField, groupKeyFor"+            | otherwise -> "  , groupKeyField"+    groupKeyLines = case wqGroupKey w of+        Nothing -> []+        Just groupKey -> common <> derivationLines groupKey+          where+            common =+                [ "groupKeyField :: Text"+                , "groupKeyField = " <> tshow (gkField groupKey)+                , ""+                ]+            derivationLines key+                | gkVia key == "raw" =+                    [ "groupKeyFor :: " <> payloadTy <> " -> Text"+                    , "groupKeyFor payload = payload." <> gkField key+                    , ""+                    ]+                | otherwise =+                    [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned."+                    , "-- Captured fixture: " <> fromMaybe "<missing>" (gkFixture key)+                    , ""+                    ]+    hsType "bool" = "Bool"+    hsType "int" = "Int"+    hsType _ = "Text"+    lead 0 kv = "    [ " <> kv+    lead _ kv = "    , " <> kv+    fieldApps [] = ""+    fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (wqfWire f) | f <- fs]++{- | Emit the pgmq retry policy + JobOutcome disposition compiled against the+LIVE @Keiro.PGMQ.Job@ runtime (RetryPolicy / JobOutcome / RetryDelay). This pins+the dangerous inversions over the runtime types: storeFailure ⇒ Retry (transient)+and decodeFailure ⇒ Dead (poison).+-}+emitQueuePolicy :: Text -> WorkqueueNode -> Text+emitQueuePolicy genPrefix w =+    nl $+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".QueuePolicy"+        , "  ( retryPolicy, jobOutcomeFor"+        , "  , jobOrdering, jobTuningFor, queueProvision"+        , "  ) where"+        , ""+        , "import Data.Text (Text)"+        , "import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)"+        , ""+        , "jobOrdering :: JobOrdering"+        , "jobOrdering = " <> orderingCtor+        , ""+        , "-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering."+        , "jobTuningFor :: JobTuning -> JobTuning"+        , "jobTuningFor = withOrdering jobOrdering"+        , ""+        , "-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard."+        , "queueProvision :: QueueProvision"+        , "queueProvision = " <> provisionExpr+        , ""+        , "retryPolicy :: RetryPolicy"+        , "retryPolicy ="+        , "  RetryPolicy"+        , "    { maxRetries = " <> tshow' (wqMaxRetries w)+        , "    , defaultRetryDelay = RetryDelay " <> windowText (wqDelay w)+        , "    , useDeadLetter = " <> (if wqDlqOn w then "True" else "False")+        , "    }"+        , ""+        , "-- The consumer JobOutcome disposition over the spec's named domain outcomes,"+        , "-- lowered to the live Keiro.PGMQ.Job.JobOutcome."+        , "jobOutcomeFor :: Text -> JobOutcome"+        , "jobOutcomeFor o = case o of"+        ]+            ++ ["  " <> tshow (wqdOutcome r) <> " -> " <> outcome (wqdAction r) | r <- wqDisposition w]+            ++ ["  _ -> Retry (RetryDelay " <> windowText (wqDelay w) <> ")"]+  where+    orderingCtor = case wqOrdering w of+        WqUnordered -> "Unordered"+        WqFifoThroughput -> "FifoThroughput"+        WqFifoRoundRobin -> "FifoRoundRobin"+    provisionExpr = fifoWrap baseProvision+    fifoWrap expression = case wqOrdering w of+        WqUnordered -> expression+        _ -> "withFifoIndexProvision (" <> expression <> ")"+    baseProvision = case wqProvision w of+        WqStandard -> "standardProvision"+        WqUnlogged -> "unloggedProvision"+        WqPartitioned interval retention ->+            "partitionedProvision (PartitionSpec { partitionInterval = "+                <> tshow interval+                <> ", retentionInterval = "+                <> tshow retention+                <> " })"+    outcome IAckOk = "Done"+    outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")"+    outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr)++--------------------------------------------------------------------------------+-- First-class read models (EP-107)+--------------------------------------------------------------------------------++{- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the+qualified-table constant shared by the hand-owned query and the generated+runtime record; @ReadModel@ re-exports it as part of the public surface.+-}+scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule]+scaffoldReadModel ctx readModel =+    [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel)+    , generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel)+    , ScaffoldModule+        { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles"+        , moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel+        , kind = HoleStub+        , origin = readModelOrigin+        }+    ]+  where+    nodeSegment = pascal (rmName readModel)+    stem = readModelStem readModel+    readModelModule = genPrefixFor ctx nodeSegment+    tableModule = readModelModule <> ".ReadModelTable"+    readModelHolePrefix = holePrefixFor ctx nodeSegment+    readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel)+    generated leaf body =+        ScaffoldModule+            { modulePath = modulePathFor readModelModule leaf+            , moduleText = body+            , kind = Generated+            , origin = readModelOrigin+            }++modulePathFor :: Text -> Text -> FilePath+modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs")++readModelStem :: ReadModelNode -> Text+readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName++emitReadModelTable :: Text -> Text -> ReadModelNode -> Text+emitReadModelTable tableModule stem readModel =+    nl+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> tableModule <> " (" <> qualifiedName <> ") where"+        , ""+        , "import Data.Text (Text)"+        , "import Keiro.Connection (qualifyTable)"+        , ""+        , "-- The fully-qualified, double-quoted data-table reference."+        , qualifiedName <> " :: Text"+        , qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel)+        ]+  where+    qualifiedName = stem <> "QualifiedTable"++emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text+emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel =+    nl $+        [ "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> readModelModule <> ".ReadModel"+        , "  ( " <> T.intercalate "\n  , " exports+        , "  ) where"+        , ""+        , "import Data.Functor (void)"+        , "import Effectful (Eff, (:>))"+        , "import " <> tableModule <> " (" <> qualifiedName <> ")"+        , "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")"+        ]+            ++ asyncImports+            ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)"+               , "import Keiro.ReadModel.Rebuild qualified as Rebuild"+               , "import Kiroku.Store.Effect (Store)"+               , "import Kiroku.Store.Types (" <> kirokuTypes <> ")"+               , ""+               , readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType+               , readModelName <> " ="+               , "  ReadModel"+               , "    { name = " <> tshow registryName+               , "    , tableName = " <> tshow (rmTable readModel)+               , "    , schema = " <> tshow (rmSchema readModel)+               , "    , subscriptionName = " <> tshow subscriptionName+               , "    , version = " <> tshow' (rmVersion readModel)+               , "    , shapeHash = " <> tshow (rmShape readModel)+               , "    , defaultConsistency = " <> consistencyExpr (rmConsistency readModel)+               , "    , strongScope = " <> scopeExpr (rmScope readModel)+               , "    , query = " <> queryName+               , "    }"+               , ""+               , "-- Call once at projection startup before serving queries."+               , registerName <> " :: (Store :> es) => Eff es ()"+               , registerName <> " ="+               , "  void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")"+               , ""+               , startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata"+               , startName <> " ="+               , "  Rebuild.startRebuild " <> readModelName <> " " <> projectionNames+               , ""+               , finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)"+               , finishName <> " ="+               , "  Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames+               , ""+               , abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata"+               , abandonName <> " = Rebuild.abandonRebuild " <> readModelName+               ]+            ++ asyncDefinition+  where+    registryName = registryNameFor (contextName ctx) readModel+    subscriptionName = subscriptionNameFor (contextName ctx) readModel+    asyncName = registryName <> "-async"+    readModelName = stem <> "ReadModel"+    qualifiedName = stem <> "QualifiedTable"+    registerName = "register" <> pascal stem+    startName = "start" <> pascal stem <> "Rebuild"+    finishName = "finish" <> pascal stem <> "Rebuild"+    abandonName = "abandon" <> pascal stem <> "Rebuild"+    asyncValueName = stem <> "AsyncProjection"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    exports =+        [ readModelName+        , qualifiedName+        , registerName+        , startName+        , finishName+        , abandonName+        ]+            ++ [asyncValueName | rmFeed readModel == RmSubscription]+    holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription]+    asyncImports = case rmFeed readModel of+        RmInline -> []+        RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"]+    kirokuTypes = case rmFeed readModel of+        RmInline -> "GlobalPosition"+        RmSubscription -> "GlobalPosition, RecordedEvent (..)"+    projectionNames = case rmFeed readModel of+        RmInline -> "[]"+        RmSubscription -> "[" <> tshow asyncName <> "]"+    asyncDefinition = case rmFeed readModel of+        RmInline -> []+        RmSubscription ->+            [ ""+            , asyncValueName <> " :: AsyncProjection"+            , asyncValueName <> " ="+            , "  AsyncProjection"+            , "    { name = " <> tshow asyncName+            , "    , readModelName = " <> tshow registryName+            , "    , subscriptionName = " <> tshow subscriptionName+            , "    , applyRecorded = " <> applyName+            , "    , idempotencyKey = \\recorded -> recorded.eventId"+            , "    }"+            ]+    consistencyExpr Strong = "Strong"+    consistencyExpr Eventual = "Eventual"+    scopeExpr Nothing = "EntireLog"+    scopeExpr (Just RmEntireLog) = "EntireLog"+    scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName++emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text+emitReadModelHoles tableModule readModelHolePrefix stem readModel =+    nl $+        [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it."+        , "module " <> readModelHolePrefix <> ".ReadModelHoles"+        , "  ( " <> T.intercalate "\n  , " exports+        , "  ) where"+        , ""+        , "import " <> tableModule <> " (" <> qualifiedName <> ")"+        , "import Hasql.Transaction qualified as Tx"+        ]+            ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription]+            ++ [ ""+               , "-- HOLE: replace these aliases with the real query input and result types."+               , "type " <> queryInputType <> " = ()"+               , "type " <> queryResultType <> " = ()"+               , ""+               , "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path."+               , "-- Declared columns:"+               ]+            ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)+            ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType+               , queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query")+               ]+            ++ applyStub+  where+    qualifiedName = stem <> "QualifiedTable"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription]+    applyStub = case rmFeed readModel of+        RmInline -> []+        RmSubscription ->+            [ ""+            , "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe."+            , applyName <> " :: RecordedEvent -> Tx.Transaction ()"+            , applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply")+            ]++qualifiedTableLiteral :: ReadModelNode -> Text+qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel)++quoteSqlIdentifier :: Text -> Text+quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\""++readModelColumnDoc :: RmColumn -> Text+readModelColumnDoc columnDecl =+    rmcName columnDecl+        <> " "+        <> rmcType columnDecl+        <> if rmcRequired columnDecl then " NOT NULL" else ""++--------------------------------------------------------------------------------+-- Router + shared worker-policy lowering (EP-108)+--------------------------------------------------------------------------------++scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule]+scaffoldRouter ctx router =+    [ ScaffoldModule+        { modulePath = modulePathFor genPrefix "Router"+        , moduleText = emitRouterGen genPrefix router+        , kind = Generated+        , origin = routerOrigin+        }+    , ScaffoldModule+        { modulePath = modulePathFor holePrefix "RouterHoles"+        , moduleText = emitRouterHoles holePrefix router+        , kind = HoleStub+        , origin = routerOrigin+        }+    ]+  where+    genPrefix = genPrefixFor ctx (rtId router)+    holePrefix = holePrefixFor ctx (rtId router)+    routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router)++emitRouterGen :: Text -> RouterNode -> Text+emitRouterGen genPrefix router =+    nl $+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".Router"+        , "  ( " <> stem <> "Name"+        , "  , " <> stem <> "WorkerOptions"+        , "  ) where"+        , ""+        , "import Data.Text (Text)"+        ]+            ++ workerPolicyImports (rtPoison router)+            ++ [ ""+               , "-- The STABLE router name. It participates in every target-keyed"+               , "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches."+               , stem <> "Name :: Text"+               , stem <> "Name = " <> tshow (rtName router)+               , ""+               , "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,"+               , "-- targetStreamName, occurrence). Target-keyed, not positional."+               , ""+               , "-- Node-level worker policy lowered from the spec. Pass this value to"+               , "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions."+               ]+            ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router)+  where+    stem = lowerFirst (rtId router)++emitRouterHoles :: Text -> RouterNode -> Text+emitRouterHoles holePrefix router =+    nl+        [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies."+        , "-- keiro-dsl creates it once and never overwrites it."+        , "module " <> holePrefix <> ".RouterHoles () where"+        , ""+        , "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]"+        , "--   Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> "."+        , "--   The spec's 'stable' keyword acknowledges that retry attempts accumulate"+        , "--   the UNION of resolved target identities. Keep the recipient set stable"+        , "--   for a source event whenever an exact recipient set matters."+        , "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name,"+        , "--   key, resolve, targetEventStream, and targetProjections; run it with"+        , "--   runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions."+        , "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> "."+        , "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate"+        , "--   event id against the TARGET stream via confirmBenignDuplicate before"+        , "--   returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise."+        ]+  where+    renderNames names = "[" <> T.intercalate ", " names <> "]"++resolveSourceText :: ResolveSource -> Text+resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)"+resolveSourceText ResolveHole = "typed resolver hole"++workerPolicyImports :: PolicyChoice -> [Text]+workerPolicyImports poison =+    [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))"+    , "import Shibuya.Core.Ack (RetryDelay (..))"+    ]+        ++ if poison == PolHalt+            then []+            else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"]++workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text]+workerOptionsLines valueName rejected poison =+    [ valueName <> signature+    , valueName <> argument <> " ="+    , "  WorkerOptions"+    , "    { poisonPolicy = " <> poisonExpr+    , "    , rejectedCommandPolicy = " <> rejectedExpr rejected+    , "    , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning"+    , "    , metrics = Nothing                  -- runtime configuration; install at call site"+    , "    }"+    ]+  where+    signature = case poison of+        PolHalt -> " :: WorkerOptions es msg"+        _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg"+    argument = case poison of+        PolHalt -> ""+        _ -> " poisonCallback"+    poisonExpr = case poison of+        PolHalt -> "PoisonHalt"+        PolDeadLetter -> "PoisonDeadLetter poisonCallback"+        PolSkip -> "PoisonSkip poisonCallback"+    rejectedExpr = \case+        PolHalt -> "RejectedHalt"+        PolDeadLetter -> "RejectedDeadLetter"+        PolSkip -> "RejectedSkip"++--------------------------------------------------------------------------------+-- Process manager + durable timer (EP-3)+--------------------------------------------------------------------------------++{- | Emit the symbol-free deterministic wiring for a process manager + its timer+into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the+behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the+fire command). The @Generated@ module contains no keiki symbolic operator (the+saga's transducer is the separate aggregate hole), so the firewall invariant+holds. The timer worker uses the spec's @max-attempts@ ceiling, never the+dangerous @defaultTimerWorkerOptions@ (@Nothing@) default.+-}+scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule]+scaffoldProcess ctx p =+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs")+        , moduleText = emitProcessGen ctxPascal genPrefix holePrefix p+        , kind = Generated+        , origin = nodeOrigin "process" (procId p) (procLoc p)+        }+    , ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs")+        , moduleText = emitProcessHoles genPrefix holePrefix p+        , kind = HoleStub+        , origin = nodeOrigin "process" (procId p) (procLoc p)+        }+    ]+  where+    ctxPascal = pascalFromKebab (contextName ctx)+    genPrefix = genPrefixFor ctx (procId p)+    holePrefix = holePrefixFor ctx (procId p)++emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text+emitProcessGen _ctxPascal genPrefix _holePrefix p =+    nl $+        [ "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> genPrefix <> ".Process"+        , "  ( " <> lo <> "ProcessName"+        , "  , " <> lo <> "Category"+        , "  , " <> lo <> "ProcessWorkerOptions"+        , "  , " <> lo <> "TimerRequest"+        , "  , " <> lo <> "FireOutcome"+        , "  ) where"+        , ""+        , "import Data.Aeson (Value, object, (.=))"+        , "import Data.Text (Text)"+        , "import qualified Data.Text as T"+        , "import Data.Time (UTCTime)"+        , "import Data.UUID (UUID)"+        , "import qualified Data.UUID.V5 as UUID.V5"+        , "import Keiro.Command (CommandError (..))"+        , "import Keiro.Stream qualified as Stream"+        , "import Keiro.Timer (TimerId (..), TimerRequest (..))"+        ]+            ++ workerPolicyImports (procPoison p)+            ++ [ ""+               , "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped)."+               , lo <> "ProcessName :: Text"+               , lo <> "ProcessName = " <> tshow (procName p)+               , ""+               , "-- The validated saga stream category (hole-kind 5: referenced, never retyped)."+               , "-- Saga streams are '<category>-<correlationId>' via Keiro.Stream.entityStream."+               , "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal."+               , lo <> "Category :: Stream.StreamCategory a"+               , lo <> "Category = Stream.categoryUnsafe " <> tshow categoryName+               , ""+               , "-- Node-level worker policy lowered from the spec. Pass this value to"+               , "-- Keiro.ProcessManager.runProcessManagerWorkerWith."+               ]+            ++ workerOptionsLines (lo <> "ProcessWorkerOptions") (procRejected p) (procPoison p)+            ++ [ ""+               , "-- The deterministic timer-request builder: id derived from the correlation"+               , "-- key (hole-kind 1), processManagerName referenced, payload from the spec."+               , "-- (timer id derived as uuidv5 of " <> tshow (idePrefix (tmId timer)) <> " <> correlationId)"+               , lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest"+               , lo <> "TimerRequest correlationId fireAtTime ="+               , "  TimerRequest"+               , "    { timerId = TimerId (namedUuid (" <> tshow (idePrefix (tmId timer)) <> " <> correlationId))"+               , "    , processManagerName = " <> lo <> "ProcessName"+               , "    , correlationId = correlationId"+               , "    , fireAt = fireAtTime"+               , "    , payload = " <> payloadExpr (tmPayload timer)+               , "    }"+               , ""+               , "-- The timer-fire disposition table (hole-kind 2), derived from the spec."+               , "-- on-reject => " <> showOutcome (onReject fd) <> " is the benign inversion."+               , "-- A duplicate append reaches on-error unless it is confirmed against the"+               , "-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:"+               , "--   StreamName -> EventId -> CommandError -> Eff es Bool"+               , "-- Fold True into the duplicate result and surface False as the failure."+               , lo <> "FireOutcome :: Either CommandError a -> Maybe ()"+               , lo <> "FireOutcome result = case result of"+               , "  Right{} -> " <> outcomeToMaybe (onOk fd)+               , "  Left CommandRejected -> " <> outcomeToMaybe (onReject fd)+               , "  Left (CommandAmbiguous _) -> " <> outcomeToMaybe (onAmbiguous fd) <> "  -- explicit definition-bug arm"+               , "  Left{} -> " <> outcomeToMaybe (onError fd)+               , ""+               , "-- max-attempts = " <> tshow' (tmMaxAttempts timer) <> ", dead-letter = " <> tshow (tmDeadLetter timer)+               , "-- (the timer worker must pass Just " <> tshow' (tmMaxAttempts timer) <> " to runTimerWorkerWith, never the"+               , "--  defaultTimerWorkerOptions Nothing ceiling that retries forever)."+               , ""+               , "-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1)."+               , "namedUuid :: Text -> UUID"+               , "namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))"+               ]+  where+    lo = lowerFirst (procId p)+    categoryName = staticCategory ("process " <> procId p) (sagaCategory (procSaga p))+    timer = procTimer p+    fd = fireDisposition (tmFire timer)++{- | The timer payload, restricted to the spec's literal (@name=\"value\"@)+bindings so it compiles in the deterministic builder. Bare fields and+ref-valued bindings are input-driven (the agent-written hole), not emitted.+-}+payloadExpr :: [FieldBinding] -> Text+payloadExpr fs = case [b | b <- fs, isLiteral b] of+    [] -> "object []"+    lits -> "object [ " <> T.intercalate ", " (map kv lits) <> " ]"+  where+    isLiteral b = maybe False (const True) (fbValue b >>= stripWrappingQuotes)+    kv b = tshow (fbName b) <> " .= (" <> maybe "\"\"" tshow (fbValue b >>= stripWrappingQuotes) <> " :: Value)"+    stripWrappingQuotes value = T.stripPrefix "\"" value >>= T.stripSuffix "\""++showOutcome :: FireOutcome -> Text+showOutcome OFired = "Fired"+showOutcome ORetry = "Retry"++outcomeToMaybe :: FireOutcome -> Text+outcomeToMaybe OFired = "Just ()  -- Fired"+outcomeToMaybe ORetry = "Nothing  -- Retry"++emitProcessHoles :: Text -> Text -> ProcessNode -> Text+emitProcessHoles _genPrefix holePrefix p =+    nl+        [ "-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies."+        , "-- keiro-dsl creates it once and never overwrites it."+        , "module " <> holePrefix <> ".ProcessHoles () where"+        , ""+        , "-- HOLE handle: build the ProcessManagerAction (the self-advance"+        , "--   '" <> advCommand (hAdvance (procHandle p)) <> "', the dispatch(es), and the timer) from the input."+        , "-- HOLE streams: build streamFor with entityStream " <> lowerFirst (procId p) <> "Category;"+        , "--   build target streams with entityStream " <> lowerFirst (procTarget p) <> "Category. Never concatenate raw stream names."+        , "-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;"+        , "--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED)."+        , "-- HOLE fire command: construct " <> fireCommand (tmFire (procTimer p)) <> " for the timer fire,"+        , "--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of"+        , "--   " <> tshow (idePrefix (fireFiredEventId (tmFire (procTimer p)))) <> " <> correlationId."+        , "-- NOTE on-duplicate AckOk is sound because the runtime confirms a duplicate"+        , "--   event id against the TARGET stream via confirmBenignDuplicate before"+        , "--   returning PMCommandDuplicate. Its effective signature is:"+        , "--     StreamName -> EventId -> CommandError -> Eff es Bool"+        , "--   Hand-rolled paths must call it with the target stream and attempted event id,"+        , "--   fold True into the duplicate result, and surface False as the original failure."+        , "--   Never pattern-match DuplicateEvent as success: event ids are globally unique."+        ]++--------------------------------------------------------------------------------+-- Domain module+--------------------------------------------------------------------------------++emitDomain :: Agg -> Text+emitDomain a =+    nl $+        [ "{-# LANGUAGE DataKinds #-}"+        , "{-# LANGUAGE DuplicateRecordFields #-}"+        ]+            ++ ["{-# LANGUAGE DeriveAnyClass #-}" | hasSnapshot a]+            ++ [ "{-# LANGUAGE OverloadedStrings #-}"+               , "{-# LANGUAGE TemplateHaskell #-}"+               , "{-# LANGUAGE TypeApplications #-}"+               , "{-# OPTIONS_GHC -Wno-unused-top-binds #-}"+               , generatedBanner+               , "module " <> aGenPrefix a <> ".Domain where"+               , ""+               ]+            ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a]+            ++ [ "import Data.Proxy (Proxy (..))"+               , "import Data.Text (Text)"+               , "import GHC.Generics (Generic)"+               , "import Keiki.Core (RegFile (..))"+               ]+            ++ ["import Keiki.Shape (CanonicalTypeName)" | hasSnapshot a]+            ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)"+               , ""+               , sectionsOf+                    [ map (emitId a) (aIds a)+                    , map (emitEnum a) (aEnums a)+                    , [emitVertex a]+                    , map (emitRecord) (aCommands a)+                    , [emitSum (aName a <> "Command") (aCommands a)]+                    , map (emitRecord) (aEvents a)+                    , [emitSum (aName a <> "Event") (aEvents a)]+                    , [emitRegsType a, emitInitialRegs a]+                    ,+                        [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)"+                        , ""+                        , "$(deriveWireCtorsAll ''" <> aName a <> "Event)"+                        ]+                    ]+               ]++hasSnapshot :: Agg -> Bool+hasSnapshot = maybe False (const True) . aSnapshot++emitId :: Agg -> IdDecl -> Text+emitId a d =+    nl $+        [ "newtype " <> idName d <> " = " <> idName d <> " Text"+        , "  deriving stock (Generic, Eq, Ord, Show)"+        ]+            ++ ["  deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a]+            ++ ["instance CanonicalTypeName " <> idName d | hasSnapshot a]+            ++ [ ""+               , lowerFirst (idName d) <> "Text :: " <> idName d <> " -> Text"+               , lowerFirst (idName d) <> "Text (" <> idName d <> " t) = t"+               ]++emitEnum :: Agg -> EnumDecl -> Text+emitEnum a d =+    nl $+        [ "data " <> enumName d <> " = " <> T.intercalate " | " (map fst (enumCtors d))+        , "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)"+        ]+            ++ ["  deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a]+            ++ ["instance CanonicalTypeName " <> enumName d | hasSnapshot a]+            ++ [ ""+               , lowerFirst (enumName d) <> "Text :: " <> enumName d <> " -> Text"+               , lowerFirst (enumName d) <> "Text = \\case"+               , nl ["  " <> c <> " -> " <> tshow w | (c, w) <- enumCtors d]+               ]++emitVertex :: Agg -> Text+emitVertex a =+    nl $+        [ "data " <> aVertexType a <> " = " <> T.intercalate " | " (map (vertexCtor a . stName) (aStates a))+        , "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)"+        ]+            ++ ["  deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a]+            ++ ["instance CanonicalTypeName " <> aVertexType a | hasSnapshot a]++emitRecord :: ResolvedCtor -> Text+emitRecord rc =+    nl $+        [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data"+        ]+            ++ recordFields (rcFields rc)+            ++ ["  deriving stock (Generic, Eq, Show)"]++recordFields :: [(Text, Text)] -> [Text]+recordFields [] =+    ["  {"]+        <> ["  }"]+recordFields fs =+    [ lead i <> n <> " :: !" <> ty+    | (i, (n, ty)) <- zip [(0 :: Int) ..] fs+    ]+        ++ ["  }"]+  where+    lead 0 = "  { "+    lead _ = "  , "++emitSum :: Text -> [ResolvedCtor] -> Text+emitSum tyName ctors =+    nl $+        [firstLine] ++ restLines ++ ["  deriving stock (Generic, Eq, Show)"]+  where+    arm rc = rc' rc+    rc' rc = rcName rc <> " !" <> rcName rc <> "Data"+    (firstLine, restLines) = case ctors of+        [] -> ("data " <> tyName <> " = ()", [])+        (c : cs) ->+            ( "data " <> tyName <> " = " <> arm c+            , ["  | " <> arm c2 | c2 <- cs]+            )++emitRegsType :: Agg -> Text+emitRegsType a =+    nl $+        ["type " <> aName a <> "Regs ="]+            ++ regListLines (aRegs a)++regListLines :: [RegDecl] -> [Text]+regListLines [] = ["  '[]"]+regListLines rs =+    [ lead i <> "'(" <> tshow (regName r) <> ", " <> regType r <> ")"+    | (i, r) <- zip [(0 :: Int) ..] rs+    ]+        ++ ["   ]"]+  where+    lead 0 = "  '[ "+    lead _ = "   , "++emitInitialRegs :: Agg -> Text+emitInitialRegs a =+    nl $+        [ "initial" <> aName a <> "Regs :: RegFile " <> aName a <> "Regs"+        , "initial" <> aName a <> "Regs ="+        ]+            ++ chain (aRegs a)+  where+    chain [] = ["  RNil"]+    chain rs =+        [ "  RCons (Proxy @" <> tshow (regName r) <> ") " <> regInitialValue a r <> " $"+        | r <- init rs+        ]+            ++ ["  RCons (Proxy @" <> tshow (regName lastR) <> ") " <> regInitialValue a lastR <> " RNil"]+      where+        lastR = last rs++-- | The Haskell initial value for a register, by the category of its type.+regInitialValue :: Agg -> RegDecl -> Text+regInitialValue a r+    | regType r `elem` idNames = "(" <> regType r <> " \"\")"+    | regType r == aVertexType a = maybe "(error \"invalid vertex initial\")" (vertexCtor a) (bareInitial r)+    | regType r == "Text" = maybe "(error \"Text initial must be quoted\")" tshow (textInitial r)+    | otherwise = maybe "(error \"invalid register initial\")" id (bareInitial r)+  where+    idNames = map idName (aIds a)+    bareInitial reg = case regInitial reg of+        RegInitBare value -> Just value+        RegInitText _ -> Nothing+    textInitial reg = case regInitial reg of+        RegInitText value -> Just value+        RegInitBare _ -> Nothing++--------------------------------------------------------------------------------+-- Codec module+--------------------------------------------------------------------------------++emitCodec :: Agg -> Text+emitCodec a =+    nl+        [ "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , generatedBanner+        , "module " <> aGenPrefix a <> ".Codec ("+        , "    " <> lowerFirst (aName a) <> "Codec,"+        , "    parse" <> aName a <> "Event,"+        , "    encode" <> aName a <> "Event,"+        , ") where"+        , ""+        , "import " <> aGenPrefix a <> ".Domain"+        , "import Data.Aeson (Value, object, withObject, (.:), (.=))"+        , "import Data.Aeson.Types (Parser, parseEither)"+        , "import Data.List.NonEmpty (NonEmpty (..))"+        , "import Data.Text (Text)"+        , "import qualified Data.Text as T"+        , "import Keiro.Codec (Codec (..), EventType (..))"+        , upcasterImport a+        , ""+        , emitEnumParsers a+        , ""+        , emitCodecValue a+        , ""+        , emitEncode a+        , ""+        , emitDecode a+        , ""+        , "mapLeftText :: Either String b -> Either Text b"+        , "mapLeftText = either (Left . T.pack) Right"+        ]++emitEnumParsers :: Agg -> Text+emitEnumParsers a = sectionsOf [[emitEnumParser e | e <- aEnums a]]++emitEnumParser :: EnumDecl -> Text+emitEnumParser d =+    nl $+        [ "parse" <> enumName d <> " :: Text -> Parser " <> enumName d+        , "parse" <> enumName d <> " = \\case"+        ]+            ++ ["  " <> tshow w <> " -> pure " <> c | (c, w) <- enumCtors d]+            ++ ["  _ -> fail " <> tshow ("unknown " <> enumName d)]++emitCodecValue :: Agg -> Text+emitCodecValue a =+    nl $+        [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event"+        , lowerFirst (aName a) <> "Codec ="+        , "  Codec"+        , "    { eventTypes = " <> eventTypesExpr+        , "    , eventType = \\case"+        ]+            ++ ["        " <> rcName e <> "{} -> EventType " <> tshow (rcName e) | e <- aEvents a]+            ++ [ "    , schemaVersion = " <> tshow' (maxEventVersion a)+               , "    , encode = encode" <> aName a <> "Event"+               , "    , decode = parse" <> aName a <> "Event"+               , "    , upcasters = " <> upcastersExpr a+               , "    }"+               ]+  where+    eventTypesExpr = case map rcName (aEvents a) of+        [] -> "error \"no events\""+        (e : es) -> "EventType " <> tshow e <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) es) <> "]"++-- | The codec's @schemaVersion@: the maximum declared event version (EP-2).+maxEventVersion :: Agg -> Int+maxEventVersion a = maximum (1 : map rcVersion (aEvents a))++{- | One @(sourceVersion, upcasterName)@ entry per event that declares an+@upcast from@. The upcaster name is per-event (e.g. @upcastFooV1@) and its+body is a hole in the hand-owned Holes module.+-}+upcasterEntries :: Agg -> [(Int, Text)]+upcasterEntries a =+    [ (m, "upcast" <> rcName e <> "V" <> tshow' m)+    | e <- aEvents a+    , Just m <- [rcUpcastFrom e]+    ]++upcastersExpr :: Agg -> Text+upcastersExpr a =+    "[" <> T.intercalate ", " ["(" <> tshow' m <> ", const " <> fn <> ")" | (m, fn) <- upcasterEntries a] <> "]"++{- | When the codec references upcasters, it imports their (hole) definitions+from the hand-owned Holes module.+-}+upcasterImport :: Agg -> Text+upcasterImport a = case upcasterEntries a of+    [] -> ""+    es -> "import " <> aHolePrefix a <> ".Holes (" <> T.intercalate ", " (map snd es) <> ")"++emitEncode :: Agg -> Text+emitEncode a =+    nl $+        [ "encode" <> aName a <> "Event :: " <> aName a <> "Event -> Value"+        , "encode" <> aName a <> "Event = \\case"+        ]+            ++ concatMap encodeArm (aEvents a)+  where+    encodeArm e =+        [ "  " <> rcName e <> " payload ->"+        , "    object"+        ]+            ++ [ lead i <> kv+               | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow (rcName e) <> " :: Text)") : map encodeField (rcFields e))+               ]+            ++ ["      ]"]+    lead 0 = "      [ "+    lead _ = "      , "+    encodeField (n, ty) =+        tshow n+            <> " .= "+            <> case fieldCat a ty of+                IdCat -> lowerFirst ty <> "Text payload." <> n+                EnumCat -> lowerFirst ty <> "Text payload." <> n+                _ -> "payload." <> n++emitDecode :: Agg -> Text+emitDecode a =+    nl $+        [ "parse" <> aName a <> "Event :: EventType -> Value -> Either Text " <> aName a <> "Event"+        , "parse" <> aName a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow (aName a <> "Event") <> " go)"+        , "  where"+        , "    go o = do"+        , "      case tag of"+        ]+            ++ concatMap decodeArm (aEvents a)+            ++ ["        _ -> fail \"unknown event type\""]+  where+    decodeArm e =+        [ "        " <> tshow (rcName e) <> " ->"+        , "          " <> rcName e <> " <$> (" <> rcName e <> "Data" <> fieldApps (rcFields e) <> ")"+        ]+    fieldApps [] = ""+    fieldApps fs = " <$> " <> T.intercalate " <*> " (map decodeField fs)+    -- The first field uses <$> (handled above), the rest <*>. We instead build+    -- a uniform list and join; for an empty record there are no fields.+    decodeField (n, ty) = case fieldCat a ty of+        IdCat -> "(" <> ty <> " <$> o .: " <> tshow n <> ")"+        EnumCat -> "(o .: " <> tshow n <> " >>= parse" <> ty <> ")"+        _ -> "o .: " <> tshow n++--------------------------------------------------------------------------------+-- EventStream module+--------------------------------------------------------------------------------++emitEventStream :: Agg -> Text+emitEventStream a =+    nl $+        [ generatedBanner+        , "module " <> aGenPrefix a <> ".EventStream"+        , "  ( " <> lowerFirst (aName a) <> "Category"+        , "  , " <> lowerFirst (aName a) <> "EventStream"+        , "  , " <> lowerFirst (aName a) <> "EventStreamDef"+        , "  , " <> aName a <> "EventStream"+        , "  , " <> aName a <> "EventStreamDef"+        ]+            ++ ["  , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a]+            ++ [ "  ) where"+               , ""+               , "import " <> aGenPrefix a <> ".Domain"+               , "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)"+               , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst (aName a) <> "Transducer)"+               , "import Keiki.Core (HsPred)"+               , "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))"+               , "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)"+               ]+            ++ ["import Data.Text (Text)" | hasSnapshot a]+            ++ ["import Keiro.Snapshot.Codec (defaultStateCodec)" | hasSnapshot a]+            ++ [ "import Keiro.Stream qualified as Stream"+               , ""+               , "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped)."+               , "-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream."+               , "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof."+               , lowerFirst (aName a) <> "Category :: Stream.StreamCategory a"+               , lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName+               , ""+               , "type " <> aName a <> "EventStreamDef ="+               , "  EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event"+               , ""+               , "type " <> aName a <> "EventStream ="+               , "  ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event"+               , ""+               , lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef"+               , lowerFirst (aName a) <> "EventStreamDef ="+               , "  EventStream"+               , "    { transducer = " <> lowerFirst (aName a) <> "Transducer"+               , "    , initialState = " <> initialVertex a+               , "    , initialRegisters = initial" <> aName a <> "Regs"+               , "    , eventCodec = " <> lowerFirst (aName a) <> "Codec"+               , "    , resolveStreamName = Stream.streamName"+               , "    , snapshotPolicy = " <> snapshotPolicyExpr a+               , "    , stateCodec = " <> stateCodecExpr a+               , "    }"+               , ""+               ]+            ++ snapshotFixtureLines a+            ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream"+               , lowerFirst (aName a) <> "EventStream ="+               , "  mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef"+               ]+  where+    categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a))++snapshotPolicyExpr :: Agg -> Text+snapshotPolicyExpr aggregate = case aSnapshot aggregate of+    Nothing -> "Never"+    Just snapshot -> case snapPolicy snapshot of+        SnapEvery interval -> "Every " <> tshow' interval+        SnapOnTerminal -> "OnTerminal"++stateCodecExpr :: Agg -> Text+stateCodecExpr aggregate = case aSnapshot aggregate of+    Nothing -> "Nothing"+    Just snapshot -> "Just (defaultStateCodec " <> tshow' (snapCodecVersion snapshot) <> ")"++snapshotFixtureLines :: Agg -> [Text]+snapshotFixtureLines aggregate = case aSnapshot aggregate of+    Nothing -> []+    Just snapshot ->+        [ lowerFirst (aName aggregate) <> "SnapshotFixture :: (Int, Text)"+        , lowerFirst (aName aggregate) <> "SnapshotFixture = (" <> tshow' (snapCodecVersion snapshot) <> ", " <> tshow (snapShapeHash snapshot) <> ")"+        , ""+        ]++--------------------------------------------------------------------------------+-- Projection module+--------------------------------------------------------------------------------++emitProjection :: Agg -> Text+emitProjection a = case aProjection a of+    Nothing -> nl [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"]+    Just p ->+        nl+            [ "{-# LANGUAGE OverloadedRecordDot #-}"+            , "{-# LANGUAGE OverloadedStrings #-}"+            , generatedBanner+            , "module " <> aGenPrefix a <> ".Projection"+            , "  ( " <> lowerFirst (projTable p) <> "Projection"+            , "  , " <> lowerFirst (projTable p) <> "StatusFor"+            , "  ) where"+            , ""+            , "import " <> aGenPrefix a <> ".Domain"+            , "import " <> aHolePrefix a <> ".Holes (apply" <> pascal (projTable p) <> ")"+            , "import Data.Text (Text)"+            , "import Keiro.Projection (InlineProjection (..))"+            , ""+            , "-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived"+            , "-- from the spec's status-map. The read-model SQL that consumes it lives in"+            , "-- the hand-owned Holes module (a DB-coupled hole, delegated to codd)."+            , projectionTableComment a p+            , lowerFirst (projTable p) <> "StatusFor :: " <> aName a <> "Event -> Maybe Text"+            , lowerFirst (projTable p) <> "StatusFor = \\case"+            , nl (statusArms a p)+            , ""+            , lowerFirst (projTable p) <> "Projection :: InlineProjection " <> aName a <> "Event"+            , lowerFirst (projTable p) <> "Projection ="+            , "  InlineProjection"+            , "    { name = " <> tshow (contextNameToProjName a p)+            , "    , apply = apply" <> pascal (projTable p)+            , "    }"+            ]++statusArms :: Agg -> ProjectionSpec -> [Text]+statusArms a p =+    [ "  " <> rcName e <> " {} -> " <> statusFor e+    | e <- aEvents a+    ]+        ++ ["  _ -> Nothing" | hasWildcard]+  where+    pairs = maybe [] mapPairs (projStatusMap p)+    statusFor e = case lookup (rcName e) pairs of+        Just value -> "Just " <> tshow value+        Nothing -> "Nothing"+    -- A wildcard is only needed if some event is uncovered; otherwise every arm+    -- is explicit and a wildcard would be redundant (and -Wall would warn).+    hasWildcard = False++contextNameToProjName :: Agg -> ProjectionSpec -> Text+contextNameToProjName a p = contextKebab a <> "-" <> projTable p <> "-inline"++contextKebab :: Agg -> Text+contextKebab = kebabFromPascal . aCtxPascal++projectionReadModel :: Agg -> Maybe ReadModelNode+projectionReadModel aggregate = do+    projection <- aProjection aggregate+    find ((== projTable projection) . rmName) (aReadModels aggregate)++projectionTableComment :: Agg -> ProjectionSpec -> Text+projectionTableComment aggregate projection = case projectionReadModel aggregate of+    Nothing ->+        "-- WARNING: no readmodel node declares '"+            <> projTable projection+            <> "'; unqualified SQL depends on search_path."+    Just readModel ->+        "-- Qualified table "+            <> qualifiedTableLiteral readModel+            <> "; use "+            <> genPrefixFor (aContext aggregate) (pascal (rmName readModel))+            <> ".ReadModelTable."+            <> readModelStem readModel+            <> "QualifiedTable."++--------------------------------------------------------------------------------+-- Holes module (create-if-absent)+--------------------------------------------------------------------------------++emitHoles :: Agg -> Text+emitHoles a =+    nl+        [ "{-# LANGUAGE BlockArguments #-}"+        , "{-# LANGUAGE DataKinds #-}"+        , "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE QualifiedDo #-}"+        , "{-# LANGUAGE TypeApplications #-}"+        , "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never"+        , "-- overwrites it. Fill the transducer body (and any other holes) against the"+        , "-- generated signatures, then run the harness to confirm behaviour."+        , "module " <> aHolePrefix a <> ".Holes"+        , "  ( " <> lowerFirst (aName a) <> "Transducer"+        , holeProjectionExport a+        , holeUpcasterExports a+        , "  ) where"+        , ""+        , "import " <> aGenPrefix a <> ".Domain"+        , "import Keiki.Builder ((=:))"+        , "import qualified Keiki.Builder as B"+        , "import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))"+        , holeUpcasterImports a+        , holeProjectionImports a+        , ""+        , "-- HOLE: the transducer body. Reproduce the structure below, replacing each"+        , "-- `-- HOLE` line with the keiki symbolic operators it describes."+        , lowerFirst (aName a) <> "Transducer"+        , "  :: SymTransducer"+        , "       (HsPred " <> aName a <> "Regs " <> aName a <> "Command)"+        , "       " <> aName a <> "Regs"+        , "       " <> aVertexType a+        , "       " <> aName a <> "Command"+        , "       " <> aName a <> "Event"+        , lowerFirst (aName a) <> "Transducer ="+        , "  B.buildTransducer " <> initialVertex a <> " initial" <> aName a <> "Regs isTerminal do"+        , nl (concatMap (fromBlock a) (groupBySource a))+        , " where"+        , "  isTerminal = \\case"+        , nl ["    " <> vertexCtor a (stName s) <> " -> True" | s <- aStates a, stTerminal s]+        , "    _ -> False"+        , holeProjectionStub a+        , holeUpcasterStubs a+        ]++-- | Export, import, and stub the per-event upcaster holes (EP-2 evolution).+holeUpcasterExports :: Agg -> Text+holeUpcasterExports a = case upcasterEntries a of+    [] -> ""+    es -> nl ["  , " <> fn | (_, fn) <- es]++holeUpcasterImports :: Agg -> Text+holeUpcasterImports a = case upcasterEntries a of+    [] -> ""+    _ -> nl ["import Data.Aeson (Value)", "import Data.Text (Text)"]++holeUpcasterStubs :: Agg -> Text+holeUpcasterStubs a = case upcasterEntries a of+    [] -> ""+    es ->+        nl $+            concat+                [ [ ""+                  , "-- HOLE upcaster: bring a " <> fn <> " payload up one version. Decide the"+                  , "-- default/derivation for any field added at the new version here."+                  , fn <> " :: Value -> Either Text Value"+                  , fn <> " _ = Left \"HOLE: upcaster not implemented\""+                  ]+                | (_, fn) <- es+                ]++holeProjectionExport :: Agg -> Text+holeProjectionExport a = case aProjection a of+    Nothing -> "  -- (no projection)"+    Just p -> "  , apply" <> pascal (projTable p)++holeProjectionImports :: Agg -> Text+holeProjectionImports aggregate = case projectionReadModel aggregate of+    Nothing -> ""+    Just readModel ->+        "import "+            <> genPrefixFor (aContext aggregate) (pascal (rmName readModel))+            <> ".ReadModelTable ("+            <> readModelStem readModel+            <> "QualifiedTable)"++holeProjectionStub :: Agg -> Text+holeProjectionStub a = case aProjection a of+    Nothing -> ""+    Just p ->+        nl+            ( [ ""+              , "-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the"+              , "-- pure event->status mapping is generated as " <> lowerFirst (projTable p) <> "StatusFor)."+              ]+                ++ projectionGuidance+                ++ [ "apply" <> pascal (projTable p) <> " :: " <> aName a <> "Event -> recorded -> txn ()"+                   , "apply" <> pascal (projTable p) <> " _event _recorded = " <> projectionTableUse <> "error \"HOLE: fill " <> projTable p <> " projection apply\""+                   ]+            )+      where+        projectionGuidance = case projectionReadModel a of+            Nothing ->+                ["-- WARNING: no readmodel node declares this table's schema; unqualified SQL depends on search_path."]+            Just readModel ->+                [ "-- Table: " <> qualifiedTableLiteral readModel <> ". Use " <> readModelStem readModel <> "QualifiedTable; never rely on search_path."+                , "-- Declared columns:"+                ]+                    ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)+        projectionTableUse = case projectionReadModel a of+            Nothing -> ""+            Just readModel -> readModelStem readModel <> "QualifiedTable `seq` "++-- Group transitions by source state, preserving order, for the B.from blocks.+groupBySource :: Agg -> [(Text, [Transition])]+groupBySource a = go [] (transitionsOf a)+  where+    go acc [] = reverse acc+    go acc (t : ts) =+        let src = tSource t+            (same, rest) = span ((== src) . tSource) ts+         in go ((src, t : same) : acc) rest++-- We don't keep the original Aggregate around in Agg, so reconstruct+-- transitions from a stored field. (Filled in resolveAgg via aTransitions.)+transitionsOf :: Agg -> [Transition]+transitionsOf = aTransitions++fromBlock :: Agg -> (Text, [Transition]) -> [Text]+fromBlock a (src, ts) =+    [ "    B.from " <> vertexCtor a src <> " do"+    ]+        ++ concatMap (onCmdBlock a) ts++onCmdBlock :: Agg -> Transition -> [Text]+onCmdBlock a t =+    [ "      B.onCmd inCtor" <> tCommand t <> " $ \\d -> B.do"+    ]+        ++ maybe [] (\g -> ["        -- HOLE guard: " <> renderGuard g]) (tGuard t)+        ++ ["        -- HOLE write " <> r <> " := " <> renderGuard e | (r, e) <- tWrites t]+        ++ ["        -- HOLE emit " <> ev <> " (B.emit wire" <> ev <> " ...)" | ev <- tEmits t]+        ++ ["        B.goto " <> vertexCtor a (tGoto t)]++--------------------------------------------------------------------------------+-- Field categories and shared helpers+--------------------------------------------------------------------------------++data FieldCat = IdCat | EnumCat | OtherCat++fieldCat :: Agg -> Text -> FieldCat+fieldCat a ty+    | ty `elem` map idName (aIds a) = IdCat+    | ty `elem` map enumName (aEnums a) = EnumCat+    | otherwise = OtherCat++-- | The first constructor of a declared enum, used to build sample values.+firstEnumCtor :: Agg -> Text -> Maybe Text+firstEnumCtor a ty =+    case [c | e <- aEnums a, enumName e == ty, (c, _) <- take 1 (enumCtors e)] of+        (c : _) -> Just c+        [] -> Nothing++vertexCtor :: Agg -> Text -> Text+vertexCtor a s = aName a <> s++initialVertex :: Agg -> Text+initialVertex a = case aStates a of+    (s : _) -> vertexCtor a (stName s)+    [] -> aName a <> "Init"++generatedBanner :: Text+generatedBanner = "-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec."++nodeOrigin :: Text -> Text -> Loc -> Text+nodeOrigin nodeKind nodeName loc =+    nodeKind <> " " <> nodeName <> case unLoc loc of+        0 -> ""+        line -> " (line " <> tshow' line <> ")"++{- | Conditions that the deterministic emitters cannot lower faithfully. The+pre-write scaffold pipeline treats each returned message as a refusal. The+list is extended alongside the policy and type lowering milestones.+-}+scaffoldRefusals :: Spec -> [Text]+scaffoldRefusals spec =+    concatMap aggregateRefusals aggregates+        <> concatMap contractRefusals contracts+        <> concatMap publisherRefusals publishers+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    contracts = [contract | NContract contract <- specNodes spec]+    publishers = [publisher | NPublisher publisher <- specNodes spec]+    idTypes = map idName (specIds spec)+    enumTypes = map enumName (specEnums spec)+    enumCtorsFor ty = case [map fst (enumCtors enum) | enum <- specEnums spec, enumName enum == ty] of+        ctors : _ -> ctors+        [] -> []+    aggregateRefusals aggregate =+        [ "AggregateEmpty: aggregate '" <> aggName aggregate <> "' must declare at least one command, event, and transition"+        | null (aggCommands aggregate) || null (aggEvents aggregate) || null (aggTransitions aggregate)+        ]+            <> concatMap (registerRefusals aggregate) (aggRegs aggregate)+            <> [ "FieldTypeUnrepresentable: aggregate '" <> aggName aggregate <> "' field '" <> fieldName field <> "' has unsupported explicit type '" <> ty <> "'"+               | field <- aggregateFields aggregate+               , Just ty <- [fieldType field]+               , not (supportedType aggregate ty)+               ]+    registerRefusals aggregate reg =+        [ "RegTypeUnsupported: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' has unsupported type '" <> regType reg <> "'"+        | not (supportedType aggregate (regType reg))+        ]+            <> [ "RegTextInitialNotQuoted: aggregate '" <> aggName aggregate <> "' Text register '" <> regName reg <> "' must use a quoted initial"+               | regType reg == "Text"+               , RegInitBare _ <- [regInitial reg]+               ]+            <> [ "RegInitialNotEnumCtor: aggregate '" <> aggName aggregate <> "' register '" <> regName reg <> "' must start at a constructor of enum '" <> regType reg <> "'"+               | regType reg `elem` enumTypes+               , case regInitial reg of+                    RegInitBare value -> value `notElem` enumCtorsFor (regType reg)+                    RegInitText _ -> True+               ]+            <> [ "RegInitialInvalidLiteral: aggregate '" <> aggName aggregate <> "' Bool register '" <> regName reg <> "' must start at True or False"+               | regType reg == "Bool"+               , case regInitial reg of RegInitBare value -> value `notElem` ["True", "False"]; RegInitText _ -> True+               ]+            <> [ "RegInitialInvalidLiteral: aggregate '" <> aggName aggregate <> "' Int register '" <> regName reg <> "' must start at an integer literal"+               | regType reg == "Int"+               , case regInitial reg of RegInitBare value -> (readMaybe (T.unpack value) :: Maybe Int) == Nothing; RegInitText _ -> True+               ]+    aggregateFields aggregate =+        concatMap cmdFields (aggCommands aggregate)+            <> concat [fields | event <- aggEvents aggregate, EventFields fields <- [evBody event]]+    supportedType aggregate ty =+        ty `elem` (["Text", "Int", "Bool", aggName aggregate <> "Vertex"] <> idTypes <> enumTypes)+    contractRefusals contract =+        [ "ContractEmpty: contract '" <> ctrName contract <> "' must declare at least one event"+        | null (ctrEvents contract)+        ]+    publisherRefusals publisher =+        let backoff = pubBackoff publisher+            label message = message <> ": publisher '" <> pubName publisher <> "'"+         in case boKind backoff of+                "constant" -> []+                "exponential" -> case (boMax backoff, boMultiplier backoff) of+                    (Just maximumWindow, Just multiplierText) ->+                        case (windowSeconds (boWindow backoff), windowSeconds maximumWindow, readMaybe (T.unpack multiplierText) :: Maybe Double) of+                            (Right initialSeconds, Right maximumSeconds, Just multiplier)+                                | initialSeconds > 0 && maximumSeconds >= initialSeconds && multiplier >= 1 -> []+                            _ -> [label "BackoffInvalidExponential"]+                    _ -> [label "BackoffExponentialIncomplete"]+                other -> [label ("BackoffUnknownKind '" <> other <> "'")]++windowSeconds :: Text -> Either Text Int+windowSeconds window = case T.unsnoc window of+    Just (digits, unit)+        | not (T.null digits)+        , Just amount <- readMaybe (T.unpack digits) -> case unit of+            's' -> Right amount+            'm' -> Right (amount * 60)+            'h' -> Right (amount * 3600)+            _ -> Left invalid+    _ -> Left invalid+  where+    invalid = "invalid window '" <> window <> "' (expected digits followed by s, m, or h)"++windowText :: Text -> Text+windowText = either (const "0") tshow' . windowSeconds++-- | Render an Expr back to source-ish text for a hole annotation.+renderGuard :: Expr -> Text+renderGuard = go (0 :: Int)+  where+    go ctx e = parenIf (prec e < ctx) (body e)+    body (EOr l r) = go 1 l <> " || " <> go 2 r+    body (EAnd l r) = go 2 l <> " && " <> go 3 r+    body (ECmp op l r) = go 4 l <> " " <> cmp op <> " " <> go 4 r+    body (EAtom (AName n)) = n+    body (EAtom (ABool True)) = "true"+    body (EAtom (ABool False)) = "false"+    prec :: Expr -> Int+    prec EOr{} = 1+    prec EAnd{} = 2+    prec ECmp{} = 3+    prec EAtom{} = 4+    parenIf True s = "(" <> s <> ")"+    parenIf False s = s+    cmp OpEq = "=="+    cmp OpNeq = "!="+    cmp OpLt = "<"+    cmp OpLe = "<="+    cmp OpGt = ">"+    cmp OpGe = ">="++--------------------------------------------------------------------------------+-- Text helpers+--------------------------------------------------------------------------------++nl :: [Text] -> Text+nl = T.intercalate "\n"++-- | Join groups of declarations, blank-line-separated, dropping empties.+sectionsOf :: [[Text]] -> Text+sectionsOf = T.intercalate "\n\n" . filter (not . T.null) . map (T.intercalate "\n\n")++lowerFirst :: Text -> Text+lowerFirst t = case T.uncons t of+    Just (c, rest) -> T.cons (toLower c) rest+    Nothing -> t++{- | Assert the shared category proof at emission time as a belt-and-braces+guard for callers that bypass the CLI's normal validate-before-scaffold path.+-}+staticCategory :: Text -> Text -> Text+staticCategory owner value = case sagaCategoryError value of+    Nothing -> value+    Just reason -> error (T.unpack ("keiro-dsl scaffold: illegal " <> owner <> " category " <> tshow value <> " " <> reason))++pascal :: Text -> Text+pascal t = case T.uncons t of+    Just (c, rest) -> T.cons (toUpper c) rest+    Nothing -> t++pascalFromKebab :: Text -> Text+pascalFromKebab = T.concat . map pascal . T.splitOn "-"++kebabFromPascal :: Text -> Text+kebabFromPascal = T.intercalate "-" . map T.toLower . splitCamel++-- | Split CamelCase into its words (best-effort, for the projection name).+splitCamel :: Text -> [Text]+splitCamel = go . T.unpack+  where+    go [] = []+    go (c : cs) =+        let (rest, more) = break' cs+         in T.pack (c : rest) : go more+    break' [] = ([], [])+    break' (x : xs)+        | x `elem` ['A' .. 'Z'] = ([], x : xs)+        | otherwise = let (r, m) = break' xs in (x : r, m)++tshow :: Text -> Text+tshow t = T.pack (show t)++tshow' :: Int -> Text+tshow' = T.pack . show
+ src/Keiro/Dsl/ScaffoldRecord.hs view
@@ -0,0 +1,75 @@+{- | Versioned, dependency-free persistence for the files produced by one+successful scaffold run. Unknown header fields are ignored so v1 readers can+consume records extended by later tool versions.+-}+module Keiro.Dsl.ScaffoldRecord (+    ScaffoldRecord (..),+    renderRecord,+    parseRecord,+    recordFileName,+) where++import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Scaffold (ModuleKind (..))+import System.FilePath (isAbsolute, splitDirectories)++data ScaffoldRecord = ScaffoldRecord+    { recSpecPath :: !Text+    , recModuleRoot :: !Text+    , recLayout :: !Text+    , recFiles :: ![(ModuleKind, FilePath)]+    }+    deriving stock (Eq, Show)++renderRecord :: ScaffoldRecord -> Text+renderRecord record =+    T.unlines $+        [ "keiro-dsl scaffold record v1"+        , "spec: " <> recSpecPath record+        , "module-root: " <> rootLabel+        , "layout: " <> recLayout record+        ]+            <> map renderFile (recFiles record)+  where+    rootLabel = if T.null (recModuleRoot record) then "(none)" else recModuleRoot record+    renderFile (Generated, path) = "generated " <> T.pack path+    renderFile (HoleStub, path) = "hole " <> T.pack path++{- | Parse a v1 record. The version header and the three required fields must+be present exactly once. Unknown lines are ignored for forward compatibility;+unsafe file paths are rejected rather than joined to a scaffold output root.+-}+parseRecord :: Text -> Maybe ScaffoldRecord+parseRecord contents = case T.lines contents of+    header : rows+        | header == "keiro-dsl scaffold record v1" -> do+            specPath <- exactlyOne "spec: " rows+            rootLabel <- exactlyOne "module-root: " rows+            layout <- exactlyOne "layout: " rows+            files <- traverse parseFile (filter isFileRow rows)+            pure+                ScaffoldRecord+                    { recSpecPath = specPath+                    , recModuleRoot = if rootLabel == "(none)" then "" else rootLabel+                    , recLayout = layout+                    , recFiles = files+                    }+    _ -> Nothing+  where+    exactlyOne prefix rows = case [value | row <- rows, Just value <- [T.stripPrefix prefix row]] of+        [value] -> Just value+        _ -> Nothing+    isFileRow row = "generated " `T.isPrefixOf` row || "hole " `T.isPrefixOf` row+    parseFile row+        | Just path <- T.stripPrefix "generated " row = checkedFile Generated path+        | Just path <- T.stripPrefix "hole " row = checkedFile HoleStub path+        | otherwise = Nothing+    checkedFile fileKind pathText =+        let path = T.unpack pathText+         in if null path || isAbsolute path || ".." `elem` splitDirectories path+                then Nothing+                else Just (fileKind, path)++recordFileName :: Text -> FilePath+recordFileName context = "keiro-dsl-scaffold-record." <> T.unpack context <> ".txt"
+ src/Keiro/Dsl/ScaffoldRun.hs view
@@ -0,0 +1,264 @@+{- | The filesystem-facing scaffold pipeline. It separates pure planning from+execution so every refusal is known before the first output byte is written.+-}+module Keiro.Dsl.ScaffoldRun (+    Refusal (..),+    WriteDisposition (..),+    StaleModule (..),+    ScaffoldReport (..),+    scaffoldModules,+    planScaffold,+    executeScaffold,+    renderRefusals,+    renderScaffoldReport,+) where++import Data.List (sortOn)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Keiro.Dsl.Grammar (Node (..), Spec (..))+import Keiro.Dsl.Harness (harnessFor, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow)+import Keiro.Dsl.Manifest (moduleNameOf, renderManifest)+import Keiro.Dsl.Scaffold+import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName, renderRecord)+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.FilePath (takeDirectory, (</>))++data Refusal+    = PathCollision !FilePath ![Text]+    | FirewallBreach ![(FilePath, Text, Int)]+    | LoweringRefusal ![Text]+    | MissingGeneratedBanner ![FilePath]+    deriving stock (Eq, Show)++data WriteDisposition = Overwritten | Created | Skipped+    deriving stock (Eq, Show)++data StaleModule = StaleModule+    { staleKind :: !ModuleKind+    , stalePath :: !FilePath+    }+    deriving stock (Eq, Show)++data ScaffoldReport = ScaffoldReport+    { reportSpecPath :: !FilePath+    , reportOutDir :: !FilePath+    , reportContext :: !Context+    , reportDispositions :: ![(ScaffoldModule, WriteDisposition)]+    , reportManifestPath :: !FilePath+    , reportRecordPath :: !FilePath+    , reportPreviousSpecPath :: !(Maybe Text)+    , reportStale :: ![StaleModule]+    }+    deriving stock (Eq, Show)++{- | Produce the complete in-memory module set for a specification. Keeping+this registry in one place prevents the CLI and tests from drifting apart.+-}+scaffoldModules :: Context -> Spec -> [ScaffoldModule]+scaffoldModules ctx spec =+    concat+        [ case node of+            NAggregate agg -> scaffoldAggregate ctx spec agg <> harnessFor ctx spec agg+            NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process+            NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router+            NContract contract -> scaffoldContract ctx contract+            NIntake intake -> scaffoldIntake ctx intake+            NPublisher publisher -> scaffoldPublisher ctx publisher+            NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue+            NReadModel readModel -> scaffoldReadModel ctx readModel <> harnessReadModel ctx readModel+            NWorkflow workflow -> harnessWorkflow ctx workflow+            NEmit _ -> []+            NPgmqDispatch _ -> []+            NOperation _ -> []+        | node <- specNodes spec+        ]++{- | Run every pure refusal gate. A successful result is the exact write set;+a refusal has no write set and therefore cannot be accidentally executed.+-}+planScaffold :: Context -> Spec -> Either [Refusal] [ScaffoldModule]+planScaffold ctx spec =+    let modules = scaffoldModules ctx spec+        breaches = firewallBreaches modules+        refusals =+            collisionRefusals modules+                <> [FirewallBreach breaches | not (null breaches)]+                <> [LoweringRefusal lowering | let lowering = scaffoldRefusals spec, not (null lowering)]+     in if null refusals then Right modules else Left refusals++collisionRefusals :: [ScaffoldModule] -> [Refusal]+collisionRefusals modules =+    [ PathCollision (modulePath first) (map origin (first : rest))+    | first : rest <- Map.elems grouped+    , not (null rest)+    ]+  where+    grouped =+        Map.fromListWith+            (flip (<>))+            [(T.toCaseFold (T.pack (modulePath m)), [m]) | m <- modules]++{- | Check existing generated paths, then perform the deterministic writes and+manifest rewrite. Banner refusal is evaluated for the complete set before the+output directory is created or any file is changed.+-}+executeScaffold :: FilePath -> Bool -> FilePath -> Context -> Spec -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeScaffold out forceGeneratedOverwrite specPath ctx spec modules = do+    bannerless <- if forceGeneratedOverwrite then pure [] else missingGeneratedBanners out modules+    if not (null bannerless)+        then pure (Left [MissingGeneratedBanner bannerless])+        else do+            let recordPath = out </> recordFileName (specContext spec)+            previousRecord <- readRecord recordPath+            stale <- maybe (pure []) (existingStale out modules) previousRecord+            createDirectoryIfMissing True out+            dispositions <- mapM (writeModule out) modules+            let manifestPath = out </> ("keiro-dsl-manifest." <> T.unpack (specContext spec) <> ".txt")+            TIO.writeFile manifestPath (renderManifest (T.pack specPath) modules spec)+            TIO.writeFile recordPath (renderRecord (currentRecord specPath ctx modules))+            pure $+                Right+                    ScaffoldReport+                        { reportSpecPath = specPath+                        , reportOutDir = out+                        , reportContext = ctx+                        , reportDispositions = dispositions+                        , reportManifestPath = manifestPath+                        , reportRecordPath = recordPath+                        , reportPreviousSpecPath = recSpecPath <$> previousRecord+                        , reportStale = stale+                        }++readRecord :: FilePath -> IO (Maybe ScaffoldRecord)+readRecord path = do+    exists <- doesFileExist path+    if exists then parseRecord <$> TIO.readFile path else pure Nothing++existingStale :: FilePath -> [ScaffoldModule] -> ScaffoldRecord -> IO [StaleModule]+existingStale out modules record = fmap concat $ mapM stillExists removed+  where+    currentPaths = Set.fromList (map modulePath modules)+    removed = [(fileKind, path) | (fileKind, path) <- recFiles record, path `Set.notMember` currentPaths]+    stillExists (fileKind, path) = do+        exists <- doesFileExist (out </> path)+        pure [StaleModule fileKind path | exists]++currentRecord :: FilePath -> Context -> [ScaffoldModule] -> ScaffoldRecord+currentRecord specPath ctx modules =+    ScaffoldRecord+        { recSpecPath = T.pack specPath+        , recModuleRoot = moduleRoot ctx+        , recLayout = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated"+        , recFiles = [(kind m, modulePath m) | m <- modules]+        }++missingGeneratedBanners :: FilePath -> [ScaffoldModule] -> IO [FilePath]+missingGeneratedBanners out modules = fmap concat $ mapM check generated+  where+    generated = [m | m <- modules, kind m == Generated]+    check m = do+        let path = out </> modulePath m+        exists <- doesFileExist path+        if not exists+            then pure []+            else do+                contents <- TIO.readFile path+                pure [modulePath m | not (any (T.isPrefixOf "-- @generated") (T.lines contents))]++writeModule :: FilePath -> ScaffoldModule -> IO (ScaffoldModule, WriteDisposition)+writeModule out m = do+    let path = out </> modulePath m+    createDirectoryIfMissing True (takeDirectory path)+    case kind m of+        Generated -> do+            TIO.writeFile path (moduleText m)+            pure (m, Overwritten)+        HoleStub -> do+            exists <- doesFileExist path+            if exists+                then pure (m, Skipped)+                else TIO.writeFile path (moduleText m) >> pure (m, Created)++renderRefusals :: [Refusal] -> [Text]+renderRefusals = concatMap render+  where+    render (PathCollision path origins) =+        [ "error: module path collision -- refusing to scaffold; nothing was written"+        , "  " <> T.pack path+        ]+            <> ["    from " <> source | source <- origins]+    render (FirewallBreach breaches) =+        [ "error: firewall breach -- refusing to scaffold; nothing was written"+        , "firewall: BREACH (" <> tshow (length breaches) <> " forbidden token occurrence(s)):"+        ]+            <> ["  " <> T.pack path <> ":" <> tshow line <> " contains " <> token | (path, token, line) <- breaches]+    render (LoweringRefusal refusals) =+        ["error: scaffold cannot lower this spec faithfully -- refusing; nothing was written"]+            <> map ("  " <>) refusals+    render (MissingGeneratedBanner paths) =+        [ "error: refusing to overwrite " <> tshow (length paths) <> " file(s) at Generated paths that lack the '-- @generated' banner"+        ]+            <> map ("  " <>) (map T.pack paths)+            <> ["  (adopted as hand code? move it, or re-run with --force-generated-overwrite)", "nothing was written"]++renderScaffoldReport :: ScaffoldReport -> [Text]+renderScaffoldReport report =+    [ "scaffold: " <> T.pack (reportSpecPath report) <> " -> " <> T.pack (reportOutDir report) <> " (module-root=" <> rootLabel <> ", layout=" <> layoutLabel <> ")"+    ]+        <> map moduleLine dispositions+        <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)"+           , harnessLine+           , "manifest: " <> T.pack (reportManifestPath report)+           ]+        <> previousSpecNote+        <> staleSection+  where+    ctx = reportContext report+    dispositions = reportDispositions report+    rootLabel = if T.null (moduleRoot ctx) then "(none)" else moduleRoot ctx+    layoutLabel = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated"+    names = [moduleNameOf (modulePath m) | (m, _) <- dispositions]+    nameWidth = maximum (1 : map T.length names)+    moduleLine (m, disposition) =+        "  " <> kindTag (kind m) <> "  " <> pad (moduleNameOf (modulePath m)) <> "  " <> dispositionTag disposition+    kindTag Generated = "generated"+    kindTag HoleStub = "hole     "+    dispositionTag Overwritten = "(overwritten)"+    dispositionTag Created = "(created)"+    dispositionTag Skipped = "(skipped: already present)"+    pad name = name <> T.replicate (nameWidth - T.length name) " "+    generatedCount = length [() | (m, _) <- dispositions, kind m == Generated]+    harnesses =+        sortOn+            id+            [ moduleNameOf (modulePath m)+            | (m, _) <- dispositions+            , any (`T.isSuffixOf` moduleNameOf (modulePath m)) [".Harness", ".ProcessHarness", ".WorkflowFacts"]+            ]+    harnessLine = case harnesses of+        [] -> "harness:  (none emitted)"+        _ -> "harness:  run `cabal test <your-component>` over " <> T.unwords harnesses+    previousSpecNote = case reportPreviousSpecPath report of+        Just previous+            | previous /= T.pack (reportSpecPath report) ->+                [ "note: the previous scaffold record used spec " <> previous+                , "      specs sharing context " <> contextName ctx <> " in one --out also share " <> T.pack (reportManifestPath report)+                ]+        _ -> []+    staleSection = case reportStale report of+        [] -> []+        stale ->+            [ "stale: " <> tshow (length stale) <> " file(s) from a previous scaffold of context " <> contextName ctx <> " are no longer produced by this spec:"+            ]+                <> map staleLine stale+                <> ["note: keiro-dsl never deletes files."]+    staleLine stale = case staleKind stale of+        Generated -> "  generated " <> T.pack (stalePath stale) <> "  (safe to delete; still on disk)"+        HoleStub -> "  hole      " <> T.pack (stalePath stale) <> "  (hand-owned — review before deleting)"++tshow :: (Show a) => a -> Text+tshow = T.pack . show
+ src/Keiro/Dsl/Skeleton.hs view
@@ -0,0 +1,342 @@+{- | Starter @.keiro@ skeletons for the @new \<kind\>@ subcommand. Each skeleton+is a minimal, __valid__ spec for one node kind: it parses and passes+@validateSpec@ with zero error diagnostics (a test enumerates them), so the+skeletons double as living, guaranteed-valid notation examples.++Kinds whose validator couples to other nodes (a @publisher@ needs an @emit@; an+@emit@/@intake@ needs a @contract@; a @dispatch@ needs a @workqueue@; an+@operation@ references a @workflow@) ship the whole coupled mini-spec, so the+skeleton is self-contained and checks clean on its own.+-}+module Keiro.Dsl.Skeleton (+    skeletonFor,+    skeletonKinds,+) where++import Data.Text (Text)+import Data.Text qualified as T++-- | The valid @new \<kind\>@ arguments, in help/listing order.+skeletonKinds :: [Text]+skeletonKinds =+    [ "aggregate"+    , "process"+    , "router"+    , "contract"+    , "intake"+    , "emit"+    , "publisher"+    , "workqueue"+    , "dispatch"+    , "workflow"+    , "operation"+    ]++{- | The minimal valid spec text for a node kind, or a 'Left' error naming the+valid kinds when the argument is unrecognised.+-}+skeletonFor :: Text -> Either Text Text+skeletonFor kind = case kind of+    "aggregate" -> Right aggregateSkeleton+    "process" -> Right processSkeleton+    "router" -> Right routerSkeleton+    "contract" -> Right contractSkeleton+    "intake" -> Right intakeSkeleton+    "emit" -> Right emitSkeleton+    "publisher" -> Right emitSkeleton+    "workqueue" -> Right workqueueSkeleton+    "dispatch" -> Right workqueueSkeleton+    "workflow" -> Right workflowSkeleton+    "operation" -> Right workflowSkeleton+    other ->+        Left $+            "unknown kind '" <> other <> "'. Valid kinds: " <> T.intercalate ", " skeletonKinds++aggregateSkeleton :: Text+aggregateSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "id ThingId prefix=thing"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "    thingId ThingId = placeholder"+        , "    state ThingVertex = Pending"+        , "  states Pending Done!"+        , ""+        , "  command DoThing { thingId attempt:Int }"+        , "  event ThingCompleted { thingId attempt:Int }"+        , ""+        , "  Pending -- DoThing -->"+        , "    write state := Done"+        , "    emit ThingCompleted"+        , "    goto Done"+        , ""+        , "  wire kind=ctorName fields=camelCase schemaVersion=1"+        ]++processSkeleton :: Text+processSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "id  HospitalId  prefix=hosp"+        , "id  CommandId   prefix=cmd"+        , ""+        , "process HospitalSurge"+        , "  name \"hospital-surge\""+        , "  input SurgeInput { hospitalId availableIcuBeds:Int redDemand:Int observedAt:Time }"+        , "  correlate input.hospitalId via idText"+        , "  saga Surge category \"hospitalSurge\""+        , "  target Hospital"+        , "  projections [ ]"+        , ""+        , "  on SurgeInput"+        , "    advance NoteSurgeThreshold { hospitalId availableIcuBeds redDemand timerId=timer.id }"+        , "    dispatch Hospital@input.hospitalId ActivateSurge { hospitalId }"+        , "      on-appended AckOk ; on-duplicate AckOk ; on-failed Retry"+        , "    schedule surgeFollowUp"+        , ""+        , "  dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)"+        , "  rejected => halt"+        , "  poison => halt"+        , ""+        , "  timer surgeFollowUp"+        , "    id uuidv5 \"hospital-surge-timer:\" <> correlationId"+        , "    fireAt input.observedAt + 5m"+        , "    payload { kind=\"hospital-surge-follow-up\" hospitalId }"+        , "    fire dispatch Surge@correlationId MarkSurgeTimerFired { hospitalId timerId }"+        , "      fired-event-id uuidv5 \"hospital-surge-fired:\" <> correlationId"+        , "      on-ok Fired ; on-reject Fired ; on-ambiguous Retry ; on-error Retry ; not-mine Retry"+        , "    decode unknown-status => Cancelled"+        , "    max-attempts 5 dead-letter \"surge timer exceeded ceiling\""+        , ""+        , "aggregate Surge"+        , "  regs"+        , "  states Idle Fired!"+        , ""+        , "  command NoteSurgeThreshold { hospitalId availableIcuBeds:Int redDemand:Int timerId }"+        , "  command MarkSurgeTimerFired { hospitalId timerId }"+        , "  event SurgeThresholdNoted = fields(NoteSurgeThreshold)"+        , "  event SurgeTimerMarked = fields(MarkSurgeTimerFired)"+        , "  Idle -- NoteSurgeThreshold --> emit SurgeThresholdNoted ; goto Idle"+        , "  Idle -- MarkSurgeTimerFired --> emit SurgeTimerMarked ; goto Fired"+        , ""+        , "aggregate Hospital"+        , "  regs"+        , "  states Operational Surging!"+        , ""+        , "  command ActivateSurge { hospitalId }"+        , "  event SurgeActivated = fields(ActivateSurge)"+        , "  Operational -- ActivateSurge --> emit SurgeActivated ; goto Surging"+        ]++routerSkeleton :: Text+routerSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "router PagingRouter"+        , "  name \"paging-router\""+        , "  input IncidentRaised { incidentId service }"+        , "  key input.incidentId via idText"+        , "  resolve stable via hole row { responderId }"+        , "  target Page"+        , "  projections [ ]"+        , "  dispatch-each SendPage { incidentId=input.incidentId responderId=resolved.responderId }"+        , "    on-appended AckOk ; on-duplicate AckOk ; on-failed Retry"+        , "  dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)"+        , "  rejected => halt"+        , "  poison => halt"+        , ""+        , "aggregate Page"+        , "  regs"+        , "  states Pending Delivered!"+        , ""+        , "  command SendPage { incidentId responderId }"+        , "  event PageSent = fields(SendPage)"+        , ""+        , "  Pending -- SendPage --> emit PageSent ; goto Delivered"+        ]++contractSkeleton :: Text+contractSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "contract myContract {"+        , "  schemaVersion 1"+        , "  discriminator messageType"+        , ""+        , "  topic events \"my-service.events\""+        , ""+        , "  event ThingHappened on events {"+        , "    thingId: typeid \"thing\""+        , "    detail: text"+        , "  }"+        , "}"+        ]++intakeSkeleton :: Text+intakeSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "contract myContract {"+        , "  schemaVersion 1"+        , "  discriminator messageType"+        , "  topic events \"my-service.events\""+        , "  event ThingHappened on events {"+        , "    thingId: typeid \"thing\""+        , "  }"+        , "}"+        , ""+        , "intake thingInbox {"+        , "  contract myContract"+        , "  topic events"+        , "  accept ThingHappened"+        , ""+        , "  bind messageId from header \"keiro-message-id\" required cross-check body"+        , ""+        , "  dedupe key messageId policy PreferIntegrationMessageId"+        , ""+        , "  decode {"+        , "    envelope strict-required lenient-optional"+        , "    body strict schemaVersion == 1"+        , "  }"+        , ""+        , "  disposition {"+        , "    processed => ackOk"+        , "    duplicate => ackOk"+        , "    inProgress => retry 5s"+        , "    previouslyFailed => deadLetter \"previous inbox failure\""+        , "    decodeFailed => deadLetter"+        , "    dedupeFailed => deadLetter"+        , "    storeFailed => retry 5s"+        , "  }"+        , "}"+        ]++emitSkeleton :: Text+emitSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "contract myContract {"+        , "  schemaVersion 1"+        , "  discriminator messageType"+        , "  topic events \"my-service.events\""+        , "  event ThingAccepted on events {"+        , "    thingId: typeid \"thing\""+        , "  }"+        , "}"+        , ""+        , "emit thingResponse {"+        , "  contract myContract"+        , "  topic events"+        , "  source \"my-service\""+        , "  key thingId"+        , "  map status {"+        , "    \"accepted\" => ThingAccepted"+        , "    _ => skip"+        , "  }"+        , "  messageId derive \"msg\" hole"+        , "  idempotencyKey derive hole"+        , "}"+        , ""+        , "publisher thingPublisher {"+        , "  emit thingResponse"+        , "  ordering PerKeyHeadOfLine"+        , "  maxAttempts 10"+        , "  backoff constant 2s"+        , "  outboxId stable from messageId"+        , "}"+        ]++workqueueSkeleton :: Text+workqueueSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "readmodel accepted_transfer_needs {"+        , "  table = \"accepted_transfer_needs\""+        , "  schema = \"my_service\""+        , "  columns {"+        , "    reservation_id text required"+        , "    hospital_id text required"+        , "  }"+        , "  version = 1"+        , "  shape = \"fnv1a:fec517dae7760b8a\""+        , "  consistency = Eventual"+        , "  feed = subscription"+        , "}"+        , ""+        , "readmodel transfer_decisions {"+        , "  table = \"transfer_decisions\""+        , "  schema = \"my_service\""+        , "  columns {"+        , "    reservation_id text required"+        , "  }"+        , "  version = 1"+        , "  shape = \"fnv1a:d44d218822582783\""+        , "  consistency = Eventual"+        , "  feed = subscription"+        , "}"+        , ""+        , "workqueue reservation_work {"+        , "  queue logical = \"my_service.reservation_work\""+        , "  derive physical = \"my_service_reservation_work\""+        , "         dlq = \"my_service_reservation_work_dlq\""+        , "         table = \"pgmq.q_my_service_reservation_work\""+        , ""+        , "  payload ReservationWorkItem {"+        , "    reservationId -> \"reservation_id\" text required"+        , "    hospitalId -> \"hospital_id\" text required"+        , "  }"+        , ""+        , "  retry maxRetries = 3 delay = 5s dlq = on"+        , ""+        , "  disposition {"+        , "    storeFailure -> retry 5s"+        , "    commandRejected -> deadLetter"+        , "    decodeFailure -> deadLetter"+        , "    onCodecReject -> deadLetter"+        , "  }"+        , "}"+        , ""+        , "dispatch reservation_work_dispatch {"+        , "  source readModel = accepted_transfer_needs key = reservationId"+        , "  fanout body = resolveTransferCandidates"+        , "  dedup key = reservationId"+        , "        seenIn readModel = transfer_decisions field = reservation_id"+        , "        seenIn queue = reservation_work field = reservation_id"+        , "  enqueue to = reservation_work"+        , "}"+        ]++workflowSkeleton :: Text+workflowSkeleton =+    T.unlines+        [ "context my-service"+        , ""+        , "workflow HospitalTransferReservation"+        , "  name \"hospital-transfer-reservation\""+        , "  in ReservationWorkflowInput { reservationId:Id hospitalId:Id }"+        , "  out ReservationWorkflowSummary"+        , "  id from input.reservationId via idText"+        , "  body"+        , "    step create-transfer-hold -> ReservationHold"+        , "    await reservation-confirmation -> ReservationConfirmation"+        , "    step summarize-reservation -> ReservationWorkflowSummary"+        , ""+        , "operation SignalReservationConfirmation"+        , "  signal reservation-confirmation of HospitalTransferReservation"+        , "    key from reservationId via reservationWorkflowId"+        , "    value ReservationConfirmation"+        , ""+        , "operation RunReservationWorkflow"+        , "  run HospitalTransferReservation"+        , "    input ReservationWorkflowInput"+        , "    outcome -> ReservationWorkflowRun"+        ]
+ src/Keiro/Dsl/Validate.hs view
@@ -0,0 +1,1558 @@+{- | The keiro DSL validator. A parsed 'Spec' is /valid/ only if it passes the+cross-cutting structural and hole-kind rules below. The point is to reject a+dangerous-by-omission spec — a deleted status-map, an undeclared command, a+guard atom that resolves to nothing, a wall-clock read inside a guard — /before+any Haskell is written/.++EP-1 defines the 'Diagnostic' framework and the cross-cutting rules; each later+vertical (EP-3…EP-6) appends its node-specific rules (e.g. EP-4's inbox+disposition inversions) reusing this same 'Diagnostic' type.+-}+module Keiro.Dsl.Validate (+    Severity (..),+    DiagnosticCode (..),+    Diagnostic (..),+    renderDiagnostic,+    validateSpec,+    derivedQueueTrio,+    sagaCategoryError,+) where++import Data.Bits (xor)+import Data.Char (isControl, isSpace, ord)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word64)+import Keiro.Dsl.Grammar+import Keiro.Dsl.ReadModelShape (deriveShapeHash)+import Numeric (showHex)++data Severity = Error | Warning+    deriving stock (Eq, Show)++-- | A machine-checkable code per rule, so tests match on the code, not prose.+data DiagnosticCode+    = UndeclaredCommand+    | UndeclaredEvent+    | UndeclaredState+    | UnreachableState+    | TerminalHasOutgoing+    | GuardAtomOutOfScope+    | StatusMapNotTotal+    | ClockSampled+    | -- EP-2 (evolution). The first three fire in single-spec @validateSpec@;+      -- the last two are emitted by the @diff@ path (they need a prior spec) and+      -- live here so the enum is the single registry of evolution rules.+      EvtVersionMissingUpcaster+    | DeprecatedEventStillEmitted+    | WireSchemaVersionMismatch+    | EvtFieldAddedWithoutBump+    | EvtRemovedNotDeprecated+    | -- EP-3 (process manager + durable timer).+      ProcessFireAtNotInjected+    | ProcessDispatchIdSupplied+    | ProcessUnresolvedRef+    | ProcessBenignInversion+    | SagaCategoryIllegal+    | -- EP-4 (integration intake / inbox disposition).+      DispositionIncomplete+    | DispositionDuplicateRetry+    | DispositionPreviouslyFailedRetry+    | DispositionDecodeUnboundedRetry+    | -- EP-4 (integration coupling).+      EmitSkipMissing+    | EmitUnresolvedContract+    | PublisherUnresolvedEmit+    | IntakeUnresolvedContract+    | -- EP-5 (pgmq workqueue/dispatch).+      WqPhysicalDivergence+    | WqStoreFailureNotRetry+    | WqDecodeFailureNotDeadLetter+    | WqDlqWithoutCeiling+    | WqGroupKeyMissing+    | WqGroupKeyWithoutFifo+    | WqGroupKeyUnresolved+    | WqUnloggedDurability+    | WqPartitionSpecEmpty+    | SnapshotIntervalInvalid+    | SnapshotCodecFixtureInvalid+    | DispatchEnqueueUnresolved+    | -- EP-6 (workflow/operation).+      AwaitSignalMismatch+    | RunWorkflowUnresolved+    | WorkflowPatchDuplicate+    | WorkflowPatchIdInvalid+    | WorkflowContinueAsNewNotTerminal+    | -- Diff-only (cross-spec) decode and identity evolution rules.+      EvtFieldTypeChanged+    | EvtFieldRemovedSameVersion+    | EvtVersionDecreased+    | EnumCtorRemoved+    | EnumWireSpellingChanged+    | WireSpecChanged+    | ContractEventRemoved+    | ContractFieldChanged+    | ContractDiscriminatorChanged+    | ContractTopicChanged+    | ContractSchemaVersionDecreased+    | WqPayloadFieldChanged+    | ProcessInputChanged+    | WorkflowShapeChanged+    | WorkflowBodyChanged+    | WorkflowStableNameChanged+    | WorkflowPatchRemoved+    | WorkflowContinueSeedChanged+    | WqOrderingChanged+    | WqProvisionChanged+    | WqGroupKeyChanged+    | IdPrefixChanged+    | DedupeIdentityChanged+    | DerivedIdentityChanged+    | QueueIdentityChanged+    | TimerWindowChanged+    | EmitMappingChanged+    | DecodePostureChanged+    | IntakePersistenceChanged+    | ProjectionChanged+    | PublisherPolicyChanged+    | DispatchRetargeted+    | ContractSchemaVersionBumped+    | EventUndeprecated+    | -- EP-104 (validator soundness).+      WorkflowDuplicateLabel+    | WorkflowSleepDelayUnresolved+    | WorkflowIdFieldUnresolved+    | RuleDomainUnresolved+    | RuleNotTotal+    | RuleCaseUnknownCtor+    | ProcessFieldBindingUnresolved+    | ProcessTimerCeilingInvalid+    | OperationUnresolvedRef+    | AwaitSignalValueMismatch+    | WqDispositionIncomplete+    | DispositionDuplicateOutcome+    | TopicAffinityMismatch+    | StatusMapDanglingKey+    | StatusMapDuplicateKey+    | WriteTargetNotRegister+    | RegisterInitialOutOfScope+    | DuplicateNodeName+    | DuplicateEnumCtor+    | DuplicateEnumWire+    | DuplicateIdPrefix+    | DuplicateCommandName+    | DuplicateEventName+    | WqDlqDivergence+    | WqTableDivergence+    | DispatchDedupQueueUnresolved+    | DispatchDedupFieldUnresolved+    | -- EP-105 (notation integrity and scaffold-safe names).+      IdentHaskellKeyword+    | IdentNotConstructorSafe+    | VertexCtorCollision+    | -- EP-107 (first-class read models).+      RmShapeHashDrift+    | RmStrongInlineOnly+    | RmScopeWithoutStrong+    | RmUnknownColumnType+    | RmInlineFeedUnreferenced+    | RmConsistencyConflict+    | RmProjectionWithoutNode+    | QueryUnresolvedReadModel+    | QueryConsistencyInvalid+    | DispatchReadModelUnresolved+    | DispatchReadModelFieldUnknown+    | -- EP-107 diff-only read-model evolution rules.+      ReadModelVersionDecreased+    | ReadModelShapeChangedWithoutBump+    | ReadModelFeedChanged+    | ReadModelConsistencyWeakened+    | -- EP-108 (router and worker-policy surfaces).+      RouterUnresolvedRef+    | RouterKeyFieldUnknown+    | RouterBindingUnscoped+    | RouterCommandUnknown+    | RouterReadModelUnverified+    | PolicyContradiction+    | PolicyDeadLetterUnused+    | AmbiguousMarkedBenign+    | AmbiguousFollowsRejectedPolicy+    | RouterStableNameChanged+    deriving stock (Eq, Show)++-- | A line-numbered, structured diagnostic.+data Diagnostic = Diagnostic+    { line :: !Int+    , severity :: !Severity+    , code :: !DiagnosticCode+    , message :: !Text+    }+    deriving stock (Eq, Show)++{- | Render a diagnostic in the conventional+@\<file\>:\<line\>: error[\<code\>]: \<message\>@ form.+-}+renderDiagnostic :: FilePath -> Diagnostic -> Text+renderDiagnostic file d =+    T.pack file+        <> ":"+        <> T.pack (show (line d))+        <> ": "+        <> sev+        <> "["+        <> T.pack (show (code d))+        <> "]: "+        <> message d+  where+    sev = case severity d of Error -> "error"; Warning -> "warning"++{- | Reserved wall-clock atom names. Sampling any of these inside a guard or+write breaks deterministic replay: TIME IS INJECTED, NOT SAMPLED.+-}+clockAtoms :: Set Name+clockAtoms = Set.fromList ["now", "currentTime", "wallClock", "today", "utcNow"]++{- | Validate a whole spec. An empty list means valid. Diagnostics are sorted by+line for stable, readable output.+-}+validateSpec :: Spec -> [Diagnostic]+validateSpec spec =+    sortOn line (validateNames spec ++ specLevelRules spec ++ concatMap (validateNode spec) (specNodes spec))++{- | Reject names that would make the scaffolder emit illegal Haskell. The+parser enforces the ASCII alphabet; this pass applies the category-specific+uppercase/lowercase and keyword rules that require AST context.+-}+validateNames :: Spec -> [Diagnostic]+validateNames spec =+    concat+        [ concatMap idNames (specIds spec)+        , concatMap enumNames (specEnums spec)+        , concatMap nodeNames (specNodes spec)+        ]+  where+    idNames declaration =+        constructorName "id name" (idName declaration) (idLoc declaration)++    enumNames declaration =+        constructorName "enum name" (enumName declaration) (enumLoc declaration)+            ++ concatMap+                (\(ctor, _) -> constructorName ("constructor of enum '" <> enumName declaration <> "'") ctor (enumLoc declaration))+                (enumCtors declaration)++    nodeNames = \case+        NAggregate aggregate -> aggregateNames aggregate+        NProcess process -> processNames process+        NRouter router -> routerNames router+        NContract contract ->+            pascalizedNodeName "contract" (ctrName contract) (ctrLoc contract)+                ++ concatMap+                    (\event -> constructorName "contract event name" (ceName event) (ctrLoc contract) ++ concatMap (contractFieldName contract) (ceFields event))+                    (ctrEvents contract)+        NIntake intake -> pascalizedNodeName "intake" (inkName intake) (inkLoc intake)+        NEmit emitNode -> pascalizedNodeName "emit" (emName emitNode) (emLoc emitNode)+        NPublisher publisher -> pascalizedNodeName "publisher" (pubName publisher) (pubLoc publisher)+        NWorkqueue workqueue ->+            pascalizedNodeName "workqueue" (wqName workqueue) (wqLoc workqueue)+                ++ constructorName "workqueue payload name" (wqPayloadName workqueue) (wqLoc workqueue)+                ++ concatMap (\field -> fieldNameRule "workqueue payload field" (wqfName field) (wqLoc workqueue)) (wqPayload workqueue)+        NPgmqDispatch dispatch -> pascalizedNodeName "dispatch" (pdName dispatch) (pdLoc dispatch)+        NReadModel readModel -> pascalizedNodeName "readmodel" (rmName readModel) (rmLoc readModel)+        NWorkflow workflow -> constructorName "workflow name" (wfId workflow) (wfLoc workflow)+        NOperation _ -> []++    aggregateNames aggregate =+        constructorName "aggregate name" (aggName aggregate) (aggLoc aggregate)+            ++ concatMap+                (\register -> fieldNameRule "register name" (regName register) (regLoc register))+                (aggRegs aggregate)+            ++ concatMap commandNames (aggCommands aggregate)+            ++ concatMap eventNames (aggEvents aggregate)+            ++ maybe [] (\projection -> fieldNameRule "projection key" (projKey projection) (projLoc projection)) (aggProjection aggregate)+            ++ vertexCollisions aggregate+      where+        commandNames command =+            constructorName "command name" (cmdName command) (cmdLoc command)+                ++ concatMap (\field -> fieldNameRule "command field" (fieldName field) (cmdLoc command)) (cmdFields command)+        eventNames event =+            constructorName "event name" (evName event) (evLoc event)+                ++ case evBody event of+                    EventFields fields -> concatMap (\field -> fieldNameRule "event field" (fieldName field) (evLoc event)) fields+                    EventFromCommand _ -> []++    processNames process =+        constructorName "process name" (procId process) (procLoc process)+            ++ constructorName "process input name" (inName input) (procLoc process)+            ++ concatMap (\field -> fieldNameRule "process input field" (fieldName field) (procLoc process)) (inFields input)+            ++ concatMap (bindingName "advance field binding" (procLoc process)) (advFields (hAdvance handle))+            ++ concatMap dispatchBindings (hDispatch handle)+            ++ concatMap (bindingName "timer payload field binding" (tmLoc timer)) (tmPayload timer)+            ++ concatMap (bindingName "timer fire field binding" (tmLoc timer)) (fireFields (tmFire timer))+      where+        input = procInput process+        handle = procHandle process+        timer = procTimer process+        dispatchBindings dispatch = concatMap (bindingName "dispatch field binding" (dispLoc dispatch)) (dispFields dispatch)++    routerNames router =+        constructorName "router name" (rtId router) (rtLoc router)+            ++ constructorName "router input name" (inName input) (rtLoc router)+            ++ concatMap (\field -> fieldNameRule "router input field" (fieldName field) (rtLoc router)) (inFields input)+            ++ concatMap (\field -> fieldNameRule "router resolve-row field" field (rvLoc resolve)) (rvRow resolve)+            ++ concatMap (bindingName "router dispatch field binding" (rdLoc dispatch)) (rdFields dispatch)+      where+        input = rtInput router+        resolve = rtResolve router+        dispatch = rtDispatch router++    bindingName category anchor binding = fieldNameRule category (fbName binding) anchor+    contractFieldName contract field = fieldNameRule "contract field" (cfName field) (ctrLoc contract)++    constructorName category name anchor+        | constructorSafe name = []+        | otherwise =+            [ mkErr (locLine anchor) IdentNotConstructorSafe $+                category <> " '" <> name <> "' must be PascalCase: it becomes a Haskell constructor, type name, or module segment in scaffolded code"+            ]++    pascalizedNodeName category name anchor+        | "_" `T.isPrefixOf` name =+            [ mkErr (locLine anchor) IdentNotConstructorSafe $+                category <> " name '" <> name <> "' cannot begin with '_': title-casing leaves an invalid Haskell module segment"+            ]+        | otherwise = []++    fieldNameRule category name anchor+        | name `Set.member` haskellKeywords =+            [ mkErr (locLine anchor) IdentHaskellKeyword $+                category <> " '" <> name <> "' is a Haskell keyword and cannot become a record field in generated code"+            ]+        | fieldSafe name = []+        | otherwise =+            [ mkErr (locLine anchor) IdentNotConstructorSafe $+                category <> " '" <> name <> "' must begin with a lowercase ASCII letter or underscore to become a Haskell record field"+            ]++    vertexCollisions aggregate =+        [ mkErr (locLine (aggLoc aggregate)) VertexCtorCollision $+            "aggregate '"+                <> aggName aggregate+                <> "' state '"+                <> stName state+                <> "' generates vertex constructor '"+                <> vertex+                <> "', which collides with "+                <> declarationKind+                <> " '"+                <> vertex+                <> "' in the generated Domain constructor namespace"+        | state <- aggStates aggregate+        , let vertex = aggName aggregate <> stName state+        , declarationKind <- collisionKinds aggregate vertex+        ]++    collisionKinds aggregate vertex =+        ["event" | vertex `elem` map evName (aggEvents aggregate)]+            ++ ["command" | vertex `elem` map cmdName (aggCommands aggregate)]+            ++ ["enum constructor" | vertex `elem` [ctor | enum <- specEnums spec, (ctor, _) <- enumCtors enum]]++-- Haskell 2010 reserved identifiers plus commonly enabled extension keywords.+haskellKeywords :: Set Name+haskellKeywords =+    Set.fromList+        [ "case"+        , "class"+        , "data"+        , "default"+        , "deriving"+        , "do"+        , "else"+        , "foreign"+        , "if"+        , "import"+        , "in"+        , "infix"+        , "infixl"+        , "infixr"+        , "instance"+        , "let"+        , "module"+        , "newtype"+        , "of"+        , "then"+        , "type"+        , "where"+        , "mdo"+        , "rec"+        , "proc"+        ]++constructorSafe :: Name -> Bool+constructorSafe name = case T.uncons name of+    Just (first, rest) -> asciiUpper first && T.all asciiAlphaNumOrUnderscore rest+    Nothing -> False++fieldSafe :: Name -> Bool+fieldSafe name = case T.uncons name of+    Just (first, rest) -> (asciiLower first || first == '_') && T.all asciiAlphaNumOrUnderscore rest+    Nothing -> False++asciiUpper :: Char -> Bool+asciiUpper c = c >= 'A' && c <= 'Z'++asciiLower :: Char -> Bool+asciiLower c = c >= 'a' && c <= 'z'++asciiAlphaNumOrUnderscore :: Char -> Bool+asciiAlphaNumOrUnderscore c = asciiUpper c || asciiLower c || (c >= '0' && c <= '9') || c == '_'++-- | Rules over namespaces shared by the whole specification.+specLevelRules :: Spec -> [Diagnostic]+specLevelRules spec = duplicateNodes ++ duplicateEnumMembers ++ duplicateIdPrefixes ++ ruleDiagnostics+  where+    duplicateNodes =+        [ mkErr (locLine loc) DuplicateNodeName $+            "duplicate " <> kind <> " node name '" <> name <> "'"+        | node <- duplicatesBy nodeKey (specNodes spec)+        , let (kind, name, loc) = nodeIdentity node+        ]+    nodeKey node = let (kind, name, _) = nodeIdentity node in (kind, name)+    duplicateEnumMembers = concatMap enumDuplicates (specEnums spec)+    enumDuplicates e =+        [ mkErr (locLine (enumLoc e)) DuplicateEnumCtor $+            "enum '" <> enumName e <> "' declares constructor '" <> ctor <> "' more than once"+        | (ctor, _) <- duplicatesBy fst (enumCtors e)+        ]+            ++ [ mkErr (locLine (enumLoc e)) DuplicateEnumWire $+                    "enum '" <> enumName e <> "' declares wire spelling '" <> wire <> "' more than once"+               | (_, wire) <- duplicatesBy snd (enumCtors e)+               ]+    duplicateIdPrefixes =+        [ mkErr (locLine (idLoc d)) DuplicateIdPrefix $+            "id '" <> idName d <> "' reuses prefix '" <> idPrefix d <> "'"+        | d <- duplicatesBy idPrefix (specIds spec)+        ]+    ruleDiagnostics = concatMap (validateRule spec) (specRules spec)++nodeIdentity :: Node -> (Text, Name, Loc)+nodeIdentity (NAggregate a) = ("aggregate", aggName a, aggLoc a)+nodeIdentity (NProcess p) = ("process", procId p, procLoc p)+nodeIdentity (NRouter r) = ("router", rtId r, rtLoc r)+nodeIdentity (NContract c) = ("contract", ctrName c, ctrLoc c)+nodeIdentity (NIntake i) = ("intake", inkName i, inkLoc i)+nodeIdentity (NEmit e) = ("emit", emName e, emLoc e)+nodeIdentity (NPublisher p) = ("publisher", pubName p, pubLoc p)+nodeIdentity (NWorkqueue w) = ("workqueue", wqName w, wqLoc w)+nodeIdentity (NPgmqDispatch d) = ("dispatch", pdName d, pdLoc d)+nodeIdentity (NReadModel r) = ("readmodel", rmName r, rmLoc r)+nodeIdentity (NWorkflow w) = ("workflow", wfId w, wfLoc w)+nodeIdentity (NOperation o) = ("operation", opName o, opLoc o)++validateNode :: Spec -> Node -> [Diagnostic]+validateNode spec (NAggregate agg) = validateAggregate spec agg+validateNode spec (NProcess p) = validateProcess spec p+validateNode spec (NRouter router) = validateRouter spec router+validateNode _spec (NContract _) = [] -- a contract is a declaration; coupling is checked at the referrers+validateNode spec (NIntake i) = validateIntake i ++ intakeCoupling spec i+validateNode spec (NEmit e) = validateEmit spec e+validateNode spec (NPublisher p) = validatePublisher spec p+validateNode _spec (NWorkqueue w) = validateWorkqueue w+validateNode spec (NPgmqDispatch d) = validatePgmqDispatch spec d+validateNode spec (NReadModel readModel) = validateReadModel spec readModel+validateNode _spec (NWorkflow w) = validateWorkflow w+validateNode spec (NOperation o) = validateOperation spec o++-- | Workflow replay keys, patch guards, rotation, and injected inputs must be unambiguous.+validateWorkflow :: WorkflowNode -> [Diagnostic]+validateWorkflow w = duplicateLabels ++ sleepFields ++ patchDuplicates ++ patchIds ++ continuePositions ++ idField+  where+    inputFields = map fieldName (wfInputFields w)+    labelledItems = workflowLabelledItems (wfBody w)+    patchItems = workflowPatchItems (wfBody w)+    duplicateLabels =+        [ mkErr (locLine (wfBodyLoc item)) WorkflowDuplicateLabel $+            "workflow '" <> wfId w <> "' declares label '" <> label <> "' more than once; labels key deterministic replay, so a duplicate label replays the first occurrence's journaled result"+        | (label, item) <- duplicatesBy fst labelledItems+        ]+    sleepFields =+        [ mkErr (locLine loc) WorkflowSleepDelayUnresolved $+            "workflow '" <> wfId w <> "' sleep '" <> label <> "' references undeclared input field '" <> delay <> "'"+        | WfSleep label delay loc <- map snd labelledItems+        , delay `notElem` inputFields+        ]+    patchDuplicates =+        [ mkErr (locLine loc) WorkflowPatchDuplicate $+            "workflow '" <> wfId w <> "' declares patch id '" <> patchId <> "' more than once; patch decisions journal under one stable key"+        | (patchId, _, loc) <- duplicatesBy (\(patchId, _, _) -> patchId) patchItems+        ]+    patchIds =+        [ mkErr (locLine loc) WorkflowPatchIdInvalid $+            "workflow '" <> wfId w <> "' patch id '" <> patchId <> "' contains ':'; the runtime reserves that separator for the patch journal-key prefix"+        | (patchId, _, loc) <- patchItems+        , ":" `T.isInfixOf` patchId+        ]+    continuePositions =+        [ mkErr (locLine loc) WorkflowContinueAsNewNotTerminal $+            "workflow '" <> wfId w <> "' continueAsNew must be the last top-level body item and may not appear inside a patch"+        | (isTopLevelTerminal, loc) <- workflowContinueItems (wfBody w)+        , not isTopLevelTerminal+        ]+    idField = case wfIdField w of+        Just field+            | field `notElem` inputFields ->+                [ mkErr (locLine (wfLoc w)) WorkflowIdFieldUnresolved $+                    "workflow '" <> wfId w <> "' derives its id from undeclared input field '" <> field <> "'"+                ]+        _ -> []++wfBodyLoc :: WfBodyItem -> Loc+wfBodyLoc (WfStep _ _ loc) = loc+wfBodyLoc (WfAwait _ _ loc) = loc+wfBodyLoc (WfSleep _ _ loc) = loc+wfBodyLoc (WfChild _ _ _ loc) = loc+wfBodyLoc (WfPatch _ _ loc) = loc+wfBodyLoc (WfContinueAsNew _ loc) = loc++workflowLabelledItems :: [WfBodyItem] -> [(Name, WfBodyItem)]+workflowLabelledItems = concatMap go+  where+    go item@(WfStep label _ _) = [(label, item)]+    go item@(WfAwait label _ _) = [(label, item)]+    go item@(WfSleep label _ _) = [(label, item)]+    go item@(WfChild label _ _ _) = [(label, item)]+    go (WfPatch _ items _) = workflowLabelledItems items+    go WfContinueAsNew{} = []++workflowPatchItems :: [WfBodyItem] -> [(Name, [WfBodyItem], Loc)]+workflowPatchItems = concatMap go+  where+    go (WfPatch patchId items loc) = (patchId, items, loc) : workflowPatchItems items+    go _ = []++-- | Pair every rotation with whether it is the final top-level item.+workflowContinueItems :: [WfBodyItem] -> [(Bool, Loc)]+workflowContinueItems items = topLevel ++ nested+  where+    topLevel =+        [ (index == length items - 1, loc)+        | (index, WfContinueAsNew _ loc) <- zip [0 ..] items+        ]+    nested =+        [ (False, loc)+        | WfPatch _ patchBody _ <- items+        , (_, loc) <- workflowContinueItems patchBody+        ]++-- | A top-level rule is a total, clock-free function over one declared enum.+validateRule :: Spec -> RuleDecl -> [Diagnostic]+validateRule spec rule = case [e | e <- specEnums spec, enumName e == ruleDomain rule] of+    [] ->+        [ mkErr rl RuleDomainUnresolved $+            "rule '" <> ruleName rule <> "' has undeclared enum domain '" <> ruleDomain rule <> "'"+        ]+    (domain : _) -> totality domain ++ unknownCases domain ++ bodyDiagnostics+  where+    rl = locLine (ruleLoc rule)+    caseNames = map fst (ruleCases rule)+    allEnumCtors = Set.fromList [ctor | e <- specEnums spec, (ctor, _) <- enumCtors e]+    totality domain =+        let missing = [ctor | (ctor, _) <- enumCtors domain, ctor `notElem` caseNames]+         in [ mkErr rl RuleNotTotal $+                "rule '" <> ruleName rule <> "' is not total over enum '" <> enumName domain <> "'; missing cases {" <> T.intercalate ", " missing <> "}"+            | not (null missing)+            ]+    unknownCases domain =+        [ mkErr rl RuleCaseUnknownCtor $+            "rule '" <> ruleName rule <> "' has case '" <> ctor <> "' which is not a constructor of enum '" <> enumName domain <> "'"+        | (ctor, _) <- ruleCases rule+        , ctor `notElem` map fst (enumCtors domain)+        ]+    bodyDiagnostics = concatMap validateBody (ruleCases rule)+    validateBody (ctor, expr) =+        [ mkErr rl ClockSampled $+            "rule '" <> ruleName rule <> "' case '" <> ctor <> "' samples the wall clock via '" <> atom <> "'; rules must be deterministic"+        | atom <- dedup (exprNames expr)+        , atom `Set.member` clockAtoms+        ]+            ++ [ mkErr rl GuardAtomOutOfScope $+                    "atom '" <> atom <> "' in rule '" <> ruleName rule <> "' resolves to no enum constructor or boolean literal"+               | atom <- dedup (exprNames expr)+               , atom `Set.notMember` clockAtoms+               , atom `Set.notMember` allEnumCtors+               ]++{- | Operation rules resolve command aggregates, stream fields, projections,+read models, workflow signal labels and value types, and run targets.+-}+validateOperation :: Spec -> OperationNode -> [Diagnostic]+validateOperation spec o = case opShape o of+    CommandOp aggregate streamField _ projections ->+        aggregateRef aggregate streamField ++ projectionRefs projections+    QueryOp readModel _ _ consistency ->+        resolveReadModelRef QueryUnresolvedReadModel spec (opLoc o) ("query operation '" <> opName o <> "'") readModel+            ++ [ mkErr ol QueryConsistencyInvalid $+                    "query operation '" <> opName o <> "' has unknown consistency '" <> consistency <> "'; expected Strong, Eventual, or PositionWait"+               | consistency `notElem` (["Strong", "Eventual", "PositionWait"] :: [Name])+               ]+    SignalOp lbl wf _ _ valueType ->+        case lookupWorkflow wf of+            Nothing ->+                [mkErr ol AwaitSignalMismatch ("signal operation '" <> opName o <> "' targets undeclared workflow '" <> wf <> "'")]+            Just w -> case [(resultType, loc) | (_, WfAwait label resultType loc) <- workflowLabelledItems (wfBody w), label == lbl] of+                [] ->+                    [ mkErr ol AwaitSignalMismatch $+                        "signal '" <> lbl <> "' of " <> wf <> " has no matching 'await' (workflow declares awaits {" <> T.intercalate ", " (awaitLabels w) <> "}); the deterministic awakeable id will not match and the workflow will wait forever"+                    ]+                ((resultType, _) : _)+                    | valueType == resultType -> []+                    | otherwise ->+                        [ mkErr ol AwaitSignalValueMismatch $+                            "signal '" <> lbl <> "' of " <> wf <> " carries value type '" <> valueType <> "' but the await expects '" <> resultType <> "'"+                        ]+    RunOp wf _ _ ->+        [ mkErr ol RunWorkflowUnresolved ("run operation '" <> opName o <> "' targets undeclared workflow '" <> wf <> "'")+        | wf `notElem` map wfId workflows+        ]+  where+    ol = locLine (opLoc o)+    workflows = [w | NWorkflow w <- specNodes spec]+    aggregates = [a | NAggregate a <- specNodes spec]+    projectionTables = [projTable p | a <- aggregates, Just p <- [aggProjection a]]+    lookupWorkflow n = case [w | w <- workflows, wfId w == n] of (w : _) -> Just w; [] -> Nothing+    awaitLabels w = [l | (_, WfAwait l _ _) <- workflowLabelledItems (wfBody w)]+    aggregateRef name streamField = case [a | a <- aggregates, aggName a == name] of+        [] ->+            [ mkErr ol OperationUnresolvedRef $+                "command operation '" <> opName o <> "' targets undeclared aggregate '" <> name <> "'"+            ]+        (aggregate : _) ->+            [ mkErr ol OperationUnresolvedRef $+                "command operation '" <> opName o <> "' stream field '" <> streamField <> "' is not declared by any command of aggregate '" <> name <> "'"+            | streamField `notElem` [fieldName field | command <- aggCommands aggregate, field <- cmdFields command]+            ]+    projectionRefs projections =+        [ mkErr ol OperationUnresolvedRef $+            "command operation '" <> opName o <> "' references undeclared projection table '" <> projection <> "'"+        | projection <- projections+        , projection `notElem` projectionTables+        ]++-- | Resolve a named read-model node using the caller's diagnostic code.+resolveReadModelRef :: DiagnosticCode -> Spec -> Loc -> Text -> Name -> [Diagnostic]+resolveReadModelRef diagnosticCode spec diagnosticLoc context name =+    [ mkErr (locLine diagnosticLoc) diagnosticCode $+        context <> " references undeclared readmodel '" <> name <> "'"+    | name `notElem` [rmName readModel | NReadModel readModel <- specNodes spec]+    ]++-- | Validate captured identity, feed semantics, and the declared column surface.+validateReadModel :: Spec -> ReadModelNode -> [Diagnostic]+validateReadModel spec readModel =+    shapeFixture ++ columnTypes ++ strongFeed ++ scopeMode ++ inlineReference+  where+    readModelLine = locLine (rmLoc readModel)+    expectedShape = deriveShapeHash readModel+    shapeFixture =+        [ mkErr readModelLine RmShapeHashDrift $+            "readmodel '"+                <> rmName readModel+                <> "': captured shape \""+                <> rmShape readModel+                <> "\" does not match the declared columns (expected \""+                <> expectedShape+                <> "\"); update the fixture AND bump version if the table shape really changed"+        | rmShape readModel /= expectedShape+        ]+    allowedColumnTypes = Set.fromList ["text", "int", "bigint", "bool", "timestamptz", "jsonb", "numeric"]+    columnTypes =+        [ mkErr readModelLine RmUnknownColumnType $+            "readmodel '" <> rmName readModel <> "' column '" <> rmcName columnDecl <> "' has unknown type '" <> rmcType columnDecl <> "'"+        | columnDecl <- rmColumns readModel+        , rmcType columnDecl `Set.notMember` allowedColumnTypes+        ]+    strongFeed =+        [ mkErr readModelLine RmStrongInlineOnly $+            "readmodel '"+                <> rmName readModel+                <> "': consistency = Strong with feed = inline; an inline-only model has no subscription worker to advance the cursor a Strong read waits on. Use consistency = Eventual, or feed = subscription"+        | rmFeed readModel == RmInline+        , rmConsistency readModel == Strong+        ]+    scopeMode =+        [ mkErr readModelLine RmScopeWithoutStrong $+            "readmodel '" <> rmName readModel <> "': scope is meaningful only with consistency = Strong"+        | rmScope readModel /= Nothing+        , rmConsistency readModel /= Strong+        ]+    inlineReference =+        [ mkErr readModelLine RmInlineFeedUnreferenced $+            "readmodel '" <> rmName readModel <> "' declares feed = inline but no aggregate projection references it"+        | rmFeed readModel == RmInline+        , rmName readModel `notElem` [projTable projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]]+        ]++{- | EP-5 workqueue rules: the captured physical name must match the queueRef+derivation; the disposition inversions (storeFailure transient => must retry;+decodeFailure poison => must dead-letter); and dlq=on requires a retry ceiling.+-}+validateWorkqueue :: WorkqueueNode -> [Diagnostic]+validateWorkqueue w = concat [divergence, completeness, duplicateRows, inversions, retryCeiling, orderingRules, groupKeyRules, provisionRules]+  where+    wl = locLine (wqLoc w)+    rows = wqDisposition w+    (derivedPhysical, derivedDlq, derivedTable) = derivedQueueTrio (wqLogical w)+    divergence =+        [ mkErr wl WqPhysicalDivergence $+            "workqueue '" <> wqName w <> "': captured physical \"" <> wqPhysical w <> "\" diverges from queueRef(\"" <> wqLogical w <> "\") = \"" <> derivedPhysical <> "\""+        | wqPhysical w /= derivedPhysical+        ]+            ++ [ mkErr wl WqDlqDivergence $+                    "workqueue '" <> wqName w <> "': captured dlq \"" <> wqDlq w <> "\" diverges from queueRef = \"" <> derivedDlq <> "\""+               | wqDlq w /= derivedDlq+               ]+            ++ [ mkErr wl WqTableDivergence $+                    "workqueue '" <> wqName w <> "': captured table \"" <> wqTable w <> "\" diverges from queueRef table = \"" <> derivedTable <> "\""+               | wqTable w /= derivedTable+               ]+    requiredOutcomes = ["storeFailure", "commandRejected", "decodeFailure", "onCodecReject"]+    completeness =+        [ mkErr wl WqDispositionIncomplete $+            "workqueue '" <> wqName w <> "' disposition table is missing outcome '" <> outcome <> "'"+        | outcome <- requiredOutcomes+        , outcome `notElem` map wqdOutcome rows+        ]+    duplicateRows =+        [ mkErr (locLine (wqdLoc row)) DispositionDuplicateOutcome $+            "workqueue '" <> wqName w <> "' repeats disposition outcome '" <> wqdOutcome row <> "'; the first row would shadow this row"+        | row <- duplicatesBy wqdOutcome rows+        ]+    firstRow outcome = case [row | row <- rows, wqdOutcome row == outcome] of+        (row : _) -> Just row+        [] -> Nothing+    isRetry row = case wqdAction row of IRetry _ -> True; _ -> False+    isDeadLetter row = case wqdAction row of IDeadLetter _ -> True; _ -> False+    inversions =+        [ mkErr (locLine (wqdLoc row)) WqStoreFailureNotRetry ("workqueue '" <> wqName w <> "': 'storeFailure' is transient and MUST retry, not dead-letter")+        | Just row <- [firstRow "storeFailure"]+        , isDeadLetter row+        ]+            ++ [ mkErr (locLine (wqdLoc row)) WqDecodeFailureNotDeadLetter ("workqueue '" <> wqName w <> "': 'decodeFailure' is poison and MUST dead-letter, not retry")+               | Just row <- [firstRow "decodeFailure"]+               , isRetry row+               ]+    retryCeiling =+        [ mkErr wl WqDlqWithoutCeiling ("workqueue '" <> wqName w <> "': dlq=on requires maxRetries >= 1 (an absent ceiling never dead-letters)")+        | wqDlqOn w && wqMaxRetries w < 1+        ]+    fifo = wqOrdering w /= WqUnordered+    orderingRules =+        [ mkErr wl WqGroupKeyMissing $+            "workqueue '" <> wqName w <> "': FIFO delivery is per group, so ordering requires a 'group key' clause that makes enqueueToGroup deterministic"+        | fifo && wqGroupKey w == Nothing+        ]+            ++ [ mkErr wl WqGroupKeyWithoutFifo $+                    "workqueue '" <> wqName w <> "': a group key with unordered reads would be ignored; declare a FIFO ordering or remove the key"+               | not fifo && wqGroupKey w /= Nothing+               ]+    groupKeyRules = case wqGroupKey w of+        Nothing -> []+        Just groupKey ->+            case [field | field <- wqPayload w, wqfName field == gkField groupKey] of+                [] ->+                    [ mkErr wl WqGroupKeyUnresolved $+                        "workqueue '" <> wqName w <> "': group key field '" <> gkField groupKey <> "' is not declared in its payload"+                    ]+                field : _ ->+                    [ mkErr wl WqGroupKeyUnresolved $+                        "workqueue '" <> wqName w <> "': group key via raw requires a text payload field, but '" <> gkField groupKey <> "' has type '" <> wqfType field <> "'"+                    | gkVia groupKey == "raw" && wqfType field /= "text"+                    ]+                        ++ [ mkErr wl WqGroupKeyUnresolved $+                                "workqueue '" <> wqName w <> "': opaque group-key derivation '" <> gkVia groupKey <> "' requires a captured fixture"+                           | gkVia groupKey /= "raw" && gkFixture groupKey == Nothing+                           ]+    provisionRules = case wqProvision w of+        WqStandard -> []+        WqUnlogged ->+            [ Diagnostic+                { line = wl+                , severity = Warning+                , code = WqUnloggedDurability+                , message = "workqueue '" <> wqName w <> "': provision unlogged is truncated to empty on a database crash; use it only for transient, regenerable work"+                }+            ]+        WqPartitioned interval retention ->+            [ mkErr wl WqPartitionSpecEmpty $+                "workqueue '" <> wqName w <> "': partition interval and retention must be non-empty; they are create-time settings and the additive reconciler will not migrate an existing queue"+            | T.null interval || T.null retention+            ]++-- | EP-5 dispatch rule: the @enqueue to@ target must resolve to a declared workqueue.+validatePgmqDispatch :: Spec -> PgmqDispatchNode -> [Diagnostic]+validatePgmqDispatch spec d = enqueueRef ++ dedupQueueRef ++ sourceReadModelRef ++ dedupReadModelRef ++ dedupReadModelField+  where+    dl = locLine (pdLoc d)+    workqueues = [w | NWorkqueue w <- specNodes spec]+    enqueueRef =+        [ mkErr dl DispatchEnqueueUnresolved ("dispatch '" <> pdName d <> "' enqueues to undeclared workqueue '" <> pdEnqueueTo d <> "'")+        | pdEnqueueTo d `notElem` map wqName workqueues+        ]+    dedupQueueRef = case [w | w <- workqueues, wqName w == pdDedupQueue d] of+        [] ->+            [ mkErr dl DispatchDedupQueueUnresolved $+                "dispatch '" <> pdName d <> "' checks an undeclared dedup queue '" <> pdDedupQueue d <> "'"+            ]+        (queue : _) ->+            [ mkErr dl DispatchDedupFieldUnresolved $+                "dispatch '" <> pdName d <> "' dedup field '" <> pdDedupQueueField d <> "' is not a payload wire field of queue '" <> pdDedupQueue d <> "'"+            | pdDedupQueueField d `notElem` map wqfWire (wqPayload queue)+            ]+    sourceReadModelRef =+        resolveReadModelRef DispatchReadModelUnresolved spec (pdLoc d) ("dispatch '" <> pdName d <> "' source") (pdSourceReadModel d)+    dedupReadModelRef =+        resolveReadModelRef DispatchReadModelUnresolved spec (pdLoc d) ("dispatch '" <> pdName d <> "' dedup") (pdDedupReadModel d)+    dedupReadModelField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdDedupReadModel d] of+        [] -> []+        (readModel : _) ->+            [ mkErr dl DispatchReadModelFieldUnknown $+                "dispatch '" <> pdName d <> "' dedup field '" <> pdDedupReadModelField d <> "' is not a declared column of readmodel '" <> pdDedupReadModel d <> "'"+            | pdDedupReadModelField d `notElem` map rmcName (rmColumns readModel)+            ]++-- | The declared contracts in a spec, by name.+specContracts :: Spec -> [ContractNode]+specContracts spec = [c | NContract c <- specNodes spec]++-- | EP-4 cross-node coupling: an intake's contract/topic/accepted-events resolve.+intakeCoupling :: Spec -> IntakeNode -> [Diagnostic]+intakeCoupling spec i = case lookupContract (inkContract i) of+    Nothing ->+        [mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' references undeclared contract '" <> inkContract i <> "'")]+    Just c ->+        [ mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' topic '" <> inkTopic i <> "' is not a topic of contract '" <> inkContract i <> "'")+        | inkTopic i `notElem` map fst (ctrTopics c)+        ]+            ++ [ mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' accepts event '" <> ev <> "' not declared in contract '" <> inkContract i <> "'")+               | ev <- inkAccept i+               , ev `notElem` map ceName (ctrEvents c)+               ]+            ++ [ mkErr (locLine (inkLoc i)) TopicAffinityMismatch $+                    "intake '" <> inkName i <> "' subscribes to topic '" <> inkTopic i <> "' but accepted event '" <> ceName event <> "' is declared on topic '" <> ceTopic event <> "'"+               | event <- ctrEvents c+               , ceName event `elem` inkAccept i+               , ceTopic event /= inkTopic i+               ]+  where+    lookupContract n = case [c | c <- specContracts spec, ctrName c == n] of (c : _) -> Just c; [] -> Nothing++validateEmit :: Spec -> EmitNode -> [Diagnostic]+validateEmit spec e = skipRule ++ coupling+  where+    el = locLine (emLoc e)+    skipRule =+        [ mkErr el EmitSkipMissing ("emit '" <> emName e <> "' map must end with an explicit '_ => skip' catch-all (hole-kind 7 optionality)")+        | not (emSkip e)+        ]+    coupling = case [c | c <- specContracts spec, ctrName c == emContract e] of+        [] -> [mkErr el EmitUnresolvedContract ("emit '" <> emName e <> "' references undeclared contract '" <> emContract e <> "'")]+        (c : _) ->+            [ mkErr el EmitUnresolvedContract ("emit '" <> emName e <> "' topic '" <> emTopic e <> "' is not a topic of contract '" <> emContract e <> "'")+            | emTopic e `notElem` map fst (ctrTopics c)+            ]+                ++ [ mkErr (locLine (emrLoc r)) EmitUnresolvedContract ("emit '" <> emName e <> "' maps to event '" <> emrEvent r <> "' not declared in contract '" <> emContract e <> "'")+                   | r <- emMap e+                   , emrEvent r `notElem` map ceName (ctrEvents c)+                   ]+                ++ [ mkErr (locLine (emrLoc row)) TopicAffinityMismatch $+                        "emit '" <> emName e <> "' publishes on topic '" <> emTopic e <> "' but mapped event '" <> emrEvent row <> "' is declared on topic '" <> ceTopic event <> "'"+                   | row <- emMap e+                   , event <- ctrEvents c+                   , ceName event == emrEvent row+                   , ceTopic event /= emTopic e+                   ]++validatePublisher :: Spec -> PublisherNode -> [Diagnostic]+validatePublisher spec p =+    [ mkErr (locLine (pubLoc p)) PublisherUnresolvedEmit ("publisher '" <> pubName p <> "' references undeclared emit '" <> pubEmit p <> "'")+    | pubEmit p `notElem` [emName e | NEmit e <- specNodes spec]+    ]++{- | EP-4 inbox disposition rules: the table must be complete over the seven+outcomes, and the three dangerous inversions must be stated the safe way.+-}+validateIntake :: IntakeNode -> [Diagnostic]+validateIntake i = concat [completeness, duplicateRows, inversions]+  where+    il = locLine (inkLoc i)+    rows = inkDisposition i+    requiredOutcomes =+        ["processed", "duplicate", "inProgress", "previouslyFailed", "decodeFailed", "dedupeFailed", "storeFailed"]+    completeness =+        [ mkErr il DispositionIncomplete $+            "intake '" <> inkName i <> "' disposition table is missing outcome '" <> o <> "'"+        | o <- requiredOutcomes+        , o `notElem` map drOutcome rows+        ]+    duplicateRows =+        [ mkErr (locLine (drLoc row)) DispositionDuplicateOutcome $+            "intake '" <> inkName i <> "' repeats disposition outcome '" <> drOutcome row <> "'; the first row would shadow this row"+        | row <- duplicatesBy drOutcome rows+        ]+    firstRow outcome = case [row | row <- rows, drOutcome row == outcome] of+        (row : _) -> Just row+        [] -> Nothing+    isRetry row = case drAction row of IRetry _ -> True; _ -> False+    inversions =+        [ mkErr (locLine (drLoc row)) DispositionDuplicateRetry $+            "intake '" <> inkName i <> "': a 'duplicate' redelivery must be ackOk (success), not retry"+        | Just row <- [firstRow "duplicate"]+        , isRetry row+        ]+            ++ [ mkErr (locLine (drLoc row)) DispositionPreviouslyFailedRetry $+                    "intake '" <> inkName i <> "': 'previouslyFailed' must dead-letter, not retry (a prior failure won't succeed on replay)"+               | Just row <- [firstRow "previouslyFailed"]+               , isRetry row+               ]+            ++ [ mkErr (locLine (drLoc row)) DispositionDecodeUnboundedRetry $+                    "intake '" <> inkName i <> "': 'decodeFailed' must dead-letter (terminal), not retry unboundedly"+               | Just row <- [firstRow "decodeFailed"]+               , isRetry row+               ]++-- | EP-3 rules for a process manager + its nested timer.+validateProcess :: Spec -> ProcessNode -> [Diagnostic]+validateProcess spec p =+    concat [sagaCategoryRule, noWallClock, runtimeOwnedDispatchId, crossNodeCoupling, timerCeiling, policyRules, ambiguityRule, benignInversions]+  where+    aggregates = [a | NAggregate a <- specNodes spec]+    aggNames = map aggName aggregates+    projectionTables = [projTable projection | aggregate <- aggregates, Just projection <- [aggProjection aggregate]]+    inputFields = map fieldName (inFields (procInput p))+    timeFields = [fieldName f | f <- inFields (procInput p), fieldType f == Just "Time"]+    timer = procTimer p+    pl = locLine (procLoc p)++    sagaCategoryRule =+        [ mkErr pl SagaCategoryIllegal $+            "saga category " <> T.pack (show (sagaCategory (procSaga p))) <> " " <> reason+        | Just reason <- [sagaCategoryError (sagaCategory (procSaga p))]+        ]++    -- TIME IS INJECTED, NOT SAMPLED: fireAt's field must be a declared :Time+    -- input field. (FireAtExpr has no clock-sampling constructor, so this is a+    -- field-resolution + typed-as-Time check.)+    noWallClock =+        let f = faField (tmFireAt timer)+         in if f `notElem` inputFields+                then+                    [ mkErr (locLine (tmLoc timer)) ProcessFireAtNotInjected $+                        "timer '" <> tmName timer <> "' fireAt field '" <> f <> "' is not a field of input '" <> inName (procInput p) <> "'"+                    ]+                else+                    [ mkErr (locLine (tmLoc timer)) ProcessFireAtNotInjected $+                        "timer '" <> tmName timer <> "' fireAt references '" <> f <> "', which is not a declared :Time field of input '" <> inName (procInput p) <> "'"+                    | f `notElem` timeFields+                    ]++    -- Dispatched (and fired) command ids are runtime-owned; no field binding may+    -- supply a commandId/id.+    runtimeOwnedDispatchId =+        [ mkErr pl ProcessDispatchIdSupplied $+            "advance command '" <> advCommand advance <> "' supplies a runtime-owned id field '" <> fbName binding <> "'; remove it"+        | let advance = hAdvance (procHandle p)+        , binding <- advFields advance+        , fbName binding `elem` (["commandId", "id"] :: [Name])+        ]+            ++ [ mkErr (locLine (dispLoc d)) ProcessDispatchIdSupplied $+                    "dispatch to '" <> dispTarget d <> "' supplies a runtime-owned id field '" <> fbName b <> "'; remove it"+               | d <- hDispatch (procHandle p)+               , b <- dispFields d+               , fbName b `elem` (["commandId", "id"] :: [Name])+               ]+            ++ [ mkErr (locLine (tmLoc timer)) ProcessDispatchIdSupplied $+                    "timer fire supplies a runtime-owned id field '" <> fbName b <> "'; remove it"+               | b <- fireFields (tmFire timer)+               , fbName b `elem` (["commandId", "id"] :: [Name])+               ]++    -- Aggregate, command, field, timer, and projection references must resolve.+    crossNodeCoupling =+        [ mkErr pl ProcessUnresolvedRef ("saga '" <> sagaAgg (procSaga p) <> "' does not resolve to a declared aggregate")+        | sagaAgg (procSaga p) `notElem` aggNames+        ]+            ++ [ mkErr pl ProcessUnresolvedRef ("target '" <> procTarget p <> "' does not resolve to a declared aggregate")+               | procTarget p `notElem` aggNames+               ]+            ++ [ mkErr (locLine (tmLoc timer)) ProcessUnresolvedRef ("timer fire target '" <> fireTarget (tmFire timer) <> "' must be the saga or the target aggregate")+               | fireTarget (tmFire timer) `notElem` [sagaAgg (procSaga p), procTarget p]+               ]+            ++ resolveCommand pl "advance" (sagaAgg (procSaga p)) (advCommand advance) (advFields advance)+            ++ concatMap resolveDispatch (hDispatch (procHandle p))+            ++ resolveCommand (locLine (tmLoc timer)) "timer fire" (fireTarget fire) (fireCommand fire) (fireFields fire)+            ++ [ mkErr pl ProcessUnresolvedRef $+                    "process '" <> procId p <> "' schedules undeclared timer '" <> hSchedule (procHandle p) <> "'; declared timer is '" <> tmName timer <> "'"+               | hSchedule (procHandle p) /= tmName timer+               ]+            ++ [ mkErr pl ProcessUnresolvedRef $+                    "process '" <> procId p <> "' references undeclared projection table '" <> projection <> "'"+               | projection <- procProjections p+               , projection `notElem` projectionTables+               ]+      where+        advance = hAdvance (procHandle p)+        fire = tmFire timer+        resolveDispatch dispatch =+            resolveCommand+                (locLine (dispLoc dispatch))+                "dispatch"+                (dispTarget dispatch)+                (dispCommand dispatch)+                (dispFields dispatch)+        resolveCommand diagnosticLine context target command bindings = case lookupAggregate target of+            Nothing -> []+            Just aggregate -> case [decl | decl <- aggCommands aggregate, cmdName decl == command] of+                [] ->+                    [ mkErr diagnosticLine ProcessUnresolvedRef $+                        context <> " command '" <> command <> "' is not declared by aggregate '" <> target <> "'"+                    ]+                (declaration : _) ->+                    [ mkErr diagnosticLine ProcessFieldBindingUnresolved $+                        context <> " command '" <> command <> "' binds undeclared target field '" <> fbName binding <> "'"+                    | binding <- bindings+                    , fbName binding `notElem` map fieldName (cmdFields declaration)+                    ]+        lookupAggregate name = case [aggregate | aggregate <- aggregates, aggName aggregate == name] of+            (aggregate : _) -> Just aggregate+            [] -> Nothing++    timerCeiling =+        [ mkErr (locLine (tmLoc timer)) ProcessTimerCeilingInvalid $+            "timer '" <> tmName timer <> "' max-attempts must be at least 1"+        | tmMaxAttempts timer < 1+        ]++    policyRules =+        policyConsistency+            (procId p)+            (procLoc p)+            (procRejected p)+            [ (dispCommand dispatch, dispLoc dispatch, dispDisposition dispatch)+            | dispatch <- hDispatch (procHandle p)+            ]++    ambiguityRule =+        [ mkErr (locLine (tmLoc timer)) AmbiguousMarkedBenign $+            "timer '" <> tmName timer <> "' maps on-ambiguous => Fired; CommandAmbiguous means multiple aggregate edges matched and is never a benign success. Use on-ambiguous Retry so the attempts ceiling dead-letters the definition bug"+        | onAmbiguous (fireDisposition (tmFire timer)) == OFired+        ]++    -- Surface the dangerous benign inversions the author confirmed (warnings).+    benignInversions =+        [ Diagnostic (locLine (tmLoc timer)) Warning ProcessBenignInversion $+            "timer '" <> tmName timer <> "' maps on-reject => Fired (a CommandRejected is treated as benign success)"+        | onReject (fireDisposition (tmFire timer)) == OFired+        ]+            ++ [ Diagnostic (locLine (dispLoc d)) Warning ProcessBenignInversion $+                    "dispatch to '" <> dispTarget d <> "' maps on-duplicate => AckOk (a duplicate is treated as benign success)"+               | d <- hDispatch (procHandle p)+               , onDuplicate (dispDisposition d) == DAckOk+               ]++{- | Explain why a process saga category is illegal.  The first four cases+mirror 'Keiro.Stream.category' without introducing a runtime dependency into+the toolchain library.  The final @:@ case is deliberately stricter because+that prefix is reserved for the @wf:<name>@ workflow stream family.+-}+sagaCategoryError :: Text -> Maybe Text+sagaCategoryError categoryName+    | T.null categoryName = Just "is empty; use a non-empty camelCase category"+    | categoryName == "$all" = Just "is reserved by the event store; choose a service-owned camelCase category"+    | T.isInfixOf "-" categoryName = Just "contains '-' (kiroku's category/id boundary); write compound categories in camelCase, for example \"hospitalSurge\""+    | Just illegal <- T.find (\character -> isSpace character || isControl character) categoryName =+        Just ("contains whitespace or control character " <> T.pack (show illegal) <> "; remove it and use camelCase")+    | T.isInfixOf ":" categoryName = Just "contains ':' which is reserved for the wf:<name> workflow stream family; choose a camelCase category without ':'"+    | otherwise = Nothing++-- | EP-108 rules for a stateless content-based router.+validateRouter :: Spec -> RouterNode -> [Diagnostic]+validateRouter spec router =+    concat+        [ references+        , keyField+        , bindingScope+        , commandReference+        , readModelReference+        , policyRules+        , duplicateNotice+        ]+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    readModels = [readModel | NReadModel readModel <- specNodes spec]+    inputFields = map fieldName (inFields (rtInput router))+    resolvedFields = rvRow (rtResolve router)+    dispatch = rtDispatch router+    routerLine = locLine (rtLoc router)+    dispatchLine = locLine (rdLoc dispatch)++    targetAggregate = case [aggregate | aggregate <- aggregates, aggName aggregate == rtTarget router] of+        aggregate : _ -> Just aggregate+        [] -> Nothing++    projectionTables = [projTable projection | aggregate <- aggregates, Just projection <- [aggProjection aggregate]]++    references =+        [ mkErr routerLine RouterUnresolvedRef $+            "router '" <> rtId router <> "' targets aggregate '" <> rtTarget router <> "' but no such aggregate is declared"+        | targetAggregate == Nothing+        ]+            ++ [ mkErr routerLine RouterUnresolvedRef $+                    "router '" <> rtId router <> "' references undeclared projection table '" <> projection <> "'"+               | projection <- rtProjections router+               , projection `notElem` projectionTables+               ]++    keyField =+        [ mkErr routerLine RouterKeyFieldUnknown $+            "key references 'input." <> corrField (rtKey router) <> "' but input '" <> inName (rtInput router) <> "' does not declare that field"+        | corrField (rtKey router) `notElem` inputFields+        ]++    bindingScope =+        [ mkErr dispatchLine RouterBindingUnscoped $+            "dispatch binding '" <> fbName binding <> maybe "" ("=" <>) (fbValue binding) <> "' is outside the router input and resolve-row scopes"+        | binding <- rdFields dispatch+        , not (bindingInScope binding)+        ]+      where+        bindingInScope binding = case fbValue binding of+            Nothing -> fbName binding `elem` inputFields+            Just value+                | isQuoted value -> True+                | Just field <- T.stripPrefix "input." value -> field `elem` inputFields+                | Just field <- T.stripPrefix "resolved." value -> field `elem` resolvedFields+                | otherwise -> False+        isQuoted value = T.length value >= 2 && T.head value == '"' && T.last value == '"'++    commandReference = case targetAggregate of+        Nothing -> []+        Just aggregate -> case [command | command <- aggCommands aggregate, cmdName command == rdCommand dispatch] of+            [] ->+                [ mkErr dispatchLine RouterCommandUnknown $+                    "dispatch command '" <> rdCommand dispatch <> "' is not declared by aggregate '" <> aggName aggregate <> "'"+                ]+            command : _ ->+                [ mkErr dispatchLine RouterCommandUnknown $+                    "dispatch command '" <> rdCommand dispatch <> "' binds undeclared target field '" <> fbName binding <> "'"+                | binding <- rdFields dispatch+                , fbName binding `notElem` map fieldName (cmdFields command)+                ]++    readModelReference = case rvSource (rtResolve router) of+        ResolveHole -> []+        ResolveReadModel name ->+            [ mkErr (locLine (rvLoc (rtResolve router))) RouterUnresolvedRef $+                "router '" <> rtId router <> "' resolve names readmodel '" <> name <> "' but no such readmodel node is declared"+            | name `notElem` map rmName readModels+            ]++    policyRules =+        policyConsistency+            (rtId router)+            (rtLoc router)+            (rtRejected router)+            [(rdCommand dispatch, rdLoc dispatch, rdDisposition dispatch)]++    duplicateNotice =+        [ Diagnostic dispatchLine Warning ProcessBenignInversion $+            "router dispatch '" <> rdCommand dispatch <> "' maps on-duplicate => AckOk; Keiro.Router confirms the event id against the target stream before treating the duplicate as benign"+        | onDuplicate (rdDisposition dispatch) == DAckOk+        ]++{- | Reconcile per-dispatch prose with the one node-level policy the runtime+actually applies to a rejection-class failure group.+-}+policyConsistency :: Name -> Loc -> PolicyChoice -> [(Name, Loc, DispatchDisposition)] -> [Diagnostic]+policyConsistency nodeName nodeLoc rejectedPolicy dispatches = contradictions ++ divergent ++ unused ++ ambiguityWarning+  where+    contradictions =+        [ mkErr (locLine dispatchLoc) PolicyContradiction $+            "dispatch '" <> command <> "' declares on-failed DeadLetter, but node '" <> nodeName <> "' does not declare rejected => deadLetter; align the dispatch story with the node-level RejectedCommandPolicy"+        | (command, dispatchLoc, disposition) <- dispatches+        , DDeadLetter _ <- [onFailed disposition]+        , rejectedPolicy /= PolDeadLetter+        ]++    divergent = case dispatches of+        [] -> []+        (_, _, firstDisposition) : rest ->+            [ mkErr (locLine dispatchLoc) PolicyContradiction $+                "dispatch '" <> command <> "' has a different on-failed action from another dispatch in node '" <> nodeName <> "'; the runtime applies one RejectedCommandPolicy to the whole failure group"+            | (command, dispatchLoc, disposition) <- rest+            , not (sameFailureAction (onFailed disposition) (onFailed firstDisposition))+            ]++    unused =+        [ Diagnostic (locLine nodeLoc) Warning PolicyDeadLetterUnused $+            "node '" <> nodeName <> "' declares rejected => deadLetter but no dispatch on-failed arm says DeadLetter; the runtime policy is live, but the per-dispatch notation does not acknowledge it"+        | rejectedPolicy == PolDeadLetter+        , all (not . isDeadLetter . onFailed . third) dispatches+        ]++    ambiguityWarning =+        [ Diagnostic (locLine nodeLoc) Warning AmbiguousFollowsRejectedPolicy $+            "node '" <> nodeName <> "' acknowledges rejection-class failures; CommandAmbiguous follows the same rejected policy, and a dead-letter errorClass is the durable witness of that definition bug"+        | rejectedPolicy `elem` [PolDeadLetter, PolSkip]+        ]++    third (_, _, value) = value+    sameFailureAction DDeadLetter{} DDeadLetter{} = True+    sameFailureAction left right = left == right+    isDeadLetter DDeadLetter{} = True+    isDeadLetter _ = False++validateAggregate :: Spec -> Aggregate -> [Diagnostic]+validateAggregate spec agg =+    concat+        [ duplicateMembers+        , declaredRefs+        , eventBodyRefs+        , registerInitialScope+        , reachability+        , terminalNoOutgoing+        , guardScope+        , clockFree+        , projectionSafety+        , statusMapTotality+        , evolutionRules+        , snapshotRules+        ]+  where+    states = Set.fromList (map stName (aggStates agg))+    terminals = Set.fromList [stName s | s <- aggStates agg, stTerminal s]+    commandFields :: Map Name [Name]+    commandFields = Map.fromList [(cmdName c, map fieldName (cmdFields c)) | c <- aggCommands agg]+    commandNames = Map.keysSet commandFields+    eventNames = Set.fromList (map evName (aggEvents agg))+    enumCtorNames = Set.fromList [c | e <- specEnums spec, (c, _) <- enumCtors e]+    ruleNames = Set.fromList (map ruleName (specRules spec))+    registerNames = Set.fromList (map regName (aggRegs agg))++    snapshotRules = case aggSnapshot agg of+        Nothing -> []+        Just snapshot ->+            [ mkErr (locLine (snapLoc snapshot)) SnapshotIntervalInvalid $+                "aggregate '" <> aggName agg <> "': snapshot every requires an interval of at least 1; non-positive runtime intervals silently disable snapshots"+            | SnapEvery interval <- [snapPolicy snapshot]+            , interval < 1+            ]+                ++ [ mkErr (locLine (snapLoc snapshot)) SnapshotCodecFixtureInvalid $+                        "aggregate '" <> aggName agg <> "': snapshot state-codec version must be at least 1 and shape-hash must be non-empty"+                   | snapCodecVersion snapshot < 1 || T.null (snapShapeHash snapshot)+                   ]++    duplicateMembers =+        [ mkErr (locLine (cmdLoc c)) DuplicateCommandName $+            "aggregate '" <> aggName agg <> "' declares command '" <> cmdName c <> "' more than once"+        | c <- duplicatesBy cmdName (aggCommands agg)+        ]+            ++ [ mkErr (locLine (evLoc e)) DuplicateEventName $+                    "aggregate '" <> aggName agg <> "' declares event '" <> evName e <> "' more than once"+               | e <- duplicatesBy evName (aggEvents agg)+               ]++    eventBodyRefs =+        [ mkErr (locLine (evLoc e)) UndeclaredCommand $+            "event '" <> evName e <> "' copies fields from undeclared command '" <> command <> "'"+        | e <- aggEvents agg+        , EventFromCommand command <- [evBody e]+        , command `Set.notMember` commandNames+        ]++    registerInitialScope = concatMap checkRegisterInitial (aggRegs agg)+    checkRegisterInitial r = case [e | e <- specEnums spec, enumName e == regType r] of+        (e : _) ->+            [ outOfScope r "constructor of enum" (enumName e)+            | regInitialBare r `notElem` map (Just . fst) (enumCtors e)+            ]+        []+            | regType r == aggName agg <> "Vertex" ->+                [ outOfScope r "state of aggregate" (aggName agg)+                | maybe True (`Set.notMember` states) (regInitialBare r)+                ]+            | regType r `elem` map idName (specIds spec) ->+                [ outOfScope r "literal" "placeholder"+                | regInitialBare r /= Just "placeholder"+                ]+            | otherwise -> []+    outOfScope r expected domain =+        mkErr (locLine (regLoc r)) RegisterInitialOutOfScope $+            "register '" <> regName r <> "' initial '" <> renderRegInitial (regInitial r) <> "' is not a " <> expected <> " '" <> domain <> "'"+    regInitialBare r = case regInitial r of+        RegInitBare value -> Just value+        RegInitText _ -> Nothing+    renderRegInitial = \case+        RegInitBare value -> value+        RegInitText value -> value++    -- Rule 1: declared-reference for command / emit / goto / source.+    declaredRefs =+        concatMap transitionRefs (aggTransitions agg)+    transitionRefs t =+        [ mkErr (locLine (tLoc t)) UndeclaredCommand $+            "transition references undeclared command '" <> tCommand t <> "'"+        | not (tCommand t `Set.member` commandNames)+        ]+            ++ [ mkErr (locLine (tLoc t)) UndeclaredState $+                    "transition source '" <> tSource t <> "' is not a declared state"+               | not (tSource t `Set.member` states)+               ]+            ++ [ mkErr (locLine (tLoc t)) UndeclaredState $+                    "transition goto '" <> tGoto t <> "' is not a declared state"+               | not (tGoto t `Set.member` states)+               ]+            ++ [ mkErr (locLine (tLoc t)) UndeclaredEvent $+                    "emit references undeclared event '" <> ev <> "'"+               | ev <- tEmits t+               , not (ev `Set.member` eventNames)+               ]++    -- Rule 2: reachability of every non-terminal state from the initial state+    -- (the first state in the list).+    reachability = case map stName (aggStates agg) of+        [] -> []+        (initial : _) ->+            let reached = bfs (Set.singleton initial) [initial]+             in [ mkErr (locLine (stLoc s)) UnreachableState $+                    "state '" <> stName s <> "' is not reachable from the initial state '" <> initial <> "'"+                | s <- aggStates agg+                , not (stTerminal s)+                , not (stName s `Set.member` reached)+                ]+    edgesFrom src = [tGoto t | t <- aggTransitions agg, tSource t == src]+    bfs seen [] = seen+    bfs seen (x : xs) =+        let nexts = [n | n <- edgesFrom x, not (n `Set.member` seen)]+         in bfs (foldr Set.insert seen nexts) (xs ++ nexts)++    -- Rule 3: a terminal state has no outgoing transition.+    terminalNoOutgoing =+        [ mkErr (locLine (tLoc t)) TerminalHasOutgoing $+            "terminal state '" <> tSource t <> "' has an outgoing transition"+        | t <- aggTransitions agg+        , tSource t `Set.member` terminals+        ]++    -- Rule 4: every atom in a guard or write Expr resolves to a register, a+    -- field of the transition's command, an enum constructor, a rule, or a bool.+    guardScope = concatMap transitionScope (aggTransitions agg)+    transitionScope t =+        let inScope =+                registerNames+                    `Set.union` Set.fromList (Map.findWithDefault [] (tCommand t) commandFields)+                    `Set.union` enumCtorNames+                    `Set.union` ruleNames+                    -- State names are constructors of the implicit vertex enum, so a+                    -- @write reservationState := Held@ references a state legitimately.+                    `Set.union` states+            exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)+            badAtoms =+                [ n+                | e <- exprs+                , n <- exprNames e+                , not (n `Set.member` clockAtoms) -- clock atoms reported separately+                , not (n `Set.member` inScope)+                ]+            badTargets = [target | (target, _) <- tWrites t, target `Set.notMember` registerNames]+         in [ mkErr (locLine (tLoc t)) WriteTargetNotRegister $+                "write target '" <> target <> "' is not a register of aggregate '" <> aggName agg <> "'"+            | target <- dedup badTargets+            ]+                ++ [ mkErr (locLine (tLoc t)) GuardAtomOutOfScope $+                        "atom '" <> n <> "' in transition '" <> tSource t <> " -- " <> tCommand t <> "' resolves to no register, command field, enum constructor, or rule"+                   | n <- dedup badAtoms+                   ]++    -- Rule 5 (cross-cutting): no guard or write Expr samples a wall clock.+    clockFree = concatMap transitionClock (aggTransitions agg)+    transitionClock t =+        let exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)+            sampled = [n | e <- exprs, n <- exprNames e, n `Set.member` clockAtoms]+         in [ mkErr (locLine (tLoc t)) ClockSampled $+                "transition '" <> tSource t <> " -- " <> tCommand t <> "' samples the wall clock via '" <> n <> "'; time must be an injected input field, not sampled"+            | n <- dedup sampled+            ]++    -- EP-107: a projection references a first-class read model when one exists.+    -- Legacy standalone projections remain legal, but are surfaced as warnings.+    projectionSafety = case aggProjection agg of+        Nothing -> []+        Just projection -> case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == projTable projection] of+            [] ->+                [ mkErr (locLine (projLoc projection)) RmStrongInlineOnly $+                    "projection '" <> projTable projection <> "' declares consistency = Strong but has no readmodel node; a standalone projection is inline-only and has no subscription cursor"+                | projConsistency projection == Just Strong+                ]+                    ++ [ Diagnostic+                            { line = locLine (projLoc projection)+                            , severity = Warning+                            , code = RmProjectionWithoutNode+                            , message = "projection '" <> projTable projection <> "' has no readmodel node; registration, schema identity, consistency, and rebuild helpers are unavailable"+                            }+                       ]+            (readModel : _) ->+                [ mkErr (locLine (projLoc projection)) RmConsistencyConflict $+                    "projection '" <> projTable projection <> "' declares consistency " <> T.pack (show projectionConsistency) <> " but its readmodel node declares " <> T.pack (show (rmConsistency readModel))+                | Just projectionConsistency <- [projConsistency projection]+                , projectionConsistency /= rmConsistency readModel+                ]++    -- Rule 6 (hole-kind 3, mapping): keys are exact event names, never suffixes;+    -- duplicates and dangling keys are errors, and non-partial maps are total.+    statusMapTotality = case aggProjection agg of+        Nothing -> []+        Just p ->+            let evs = map evName (aggEvents agg)+                pairs = maybe [] mapPairs (projStatusMap p)+                keys = map fst pairs+                partial = maybe False mapPartial (projStatusMap p)+                uncovered = [event | event <- evs, event `notElem` keys]+                dangling = [key | key <- keys, key `notElem` evs]+                duplicateKeys = map fst (duplicatesBy fst pairs)+             in [ mkErr (locLine (projLoc p)) StatusMapDanglingKey $+                    "projection '" <> projTable p <> "' status-map key '" <> key <> "' is not an event name of aggregate '" <> aggName agg <> "'"+                | key <- dangling+                ]+                    ++ [ mkErr (locLine (projLoc p)) StatusMapDuplicateKey $+                            "projection '" <> projTable p <> "' repeats status-map key '" <> key <> "'"+                       | key <- duplicateKeys+                       ]+                    ++ [ mkErr (locLine (projLoc p)) StatusMapNotTotal $+                            "projection '" <> projTable p <> "' status-map is not total over events {" <> T.intercalate ", " uncovered <> "}"+                       | not partial+                       , not (null evs)+                       , not (null uncovered)+                       ]++    -- EP-2 evolution rules (single-spec; the diff path adds the cross-spec ones).+    evolutionRules = versionUpcasterRule ++ deprecatedEmitRule ++ wireVersionRule+    emittedNames = Set.fromList (concatMap tEmits (aggTransitions agg))+    maxEventVersion = maximum (1 : map evVersion (aggEvents agg))++    -- A non-initial event version must carry a contiguous upcaster (from v-1).+    versionUpcasterRule =+        [ mkErr (locLine (evLoc e)) EvtVersionMissingUpcaster $+            "event '" <> evName e <> "' version " <> tInt (evVersion e) <> " has no 'upcast from v" <> tInt (evVersion e - 1) <> "' clause"+        | e <- aggEvents agg+        , evVersion e > 1+        , maybe True ((/= evVersion e - 1) . fst) (evUpcastFrom e)+        ]++    -- A deprecated event must have left the write path.+    deprecatedEmitRule =+        [ mkErr (locLine (evLoc e)) DeprecatedEventStillEmitted $+            "deprecated event '" <> evName e <> "' is still emitted by a transition"+        | e <- aggEvents agg+        , evDeprecated e+        , evName e `Set.member` emittedNames+        ]++    -- The explicit `wire schemaVersion=` (if any) must equal the max event version.+    wireVersionRule = case aggWire agg of+        Just w+            | wireSchemaVersion w /= maxEventVersion ->+                [ Diagnostic+                    { line = locLine (aggLoc agg)+                    , severity = Warning+                    , code = WireSchemaVersionMismatch+                    , message =+                        "wire schemaVersion=" <> tInt (wireSchemaVersion w) <> " does not match the maximum event version " <> tInt maxEventVersion+                    }+                ]+        _ -> []++{- | The validator's re-derivation of the live+'Keiro.PGMQ.Runtime.queueRef' trio: physical queue, dead-letter queue, and+PGMQ backing table. Parity is pinned by the queue-runtime conformance suite.+-}+derivedQueueTrio :: Text -> (Text, Text, Text)+derivedQueueTrio logical = (physical, physical <> "_dlq", "pgmq.q_" <> physical)+  where+    physical = physicalBase logical++physicalBase :: Text -> Text+physicalBase logical+    | T.length base <= 43 && not ("_dlq" `T.isSuffixOf` base) = base+    | otherwise = hashedBase logical base+  where+    base = sanitizeQueueName logical++sanitizeQueueName :: Text -> Text+sanitizeQueueName =+    ensureLeadingLetter+        . T.intercalate "_"+        . filter (not . T.null)+        . T.splitOn "_"+        . T.map toLegal+        . T.toLower+  where+    toLegal c+        | (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '_' = c+        | otherwise = '_'+    ensureLeadingLetter value = case T.uncons value of+        Nothing -> "q"+        Just (c, _)+            | c >= 'a' && c <= 'z' -> value+            | otherwise -> T.cons 'q' value++hashedBase :: Text -> Text -> Text+hashedBase logical base = prefix <> "_" <> fnv1a64Hex logical+  where+    trimmedPrefix = T.dropWhileEnd (== '_') (T.take 26 base)+    prefix+        | T.null trimmedPrefix = "q"+        | otherwise = trimmedPrefix++fnv1a64Hex :: Text -> Text+fnv1a64Hex logical = T.pack (replicate (16 - length rendered) '0' <> rendered)+  where+    rendered = showHex (T.foldl' step offset logical) ""+    offset :: Word64+    offset = 0xcbf29ce484222325+    prime :: Word64+    prime = 0x100000001b3+    step hash character = (hash `xor` fromIntegral (ord character)) * prime++tInt :: Int -> Text+tInt = T.pack . show++mkErr :: Int -> DiagnosticCode -> Text -> Diagnostic+mkErr l c m = Diagnostic{line = l, severity = Error, code = c, message = m}++locLine :: Loc -> Int+locLine = unLoc++-- | The 'AName' atom names occurring anywhere in an expression.+exprNames :: Expr -> [Name]+exprNames (EOr a b) = exprNames a ++ exprNames b+exprNames (EAnd a b) = exprNames a ++ exprNames b+exprNames (ECmp _ a b) = exprNames a ++ exprNames b+exprNames (EAtom (AName n)) = [n]+exprNames (EAtom (ABool _)) = []++dedup :: (Ord a) => [a] -> [a]+dedup = Set.toList . Set.fromList++{- | Keep each occurrence after the first for a chosen key. Diagnostics are+anchored on the shadowing declaration rather than the declaration it shadows.+-}+duplicatesBy :: (Eq key) => (a -> key) -> [a] -> [a]+duplicatesBy key xs =+    [ x+    | (index, x) <- zip [0 :: Int ..] xs+    , key x `elem` map key (take index xs)+    ]
+ test/Main.hs view
@@ -0,0 +1,2482 @@+{- | Test driver for keiro-dsl. EP-1 milestone 1 tests: the @parse . pretty@+round-trip property over generated specs, and a unit test pinning the shape+of the canonical Reservation fixture.+-}+module Main (main) where++import Control.Exception (bracket)+import Control.Monad (filterM, forM_)+import Data.Either (isLeft)+import Data.List (partition, sort)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Keiro.Dsl.Diff (Change (..), ChangeKind (..), FamilyDiff (..), NodeFamily, diffSpecs, familyRegistry, isAdvisory, isBreaking)+import Keiro.Dsl.Grammar+import Keiro.Dsl.Harness (harnessFor, harnessReadModel, harnessRouter, harnessWorkflow)+import Keiro.Dsl.Manifest (manifestDependencies, moduleNameOf, renderManifest)+import Keiro.Dsl.Parser (parseSpec)+import Keiro.Dsl.PrettyPrint (renderSpec)+import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor)+import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), ScaffoldModule (..), defaultContext, firewallBreaches, genPrefixFor, holePrefixFor, scaffoldAggregate, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldRouter, scaffoldWorkqueue, windowSeconds)+import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName)+import Keiro.Dsl.ScaffoldRun (Refusal (..), ScaffoldReport (..), StaleModule (..), executeScaffold, planScaffold, renderScaffoldReport, scaffoldModules)+import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds)+import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, validateSpec)+import System.Directory (createDirectory, createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly)+import System.Environment (lookupEnv)+import System.FilePath (takeDirectory, (</>))+import System.IO (hClose, openTempFile)+import Test.Hspec hiding (Spec)+import Test.QuickCheck++main :: IO ()+main = hspec $ do+    describe "parse . pretty round-trip" $+        do+            it "re-parses any generated spec to an equal AST (modulo source locations)" $+                checkCoverage $+                    forAll genSpec $ \s ->+                        let families = map nodeTag (specNodes s)+                            roundTrip = parseSpec "<gen>" (renderSpec s) === Right s+                         in foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags+            it "round-trips an aggregate with no states" $+                parseSpec "<empty-states>" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec+            it "separates transition emit clauses from following nodes" $ do+                spec <- parseInlineSpec "<cross-family-boundaries>" crossFamilyBoundarySpec+                case specNodes spec of+                    [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do+                        concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"]+                        aggStates second `shouldBe` []+                    nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes))++    describe "string literal integrity" $ do+        it "parses an escaped emit-map value as exactly one row" $ do+            let src =+                    T.unlines+                        [ "context svc"+                        , ""+                        , "emit e {"+                        , "  contract c"+                        , "  topic events"+                        , "  source \"svc\""+                        , "  key thingId"+                        , "  map status {"+                        , "    \"a\\\" => Wat \\\"b\" => ThingAccepted"+                        , "    _ => skip"+                        , "  }"+                        , "  messageId derive hole"+                        , "  idempotencyKey derive hole"+                        , "}"+                        ]+            case parseSpec "<escaped-map>" src of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of+                    [row] -> do+                        emrValue row `shouldBe` "a\" => Wat \"b"+                        emrEvent row `shouldBe` "ThingAccepted"+                    rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows))+        it "rejects a raw newline inside a quoted string" $ do+            let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"first\nsecond\"\n}\n"+            parseSpec "<raw-newline>" src `shouldSatisfy` leftContains "unescaped newline"+        it "rejects an unknown escape sequence" $ do+            let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"bad\\q\"\n}\n"+            parseSpec "<unknown-escape>" src `shouldSatisfy` leftContains "unknown escape"+        it "round-trips adversarial text through topics, emit maps, and quoted bindings" $+            property $+                forAll genAdversarialText $ \t ->+                    let spec = escapedSpec t+                        rendered = renderSpec spec+                     in counterexample (T.unpack rendered) (parseSpec "<escaped-round-trip>" rendered === Right spec)++    describe "partial status maps" $ do+        it "suppresses totality only when the partial marker is present" $ do+            partial <- parseInlineSpec "<partial-status-map>" (statusMapSpec " partial")+            totalSpec <- parseInlineSpec "<total-status-map>" (statusMapSpec "")+            map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal]+            map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal]+            parseSpec "<partial-round-trip>" (renderSpec partial) `shouldBe` Right partial++    describe "positioned parser diagnostics" $ do+        it "rejects a duplicate goto at the second clause" $ do+            err <- parseErrorOf "<duplicate-goto>" duplicateGotoSpec+            err `shouldSatisfy` T.isInfixOf "duplicate goto"+            err `shouldSatisfy` T.isInfixOf "<duplicate-goto>:10:"+        it "rejects duplicate wire and projection blocks at their second occurrences" $ do+            wireErr <- parseErrorOf "<duplicate-wire>" duplicateWireSpec+            wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block"+            wireErr `shouldSatisfy` T.isInfixOf "<duplicate-wire>:8:"+            projectionErr <- parseErrorOf "<duplicate-projection>" duplicateProjectionSpec+            projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block"+            projectionErr `shouldSatisfy` T.isInfixOf "<duplicate-projection>:9:"+        it "anchors a missing goto on the transition line" $ do+            err <- parseErrorOf "<missing-goto>" missingGotoSpec+            err `shouldSatisfy` T.isInfixOf "missing a goto clause"+            err `shouldSatisfy` T.isInfixOf "<missing-goto>:8:"+        it "stops before a misplaced dispatch-id and expects schedule at its start" $ do+            let src = misplacedDispatchIdSpec+                expectedPosition =+                    "<misplaced-dispatch-id>:"+                        <> T.pack (show (lineNumberContaining "dispatch-id" src))+                        <> ":5:"+            err <- parseErrorOf "<misplaced-dispatch-id>" src+            err `shouldSatisfy` T.isInfixOf "schedule"+            err `shouldSatisfy` T.isInfixOf expectedPosition+        it "keeps a malformed register declaration's equals error" $ do+            err <- parseErrorOf "<malformed-register>" malformedRegisterSpec+            err `shouldSatisfy` T.isInfixOf "expecting '='"++    describe "bounded decimal literals" $ do+        forM_ decimalOverflowSpecs $ \(site, src) ->+            it ("rejects overflow at " <> site) $ do+                err <- parseErrorOf ("<overflow-" <> site <> ">") src+                err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range")+        it "accepts maxBound without changing its value" $ do+            spec <- parseInlineSpec "<max-bound>" (wireDecimalSpec (T.pack (show (maxBound :: Int))))+            [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]]+                `shouldBe` [maxBound]++    describe "identifier hygiene" $ do+        it "reports constructor shape and Haskell keywords at their owning declarations" $ do+            spec <- parseInlineSpec "<identifier-hygiene>" identifierHygieneSpec+            [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentNotConstructorSafe, IdentHaskellKeyword]]+                `shouldContain` [(IdentNotConstructorSafe, 3), (IdentHaskellKeyword, 7)]+        it "rejects generated vertex constructors that collide with event constructors" $ do+            spec <- parseInlineSpec "<vertex-collision>" vertexCollisionSpec+            [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision]+                `shouldBe` [(VertexCtorCollision, 3)]+        it "rejects underscore-leading names whose title-casing cannot make a module segment" $ do+            spec <- parseInlineSpec "<underscore-node>" underscoreNodeSpec+            [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe]+                `shouldBe` [(IdentNotConstructorSafe, 3)]+        it "rejects non-ASCII identifier characters in the parser" $+            parseSpec "<unicode-identifier>" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected"++    describe "canonical reservation.keiro" $+        it "parses into the expected aggregate shape" $ do+            input <- readTestText "test/fixtures/reservation.keiro"+            case parseSpec "test/fixtures/reservation.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    specContext spec `shouldBe` "hospital-capacity"+                    length (specIds spec) `shouldBe` 3+                    length (specEnums spec) `shouldBe` 3+                    length (specRules spec) `shouldBe` 1+                    case specNodes spec of+                        [NAggregate a] -> do+                            aggName a `shouldBe` "Reservation"+                            length (aggStates a) `shouldBe` 6+                            length (aggCommands a) `shouldBe` 2+                            length (aggEvents a) `shouldBe` 2+                            length (aggTransitions a) `shouldBe` 2+                            map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True]+                        other -> expectationFailure ("expected one aggregate node, got " <> show (length other))++    describe "validator" $ do+        it "accepts the canonical reservation.keiro" $ do+            codes <- errorCodesOf "test/fixtures/reservation.keiro"+            codes `shouldBe` []+        it "rejects a missing status-map as StatusMapNotTotal" $ do+            codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro"+            codes `shouldContain` [StatusMapNotTotal]+        it "rejects an undeclared command as UndeclaredCommand" $ do+            codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro"+            codes `shouldContain` [UndeclaredCommand]+        it "rejects a wall-clock guard atom as ClockSampled" $ do+            codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro"+            codes `shouldContain` [ClockSampled]+        it "accepts a v2 event with a contiguous upcaster hole" $ do+            codes <- errorCodesOf "test/fixtures/reservation-v2.keiro"+            codes `shouldBe` []+        it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do+            codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro"+            codes `shouldContain` [EvtVersionMissingUpcaster]+        it "requires exact, unique status-map event keys" $ do+            dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro"+            mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal]+            duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro"+            duplicate `shouldContain` [StatusMapDuplicateKey]+        it "rejects duplicate spec and aggregate names" $ do+            codes <- errorCodesOf "test/fixtures/duplicate-names.keiro"+            mapM_+                (\expected -> codes `shouldContain` [expected])+                [ DuplicateNodeName+                , DuplicateEnumCtor+                , DuplicateEnumWire+                , DuplicateIdPrefix+                , DuplicateCommandName+                , DuplicateEventName+                ]+        it "rejects aggregate-local references that do not resolve" $ do+            codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro"+            codes `shouldContain` [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister]+        it "anchors UnreachableState on the state row" $ do+            let src =+                    T.unlines+                        [ "context repro"+                        , ""+                        , "aggregate Thing"+                        , "  regs"+                        , "  states"+                        , "    Initial"+                        , "    Unreachable"+                        ]+            case parseSpec "<unreachable-row>" src of+                Left err -> expectationFailure (T.unpack err)+                Right spec ->+                    [line d | d <- validateSpec spec, code d == UnreachableState]+                        `shouldBe` [7]++    describe "evolution parsing" $+        it "parses event version and upcaster from reservation-v2.keiro" $ do+            input <- readTestText "test/fixtures/reservation-v2.keiro"+            case parseSpec "test/fixtures/reservation-v2.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of+                    (e : _) -> do+                        evVersion e `shouldBe` 2+                        evUpcastFrom e `shouldBe` Just (1, Hole)+                    [] -> expectationFailure "TransferReservationCreated not found"++    describe "aggregate snapshots (EP-109)" $ do+        it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do+            spec <- specOf "test/fixtures/reservation-snapshot.keiro"+            errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` []+            parseSpec "<snapshot-round-trip>" (renderSpec spec) `shouldBe` Right spec+            case [aggregate | NAggregate aggregate <- specNodes spec] of+                [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc" noLoc)+                aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates))+        it "rejects disabled intervals and invalid codec fixtures" $ do+            source <- readTestText "test/fixtures/reservation-snapshot.keiro"+            interval <- parseInlineSpec "<snapshot-zero>" (T.replace "snapshot every 100" "snapshot every 0" source)+            map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid]+            version <- parseInlineSpec "<snapshot-version-zero>" (T.replace "state-codec version=1" "state-codec version=0" source)+            map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid]+            emptyHash <- parseInlineSpec "<snapshot-empty-hash>" (T.replace "shape-hash=\"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\"" "shape-hash=\"\"" source)+            map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid]+        it "conditionally lowers JSON instances and the live defaultStateCodec" $ do+            snapshot <- specOf "test/fixtures/reservation-snapshot.keiro"+            ordinary <- specOf "test/fixtures/reservation.keiro"+            case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of+                ([snapshotAggregate], [ordinaryAggregate]) -> do+                    let snapshotModules = scaffoldAggregate (defaultContext (specContext snapshot)) snapshot snapshotAggregate+                        ordinaryModules = scaffoldAggregate (defaultContext (specContext ordinary)) ordinary ordinaryAggregate+                        snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules+                        snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules+                        ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules+                        ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules+                    snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)"+                    snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100"+                    snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (defaultStateCodec 1)"+                    snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\")"+                    ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass"+                    ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never"+                    ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing"+                    ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\""+                    firewallBreaches snapshotModules `shouldBe` []+                _ -> expectationFailure "expected one aggregate in each snapshot test spec"++    describe "process/timer (EP-3)" $ do+        it "parses the hospital-surge process + nested timer" $ do+            input <- readTestText "test/fixtures/hospital-surge.keiro"+            case parseSpec "test/fixtures/hospital-surge.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [p | NProcess p <- specNodes spec] of+                    (p : _) -> do+                        procId p `shouldBe` "HospitalSurge"+                        procName p `shouldBe` "hospital-surge"+                        procRejected p `shouldBe` PolHalt+                        procPoison p `shouldBe` PolHalt+                        sagaCategory (procSaga p) `shouldBe` "hospitalSurge"+                        tmName (procTimer p) `shouldBe` "surgeFollowUp"+                        onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired+                        onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry+                        tmMaxAttempts (procTimer p) `shouldBe` 5+                    [] -> expectationFailure "no process node parsed"+        it "round-trips the hospital-surge spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/hospital-surge.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge.keiro"+            codes `shouldBe` []+        it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do+            spec <- specOf "test/fixtures/hospital-surge.keiro"+            mapM_+                (\categoryName -> processErrorCodes (\process -> process{procSaga = (procSaga process){sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal])+                ["", "$all", "hospital-surge", "hospital surge", "wf:surge"]+            source <- readTestText "test/fixtures/hospital-surge.keiro"+            parseSpec "<legacy-saga>" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source)+                `shouldSatisfy` isLeft+        it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"+            codes `shouldContain` [ProcessFireAtNotInjected]+        it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"+            length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1+        it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro"+            codes `shouldContain` [ProcessDispatchIdSupplied]+        it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro"+            codes `shouldContain` [ProcessUnresolvedRef]+        it "rejects unresolved process commands, projections, schedules, and advance ids" $ do+            codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro"+            length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5+            codes `shouldContain` [ProcessDispatchIdSupplied]++    describe "router (EP-108)" $ do+        it "parses the incident-paging router shape" $ do+            input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro"+            case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [router | NRouter router <- specNodes spec] of+                    [router] -> do+                        rtId router `shouldBe` "PagingRouter"+                        rtName router `shouldBe` "jitsurei-paging"+                        corrField (rtKey router) `shouldBe` "incidentId"+                        rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall"+                        rvRow (rtResolve router) `shouldBe` ["responderId"]+                        rdCommand (rtDispatch router) `shouldBe` "SendPage"+                        rtRejected router `shouldBe` PolDeadLetter+                        rtPoison router `shouldBe` PolHalt+                    routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "round-trips the incident-paging spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts the incident-paging router with warnings only" $ do+            codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro"+            codes `shouldBe` []+            diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro"+            diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy]+        it "rejects unresolved targets, keys, commands, and binding scopes" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            routerErrorCodes (\router -> router{rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef]+            routerErrorCodes (\router -> router{rtKey = (rtKey router){corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown]+            routerErrorCodes (\router -> router{rtDispatch = (rtDispatch router){rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown]+            routerErrorCodes+                ( \router ->+                    let dispatch = rtDispatch router+                     in router{rtDispatch = dispatch{rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}}+                )+                spec+                `shouldContain` [RouterBindingUnscoped]+        it "rejects unresolved read models and contradictory rejection policies" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            let withoutReadModel = removeReadModel "service_oncall" spec+            errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef]+            routerErrorCodes+                ( \router ->+                    let dispatch = rtDispatch router+                        disposition = rdDisposition dispatch+                     in router+                            { rtRejected = PolHalt+                            , rtDispatch = dispatch{rdDisposition = disposition{onFailed = DDeadLetter "page rejected"}}+                            }+                )+                spec+                `shouldContain` [PolicyContradiction]+        it "rejects on-ambiguous Fired for process timers" $ do+            spec <- specOf "test/fixtures/hospital-surge.keiro"+            let changed =+                    spec+                        { specNodes =+                            [ case node of+                                NProcess process ->+                                    let timer = procTimer process+                                        fire = tmFire timer+                                        disposition = fireDisposition fire+                                     in NProcess process{procTimer = timer{tmFire = fire{fireDisposition = disposition{onAmbiguous = OFired}}}}+                                _ -> node+                            | node <- specNodes spec+                            ]+                        }+            errorCodes changed `shouldContain` [AmbiguousMarkedBenign]+        it "requires explicit policy and ambiguity clauses in the grammar" $ do+            source <- readTestText "test/fixtures/hospital-surge.keiro"+            parseSpec "<missing-poison>" (T.replace "  poison => halt\n" "" source) `shouldSatisfy` isLeft+            parseSpec "<missing-ambiguous>" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft+        it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            case [router | NRouter router <- specNodes spec] of+                [router] -> do+                    let ctx = defaultContext (specContext spec)+                        modules = scaffoldRouter ctx router+                        generated = [m | m <- modules, kind m == Generated]+                        holes = [m | m <- modules, kind m == HoleStub]+                    firewallBreaches generated `shouldBe` []+                    case (generated, holes) of+                        ([generatedModule], [holeModule]) -> do+                            moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions"+                            moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter"+                            moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities"+                            moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"+                        _ -> expectationFailure "expected one generated router module and one router hole module"+                routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "requires a caller callback for non-halting poison policies" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            case [router | NRouter router <- specNodes spec] of+                [router] -> do+                    let ctx = defaultContext (specContext spec)+                        generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated]+                    mapM_+                        ( \(choice, constructor) -> case generatedFor choice of+                            [generatedModule] -> do+                                generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg"+                                generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback")+                            _ -> expectationFailure "expected one generated router module"+                        )+                        [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")]+                    case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of+                        [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip"+                        _ -> expectationFailure "expected one generated router module"+                routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "emits router harness facts that pin policy and target-keyed identity" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            case [router | NRouter router <- specNodes spec] of+                [router] -> case harnessRouter (defaultContext (specContext spec)) router of+                    [facts] -> do+                        moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")"+                        moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence"+                    modules -> expectationFailure ("expected one router harness, got " <> show (length modules))+                routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "rejects invalid timer ceilings and target field bindings" $ do+            codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro"+            mapM_+                (\expected -> codes `shouldContain` [expected])+                [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved]+        it "accepts resolved process projection references" $ do+            codes <- errorCodesOf "test/fixtures/surge-service.keiro"+            codes `shouldBe` []+        it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do+            mods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+            let gens = [m | m <- mods, kind m == Generated]+                holes = [m | m <- mods, kind m == HoleStub]+            length holes `shouldBe` 1+            firewallBreaches gens `shouldBe` []+            case gens of+                [generatedModule] -> do+                    -- the worker uses the spec's ceiling, never the dangerous default+                    moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5"+                    moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions"+                    moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\""+                    moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"+                    moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool"+                    moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)"+                    case holes of+                        [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory"+                        _ -> expectationFailure "expected one process hole module"+                _ -> expectationFailure "expected one generated process module"+        it "process scaffold is deterministic" $ do+            a <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+            b <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+            map moduleText a `shouldBe` map moduleText b++    describe "contract (EP-4)" $ do+        it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do+            input <- readTestText "test/fixtures/contract.keiro"+            case parseSpec "test/fixtures/contract.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [c | NContract c <- specNodes spec] of+                    (c : _) -> do+                        ctrName c `shouldBe` "emergency"+                        ctrDiscriminator c `shouldBe` "messageType"+                        map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"]+                        map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"]+                    [] -> expectationFailure "no contract node parsed"+        it "round-trips the contract spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/contract.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "round-trips the intake (inbox) spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/intake.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts the intake spec (complete disposition, no inversions)" $ do+            codes <- errorCodesOf "test/fixtures/intake.keiro"+            codes `shouldBe` []+        it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do+            spec <- specOf "test/fixtures/intake.keiro"+            ordinary <- specOf "test/fixtures/intake-decode.keiro"+            case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of+                ([intake], [defaultIntake]) -> do+                    inkPersist intake `shouldBe` InkPersistDedupeOnly+                    inkPersist defaultIntake `shouldBe` InkPersistFull+                    renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only"+                    renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist ="+                    let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake)+                    inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly"+                (intakes, defaultIntakes) ->+                    expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes))+        it "rejects duplicate => retry (inversion 1)" $ do+            codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro"+            codes `shouldContain` [DispositionDuplicateRetry]+        it "rejects previouslyFailed => retry (inversion 2)" $ do+            codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro"+            codes `shouldContain` [DispositionPreviouslyFailedRetry]+        it "rejects an incomplete disposition table" $ do+            codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro"+            codes `shouldContain` [DispositionIncomplete]+        it "rejects a shadowing duplicate intake disposition row" $ do+            codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro"+            codes `shouldContain` [DispositionDuplicateOutcome]+        it "rejects intake events declared on another topic" $ do+            codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro"+            codes `shouldContain` [TopicAffinityMismatch]+        it "round-trips the emit/publisher spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/emit.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do+            codes <- errorCodesOf "test/fixtures/emit.keiro"+            codes `shouldBe` []+        it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do+            codes <- errorCodesOf "test/fixtures/emit-noskip.keiro"+            codes `shouldContain` [EmitSkipMissing]+        it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do+            codes <- errorCodesOf "test/fixtures/emit-badevent.keiro"+            codes `shouldContain` [EmitUnresolvedContract]+        it "rejects emit events declared on another topic" $ do+            codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro"+            codes `shouldContain` [TopicAffinityMismatch]++    describe "pgmq workqueue/dispatch (EP-5)" $ do+        it "round-trips the reservation-work spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/reservation-work.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts the reservation-work spec (physical matches, no inversions)" $ do+            codes <- errorCodesOf "test/fixtures/reservation-work.keiro"+            codes `shouldBe` []+        it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do+            codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro"+            codes `shouldContain` [WqPhysicalDivergence]+        it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do+            codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro"+            codes `shouldContain` [WqStoreFailureNotRetry]+        it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do+            codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro"+            codes `shouldContain` [WqDecodeFailureNotDeadLetter]+        it "requires complete, unique workqueue disposition rows" $ do+            incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro"+            incomplete `shouldContain` [WqDispositionIncomplete]+            duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro"+            let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome]+            map line duplicateDiagnostics `shouldBe` [17]+        it "checks the captured queueRef dlq and table fixtures" $ do+            dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro"+            dlqCodes `shouldContain` [WqDlqDivergence]+            tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro"+            tableCodes `shouldContain` [WqTableDivergence]+        it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do+            upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro"+            upper `shouldBe` []+            hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro"+            hashed `shouldBe` []+            derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments"+                `shouldBe` ( "hospital_capacity_reservat_757040df00976c33"+                           , "hospital_capacity_reservat_757040df00976c33_dlq"+                           , "pgmq.q_hospital_capacity_reservat_757040df00976c33"+                           )+        it "resolves dispatch dedup queues and payload wire fields" $ do+            ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro"+            ghost `shouldContain` [DispatchDedupQueueUnresolved]+            field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro"+            field `shouldContain` [DispatchDedupFieldUnresolved]+        it "requires a resolvable group key exactly when ordering is FIFO" $ do+            noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro"+            noKey `shouldContain` [WqGroupKeyMissing]+            unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro"+            unordered `shouldContain` [WqGroupKeyWithoutFifo]+            source <- readTestText "test/fixtures/reservation-work.keiro"+            unresolved <- parseInlineSpec "<unresolved-group-key>" (T.replace "group key from reservationId" "group key from missingId" source)+            map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved]+        it "warns on unlogged storage and rejects empty partition settings" $ do+            warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro"+            warningCodes `shouldContain` [WqUnloggedDurability]+            partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro"+            partitionCodes `shouldContain` [WqPartitionSpecEmpty]+        it "lowers ordering, provisioning, and raw group-key projection" $ do+            spec <- specOf "test/fixtures/reservation-work.keiro"+            case [workqueue | NWorkqueue workqueue <- specNodes spec] of+                workqueue : _ -> do+                    let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue+                        queue = generatedTextEndingIn "Queue.hs" modules+                        policy = generatedTextEndingIn "QueuePolicy.hs" modules+                    queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId"+                    policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput"+                    policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)"+                    firewallBreaches modules `shouldBe` []+                [] -> expectationFailure "reservation-work fixture has no workqueue"++    describe "readmodel (EP-107)" $ do+        it "parses and round-trips first-class read models" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            case [readModel | NReadModel readModel <- specNodes spec] of+                [subscriptionModel, inlineModel] -> do+                    rmName subscriptionModel `shouldBe` "transfer_decisions"+                    rmColumns subscriptionModel+                        `shouldBe` [ RmColumn "reservation_id" "text" True+                                   , RmColumn "hospital_id" "text" True+                                   , RmColumn "status" "text" True+                                   , RmColumn "decided_at" "timestamptz" False+                                   ]+                    rmScope subscriptionModel `shouldBe` Just (RmCategory "reservation")+                    rmFeed subscriptionModel `shouldBe` RmSubscription+                    rmSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub"+                    rmName inlineModel `shouldBe` "subscriptions"+                    rmScope inlineModel `shouldBe` Nothing+                    rmFeed inlineModel `shouldBe` RmInline+                nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes))+            parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts an aggregate projection without a consistency clause" $ do+            spec <- parseInlineSpec "<projection-without-consistency>" projectionWithoutConsistencySpec+            case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of+                [projection] -> projConsistency projection `shouldBe` Nothing+                projections -> expectationFailure ("expected one projection, got " <> show (length projections))+        it "pins the canonical UTF-8 shape digest and runtime identities" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            case [readModel | NReadModel readModel <- specNodes spec] of+                (subscriptionModel : inlineModel : _) -> do+                    canonicalShape subscriptionModel+                        `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null"+                    deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"+                    deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738"+                    registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions"+                    subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub"+                    subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub"+                nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))+        it "accepts the positive readmodel fixture with all references resolved" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            validateSpec spec `shouldBe` []+        it "rejects shape drift and unknown SQL column types" $ do+            codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro"+            codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType]+        it "rejects Strong on inline and standalone projections" $ do+            inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro"+            inlineCodes `shouldContain` [RmStrongInlineOnly]+            standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro"+            let diagnostics = validateSpec standalone+            map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode]+            [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode]+                `shouldBe` [Warning]+        it "rejects scope without Strong and an unreferenced inline feed" $ do+            scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro"+            scopeCodes `shouldContain` [RmScopeWithoutStrong]+            inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro"+            inlineCodes `shouldContain` [RmInlineFeedUnreferenced]+        it "rejects projection consistency conflicts" $ do+            codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro"+            codes `shouldContain` [RmConsistencyConflict]+        it "resolves query read models and validates query consistency" $ do+            codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro"+            codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid]+        it "resolves dispatch read models and declared dedup columns" $ do+            codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro"+            codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown]+        it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            let ctx = defaultContext (specContext spec)+                readModels = [readModel | NReadModel readModel <- specNodes spec]+                modules = concatMap (scaffoldReadModel ctx) readModels+                transfer = generatedTextEndingIn "Transfer_decisions/ReadModel.hs" modules+                inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules+                transferHoles = [moduleText m | m <- modules, "Transfer_decisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)]+            length modules `shouldBe` 6+            length [m | m <- modules, kind m == Generated] `shouldBe` 4+            length [m | m <- modules, kind m == HoleStub] `shouldBe` 2+            firewallBreaches modules `shouldBe` []+            transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions"+            transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]"+            transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\""+            transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection"+            inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []"+            inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection"+            transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()")+        it "threads qualified table and column guidance into aggregate projection holes" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            case [aggregate | NAggregate aggregate <- specNodes spec] of+                [aggregate] -> do+                    let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate+                        holes = [moduleText m | m <- modules, kind m == HoleStub]+                        projection = generatedTextEndingIn "Projection.hs" modules+                    holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable")+                    holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"")+                    projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable"+                aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates))+        it "emits runtime-free derivation facts for each read model" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            case [readModel | NReadModel readModel <- specNodes spec] of+                (subscriptionModel : _) -> do+                    let modules = harnessReadModel (defaultContext (specContext spec)) subscriptionModel+                        harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules+                    length modules `shouldBe` 1+                    firewallBreaches modules `shouldBe` []+                    harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", \"fnv1a:3717f6d9e3c44bd6\")"+                    harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", \"CategoryHead reservation\")"+                    harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts"+                nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))++    describe "workflow/operation (EP-6)" $ do+        it "round-trips the workflow spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/workflow.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+        it "accepts the workflow spec (await<->signal matches, run resolves)" $ do+            codes <- errorCodesOf "test/fixtures/workflow.keiro"+            codes `shouldBe` []+        it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do+            codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro"+            codes `shouldContain` [AwaitSignalMismatch]+        it "rejects duplicate workflow labels" $ do+            codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro"+            codes `shouldContain` [WorkflowDuplicateLabel]+        it "rejects unresolved workflow id and sleep fields" $ do+            codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro"+            codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved]+        it "validates rule domains, totality, case constructors, and bodies" $ do+            unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro"+            unresolved `shouldBe` [RuleDomainUnresolved]+            codes <- errorCodesOf "test/fixtures/rule-not-total.keiro"+            mapM_+                (\expected -> codes `shouldContain` [expected])+                [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope]+        it "rejects unresolved command operation references" $ do+            codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro"+            codes `shouldContain` [OperationUnresolvedRef]+        it "rejects a signal value type that differs from its await" $ do+            codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro"+            codes `shouldContain` [AwaitSignalValueMismatch]+        it "round-trips guarded patches and terminal continueAsNew" $ do+            input <- readTestText "test/fixtures/workflow-evolution.keiro"+            case parseSpec "workflow-evolution" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec+                    errorCodes spec `shouldBe` []+        it "rejects duplicate patch ids anywhere in the workflow body" $ do+            codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro"+            codes `shouldBe` [WorkflowPatchDuplicate]+        it "rejects non-terminal and nested continueAsNew" $ do+            codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro"+            codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal]+        it "rejects a colon in a patch id with a workflow diagnostic" $ do+            codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro"+            codes `shouldBe` [WorkflowPatchIdInvalid]+        it "lowers patch facts and live runtime declarations" $ do+            spec <- specOf "test/fixtures/workflow-evolution.keiro"+            case [workflow | NWorkflow workflow <- specNodes spec] of+                [workflow] -> do+                    let modules = harnessWorkflow (defaultContext (specContext spec)) workflow+                        facts = generatedTextEndingIn "WorkflowFacts.hs" modules+                        runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules+                    facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)"+                    facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed"+                    facts `shouldSatisfy` T.isInfixOf "(\"patches\", \"fraud-check-v2\")"+                    runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]"+                    runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}"+                workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows))++    describe "diff (evolution classification)" $ do+        it "covers every node family exactly once and explains exclusions" $ do+            sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily])+            [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` []+        it "classifies a field added without a version bump as BREAKING" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro"+            any isBreaking cs `shouldBe` True+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldAddedWithoutBump]+        it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro"+            any isBreaking cs `shouldBe` False+            [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject)+        it "reports no breaking change when the spec is unchanged" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro"+            any isBreaking cs `shouldBe` False+        it "classifies a direct event field type change as EvtFieldTypeChanged" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldTypeChanged]+        it "resolves fields(Command) before comparing event field types" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldTypeChanged]+        it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtFieldRemovedSameVersion]+        it "uses EvtVersionDecreased for a version decrease" $ do+            cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtVersionDecreased]+        it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EvtVersionMissingUpcaster]+        it "classifies an enum constructor removal as EnumCtorRemoved" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EnumCtorRemoved]+        it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just EnumWireSpellingChanged]+        it "classifies an enum constructor addition as additive" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro"+            any isBreaking cs `shouldBe` False+            [ckSubject k | Additive k <- cs] `shouldContain` ["BlackTag"]+        it "classifies an effective wire convention change as WireSpecChanged" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just WireSpecChanged]+        it "keeps deprecation additive and reports un-deprecation as EventUndeprecated" $ do+            deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro"+            any isBreaking deprecated `shouldBe` False+            restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro"+            any isAdvisory restored `shouldBe` True+            [ckCode k | Advisory k <- restored] `shouldContain` [Just EventUndeprecated]+        it "classifies a removed contract event as ContractEventRemoved" $ do+            cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just ContractEventRemoved]+        it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do+            changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro"+            [ckCode k | Breaking k <- changed] `shouldContain` [Just ContractFieldChanged]+            added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro"+            [ckCode k | Breaking k <- added] `shouldContain` [Just ContractFieldChanged]+        it "reports a field addition with a contract version bump as an advisory" $ do+            cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro"+            any isBreaking cs `shouldBe` False+            [ckCode k | Advisory k <- cs] `shouldContain` [Just ContractSchemaVersionBumped]+        it "classifies a contract schema version decrease separately" $ do+            cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just ContractSchemaVersionDecreased]+        it "classifies contract topic and discriminator changes separately" $ do+            topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro"+            [ckCode k | Breaking k <- topic] `shouldContain` [Just ContractTopicChanged]+            discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro"+            [ckCode k | Breaking k <- discriminator] `shouldContain` [Just ContractDiscriminatorChanged]+        it "classifies a new contract event as additive" $ do+            cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro"+            any isBreaking cs `shouldBe` False+            [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"]+        it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do+            wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro"+            [ckCode k | Breaking k <- wire] `shouldContain` [Just WqPayloadFieldChanged]+            fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro"+            [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [Just WqPayloadFieldChanged]+            required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro"+            [ckCode k | Breaking k <- required] `shouldContain` [Just WqPayloadFieldChanged]+        it "classifies a new optional workqueue payload field as additive" $ do+            cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro"+            any isBreaking cs `shouldBe` False+            [ckSubject k | Additive k <- cs] `shouldContain` ["note"]+        it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do+            cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just WqOrderingChanged]+            [ckDetail k | Breaking k <- cs, ckCode k == Just WqOrderingChanged]+                `shouldSatisfy` any (T.isInfixOf "delivery-order contract")+        it "classifies workqueue provision changes as operational migrations" $ do+            cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just WqProvisionChanged]+            [ckDetail k | Breaking k <- cs, ckCode k == Just WqProvisionChanged]+                `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally")+        it "classifies workqueue group-key changes as breaking repartitioning" $ do+            cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just WqGroupKeyChanged]+            [ckDetail k | Breaking k <- cs, ckCode k == Just WqGroupKeyChanged]+                `shouldSatisfy` any (T.isInfixOf "re-partitioned")+        it "classifies a process input type change as ProcessInputChanged" $ do+            cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just ProcessInputChanged]+        it "classifies workflow input and output changes as WorkflowShapeChanged" $ do+            input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro"+            [ckCode k | Breaking k <- input] `shouldContain` [Just WorkflowShapeChanged]+            output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro"+            [ckCode k | Breaking k <- output] `shouldContain` [Just WorkflowShapeChanged]+        it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do+            relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro"+            [ckCode k | Breaking k <- relabeled] `shouldContain` [Just WorkflowBodyChanged]+            appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro"+            [ckCode k | Breaking k <- appended] `shouldContain` [Just WorkflowBodyChanged]+            [ckDetail k | Breaking k <- appended, ckCode k == Just WorkflowBodyChanged]+                `shouldSatisfy` any (T.isInfixOf "new patch guard")+        it "classifies a body addition wholly guarded by a new patch as additive" $ do+            cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro"+            any isBreaking cs `shouldBe` False+            [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"]+            [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"]+        it "classifies removing an existing patch as breaking" $ do+            cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just WorkflowPatchRemoved]+            [ckDetail k | Breaking k <- cs, ckCode k == Just WorkflowPatchRemoved]+                `shouldSatisfy` any (T.isInfixOf "cannot prove")+        it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do+            appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro"+            any isBreaking appended `shouldBe` False+            [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"]+            changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro"+            [ckCode k | Breaking k <- changed] `shouldContain` [Just WorkflowContinueSeedChanged]+            [ckDetail k | Breaking k <- changed, ckCode k == Just WorkflowContinueSeedChanged]+                `shouldSatisfy` any (T.isInfixOf "restoreSeed")+        it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do+            cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just WorkflowStableNameChanged]+        it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do+            cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just DerivedIdentityChanged]+        it "classifies an id prefix change as IdPrefixChanged" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just IdPrefixChanged]+        it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do+            policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro"+            [ckCode k | Breaking k <- policy] `shouldContain` [Just DedupeIdentityChanged]+            key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro"+            [ckCode k | Breaking k <- key] `shouldContain` [Just DedupeIdentityChanged]+        it "reports intake decode-posture changes as warnings" $ do+            cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro"+            any isBreaking cs `shouldBe` False+            [ckCode k | Advisory k <- cs] `shouldContain` [Just DecodePostureChanged]+            [ckCode k | Advisory k <- cs] `shouldContain` [Just IntakePersistenceChanged]+        it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do+            processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro"+            [ckCode k | Breaking k <- processName] `shouldContain` [Just DerivedIdentityChanged]+            timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro"+            [ckCode k | Breaking k <- timerId] `shouldContain` [Just DerivedIdentityChanged]+            base <- specOf "test/fixtures/hospital-surge.keiro"+            let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process{procSaga = (procSaga process){sagaCategory = "hospitalSurgeV2"}}) base)+            [ckCode k | Breaking k <- categoryChange] `shouldContain` [Just DerivedIdentityChanged]+        it "classifies router stable names, keys, and targets as identity-bearing" $ do+            base <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtName = "paging-v2"}) base)+                keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtKey = (rtKey router){corrVia = "otherIdText"}}) base)+                target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtTarget = "OtherPage"}) base)+            [ckCode k | Breaking k <- stableName] `shouldContain` [Just RouterStableNameChanged]+            [ckCode k | Breaking k <- keyDerivation] `shouldContain` [Just DerivedIdentityChanged]+            [ckCode k | Breaking k <- target] `shouldContain` [Just DerivedIdentityChanged]+        it "reports a timer window change as a warning" $ do+            cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro"+            any isBreaking cs `shouldBe` False+            [ckCode k | Advisory k <- cs] `shouldContain` [Just TimerWindowChanged]+        it "reports emit-map changes as warnings and derive changes as breaking" $ do+            mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro"+            any isBreaking mapping `shouldBe` False+            [ckCode k | Advisory k <- mapping] `shouldContain` [Just EmitMappingChanged]+            derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro"+            [ckCode k | Breaking k <- derive] `shouldContain` [Just DerivedIdentityChanged]+        it "classifies publisher outbox identity and ordering independently" $ do+            outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro"+            [ckCode k | Breaking k <- outbox] `shouldContain` [Just DerivedIdentityChanged]+            ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro"+            any isBreaking ordering `shouldBe` False+            [ckCode k | Advisory k <- ordering] `shouldContain` [Just PublisherPolicyChanged]+        it "classifies workqueue names as QueueIdentityChanged" $ do+            cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [Just QueueIdentityChanged]+        it "classifies pgmq dispatch dedupe and retargeting independently" $ do+            dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro"+            [ckCode k | Breaking k <- dedupe] `shouldContain` [Just DedupeIdentityChanged]+            retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro"+            any isBreaking retarget `shouldBe` False+            [ckCode k | Advisory k <- retarget] `shouldContain` [Just DispatchRetargeted]+        it "reports aggregate projection changes as warnings" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro"+            any isBreaking cs `shouldBe` False+            [ckCode k | Advisory k <- cs] `shouldContain` [Just ProjectionChanged]+        it "classifies read-model version and unversioned shape changes" $ do+            base <- specOf "test/fixtures/readmodel-runtime.keiro"+            let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmVersion = 2}) base+                changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base+                bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel){rmVersion = 2}) base+                decreased = diffSpecs versionTwo base+                unversioned = diffSpecs base changedShape+                bumped = diffSpecs base bumpedShape+            [ckCode k | Breaking k <- decreased] `shouldContain` [Just ReadModelVersionDecreased]+            [ckCode k | Breaking k <- unversioned] `shouldContain` [Just ReadModelShapeChangedWithoutBump]+            any isBreaking bumped `shouldBe` False+            [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"]+        it "classifies read-model registry, table, subscription, and removal identities" $ do+            base <- specOf "test/fixtures/readmodel-runtime.keiro"+            let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmTable = "transfer_decisions_v2"}) base+                subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmSubscription = Just "transfer-decisions-v2"}) base+                renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmName = "reservation_decisions"}) base+                removed = removeReadModel "transfer_decisions" base+            mapM_+                (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [Just DerivedIdentityChanged])+                [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed]+        it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do+            base <- specOf "test/fixtures/readmodel-runtime.keiro"+            let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmFeed = RmInline}) base+                consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) base+                entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmScope = Just RmEntireLog}) base+            [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [Just ReadModelFeedChanged]+            [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [Just ReadModelConsistencyWeakened]+            [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [Just ReadModelConsistencyWeakened]+        it "classifies Eventual to Strong read-model consistency as additive" $ do+            strong <- specOf "test/fixtures/readmodel-runtime.keiro"+            let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) strong+                changes = diffSpecs eventual strong+            any isBreaking changes `shouldBe` False+            [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"]++    describe "module placement (M1)" $ do+        it "GeneratedPrefix is today's namespace (Generated.<Ctx>.<Node>, holes at <Ctx>.<Node>)" $ do+            let ctx = defaultContext "hospital-capacity"+            genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation"+            holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation"+        it "module-root prefixes both layers" $ do+            let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"}+            genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation"+            holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"+        it "CollocatedLeaf places the generated layer under the domain leaf" $ do+            let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf}+            genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated"+            holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"+        it "parses and preserves the module/layout clauses through parse . pretty" $ do+            let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n  regs\n  states Open\n"+            case parseSpec "<m1>" src of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    specModuleRoot spec `shouldBe` Just "Acme.Services"+                    specLayout spec `shouldBe` Just CollocatedLeaf+                    parseSpec "<m1>" (renderSpec spec) `shouldBe` Right spec+        it "a spec without the clauses leaves placement at the default" $ do+            input <- readTestText "test/fixtures/reservation.keiro"+            case parseSpec "test/fixtures/reservation.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    specModuleRoot spec `shouldBe` Nothing+                    specLayout spec `shouldBe` Nothing++    describe "manifest (M2)" $ do+        it "lists exactly the modules the scaffolder produced" $ do+            mods <- scaffoldFixture "test/fixtures/reservation.keiro"+            spec <- specOf "test/fixtures/reservation.keiro"+            let manifest = renderManifest "reservation.keiro" mods spec+                expectedNames = sort (map (moduleNameOf . modulePath) mods)+            -- every produced module name appears in the manifest…+            mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames+            -- …and the module list is exactly the scaffolder's output set.+            expectedNames+                `shouldBe` sort+                    [ "Generated.HospitalCapacity.Reservation.Codec"+                    , "Generated.HospitalCapacity.Reservation.Domain"+                    , "Generated.HospitalCapacity.Reservation.EventStream"+                    , "Generated.HospitalCapacity.Reservation.Harness"+                    , "Generated.HospitalCapacity.Reservation.Projection"+                    , "HospitalCapacity.Reservation.Holes"+                    ]+        it "derives the dependency set from the node kinds present (aggregate)" $ do+            spec <- specOf "test/fixtures/reservation.keiro"+            manifestDependencies spec `shouldBe` ["aeson", "base", "keiki", "keiro", "text"]+        it "derives the process dependency set, including worker-policy runtime imports" $ do+            spec <- specOf "test/fixtures/hospital-surge.keiro"+            let dependencies = manifestDependencies spec+            mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"]+        it "uses the registered shibuya-core package name for router scaffolds" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            let dependencies = manifestDependencies spec+            mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"]+            dependencies `shouldNotContain` ["shibuya"]++    describe "new <kind> skeletons (M5)" $ do+        it "every skeleton parses and validates with zero error diagnostics" $+            mapM_ assertSkeletonValid skeletonKinds+        it "every skeleton passes the scaffold refusal gates" $+            mapM_ assertSkeletonScaffoldable skeletonKinds+        it "fresh skeleton scaffolds match the committed compiling modules" $+            mapM_ (uncurry assertSkeletonMatchesCommitted) skeletonModuleRoots+        it "rejects an unknown kind with a helpful message" $+            case skeletonFor "bogus" of+                Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True+                Right _ -> expectationFailure "expected an error for an unknown kind"++    describe "firewall self-check (M3)" $ do+        it "flags a forbidden operator in a Generated module" $ do+            let m = ScaffoldModule{modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"}+            firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)]+        it "ignores forbidden operators in a HoleStub module (holes own them)" $ do+            let m = ScaffoldModule{modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"}+            firewallBreaches [m] `shouldBe` []+        it "matches `lit` as a word, not a substring of quality/split" $ do+            let clean = ScaffoldModule{modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"}+                dirty = ScaffoldModule{modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"}+            firewallBreaches [clean] `shouldBe` []+            firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)]+        it "skips strings and comments and maximal-munches symbolic tokens" $ do+            let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b"+                dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d"+            firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)]+            firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)]+        it "guards keiki imports while allowing the generated Core allowlist" $ do+            let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder"+                restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)"+                allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)"+            firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)]+            firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)]+            firewallBreaches [allowed] `shouldBe` []+        it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do+            aggMods <- scaffoldFixture "test/fixtures/reservation.keiro"+            procMods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+            firewallBreaches (aggMods <> procMods) `shouldBe` []++    describe "scaffold gates" $ do+        it "refuses duplicate and case-folded module paths with both origins" $ do+            spec <- specOf "test/fixtures/reservation.keiro"+            case [aggregate | NAggregate aggregate <- specNodes spec] of+                aggregate : _ -> do+                    let duplicate = spec{specNodes = [NAggregate aggregate, NAggregate aggregate]}+                        caseVariant = spec{specNodes = [NAggregate aggregate, NAggregate aggregate{aggName = T.toUpper (aggName aggregate)}]}+                    planScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins+                    planScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins+                [] -> expectationFailure "reservation fixture has no aggregate"+        it "refuses a bannerless Generated target without changing its bytes" $+            withTempDirectory "keiro-dsl-banner" $ \out -> do+                spec <- specOf "test/fixtures/reservation.keiro"+                let ctx = defaultContext (specContext spec)+                case planScaffold ctx spec of+                    Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals)+                    Right modules -> case [m | m <- modules, kind m == Generated] of+                        generated : _ -> do+                            let target = out </> modulePath generated+                            createDirectoryIfMissing True (takeDirectory target)+                            TIO.writeFile target "hand owned\n"+                            result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules+                            result `shouldSatisfy` isMissingBannerRefusal+                            TIO.readFile target `shouldReturn` "hand owned\n"+                            forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules+                            forced `shouldSatisfy` isSuccessfulScaffold+                            TIO.readFile target `shouldReturn` moduleText generated+                        [] -> expectationFailure "reservation scaffold has no Generated module"+        it "reports renamed-node modules as stale without deleting them" $+            withTempDirectory "keiro-dsl-stale-rename" $ \out -> do+                spec <- parseInlineSpec "<stale-rename>" loweringAggregateSpec+                first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec+                let renamed = spec{specNodes = map renameCounter (specNodes spec)}+                second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed+                let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))+                    oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first))+                reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `elem` stale && StaleModule HoleStub oldHoles `elem` stale+                doesFileExist (out </> oldDomain) `shouldReturn` True+                doesFileExist (out </> oldHoles) `shouldReturn` True+        it "reports the entire old tree across a module-root flip" $+            withTempDirectory "keiro-dsl-stale-root" $ \out -> do+                spec <- parseInlineSpec "<stale-root>" loweringAggregateSpec+                let initialCtx = defaultContext (specContext spec)+                    rootedCtx = initialCtx{moduleRoot = "Acme"}+                first <- executePlannedScaffold out "counter.keiro" initialCtx spec+                second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec+                reportStale second+                    `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first]+                forM_ (reportStale second) $ \stale -> doesFileExist (out </> stalePath stale) `shouldReturn` True+                renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro")+        it "reports moved generated modules across a layout flip" $+            withTempDirectory "keiro-dsl-stale-layout" $ \out -> do+                spec <- parseInlineSpec "<stale-layout>" loweringAggregateSpec+                let initialCtx = defaultContext (specContext spec)+                    collocatedCtx = initialCtx{placement = CollocatedLeaf}+                first <- executePlannedScaffold out "counter.keiro" initialCtx spec+                second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec+                let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated]+                reportStale second `shouldSatisfy` all (`elem` oldGenerated)+                length (reportStale second) `shouldBe` length oldGenerated+        it "writes a parseable record and no stale section for a fresh output" $+            withTempDirectory "keiro-dsl-record" $ \out -> do+                spec <- parseInlineSpec "<fresh-record>" loweringAggregateSpec+                let ctx = defaultContext (specContext spec)+                report <- executePlannedScaffold out "counter.keiro" ctx spec+                reportStale report `shouldBe` []+                renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:")+                contents <- TIO.readFile (out </> recordFileName (specContext spec))+                parseRecord contents+                    `shouldBe` Just+                        ScaffoldRecord+                            { recSpecPath = "counter.keiro"+                            , recModuleRoot = ""+                            , recLayout = "prefixed"+                            , recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report]+                            }+                parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents+                parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing++    describe "faithful scaffold lowering" $ do+        it "escapes a trailing-backslash payload literal exactly once" $ do+            spec <- specOf "test/fixtures/hospital-surge.keiro"+            case [process | NProcess process <- specNodes spec] of+                process : _ -> do+                    let timer = (procTimer process){tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]}+                        modules = scaffoldProcess (defaultContext (specContext spec)) process{procTimer = timer}+                    generatedTextEndingIn "Process.hs" modules+                        `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)"+                [] -> expectationFailure "hospital-surge fixture has no process"+        it "preserves quoted Text register initials and refuses unsafe register shapes" $ do+            spec <- parseInlineSpec "<register-initials>" loweringAggregateSpec+            let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec]+                domain = generatedTextEndingIn "Domain.hs" modules+            domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\""+            scaffoldRefusals spec `shouldBe` []+            bare <- parseInlineSpec "<bare-text-initial>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)+            scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted")+            unsupported <- parseInlineSpec "<unsupported-field>" (T.replace "count:Int" "count:Time" loweringAggregateSpec)+            scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable")+        it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do+            windowSeconds "90s" `shouldBe` Right 90+            windowSeconds "5m" `shouldBe` Right 300+            windowSeconds "2h" `shouldBe` Right 7200+            emitSource <- readTestText "test/fixtures/emit.keiro"+            let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource+            exponential <- parseInlineSpec "<exponential-backoff>" exponentialSource+            case [publisher | NPublisher publisher <- specNodes exponential] of+                publisher : _ -> do+                    let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher)+                    generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }"+                    parseSpec "<exponential-round-trip>" (renderSpec exponential) `shouldBe` Right exponential+                [] -> expectationFailure "emit fixture has no publisher"+            constant <- parseInlineSpec "<constant-backoff>" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource)+            case [publisher | NPublisher publisher <- specNodes constant] of+                publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120"+                [] -> expectationFailure "emit fixture has no publisher"+        it "refuses incomplete exponential backoff and rejects unknown window units" $ do+            emitSource <- readTestText "test/fixtures/emit.keiro"+            incomplete <- parseInlineSpec "<incomplete-backoff>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)+            scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete")+            parseSpec "<bad-window>" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource)+                `shouldSatisfy` leftContains "time unit: s, m, or h"+        it "lowers workqueue retry windows in minutes to seconds" $ do+            queueSource <- readTestText "test/fixtures/reservation-work.keiro"+            queueSpec <- parseInlineSpec "<minute-queue>" (T.replace "5s" "5m" queueSource)+            case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of+                workqueue : _ -> do+                    let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue)+                    policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300"+                    policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)"+                [] -> expectationFailure "queue fixture has no workqueue"+        it "uses exact status-map keys and emits total Int harness samples" $ do+            statusSpec <- parseInlineSpec "<exact-status>" exactStatusSpec+            case [aggregate | NAggregate aggregate <- specNodes statusSpec] of+                aggregate : _ -> do+                    let ctx = defaultContext (specContext statusSpec)+                        projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate)+                        harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate)+                    projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\""+                    harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0"+                    harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported"+                [] -> expectationFailure "exact-status spec has no aggregate"++    describe "scaffold" $ do+        it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do+            mods <- scaffoldFixture "test/fixtures/reservation.keiro"+            firewallBreaches mods `shouldBe` []+        it "marks the Holes module HoleStub and the rest Generated" $ do+            mods <- scaffoldFixture "test/fixtures/reservation.keiro"+            let holes = [m | m <- mods, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)]+            map kind holes `shouldBe` [HoleStub]+            -- Domain, Codec, EventStream, Projection, Harness.+            length [m | m <- mods, kind m == Generated] `shouldBe` 5+        it "is deterministic (re-scaffolding yields byte-identical text)" $ do+            a <- scaffoldFixture "test/fixtures/reservation.keiro"+            b <- scaffoldFixture "test/fixtures/reservation.keiro"+            map moduleText a `shouldBe` map moduleText b+        it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do+            mods <- scaffoldFixture "test/fixtures/reservation.keiro"+            mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated]+        it "matches every committed new-surface Generated module (modulo formatting)" $ do+            spec <- specOf "test/fixtures/transfer-routing.keiro"+            let modules = scaffoldModules (defaultContext (specContext spec)) spec+            forM_ [m | m <- modules, kind m == Generated] $ \m -> do+                committed <- readTestText ("test/conformance-newsurface/" <> modulePath m)+                normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)+        it "scaffolds the register-free OrderStream smoke target without error" $ do+            mods <- scaffoldFixture "test/fixtures/order.keiro"+            -- 5 Generated (Domain/Codec/EventStream/Projection/Harness) + 1 Holes.+            length mods `shouldBe` 6+            firewallBreaches mods `shouldBe` []++syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule+syntheticGenerated path contents =+    ScaffoldModule{modulePath = path, moduleText = contents, kind = Generated, origin = "test"}++generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text+generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of+    contents : _ -> contents+    [] -> ""++loweringAggregateSpec :: T.Text+loweringAggregateSpec =+    T.unlines+        [ "context samples"+        , ""+        , "aggregate Counter"+        , "  regs"+        , "    note Text = \"hello world\""+        , "    count Int = 0"+        , "    state CounterVertex = Pending"+        , "  states Pending Done!"+        , "  command Bump { count:Int }"+        , "  event CountBumped { count:Int }"+        , "  Pending -- Bump --> emit CountBumped ; goto Done"+        ]++exactStatusSpec :: T.Text+exactStatusSpec =+    T.unlines+        [ "context samples"+        , ""+        , "aggregate Reservation"+        , "  regs"+        , "    state ReservationVertex = Open"+        , "  states Open Closed!"+        , "  command Bump { count:Int }"+        , "  event ReservationHeld { count:Int }"+        , "  event ReservationUnHeld { count:Int }"+        , "  event CountBumped { count:Int }"+        , "  Open -- Bump --> emit CountBumped ; goto Closed"+        , "  projection reservation_status consistency=Eventual key=count"+        , "    status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }"+        ]++hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool+hasPathCollisionWithTwoOrigins = \case+    Left refusals -> any hasTwo refusals+    Right _ -> False+  where+    hasTwo (PathCollision _ origins) = length origins == 2+    hasTwo _ = False++isMissingBannerRefusal :: Either [Refusal] a -> Bool+isMissingBannerRefusal = \case+    Left [MissingGeneratedBanner paths] -> not (null paths)+    _ -> False++isSuccessfulScaffold :: Either [Refusal] a -> Bool+isSuccessfulScaffold = \case+    Right _ -> True+    Left _ -> False++executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport+executePlannedScaffold out specPath ctx spec = case planScaffold ctx spec of+    Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable"+    Right modules -> do+        result <- executeScaffold out False specPath ctx spec modules+        case result of+            Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable"+            Right report -> pure report++renameCounter :: Node -> Node+renameCounter (NAggregate aggregate) =+    NAggregate+        aggregate+            { aggName = "Widget"+            , aggRegs = [reg{regType = if regType reg == "CounterVertex" then "WidgetVertex" else regType reg} | reg <- aggRegs aggregate]+            }+renameCounter node = node++onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath+onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of+    [path] -> path+    paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths)++withTempDirectory :: String -> (FilePath -> IO a) -> IO a+withTempDirectory template = bracket acquire removePathForcibly+  where+    acquire = do+        base <- getTemporaryDirectory+        (path, handle) <- openTempFile base template+        hClose handle+        removeFile path+        createDirectory path+        pure path++{- | Parse a fixture and return the validator's diagnostic codes (failing the+test on a parse error).+-}+diagnosticCodesOf :: FilePath -> IO [DiagnosticCode]+diagnosticCodesOf path = do+    input <- readTestText path+    case parseSpec path input of+        Left err -> expectationFailure (T.unpack err) >> pure []+        Right spec -> pure (map code (validateSpec spec))++{- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g.+the benign-inversion notices, are excluded).+-}+errorCodesOf :: FilePath -> IO [DiagnosticCode]+errorCodesOf path = do+    input <- readTestText path+    case parseSpec path input of+        Left err -> expectationFailure (T.unpack err) >> pure []+        Right spec -> pure [code d | d <- validateSpec spec, severity d == Error]++-- | Parse two fixtures and diff them (old, new).+diffFixtures :: FilePath -> FilePath -> IO [Change]+diffFixtures oldP newP = do+    old <- readTestText oldP+    new <- readTestText newP+    case (,) <$> parseSpec oldP old <*> parseSpec newP new of+        Left err -> expectationFailure (T.unpack err) >> pure []+        Right (o, n) -> pure (diffSpecs o n)++modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec+modifyReadModel target update spec =+    spec+        { specNodes =+            [ case node of+                NReadModel readModel | rmName readModel == target -> NReadModel (update readModel)+                _ -> node+            | node <- specNodes spec+            ]+        }++removeReadModel :: Name -> Spec -> Spec+removeReadModel target spec =+    spec{specNodes = [node | node <- specNodes spec, not (isTarget node)]}+  where+    isTarget (NReadModel readModel) = rmName readModel == target+    isTarget _ = False++modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec+modifyRouter target update spec =+    spec+        { specNodes =+            [ case node of+                NRouter router | rtId router == target -> NRouter (update router)+                _ -> node+            | node <- specNodes spec+            ]+        }++routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode]+routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update++modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec+modifyProcess target update spec =+    spec+        { specNodes =+            [ case node of+                NProcess process | procId process == target -> NProcess (update process)+                _ -> node+            | node <- specNodes spec+            ]+        }++processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode]+processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update++errorCodes :: Spec -> [DiagnosticCode]+errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error]++changeReadModelShape :: ReadModelNode -> ReadModelNode+changeReadModelShape readModel =+    readModel+        { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False]+        , rmShape = "fnv1a:0000000000000000"+        }++{- | Assert a @new \<kind\>@ skeleton parses and validates with zero+error-severity diagnostics.+-}+assertSkeletonValid :: T.Text -> IO ()+assertSkeletonValid kind = case skeletonFor kind of+    Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))+    Right src -> case parseSpec ("new:" <> T.unpack kind) src of+        Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr))+        Right spec ->+            [code d | d <- validateSpec spec, severity d == Error]+                `shouldBe` ([] :: [DiagnosticCode])++assertSkeletonScaffoldable :: T.Text -> IO ()+assertSkeletonScaffoldable kind = case skeletonFor kind of+    Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))+    Right src -> case parseSpec ("new:" <> T.unpack kind) src of+        Left perr -> expectationFailure (T.unpack perr)+        Right spec -> planScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold++skeletonModuleRoots :: [(T.Text, T.Text)]+skeletonModuleRoots =+    [ ("aggregate", "SkelAggregate")+    , ("process", "SkelProcess")+    , ("router", "SkelRouter")+    , ("contract", "SkelContract")+    , ("intake", "SkelIntake")+    , ("emit", "SkelEmit")+    , ("workqueue", "SkelQueue")+    , ("workflow", "SkelWorkflow")+    ]++assertSkeletonMatchesCommitted :: T.Text -> T.Text -> IO ()+assertSkeletonMatchesCommitted kind root = case skeletonFor kind of+    Left err -> expectationFailure (T.unpack err)+    Right source -> case parseSpec ("new:" <> T.unpack kind) source of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> do+            let ctx = (defaultContext (specContext spec)){moduleRoot = root}+            forM_ [m | m <- scaffoldModules ctx spec, kindOf m == Generated] $ \m -> do+                committed <- readTestText ("test/conformance-skeletons/" <> modulePath m)+                normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)+  where+    kindOf = Keiro.Dsl.Scaffold.kind++-- | Parse a fixture into a 'Spec', failing the test on a parse error.+specOf :: FilePath -> IO Spec+specOf path = do+    input <- readTestText path+    case parseSpec path input of+        Left err -> expectationFailure (T.unpack err) >> error "unreachable"+        Right spec -> pure spec++-- | Parse a fixture and scaffold every aggregate in it.+scaffoldFixture :: FilePath -> IO [ScaffoldModule]+scaffoldFixture path = do+    input <- readTestText path+    case parseSpec path input of+        Left err -> expectationFailure (T.unpack err) >> pure []+        Right spec ->+            pure $+                concat+                    [ scaffoldAggregate (ctx spec) spec agg <> harnessFor (ctx spec) spec agg+                    | NAggregate agg <- specNodes spec+                    ]+  where+    ctx spec = defaultContext (specContext spec)++scaffoldProcessFixture :: FilePath -> IO [ScaffoldModule]+scaffoldProcessFixture path = do+    input <- readTestText path+    case parseSpec path input of+        Left err -> expectationFailure (T.unpack err) >> pure []+        Right spec ->+            pure $ concat [scaffoldProcess (ctx spec) p | NProcess p <- specNodes spec]+  where+    ctx spec = defaultContext (specContext spec)++{- | Assert a freshly-scaffolded Generated module matches its committed copy+under test/conformance/ (whitespace-normalized). The committed copies are the+ones the keiro-dsl-conformance suite compiles, so this pins the live scaffolder+to known-compiling output.+-}+assertMatchesCommitted :: ScaffoldModule -> IO ()+assertMatchesCommitted m = do+    let committedPath = "test/conformance/" <> modulePath m+    committed <- readTestText committedPath+    normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)++normalizeGenerated :: T.Text -> (T.Text, [T.Text])+normalizeGenerated text =+    let (imports, body) = partition isImport (T.lines text)+     in (normalizeBody body, sort (map normalizeImport imports))+  where+    -- Compare the deterministic body exactly as before and imports as a sorted,+    -- whitespace-normalized list. Sorting tolerates formatter reordering while+    -- additions, removals, and renamed imports now fail the pin.+    normalizeBody =+        T.replace " , )" " )"+            . T.unwords+            . T.words+            . T.replace "}" " } "+            . T.replace "{" " { "+            . T.replace "]" " ] "+            . T.replace "[" " [ "+            . T.replace "," " , "+            . T.unlines+    normalizeImport line =+        let reordered = case T.words line of+                "import" : "qualified" : moduleName : rest -> T.unwords ("import" : moduleName : "qualified" : rest)+                wordsInImport -> T.unwords wordsInImport+            (prefix, explicit) = T.breakOn " (" reordered+         in if T.null explicit+                then prefix+                else+                    let members =+                            sort+                                . map (T.unwords . T.words)+                                . T.splitOn ","+                                . T.dropEnd 1+                                $ T.drop 2 explicit+                     in prefix <> " (" <> T.intercalate "," members <> ")"+    isImport line = case T.words line of+        "import" : _ -> True+        _ -> False++{- | Locate and read a test fixture or committed conformance source regardless+of whether the suite was launched from the package directory or repo root.+-}+readTestText :: FilePath -> IO T.Text+readTestText path = resolveTestPath path >>= TIO.readFile++-- | Locate a repo file regardless of the test process's current directory.+resolveTestPath :: FilePath -> IO FilePath+resolveTestPath rel = do+    override <- lookupEnv "KEIRO_DSL_TEST_ROOT"+    let candidates = [rel, "keiro-dsl" </> rel] <> maybe [] (\root -> [root </> rel]) override+    existing <- filterM doesFileExist candidates+    case existing of+        path : _ -> pure path+        [] ->+            fail $+                "unable to locate keiro-dsl test file "+                    <> show rel+                    <> "; tried "+                    <> show candidates++leftContains :: T.Text -> Either T.Text a -> Bool+leftContains needle = \case+    Left err -> needle `T.isInfixOf` err+    Right _ -> False++parseInlineSpec :: FilePath -> T.Text -> IO Spec+parseInlineSpec sourceName src = case parseSpec sourceName src of+    Left err -> expectationFailure (T.unpack err) >> error "unreachable"+    Right spec -> pure spec++statusMapSpec :: T.Text -> T.Text+statusMapSpec marker =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  event Created { }"+        , "  event Changed { }"+        , ""+        , "  projection things consistency=Eventual key=thingId"+        , "    status-map" <> marker <> " { Created=>held }"+        ]++parseErrorOf :: FilePath -> T.Text -> IO T.Text+parseErrorOf sourceName src = case parseSpec sourceName src of+    Left err -> pure err+    Right _ -> expectationFailure ("expected parse failure for " <> sourceName) >> error "unreachable"++duplicateGotoSpec :: T.Text+duplicateGotoSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states A B C"+        , ""+        , "  command Go { }"+        , "  A -- Go -->"+        , "    goto B"+        , "    goto C"+        ]++missingGotoSpec :: T.Text+missingGotoSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states A B"+        , ""+        , "  command Go { }"+        , "  A -- Go -->"+        , "    emit Changed"+        ]++duplicateWireSpec :: T.Text+duplicateWireSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  wire kind=ctorName fields=camelCase schemaVersion=1"+        , "  wire kind=typeName fields=snakeCase schemaVersion=2"+        ]++duplicateProjectionSpec :: T.Text+duplicateProjectionSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  projection first consistency=Strong key=thingId"+        , "    status-map partial { }"+        , "  projection second consistency=Eventual key=thingId"+        ]++projectionWithoutConsistencySpec :: T.Text+projectionWithoutConsistencySpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  projection things key=thingId"+        ]++malformedRegisterSpec :: T.Text+malformedRegisterSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "    status Status"+        , "  states Open"+        ]++misplacedDispatchIdSpec :: T.Text+misplacedDispatchIdSpec =+    T.replace+        "    schedule timer\n\n  dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n"+        "    dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n    schedule timer\n"+        (renderSpec (Spec "svc" Nothing Nothing [] [] [] [NProcess (processWithLiteral "literal")]))++lineNumberContaining :: T.Text -> T.Text -> Int+lineNumberContaining needle = go 1 . T.lines+  where+    go current = \case+        [] -> current+        lineText : rest+            | needle `T.isInfixOf` lineText -> current+            | otherwise -> go (current + 1) rest++decimalOverflow :: T.Text+decimalOverflow = "18446744073709551617"++decimalOverflowSpecs :: [(String, T.Text)]+decimalOverflowSpecs =+    [ ("event-version", eventVersionDecimalSpec decimalOverflow)+    , ("wire-schema", wireDecimalSpec decimalOverflow)+    , ("contract-schema", contractDecimalSpec decimalOverflow)+    , ("decode-schema", decodeDecimalSpec decimalOverflow)+    , ("publisher-attempts", publisherDecimalSpec decimalOverflow)+    , ("workqueue-retries", workqueueDecimalSpec decimalOverflow)+    , ("timer-attempts", timerDecimalSpec decimalOverflow)+    ]++eventVersionDecimalSpec :: T.Text -> T.Text+eventVersionDecimalSpec value =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  event Changed v" <> value <> " { }"+        ]++wireDecimalSpec :: T.Text -> T.Text+wireDecimalSpec value =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  wire kind=ctorName fields=camelCase schemaVersion=" <> value+        ]++contractDecimalSpec :: T.Text -> T.Text+contractDecimalSpec value =+    T.unlines+        [ "context svc"+        , ""+        , "contract Contract {"+        , "  schemaVersion " <> value+        , "  discriminator kind"+        , "}"+        ]++decodeDecimalSpec :: T.Text -> T.Text+decodeDecimalSpec value =+    T.unlines+        [ "context svc"+        , ""+        , "intake Inbox {"+        , "  contract Contract"+        , "  topic events"+        , "  accept Event"+        , "  dedupe key messageId policy PreferIntegrationMessageId"+        , "  decode { envelope strict-required lenient-optional body strict schemaVersion == " <> value <> " }"+        , "  disposition { }"+        , "}"+        ]++publisherDecimalSpec :: T.Text -> T.Text+publisherDecimalSpec value =+    T.unlines+        [ "context svc"+        , ""+        , "publisher Publisher {"+        , "  emit Emit"+        , "  ordering PerKeyHeadOfLine"+        , "  maxAttempts " <> value+        , "  backoff constant 2s"+        , "  outboxId stable from messageId"+        , "}"+        ]++workqueueDecimalSpec :: T.Text -> T.Text+workqueueDecimalSpec value =+    T.unlines+        [ "context svc"+        , ""+        , "workqueue Queue {"+        , "  queue logical = \"queue\""+        , "  derive physical = \"queue\""+        , "    dlq = \"queue_dlq\""+        , "    table = \"pgmq.q_queue\""+        , "  payload Job { }"+        , "  retry maxRetries = " <> value <> " delay = 5s dlq = on"+        , "  disposition { }"+        , "}"+        ]++timerDecimalSpec :: T.Text -> T.Text+timerDecimalSpec value =+    T.replace+        "max-attempts 5"+        ("max-attempts " <> value)+        (renderSpec (Spec "svc" Nothing Nothing [] [] [] [NProcess (processWithLiteral "literal")]))++identifierHygieneSpec :: T.Text+identifierHygieneSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate thing"+        , "  regs"+        , "  states Open"+        , ""+        , "  command DoIt { data }"+        ]++vertexCollisionSpec :: T.Text+vertexCollisionSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Reservation"+        , "  regs"+        , "  states Created"+        , ""+        , "  event ReservationCreated { }"+        ]++underscoreNodeSpec :: T.Text+underscoreNodeSpec =+    T.unlines+        [ "context svc"+        , ""+        , "contract _contract {"+        , "  schemaVersion 1"+        , "  discriminator kind"+        , "}"+        ]++unicodeIdentifierSpec :: T.Text+unicodeIdentifierSpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate Résumé"+        , "  regs"+        , "  states Open"+        ]++emptyStatesSpec :: Spec+emptyStatesSpec =+    Spec+        "svc"+        Nothing+        Nothing+        []+        []+        []+        [NAggregate (Aggregate "Thing" [] [] [] [] [] Nothing Nothing Nothing noLoc)]++crossFamilyBoundarySpec :: T.Text+crossFamilyBoundarySpec =+    T.unlines+        [ "context svc"+        , ""+        , "aggregate First"+        , "  regs"+        , "  states A B"+        , "  command Go { }"+        , "  A -- Go -->"+        , "    emit Changed"+        , "    goto B"+        , ""+        , "emit Output {"+        , "  contract Contract"+        , "  topic events"+        , "  source \"source\""+        , "  key thingId"+        , "  map status { _ => skip }"+        , "  messageId derive hole"+        , "  idempotencyKey derive hole"+        , "}"+        , ""+        , "aggregate Second"+        , "  regs"+        , "  states"+        , ""+        , "dispatch QueueDispatch {"+        , "  source readModel = source key = thingId"+        , "  fanout body = resolveFanout"+        , "  dedup key = thingId"+        , "    seenIn readModel = seen field = thingId"+        , "    seenIn queue = workQueue field = thingId"+        , "  enqueue to = workQueue"+        , "}"+        ]++--------------------------------------------------------------------------------+-- Generators (bounded; restricted to valid, non-reserved identifiers)+--------------------------------------------------------------------------------++{- | Text that exercises every supported escape plus notation punctuation that+used to be able to split one emit-map row into several rows.+-}+genAdversarialText :: Gen T.Text+genAdversarialText =+    T.concat+        <$> resize+            20+            (listOf (elements ["a", "Z", "\"", "\\", "\n", "\t", "\r", "=>", "#", "{", "}", " "]))++{- | One spec carrying the same adversarial value through three distinct+printer paths: a contract topic, an emit-map value, and a quote-wrapped+field-binding literal.+-}+escapedSpec :: T.Text -> Spec+escapedSpec value =+    Spec+        "escape"+        Nothing+        Nothing+        []+        []+        []+        [ NContract+            ContractNode+                { ctrName = "Contract"+                , ctrSchemaVersion = 1+                , ctrDiscriminator = "kind"+                , ctrTopics = [("events", value)]+                , ctrEvents = []+                , ctrLoc = noLoc+                }+        , NEmit+            EmitNode+                { emName = "Emit"+                , emContract = "Contract"+                , emTopic = "events"+                , emSource = "source"+                , emKey = "key"+                , emDiscriminant = "status"+                , emMap = [EmitMapRow value "Event" noLoc]+                , emSkip = True+                , emMessageId = DeriveSpec Nothing+                , emIdempotencyKey = DeriveSpec Nothing+                , emLoc = noLoc+                }+        , NProcess (processWithLiteral value)+        ]++processWithLiteral :: T.Text -> ProcessNode+processWithLiteral value =+    ProcessNode+        { procId = "Process"+        , procName = "process"+        , procInput = InputDecl "Input" []+        , procCorrelate = CorrelateDecl "key" "idText"+        , procSaga = SagaRef "Saga" "saga"+        , procTarget = "Target"+        , procProjections = []+        , procHandle =+            HandleNode+                { hOn = "Input"+                , hAdvance = AdvanceNode "Advance" [FieldBinding "literal" (Just ("\"" <> value <> "\""))]+                , hDispatch = []+                , hSchedule = "timer"+                }+        , procRejected = PolHalt+        , procPoison = PolHalt+        , procTimer =+            TimerNode+                { tmName = "timer"+                , tmId = IdExpr UuidV5Id "timer:"+                , tmFireAt = FireAtExpr "observedAt" "5m"+                , tmPayload = []+                , tmFire =+                    FireNode+                        { fireTarget = "Target"+                        , fireKey = "correlationId"+                        , fireCommand = "Fire"+                        , fireFields = []+                        , fireFiredEventId = IdExpr UuidV5Id "fired:"+                        , fireDisposition = FireDisposition OFired OFired ORetry ORetry ORetry+                        }+                , tmDecodeUnknown = "Cancelled"+                , tmMaxAttempts = 5+                , tmDeadLetter = "exhausted"+                , tmLoc = noLoc+                }+        , procLoc = noLoc+        }++genName :: Gen Name+genName =+    frequency+        [+            ( 3+            , do+                base <- elements ["Aa", "Bb", "Cc", "Dd", "St", "Cmd", "Ev", "Reg", "Fld", "Foo", "Bar", "Qux"]+                n <- choose (0, 9 :: Int)+                pure (T.pack (base <> show n))+            )+        , (1, elements ["data1", "typeA", "whereX", "gotoX", "guardY", "emitZ", "_lead"])+        ]++genWire :: Gen T.Text+genWire = do+    base <- elements ["red", "blue", "green", "ctorName", "camelCase", "rsv", "hosp", "held", "partial-divert", "1st"]+    n <- choose (0, 9 :: Int)+    pure (T.pack (base <> show n))++genWireWord :: Gen T.Text+genWireWord = genWire++smallList :: Gen a -> Gen [a]+smallList g = choose (0, 3 :: Int) >>= \n -> vectorOf n g++nonEmptyList :: Gen a -> Gen [a]+nonEmptyList g = choose (1, 3 :: Int) >>= \n -> vectorOf n g++genMaybe :: Gen a -> Gen (Maybe a)+genMaybe g = oneof [pure Nothing, Just <$> g]++genCmp :: Gen CmpOp+genCmp = elements [OpEq, OpNeq, OpLt, OpLe, OpGt, OpGe]++genAtom :: Gen Expr+genAtom = EAtom <$> oneof [AName <$> genName, ABool <$> arbitrary]++genExpr :: Gen Expr+genExpr = go (3 :: Int)+  where+    go 0 = genAtom+    go d =+        oneof+            [ genAtom+            , EOr <$> go (d - 1) <*> go (d - 1)+            , EAnd <$> go (d - 1) <*> go (d - 1)+            , ECmp <$> genCmp <*> go (d - 1) <*> go (d - 1)+            ]++genField :: Gen Field+genField = Field <$> genName <*> oneof [pure Nothing, Just <$> genName]++genReg :: Gen RegDecl+genReg = RegDecl <$> genName <*> genName <*> genRegInitial <*> pure noLoc++genRegInitial :: Gen RegInitial+genRegInitial = oneof [RegInitBare <$> genName, RegInitText <$> genAdversarialText]++genState :: Gen StateDecl+genState = StateDecl <$> genName <*> arbitrary <*> pure noLoc++genCommand :: Gen Command+genCommand = Command <$> genName <*> smallList genField <*> pure noLoc++genEvent :: Gen Event+genEvent =+    Event+        <$> genName+        <*> body+        <*> choose (1, 3)+        <*> genMaybe ((,) <$> choose (0, 3) <*> pure Hole)+        <*> arbitrary+        <*> pure noLoc+  where+    body = oneof [EventFromCommand <$> genName, EventFields <$> smallList genField]++genTransition :: Gen Transition+genTransition =+    Transition+        <$> genName+        <*> genName+        <*> genMaybe genExpr+        <*> smallList ((,) <$> genName <*> genExpr)+        <*> smallList genName+        <*> genName+        <*> pure noLoc++genWireSpec :: Gen WireSpec+genWireSpec = WireSpec <$> genWire <*> genWire <*> (getNonNegative <$> arbitrary)++genProjection :: Gen ProjectionSpec+genProjection =+    ProjectionSpec+        <$> genName+        <*> genMaybe (elements [Strong, Eventual])+        <*> genName+        <*> genMaybe (Mapping <$> smallList ((,) <$> genName <*> genWire) <*> arbitrary)+        <*> pure noLoc++genAggregate :: Gen Aggregate+genAggregate =+    Aggregate+        <$> genName+        <*> smallList genReg+        <*> smallList genState+        <*> smallList genCommand+        <*> smallList genEvent+        <*> smallList genTransition+        <*> genMaybe genWireSpec+        <*> genMaybe genProjection+        <*> genMaybe (SnapshotSpec <$> oneof [SnapEvery <$> choose (0, 5), pure SnapOnTerminal] <*> choose (0, 5) <*> genAdversarialText <*> pure noLoc)+        <*> pure noLoc++genDottedRef :: Gen T.Text+genDottedRef = elements ["input.id", "input.hospitalId", "timer.id", "correlationId", "payload.messageId"]++genWindow :: Gen T.Text+genWindow = elements ["0s", "5s", "2m", "1h"]++genFieldBinding :: Gen FieldBinding+genFieldBinding =+    FieldBinding+        <$> genName+        <*> oneof+            [ pure Nothing+            , Just <$> genDottedRef+            , Just . (\raw -> "\"" <> raw <> "\"") <$> genAdversarialText+            ]++genDispatchDisposition :: Gen DispatchDisposition+genDispatchDisposition = DispatchDisposition <$> genDisp <*> genDisp <*> genDisp+  where+    genDisp = oneof [pure DAckOk, pure DRetry, DDeadLetter <$> genAdversarialText]++genDispatchNode :: Gen DispatchNode+genDispatchNode =+    DispatchNode+        <$> genName+        <*> genDottedRef+        <*> genName+        <*> smallList genFieldBinding+        <*> genDispatchDisposition+        <*> pure noLoc++genFireDisposition :: Gen FireDisposition+genFireDisposition =+    FireDisposition+        <$> elements [OFired, ORetry]+        <*> elements [OFired, ORetry]+        <*> elements [OFired, ORetry]+        <*> elements [OFired, ORetry]+        <*> elements [OFired, ORetry]++genIdExpr :: Gen IdExpr+genIdExpr = IdExpr UuidV5Id <$> genAdversarialText++genFireNode :: Gen FireNode+genFireNode =+    FireNode+        <$> genName+        <*> genDottedRef+        <*> genName+        <*> smallList genFieldBinding+        <*> genIdExpr+        <*> genFireDisposition++genTimerNode :: Gen TimerNode+genTimerNode =+    TimerNode+        <$> genName+        <*> genIdExpr+        <*> (FireAtExpr <$> genName <*> genWindow)+        <*> smallList genFieldBinding+        <*> genFireNode+        <*> genName+        <*> choose (0, 5)+        <*> genAdversarialText+        <*> pure noLoc++genProcess :: Gen ProcessNode+genProcess =+    ProcessNode+        <$> genName+        <*> genAdversarialText+        <*> (InputDecl <$> genName <*> smallList genField)+        <*> (CorrelateDecl <$> genName <*> genName)+        <*> (SagaRef <$> genName <*> genAdversarialText)+        <*> genName+        <*> smallList genName+        <*> (HandleNode <$> genName <*> (AdvanceNode <$> genName <*> smallList genFieldBinding) <*> smallList genDispatchNode <*> genName)+        <*> elements [PolHalt, PolDeadLetter, PolSkip]+        <*> elements [PolHalt, PolDeadLetter, PolSkip]+        <*> genTimerNode+        <*> pure noLoc++genResolveSource :: Gen ResolveSource+genResolveSource = oneof [ResolveReadModel <$> genName, pure ResolveHole]++genRouter :: Gen RouterNode+genRouter =+    RouterNode+        <$> genName+        <*> genAdversarialText+        <*> (InputDecl <$> genName <*> smallList genField)+        <*> (CorrelateDecl <$> genName <*> genName)+        <*> (ResolveDecl <$> genResolveSource <*> smallList genName <*> pure noLoc)+        <*> genName+        <*> smallList genName+        <*> (RouterDispatchNode <$> genName <*> smallList genFieldBinding <*> genDispatchDisposition <*> pure noLoc)+        <*> elements [PolHalt, PolDeadLetter, PolSkip]+        <*> elements [PolHalt, PolDeadLetter, PolSkip]+        <*> pure noLoc++genContractField :: Gen ContractField+genContractField = ContractField <$> genName <*> oneof [CTypeId <$> genAdversarialText, pure CText, pure CInt]++genContractEvent :: Gen ContractEvent+genContractEvent = ContractEvent <$> genName <*> genName <*> smallList genContractField++genContract :: Gen ContractNode+genContract =+    ContractNode+        <$> genName+        <*> choose (0, 5)+        <*> genName+        <*> smallList ((,) <$> genName <*> genAdversarialText)+        <*> smallList genContractEvent+        <*> pure noLoc++genWireSource :: Gen WireSource+genWireSource = oneof [SrcHeader <$> genAdversarialText, pure SrcBody, pure SrcKafkaKey, pure SrcKafkaCursor]++genInboxAction :: Gen InboxAction+genInboxAction = oneof [pure IAckOk, IRetry <$> genWindow, IDeadLetter <$> genMaybe genAdversarialText]++genDispositionRow :: Gen DispositionRow+genDispositionRow = DispositionRow <$> genName <*> genInboxAction <*> pure noLoc++genDecodeSpec :: Gen DecodeSpec+genDecodeSpec =+    DecodeSpec+        <$> ((\first second -> first <> " " <> second) <$> genWireWord <*> genWireWord)+        <*> arbitrary+        <*> choose (0, 5)++genIntake :: Gen IntakeNode+genIntake =+    IntakeNode+        <$> genName+        <*> genName+        <*> genName+        <*> nonEmptyList genName+        <*> smallList (BindRow <$> genName <*> genWireSource <*> arbitrary <*> arbitrary)+        <*> genName+        <*> genName+        <*> elements [InkPersistFull, InkPersistDedupeOnly]+        <*> genDecodeSpec+        <*> smallList genDispositionRow+        <*> pure noLoc++genDeriveSpec :: Gen DeriveSpec+genDeriveSpec = DeriveSpec <$> genMaybe genAdversarialText++genEmit :: Gen EmitNode+genEmit =+    EmitNode+        <$> genName+        <*> genName+        <*> genName+        <*> genAdversarialText+        <*> genName+        <*> genName+        <*> smallList (EmitMapRow <$> genAdversarialText <*> genName <*> pure noLoc)+        <*> arbitrary+        <*> genDeriveSpec+        <*> genDeriveSpec+        <*> pure noLoc++genPublisher :: Gen PublisherNode+genPublisher =+    PublisherNode+        <$> genName+        <*> genName+        <*> genName+        <*> choose (0, 5)+        <*> (BackoffSpec <$> genName <*> genWindow <*> genMaybe genWindow <*> genMaybe (elements ["1.0", "2.0", "3"]))+        <*> genName+        <*> pure noLoc++genWqField :: Gen WqField+genWqField = WqField <$> genName <*> genAdversarialText <*> genName <*> arbitrary++genWqDispRow :: Gen WqDispRow+genWqDispRow = WqDispRow <$> genName <*> genInboxAction <*> pure noLoc++genWorkqueue :: Gen WorkqueueNode+genWorkqueue =+    WorkqueueNode+        <$> genName+        <*> genAdversarialText+        <*> genAdversarialText+        <*> genAdversarialText+        <*> genAdversarialText+        <*> elements [WqUnordered, WqFifoThroughput, WqFifoRoundRobin]+        <*> genMaybe (WqGroupKey <$> genName <*> genName <*> genMaybe genAdversarialText)+        <*> oneof [pure WqStandard, pure WqUnlogged, WqPartitioned <$> genAdversarialText <*> genAdversarialText]+        <*> genName+        <*> smallList genWqField+        <*> choose (0, 5)+        <*> genWindow+        <*> arbitrary+        <*> smallList genWqDispRow+        <*> pure noLoc++genReadModel :: Gen ReadModelNode+genReadModel =+    ReadModelNode+        <$> genName+        <*> genAdversarialText+        <*> genAdversarialText+        <*> smallList (RmColumn <$> genWireWord <*> genName <*> arbitrary)+        <*> choose (0, 5)+        <*> genAdversarialText+        <*> elements [Strong, Eventual]+        <*> genMaybe (oneof [pure RmEntireLog, RmCategory <$> genAdversarialText])+        <*> elements [RmInline, RmSubscription]+        <*> genMaybe genAdversarialText+        <*> pure noLoc++genPgmqDispatch :: Gen PgmqDispatchNode+genPgmqDispatch =+    PgmqDispatchNode+        <$> genName+        <*> genName+        <*> genName+        <*> genName+        <*> genName+        <*> genName+        <*> genName+        <*> genName+        <*> genName+        <*> genName+        <*> pure noLoc++genWfBodyItem :: Gen WfBodyItem+genWfBodyItem = sized go+  where+    go size =+        oneof $+            [ WfStep <$> genWireWord <*> genName <*> pure noLoc+            , WfAwait <$> genWireWord <*> genName <*> pure noLoc+            , WfSleep <$> genWireWord <*> genName <*> pure noLoc+            , WfChild <$> genWireWord <*> genName <*> genName <*> pure noLoc+            , WfContinueAsNew <$> genName <*> pure noLoc+            ]+                ++ [ WfPatch <$> genWireWord <*> resize (size `div` 2) (smallList genWfBodyItem) <*> pure noLoc+                   | size > 0+                   ]++genWorkflow :: Gen WorkflowNode+genWorkflow =+    WorkflowNode+        <$> genName+        <*> genAdversarialText+        <*> genName+        <*> smallList genField+        <*> genName+        <*> genMaybe genName+        <*> genName+        <*> smallList genWfBodyItem+        <*> pure noLoc++genOperationShape :: Gen OperationShape+genOperationShape =+    oneof+        [ CommandOp <$> genName <*> genName <*> genName <*> smallList genName+        , QueryOp <$> genName <*> genName <*> ((\parts -> T.unwords parts) <$> nonEmptyList genName) <*> genName+        , SignalOp <$> genWireWord <*> genName <*> genName <*> genName <*> genName+        , RunOp <$> genName <*> genName <*> genName+        ]++genOperation :: Gen OperationNode+genOperation = OperationNode <$> genName <*> genOperationShape <*> pure noLoc++allNodeTags :: [String]+allNodeTags = ["aggregate", "process", "router", "contract", "intake", "emit", "publisher", "workqueue", "pgmq-dispatch", "readmodel", "workflow", "operation"]++nodeTag :: Node -> String+nodeTag = \case+    NAggregate _ -> "aggregate"+    NProcess _ -> "process"+    NRouter _ -> "router"+    NContract _ -> "contract"+    NIntake _ -> "intake"+    NEmit _ -> "emit"+    NPublisher _ -> "publisher"+    NWorkqueue _ -> "workqueue"+    NPgmqDispatch _ -> "pgmq-dispatch"+    NReadModel _ -> "readmodel"+    NWorkflow _ -> "workflow"+    NOperation _ -> "operation"++genId :: Gen IdDecl+genId = IdDecl <$> genName <*> genWire <*> pure noLoc++genEnum :: Gen EnumDecl+genEnum = EnumDecl <$> genName <*> smallList ((,) <$> genName <*> genWire) <*> pure noLoc++genRule :: Gen RuleDecl+genRule =+    RuleDecl+        <$> genName+        <*> genName+        <*> genName+        <*> nonEmptyList ((,) <$> genName <*> genExpr)+        <*> pure noLoc++genSpec :: Gen Spec+genSpec =+    Spec+        <$> genWire+        <*> genMaybe genModuleRoot+        <*> genMaybe (elements [GeneratedPrefix, CollocatedLeaf])+        <*> smallList genId+        <*> smallList genEnum+        <*> smallList genRule+        <*> smallList genNode+  where+    genNode =+        oneof+            [ NAggregate <$> genAggregate+            , NProcess <$> genProcess+            , NRouter <$> genRouter+            , NContract <$> genContract+            , NIntake <$> genIntake+            , NEmit <$> genEmit+            , NPublisher <$> genPublisher+            , NWorkqueue <$> genWorkqueue+            , NPgmqDispatch <$> genPgmqDispatch+            , NReadModel <$> genReadModel+            , NWorkflow <$> genWorkflow+            , NOperation <$> genOperation+            ]++-- | A dotted PascalCase module prefix, e.g. @Acme@ or @Acme.Services@.+genModuleRoot :: Gen T.Text+genModuleRoot = do+    n <- choose (1, 3 :: Int)+    segs <- vectorOf n (elements ["Acme", "Services", "Hospital", "Domain", "Core"])+    pure (T.intercalate "." segs)
+ test/conformance-coldstart/Billing/Subscription/Holes.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- HAND-FILLED hole module for the EP-7 cold-start demo: a fresh `subscription`+-- aggregate authored from only the skill notation, then filled against the+-- generated signatures. The harness pins this fill.+module Billing.Subscription.Holes (+    subscriptionTransducer,+    applySubscriptions,+) where++import Generated.Billing.Subscription.Domain+import Keiki.Builder ((=:))+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer, lit, (./=))++subscriptionTransducer ::+    SymTransducer+        (HsPred SubscriptionRegs SubscriptionCommand)+        SubscriptionRegs+        SubscriptionVertex+        SubscriptionCommand+        SubscriptionEvent+subscriptionTransducer =+    B.buildTransducer SubscriptionInactive initialSubscriptionRegs isTerminal do+        B.from SubscriptionInactive do+            B.onCmd inCtorActivateSubscription $ \d -> B.do+                B.requireGuard (d.plan ./= lit Free)+                B.slot @"subscriptionState" =: lit SubscriptionActive+                B.emit+                    wireSubscriptionActivated+                    SubscriptionActivatedTermFields+                        { subscriptionId = d.subscriptionId+                        , customerId = d.customerId+                        , plan = d.plan+                        }+                B.goto SubscriptionActive+        B.from SubscriptionActive do+            B.onCmd inCtorCancelSubscription $ \d -> B.do+                B.slot @"subscriptionState" =: lit SubscriptionClosed+                B.emit+                    wireSubscriptionCancelled+                    SubscriptionCancelledTermFields+                        { subscriptionId = d.subscriptionId+                        , customerId = d.customerId+                        }+                B.goto SubscriptionClosed+  where+    isTerminal = \case+        SubscriptionClosed -> True+        _ -> False++applySubscriptions :: SubscriptionEvent -> recorded -> txn ()+applySubscriptions _event _recorded = error "HOLE: fill subscriptions projection apply"
+ test/conformance-coldstart/Generated/Billing/Subscription/Codec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.Billing.Subscription.Codec (+    subscriptionCodec,+    parseSubscriptionEvent,+    encodeSubscriptionEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.Billing.Subscription.Domain+import Keiro.Codec (Codec (..), EventType (..))++parsePlan :: Text -> Parser Plan+parsePlan = \case+    "paid" -> pure Paid+    "free" -> pure Free+    _ -> fail "unknown Plan"++subscriptionCodec :: Codec SubscriptionEvent+subscriptionCodec =+    Codec+        { eventTypes = EventType "SubscriptionActivated" :| [EventType "SubscriptionCancelled"]+        , eventType = \case+            SubscriptionActivated{} -> EventType "SubscriptionActivated"+            SubscriptionCancelled{} -> EventType "SubscriptionCancelled"+        , schemaVersion = 1+        , encode = encodeSubscriptionEvent+        , decode = parseSubscriptionEvent+        , upcasters = []+        }++encodeSubscriptionEvent :: SubscriptionEvent -> Value+encodeSubscriptionEvent = \case+    SubscriptionActivated payload ->+        object+            [ "kind" .= ("SubscriptionActivated" :: Text)+            , "subscriptionId" .= subscriptionIdText payload.subscriptionId+            , "customerId" .= customerIdText payload.customerId+            , "plan" .= planText payload.plan+            ]+    SubscriptionCancelled payload ->+        object+            [ "kind" .= ("SubscriptionCancelled" :: Text)+            , "subscriptionId" .= subscriptionIdText payload.subscriptionId+            , "customerId" .= customerIdText payload.customerId+            ]++parseSubscriptionEvent :: EventType -> Value -> Either Text SubscriptionEvent+parseSubscriptionEvent (EventType tag) = mapLeftText . parseEither (withObject "SubscriptionEvent" go)+  where+    go o = do+        case tag of+            "SubscriptionActivated" ->+                SubscriptionActivated <$> (SubscriptionActivatedData <$> (SubscriptionId <$> o .: "subscriptionId") <*> (CustomerId <$> o .: "customerId") <*> (o .: "plan" >>= parsePlan))+            "SubscriptionCancelled" ->+                SubscriptionCancelled <$> (SubscriptionCancelledData <$> (SubscriptionId <$> o .: "subscriptionId") <*> (CustomerId <$> o .: "customerId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-coldstart/Generated/Billing/Subscription/Domain.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.Billing.Subscription.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype SubscriptionId = SubscriptionId Text+  deriving stock (Generic, Eq, Ord, Show)++subscriptionIdText :: SubscriptionId -> Text+subscriptionIdText (SubscriptionId t) = t++newtype CustomerId = CustomerId Text+  deriving stock (Generic, Eq, Ord, Show)++customerIdText :: CustomerId -> Text+customerIdText (CustomerId t) = t++data Plan = Paid | Free+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++planText :: Plan -> Text+planText = \case+  Paid -> "paid"+  Free -> "free"++data SubscriptionVertex = SubscriptionInactive | SubscriptionActive | SubscriptionClosed+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data ActivateSubscriptionData = ActivateSubscriptionData+  { subscriptionId :: !SubscriptionId+  , customerId :: !CustomerId+  , plan :: !Plan+  }+  deriving stock (Generic, Eq, Show)++data CancelSubscriptionData = CancelSubscriptionData+  { subscriptionId :: !SubscriptionId+  , customerId :: !CustomerId+  }+  deriving stock (Generic, Eq, Show)++data SubscriptionCommand = ActivateSubscription !ActivateSubscriptionData+  | CancelSubscription !CancelSubscriptionData+  deriving stock (Generic, Eq, Show)++data SubscriptionActivatedData = SubscriptionActivatedData+  { subscriptionId :: !SubscriptionId+  , customerId :: !CustomerId+  , plan :: !Plan+  }+  deriving stock (Generic, Eq, Show)++data SubscriptionCancelledData = SubscriptionCancelledData+  { subscriptionId :: !SubscriptionId+  , customerId :: !CustomerId+  }+  deriving stock (Generic, Eq, Show)++data SubscriptionEvent = SubscriptionActivated !SubscriptionActivatedData+  | SubscriptionCancelled !SubscriptionCancelledData+  deriving stock (Generic, Eq, Show)++type SubscriptionRegs =+  '[ '("plan", Plan)+   , '("subscriptionState", SubscriptionVertex)+   ]++initialSubscriptionRegs :: RegFile SubscriptionRegs+initialSubscriptionRegs =+  RCons (Proxy @"plan") Free $+  RCons (Proxy @"subscriptionState") SubscriptionInactive RNil++$(deriveAggregateCtorsAll ''SubscriptionCommand ''SubscriptionRegs)++++$(deriveWireCtorsAll ''SubscriptionEvent)
+ test/conformance-coldstart/Generated/Billing/Subscription/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.Billing.Subscription.EventStream (+    subscriptionCategory,+    subscriptionEventStream,+    subscriptionEventStreamDef,+    SubscriptionEventStream,+    SubscriptionEventStreamDef,+) where++import Billing.Subscription.Holes (subscriptionTransducer)+import Generated.Billing.Subscription.Codec (subscriptionCodec)+import Generated.Billing.Subscription.Domain+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+subscriptionCategory :: Stream.StreamCategory a+subscriptionCategory = Stream.categoryUnsafe "subscription"++type SubscriptionEventStreamDef =+    EventStream (HsPred SubscriptionRegs SubscriptionCommand) SubscriptionRegs SubscriptionVertex SubscriptionCommand SubscriptionEvent++type SubscriptionEventStream =+    ValidatedEventStream (HsPred SubscriptionRegs SubscriptionCommand) SubscriptionRegs SubscriptionVertex SubscriptionCommand SubscriptionEvent++subscriptionEventStreamDef :: SubscriptionEventStreamDef+subscriptionEventStreamDef =+    EventStream+        { transducer = subscriptionTransducer+        , initialState = SubscriptionInactive+        , initialRegisters = initialSubscriptionRegs+        , eventCodec = subscriptionCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++subscriptionEventStream :: SubscriptionEventStream+subscriptionEventStream =+    mkEventStreamOrThrow "Subscription" subscriptionEventStreamDef
+ test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.Billing.Subscription.Harness (harnessAssertions) where++import Billing.Subscription.Holes (subscriptionTransducer)+import Generated.Billing.Subscription.Codec (encodeSubscriptionEvent, parseSubscriptionEvent, subscriptionCodec)+import Generated.Billing.Subscription.Domain+import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions subscriptionTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: SubscriptionActivated", roundTrips sampleEventSubscriptionActivated)+    , ("golden round-trip: SubscriptionCancelled", roundTrips sampleEventSubscriptionCancelled)+    , ("accepts ActivateSubscription from SubscriptionInactive", acceptActivateSubscription)+    ]++roundTrips :: SubscriptionEvent -> Bool+roundTrips e = parseSubscriptionEvent (eventType subscriptionCodec e) (encodeSubscriptionEvent e) == Right e++sampleEventSubscriptionActivated :: SubscriptionEvent+sampleEventSubscriptionActivated = (SubscriptionActivated (SubscriptionActivatedData (SubscriptionId "sample") (CustomerId "sample") Paid))++sampleEventSubscriptionCancelled :: SubscriptionEvent+sampleEventSubscriptionCancelled = (SubscriptionCancelled (SubscriptionCancelledData (SubscriptionId "sample") (CustomerId "sample")))++acceptActivateSubscription :: Bool+acceptActivateSubscription =+    case step subscriptionTransducer (SubscriptionInactive, initialSubscriptionRegs) ((ActivateSubscription (ActivateSubscriptionData (SubscriptionId "sample") (CustomerId "sample") Paid))) of+        Just (v, _, _) -> v == SubscriptionActive+        Nothing -> False
+ test/conformance-coldstart/Generated/Billing/Subscription/Projection.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.Billing.Subscription.Projection+  ( subscriptionsProjection+  , subscriptionsStatusFor+  ) where++import Generated.Billing.Subscription.Domain+import Billing.Subscription.Holes (applySubscriptions)+import Data.Text (Text)+import Keiro.Projection (InlineProjection (..))++-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived+-- from the spec's status-map. The read-model SQL that consumes it lives in+-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).+subscriptionsStatusFor :: SubscriptionEvent -> Maybe Text+subscriptionsStatusFor = \case+  SubscriptionActivated {} -> Just "active"+  SubscriptionCancelled {} -> Just "cancelled"++subscriptionsProjection :: InlineProjection SubscriptionEvent+subscriptionsProjection =+  InlineProjection+    { name = "billing-subscriptions-inline"+    , apply = applySubscriptions+    }
+ test/conformance-coldstart/Main.hs view
@@ -0,0 +1,20 @@+{- | EP-7 cold-start proof: a brand-new `subscription` service, authored from+only the skill's notation (not in the corpus), driven through the full loop+(check -> scaffold -> fill the hole -> harness). Compiling this component+proves the scaffolded Generated modules + the hand-filled Holes compile+against keiki/keiro; running it runs the spec-derived harness green.+-}+module Main (main) where++import Control.Monad (forM_, unless)+import Generated.Billing.Subscription.Harness (harnessAssertions)+import System.Exit (exitFailure)++main :: IO ()+main = do+    forM_ harnessAssertions $ \(label, ok) ->+        putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    let failed = [label | (label, ok) <- harnessAssertions, not ok]+    unless (null failed) $ do+        putStrLn ("cold-start harness: " <> show (length failed) <> " failed")+        exitFailure
+ test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Emergency.Contract+  ( EmergencyPayload (..)+  , IncidentTransferNeedDeclaredData (..)+  , TransferReservationAcceptedData (..)+  , messageTypeOf+  , encodeEmergencyPayload+  , parseEmergencyPayload+  ) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.Text (Text)+import qualified Data.Text as T++-- topic constants+incidentEventsTopic :: Text+incidentEventsTopic = "emergency.incident.events"+hospitalEventsTopic :: Text+hospitalEventsTopic = "emergency.hospital.events"++-- the closed payload set (discriminated by "messageType")+data IncidentTransferNeedDeclaredData = IncidentTransferNeedDeclaredData { incidentId :: !Text, triageRecordId :: !Text, region :: !Text, redCount :: !Int }+  deriving stock (Eq, Show)++data TransferReservationAcceptedData = TransferReservationAcceptedData { incidentId :: !Text, reservationId :: !Text, hospitalId :: !Text, expirationDeadline :: !Text }+  deriving stock (Eq, Show)++data EmergencyPayload = IncidentTransferNeedDeclared !IncidentTransferNeedDeclaredData+  | TransferReservationAccepted !TransferReservationAcceptedData+  deriving stock (Eq, Show)++messageTypeOf :: EmergencyPayload -> Text+messageTypeOf = \case+  IncidentTransferNeedDeclared {} -> "IncidentTransferNeedDeclared"+  TransferReservationAccepted {} -> "TransferReservationAccepted"++encodeEmergencyPayload :: EmergencyPayload -> Value+encodeEmergencyPayload = \case+  IncidentTransferNeedDeclared payload ->+    object+      [ "messageType" .= ("IncidentTransferNeedDeclared" :: Text)+      , "incidentId" .= payload.incidentId+      , "triageRecordId" .= payload.triageRecordId+      , "region" .= payload.region+      , "redCount" .= payload.redCount+      ]+  TransferReservationAccepted payload ->+    object+      [ "messageType" .= ("TransferReservationAccepted" :: Text)+      , "incidentId" .= payload.incidentId+      , "reservationId" .= payload.reservationId+      , "hospitalId" .= payload.hospitalId+      , "expirationDeadline" .= payload.expirationDeadline+      ]++parseEmergencyPayload :: Value -> Either Text EmergencyPayload+parseEmergencyPayload = mapLeftText . parseEither (withObject "EmergencyPayload" go)+  where+    go o = do+      kind <- o .: "messageType" :: Parser Text+      case kind of+        "IncidentTransferNeedDeclared" ->+          IncidentTransferNeedDeclared <$> (IncidentTransferNeedDeclaredData <$> o .: "incidentId" <*> o .: "triageRecordId" <*> o .: "region" <*> o .: "redCount")+        "TransferReservationAccepted" ->+          TransferReservationAccepted <$> (TransferReservationAcceptedData <$> o .: "incidentId" <*> o .: "reservationId" <*> o .: "hospitalId" <*> o .: "expirationDeadline")+        _ -> fail "unknown message type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-contract/Main.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Conformance driver for the scaffolded EP-4 contract layer. Compiling this+component proves the scaffolded @Generated.…Emergency.Contract@ module (the+payload ADT + topic constants + messageType discriminator + strict codec) is+real, self-contained Haskell; running it proves every contract event type+round-trips through encode/decode and that messageTypeOf agrees.+-}+module Main (main) where++import Control.Monad (forM_, unless)+import Data.Text qualified as T+import Generated.HospitalCapacity.Emergency.Contract+import System.Exit (exitFailure)++samples :: [(String, EmergencyPayload)]+samples =+    [ ("IncidentTransferNeedDeclared", IncidentTransferNeedDeclared (IncidentTransferNeedDeclaredData "inc-1" "tri-1" "north" 3))+    , ("TransferReservationAccepted", TransferReservationAccepted (TransferReservationAcceptedData "inc-1" "rsv-1" "hsp-1" "2026-01-01"))+    ]++main :: IO ()+main = do+    let results =+            [ (label, parseEmergencyPayload (encodeEmergencyPayload p) == Right p && messageTypeOf p == T.pack label)+            | (label, p) <- samples+            ]+    forM_ results $ \(label, ok) -> putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    let failed = [label | (label, ok) <- results, not ok]+    unless (null failed) $ putStrLn ("contract: failed " <> show failed) >> exitFailure
+ test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/Queue.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation_work.Queue (+    ReservationWorkItem (..),+    encodeReservationWorkItem,+    parseReservationWorkItem,+    queuePhysical,+    queueDlq,+    queueTable,+    groupKeyField,+    groupKeyFor,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.Text (Text)+import Data.Text qualified as T++queuePhysical, queueDlq, queueTable :: Text+queuePhysical = "hospital_capacity_reservation_work"+queueDlq = "hospital_capacity_reservation_work_dlq"+queueTable = "pgmq.q_hospital_capacity_reservation_work"++groupKeyField :: Text+groupKeyField = "reservationId"++groupKeyFor :: ReservationWorkItem -> Text+groupKeyFor payload = payload.reservationId++data ReservationWorkItem = ReservationWorkItem+    { reservationId :: !Text+    , hospitalId :: !Text+    , commandId :: !Text+    , lifeCriticalOverride :: !Bool+    }+    deriving stock (Eq, Show)++encodeReservationWorkItem :: ReservationWorkItem -> Value+encodeReservationWorkItem p =+    object+        [ "reservation_id" .= p.reservationId+        , "hospital_id" .= p.hospitalId+        , "command_id" .= p.commandId+        , "life_critical_override" .= p.lifeCriticalOverride+        ]++parseReservationWorkItem :: Value -> Either Text ReservationWorkItem+parseReservationWorkItem = mapLeftText . parseEither (withObject "ReservationWorkItem" go)+  where+    go o = ReservationWorkItem <$> o .: "reservation_id" <*> o .: "hospital_id" <*> o .: "command_id" <*> o .: "life_critical_override"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueuePolicy.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation_work.QueuePolicy (+    retryPolicy,+    jobOutcomeFor,+    jobOrdering,+    jobTuningFor,+    queueProvision,+) where++import Data.Text (Text)+import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)++jobOrdering :: JobOrdering+jobOrdering = FifoThroughput++-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.+jobTuningFor :: JobTuning -> JobTuning+jobTuningFor = withOrdering jobOrdering++-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.+queueProvision :: QueueProvision+queueProvision = withFifoIndexProvision (standardProvision)++retryPolicy :: RetryPolicy+retryPolicy =+    RetryPolicy+        { maxRetries = 3+        , defaultRetryDelay = RetryDelay 5+        , useDeadLetter = True+        }++-- The consumer JobOutcome disposition over the spec's named domain outcomes,+-- lowered to the live Keiro.PGMQ.Job.JobOutcome.+jobOutcomeFor :: Text -> JobOutcome+jobOutcomeFor o = case o of+    "storeFailure" -> Retry (RetryDelay 5)+    "commandRejected" -> Dead "dead-lettered"+    "decodeFailure" -> Dead "dead-lettered"+    "onCodecReject" -> Dead "dead-lettered"+    _ -> Retry (RetryDelay 5)
+ test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++-- HAND-FILLED pgmq dispatch service (EP-5 M5 full-service integration): the+-- declarative Job value (queue + codec + retry policy, all from the scaffolded+-- deterministic layer) paired with the worker handler — the behaviour-bearing+-- hole — filled and type-checked against the live keiro-pgmq runtime.+module HospitalCapacity.ReservationWork.WorkqueueJob (+    reservationWorkJob,+    reservationWorkHandler,+) where++import Effectful (Eff)+import Generated.HospitalCapacity.Reservation_work.Queue (+    ReservationWorkItem,+    encodeReservationWorkItem,+    parseReservationWorkItem,+ )+import Generated.HospitalCapacity.Reservation_work.QueuePolicy (retryPolicy)+import Keiro.PGMQ.Codec (mkJobCodec)+import Keiro.PGMQ.Job (Job (..), JobOutcome (..))+import Keiro.PGMQ.Runtime (queueRef)++-- | The declarative job, assembled entirely from scaffolded deterministic parts.+reservationWorkJob :: Job ReservationWorkItem+reservationWorkJob =+    Job+        { jobName = "reservation-work"+        , jobQueue = queueRef "hospital_capacity.reservation_work"+        , jobCodec =+            mkJobCodec+                encodeReservationWorkItem+                parseReservationWorkItem+        , jobPolicy = retryPolicy+        }++{- | The worker hole, filled: process one work item, decide an outcome. (A real+handler reads downstream state; here it acknowledges, type-checked against the+live @p -> Eff es JobOutcome@ contract.)+-}+reservationWorkHandler :: ReservationWorkItem -> Eff es JobOutcome+reservationWorkHandler _item = pure Done
+ test/conformance-dispatch-full/Main.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++{- | EP-5 M5 full-service conformance: a complete pgmq dispatch service — the+scaffolded Job codec + retry policy plus a filled worker handler, assembled+into a live @Keiro.PGMQ.Job.Job@ value — compiled against keiro-pgmq.+-}+module Main (main) where++import Control.Monad (unless)+import HospitalCapacity.ReservationWork.WorkqueueJob (reservationWorkHandler, reservationWorkJob)+import Keiro.PGMQ.Job (Job (..), RetryPolicy (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    -- reference the handler so its (filled) definition is part of the build.+    let _handler = reservationWorkHandler+        nameOk = jobName reservationWorkJob == "reservation-work"+        policyOk = maxRetries (jobPolicy reservationWorkJob) == 3 && useDeadLetter (jobPolicy reservationWorkJob)+    putStrLn ("job name: " <> show nameOk)+    putStrLn ("retry policy (maxRetries=3, dlq on): " <> show policyOk)+    unless (nameOk && policyOk) exitFailure
+ test/conformance-intake-full/Generated/HospitalCapacity/IncidentInbox/Inbox.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.IncidentInbox.Inbox (+    InboxAck (..),+    inboxDedupePolicy,+    inboxPersistence,+    inboxDisposition,+) where++import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))++-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy.+inboxDedupePolicy :: InboxDedupePolicy+inboxDedupePolicy = PreferIntegrationMessageId++{- | Success-path envelope retention passed to runInboxTransactionWith.+Failures always retain their full operator-facing dead-letter envelope.+Dedupe-only success rows decode with an empty payload.+-}+inboxPersistence :: InboxPersistence+inboxPersistence = PersistDedupeOnly++-- The service's ack decision for each inbox classification.+data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter+    deriving stock (Eq, Show)++-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult.+-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous+-- inversions the spec states explicitly.+inboxDisposition :: InboxResult a -> InboxAck+inboxDisposition r = case r of+    InboxProcessed _ -> InboxAckOk+    InboxDuplicate -> InboxAckOk+    InboxInProgress -> InboxRetry+    InboxPreviouslyFailed _ -> InboxDeadLetter++-- handler-level failures (not InboxResult): decodeFailed => deadLetter, dedupeFailed => deadLetter, storeFailed => retry
+ test/conformance-intake-full/HospitalCapacity/IncidentInbox/Integration.hs view
@@ -0,0 +1,41 @@+-- HAND-FILLED integration service (EP-4 M5 full-service integration): the+-- inbox transaction runner (wired to the scaffolded dedupe policy) and the+-- outbox IntegrationProducer (its mapEvent the filled emit map/skip hole) —+-- the behaviour-bearing bodies — type-checked against the live keiro runtime.+module HospitalCapacity.IncidentInbox.Integration (+    runIncidentInbox,+    incidentProducer,+) where++import Effectful (Eff, IOE, (:>))+import Generated.HospitalCapacity.IncidentInbox.Inbox (inboxDedupePolicy, inboxPersistence)+import Hasql.Transaction qualified as Tx+import Keiro.Inbox (InboxError, InboxResult, runInboxTransactionWith)+import Keiro.Inbox.Types (KafkaDeliveryRef)+import Keiro.Integration.Event (IntegrationEvent)+import Keiro.Outbox (IntegrationProducer (..))+import Kiroku.Store.Effect (Store)++{- | The inbox runner, wired to the scaffolded dedupe policy. The handler (the+in-transaction domain effect) is the filled behaviour-bearing hole.+-}+runIncidentInbox ::+    (IOE :> es, Store :> es) =>+    IntegrationEvent ->+    Maybe KafkaDeliveryRef ->+    (IntegrationEvent -> Tx.Transaction a) ->+    Eff es (Either InboxError (InboxResult a))+runIncidentInbox event kafka handler =+    runInboxTransactionWith Nothing inboxPersistence inboxDedupePolicy event kafka handler++{- | The outbox producer; @mapEvent@ is the filled emit map (here the total+@_ => skip@ mapping — a valid, exhaustive choice).+-}+incidentProducer :: IntegrationProducer e+incidentProducer =+    IntegrationProducer+        { name = "hospital-capacity-outbox"+        , source = "hospital-capacity"+        , messageIdPrefix = "msg"+        , mapEvent = \_recorded _event -> Nothing+        }
+ test/conformance-intake-full/Main.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++{- | EP-4 M5 full-service conformance: a complete integration service — the+scaffolded inbox dedupe/disposition plus a filled inbox transaction runner+and outbox IntegrationProducer — compiled against the live keiro runtime+(Keiro.Inbox / Keiro.Outbox / Kiroku.Store).+-}+module Main (main) where++import Control.Monad (unless)++-- runIncidentInbox (the inbox transaction runner) is compiled as part of the+-- Integration other-module; here we exercise the outbox producer.+import HospitalCapacity.IncidentInbox.Integration (incidentProducer)+import Keiro.Outbox (IntegrationProducer (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    let sourceOk = source incidentProducer == "hospital-capacity"+        prefixOk = messageIdPrefix incidentProducer == "msg"+    putStrLn ("outbox producer source: " <> show sourceOk)+    putStrLn ("outbox messageId prefix: " <> show prefixOk)+    unless (sourceOk && prefixOk) exitFailure
+ test/conformance-intake-runtime/Generated/HospitalCapacity/IncidentInbox/Inbox.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.IncidentInbox.Inbox (+    InboxAck (..),+    inboxDedupePolicy,+    inboxPersistence,+    inboxDisposition,+) where++import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))++-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy.+inboxDedupePolicy :: InboxDedupePolicy+inboxDedupePolicy = PreferIntegrationMessageId++{- | Success-path envelope retention passed to runInboxTransactionWith.+Failures always retain their full operator-facing dead-letter envelope.+Dedupe-only success rows decode with an empty payload.+-}+inboxPersistence :: InboxPersistence+inboxPersistence = PersistDedupeOnly++-- The service's ack decision for each inbox classification.+data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter+    deriving stock (Eq, Show)++-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult.+-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous+-- inversions the spec states explicitly.+inboxDisposition :: InboxResult a -> InboxAck+inboxDisposition r = case r of+    InboxProcessed _ -> InboxAckOk+    InboxDuplicate -> InboxAckOk+    InboxInProgress -> InboxRetry+    InboxPreviouslyFailed _ -> InboxDeadLetter++-- handler-level failures (not InboxResult): decodeFailed => deadLetter, dedupeFailed => deadLetter, storeFailed => retry
+ test/conformance-intake-runtime/Main.hs view
@@ -0,0 +1,26 @@+{- | EP-4 runtime conformance: the scaffolded intake @Inbox@ module's disposition+wiring — the dedupe policy (a real @Keiro.Inbox.Types.InboxDedupePolicy@) and+the disposition over the real @InboxResult@ — compiled against the LIVE keiro+runtime. Running it pins the two dangerous inversions: a duplicate redelivery+is ackOk (success), and a previously-failed delivery dead-letters (not retry).+-}+module Main (main) where++import Control.Monad (unless)+import Generated.HospitalCapacity.IncidentInbox.Inbox (InboxAck (..), inboxDisposition, inboxPersistence)+import Keiro.Inbox.Types (InboxPersistence (..), InboxResult (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    let dupOk = inboxDisposition (InboxDuplicate :: InboxResult ()) == InboxAckOk+        pfOk = inboxDisposition (InboxPreviouslyFailed Nothing :: InboxResult ()) == InboxDeadLetter+        procOk = inboxDisposition (InboxProcessed () :: InboxResult ()) == InboxAckOk+        ipOk = inboxDisposition (InboxInProgress :: InboxResult ()) == InboxRetry+        persistenceOk = inboxPersistence == PersistDedupeOnly+    putStrLn ("duplicate => ackOk (inversion 1): " <> show dupOk)+    putStrLn ("previouslyFailed => deadLetter (inversion 2): " <> show pfOk)+    putStrLn ("processed => ackOk: " <> show procOk)+    putStrLn ("inProgress => retry: " <> show ipOk)+    putStrLn ("success persistence => dedupe-only: " <> show persistenceOk)+    unless (dupOk && pfOk && procOk && ipOk && persistenceOk) exitFailure
+ test/conformance-newsurface/Generated/TransferRouting/Hospital/Codec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital.Codec (+    hospitalCodec,+    parseHospitalEvent,+    encodeHospitalEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.TransferRouting.Hospital.Domain+import Keiro.Codec (Codec (..), EventType (..))++hospitalCodec :: Codec HospitalEvent+hospitalCodec =+    Codec+        { eventTypes = EventType "AcceptedTransferNeedRouted" :| []+        , eventType = \case+            AcceptedTransferNeedRouted{} -> EventType "AcceptedTransferNeedRouted"+        , schemaVersion = 1+        , encode = encodeHospitalEvent+        , decode = parseHospitalEvent+        , upcasters = []+        }++encodeHospitalEvent :: HospitalEvent -> Value+encodeHospitalEvent = \case+    AcceptedTransferNeedRouted payload ->+        object+            [ "kind" .= ("AcceptedTransferNeedRouted" :: Text)+            , "transferNeedId" .= payload.transferNeedId+            , "hospitalId" .= payload.hospitalId+            ]++parseHospitalEvent :: EventType -> Value -> Either Text HospitalEvent+parseHospitalEvent (EventType tag) = mapLeftText . parseEither (withObject "HospitalEvent" go)+  where+    go o = do+        case tag of+            "AcceptedTransferNeedRouted" ->+                AcceptedTransferNeedRouted <$> (AcceptedTransferNeedRoutedData <$> o .: "transferNeedId" <*> o .: "hospitalId")+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-newsurface/Generated/TransferRouting/Hospital/Domain.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data HospitalVertex = HospitalAccepting+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data RouteAcceptedTransferNeedData = RouteAcceptedTransferNeedData+    { transferNeedId :: !Text+    , hospitalId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data HospitalCommand = RouteAcceptedTransferNeed !RouteAcceptedTransferNeedData+    deriving stock (Generic, Eq, Show)++data AcceptedTransferNeedRoutedData = AcceptedTransferNeedRoutedData+    { transferNeedId :: !Text+    , hospitalId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data HospitalEvent = AcceptedTransferNeedRouted !AcceptedTransferNeedRoutedData+    deriving stock (Generic, Eq, Show)++type HospitalRegs =+    '[]++initialHospitalRegs :: RegFile HospitalRegs+initialHospitalRegs =+    RNil++$(deriveAggregateCtorsAll ''HospitalCommand ''HospitalRegs)++$(deriveWireCtorsAll ''HospitalEvent)
+ test/conformance-newsurface/Generated/TransferRouting/Hospital/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital.EventStream (+    hospitalCategory,+    hospitalEventStream,+    hospitalEventStreamDef,+    HospitalEventStream,+    HospitalEventStreamDef,+) where++import Generated.TransferRouting.Hospital.Codec (hospitalCodec)+import Generated.TransferRouting.Hospital.Domain+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import TransferRouting.Hospital.Holes (hospitalTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+hospitalCategory :: Stream.StreamCategory a+hospitalCategory = Stream.categoryUnsafe "hospital"++type HospitalEventStreamDef =+    EventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++type HospitalEventStream =+    ValidatedEventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++hospitalEventStreamDef :: HospitalEventStreamDef+hospitalEventStreamDef =+    EventStream+        { transducer = hospitalTransducer+        , initialState = HospitalAccepting+        , initialRegisters = initialHospitalRegs+        , eventCodec = hospitalCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++hospitalEventStream :: HospitalEventStream+hospitalEventStream =+    mkEventStreamOrThrow "Hospital" hospitalEventStreamDef
+ test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital.Harness (harnessAssertions) where++import Generated.TransferRouting.Hospital.Codec (encodeHospitalEvent, hospitalCodec, parseHospitalEvent)+import Generated.TransferRouting.Hospital.Domain+import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import TransferRouting.Hospital.Holes (hospitalTransducer)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions hospitalTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: AcceptedTransferNeedRouted", roundTrips sampleEventAcceptedTransferNeedRouted)+    , ("accepts RouteAcceptedTransferNeed from HospitalAccepting", acceptRouteAcceptedTransferNeed)+    ]++roundTrips :: HospitalEvent -> Bool+roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e++sampleEventAcceptedTransferNeedRouted :: HospitalEvent+sampleEventAcceptedTransferNeedRouted = (AcceptedTransferNeedRouted (AcceptedTransferNeedRoutedData "sample" "sample"))++acceptRouteAcceptedTransferNeed :: Bool+acceptRouteAcceptedTransferNeed =+    case step hospitalTransducer (HospitalAccepting, initialHospitalRegs) ((RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "sample" "sample"))) of+        Just (v, _, _) -> v == HospitalAccepting+        Nothing -> False
+ test/conformance-newsurface/Generated/TransferRouting/Hospital/Projection.hs view
@@ -0,0 +1,2 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital.Projection () where
+ test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/Router.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.HospitalTransferRouter.Router (+    hospitalTransferRouterName,+    hospitalTransferRouterWorkerOptions,+) where++import Data.Text (Text)+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The STABLE router name. It participates in every target-keyed+-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.+hospitalTransferRouterName :: Text+hospitalTransferRouterName = "hospital-transfer-router"++-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,+-- targetStreamName, occurrence). Target-keyed, not positional.++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions.+hospitalTransferRouterWorkerOptions :: WorkerOptions es msg+hospitalTransferRouterWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedDeadLetter+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }
+ test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs view
@@ -0,0 +1,16 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.HospitalTransferRouter.RouterHarness (routerHarnessValues) where++routerHarnessValues :: [(String, String)]+routerHarnessValues =+    [ ("routerName", "hospital-transfer-router")+    , ("keyField", "transferNeedId")+    , ("resolveSource", "read-model hospital_load")+    , ("resolveRow", "hospitalId")+    , ("dispatchCommand", "RouteAcceptedTransferNeed")+    , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+    , ("onDuplicate", "AckOk")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "deadLetter")+    , ("poisonPolicy", "halt")+    ]
+ test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModel.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital_load.ReadModel (+    hospitalLoadReadModel,+    hospitalLoadQualifiedTable,+    registerHospitalLoad,+    startHospitalLoadRebuild,+    finishHospitalLoadRebuild,+    abandonHospitalLoadRebuild,+    hospitalLoadAsyncProjection,+) where++import Data.Functor (void)+import Effectful (Eff, (:>))+import Generated.TransferRouting.Hospital_load.ReadModelTable (hospitalLoadQualifiedTable)+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition, RecordedEvent (..))+import TransferRouting.Hospital_load.ReadModelHoles (HospitalLoadQueryInput, HospitalLoadQueryResult, applyHospitalLoad, hospitalLoadQuery)++hospitalLoadReadModel :: ReadModel HospitalLoadQueryInput HospitalLoadQueryResult+hospitalLoadReadModel =+    ReadModel+        { name = "transfer-routing-hospital-load"+        , tableName = "hospital_load"+        , schema = "hospital_transfer"+        , subscriptionName = "transfer-routing-hospital-load-sub"+        , version = 1+        , shapeHash = "fnv1a:977395d28f254ddb"+        , defaultConsistency = Eventual+        , strongScope = EntireLog+        , query = hospitalLoadQuery+        }++-- Call once at projection startup before serving queries.+registerHospitalLoad :: (Store :> es) => Eff es ()+registerHospitalLoad =+    void (registerReadModel "transfer-routing-hospital-load" 1 "fnv1a:977395d28f254ddb")++startHospitalLoadRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+startHospitalLoadRebuild =+    Rebuild.startRebuild hospitalLoadReadModel ["transfer-routing-hospital-load-async"]++finishHospitalLoadRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)+finishHospitalLoadRebuild =+    Rebuild.finishRebuild hospitalLoadReadModel ["transfer-routing-hospital-load-async"]++abandonHospitalLoadRebuild :: (Store :> es) => Eff es ReadModelMetadata+abandonHospitalLoadRebuild = Rebuild.abandonRebuild hospitalLoadReadModel++hospitalLoadAsyncProjection :: AsyncProjection+hospitalLoadAsyncProjection =+    AsyncProjection+        { name = "transfer-routing-hospital-load-async"+        , readModelName = "transfer-routing-hospital-load"+        , subscriptionName = "transfer-routing-hospital-load-sub"+        , applyRecorded = applyHospitalLoad+        , idempotencyKey = \recorded -> recorded.eventId+        }
+ test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModelHarness.hs view
@@ -0,0 +1,19 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital_load.ReadModelHarness (readModelFacts, runReadModelFacts) where++-- | (fact, expected from notation, actual shared derivation/lowering).+readModelFacts :: [(String, String, String)]+readModelFacts =+    [ ("registryName", "transfer-routing-hospital-load", "transfer-routing-hospital-load")+    , ("subscriptionName", "transfer-routing-hospital-load-sub", "transfer-routing-hospital-load-sub")+    , ("shapeHash", "fnv1a:977395d28f254ddb", "fnv1a:977395d28f254ddb")+    , ("asyncProjectionName", "transfer-routing-hospital-load-async", "transfer-routing-hospital-load-async")+    , ("consistency", "Eventual", "Eventual")+    , ("strongScope", "EntireLog", "EntireLog")+    ]++runReadModelFacts :: IO Bool+runReadModelFacts = do+    let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]+    mapM_ (\(fact, expected, actual) -> putStrLn ("FAIL  " <> fact <> " expected=" <> show expected <> " actual=" <> show actual)) failures+    pure (null failures)
+ test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModelTable.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.TransferRouting.Hospital_load.ReadModelTable (hospitalLoadQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+hospitalLoadQualifiedTable :: Text+hospitalLoadQualifiedTable = qualifyTable "hospital_transfer" "hospital_load"
+ test/conformance-newsurface/Main.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (unless)+import Effectful (runPureEff)+import Generated.TransferRouting.Hospital.Domain qualified as Hospital+import Generated.TransferRouting.Hospital.EventStream (hospitalCategory, hospitalEventStream)+import Generated.TransferRouting.Hospital.Harness (harnessAssertions)+import Generated.TransferRouting.HospitalTransferRouter.RouterHarness (routerHarnessValues)+import Generated.TransferRouting.Hospital_load.ReadModelHarness (runReadModelFacts)+import Keiro.ProcessManager (PMCommand (..))+import Keiro.Router (Router (..))+import Keiro.Stream (entityStream)+import System.Exit (exitFailure)+import TransferRouting.HospitalTransferRouter.RouterValue (+    AcceptedHospitalTransferNeed (..),+    hospitalTransferRouter,+ )++main :: IO ()+main = do+    readModelFactsPass <- runReadModelFacts+    let input =+            AcceptedHospitalTransferNeed+                { transferNeedId = "need-42"+                , region = "north"+                }+        commands = runPureEff (hospitalTransferRouter.resolve input)+        checks =+            [("aggregate: " <> label, passed) | (label, passed) <- harnessAssertions]+                <> [ ("validated hospital event stream constructs", hospitalEventStream `seq` True)+                   , ("read-model facts", readModelFactsPass)+                   , ("router name", hospitalTransferRouter.name == "hospital-transfer-router")+                   , ("router key", hospitalTransferRouter.key input == "need-42")+                   ,+                       ( "resolver source is hospital_load"+                       , lookup "resolveSource" routerHarnessValues == Just "read-model hospital_load"+                       )+                   ,+                       ( "rejected commands dead-letter"+                       , lookup "rejectedPolicy" routerHarnessValues == Just "deadLetter"+                       )+                   ,+                       ( "resolver targets the selected hospital aggregate"+                       , map target commands == [entityStream hospitalCategory "north-general"]+                       )+                   ,+                       ( "resolver dispatches the accepted need"+                       , map command commands+                            == [ Hospital.RouteAcceptedTransferNeed+                                    (Hospital.RouteAcceptedTransferNeedData "need-42" "north-general")+                               ]+                       )+                   ]+    mapM_ printCheck checks+    unless (all snd checks) exitFailure++printCheck :: (String, Bool) -> IO ()+printCheck (label, passed) =+    putStrLn ((if passed then "PASS  " else "FAIL  ") <> label)
+ test/conformance-newsurface/TransferRouting/Hospital/Holes.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module TransferRouting.Hospital.Holes (+    hospitalTransducer,+    -- (no projection)+) where++import Generated.TransferRouting.Hospital.Domain+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+hospitalTransducer ::+    SymTransducer+        (HsPred HospitalRegs HospitalCommand)+        HospitalRegs+        HospitalVertex+        HospitalCommand+        HospitalEvent+hospitalTransducer =+    B.buildTransducer HospitalAccepting initialHospitalRegs isTerminal do+        B.from HospitalAccepting do+            B.onCmd inCtorRouteAcceptedTransferNeed $ \d -> B.do+                B.emit+                    wireAcceptedTransferNeedRouted+                    AcceptedTransferNeedRoutedTermFields+                        { transferNeedId = d.transferNeedId+                        , hospitalId = d.hospitalId+                        }+                B.goto HospitalAccepting+  where+    isTerminal = \case+        _ -> False
+ test/conformance-newsurface/TransferRouting/HospitalTransferRouter/RouterHoles.hs view
@@ -0,0 +1,16 @@+-- HAND-OWNED hole module for the router's behaviour-bearing bodies.+-- keiro-dsl creates it once and never overwrites it.+module TransferRouting.HospitalTransferRouter.RouterHoles () where++-- HOLE resolve :: AcceptedHospitalTransferNeed -> Eff es [PMCommand targetCommand]+--   Spec source: read-model hospital_load (typically Keiro.ReadModel.runQuery).+--   The spec's 'stable' keyword acknowledges that retry attempts accumulate+--   the UNION of resolved target identities. Keep the recipient set stable+--   for a source event whenever an exact recipient set matters.+-- HOLE router value: assemble Keiro.Router.Router with name = hospitalTransferRouterName,+--   key, resolve, targetEventStream, and targetProjections; run it with+--   runRouterWorkerWith hospitalTransferRouterWorkerOptions.+-- HOLE targetProjections: spec projections = [].+-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate+--   event id against the TARGET stream via confirmBenignDuplicate before+--   returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise.
+ test/conformance-newsurface/TransferRouting/HospitalTransferRouter/RouterValue.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module TransferRouting.HospitalTransferRouter.RouterValue (+    AcceptedHospitalTransferNeed (..),+    hospitalTransferRouter,+    resolveTargets,+) where++import Data.Text (Text)+import Effectful (Eff)+import Generated.TransferRouting.Hospital.Domain qualified as Hospital+import Generated.TransferRouting.Hospital.EventStream (+    hospitalCategory,+    hospitalEventStream,+ )+import Generated.TransferRouting.HospitalTransferRouter.Router (hospitalTransferRouterName)+import Generated.TransferRouting.Hospital_load.ReadModel (hospitalLoadReadModel)+import Keiki.Core (HsPred)+import Keiro.ProcessManager (PMCommand (..))+import Keiro.Router (Router (..))+import Keiro.Stream (entityStream)++data AcceptedHospitalTransferNeed = AcceptedHospitalTransferNeed+    { transferNeedId :: !Text+    , region :: !Text+    }+    deriving stock (Eq, Show)++data HospitalLoadRow = HospitalLoadRow+    { hospitalId :: !Text+    , region :: !Text+    , availableBeds :: !Int+    }++resolveHospitalLoad :: AcceptedHospitalTransferNeed -> Eff '[] [HospitalLoadRow]+resolveHospitalLoad input =+    hospitalLoadReadModel `seq`+        pure+            [ HospitalLoadRow+                { hospitalId = input.region <> "-general"+                , region = input.region+                , availableBeds = 12+                }+            ]++resolveTargets :: AcceptedHospitalTransferNeed -> Eff '[] [PMCommand Hospital.HospitalCommand]+resolveTargets input = do+    rows <- resolveHospitalLoad input+    pure+        [ PMCommand+            { target = entityStream hospitalCategory row.hospitalId+            , command =+                Hospital.RouteAcceptedTransferNeed+                    (Hospital.RouteAcceptedTransferNeedData input.transferNeedId row.hospitalId)+            }+        | row <- rows+        , row.availableBeds > 0+        ]++hospitalTransferRouter ::+    Router+        AcceptedHospitalTransferNeed+        (HsPred Hospital.HospitalRegs Hospital.HospitalCommand)+        Hospital.HospitalRegs+        Hospital.HospitalVertex+        Hospital.HospitalCommand+        Hospital.HospitalEvent+        '[]+hospitalTransferRouter =+    Router+        { name = hospitalTransferRouterName+        , key = \input -> input.transferNeedId+        , resolve = resolveTargets+        , targetEventStream = hospitalEventStream+        , targetProjections = const []+        }
+ test/conformance-newsurface/TransferRouting/Hospital_load/ReadModelHoles.hs view
@@ -0,0 +1,35 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module TransferRouting.Hospital_load.ReadModelHoles (+    HospitalLoadQueryInput,+    HospitalLoadQueryResult,+    hospitalLoadQuery,+    applyHospitalLoad,+) where++import Data.Text.Encoding qualified as Text+import Generated.TransferRouting.Hospital_load.ReadModelTable (hospitalLoadQualifiedTable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent)++-- HOLE: replace these aliases with the real query input and result types.+type HospitalLoadQueryInput = ()+type HospitalLoadQueryResult = ()++-- HOLE: query "hospital_transfer"."hospital_load" via hospitalLoadQualifiedTable; never rely on search_path.+-- Declared columns:+--   hospital_id text NOT NULL+--   region text NOT NULL+--   available_beds int NOT NULL+hospitalLoadQuery :: HospitalLoadQueryInput -> Tx.Transaction HospitalLoadQueryResult+hospitalLoadQuery _input =+    Tx.sql+        ( Text.encodeUtf8+            ( "SELECT hospital_id FROM "+                <> hospitalLoadQualifiedTable+                <> " WHERE available_beds > 0 ORDER BY available_beds DESC, hospital_id LIMIT 1"+            )+        )++-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.+applyHospitalLoad :: RecordedEvent -> Tx.Transaction ()+applyHospitalLoad _recorded = pure ()
+ test/conformance-process-full/Generated/SurgeDemo/Hospital/Codec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Hospital.Codec (+    hospitalCodec,+    parseHospitalEvent,+    encodeHospitalEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.SurgeDemo.Hospital.Domain+import Keiro.Codec (Codec (..), EventType (..))++hospitalCodec :: Codec HospitalEvent+hospitalCodec =+    Codec+        { eventTypes = EventType "SurgeActivated" :| []+        , eventType = \case+            SurgeActivated{} -> EventType "SurgeActivated"+        , schemaVersion = 1+        , encode = encodeHospitalEvent+        , decode = parseHospitalEvent+        , upcasters = []+        }++encodeHospitalEvent :: HospitalEvent -> Value+encodeHospitalEvent = \case+    SurgeActivated payload ->+        object+            [ "kind" .= ("SurgeActivated" :: Text)+            , "hospitalId" .= hospitalIdText payload.hospitalId+            ]++parseHospitalEvent :: EventType -> Value -> Either Text HospitalEvent+parseHospitalEvent (EventType tag) = mapLeftText . parseEither (withObject "HospitalEvent" go)+  where+    go o = do+        case tag of+            "SurgeActivated" ->+                SurgeActivated <$> (SurgeActivatedData <$> (HospitalId <$> o .: "hospitalId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-process-full/Generated/SurgeDemo/Hospital/Domain.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Hospital.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype HospitalId = HospitalId Text+  deriving stock (Generic, Eq, Ord, Show)++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++data HospitalVertex = HospitalIdle | HospitalSurging+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data ActivateSurgeData = ActivateSurgeData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data HospitalCommand = ActivateSurge !ActivateSurgeData+  deriving stock (Generic, Eq, Show)++data SurgeActivatedData = SurgeActivatedData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data HospitalEvent = SurgeActivated !SurgeActivatedData+  deriving stock (Generic, Eq, Show)++type HospitalRegs =+  '[ '("hospitalState", HospitalVertex)+   ]++initialHospitalRegs :: RegFile HospitalRegs+initialHospitalRegs =+  RCons (Proxy @"hospitalState") HospitalIdle RNil++$(deriveAggregateCtorsAll ''HospitalCommand ''HospitalRegs)++++$(deriveWireCtorsAll ''HospitalEvent)
+ test/conformance-process-full/Generated/SurgeDemo/Hospital/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Hospital.EventStream (+    hospitalCategory,+    hospitalEventStream,+    hospitalEventStreamDef,+    HospitalEventStream,+    HospitalEventStreamDef,+) where++import Generated.SurgeDemo.Hospital.Codec (hospitalCodec)+import Generated.SurgeDemo.Hospital.Domain+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import SurgeDemo.Hospital.Holes (hospitalTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+hospitalCategory :: Stream.StreamCategory a+hospitalCategory = Stream.categoryUnsafe "hospital"++type HospitalEventStreamDef =+    EventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++type HospitalEventStream =+    ValidatedEventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++hospitalEventStreamDef :: HospitalEventStreamDef+hospitalEventStreamDef =+    EventStream+        { transducer = hospitalTransducer+        , initialState = HospitalIdle+        , initialRegisters = initialHospitalRegs+        , eventCodec = hospitalCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++hospitalEventStream :: HospitalEventStream+hospitalEventStream =+    mkEventStreamOrThrow "Hospital" hospitalEventStreamDef
+ test/conformance-process-full/Generated/SurgeDemo/Hospital/Projection.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Hospital.Projection (+    hospitalProjection,+    hospitalStatusFor,+) where++import Data.Text (Text)+import Generated.SurgeDemo.Hospital.Domain+import Keiro.Projection (InlineProjection (..))+import SurgeDemo.Hospital.Holes (applyHospital)++-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived+-- from the spec's status-map. The read-model SQL that consumes it lives in+-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).+-- WARNING: no readmodel node declares 'hospital'; unqualified SQL depends on search_path.+hospitalStatusFor :: HospitalEvent -> Maybe Text+hospitalStatusFor = \case+    SurgeActivated{} -> Just "surging"++hospitalProjection :: InlineProjection HospitalEvent+hospitalProjection =+    InlineProjection+        { name = "surge-demo-hospital-inline"+        , apply = applyHospital+        }
+ test/conformance-process-full/Generated/SurgeDemo/Surge/Codec.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Surge.Codec (+    surgeCodec,+    parseSurgeEvent,+    encodeSurgeEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.SurgeDemo.Surge.Domain+import Keiro.Codec (Codec (..), EventType (..))++surgeCodec :: Codec SurgeEvent+surgeCodec =+    Codec+        { eventTypes = EventType "SurgeThresholdNoted" :| [EventType "SurgeTimerFired"]+        , eventType = \case+            SurgeThresholdNoted{} -> EventType "SurgeThresholdNoted"+            SurgeTimerFired{} -> EventType "SurgeTimerFired"+        , schemaVersion = 1+        , encode = encodeSurgeEvent+        , decode = parseSurgeEvent+        , upcasters = []+        }++encodeSurgeEvent :: SurgeEvent -> Value+encodeSurgeEvent = \case+    SurgeThresholdNoted payload ->+        object+            [ "kind" .= ("SurgeThresholdNoted" :: Text)+            , "hospitalId" .= hospitalIdText payload.hospitalId+            ]+    SurgeTimerFired payload ->+        object+            [ "kind" .= ("SurgeTimerFired" :: Text)+            , "hospitalId" .= hospitalIdText payload.hospitalId+            ]++parseSurgeEvent :: EventType -> Value -> Either Text SurgeEvent+parseSurgeEvent (EventType tag) = mapLeftText . parseEither (withObject "SurgeEvent" go)+  where+    go o = do+        case tag of+            "SurgeThresholdNoted" ->+                SurgeThresholdNoted <$> (SurgeThresholdNotedData <$> (HospitalId <$> o .: "hospitalId"))+            "SurgeTimerFired" ->+                SurgeTimerFired <$> (SurgeTimerFiredData <$> (HospitalId <$> o .: "hospitalId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-process-full/Generated/SurgeDemo/Surge/Domain.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Surge.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype HospitalId = HospitalId Text+  deriving stock (Generic, Eq, Ord, Show)++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++data SurgeVertex = SurgeWatching | SurgeNoted | SurgeFired+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data NoteSurgeThresholdData = NoteSurgeThresholdData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data MarkSurgeTimerFiredData = MarkSurgeTimerFiredData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data SurgeCommand = NoteSurgeThreshold !NoteSurgeThresholdData+  | MarkSurgeTimerFired !MarkSurgeTimerFiredData+  deriving stock (Generic, Eq, Show)++data SurgeThresholdNotedData = SurgeThresholdNotedData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data SurgeTimerFiredData = SurgeTimerFiredData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data SurgeEvent = SurgeThresholdNoted !SurgeThresholdNotedData+  | SurgeTimerFired !SurgeTimerFiredData+  deriving stock (Generic, Eq, Show)++type SurgeRegs =+  '[ '("surgeState", SurgeVertex)+   ]++initialSurgeRegs :: RegFile SurgeRegs+initialSurgeRegs =+  RCons (Proxy @"surgeState") SurgeWatching RNil++$(deriveAggregateCtorsAll ''SurgeCommand ''SurgeRegs)++++$(deriveWireCtorsAll ''SurgeEvent)
+ test/conformance-process-full/Generated/SurgeDemo/Surge/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Surge.EventStream (+    surgeCategory,+    surgeEventStream,+    surgeEventStreamDef,+    SurgeEventStream,+    SurgeEventStreamDef,+) where++import Generated.SurgeDemo.Surge.Codec (surgeCodec)+import Generated.SurgeDemo.Surge.Domain+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import SurgeDemo.Surge.Holes (surgeTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+surgeCategory :: Stream.StreamCategory a+surgeCategory = Stream.categoryUnsafe "surge"++type SurgeEventStreamDef =+    EventStream (HsPred SurgeRegs SurgeCommand) SurgeRegs SurgeVertex SurgeCommand SurgeEvent++type SurgeEventStream =+    ValidatedEventStream (HsPred SurgeRegs SurgeCommand) SurgeRegs SurgeVertex SurgeCommand SurgeEvent++surgeEventStreamDef :: SurgeEventStreamDef+surgeEventStreamDef =+    EventStream+        { transducer = surgeTransducer+        , initialState = SurgeWatching+        , initialRegisters = initialSurgeRegs+        , eventCodec = surgeCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++surgeEventStream :: SurgeEventStream+surgeEventStream =+    mkEventStreamOrThrow "Surge" surgeEventStreamDef
+ test/conformance-process-full/Generated/SurgeDemo/Surge/Projection.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.Surge.Projection (+    surgeProjection,+    surgeStatusFor,+) where++import Data.Text (Text)+import Generated.SurgeDemo.Surge.Domain+import Keiro.Projection (InlineProjection (..))+import SurgeDemo.Surge.Holes (applySurge)++-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived+-- from the spec's status-map. The read-model SQL that consumes it lives in+-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).+-- WARNING: no readmodel node declares 'surge'; unqualified SQL depends on search_path.+surgeStatusFor :: SurgeEvent -> Maybe Text+surgeStatusFor = \case+    SurgeThresholdNoted{} -> Just "noted"+    SurgeTimerFired{} -> Just "fired"++surgeProjection :: InlineProjection SurgeEvent+surgeProjection =+    InlineProjection+        { name = "surge-demo-surge-inline"+        , apply = applySurge+        }
+ test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/Process.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.SurgeDemo.SurgeFlow.Process (+    surgeFlowProcessName,+    surgeFlowCategory,+    surgeFlowProcessWorkerOptions,+    surgeFlowTimerRequest,+    surgeFlowFireOutcome,+) where++import Data.Aeson (Value, object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Data.UUID.V5 qualified as UUID.V5+import Keiro.Command (CommandError (..))+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Keiro.Stream qualified as Stream+import Keiro.Timer (TimerId (..), TimerRequest (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).+surgeFlowProcessName :: Text+surgeFlowProcessName = "surge-demo"++-- The validated saga stream category (hole-kind 5: referenced, never retyped).+-- Saga streams are '<category>-<correlationId>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.+surgeFlowCategory :: Stream.StreamCategory a+surgeFlowCategory = Stream.categoryUnsafe "surge"++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.ProcessManager.runProcessManagerWorkerWith.+surgeFlowProcessWorkerOptions :: WorkerOptions es msg+surgeFlowProcessWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedHalt+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }++-- The deterministic timer-request builder: id derived from the correlation+-- key (hole-kind 1), processManagerName referenced, payload from the spec.+-- (timer id derived as uuidv5 of "surge-timer:" <> correlationId)+surgeFlowTimerRequest :: Text -> UTCTime -> TimerRequest+surgeFlowTimerRequest correlationId fireAtTime =+    TimerRequest+        { timerId = TimerId (namedUuid ("surge-timer:" <> correlationId))+        , processManagerName = surgeFlowProcessName+        , correlationId = correlationId+        , fireAt = fireAtTime+        , payload = object ["kind" .= ("surge-follow-up" :: Value)]+        }++-- The timer-fire disposition table (hole-kind 2), derived from the spec.+-- on-reject => Fired is the benign inversion.+-- A duplicate append reaches on-error unless it is confirmed against the+-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:+--   StreamName -> EventId -> CommandError -> Eff es Bool+-- Fold True into the duplicate result and surface False as the failure.+surgeFlowFireOutcome :: Either CommandError a -> Maybe ()+surgeFlowFireOutcome result = case result of+    Right{} -> Just () -- Fired+    Left CommandRejected -> Just () -- Fired+    Left (CommandAmbiguous _) -> Nothing -- Retry  -- explicit definition-bug arm+    Left{} -> Nothing -- Retry++-- max-attempts = 5, dead-letter = "ceiling"+-- (the timer worker must pass Just 5 to runTimerWorkerWith, never the+--  defaultTimerWorkerOptions Nothing ceiling that retries forever).++-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1).+namedUuid :: Text -> UUID+namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))
+ test/conformance-process-full/Main.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++{- | EP-3 M5 full-service conformance: a complete process service — the+scaffolded Surge (saga) + Hospital (target) aggregates with FILLED+transducers, plus a FILLED ProcessManager @handle@ — compiled against the live+keiro/keiki runtime. Compiling this component proves the whole multi-aggregate+service builds; running it exercises the pure @handle@: one input yields the+manager-advance command, one dispatched target command, and one timer.+-}+module Main (main) where++import Control.Monad (unless)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Keiro.ProcessManager (ProcessManager (..), ProcessManagerAction (..))+import SurgeDemo.SurgeFlow.Manager (SurgeInput (..), surgeManager)+import System.Exit (exitFailure)++main :: IO ()+main = do+    let input = SurgeInput{hospitalId = "hosp-1", observedAt = posixSecondsToUTCTime 0}+        action = surgeManager.handle input+        nameOk = surgeManager.name == "surge-demo"+        corrOk = surgeManager.correlate input == "hosp-1"+        dispatchOk = length action.commands == 1+        timerOk = length action.timers == 1+        duplicateContractOk = dispatchOk+    putStrLn ("manager name: " <> show nameOk)+    putStrLn ("correlate: " <> show corrOk)+    putStrLn ("handle dispatches 1 target command: " <> show dispatchOk)+    putStrLn ("handle schedules 1 timer: " <> show timerOk)+    putStrLn ("on-duplicate AckOk delegates to target-stream confirmBenignDuplicate: " <> show duplicateContractOk)+    unless (nameOk && corrOk && dispatchOk && timerOk && duplicateContractOk) exitFailure
+ test/conformance-process-full/SurgeDemo/Hospital/Holes.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module SurgeDemo.Hospital.Holes (+    hospitalTransducer,+    applyHospital,+) where++import Generated.SurgeDemo.Hospital.Domain+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)++hospitalTransducer ::+    SymTransducer+        (HsPred HospitalRegs HospitalCommand)+        HospitalRegs+        HospitalVertex+        HospitalCommand+        HospitalEvent+hospitalTransducer =+    B.buildTransducer HospitalIdle initialHospitalRegs isTerminal do+        B.from HospitalIdle do+            B.onCmd inCtorActivateSurge $ \d -> B.do+                B.emit wireSurgeActivated SurgeActivatedTermFields{hospitalId = d.hospitalId}+                B.goto HospitalSurging+  where+    isTerminal = \case+        HospitalSurging -> True+        _ -> False++-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the+-- pure event->status mapping is generated as hospitalStatusFor).+-- Fill against your codd-managed read-model table.+applyHospital :: HospitalEvent -> recorded -> txn ()+applyHospital _event _recorded = error "HOLE: fill hospital projection apply"
+ test/conformance-process-full/SurgeDemo/Surge/Holes.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- HAND-FILLED hole module (EP-3 M5 full-service integration): the saga+-- aggregate's transducer, filled against the generated signatures.+module SurgeDemo.Surge.Holes (+    surgeTransducer,+    applySurge,+) where++import Generated.SurgeDemo.Surge.Domain+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)++surgeTransducer ::+    SymTransducer+        (HsPred SurgeRegs SurgeCommand)+        SurgeRegs+        SurgeVertex+        SurgeCommand+        SurgeEvent+surgeTransducer =+    B.buildTransducer SurgeWatching initialSurgeRegs isTerminal do+        B.from SurgeWatching do+            B.onCmd inCtorNoteSurgeThreshold $ \d -> B.do+                B.emit wireSurgeThresholdNoted SurgeThresholdNotedTermFields{hospitalId = d.hospitalId}+                B.goto SurgeNoted+        B.from SurgeNoted do+            B.onCmd inCtorMarkSurgeTimerFired $ \d -> B.do+                B.emit wireSurgeTimerFired SurgeTimerFiredTermFields{hospitalId = d.hospitalId}+                B.goto SurgeFired+  where+    isTerminal = \case+        SurgeFired -> True+        _ -> False++applySurge :: SurgeEvent -> recorded -> txn ()+applySurge _event _recorded = error "HOLE: fill surge projection apply"
+ test/conformance-process-full/SurgeDemo/SurgeFlow/Manager.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++-- HAND-FILLED process-manager value (EP-3 M5 full-service integration): the+-- @handle@ hole filled against the live Keiro.ProcessManager API, wiring the+-- scaffolded Surge (saga) and Hospital (target) EventStreams plus the+-- scaffolded timer-request builder. This is the behaviour-bearing body the+-- scaffolder deliberately leaves as a hole (the firewall); here it is written+-- and type-checked against the runtime to prove the full service compiles.+--+-- The runtime dispatch worker may acknowledge @on-duplicate AckOk@ only after+-- @confirmBenignDuplicate@ proves the attempted event id exists in this+-- command's target stream. A hand-written dispatch path must preserve that+-- target-stream check; a bare global @DuplicateEvent@ is not sufficient.+module SurgeDemo.SurgeFlow.Manager (+    surgeManager,+    SurgeInput (..),+) where++import Data.Text (Text)+import Data.Time (UTCTime)+import Generated.SurgeDemo.Hospital.Domain qualified as H+import Generated.SurgeDemo.Hospital.EventStream (hospitalCategory, hospitalEventStream)+import Generated.SurgeDemo.Surge.Domain qualified as S+import Generated.SurgeDemo.Surge.EventStream (surgeEventStream)+import Generated.SurgeDemo.SurgeFlow.Process (surgeFlowCategory, surgeFlowTimerRequest)+import Keiki.Core (HsPred)+import Keiro.ProcessManager (PMCommand (..), ProcessManager (..), ProcessManagerAction (..))+import Keiro.Stream (entityStream)++data SurgeInput = SurgeInput+    { hospitalId :: Text+    , observedAt :: UTCTime+    }++surgeManager ::+    ProcessManager+        SurgeInput+        (HsPred S.SurgeRegs S.SurgeCommand)+        S.SurgeRegs+        S.SurgeVertex+        S.SurgeCommand+        S.SurgeEvent+        (HsPred H.HospitalRegs H.HospitalCommand)+        H.HospitalRegs+        H.HospitalVertex+        H.HospitalCommand+        H.HospitalEvent+surgeManager =+    ProcessManager+        { name = "surge-demo"+        , correlate = \i -> hospitalId (i :: SurgeInput)+        , eventStream = surgeEventStream+        , streamFor = entityStream surgeFlowCategory+        , targetEventStream = hospitalEventStream+        , targetProjections = const []+        , handle = \i ->+            ProcessManagerAction+                { command = S.NoteSurgeThreshold (S.NoteSurgeThresholdData (S.HospitalId (hospitalId i)))+                , commands =+                    [ PMCommand+                        { target = entityStream hospitalCategory (hospitalId i)+                        , command = H.ActivateSurge (H.ActivateSurgeData (H.HospitalId (hospitalId i)))+                        }+                    ]+                , timers = [surgeFlowTimerRequest (hospitalId i) (observedAt i)]+                }+        }
+ test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.HospitalSurge.Process (+    hospitalSurgeProcessName,+    hospitalSurgeCategory,+    hospitalSurgeProcessWorkerOptions,+    hospitalSurgeTimerRequest,+    hospitalSurgeFireOutcome,+) where++import Data.Aeson (Value, object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Data.UUID.V5 qualified as UUID.V5+import Keiro.Command (CommandError (..))+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Keiro.Stream qualified as Stream+import Keiro.Timer (TimerId (..), TimerRequest (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).+hospitalSurgeProcessName :: Text+hospitalSurgeProcessName = "hospital-surge"++-- The validated saga stream category (hole-kind 5: referenced, never retyped).+-- Saga streams are '<category>-<correlationId>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.+hospitalSurgeCategory :: Stream.StreamCategory a+hospitalSurgeCategory = Stream.categoryUnsafe "hospitalSurge"++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.ProcessManager.runProcessManagerWorkerWith.+hospitalSurgeProcessWorkerOptions :: WorkerOptions es msg+hospitalSurgeProcessWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedHalt+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }++-- The deterministic timer-request builder: id derived from the correlation+-- key (hole-kind 1), processManagerName referenced, payload from the spec.+-- (timer id derived as uuidv5 of "hospital-surge-timer:" <> correlationId)+hospitalSurgeTimerRequest :: Text -> UTCTime -> TimerRequest+hospitalSurgeTimerRequest correlationId fireAtTime =+    TimerRequest+        { timerId = TimerId (namedUuid ("hospital-surge-timer:" <> correlationId))+        , processManagerName = hospitalSurgeProcessName+        , correlationId = correlationId+        , fireAt = fireAtTime+        , payload = object ["kind" .= ("hospital-surge-follow-up" :: Value)]+        }++-- The timer-fire disposition table (hole-kind 2), derived from the spec.+-- on-reject => Fired is the benign inversion.+-- A duplicate append reaches on-error unless it is confirmed against the+-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:+--   StreamName -> EventId -> CommandError -> Eff es Bool+-- Fold True into the duplicate result and surface False as the failure.+hospitalSurgeFireOutcome :: Either CommandError a -> Maybe ()+hospitalSurgeFireOutcome result = case result of+    Right{} -> Just () -- Fired+    Left CommandRejected -> Just () -- Fired+    Left (CommandAmbiguous _) -> Nothing -- Retry  -- explicit definition-bug arm+    Left{} -> Nothing -- Retry++-- max-attempts = 5, dead-letter = "surge timer exceeded ceiling"+-- (the timer worker must pass Just 5 to runTimerWorkerWith, never the+--  defaultTimerWorkerOptions Nothing ceiling that retries forever).++-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1).+namedUuid :: Text -> UUID+namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))
+ test/conformance-process-runtime/Main.hs view
@@ -0,0 +1,62 @@+{- | EP-3 runtime conformance: the scaffolded process @Process@ module's+deterministic wiring — the timer-request builder (a real+@Keiro.Timer.TimerRequest@ with a v5-derived @TimerId@) and the fire+disposition over @Keiro.Command.CommandError@ — compiled against the LIVE+keiro runtime (not just emitted as text). Running it checks the+@on-reject => Fired@ benign inversion lowered correctly. (The full+ProcessManager value with a filled @handle@ remains the agent-written hole.)+-}+module Main (main) where++import Control.Monad (unless)+import Data.Text (Text)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Generated.HospitalCapacity.HospitalSurge.Process (+    hospitalSurgeFireOutcome,+    hospitalSurgeProcessName,+    hospitalSurgeProcessWorkerOptions,+    hospitalSurgeTimerRequest,+ )+import Keiro.Command (CommandError (..))+import Keiro.Dsl.Validate (sagaCategoryError)+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Keiro.Stream (CategoryError, StreamCategory, category)+import Keiro.Timer (TimerRequest (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    let nameOk = hospitalSurgeProcessName == "hospital-surge"+        -- the builder compiles against Keiro.Timer and names the queue.+        reqOk = processManagerName (hospitalSurgeTimerRequest "hosp-1" (posixSecondsToUTCTime 0)) == "hospital-surge"+        -- the disposition lowered from the spec: on-ok Fired, on-reject Fired.+        okOk = hospitalSurgeFireOutcome (Right () :: Either CommandError ()) == Just ()+        rejectOk = hospitalSurgeFireOutcome (Left CommandRejected :: Either CommandError ()) == Just ()+        ambiguousOk = hospitalSurgeFireOutcome (Left (CommandAmbiguous [0, 1]) :: Either CommandError ()) == Nothing+        rejectedPolicyOk = rejectedCommandPolicy hospitalSurgeProcessWorkerOptions == RejectedHalt+        poisonPolicyOk = poisonIsHalt hospitalSurgeProcessWorkerOptions+        categoryMirrorOk = all categoryAgreement ["hospitalSurge", "surge", "", "$all", "hospital-surge", "hospital surge", "bad\NULcategory"]+        colonReservedOk = sagaCategoryError "wf:surge" /= Nothing && not (runtimeRejectsCategory "wf:surge")+    putStrLn ("process name: " <> show nameOk)+    putStrLn ("timer request builds against Keiro.Timer: " <> show reqOk)+    putStrLn ("on-ok => Fired: " <> show okOk)+    putStrLn ("on-reject => Fired (benign inversion): " <> show rejectOk)+    putStrLn ("on-ambiguous => Retry: " <> show ambiguousOk)+    putStrLn ("rejected policy lowered: " <> show rejectedPolicyOk)+    putStrLn ("poison policy lowered: " <> show poisonPolicyOk)+    putStrLn ("DSL saga category mirror agrees with Keiro.Stream.category: " <> show categoryMirrorOk)+    putStrLn ("DSL additionally reserves ':' for workflow streams: " <> show colonReservedOk)+    unless (nameOk && reqOk && okOk && rejectOk && ambiguousOk && rejectedPolicyOk && poisonPolicyOk && categoryMirrorOk && colonReservedOk) exitFailure++categoryAgreement :: Text -> Bool+categoryAgreement value = (sagaCategoryError value /= Nothing) == runtimeRejectsCategory value++runtimeRejectsCategory :: Text -> Bool+runtimeRejectsCategory value = case category value :: Either CategoryError (StreamCategory ()) of+    Left _ -> True+    Right _ -> False++poisonIsHalt :: WorkerOptions es msg -> Bool+poisonIsHalt options = case poisonPolicy options of+    PoisonHalt -> True+    _ -> False
+ test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.HospitalSurge.ProcessHarness (processHarnessValues) where++{- | (label, value): the spec's deterministic process/timer decisions,+lowered to plain values so a driver can assert them against a committed+expectation. The driver's expectation is hand-written (not generated), so a+spec change that alters a decision diverges from it and turns a specific+assertion red — the spec->behaviour pin. (Live-runtime behavioural+conformance of the filled ProcessManager is the M5 step.)+-}+processHarnessValues :: [(String, String)]+processHarnessValues =+    [ ("fireAtField", "observedAt")+    , ("timerIdPrefix", "hospital-surge-timer:")+    , ("firedEventIdPrefix", "hospital-surge-fired:")+    , ("dispatchIdUserField", "none")+    , ("onReject", "Fired")+    , ("onAmbiguous", "Retry")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "halt")+    , ("poisonPolicy", "halt")+    , ("maxAttempts", "5")+    ]
+ test/conformance-process/Main.hs view
@@ -0,0 +1,44 @@+{- | Conformance driver for the hospital-surge process manager's spec-derived+facts harness (EP-3 M4/M5). The scaffolded @ProcessHarness@ module exports the+spec's deterministic process/timer decisions as plain values; this driver+asserts them against a HAND-WRITTEN expectation. Because the expectation is+not generated, a spec change that alters a decision (e.g. flipping the timer+@on-reject@ disposition from @Fired@ to @Retry@) diverges from it and turns a+specific assertion red — the spec->behaviour pin. (Behavioural conformance of+the /filled/ ProcessManager against the live effectful/hasql runtime is the+heavier remaining M5 step.)+-}+module Main (main) where++import Control.Monad (forM_, unless)+import Generated.HospitalCapacity.HospitalSurge.ProcessHarness (processHarnessValues)+import System.Exit (exitFailure)++-- | The expected lowering of hospital-surge.keiro's process/timer decisions.+expected :: [(String, String)]+expected =+    [ ("fireAtField", "observedAt") -- time is injected (deadline = window + observedAt)+    , ("timerIdPrefix", "hospital-surge-timer:") -- deterministic timer id+    , ("firedEventIdPrefix", "hospital-surge-fired:") -- deterministic fired-event id+    , ("dispatchIdUserField", "none") -- dispatch id is runtime-owned+    , ("onReject", "Fired") -- the benign inversion+    , ("onAmbiguous", "Retry") -- definition bugs retry to the timer ceiling+    , ("onFailed", "Retry") -- a real failure retries the source event+    , ("rejectedPolicy", "halt") -- rejection-class failures halt loudly+    , ("poisonPolicy", "halt") -- undecodable messages halt loudly+    , ("maxAttempts", "5") -- the ceiling is forced on+    ]++main :: IO ()+main = do+    results <-+        pure+            [ (label, lookup label processHarnessValues == Just want)+            | (label, want) <- expected+            ]+    forM_ results $ \(label, ok) ->+        putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    let failed = [label | (label, ok) <- results, not ok]+    unless (null failed) $ do+        putStrLn ("process harness: " <> show (length failed) <> " assertion(s) failed: " <> show failed)+        exitFailure
+ test/conformance-publisher-runtime/Generated/HospitalCapacity/HospitalPublisher/Publisher.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.HospitalPublisher.Publisher+  ( publisherOrdering+  , publisherBackoff+  , publisherMaxAttempts+  ) where++import Keiro.Outbox.Types (BackoffSchedule (..), OrderingPolicy (..))++publisherOrdering :: OrderingPolicy+publisherOrdering = PerKeyHeadOfLine++publisherBackoff :: BackoffSchedule+publisherBackoff = ConstantBackoff 2++publisherMaxAttempts :: Int+publisherMaxAttempts = 10
+ test/conformance-publisher-runtime/Main.hs view
@@ -0,0 +1,24 @@+{- | EP-4 publisher runtime conformance: the scaffolded @Publisher@ config —+ordering policy, backoff curve, max-attempts — compiled against the LIVE+@Keiro.Outbox.Types@ (OrderingPolicy / BackoffSchedule).+-}+module Main (main) where++import Control.Monad (unless)+import Generated.HospitalCapacity.HospitalPublisher.Publisher (+    publisherBackoff,+    publisherMaxAttempts,+    publisherOrdering,+ )+import Keiro.Outbox.Types (BackoffSchedule (..), OrderingPolicy (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    let orderingOk = publisherOrdering == PerKeyHeadOfLine+        backoffOk = case publisherBackoff of ConstantBackoff d -> d == 2; _ -> False+        attemptsOk = publisherMaxAttempts == 10+    putStrLn ("ordering = PerKeyHeadOfLine: " <> show orderingOk)+    putStrLn ("backoff = ConstantBackoff 2s: " <> show backoffOk)+    putStrLn ("maxAttempts = 10: " <> show attemptsOk)+    unless (orderingOk && backoffOk && attemptsOk) exitFailure
+ test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/Queue.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation_work.Queue (+    ReservationWorkItem (..),+    encodeReservationWorkItem,+    parseReservationWorkItem,+    queuePhysical,+    queueDlq,+    queueTable,+    groupKeyField,+    groupKeyFor,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.Text (Text)+import Data.Text qualified as T++queuePhysical, queueDlq, queueTable :: Text+queuePhysical = "hospital_capacity_reservation_work"+queueDlq = "hospital_capacity_reservation_work_dlq"+queueTable = "pgmq.q_hospital_capacity_reservation_work"++groupKeyField :: Text+groupKeyField = "reservationId"++groupKeyFor :: ReservationWorkItem -> Text+groupKeyFor payload = payload.reservationId++data ReservationWorkItem = ReservationWorkItem+    { reservationId :: !Text+    , hospitalId :: !Text+    , commandId :: !Text+    , lifeCriticalOverride :: !Bool+    }+    deriving stock (Eq, Show)++encodeReservationWorkItem :: ReservationWorkItem -> Value+encodeReservationWorkItem p =+    object+        [ "reservation_id" .= p.reservationId+        , "hospital_id" .= p.hospitalId+        , "command_id" .= p.commandId+        , "life_critical_override" .= p.lifeCriticalOverride+        ]++parseReservationWorkItem :: Value -> Either Text ReservationWorkItem+parseReservationWorkItem = mapLeftText . parseEither (withObject "ReservationWorkItem" go)+  where+    go o = ReservationWorkItem <$> o .: "reservation_id" <*> o .: "hospital_id" <*> o .: "command_id" <*> o .: "life_critical_override"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueuePolicy.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation_work.QueuePolicy (+    retryPolicy,+    jobOutcomeFor,+    jobOrdering,+    jobTuningFor,+    queueProvision,+) where++import Data.Text (Text)+import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)++jobOrdering :: JobOrdering+jobOrdering = FifoThroughput++-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.+jobTuningFor :: JobTuning -> JobTuning+jobTuningFor = withOrdering jobOrdering++-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.+queueProvision :: QueueProvision+queueProvision = withFifoIndexProvision (standardProvision)++retryPolicy :: RetryPolicy+retryPolicy =+    RetryPolicy+        { maxRetries = 3+        , defaultRetryDelay = RetryDelay 5+        , useDeadLetter = True+        }++-- The consumer JobOutcome disposition over the spec's named domain outcomes,+-- lowered to the live Keiro.PGMQ.Job.JobOutcome.+jobOutcomeFor :: Text -> JobOutcome+jobOutcomeFor o = case o of+    "storeFailure" -> Retry (RetryDelay 5)+    "commandRejected" -> Dead "dead-lettered"+    "decodeFailure" -> Dead "dead-lettered"+    "onCodecReject" -> Dead "dead-lettered"+    _ -> Retry (RetryDelay 5)
+ test/conformance-queue-runtime/Main.hs view
@@ -0,0 +1,83 @@+{- | EP-5 runtime conformance: the scaffolded pgmq @QueuePolicy@ — the+@RetryPolicy@ and the @JobOutcome@ disposition — compiled against the LIVE+@Keiro.PGMQ.Job@ runtime. Running it pins the dangerous inversions over the+real JobOutcome: storeFailure ⇒ Retry (transient) and decodeFailure ⇒ Dead+(poison), plus the dlq=on ceiling.+-}+module Main (main) where++import Control.Monad (unless)+import Data.Text (Text)+import Generated.HospitalCapacity.Reservation_work.Queue (ReservationWorkItem (..), encodeReservationWorkItem, groupKeyFor, parseReservationWorkItem)+import Generated.HospitalCapacity.Reservation_work.QueuePolicy (jobOrdering, jobOutcomeFor, jobTuningFor, queueProvision, retryPolicy)+import Keiro.Dsl.Validate (derivedQueueTrio)+import Keiro.PGMQ.Codec (mkJobCodec)+import Keiro.PGMQ.Job (Job (..), JobOrdering (..), JobOutcome (..), JobTuning (..), RetryPolicy (..), defaultJobTuning, queueProvisionConfigs)+import Keiro.PGMQ.Runtime (QueueRef (..), queueRef)+import Pgmq.Config qualified as Config+import Pgmq.Types (queueNameToText)+import System.Exit (exitFailure)++isRetry :: JobOutcome -> Bool+isRetry (Retry _) = True+isRetry _ = False++isDead :: JobOutcome -> Bool+isDead (Dead _) = True+isDead _ = False++main :: IO ()+main = do+    let storeOk = isRetry (jobOutcomeFor "storeFailure") -- transient: MUST retry+        decodeOk = isDead (jobOutcomeFor "decodeFailure") -- poison: MUST dead-letter+        ceilingOk = maxRetries retryPolicy == 3 && useDeadLetter retryPolicy+        orderingOk = jobOrdering == FifoThroughput+        tuningOk = ordering (jobTuningFor defaultJobTuning) == FifoThroughput+        job =+            Job+                { jobName = "reservation-work"+                , jobQueue = queueRef "hospital_capacity.reservation_work"+                , jobCodec = mkJobCodec encodeReservationWorkItem parseReservationWorkItem+                , jobPolicy = retryPolicy+                }+        provisionOk = case queueProvisionConfigs queueProvision job of+            [mainQueue, deadLetterQueue] ->+                Config.fifoIndex mainQueue+                    && not (Config.fifoIndex deadLetterQueue)+                    && isStandard mainQueue+                    && isStandard deadLetterQueue+            _ -> False+        groupKeyOk = groupKeyFor (ReservationWorkItem "rsv-123" "hsp-1" "cmd-1" True) == "rsv-123"+        vectors =+            [ "hospital_capacity.reservation_work"+            , "Repro.Work"+            , "a__b..c"+            , "9lives"+            , "already_dlq"+            , "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments"+            ]+        parity = [(logical, derivedQueueTrio logical == liveQueueTrio logical) | logical <- vectors]+    putStrLn ("storeFailure => Retry (transient): " <> show storeOk)+    putStrLn ("decodeFailure => Dead (poison): " <> show decodeOk)+    putStrLn ("retry ceiling + dlq on: " <> show ceilingOk)+    putStrLn ("ordering lowered to FifoThroughput: " <> show orderingOk)+    putStrLn ("provision includes the FIFO index: " <> show provisionOk)+    putStrLn ("groupKeyFor projects the payload field: " <> show groupKeyOk)+    putStrLn ("jobTuningFor overlays deployment tuning: " <> show tuningOk)+    mapM_ (\(logical, matches) -> putStrLn ("derivedQueueTrio " <> show logical <> " == live queueRef: " <> show matches)) parity+    unless (storeOk && decodeOk && ceilingOk && orderingOk && provisionOk && groupKeyOk && tuningOk && all snd parity) exitFailure++liveQueueTrio :: Text -> (Text, Text, Text)+liveQueueTrio logical =+    ( physical+    , queueNameToText (dlqName ref)+    , "pgmq.q_" <> physical+    )+  where+    ref = queueRef logical+    physical = queueNameToText (physicalName ref)++isStandard :: Config.QueueConfig -> Bool+isStandard config = case Config.queueType config of+    Config.StandardQueue -> True+    _ -> False
+ test/conformance-queue/Generated/HospitalCapacity/Reservation_work/Queue.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation_work.Queue (+    ReservationWorkItem (..),+    encodeReservationWorkItem,+    parseReservationWorkItem,+    queuePhysical,+    queueDlq,+    queueTable,+    groupKeyField,+    groupKeyFor,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.Text (Text)+import Data.Text qualified as T++queuePhysical, queueDlq, queueTable :: Text+queuePhysical = "hospital_capacity_reservation_work"+queueDlq = "hospital_capacity_reservation_work_dlq"+queueTable = "pgmq.q_hospital_capacity_reservation_work"++groupKeyField :: Text+groupKeyField = "reservationId"++groupKeyFor :: ReservationWorkItem -> Text+groupKeyFor payload = payload.reservationId++data ReservationWorkItem = ReservationWorkItem+    { reservationId :: !Text+    , hospitalId :: !Text+    , commandId :: !Text+    , lifeCriticalOverride :: !Bool+    }+    deriving stock (Eq, Show)++encodeReservationWorkItem :: ReservationWorkItem -> Value+encodeReservationWorkItem p =+    object+        [ "reservation_id" .= p.reservationId+        , "hospital_id" .= p.hospitalId+        , "command_id" .= p.commandId+        , "life_critical_override" .= p.lifeCriticalOverride+        ]++parseReservationWorkItem :: Value -> Either Text ReservationWorkItem+parseReservationWorkItem = mapLeftText . parseEither (withObject "ReservationWorkItem" go)+  where+    go o = ReservationWorkItem <$> o .: "reservation_id" <*> o .: "hospital_id" <*> o .: "command_id" <*> o .: "life_critical_override"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-queue/Main.hs view
@@ -0,0 +1,22 @@+{- | Conformance driver for the scaffolded EP-5 pgmq Job codec. Compiling this+component proves the scaffolded @Generated.…Reservation_work.Queue@ module+(the Job payload record + field->wire JSON codec + physical/dlq/table+constants) is real, self-contained Haskell; running it proves the payload+round-trips through encode/decode and the captured physical name is exposed.+-}+module Main (main) where++import Control.Monad (unless)+import Generated.HospitalCapacity.Reservation_work.Queue+import System.Exit (exitFailure)++main :: IO ()+main = do+    let sample = ReservationWorkItem "rsv-1" "hsp-1" "cmd-1" True+        roundTrips = parseReservationWorkItem (encodeReservationWorkItem sample) == Right sample+        physicalOk = queuePhysical == "hospital_capacity_reservation_work"+        groupKeyOk = groupKeyFor sample == "rsv-1"+    putStrLn ((if roundTrips then "PASS  " else "FAIL  ") <> "Job codec round-trip")+    putStrLn ((if physicalOk then "PASS  " else "FAIL  ") <> "captured physical name")+    putStrLn ((if groupKeyOk then "PASS  " else "FAIL  ") <> "raw FIFO group-key projection")+    unless (roundTrips && physicalOk && groupKeyOk) exitFailure
+ test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModel.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Transfer_decisions.ReadModel (+    transferDecisionsReadModel,+    transferDecisionsQualifiedTable,+    registerTransferDecisions,+    startTransferDecisionsRebuild,+    finishTransferDecisionsRebuild,+    abandonTransferDecisionsRebuild,+    transferDecisionsAsyncProjection,+) where++import Data.Functor (void)+import Effectful (Eff, (:>))+import Generated.HospitalCapacity.Transfer_decisions.ReadModelTable (transferDecisionsQualifiedTable)+import HospitalCapacity.Transfer_decisions.ReadModelHoles (TransferDecisionsQueryInput, TransferDecisionsQueryResult, applyTransferDecisions, transferDecisionsQuery)+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition, RecordedEvent (..))++transferDecisionsReadModel :: ReadModel TransferDecisionsQueryInput TransferDecisionsQueryResult+transferDecisionsReadModel =+    ReadModel+        { name = "hospital-capacity-transfer-decisions"+        , tableName = "transfer_decisions"+        , schema = "hospital_capacity"+        , subscriptionName = "hospital-capacity-transfer-decisions-sub"+        , version = 1+        , shapeHash = "fnv1a:3717f6d9e3c44bd6"+        , defaultConsistency = Strong+        , strongScope = CategoryHead "reservation"+        , query = transferDecisionsQuery+        }++-- Call once at projection startup before serving queries.+registerTransferDecisions :: (Store :> es) => Eff es ()+registerTransferDecisions =+    void (registerReadModel "hospital-capacity-transfer-decisions" 1 "fnv1a:3717f6d9e3c44bd6")++startTransferDecisionsRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+startTransferDecisionsRebuild =+    Rebuild.startRebuild transferDecisionsReadModel ["hospital-capacity-transfer-decisions-async"]++finishTransferDecisionsRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)+finishTransferDecisionsRebuild =+    Rebuild.finishRebuild transferDecisionsReadModel ["hospital-capacity-transfer-decisions-async"]++abandonTransferDecisionsRebuild :: (Store :> es) => Eff es ReadModelMetadata+abandonTransferDecisionsRebuild = Rebuild.abandonRebuild transferDecisionsReadModel++transferDecisionsAsyncProjection :: AsyncProjection+transferDecisionsAsyncProjection =+    AsyncProjection+        { name = "hospital-capacity-transfer-decisions-async"+        , readModelName = "hospital-capacity-transfer-decisions"+        , subscriptionName = "hospital-capacity-transfer-decisions-sub"+        , applyRecorded = applyTransferDecisions+        , idempotencyKey = \recorded -> recorded.eventId+        }
+ test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModelHarness.hs view
@@ -0,0 +1,19 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Transfer_decisions.ReadModelHarness (readModelFacts, runReadModelFacts) where++-- | (fact, expected from notation, actual shared derivation/lowering).+readModelFacts :: [(String, String, String)]+readModelFacts =+    [ ("registryName", "hospital-capacity-transfer-decisions", "hospital-capacity-transfer-decisions")+    , ("subscriptionName", "hospital-capacity-transfer-decisions-sub", "hospital-capacity-transfer-decisions-sub")+    , ("shapeHash", "fnv1a:3717f6d9e3c44bd6", "fnv1a:3717f6d9e3c44bd6")+    , ("asyncProjectionName", "hospital-capacity-transfer-decisions-async", "hospital-capacity-transfer-decisions-async")+    , ("consistency", "Strong", "Strong")+    , ("strongScope", "CategoryHead reservation", "CategoryHead reservation")+    ]++runReadModelFacts :: IO Bool+runReadModelFacts = do+    let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]+    mapM_ (\(fact, expected, actual) -> putStrLn ("FAIL  " <> fact <> " expected=" <> show expected <> " actual=" <> show actual)) failures+    pure (null failures)
+ test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModelTable.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Transfer_decisions.ReadModelTable (transferDecisionsQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+transferDecisionsQualifiedTable :: Text+transferDecisionsQualifiedTable = qualifyTable "hospital_capacity" "transfer_decisions"
+ test/conformance-readmodel-runtime/HospitalCapacity/Transfer_decisions/ReadModelHoles.hs view
@@ -0,0 +1,30 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module HospitalCapacity.Transfer_decisions.ReadModelHoles (+    TransferDecisionsQueryInput,+    TransferDecisionsQueryResult,+    transferDecisionsQuery,+    applyTransferDecisions,+) where++import Data.Text.Encoding qualified as Text+import Generated.HospitalCapacity.Transfer_decisions.ReadModelTable (transferDecisionsQualifiedTable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent)++-- HOLE: replace these aliases with the real query input and result types.+type TransferDecisionsQueryInput = ()+type TransferDecisionsQueryResult = ()++-- HOLE: query "hospital_capacity"."transfer_decisions" via transferDecisionsQualifiedTable; never rely on search_path.+-- Declared columns:+--   reservation_id text NOT NULL+--   hospital_id text NOT NULL+--   status text NOT NULL+--   decided_at timestamptz+transferDecisionsQuery :: TransferDecisionsQueryInput -> Tx.Transaction TransferDecisionsQueryResult+transferDecisionsQuery _input =+    Tx.sql (Text.encodeUtf8 ("SELECT count(*) FROM " <> transferDecisionsQualifiedTable))++-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.+applyTransferDecisions :: RecordedEvent -> Tx.Transaction ()+applyTransferDecisions _recorded = pure ()
+ test/conformance-readmodel-runtime/Main.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (unless)+import Effectful (Eff, (:>))+import Generated.HospitalCapacity.Transfer_decisions.ReadModel+import Generated.HospitalCapacity.Transfer_decisions.ReadModelHarness (readModelFacts, runReadModelFacts)+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), qualifiedTableName)+import Keiro.ReadModel.Rebuild (RebuildError)+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition)+import System.Exit (exitFailure)++main :: IO ()+main = do+    factsOk <- runReadModelFacts+    let recordOk =+            transferDecisionsReadModel.name == "hospital-capacity-transfer-decisions"+                && transferDecisionsReadModel.tableName == "transfer_decisions"+                && transferDecisionsReadModel.schema == "hospital_capacity"+                && transferDecisionsReadModel.subscriptionName == "hospital-capacity-transfer-decisions-sub"+                && transferDecisionsReadModel.version == 1+                && transferDecisionsReadModel.shapeHash == "fnv1a:3717f6d9e3c44bd6"+        consistencyOk = case transferDecisionsReadModel.defaultConsistency of+            Strong -> True+            _ -> False+        scopeOk = case transferDecisionsReadModel.strongScope of+            CategoryHead "reservation" -> True+            _ -> False+        qualifiedTableOk =+            qualifiedTableName transferDecisionsReadModel == transferDecisionsQualifiedTable+                && transferDecisionsQualifiedTable == "\"hospital_capacity\".\"transfer_decisions\""+        asyncOk =+            transferDecisionsAsyncProjection.readModelName == transferDecisionsReadModel.name+                && transferDecisionsAsyncProjection.subscriptionName == transferDecisionsReadModel.subscriptionName+                && transferDecisionsAsyncProjection.name == "hospital-capacity-transfer-decisions-async"+        allOk = factsOk && all (\(_, expected, actual) -> expected == actual) readModelFacts && recordOk && consistencyOk && scopeOk && qualifiedTableOk && asyncOk+    putStrLn ("read-model facts: " <> show factsOk)+    putStrLn ("runtime record: " <> show recordOk)+    putStrLn ("consistency/scope: " <> show (consistencyOk && scopeOk))+    putStrLn ("qualified table: " <> show qualifiedTableOk)+    putStrLn ("async identity: " <> show asyncOk)+    unless allOk exitFailure++_usesRegister :: (Store :> es) => Eff es ()+_usesRegister = registerTransferDecisions++_usesStartRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+_usesStartRebuild = startTransferDecisionsRebuild++_usesFinishRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either RebuildError ReadModelMetadata)+_usesFinishRebuild = finishTransferDecisionsRebuild++_usesAbandonRebuild :: (Store :> es) => Eff es ReadModelMetadata+_usesAbandonRebuild = abandonTransferDecisionsRebuild
+ test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.Page.Codec (+    pageCodec,+    parsePageEvent,+    encodePageEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.IncidentPaging.Page.Domain+import Keiro.Codec (Codec (..), EventType (..))++pageCodec :: Codec PageEvent+pageCodec =+    Codec+        { eventTypes = EventType "PageSent" :| []+        , eventType = \case+            PageSent{} -> EventType "PageSent"+        , schemaVersion = 1+        , encode = encodePageEvent+        , decode = parsePageEvent+        , upcasters = []+        }++encodePageEvent :: PageEvent -> Value+encodePageEvent = \case+    PageSent payload ->+        object+            [ "kind" .= ("PageSent" :: Text)+            , "incidentId" .= payload.incidentId+            , "responderId" .= payload.responderId+            ]++parsePageEvent :: EventType -> Value -> Either Text PageEvent+parsePageEvent (EventType tag) = mapLeftText . parseEither (withObject "PageEvent" go)+  where+    go o = do+        case tag of+            "PageSent" ->+                PageSent <$> (PageSentData <$> o .: "incidentId" <*> o .: "responderId")+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.Page.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data PageVertex = PagePending | PageDelivered+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data SendPageData = SendPageData+    { incidentId :: !Text+    , responderId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data PageCommand = SendPage !SendPageData+    deriving stock (Generic, Eq, Show)++data PageSentData = PageSentData+    { incidentId :: !Text+    , responderId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data PageEvent = PageSent !PageSentData+    deriving stock (Generic, Eq, Show)++type PageRegs =+    '[]++initialPageRegs :: RegFile PageRegs+initialPageRegs =+    RNil++$(deriveAggregateCtorsAll ''PageCommand ''PageRegs)++$(deriveWireCtorsAll ''PageEvent)
+ test/conformance-router-full/Generated/IncidentPaging/Page/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.Page.EventStream (+    pageCategory,+    pageEventStream,+    pageEventStreamDef,+    PageEventStream,+    PageEventStreamDef,+) where++import Generated.IncidentPaging.Page.Codec (pageCodec)+import Generated.IncidentPaging.Page.Domain+import IncidentPaging.Page.Holes (pageTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+pageCategory :: Stream.StreamCategory a+pageCategory = Stream.categoryUnsafe "page"++type PageEventStreamDef =+    EventStream (HsPred PageRegs PageCommand) PageRegs PageVertex PageCommand PageEvent++type PageEventStream =+    ValidatedEventStream (HsPred PageRegs PageCommand) PageRegs PageVertex PageCommand PageEvent++pageEventStreamDef :: PageEventStreamDef+pageEventStreamDef =+    EventStream+        { transducer = pageTransducer+        , initialState = PagePending+        , initialRegisters = initialPageRegs+        , eventCodec = pageCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++pageEventStream :: PageEventStream+pageEventStream =+    mkEventStreamOrThrow "Page" pageEventStreamDef
+ test/conformance-router-full/Generated/IncidentPaging/PagingRouter/Router.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.PagingRouter.Router (+    pagingRouterName,+    pagingRouterWorkerOptions,+) where++import Data.Text (Text)+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The STABLE router name. It participates in every target-keyed+-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.+pagingRouterName :: Text+pagingRouterName = "jitsurei-paging"++-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,+-- targetStreamName, occurrence). Target-keyed, not positional.++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions.+pagingRouterWorkerOptions :: WorkerOptions es msg+pagingRouterWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedDeadLetter+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }
+ test/conformance-router-full/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view
@@ -0,0 +1,16 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues) where++routerHarnessValues :: [(String, String)]+routerHarnessValues =+    [ ("routerName", "jitsurei-paging")+    , ("keyField", "incidentId")+    , ("resolveSource", "read-model service_oncall")+    , ("resolveRow", "responderId")+    , ("dispatchCommand", "SendPage")+    , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+    , ("onDuplicate", "AckOk")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "deadLetter")+    , ("poisonPolicy", "halt")+    ]
+ test/conformance-router-full/IncidentPaging/Page/Holes.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module IncidentPaging.Page.Holes (+    pageTransducer,+    -- (no projection)+) where++import Generated.IncidentPaging.Page.Domain+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+pageTransducer ::+    SymTransducer+        (HsPred PageRegs PageCommand)+        PageRegs+        PageVertex+        PageCommand+        PageEvent+pageTransducer =+    B.buildTransducer PagePending initialPageRegs isTerminal do+        B.from PagePending do+            B.onCmd inCtorSendPage $ \d -> B.do+                B.emit wirePageSent PageSentTermFields{incidentId = d.incidentId, responderId = d.responderId}+                B.goto PageDelivered+  where+    isTerminal = \case+        PageDelivered -> True+        _ -> False
+ test/conformance-router-full/IncidentPaging/PagingRouter/RouterValue.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}++module IncidentPaging.PagingRouter.RouterValue (+    IncidentRaised (..),+    pagingRouter,+    resolveTargets,+) where++import Data.Text (Text)+import Effectful (Eff)+import Generated.IncidentPaging.Page.Domain qualified as Page+import Generated.IncidentPaging.Page.EventStream (pageCategory, pageEventStream)+import Generated.IncidentPaging.PagingRouter.Router (pagingRouterName)+import Keiki.Core (HsPred)+import Keiro.ProcessManager (PMCommand (..))+import Keiro.Router (Router (..))+import Keiro.Stream (entityStream)++data IncidentRaised = IncidentRaised+    { incidentId :: !Text+    , service :: !Text+    }+    deriving stock (Eq, Show)++resolveTargets :: IncidentRaised -> Eff '[] [PMCommand Page.PageCommand]+resolveTargets input =+    pure+        [ PMCommand+            { target = entityStream pageCategory (input.incidentId <> "-responder-a")+            , command = Page.SendPage (Page.SendPageData input.incidentId "responder-a")+            }+        , PMCommand+            { target = entityStream pageCategory (input.incidentId <> "-responder-b")+            , command = Page.SendPage (Page.SendPageData input.incidentId "responder-b")+            }+        ]++pagingRouter ::+    Router+        IncidentRaised+        (HsPred Page.PageRegs Page.PageCommand)+        Page.PageRegs+        Page.PageVertex+        Page.PageCommand+        Page.PageEvent+        '[]+pagingRouter =+    Router+        { name = pagingRouterName+        , key = \input -> input.incidentId+        , resolve = resolveTargets+        , targetEventStream = pageEventStream+        , targetProjections = const []+        }
+ test/conformance-router-full/Main.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Main (main) where++import Control.Monad (unless)+import Effectful (runPureEff)+import Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues)+import IncidentPaging.PagingRouter.RouterValue (IncidentRaised (..), pagingRouter)+import Keiro.ProcessManager (PMCommand (..))+import Keiro.Router (Router (..))+import Keiro.Stream (stream)+import System.Exit (exitFailure)++main :: IO ()+main = do+    let input = IncidentRaised{incidentId = "incident-1", service = "cardiology"}+        commands = runPureEff (pagingRouter.resolve input)+        targets = map target commands+        checks =+            [ ("router name", pagingRouter.name == "jitsurei-paging")+            , ("router key", pagingRouter.key input == "incident-1")+            , ("resolver returns the expected targets", targets == [stream "page-incident-1-responder-a", stream "page-incident-1-responder-b"])+            , ("harness policy", lookup "rejectedPolicy" routerHarnessValues == Just "deadLetter")+            ]+    mapM_ (\(label, ok) -> putStrLn (label <> ": " <> show ok)) checks+    unless (all snd checks) exitFailure
+ test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/Router.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.PagingRouter.Router (+    pagingRouterName,+    pagingRouterWorkerOptions,+) where++import Data.Text (Text)+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The STABLE router name. It participates in every target-keyed+-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.+pagingRouterName :: Text+pagingRouterName = "jitsurei-paging"++-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,+-- targetStreamName, occurrence). Target-keyed, not positional.++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions.+pagingRouterWorkerOptions :: WorkerOptions es msg+pagingRouterWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedDeadLetter+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }
+ test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view
@@ -0,0 +1,16 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues) where++routerHarnessValues :: [(String, String)]+routerHarnessValues =+    [ ("routerName", "jitsurei-paging")+    , ("keyField", "incidentId")+    , ("resolveSource", "read-model service_oncall")+    , ("resolveRow", "responderId")+    , ("dispatchCommand", "SendPage")+    , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+    , ("onDuplicate", "AckOk")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "deadLetter")+    , ("poisonPolicy", "halt")+    ]
+ test/conformance-router-runtime/Main.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DataKinds #-}++module Main (main) where++import Control.Monad (unless)+import Data.UUID qualified as UUID+import Generated.IncidentPaging.PagingRouter.Router (pagingRouterName, pagingRouterWorkerOptions)+import Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues)+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Keiro.Router (deterministicRouterCommandId)+import Kiroku.Store.Types (EventId (..), StreamName (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    let sourceEventId = EventId UUID.nil+        first = deterministicRouterCommandId pagingRouterName "incident-1" sourceEventId (StreamName "page-a") 0+        same = deterministicRouterCommandId pagingRouterName "incident-1" sourceEventId (StreamName "page-a") 0+        otherTarget = deterministicRouterCommandId pagingRouterName "incident-1" sourceEventId (StreamName "page-b") 0+        otherOccurrence = deterministicRouterCommandId pagingRouterName "incident-1" sourceEventId (StreamName "page-a") 1+        checks =+            [ ("router name", pagingRouterName == "jitsurei-paging")+            , ("rejected policy lowered", rejectedCommandPolicy pagingRouterWorkerOptions == RejectedDeadLetter)+            , ("poison policy lowered", poisonIsHalt pagingRouterWorkerOptions)+            , ("id stable across calls", first == same)+            , ("id discriminates target stream", first /= otherTarget)+            , ("id discriminates occurrence", first /= otherOccurrence)+            , ("harness pins target-keyed inputs", lookup "dispatchIdInputs" routerHarnessValues == Just "(name, key, sourceEventId, targetStreamName, occurrence)")+            ]+    mapM_ (\(label, ok) -> putStrLn (label <> ": " <> show ok)) checks+    unless (all snd checks) exitFailure++poisonIsHalt :: WorkerOptions es msg -> Bool+poisonIsHalt options = case poisonPolicy options of+    PoisonHalt -> True+    _ -> False
+ test/conformance-router/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view
@@ -0,0 +1,16 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues) where++routerHarnessValues :: [(String, String)]+routerHarnessValues =+    [ ("routerName", "jitsurei-paging")+    , ("keyField", "incidentId")+    , ("resolveSource", "read-model service_oncall")+    , ("resolveRow", "responderId")+    , ("dispatchCommand", "SendPage")+    , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+    , ("onDuplicate", "AckOk")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "deadLetter")+    , ("poisonPolicy", "halt")+    ]
+ test/conformance-router/Main.hs view
@@ -0,0 +1,28 @@+module Main (main) where++import Control.Monad (forM_, unless)+import Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues)+import System.Exit (exitFailure)++expected :: [(String, String)]+expected =+    [ ("routerName", "jitsurei-paging")+    , ("keyField", "incidentId")+    , ("resolveSource", "read-model service_oncall")+    , ("resolveRow", "responderId")+    , ("dispatchCommand", "SendPage")+    , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+    , ("onDuplicate", "AckOk")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "deadLetter")+    , ("poisonPolicy", "halt")+    ]++main :: IO ()+main = do+    let results = [(label, lookup label routerHarnessValues == Just value) | (label, value) <- expected]+        failed = [label | (label, ok) <- results, not ok]+    forM_ results $ \(label, ok) -> putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    unless (null failed) $ do+        putStrLn ("router harness: " <> show (length failed) <> " assertion(s) failed: " <> show failed)+        exitFailure
+ test/conformance-skeletons/Main.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import Control.Monad (unless)+import SkelAggregate.Generated.MyService.Thing.Harness (harnessAssertions)+import SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowFacts (workflowFacts)++main :: IO ()+main = do+    mapM_ assertHarness harnessAssertions+    unless (not (null workflowFacts)) (fail "workflow skeleton emitted no facts")+    putStrLn "PASS  every committed skeleton scaffold compiles"+    putStrLn "PASS  aggregate skeleton harness"+    putStrLn "PASS  workflow skeleton facts"+  where+    assertHarness (label, passed) = unless passed (fail label)
+ test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Codec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelAggregate.Generated.MyService.Thing.Codec (+    thingCodec,+    parseThingEvent,+    encodeThingEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Codec (Codec (..), EventType (..))+import SkelAggregate.Generated.MyService.Thing.Domain++thingCodec :: Codec ThingEvent+thingCodec =+    Codec+        { eventTypes = EventType "ThingCompleted" :| []+        , eventType = \case+            ThingCompleted{} -> EventType "ThingCompleted"+        , schemaVersion = 1+        , encode = encodeThingEvent+        , decode = parseThingEvent+        , upcasters = []+        }++encodeThingEvent :: ThingEvent -> Value+encodeThingEvent = \case+    ThingCompleted payload ->+        object+            [ "kind" .= ("ThingCompleted" :: Text)+            , "thingId" .= thingIdText payload.thingId+            , "attempt" .= payload.attempt+            ]++parseThingEvent :: EventType -> Value -> Either Text ThingEvent+parseThingEvent (EventType tag) = mapLeftText . parseEither (withObject "ThingEvent" go)+  where+    go o = do+        case tag of+            "ThingCompleted" ->+                ThingCompleted <$> (ThingCompletedData <$> (ThingId <$> o .: "thingId") <*> o .: "attempt")+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Domain.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelAggregate.Generated.MyService.Thing.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype ThingId = ThingId Text+    deriving stock (Generic, Eq, Ord, Show)++thingIdText :: ThingId -> Text+thingIdText (ThingId t) = t++data ThingVertex = ThingPending | ThingDone+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data DoThingData = DoThingData+    { thingId :: !ThingId+    , attempt :: !Int+    }+    deriving stock (Generic, Eq, Show)++data ThingCommand = DoThing !DoThingData+    deriving stock (Generic, Eq, Show)++data ThingCompletedData = ThingCompletedData+    { thingId :: !ThingId+    , attempt :: !Int+    }+    deriving stock (Generic, Eq, Show)++data ThingEvent = ThingCompleted !ThingCompletedData+    deriving stock (Generic, Eq, Show)++type ThingRegs =+    '[ '("thingId", ThingId)+     , '("state", ThingVertex)+     ]++initialThingRegs :: RegFile ThingRegs+initialThingRegs =+    RCons (Proxy @"thingId") (ThingId "") $+        RCons (Proxy @"state") ThingPending RNil++$(deriveAggregateCtorsAll ''ThingCommand ''ThingRegs)++$(deriveWireCtorsAll ''ThingEvent)
+ test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelAggregate.Generated.MyService.Thing.EventStream (+    thingCategory,+    thingEventStream,+    thingEventStreamDef,+    ThingEventStream,+    ThingEventStreamDef,+) where++import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import SkelAggregate.Generated.MyService.Thing.Codec (thingCodec)+import SkelAggregate.Generated.MyService.Thing.Domain+import SkelAggregate.MyService.Thing.Holes (thingTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+thingCategory :: Stream.StreamCategory a+thingCategory = Stream.categoryUnsafe "thing"++type ThingEventStreamDef =+    EventStream (HsPred ThingRegs ThingCommand) ThingRegs ThingVertex ThingCommand ThingEvent++type ThingEventStream =+    ValidatedEventStream (HsPred ThingRegs ThingCommand) ThingRegs ThingVertex ThingCommand ThingEvent++thingEventStreamDef :: ThingEventStreamDef+thingEventStreamDef =+    EventStream+        { transducer = thingTransducer+        , initialState = ThingPending+        , initialRegisters = initialThingRegs+        , eventCodec = thingCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++thingEventStream :: ThingEventStream+thingEventStream =+    mkEventStreamOrThrow "Thing" thingEventStreamDef
+ test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelAggregate.Generated.MyService.Thing.Harness (harnessAssertions) where++import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import SkelAggregate.Generated.MyService.Thing.Codec (encodeThingEvent, parseThingEvent, thingCodec)+import SkelAggregate.Generated.MyService.Thing.Domain+import SkelAggregate.MyService.Thing.Holes (thingTransducer)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions thingTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: ThingCompleted", roundTrips sampleEventThingCompleted)+    , ("accepts DoThing from ThingPending", acceptDoThing)+    ]++roundTrips :: ThingEvent -> Bool+roundTrips e = parseThingEvent (eventType thingCodec e) (encodeThingEvent e) == Right e++sampleEventThingCompleted :: ThingEvent+sampleEventThingCompleted = (ThingCompleted (ThingCompletedData (ThingId "sample") 0))++acceptDoThing :: Bool+acceptDoThing =+    case step thingTransducer (ThingPending, initialThingRegs) ((DoThing (DoThingData (ThingId "sample") 0))) of+        Just (v, _, _) -> v == ThingDone+        Nothing -> False
+ test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Projection.hs view
@@ -0,0 +1,2 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelAggregate.Generated.MyService.Thing.Projection () where
+ test/conformance-skeletons/SkelAggregate/MyService/Thing/Holes.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module SkelAggregate.MyService.Thing.Holes (+    thingTransducer,+    -- (no projection)+) where++import Keiki.Builder ((=:))+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer, lit)+import SkelAggregate.Generated.MyService.Thing.Domain++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+thingTransducer ::+    SymTransducer+        (HsPred ThingRegs ThingCommand)+        ThingRegs+        ThingVertex+        ThingCommand+        ThingEvent+thingTransducer =+    B.buildTransducer ThingPending initialThingRegs isTerminal do+        B.from ThingPending do+            B.onCmd inCtorDoThing $ \d -> B.do+                B.slot @"state" =: lit ThingDone+                B.emit+                    wireThingCompleted+                    ThingCompletedTermFields+                        { thingId = d.thingId+                        , attempt = d.attempt+                        }+                B.goto ThingDone+  where+    isTerminal = \case+        ThingDone -> True+        _ -> False
+ test/conformance-skeletons/SkelContract/Generated/MyService/MyContract/Contract.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelContract.Generated.MyService.MyContract.Contract (+    MyContractPayload (..),+    ThingHappenedData (..),+    messageTypeOf,+    encodeMyContractPayload,+    parseMyContractPayload,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.Text (Text)+import Data.Text qualified as T++-- topic constants+eventsTopic :: Text+eventsTopic = "my-service.events"++-- the closed payload set (discriminated by "messageType")+data ThingHappenedData = ThingHappenedData {thingId :: !Text, detail :: !Text}+    deriving stock (Eq, Show)++data MyContractPayload = ThingHappened !ThingHappenedData+    deriving stock (Eq, Show)++messageTypeOf :: MyContractPayload -> Text+messageTypeOf = \case+    ThingHappened{} -> "ThingHappened"++encodeMyContractPayload :: MyContractPayload -> Value+encodeMyContractPayload = \case+    ThingHappened payload ->+        object+            [ "messageType" .= ("ThingHappened" :: Text)+            , "thingId" .= payload.thingId+            , "detail" .= payload.detail+            ]++parseMyContractPayload :: Value -> Either Text MyContractPayload+parseMyContractPayload = mapLeftText . parseEither (withObject "MyContractPayload" go)+  where+    go o = do+        kind <- o .: "messageType" :: Parser Text+        case kind of+            "ThingHappened" ->+                ThingHappened <$> (ThingHappenedData <$> o .: "thingId" <*> o .: "detail")+            _ -> fail "unknown message type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelEmit/Generated/MyService/MyContract/Contract.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelEmit.Generated.MyService.MyContract.Contract (+    MyContractPayload (..),+    ThingAcceptedData (..),+    messageTypeOf,+    encodeMyContractPayload,+    parseMyContractPayload,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.Text (Text)+import Data.Text qualified as T++-- topic constants+eventsTopic :: Text+eventsTopic = "my-service.events"++-- the closed payload set (discriminated by "messageType")+data ThingAcceptedData = ThingAcceptedData {thingId :: !Text}+    deriving stock (Eq, Show)++data MyContractPayload = ThingAccepted !ThingAcceptedData+    deriving stock (Eq, Show)++messageTypeOf :: MyContractPayload -> Text+messageTypeOf = \case+    ThingAccepted{} -> "ThingAccepted"++encodeMyContractPayload :: MyContractPayload -> Value+encodeMyContractPayload = \case+    ThingAccepted payload ->+        object+            [ "messageType" .= ("ThingAccepted" :: Text)+            , "thingId" .= payload.thingId+            ]++parseMyContractPayload :: Value -> Either Text MyContractPayload+parseMyContractPayload = mapLeftText . parseEither (withObject "MyContractPayload" go)+  where+    go o = do+        kind <- o .: "messageType" :: Parser Text+        case kind of+            "ThingAccepted" ->+                ThingAccepted <$> (ThingAcceptedData <$> o .: "thingId")+            _ -> fail "unknown message type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelEmit/Generated/MyService/ThingPublisher/Publisher.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelEmit.Generated.MyService.ThingPublisher.Publisher (+    publisherOrdering,+    publisherBackoff,+    publisherMaxAttempts,+) where++import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))++publisherOrdering :: OrderingPolicy+publisherOrdering = PerKeyHeadOfLine++publisherBackoff :: BackoffSchedule+publisherBackoff = ConstantBackoff 2++publisherMaxAttempts :: Int+publisherMaxAttempts = 10
+ test/conformance-skeletons/SkelIntake/Generated/MyService/MyContract/Contract.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelIntake.Generated.MyService.MyContract.Contract (+    MyContractPayload (..),+    ThingHappenedData (..),+    messageTypeOf,+    encodeMyContractPayload,+    parseMyContractPayload,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.Text (Text)+import Data.Text qualified as T++-- topic constants+eventsTopic :: Text+eventsTopic = "my-service.events"++-- the closed payload set (discriminated by "messageType")+data ThingHappenedData = ThingHappenedData {thingId :: !Text}+    deriving stock (Eq, Show)++data MyContractPayload = ThingHappened !ThingHappenedData+    deriving stock (Eq, Show)++messageTypeOf :: MyContractPayload -> Text+messageTypeOf = \case+    ThingHappened{} -> "ThingHappened"++encodeMyContractPayload :: MyContractPayload -> Value+encodeMyContractPayload = \case+    ThingHappened payload ->+        object+            [ "messageType" .= ("ThingHappened" :: Text)+            , "thingId" .= payload.thingId+            ]++parseMyContractPayload :: Value -> Either Text MyContractPayload+parseMyContractPayload = mapLeftText . parseEither (withObject "MyContractPayload" go)+  where+    go o = do+        kind <- o .: "messageType" :: Parser Text+        case kind of+            "ThingHappened" ->+                ThingHappened <$> (ThingHappenedData <$> o .: "thingId")+            _ -> fail "unknown message type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelIntake/Generated/MyService/ThingInbox/Inbox.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelIntake.Generated.MyService.ThingInbox.Inbox (+    InboxAck (..),+    inboxDedupePolicy,+    inboxPersistence,+    inboxDisposition,+) where++import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))++-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy.+inboxDedupePolicy :: InboxDedupePolicy+inboxDedupePolicy = PreferIntegrationMessageId++{- | Success-path envelope retention passed to runInboxTransactionWith.+Failures always retain their full operator-facing dead-letter envelope.+Dedupe-only success rows decode with an empty payload.+-}+inboxPersistence :: InboxPersistence+inboxPersistence = PersistFullEnvelope++-- The service's ack decision for each inbox classification.+data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter+    deriving stock (Eq, Show)++-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult.+-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous+-- inversions the spec states explicitly.+inboxDisposition :: InboxResult a -> InboxAck+inboxDisposition r = case r of+    InboxProcessed _ -> InboxAckOk+    InboxDuplicate -> InboxAckOk+    InboxInProgress -> InboxRetry+    InboxPreviouslyFailed _ -> InboxDeadLetter++-- handler-level failures (not InboxResult): decodeFailed => deadLetter, dedupeFailed => deadLetter, storeFailed => retry
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Codec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Hospital.Codec (+    hospitalCodec,+    parseHospitalEvent,+    encodeHospitalEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Codec (Codec (..), EventType (..))+import SkelProcess.Generated.MyService.Hospital.Domain++hospitalCodec :: Codec HospitalEvent+hospitalCodec =+    Codec+        { eventTypes = EventType "SurgeActivated" :| []+        , eventType = \case+            SurgeActivated{} -> EventType "SurgeActivated"+        , schemaVersion = 1+        , encode = encodeHospitalEvent+        , decode = parseHospitalEvent+        , upcasters = []+        }++encodeHospitalEvent :: HospitalEvent -> Value+encodeHospitalEvent = \case+    SurgeActivated payload ->+        object+            [ "kind" .= ("SurgeActivated" :: Text)+            , "hospitalId" .= hospitalIdText payload.hospitalId+            ]++parseHospitalEvent :: EventType -> Value -> Either Text HospitalEvent+parseHospitalEvent (EventType tag) = mapLeftText . parseEither (withObject "HospitalEvent" go)+  where+    go o = do+        case tag of+            "SurgeActivated" ->+                SurgeActivated <$> (SurgeActivatedData <$> (HospitalId <$> o .: "hospitalId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Domain.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Hospital.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype HospitalId = HospitalId Text+    deriving stock (Generic, Eq, Ord, Show)++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++newtype CommandId = CommandId Text+    deriving stock (Generic, Eq, Ord, Show)++commandIdText :: CommandId -> Text+commandIdText (CommandId t) = t++data HospitalVertex = HospitalOperational | HospitalSurging+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data ActivateSurgeData = ActivateSurgeData+    { hospitalId :: !HospitalId+    }+    deriving stock (Generic, Eq, Show)++data HospitalCommand = ActivateSurge !ActivateSurgeData+    deriving stock (Generic, Eq, Show)++data SurgeActivatedData = SurgeActivatedData+    { hospitalId :: !HospitalId+    }+    deriving stock (Generic, Eq, Show)++data HospitalEvent = SurgeActivated !SurgeActivatedData+    deriving stock (Generic, Eq, Show)++type HospitalRegs =+    '[]++initialHospitalRegs :: RegFile HospitalRegs+initialHospitalRegs =+    RNil++$(deriveAggregateCtorsAll ''HospitalCommand ''HospitalRegs)++$(deriveWireCtorsAll ''HospitalEvent)
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Hospital.EventStream (+    hospitalCategory,+    hospitalEventStream,+    hospitalEventStreamDef,+    HospitalEventStream,+    HospitalEventStreamDef,+) where++import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import SkelProcess.Generated.MyService.Hospital.Codec (hospitalCodec)+import SkelProcess.Generated.MyService.Hospital.Domain+import SkelProcess.MyService.Hospital.Holes (hospitalTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+hospitalCategory :: Stream.StreamCategory a+hospitalCategory = Stream.categoryUnsafe "hospital"++type HospitalEventStreamDef =+    EventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++type HospitalEventStream =+    ValidatedEventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++hospitalEventStreamDef :: HospitalEventStreamDef+hospitalEventStreamDef =+    EventStream+        { transducer = hospitalTransducer+        , initialState = HospitalOperational+        , initialRegisters = initialHospitalRegs+        , eventCodec = hospitalCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++hospitalEventStream :: HospitalEventStream+hospitalEventStream =+    mkEventStreamOrThrow "Hospital" hospitalEventStreamDef
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Hospital.Harness (harnessAssertions) where++import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import SkelProcess.Generated.MyService.Hospital.Codec (encodeHospitalEvent, hospitalCodec, parseHospitalEvent)+import SkelProcess.Generated.MyService.Hospital.Domain+import SkelProcess.MyService.Hospital.Holes (hospitalTransducer)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions hospitalTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: SurgeActivated", roundTrips sampleEventSurgeActivated)+    , ("accepts ActivateSurge from HospitalOperational", acceptActivateSurge)+    ]++roundTrips :: HospitalEvent -> Bool+roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e++sampleEventSurgeActivated :: HospitalEvent+sampleEventSurgeActivated = (SurgeActivated (SurgeActivatedData (HospitalId "sample")))++acceptActivateSurge :: Bool+acceptActivateSurge =+    case step hospitalTransducer (HospitalOperational, initialHospitalRegs) ((ActivateSurge (ActivateSurgeData (HospitalId "sample")))) of+        Just (v, _, _) -> v == HospitalSurging+        Nothing -> False
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Projection.hs view
@@ -0,0 +1,2 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Hospital.Projection () where
+ test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/Process.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.HospitalSurge.Process (+    hospitalSurgeProcessName,+    hospitalSurgeCategory,+    hospitalSurgeProcessWorkerOptions,+    hospitalSurgeTimerRequest,+    hospitalSurgeFireOutcome,+) where++import Data.Aeson (Value, object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Data.UUID.V5 qualified as UUID.V5+import Keiro.Command (CommandError (..))+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Keiro.Stream qualified as Stream+import Keiro.Timer (TimerId (..), TimerRequest (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).+hospitalSurgeProcessName :: Text+hospitalSurgeProcessName = "hospital-surge"++-- The validated saga stream category (hole-kind 5: referenced, never retyped).+-- Saga streams are '<category>-<correlationId>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.+hospitalSurgeCategory :: Stream.StreamCategory a+hospitalSurgeCategory = Stream.categoryUnsafe "hospitalSurge"++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.ProcessManager.runProcessManagerWorkerWith.+hospitalSurgeProcessWorkerOptions :: WorkerOptions es msg+hospitalSurgeProcessWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedHalt+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }++-- The deterministic timer-request builder: id derived from the correlation+-- key (hole-kind 1), processManagerName referenced, payload from the spec.+-- (timer id derived as uuidv5 of "hospital-surge-timer:" <> correlationId)+hospitalSurgeTimerRequest :: Text -> UTCTime -> TimerRequest+hospitalSurgeTimerRequest correlationId fireAtTime =+    TimerRequest+        { timerId = TimerId (namedUuid ("hospital-surge-timer:" <> correlationId))+        , processManagerName = hospitalSurgeProcessName+        , correlationId = correlationId+        , fireAt = fireAtTime+        , payload = object ["kind" .= ("hospital-surge-follow-up" :: Value)]+        }++-- The timer-fire disposition table (hole-kind 2), derived from the spec.+-- on-reject => Fired is the benign inversion.+-- A duplicate append reaches on-error unless it is confirmed against the+-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:+--   StreamName -> EventId -> CommandError -> Eff es Bool+-- Fold True into the duplicate result and surface False as the failure.+hospitalSurgeFireOutcome :: Either CommandError a -> Maybe ()+hospitalSurgeFireOutcome result = case result of+    Right{} -> Just () -- Fired+    Left CommandRejected -> Just () -- Fired+    Left (CommandAmbiguous _) -> Nothing -- Retry  -- explicit definition-bug arm+    Left{} -> Nothing -- Retry++-- max-attempts = 5, dead-letter = "surge timer exceeded ceiling"+-- (the timer worker must pass Just 5 to runTimerWorkerWith, never the+--  defaultTimerWorkerOptions Nothing ceiling that retries forever).++-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1).+namedUuid :: Text -> UUID+namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))
+ test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/ProcessHarness.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness (processHarnessValues) where++{- | (label, value): the spec's deterministic process/timer decisions,+lowered to plain values so a driver can assert them against a committed+expectation. The driver's expectation is hand-written (not generated), so a+spec change that alters a decision diverges from it and turns a specific+assertion red — the spec->behaviour pin. (Live-runtime behavioural+conformance of the filled ProcessManager is the M5 step.)+-}+processHarnessValues :: [(String, String)]+processHarnessValues =+    [ ("fireAtField", "observedAt")+    , ("timerIdPrefix", "hospital-surge-timer:")+    , ("firedEventIdPrefix", "hospital-surge-fired:")+    , ("dispatchIdUserField", "none")+    , ("onReject", "Fired")+    , ("onAmbiguous", "Retry")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "halt")+    , ("poisonPolicy", "halt")+    , ("maxAttempts", "5")+    ]
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Codec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Surge.Codec (+    surgeCodec,+    parseSurgeEvent,+    encodeSurgeEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Codec (Codec (..), EventType (..))+import SkelProcess.Generated.MyService.Surge.Domain++surgeCodec :: Codec SurgeEvent+surgeCodec =+    Codec+        { eventTypes = EventType "SurgeThresholdNoted" :| [EventType "SurgeTimerMarked"]+        , eventType = \case+            SurgeThresholdNoted{} -> EventType "SurgeThresholdNoted"+            SurgeTimerMarked{} -> EventType "SurgeTimerMarked"+        , schemaVersion = 1+        , encode = encodeSurgeEvent+        , decode = parseSurgeEvent+        , upcasters = []+        }++encodeSurgeEvent :: SurgeEvent -> Value+encodeSurgeEvent = \case+    SurgeThresholdNoted payload ->+        object+            [ "kind" .= ("SurgeThresholdNoted" :: Text)+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "availableIcuBeds" .= payload.availableIcuBeds+            , "redDemand" .= payload.redDemand+            , "timerId" .= payload.timerId+            ]+    SurgeTimerMarked payload ->+        object+            [ "kind" .= ("SurgeTimerMarked" :: Text)+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "timerId" .= payload.timerId+            ]++parseSurgeEvent :: EventType -> Value -> Either Text SurgeEvent+parseSurgeEvent (EventType tag) = mapLeftText . parseEither (withObject "SurgeEvent" go)+  where+    go o = do+        case tag of+            "SurgeThresholdNoted" ->+                SurgeThresholdNoted <$> (SurgeThresholdNotedData <$> (HospitalId <$> o .: "hospitalId") <*> o .: "availableIcuBeds" <*> o .: "redDemand" <*> o .: "timerId")+            "SurgeTimerMarked" ->+                SurgeTimerMarked <$> (SurgeTimerMarkedData <$> (HospitalId <$> o .: "hospitalId") <*> o .: "timerId")+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Domain.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Surge.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype HospitalId = HospitalId Text+    deriving stock (Generic, Eq, Ord, Show)++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++newtype CommandId = CommandId Text+    deriving stock (Generic, Eq, Ord, Show)++commandIdText :: CommandId -> Text+commandIdText (CommandId t) = t++data SurgeVertex = SurgeIdle | SurgeFired+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data NoteSurgeThresholdData = NoteSurgeThresholdData+    { hospitalId :: !HospitalId+    , availableIcuBeds :: !Int+    , redDemand :: !Int+    , timerId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data MarkSurgeTimerFiredData = MarkSurgeTimerFiredData+    { hospitalId :: !HospitalId+    , timerId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data SurgeCommand+    = NoteSurgeThreshold !NoteSurgeThresholdData+    | MarkSurgeTimerFired !MarkSurgeTimerFiredData+    deriving stock (Generic, Eq, Show)++data SurgeThresholdNotedData = SurgeThresholdNotedData+    { hospitalId :: !HospitalId+    , availableIcuBeds :: !Int+    , redDemand :: !Int+    , timerId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data SurgeTimerMarkedData = SurgeTimerMarkedData+    { hospitalId :: !HospitalId+    , timerId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data SurgeEvent+    = SurgeThresholdNoted !SurgeThresholdNotedData+    | SurgeTimerMarked !SurgeTimerMarkedData+    deriving stock (Generic, Eq, Show)++type SurgeRegs =+    '[]++initialSurgeRegs :: RegFile SurgeRegs+initialSurgeRegs =+    RNil++$(deriveAggregateCtorsAll ''SurgeCommand ''SurgeRegs)++$(deriveWireCtorsAll ''SurgeEvent)
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Surge.EventStream (+    surgeCategory,+    surgeEventStream,+    surgeEventStreamDef,+    SurgeEventStream,+    SurgeEventStreamDef,+) where++import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import SkelProcess.Generated.MyService.Surge.Codec (surgeCodec)+import SkelProcess.Generated.MyService.Surge.Domain+import SkelProcess.MyService.Surge.Holes (surgeTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+surgeCategory :: Stream.StreamCategory a+surgeCategory = Stream.categoryUnsafe "surge"++type SurgeEventStreamDef =+    EventStream (HsPred SurgeRegs SurgeCommand) SurgeRegs SurgeVertex SurgeCommand SurgeEvent++type SurgeEventStream =+    ValidatedEventStream (HsPred SurgeRegs SurgeCommand) SurgeRegs SurgeVertex SurgeCommand SurgeEvent++surgeEventStreamDef :: SurgeEventStreamDef+surgeEventStreamDef =+    EventStream+        { transducer = surgeTransducer+        , initialState = SurgeIdle+        , initialRegisters = initialSurgeRegs+        , eventCodec = surgeCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++surgeEventStream :: SurgeEventStream+surgeEventStream =+    mkEventStreamOrThrow "Surge" surgeEventStreamDef
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Surge.Harness (harnessAssertions) where++import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import SkelProcess.Generated.MyService.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import SkelProcess.Generated.MyService.Surge.Domain+import SkelProcess.MyService.Surge.Holes (surgeTransducer)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions surgeTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: SurgeThresholdNoted", roundTrips sampleEventSurgeThresholdNoted)+    , ("golden round-trip: SurgeTimerMarked", roundTrips sampleEventSurgeTimerMarked)+    , ("accepts NoteSurgeThreshold from SurgeIdle", acceptNoteSurgeThreshold)+    , ("accepts MarkSurgeTimerFired from SurgeIdle", acceptMarkSurgeTimerFired)+    ]++roundTrips :: SurgeEvent -> Bool+roundTrips e = parseSurgeEvent (eventType surgeCodec e) (encodeSurgeEvent e) == Right e++sampleEventSurgeThresholdNoted :: SurgeEvent+sampleEventSurgeThresholdNoted = (SurgeThresholdNoted (SurgeThresholdNotedData (HospitalId "sample") 0 0 "sample"))++sampleEventSurgeTimerMarked :: SurgeEvent+sampleEventSurgeTimerMarked = (SurgeTimerMarked (SurgeTimerMarkedData (HospitalId "sample") "sample"))++acceptNoteSurgeThreshold :: Bool+acceptNoteSurgeThreshold =+    case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((NoteSurgeThreshold (NoteSurgeThresholdData (HospitalId "sample") 0 0 "sample"))) of+        Just (v, _, _) -> v == SurgeIdle+        Nothing -> False++acceptMarkSurgeTimerFired :: Bool+acceptMarkSurgeTimerFired =+    case step surgeTransducer (SurgeIdle, initialSurgeRegs) ((MarkSurgeTimerFired (MarkSurgeTimerFiredData (HospitalId "sample") "sample"))) of+        Just (v, _, _) -> v == SurgeFired+        Nothing -> False
+ test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Projection.hs view
@@ -0,0 +1,2 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelProcess.Generated.MyService.Surge.Projection () where
+ test/conformance-skeletons/SkelProcess/MyService/Hospital/Holes.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module SkelProcess.MyService.Hospital.Holes (+    hospitalTransducer,+    -- (no projection)+) where++import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)+import SkelProcess.Generated.MyService.Hospital.Domain++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+hospitalTransducer ::+    SymTransducer+        (HsPred HospitalRegs HospitalCommand)+        HospitalRegs+        HospitalVertex+        HospitalCommand+        HospitalEvent+hospitalTransducer =+    B.buildTransducer HospitalOperational initialHospitalRegs isTerminal do+        B.from HospitalOperational do+            B.onCmd inCtorActivateSurge $ \d -> B.do+                B.emit+                    wireSurgeActivated+                    SurgeActivatedTermFields+                        { hospitalId = d.hospitalId+                        }+                B.goto HospitalSurging+  where+    isTerminal = \case+        HospitalSurging -> True+        _ -> False
+ test/conformance-skeletons/SkelProcess/MyService/HospitalSurge/ProcessHoles.hs view
@@ -0,0 +1,11 @@+-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.+-- keiro-dsl creates it once and never overwrites it.+module SkelProcess.MyService.HospitalSurge.ProcessHoles () where++-- HOLE handle: build the ProcessManagerAction (the self-advance+--   'NoteSurgeThreshold', the dispatch(es), and the timer) from the input.+-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;+--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED).+-- HOLE fire command: construct MarkSurgeTimerFired for the timer fire,+--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of+--   "hospital-surge-fired:" <> correlationId.
+ test/conformance-skeletons/SkelProcess/MyService/Surge/Holes.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module SkelProcess.MyService.Surge.Holes (+    surgeTransducer,+    -- (no projection)+) where++import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)+import SkelProcess.Generated.MyService.Surge.Domain++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+surgeTransducer ::+    SymTransducer+        (HsPred SurgeRegs SurgeCommand)+        SurgeRegs+        SurgeVertex+        SurgeCommand+        SurgeEvent+surgeTransducer =+    B.buildTransducer SurgeIdle initialSurgeRegs isTerminal do+        B.from SurgeIdle do+            B.onCmd inCtorNoteSurgeThreshold $ \d -> B.do+                B.emit+                    wireSurgeThresholdNoted+                    SurgeThresholdNotedTermFields+                        { hospitalId = d.hospitalId+                        , availableIcuBeds = d.availableIcuBeds+                        , redDemand = d.redDemand+                        , timerId = d.timerId+                        }+                B.goto SurgeIdle+            B.onCmd inCtorMarkSurgeTimerFired $ \d -> B.do+                B.emit+                    wireSurgeTimerMarked+                    SurgeTimerMarkedTermFields+                        { hospitalId = d.hospitalId+                        , timerId = d.timerId+                        }+                B.goto SurgeFired+  where+    isTerminal = \case+        SurgeFired -> True+        _ -> False
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModel.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModel (+    acceptedTransferNeedsReadModel,+    acceptedTransferNeedsQualifiedTable,+    registerAcceptedTransferNeeds,+    startAcceptedTransferNeedsRebuild,+    finishAcceptedTransferNeedsRebuild,+    abandonAcceptedTransferNeedsRebuild,+    acceptedTransferNeedsAsyncProjection,+) where++import Data.Functor (void)+import Effectful (Eff, (:>))+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition, RecordedEvent (..))+import SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable (acceptedTransferNeedsQualifiedTable)+import SkelQueue.MyService.Accepted_transfer_needs.ReadModelHoles (AcceptedTransferNeedsQueryInput, AcceptedTransferNeedsQueryResult, acceptedTransferNeedsQuery, applyAcceptedTransferNeeds)++acceptedTransferNeedsReadModel :: ReadModel AcceptedTransferNeedsQueryInput AcceptedTransferNeedsQueryResult+acceptedTransferNeedsReadModel =+    ReadModel+        { name = "my-service-accepted-transfer-needs"+        , tableName = "accepted_transfer_needs"+        , schema = "my_service"+        , subscriptionName = "my-service-accepted-transfer-needs-sub"+        , version = 1+        , shapeHash = "fnv1a:fec517dae7760b8a"+        , defaultConsistency = Eventual+        , strongScope = EntireLog+        , query = acceptedTransferNeedsQuery+        }++-- Call once at projection startup before serving queries.+registerAcceptedTransferNeeds :: (Store :> es) => Eff es ()+registerAcceptedTransferNeeds =+    void (registerReadModel "my-service-accepted-transfer-needs" 1 "fnv1a:fec517dae7760b8a")++startAcceptedTransferNeedsRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+startAcceptedTransferNeedsRebuild =+    Rebuild.startRebuild acceptedTransferNeedsReadModel ["my-service-accepted-transfer-needs-async"]++finishAcceptedTransferNeedsRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)+finishAcceptedTransferNeedsRebuild =+    Rebuild.finishRebuild acceptedTransferNeedsReadModel ["my-service-accepted-transfer-needs-async"]++abandonAcceptedTransferNeedsRebuild :: (Store :> es) => Eff es ReadModelMetadata+abandonAcceptedTransferNeedsRebuild = Rebuild.abandonRebuild acceptedTransferNeedsReadModel++acceptedTransferNeedsAsyncProjection :: AsyncProjection+acceptedTransferNeedsAsyncProjection =+    AsyncProjection+        { name = "my-service-accepted-transfer-needs-async"+        , readModelName = "my-service-accepted-transfer-needs"+        , subscriptionName = "my-service-accepted-transfer-needs-sub"+        , applyRecorded = applyAcceptedTransferNeeds+        , idempotencyKey = \recorded -> recorded.eventId+        }
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModelHarness.hs view
@@ -0,0 +1,19 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelHarness (readModelFacts, runReadModelFacts) where++-- | (fact, expected from notation, actual shared derivation/lowering).+readModelFacts :: [(String, String, String)]+readModelFacts =+    [ ("registryName", "my-service-accepted-transfer-needs", "my-service-accepted-transfer-needs")+    , ("subscriptionName", "my-service-accepted-transfer-needs-sub", "my-service-accepted-transfer-needs-sub")+    , ("shapeHash", "fnv1a:fec517dae7760b8a", "fnv1a:fec517dae7760b8a")+    , ("asyncProjectionName", "my-service-accepted-transfer-needs-async", "my-service-accepted-transfer-needs-async")+    , ("consistency", "Eventual", "Eventual")+    , ("strongScope", "EntireLog", "EntireLog")+    ]++runReadModelFacts :: IO Bool+runReadModelFacts = do+    let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]+    mapM_ (\(fact, expected, actual) -> putStrLn ("FAIL  " <> fact <> " expected=" <> show expected <> " actual=" <> show actual)) failures+    pure (null failures)
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModelTable.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable (acceptedTransferNeedsQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+acceptedTransferNeedsQualifiedTable :: Text+acceptedTransferNeedsQualifiedTable = qualifyTable "my_service" "accepted_transfer_needs"
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/Queue.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Reservation_work.Queue (+    ReservationWorkItem (..),+    encodeReservationWorkItem,+    parseReservationWorkItem,+    queuePhysical,+    queueDlq,+    queueTable,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.Text (Text)+import Data.Text qualified as T++queuePhysical, queueDlq, queueTable :: Text+queuePhysical = "my_service_reservation_work"+queueDlq = "my_service_reservation_work_dlq"+queueTable = "pgmq.q_my_service_reservation_work"++data ReservationWorkItem = ReservationWorkItem+    { reservationId :: !Text+    , hospitalId :: !Text+    }+    deriving stock (Eq, Show)++encodeReservationWorkItem :: ReservationWorkItem -> Value+encodeReservationWorkItem p =+    object+        [ "reservation_id" .= p.reservationId+        , "hospital_id" .= p.hospitalId+        ]++parseReservationWorkItem :: Value -> Either Text ReservationWorkItem+parseReservationWorkItem = mapLeftText . parseEither (withObject "ReservationWorkItem" go)+  where+    go o = ReservationWorkItem <$> o .: "reservation_id" <*> o .: "hospital_id"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueuePolicy.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Reservation_work.QueuePolicy (+    retryPolicy,+    jobOutcomeFor,+    jobOrdering,+    jobTuningFor,+    queueProvision,+)+where++import Data.Text (Text)+import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)++jobOrdering :: JobOrdering+jobOrdering = Unordered++-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.+jobTuningFor :: JobTuning -> JobTuning+jobTuningFor = withOrdering jobOrdering++-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.+queueProvision :: QueueProvision+queueProvision = standardProvision++retryPolicy :: RetryPolicy+retryPolicy =+    RetryPolicy+        { maxRetries = 3+        , defaultRetryDelay = RetryDelay 5+        , useDeadLetter = True+        }++-- The consumer JobOutcome disposition over the spec's named domain outcomes,+-- lowered to the live Keiro.PGMQ.Job.JobOutcome.+jobOutcomeFor :: Text -> JobOutcome+jobOutcomeFor o = case o of+    "storeFailure" -> Retry (RetryDelay 5)+    "commandRejected" -> Dead "dead-lettered"+    "decodeFailure" -> Dead "dead-lettered"+    "onCodecReject" -> Dead "dead-lettered"+    _ -> Retry (RetryDelay 5)
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModel.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Transfer_decisions.ReadModel (+    transferDecisionsReadModel,+    transferDecisionsQualifiedTable,+    registerTransferDecisions,+    startTransferDecisionsRebuild,+    finishTransferDecisionsRebuild,+    abandonTransferDecisionsRebuild,+    transferDecisionsAsyncProjection,+) where++import Data.Functor (void)+import Effectful (Eff, (:>))+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition, RecordedEvent (..))+import SkelQueue.Generated.MyService.Transfer_decisions.ReadModelTable (transferDecisionsQualifiedTable)+import SkelQueue.MyService.Transfer_decisions.ReadModelHoles (TransferDecisionsQueryInput, TransferDecisionsQueryResult, applyTransferDecisions, transferDecisionsQuery)++transferDecisionsReadModel :: ReadModel TransferDecisionsQueryInput TransferDecisionsQueryResult+transferDecisionsReadModel =+    ReadModel+        { name = "my-service-transfer-decisions"+        , tableName = "transfer_decisions"+        , schema = "my_service"+        , subscriptionName = "my-service-transfer-decisions-sub"+        , version = 1+        , shapeHash = "fnv1a:d44d218822582783"+        , defaultConsistency = Eventual+        , strongScope = EntireLog+        , query = transferDecisionsQuery+        }++-- Call once at projection startup before serving queries.+registerTransferDecisions :: (Store :> es) => Eff es ()+registerTransferDecisions =+    void (registerReadModel "my-service-transfer-decisions" 1 "fnv1a:d44d218822582783")++startTransferDecisionsRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+startTransferDecisionsRebuild =+    Rebuild.startRebuild transferDecisionsReadModel ["my-service-transfer-decisions-async"]++finishTransferDecisionsRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)+finishTransferDecisionsRebuild =+    Rebuild.finishRebuild transferDecisionsReadModel ["my-service-transfer-decisions-async"]++abandonTransferDecisionsRebuild :: (Store :> es) => Eff es ReadModelMetadata+abandonTransferDecisionsRebuild = Rebuild.abandonRebuild transferDecisionsReadModel++transferDecisionsAsyncProjection :: AsyncProjection+transferDecisionsAsyncProjection =+    AsyncProjection+        { name = "my-service-transfer-decisions-async"+        , readModelName = "my-service-transfer-decisions"+        , subscriptionName = "my-service-transfer-decisions-sub"+        , applyRecorded = applyTransferDecisions+        , idempotencyKey = \recorded -> recorded.eventId+        }
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModelHarness.hs view
@@ -0,0 +1,19 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Transfer_decisions.ReadModelHarness (readModelFacts, runReadModelFacts) where++-- | (fact, expected from notation, actual shared derivation/lowering).+readModelFacts :: [(String, String, String)]+readModelFacts =+    [ ("registryName", "my-service-transfer-decisions", "my-service-transfer-decisions")+    , ("subscriptionName", "my-service-transfer-decisions-sub", "my-service-transfer-decisions-sub")+    , ("shapeHash", "fnv1a:d44d218822582783", "fnv1a:d44d218822582783")+    , ("asyncProjectionName", "my-service-transfer-decisions-async", "my-service-transfer-decisions-async")+    , ("consistency", "Eventual", "Eventual")+    , ("strongScope", "EntireLog", "EntireLog")+    ]++runReadModelFacts :: IO Bool+runReadModelFacts = do+    let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]+    mapM_ (\(fact, expected, actual) -> putStrLn ("FAIL  " <> fact <> " expected=" <> show expected <> " actual=" <> show actual)) failures+    pure (null failures)
+ test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModelTable.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelQueue.Generated.MyService.Transfer_decisions.ReadModelTable (transferDecisionsQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+transferDecisionsQualifiedTable :: Text+transferDecisionsQualifiedTable = qualifyTable "my_service" "transfer_decisions"
+ test/conformance-skeletons/SkelQueue/MyService/Accepted_transfer_needs/ReadModelHoles.hs view
@@ -0,0 +1,26 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module SkelQueue.MyService.Accepted_transfer_needs.ReadModelHoles (+    AcceptedTransferNeedsQueryInput,+    AcceptedTransferNeedsQueryResult,+    acceptedTransferNeedsQuery,+    applyAcceptedTransferNeeds,+) where++import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent)+import SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable (acceptedTransferNeedsQualifiedTable)++-- HOLE: replace these aliases with the real query input and result types.+type AcceptedTransferNeedsQueryInput = ()+type AcceptedTransferNeedsQueryResult = ()++-- HOLE: query "my_service"."accepted_transfer_needs" via acceptedTransferNeedsQualifiedTable; never rely on search_path.+-- Declared columns:+--   reservation_id text NOT NULL+--   hospital_id text NOT NULL+acceptedTransferNeedsQuery :: AcceptedTransferNeedsQueryInput -> Tx.Transaction AcceptedTransferNeedsQueryResult+acceptedTransferNeedsQuery _input = acceptedTransferNeedsQualifiedTable `seq` error "HOLE: fill accepted_transfer_needs query"++-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.+applyAcceptedTransferNeeds :: RecordedEvent -> Tx.Transaction ()+applyAcceptedTransferNeeds _recorded = error "HOLE: fill accepted_transfer_needs async apply"
+ test/conformance-skeletons/SkelQueue/MyService/Transfer_decisions/ReadModelHoles.hs view
@@ -0,0 +1,25 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module SkelQueue.MyService.Transfer_decisions.ReadModelHoles (+    TransferDecisionsQueryInput,+    TransferDecisionsQueryResult,+    transferDecisionsQuery,+    applyTransferDecisions,+) where++import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent)+import SkelQueue.Generated.MyService.Transfer_decisions.ReadModelTable (transferDecisionsQualifiedTable)++-- HOLE: replace these aliases with the real query input and result types.+type TransferDecisionsQueryInput = ()+type TransferDecisionsQueryResult = ()++-- HOLE: query "my_service"."transfer_decisions" via transferDecisionsQualifiedTable; never rely on search_path.+-- Declared columns:+--   reservation_id text NOT NULL+transferDecisionsQuery :: TransferDecisionsQueryInput -> Tx.Transaction TransferDecisionsQueryResult+transferDecisionsQuery _input = transferDecisionsQualifiedTable `seq` error "HOLE: fill transfer_decisions query"++-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.+applyTransferDecisions :: RecordedEvent -> Tx.Transaction ()+applyTransferDecisions _recorded = error "HOLE: fill transfer_decisions async apply"
+ test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Codec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.Page.Codec (+    pageCodec,+    parsePageEvent,+    encodePageEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Codec (Codec (..), EventType (..))+import SkelRouter.Generated.MyService.Page.Domain++pageCodec :: Codec PageEvent+pageCodec =+    Codec+        { eventTypes = EventType "PageSent" :| []+        , eventType = \case+            PageSent{} -> EventType "PageSent"+        , schemaVersion = 1+        , encode = encodePageEvent+        , decode = parsePageEvent+        , upcasters = []+        }++encodePageEvent :: PageEvent -> Value+encodePageEvent = \case+    PageSent payload ->+        object+            [ "kind" .= ("PageSent" :: Text)+            , "incidentId" .= payload.incidentId+            , "responderId" .= payload.responderId+            ]++parsePageEvent :: EventType -> Value -> Either Text PageEvent+parsePageEvent (EventType tag) = mapLeftText . parseEither (withObject "PageEvent" go)+  where+    go o = do+        case tag of+            "PageSent" ->+                PageSent <$> (PageSentData <$> o .: "incidentId" <*> o .: "responderId")+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Domain.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.Page.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data PageVertex = PagePending | PageDelivered+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data SendPageData = SendPageData+    { incidentId :: !Text+    , responderId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data PageCommand = SendPage !SendPageData+    deriving stock (Generic, Eq, Show)++data PageSentData = PageSentData+    { incidentId :: !Text+    , responderId :: !Text+    }+    deriving stock (Generic, Eq, Show)++data PageEvent = PageSent !PageSentData+    deriving stock (Generic, Eq, Show)++type PageRegs =+    '[]++initialPageRegs :: RegFile PageRegs+initialPageRegs =+    RNil++$(deriveAggregateCtorsAll ''PageCommand ''PageRegs)++$(deriveWireCtorsAll ''PageEvent)
+ test/conformance-skeletons/SkelRouter/Generated/MyService/Page/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.Page.EventStream (+    pageCategory,+    pageEventStream,+    pageEventStreamDef,+    PageEventStream,+    PageEventStreamDef,+) where++import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream+import SkelRouter.Generated.MyService.Page.Codec (pageCodec)+import SkelRouter.Generated.MyService.Page.Domain+import SkelRouter.MyService.Page.Holes (pageTransducer)++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+pageCategory :: Stream.StreamCategory a+pageCategory = Stream.categoryUnsafe "page"++type PageEventStreamDef =+    EventStream (HsPred PageRegs PageCommand) PageRegs PageVertex PageCommand PageEvent++type PageEventStream =+    ValidatedEventStream (HsPred PageRegs PageCommand) PageRegs PageVertex PageCommand PageEvent++pageEventStreamDef :: PageEventStreamDef+pageEventStreamDef =+    EventStream+        { transducer = pageTransducer+        , initialState = PagePending+        , initialRegisters = initialPageRegs+        , eventCodec = pageCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++pageEventStream :: PageEventStream+pageEventStream =+    mkEventStreamOrThrow "Page" pageEventStreamDef
+ test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.Page.Harness (harnessAssertions) where++import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import SkelRouter.Generated.MyService.Page.Codec (encodePageEvent, pageCodec, parsePageEvent)+import SkelRouter.Generated.MyService.Page.Domain+import SkelRouter.MyService.Page.Holes (pageTransducer)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions pageTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: PageSent", roundTrips sampleEventPageSent)+    , ("accepts SendPage from PagePending", acceptSendPage)+    ]++roundTrips :: PageEvent -> Bool+roundTrips e = parsePageEvent (eventType pageCodec e) (encodePageEvent e) == Right e++sampleEventPageSent :: PageEvent+sampleEventPageSent = (PageSent (PageSentData "sample" "sample"))++acceptSendPage :: Bool+acceptSendPage =+    case step pageTransducer (PagePending, initialPageRegs) ((SendPage (SendPageData "sample" "sample"))) of+        Just (v, _, _) -> v == PageDelivered+        Nothing -> False
+ test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Projection.hs view
@@ -0,0 +1,2 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.Page.Projection () where
+ test/conformance-skeletons/SkelRouter/Generated/MyService/PagingRouter/Router.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.PagingRouter.Router (+    pagingRouterName,+    pagingRouterWorkerOptions,+) where++import Data.Text (Text)+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The STABLE router name. It participates in every target-keyed+-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.+pagingRouterName :: Text+pagingRouterName = "paging-router"++-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,+-- targetStreamName, occurrence). Target-keyed, not positional.++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions.+pagingRouterWorkerOptions :: WorkerOptions es msg+pagingRouterWorkerOptions =+    WorkerOptions+        { poisonPolicy = PoisonHalt+        , rejectedCommandPolicy = RejectedHalt+        , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning+        , metrics = Nothing -- runtime configuration; install at call site+        }
+ test/conformance-skeletons/SkelRouter/Generated/MyService/PagingRouter/RouterHarness.hs view
@@ -0,0 +1,16 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelRouter.Generated.MyService.PagingRouter.RouterHarness (routerHarnessValues) where++routerHarnessValues :: [(String, String)]+routerHarnessValues =+    [ ("routerName", "paging-router")+    , ("keyField", "incidentId")+    , ("resolveSource", "hole")+    , ("resolveRow", "responderId")+    , ("dispatchCommand", "SendPage")+    , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+    , ("onDuplicate", "AckOk")+    , ("onFailed", "Retry")+    , ("rejectedPolicy", "halt")+    , ("poisonPolicy", "halt")+    ]
+ test/conformance-skeletons/SkelRouter/MyService/Page/Holes.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Fill the transducer body (and any other holes) against the+-- generated signatures, then run the harness to confirm behaviour.+module SkelRouter.MyService.Page.Holes (+    pageTransducer,+    -- (no projection)+) where++import Keiki.Builder ((=:))+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (./=), (.==), (.||))+import SkelRouter.Generated.MyService.Page.Domain++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+pageTransducer ::+    SymTransducer+        (HsPred PageRegs PageCommand)+        PageRegs+        PageVertex+        PageCommand+        PageEvent+pageTransducer =+    B.buildTransducer PagePending initialPageRegs isTerminal do+        B.from PagePending do+            B.onCmd inCtorSendPage $ \d -> B.do+                -- HOLE emit PageSent (B.emit wirePageSent ...)+                B.goto PageDelivered+  where+    isTerminal = \case+        PageDelivered -> True+        _ -> False
+ test/conformance-skeletons/SkelRouter/MyService/PagingRouter/RouterHoles.hs view
@@ -0,0 +1,16 @@+-- HAND-OWNED hole module for the router's behaviour-bearing bodies.+-- keiro-dsl creates it once and never overwrites it.+module SkelRouter.MyService.PagingRouter.RouterHoles () where++-- HOLE resolve :: IncidentRaised -> Eff es [PMCommand targetCommand]+--   Spec source: typed resolver hole.+--   The spec's 'stable' keyword acknowledges that retry attempts accumulate+--   the UNION of resolved target identities. Keep the recipient set stable+--   for a source event whenever an exact recipient set matters.+-- HOLE router value: assemble Keiro.Router.Router with name = pagingRouterName,+--   key, resolve, targetEventStream, and targetProjections; run it with+--   runRouterWorkerWith pagingRouterWorkerOptions.+-- HOLE targetProjections: spec projections = [].+-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate+--   event id against the TARGET stream via confirmBenignDuplicate before+--   returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise.
+ test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowFacts.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowFacts (workflowFacts) where++{- | (label, value): the workflow's deterministic decisions, pinned as pure+facts. A driver asserts them against a hand-written expectation, so a spec+change (e.g. renaming an await) reddens a specific assertion.+-}+workflowFacts :: [(String, String)]+workflowFacts =+    [ ("name", "hospital-transfer-reservation")+    , ("idVia", "idText")+    , ("idField", "reservationId")+    , ("body", "step:create-transfer-hold,await:reservation-confirmation,step:summarize-reservation")+    , ("awaits", "reservation-confirmation")+    , ("patches", "")+    ]
+ test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowRuntime.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowRuntime (+    workflowName,+    awaitAwakeableId,+    awaitLabels,+    declaredPatches,+    declaredPatchStepNames,+    withDeclaredPatches,+) where++import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Workflow (WorkflowRunOptions (..))+import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)+import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)++workflowName :: WorkflowName+workflowName = WorkflowName "hospital-transfer-reservation"++-- The awakeable id an await allocates — the real deterministicAwakeableId.+-- A signal op deriving the same (name, id, label) gets the same id.+awaitAwakeableId :: WorkflowId -> Text -> AwakeableId+awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label++awaitLabels :: [Text]+awaitLabels = ["reservation-confirmation"]++declaredPatches :: Set PatchId+declaredPatches = Set.fromList []++-- The journal keys the runtime records patch decisions under.+declaredPatchStepNames :: [Text]+declaredPatchStepNames = map patchStepName (Set.toList declaredPatches)++-- Activate exactly the patches declared by this spec for a workflow run.+withDeclaredPatches :: WorkflowRunOptions -> WorkflowRunOptions+withDeclaredPatches opts = opts{activePatches = declaredPatches}
+ test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Codec (+    reservationCodec,+    parseReservationEvent,+    encodeReservationEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.HospitalCapacity.Reservation.Domain+import Keiro.Codec (Codec (..), EventType (..))++parsePatientAcuity :: Text -> Parser PatientAcuity+parsePatientAcuity = \case+    "red" -> pure RedTag+    "yellow" -> pure YellowTag+    "green" -> pure GreenTag+    _ -> fail "unknown PatientAcuity"++parseBedType :: Text -> Parser BedType+parseBedType = \case+    "icu" -> pure Icu+    "medical-surgical" -> pure MedicalSurgical+    _ -> fail "unknown BedType"++parseDivertStatus :: Text -> Parser DivertStatus+parseDivertStatus = \case+    "open" -> pure Open+    "partial-divert" -> pure PartialDivert+    "total-divert" -> pure TotalDivert+    _ -> fail "unknown DivertStatus"++reservationCodec :: Codec ReservationEvent+reservationCodec =+    Codec+        { eventTypes = EventType "TransferReservationCreated" :| [EventType "TransferReservationConfirmed"]+        , eventType = \case+            TransferReservationCreated{} -> EventType "TransferReservationCreated"+            TransferReservationConfirmed{} -> EventType "TransferReservationConfirmed"+        , schemaVersion = 1+        , encode = encodeReservationEvent+        , decode = parseReservationEvent+        , upcasters = []+        }++encodeReservationEvent :: ReservationEvent -> Value+encodeReservationEvent = \case+    TransferReservationCreated payload ->+        object+            [ "kind" .= ("TransferReservationCreated" :: Text)+            , "reservationId" .= transferReservationIdText payload.reservationId+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "commandId" .= commandIdText payload.commandId+            , "patientAcuity" .= patientAcuityText payload.patientAcuity+            , "divertStatus" .= divertStatusText payload.divertStatus+            , "lifeCriticalOverride" .= payload.lifeCriticalOverride+            ]+    TransferReservationConfirmed payload ->+        object+            [ "kind" .= ("TransferReservationConfirmed" :: Text)+            , "reservationId" .= transferReservationIdText payload.reservationId+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "commandId" .= commandIdText payload.commandId+            ]++parseReservationEvent :: EventType -> Value -> Either Text ReservationEvent+parseReservationEvent (EventType tag) = mapLeftText . parseEither (withObject "ReservationEvent" go)+  where+    go o = do+        case tag of+            "TransferReservationCreated" ->+                TransferReservationCreated <$> (TransferReservationCreatedData <$> (TransferReservationId <$> o .: "reservationId") <*> (HospitalId <$> o .: "hospitalId") <*> (CommandId <$> o .: "commandId") <*> (o .: "patientAcuity" >>= parsePatientAcuity) <*> (o .: "divertStatus" >>= parseDivertStatus) <*> o .: "lifeCriticalOverride")+            "TransferReservationConfirmed" ->+                TransferReservationConfirmed <$> (TransferReservationConfirmedData <$> (TransferReservationId <$> o .: "reservationId") <*> (HospitalId <$> o .: "hospitalId") <*> (CommandId <$> o .: "commandId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Domain where++import Data.Aeson (FromJSON, ToJSON)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)+import Keiki.Shape (CanonicalTypeName)++newtype TransferReservationId = TransferReservationId Text+    deriving stock (Generic, Eq, Ord, Show)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName TransferReservationId++transferReservationIdText :: TransferReservationId -> Text+transferReservationIdText (TransferReservationId t) = t++newtype HospitalId = HospitalId Text+    deriving stock (Generic, Eq, Ord, Show)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName HospitalId++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++newtype CommandId = CommandId Text+    deriving stock (Generic, Eq, Ord, Show)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName CommandId++commandIdText :: CommandId -> Text+commandIdText (CommandId t) = t++data PatientAcuity = RedTag | YellowTag | GreenTag+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName PatientAcuity++patientAcuityText :: PatientAcuity -> Text+patientAcuityText = \case+    RedTag -> "red"+    YellowTag -> "yellow"+    GreenTag -> "green"++data BedType = Icu | MedicalSurgical+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName BedType++bedTypeText :: BedType -> Text+bedTypeText = \case+    Icu -> "icu"+    MedicalSurgical -> "medical-surgical"++data DivertStatus = Open | PartialDivert | TotalDivert+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName DivertStatus++divertStatusText :: DivertStatus -> Text+divertStatusText = \case+    Open -> "open"+    PartialDivert -> "partial-divert"+    TotalDivert -> "total-divert"++data ReservationVertex = ReservationUnrequested | ReservationHeld | ReservationConfirmed | ReservationExpired | ReservationAdmitted | ReservationReleased+    deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)+    deriving anyclass (ToJSON, FromJSON)+instance CanonicalTypeName ReservationVertex++data RequestTransferReservationData = RequestTransferReservationData+    { reservationId :: !TransferReservationId+    , hospitalId :: !HospitalId+    , commandId :: !CommandId+    , patientAcuity :: !PatientAcuity+    , divertStatus :: !DivertStatus+    , lifeCriticalOverride :: !Bool+    }+    deriving stock (Generic, Eq, Show)++data ConfirmReservationData = ConfirmReservationData+    { reservationId :: !TransferReservationId+    , hospitalId :: !HospitalId+    , commandId :: !CommandId+    }+    deriving stock (Generic, Eq, Show)++data ReservationCommand+    = RequestTransferReservation !RequestTransferReservationData+    | ConfirmReservation !ConfirmReservationData+    deriving stock (Generic, Eq, Show)++data TransferReservationCreatedData = TransferReservationCreatedData+    { reservationId :: !TransferReservationId+    , hospitalId :: !HospitalId+    , commandId :: !CommandId+    , patientAcuity :: !PatientAcuity+    , divertStatus :: !DivertStatus+    , lifeCriticalOverride :: !Bool+    }+    deriving stock (Generic, Eq, Show)++data TransferReservationConfirmedData = TransferReservationConfirmedData+    { reservationId :: !TransferReservationId+    , hospitalId :: !HospitalId+    , commandId :: !CommandId+    }+    deriving stock (Generic, Eq, Show)++data ReservationEvent+    = TransferReservationCreated !TransferReservationCreatedData+    | TransferReservationConfirmed !TransferReservationConfirmedData+    deriving stock (Generic, Eq, Show)++type ReservationRegs =+    '[ '("reservationId", TransferReservationId)+     , '("hospitalId", HospitalId)+     , '("patientAcuity", PatientAcuity)+     , '("reservationState", ReservationVertex)+     ]++initialReservationRegs :: RegFile ReservationRegs+initialReservationRegs =+    RCons (Proxy @"reservationId") (TransferReservationId "") $+        RCons (Proxy @"hospitalId") (HospitalId "") $+            RCons (Proxy @"patientAcuity") GreenTag $+                RCons (Proxy @"reservationState") ReservationUnrequested RNil++$(deriveAggregateCtorsAll ''ReservationCommand ''ReservationRegs)++$(deriveWireCtorsAll ''ReservationEvent)
+ test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs view
@@ -0,0 +1,50 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.EventStream (+    reservationCategory,+    reservationEventStream,+    reservationEventStreamDef,+    ReservationEventStream,+    ReservationEventStreamDef,+    reservationSnapshotFixture,+) where++import Data.Text (Text)+import Generated.HospitalCapacity.Reservation.Codec (reservationCodec)+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (reservationTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Snapshot.Codec (defaultStateCodec)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+reservationCategory :: Stream.StreamCategory a+reservationCategory = Stream.categoryUnsafe "reservation"++type ReservationEventStreamDef =+    EventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++type ReservationEventStream =+    ValidatedEventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++reservationEventStreamDef :: ReservationEventStreamDef+reservationEventStreamDef =+    EventStream+        { transducer = reservationTransducer+        , initialState = ReservationUnrequested+        , initialRegisters = initialReservationRegs+        , eventCodec = reservationCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Every 100+        , stateCodec = Just (defaultStateCodec 1)+        }++reservationSnapshotFixture :: (Int, Text)+reservationSnapshotFixture = (1, "7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc")++reservationEventStream :: ReservationEventStream+reservationEventStream =+    mkEventStreamOrThrow "Reservation" reservationEventStreamDef
+ test/conformance-snapshot/HospitalCapacity/Reservation/Holes.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Its transducer body has been filled by hand to match the+-- captured HospitalCapacity/Reservation reference, against the generated+-- signatures. The harness pins this behaviour.+module HospitalCapacity.Reservation.Holes (+    reservationTransducer,+    applyTransfer_decisions,+) where++import Generated.HospitalCapacity.Reservation.Domain+import Keiki.Builder ((=:))+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer, lit, (./=), (.==), (.||))++reservationTransducer ::+    SymTransducer+        (HsPred ReservationRegs ReservationCommand)+        ReservationRegs+        ReservationVertex+        ReservationCommand+        ReservationEvent+reservationTransducer =+    B.buildTransducer ReservationUnrequested initialReservationRegs isTerminal do+        B.from ReservationUnrequested do+            B.onCmd inCtorRequestTransferReservation $ \d -> B.do+                B.requireGuard (d.divertStatus ./= lit TotalDivert .|| d.lifeCriticalOverride .== lit True)+                B.slot @"reservationState" =: lit ReservationHeld+                B.emit+                    wireTransferReservationCreated+                    TransferReservationCreatedTermFields+                        { reservationId = d.reservationId+                        , hospitalId = d.hospitalId+                        , commandId = d.commandId+                        , patientAcuity = d.patientAcuity+                        , divertStatus = d.divertStatus+                        , lifeCriticalOverride = d.lifeCriticalOverride+                        }+                B.goto ReservationHeld+        B.from ReservationHeld do+            B.onCmd inCtorConfirmReservation $ \d -> B.do+                B.slot @"reservationState" =: lit ReservationConfirmed+                B.emit+                    wireTransferReservationConfirmed+                    TransferReservationConfirmedTermFields+                        { reservationId = d.reservationId+                        , hospitalId = d.hospitalId+                        , commandId = d.commandId+                        }+                B.goto ReservationConfirmed+  where+    isTerminal = \case+        ReservationExpired -> True+        ReservationAdmitted -> True+        ReservationReleased -> True+        _ -> False++-- HOLE (DB-coupled, out of scope for EP-1): the read-model SQL for the+-- transfer_decisions projection. The pure event->status mapping is generated as+-- transfer_decisionsStatusFor. Left as a typed hole; the harness does not pin it.+applyTransfer_decisions :: ReservationEvent -> recorded -> txn ()+applyTransfer_decisions _event _recorded = error "HOLE: fill transfer_decisions projection apply"
+ test/conformance-snapshot/Main.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Main (main) where++import Control.Exception (evaluate)+import Control.Monad (unless)+import Data.Proxy (Proxy (..))+import Generated.HospitalCapacity.Reservation.Domain (ReservationRegs)+import Generated.HospitalCapacity.Reservation.EventStream (reservationEventStream, reservationEventStreamDef, reservationSnapshotFixture)+import Keiki.Shape (regFileShapeHash)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..), StateCodec (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    _ <- evaluate reservationEventStream+    case stateCodec reservationEventStreamDef of+        Nothing -> do+            putStrLn "snapshot codec present: False"+            exitFailure+        Just liveCodec -> do+            let (fixtureVersion, fixtureHash) = reservationSnapshotFixture+                versionOk = stateCodecVersion liveCodec == fixtureVersion+                hashOk = shapeHash liveCodec == fixtureHash+                hashDerived = shapeHash liveCodec == regFileShapeHash (Proxy @ReservationRegs)+                policyOk = case snapshotPolicy reservationEventStreamDef of+                    Every interval -> interval == 100+                    _ -> False+                encoded = encode liveCodec (initialState reservationEventStreamDef, initialRegisters reservationEventStreamDef)+                roundTripOk = case decode liveCodec encoded of+                    Left _ -> False+                    Right decoded -> encode liveCodec decoded == encoded+                checks = [versionOk, hashOk, hashDerived, policyOk, roundTripOk]+            putStrLn ("live snapshot shape hash: " <> show (shapeHash liveCodec))+            putStrLn ("codec version matches captured fixture: " <> show versionOk)+            putStrLn ("shape hash matches captured fixture: " <> show hashOk)+            putStrLn ("shape hash matches live regFileShapeHash: " <> show hashDerived)+            putStrLn ("snapshot policy is Every 100: " <> show policyOk)+            putStrLn ("initial snapshot JSON round-trips: " <> show roundTripOk)+            unless (and checks) exitFailure
+ test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Codec (+    reservationCodec,+    parseReservationEvent,+    encodeReservationEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (upcastTransferReservationCreatedV1)+import Keiro.Codec (Codec (..), EventType (..))++parsePatientAcuity :: Text -> Parser PatientAcuity+parsePatientAcuity = \case+    "red" -> pure RedTag+    "yellow" -> pure YellowTag+    "green" -> pure GreenTag+    _ -> fail "unknown PatientAcuity"++parseBedType :: Text -> Parser BedType+parseBedType = \case+    "icu" -> pure Icu+    "medical-surgical" -> pure MedicalSurgical+    _ -> fail "unknown BedType"++parseDivertStatus :: Text -> Parser DivertStatus+parseDivertStatus = \case+    "open" -> pure Open+    "partial-divert" -> pure PartialDivert+    "total-divert" -> pure TotalDivert+    _ -> fail "unknown DivertStatus"++reservationCodec :: Codec ReservationEvent+reservationCodec =+    Codec+        { eventTypes = EventType "TransferReservationCreated" :| [EventType "TransferReservationConfirmed"]+        , eventType = \case+            TransferReservationCreated{} -> EventType "TransferReservationCreated"+            TransferReservationConfirmed{} -> EventType "TransferReservationConfirmed"+        , schemaVersion = 2+        , encode = encodeReservationEvent+        , decode = parseReservationEvent+        , upcasters = [(1, const upcastTransferReservationCreatedV1)]+        }++encodeReservationEvent :: ReservationEvent -> Value+encodeReservationEvent = \case+    TransferReservationCreated payload ->+        object+            [ "kind" .= ("TransferReservationCreated" :: Text)+            , "reservationId" .= transferReservationIdText payload.reservationId+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "commandId" .= commandIdText payload.commandId+            , "patientAcuity" .= patientAcuityText payload.patientAcuity+            , "divertStatus" .= divertStatusText payload.divertStatus+            , "lifeCriticalOverride" .= payload.lifeCriticalOverride+            , "triageNote" .= payload.triageNote+            ]+    TransferReservationConfirmed payload ->+        object+            [ "kind" .= ("TransferReservationConfirmed" :: Text)+            , "reservationId" .= transferReservationIdText payload.reservationId+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "commandId" .= commandIdText payload.commandId+            ]++parseReservationEvent :: EventType -> Value -> Either Text ReservationEvent+parseReservationEvent (EventType tag) = mapLeftText . parseEither (withObject "ReservationEvent" go)+  where+    go o = do+        case tag of+            "TransferReservationCreated" ->+                TransferReservationCreated <$> (TransferReservationCreatedData <$> (TransferReservationId <$> o .: "reservationId") <*> (HospitalId <$> o .: "hospitalId") <*> (CommandId <$> o .: "commandId") <*> (o .: "patientAcuity" >>= parsePatientAcuity) <*> (o .: "divertStatus" >>= parseDivertStatus) <*> o .: "lifeCriticalOverride" <*> o .: "triageNote")+            "TransferReservationConfirmed" ->+                TransferReservationConfirmed <$> (TransferReservationConfirmedData <$> (TransferReservationId <$> o .: "reservationId") <*> (HospitalId <$> o .: "hospitalId") <*> (CommandId <$> o .: "commandId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype TransferReservationId = TransferReservationId Text+  deriving stock (Generic, Eq, Ord, Show)++transferReservationIdText :: TransferReservationId -> Text+transferReservationIdText (TransferReservationId t) = t++newtype HospitalId = HospitalId Text+  deriving stock (Generic, Eq, Ord, Show)++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++newtype CommandId = CommandId Text+  deriving stock (Generic, Eq, Ord, Show)++commandIdText :: CommandId -> Text+commandIdText (CommandId t) = t++data PatientAcuity = RedTag | YellowTag | GreenTag+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++patientAcuityText :: PatientAcuity -> Text+patientAcuityText = \case+  RedTag -> "red"+  YellowTag -> "yellow"+  GreenTag -> "green"++data BedType = Icu | MedicalSurgical+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++bedTypeText :: BedType -> Text+bedTypeText = \case+  Icu -> "icu"+  MedicalSurgical -> "medical-surgical"++data DivertStatus = Open | PartialDivert | TotalDivert+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++divertStatusText :: DivertStatus -> Text+divertStatusText = \case+  Open -> "open"+  PartialDivert -> "partial-divert"+  TotalDivert -> "total-divert"++data ReservationVertex = ReservationUnrequested | ReservationHeld | ReservationConfirmed | ReservationExpired | ReservationAdmitted | ReservationReleased+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data RequestTransferReservationData = RequestTransferReservationData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  , patientAcuity :: !PatientAcuity+  , divertStatus :: !DivertStatus+  , lifeCriticalOverride :: !Bool+  }+  deriving stock (Generic, Eq, Show)++data ConfirmReservationData = ConfirmReservationData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  }+  deriving stock (Generic, Eq, Show)++data ReservationCommand = RequestTransferReservation !RequestTransferReservationData+  | ConfirmReservation !ConfirmReservationData+  deriving stock (Generic, Eq, Show)++data TransferReservationCreatedData = TransferReservationCreatedData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  , patientAcuity :: !PatientAcuity+  , divertStatus :: !DivertStatus+  , lifeCriticalOverride :: !Bool+  , triageNote :: !Text+  }+  deriving stock (Generic, Eq, Show)++data TransferReservationConfirmedData = TransferReservationConfirmedData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  }+  deriving stock (Generic, Eq, Show)++data ReservationEvent = TransferReservationCreated !TransferReservationCreatedData+  | TransferReservationConfirmed !TransferReservationConfirmedData+  deriving stock (Generic, Eq, Show)++type ReservationRegs =+  '[ '("reservationId", TransferReservationId)+   , '("hospitalId", HospitalId)+   , '("patientAcuity", PatientAcuity)+   , '("reservationState", ReservationVertex)+   ]++initialReservationRegs :: RegFile ReservationRegs+initialReservationRegs =+  RCons (Proxy @"reservationId") (TransferReservationId "") $+  RCons (Proxy @"hospitalId") (HospitalId "") $+  RCons (Proxy @"patientAcuity") GreenTag $+  RCons (Proxy @"reservationState") ReservationUnrequested RNil++$(deriveAggregateCtorsAll ''ReservationCommand ''ReservationRegs)++++$(deriveWireCtorsAll ''ReservationEvent)
+ test/conformance-v2/Generated/HospitalCapacity/Reservation/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.EventStream (+    reservationCategory,+    reservationEventStream,+    reservationEventStreamDef,+    ReservationEventStream,+    ReservationEventStreamDef,+) where++import Generated.HospitalCapacity.Reservation.Codec (reservationCodec)+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (reservationTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+reservationCategory :: Stream.StreamCategory a+reservationCategory = Stream.categoryUnsafe "reservation"++type ReservationEventStreamDef =+    EventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++type ReservationEventStream =+    ValidatedEventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++reservationEventStreamDef :: ReservationEventStreamDef+reservationEventStreamDef =+    EventStream+        { transducer = reservationTransducer+        , initialState = ReservationUnrequested+        , initialRegisters = initialReservationRegs+        , eventCodec = reservationCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++reservationEventStream :: ReservationEventStream+reservationEventStream =+    mkEventStreamOrThrow "Reservation" reservationEventStreamDef
+ test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) where++import Generated.HospitalCapacity.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec)+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (reservationTransducer)+import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (EventType (..), decodeRaw, eventType)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions reservationTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: TransferReservationCreated", roundTrips sampleEventTransferReservationCreated)+    , ("golden round-trip: TransferReservationConfirmed", roundTrips sampleEventTransferReservationConfirmed)+    , ("accepts RequestTransferReservation from ReservationUnrequested", acceptRequestTransferReservation)+    , ("upcaster wired: a v1 TransferReservationCreated payload decodes through the chain", upcastsTransferReservationCreated)+    ]++roundTrips :: ReservationEvent -> Bool+roundTrips e = parseReservationEvent (eventType reservationCodec e) (encodeReservationEvent e) == Right e++sampleEventTransferReservationCreated :: ReservationEvent+sampleEventTransferReservationCreated = (TransferReservationCreated (TransferReservationCreatedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False "sample"))++sampleEventTransferReservationConfirmed :: ReservationEvent+sampleEventTransferReservationConfirmed = (TransferReservationConfirmed (TransferReservationConfirmedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample")))++acceptRequestTransferReservation :: Bool+acceptRequestTransferReservation =+    case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of+        Just (v, _, _) -> v == ReservationHeld+        Nothing -> False++upcastsTransferReservationCreated :: Bool+upcastsTransferReservationCreated =+    either+        (const False)+        (const True)+        (decodeRaw reservationCodec (EventType "TransferReservationCreated") 1 (encodeReservationEvent sampleEventTransferReservationCreated))
+ test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Projection+  ( transfer_decisionsProjection+  , transfer_decisionsStatusFor+  ) where++import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (applyTransfer_decisions)+import Data.Text (Text)+import Keiro.Projection (InlineProjection (..))++-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived+-- from the spec's status-map. The read-model SQL that consumes it lives in+-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).+transfer_decisionsStatusFor :: ReservationEvent -> Maybe Text+transfer_decisionsStatusFor = \case+  TransferReservationCreated {} -> Just "held"+  TransferReservationConfirmed {} -> Just "confirmed"++transfer_decisionsProjection :: InlineProjection ReservationEvent+transfer_decisionsProjection =+  InlineProjection+    { name = "hospital-capacity-transfer_decisions-inline"+    , apply = applyTransfer_decisions+    }
+ test/conformance-v2/HospitalCapacity/Reservation/Holes.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- HAND-OWNED hole module, filled by hand for the v2 (evolved) conformance+-- aggregate. The transducer body matches the v1 reference; the v2 event carries+-- a new `triageNote` field sourced as a literal here, and the upcaster defaults+-- `triageNote` on v1-on-disk payloads that lack it.+module HospitalCapacity.Reservation.Holes (+    reservationTransducer,+    applyTransfer_decisions,+    upcastTransferReservationCreatedV1,+) where++import Data.Aeson (Value (..))+import Data.Aeson.KeyMap qualified as KM+import Data.Text (Text)+import Generated.HospitalCapacity.Reservation.Domain+import Keiki.Builder ((=:))+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer, lit, (./=), (.==), (.||))++reservationTransducer ::+    SymTransducer+        (HsPred ReservationRegs ReservationCommand)+        ReservationRegs+        ReservationVertex+        ReservationCommand+        ReservationEvent+reservationTransducer =+    B.buildTransducer ReservationUnrequested initialReservationRegs isTerminal do+        B.from ReservationUnrequested do+            B.onCmd inCtorRequestTransferReservation $ \d -> B.do+                B.requireGuard (d.divertStatus ./= lit TotalDivert .|| d.lifeCriticalOverride .== lit True)+                B.slot @"reservationState" =: lit ReservationHeld+                B.emit+                    wireTransferReservationCreated+                    TransferReservationCreatedTermFields+                        { reservationId = d.reservationId+                        , hospitalId = d.hospitalId+                        , commandId = d.commandId+                        , patientAcuity = d.patientAcuity+                        , divertStatus = d.divertStatus+                        , lifeCriticalOverride = d.lifeCriticalOverride+                        , triageNote = lit ""+                        }+                B.goto ReservationHeld+        B.from ReservationHeld do+            B.onCmd inCtorConfirmReservation $ \d -> B.do+                B.slot @"reservationState" =: lit ReservationConfirmed+                B.emit+                    wireTransferReservationConfirmed+                    TransferReservationConfirmedTermFields+                        { reservationId = d.reservationId+                        , hospitalId = d.hospitalId+                        , commandId = d.commandId+                        }+                B.goto ReservationConfirmed+  where+    isTerminal = \case+        ReservationExpired -> True+        ReservationAdmitted -> True+        ReservationReleased -> True+        _ -> False++applyTransfer_decisions :: ReservationEvent -> recorded -> txn ()+applyTransfer_decisions _event _recorded = error "HOLE: fill transfer_decisions projection apply"++-- Bring a v1 TransferReservationCreated payload up to v2 by defaulting the new+-- `triageNote` field when it is absent (a v1-on-disk payload lacks it).+upcastTransferReservationCreatedV1 :: Value -> Either Text Value+upcastTransferReservationCreatedV1 v = case v of+    Object o -> Right (Object (KM.insertWith (\_new old -> old) "triageNote" (String "") o))+    _ -> Left "upcastTransferReservationCreatedV1: expected a JSON object"
+ test/conformance-v2/Main.hs view
@@ -0,0 +1,22 @@+{- | Conformance driver for the evolved (v2) HospitalCapacity/Reservation+aggregate (EP-2). Compiling this component proves the scaffolded v2 Generated+modules — a Codec with @schemaVersion = 2@ and+@upcasters = [(1, upcastTransferReservationCreatedV1)]@ — build against+keiki/keiro with the hand-filled upcaster hole. Running it proves the upcaster+chain actually migrates a v1-tagged payload forward (the "upcaster wired"+harness assertion is green only because the hole is filled).+-}+module Main (main) where++import Control.Monad (forM_, unless)+import Generated.HospitalCapacity.Reservation.Harness (harnessAssertions)+import System.Exit (exitFailure)++main :: IO ()+main = do+    forM_ harnessAssertions $ \(label, ok) ->+        putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    let failed = [label | (label, ok) <- harnessAssertions, not ok]+    unless (null failed) $ do+        putStrLn ("harness: " <> show (length failed) <> " assertion(s) failed")+        exitFailure
+ test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime (+    workflowName,+    awaitAwakeableId,+    awaitLabels,+    declaredPatches,+    declaredPatchStepNames,+    withDeclaredPatches,+) where++import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Workflow (WorkflowRunOptions (..))+import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)+import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)++workflowName :: WorkflowName+workflowName = WorkflowName "hospital-transfer-reservation"++-- The awakeable id an await allocates — the real deterministicAwakeableId.+-- A signal op deriving the same (name, id, label) gets the same id.+awaitAwakeableId :: WorkflowId -> Text -> AwakeableId+awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label++awaitLabels :: [Text]+awaitLabels = ["reservation-confirmation"]++declaredPatches :: Set PatchId+declaredPatches = Set.fromList [PatchId "fraud-check-v2"]++-- The journal keys the runtime records patch decisions under.+declaredPatchStepNames :: [Text]+declaredPatchStepNames = map patchStepName (Set.toList declaredPatches)++-- Activate exactly the patches declared by this spec for a workflow run.+withDeclaredPatches :: WorkflowRunOptions -> WorkflowRunOptions+withDeclaredPatches opts = opts{activePatches = declaredPatches}
+ test/conformance-workflow-full/HospitalCapacity/HospitalTransferReservation/WorkflowBody.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- HAND-FILLED workflow body (EP-6 M5 full-service integration): the ordered+-- step/await body — the behaviour-bearing hole — written against the live+-- Keiro.Workflow effect (step / awaitStep), with the journal step names matching+-- the scaffolded WorkflowFacts/WorkflowRuntime labels. The step bodies here are+-- trivial (the agent fills real domain effects); the structure is what the+-- scaffold pins.+module HospitalCapacity.HospitalTransferReservation.WorkflowBody (+    reservationWorkflow,+) where++import Control.Monad (void, when)+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import Effectful (Eff, (:>))+import GHC.Generics (Generic)+import Keiro.Workflow (Workflow, awaitStep, continueAsNew, patch, restoreSeed, step)+import Keiro.Workflow.Types (PatchId (..), StepName (..))++newtype RolloverSeed = RolloverSeed Text+    deriving stock (Eq, Show, Generic)+    deriving anyclass (FromJSON, ToJSON)++reservationWorkflow :: (Workflow :> es) => Eff es Text+reservationWorkflow = do+    restored <- restoreSeed (RolloverSeed "first-generation")+    _hold <- step (StepName "create-transfer-hold") (pure ("hold" :: Text))+    fraudCheckActive <- patch (PatchId "fraud-check-v2")+    when fraudCheckActive $+        void (step (StepName "fraud-check") (pure ("clear" :: Text)))+    confirmed <- awaitStep (StepName "reservation-confirmation") (pure ())+    _released <- step (StepName "release-or-retain-capacity") (pure ("released" :: Text))+    summary <- step (StepName "summarize-reservation") (pure (confirmed <> " summary"))+    continueAsNew (RolloverSeed (summary <> " after " <> seedText restored))+  where+    seedText (RolloverSeed seed) = seed
+ test/conformance-workflow-full/Main.hs view
@@ -0,0 +1,21 @@+{- | EP-6 M5 full-service conformance: a complete durable workflow — the+scaffolded WorkflowRuntime (name + awakeable-id derivation) plus a FILLED+ordered step/await body — compiled against the live Keiro.Workflow effect.+The body's await label is the same one the scaffolded runtime declares.+-}+module Main (main) where++import Control.Monad (unless)+import Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime (awaitLabels, declaredPatchStepNames)+import System.Exit (exitFailure)++-- The filled workflow body (reservationWorkflow) is compiled as the+-- WorkflowBody other-module; here we check its await label is the one the+-- scaffolded runtime declares.+main :: IO ()+main = do+    let labelOk = "reservation-confirmation" `elem` awaitLabels+        patchOk = declaredPatchStepNames == ["patch:fraud-check-v2"]+    putStrLn ("workflow body compiles against Keiro.Workflow + await label declared: " <> show labelOk)+    putStrLn ("workflow body patch uses the declared runtime journal key: " <> show patchOk)+    unless (labelOk && patchOk) exitFailure
+ test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime (+    workflowName,+    awaitAwakeableId,+    awaitLabels,+    declaredPatches,+    declaredPatchStepNames,+    withDeclaredPatches,+) where++import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Workflow (WorkflowRunOptions (..))+import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)+import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)++workflowName :: WorkflowName+workflowName = WorkflowName "hospital-transfer-reservation"++-- The awakeable id an await allocates — the real deterministicAwakeableId.+-- A signal op deriving the same (name, id, label) gets the same id.+awaitAwakeableId :: WorkflowId -> Text -> AwakeableId+awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label++awaitLabels :: [Text]+awaitLabels = ["reservation-confirmation"]++declaredPatches :: Set PatchId+declaredPatches = Set.fromList [PatchId "fraud-check-v2"]++-- The journal keys the runtime records patch decisions under.+declaredPatchStepNames :: [Text]+declaredPatchStepNames = map patchStepName (Set.toList declaredPatches)++-- Activate exactly the patches declared by this spec for a workflow run.+withDeclaredPatches :: WorkflowRunOptions -> WorkflowRunOptions+withDeclaredPatches opts = opts{activePatches = declaredPatches}
+ test/conformance-workflow-runtime/Main.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++{- | EP-6 workflow runtime conformance: the scaffolded @WorkflowRuntime@ — the+WorkflowName and the awakeable-id derivation — compiled against the LIVE+@Keiro.Workflow@. The headline check: the id an `await` allocates equals the+id the partner `signal` operation derives from the same (name, id, label),+computed by the REAL deterministicAwakeableId. A label mismatch diverges.+-}+module Main (main) where++import Control.Monad (unless)+import Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime (+    awaitAwakeableId,+    awaitLabels,+    declaredPatchStepNames,+    declaredPatches,+    withDeclaredPatches,+    workflowName,+ )+import Keiro.Workflow (WorkflowRunOptions (activePatches), defaultWorkflowRunOptions)+import Keiro.Workflow.Awakeable (deterministicAwakeableId)+import Keiro.Workflow.Types (WorkflowId (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+    let wid = WorkflowId "rsv-1"+        label = "reservation-confirmation"+        -- the signal operation derives the id the SAME way (same name, id, label).+        signalSide = deterministicAwakeableId workflowName wid label+        awaitSide = awaitAwakeableId wid label+        matchOk = awaitSide == signalSide+        -- a non-matching label must NOT collide.+        mismatchOk = awaitAwakeableId wid "reservation-confirmed" /= awaitSide+        labelsOk = label `elem` awaitLabels+        patchKeysOk = declaredPatchStepNames == ["patch:fraud-check-v2"]+        activePatchesOk = activePatches (withDeclaredPatches defaultWorkflowRunOptions) == declaredPatches+    putStrLn ("await<->signal awakeable id match (real deterministicAwakeableId): " <> show matchOk)+    putStrLn ("mismatched label diverges: " <> show mismatchOk)+    putStrLn ("await label declared: " <> show labelsOk)+    putStrLn ("declared patch journal key uses live patchStepName: " <> show patchKeysOk)+    putStrLn ("run options activate exactly declared patches: " <> show activePatchesOk)+    unless (matchOk && mismatchOk && labelsOk && patchKeysOk && activePatchesOk) exitFailure
+ test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.HospitalTransferReservation.WorkflowFacts (workflowFacts) where++{- | (label, value): the workflow's deterministic decisions, pinned as pure+facts. A driver asserts them against a hand-written expectation, so a spec+change (e.g. renaming an await) reddens a specific assertion.+-}+workflowFacts :: [(String, String)]+workflowFacts =+    [ ("name", "hospital-transfer-reservation")+    , ("idVia", "idText")+    , ("idField", "reservationId")+    , ("body", "step:create-transfer-hold,patch:fraud-check-v2(step:fraud-check),await:reservation-confirmation,step:release-or-retain-capacity,step:summarize-reservation,continueAsNew:RolloverSeed")+    , ("awaits", "reservation-confirmation")+    , ("patches", "fraud-check-v2")+    ]
+ test/conformance-workflow/Main.hs view
@@ -0,0 +1,27 @@+{- | Conformance driver for the EP-6 workflow facts harness. The scaffolded+WorkflowFacts module exports the workflow's deterministic decisions; this+driver asserts them against a HAND-WRITTEN expectation, so a spec change+(e.g. renaming the await label) diverges and reddens a specific assertion.+-}+module Main (main) where++import Control.Monad (forM_, unless)+import Generated.HospitalCapacity.HospitalTransferReservation.WorkflowFacts (workflowFacts)+import System.Exit (exitFailure)++expected :: [(String, String)]+expected =+    [ ("name", "hospital-transfer-reservation")+    , ("idVia", "idText")+    , ("idField", "reservationId")+    , ("body", "step:create-transfer-hold,patch:fraud-check-v2(step:fraud-check),await:reservation-confirmation,step:release-or-retain-capacity,step:summarize-reservation,continueAsNew:RolloverSeed")+    , ("awaits", "reservation-confirmation") -- the signal operation's id must match this+    , ("patches", "fraud-check-v2")+    ]++main :: IO ()+main = do+    let results = [(label, lookup label workflowFacts == Just want) | (label, want) <- expected]+    forM_ results $ \(label, ok) -> putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    let failed = [label | (label, ok) <- results, not ok]+    unless (null failed) $ putStrLn ("workflow facts: failed " <> show failed) >> exitFailure
+ test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Codec (+    reservationCodec,+    parseReservationEvent,+    encodeReservationEvent,+) where++import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text qualified as T+import Generated.HospitalCapacity.Reservation.Domain+import Keiro.Codec (Codec (..), EventType (..))++parsePatientAcuity :: Text -> Parser PatientAcuity+parsePatientAcuity = \case+    "red" -> pure RedTag+    "yellow" -> pure YellowTag+    "green" -> pure GreenTag+    _ -> fail "unknown PatientAcuity"++parseBedType :: Text -> Parser BedType+parseBedType = \case+    "icu" -> pure Icu+    "medical-surgical" -> pure MedicalSurgical+    _ -> fail "unknown BedType"++parseDivertStatus :: Text -> Parser DivertStatus+parseDivertStatus = \case+    "open" -> pure Open+    "partial-divert" -> pure PartialDivert+    "total-divert" -> pure TotalDivert+    _ -> fail "unknown DivertStatus"++reservationCodec :: Codec ReservationEvent+reservationCodec =+    Codec+        { eventTypes = EventType "TransferReservationCreated" :| [EventType "TransferReservationConfirmed"]+        , eventType = \case+            TransferReservationCreated{} -> EventType "TransferReservationCreated"+            TransferReservationConfirmed{} -> EventType "TransferReservationConfirmed"+        , schemaVersion = 1+        , encode = encodeReservationEvent+        , decode = parseReservationEvent+        , upcasters = []+        }++encodeReservationEvent :: ReservationEvent -> Value+encodeReservationEvent = \case+    TransferReservationCreated payload ->+        object+            [ "kind" .= ("TransferReservationCreated" :: Text)+            , "reservationId" .= transferReservationIdText payload.reservationId+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "commandId" .= commandIdText payload.commandId+            , "patientAcuity" .= patientAcuityText payload.patientAcuity+            , "divertStatus" .= divertStatusText payload.divertStatus+            , "lifeCriticalOverride" .= payload.lifeCriticalOverride+            ]+    TransferReservationConfirmed payload ->+        object+            [ "kind" .= ("TransferReservationConfirmed" :: Text)+            , "reservationId" .= transferReservationIdText payload.reservationId+            , "hospitalId" .= hospitalIdText payload.hospitalId+            , "commandId" .= commandIdText payload.commandId+            ]++parseReservationEvent :: EventType -> Value -> Either Text ReservationEvent+parseReservationEvent (EventType tag) = mapLeftText . parseEither (withObject "ReservationEvent" go)+  where+    go o = do+        case tag of+            "TransferReservationCreated" ->+                TransferReservationCreated <$> (TransferReservationCreatedData <$> (TransferReservationId <$> o .: "reservationId") <*> (HospitalId <$> o .: "hospitalId") <*> (CommandId <$> o .: "commandId") <*> (o .: "patientAcuity" >>= parsePatientAcuity) <*> (o .: "divertStatus" >>= parseDivertStatus) <*> o .: "lifeCriticalOverride")+            "TransferReservationConfirmed" ->+                TransferReservationConfirmed <$> (TransferReservationConfirmedData <$> (TransferReservationId <$> o .: "reservationId") <*> (HospitalId <$> o .: "hospitalId") <*> (CommandId <$> o .: "commandId"))+            _ -> fail "unknown event type"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right
+ test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++newtype TransferReservationId = TransferReservationId Text+  deriving stock (Generic, Eq, Ord, Show)++transferReservationIdText :: TransferReservationId -> Text+transferReservationIdText (TransferReservationId t) = t++newtype HospitalId = HospitalId Text+  deriving stock (Generic, Eq, Ord, Show)++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId t) = t++newtype CommandId = CommandId Text+  deriving stock (Generic, Eq, Ord, Show)++commandIdText :: CommandId -> Text+commandIdText (CommandId t) = t++data PatientAcuity = RedTag | YellowTag | GreenTag+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++patientAcuityText :: PatientAcuity -> Text+patientAcuityText = \case+  RedTag -> "red"+  YellowTag -> "yellow"+  GreenTag -> "green"++data BedType = Icu | MedicalSurgical+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++bedTypeText :: BedType -> Text+bedTypeText = \case+  Icu -> "icu"+  MedicalSurgical -> "medical-surgical"++data DivertStatus = Open | PartialDivert | TotalDivert+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++divertStatusText :: DivertStatus -> Text+divertStatusText = \case+  Open -> "open"+  PartialDivert -> "partial-divert"+  TotalDivert -> "total-divert"++data ReservationVertex = ReservationUnrequested | ReservationHeld | ReservationConfirmed | ReservationExpired | ReservationAdmitted | ReservationReleased+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data RequestTransferReservationData = RequestTransferReservationData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  , patientAcuity :: !PatientAcuity+  , divertStatus :: !DivertStatus+  , lifeCriticalOverride :: !Bool+  }+  deriving stock (Generic, Eq, Show)++data ConfirmReservationData = ConfirmReservationData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  }+  deriving stock (Generic, Eq, Show)++data ReservationCommand = RequestTransferReservation !RequestTransferReservationData+  | ConfirmReservation !ConfirmReservationData+  deriving stock (Generic, Eq, Show)++data TransferReservationCreatedData = TransferReservationCreatedData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  , patientAcuity :: !PatientAcuity+  , divertStatus :: !DivertStatus+  , lifeCriticalOverride :: !Bool+  }+  deriving stock (Generic, Eq, Show)++data TransferReservationConfirmedData = TransferReservationConfirmedData+  { reservationId :: !TransferReservationId+  , hospitalId :: !HospitalId+  , commandId :: !CommandId+  }+  deriving stock (Generic, Eq, Show)++data ReservationEvent = TransferReservationCreated !TransferReservationCreatedData+  | TransferReservationConfirmed !TransferReservationConfirmedData+  deriving stock (Generic, Eq, Show)++type ReservationRegs =+  '[ '("reservationId", TransferReservationId)+   , '("hospitalId", HospitalId)+   , '("patientAcuity", PatientAcuity)+   , '("reservationState", ReservationVertex)+   ]++initialReservationRegs :: RegFile ReservationRegs+initialReservationRegs =+  RCons (Proxy @"reservationId") (TransferReservationId "") $+  RCons (Proxy @"hospitalId") (HospitalId "") $+  RCons (Proxy @"patientAcuity") GreenTag $+  RCons (Proxy @"reservationState") ReservationUnrequested RNil++$(deriveAggregateCtorsAll ''ReservationCommand ''ReservationRegs)++++$(deriveWireCtorsAll ''ReservationEvent)
+ test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs view
@@ -0,0 +1,44 @@+-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.EventStream (+    reservationCategory,+    reservationEventStream,+    reservationEventStreamDef,+    ReservationEventStream,+    ReservationEventStreamDef,+) where++import Generated.HospitalCapacity.Reservation.Codec (reservationCodec)+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (reservationTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+reservationCategory :: Stream.StreamCategory a+reservationCategory = Stream.categoryUnsafe "reservation"++type ReservationEventStreamDef =+    EventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++type ReservationEventStream =+    ValidatedEventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++reservationEventStreamDef :: ReservationEventStreamDef+reservationEventStreamDef =+    EventStream+        { transducer = reservationTransducer+        , initialState = ReservationUnrequested+        , initialRegisters = initialReservationRegs+        , eventCodec = reservationCodec+        , resolveStreamName = Stream.streamName+        , snapshotPolicy = Never+        , stateCodec = Nothing+        }++reservationEventStream :: ReservationEventStream+reservationEventStream =+    mkEventStreamOrThrow "Reservation" reservationEventStreamDef
+ test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) where++import Generated.HospitalCapacity.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec)+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (reservationTransducer)+import Keiki.Core (defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)++{- | (label, passed). A driver runs these and exits non-zero on any False,+naming the failing assertion. Filling a hole wrongly turns a specific+entry False; the scaffold cannot.+-}+harnessAssertions :: [(String, Bool)]+harnessAssertions =+    [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions reservationTransducer))+    , ("clock-free: spec samples no wall clock", True)+    , ("golden round-trip: TransferReservationCreated", roundTrips sampleEventTransferReservationCreated)+    , ("golden round-trip: TransferReservationConfirmed", roundTrips sampleEventTransferReservationConfirmed)+    , ("accepts RequestTransferReservation from ReservationUnrequested", acceptRequestTransferReservation)+    ]++roundTrips :: ReservationEvent -> Bool+roundTrips e = parseReservationEvent (eventType reservationCodec e) (encodeReservationEvent e) == Right e++sampleEventTransferReservationCreated :: ReservationEvent+sampleEventTransferReservationCreated = (TransferReservationCreated (TransferReservationCreatedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))++sampleEventTransferReservationConfirmed :: ReservationEvent+sampleEventTransferReservationConfirmed = (TransferReservationConfirmed (TransferReservationConfirmedData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample")))++acceptRequestTransferReservation :: Bool+acceptRequestTransferReservation =+    case step reservationTransducer (ReservationUnrequested, initialReservationRegs) ((RequestTransferReservation (RequestTransferReservationData (TransferReservationId "sample") (HospitalId "sample") (CommandId "sample") RedTag Open False))) of+        Just (v, _, _) -> v == ReservationHeld+        Nothing -> False
+ test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec.+module Generated.HospitalCapacity.Reservation.Projection (+    transfer_decisionsProjection,+    transfer_decisionsStatusFor,+) where++import Data.Text (Text)+import Generated.HospitalCapacity.Reservation.Domain+import HospitalCapacity.Reservation.Holes (applyTransfer_decisions)+import Keiro.Projection (InlineProjection (..))++-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived+-- from the spec's status-map. The read-model SQL that consumes it lives in+-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).+-- WARNING: no readmodel node declares 'transfer_decisions'; unqualified SQL depends on search_path.+transfer_decisionsStatusFor :: ReservationEvent -> Maybe Text+transfer_decisionsStatusFor = \case+    TransferReservationCreated{} -> Just "held"+    TransferReservationConfirmed{} -> Just "confirmed"++transfer_decisionsProjection :: InlineProjection ReservationEvent+transfer_decisionsProjection =+    InlineProjection+        { name = "hospital-capacity-transfer_decisions-inline"+        , apply = applyTransfer_decisions+        }
+ test/conformance/HospitalCapacity/Reservation/Holes.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never+-- overwrites it. Its transducer body has been filled by hand to match the+-- captured HospitalCapacity/Reservation reference, against the generated+-- signatures. The harness pins this behaviour.+module HospitalCapacity.Reservation.Holes (+    reservationTransducer,+    applyTransfer_decisions,+) where++import Generated.HospitalCapacity.Reservation.Domain+import Keiki.Builder ((=:))+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer, lit, (./=), (.==), (.||))++reservationTransducer ::+    SymTransducer+        (HsPred ReservationRegs ReservationCommand)+        ReservationRegs+        ReservationVertex+        ReservationCommand+        ReservationEvent+reservationTransducer =+    B.buildTransducer ReservationUnrequested initialReservationRegs isTerminal do+        B.from ReservationUnrequested do+            B.onCmd inCtorRequestTransferReservation $ \d -> B.do+                B.requireGuard (d.divertStatus ./= lit TotalDivert .|| d.lifeCriticalOverride .== lit True)+                B.slot @"reservationState" =: lit ReservationHeld+                B.emit+                    wireTransferReservationCreated+                    TransferReservationCreatedTermFields+                        { reservationId = d.reservationId+                        , hospitalId = d.hospitalId+                        , commandId = d.commandId+                        , patientAcuity = d.patientAcuity+                        , divertStatus = d.divertStatus+                        , lifeCriticalOverride = d.lifeCriticalOverride+                        }+                B.goto ReservationHeld+        B.from ReservationHeld do+            B.onCmd inCtorConfirmReservation $ \d -> B.do+                B.slot @"reservationState" =: lit ReservationConfirmed+                B.emit+                    wireTransferReservationConfirmed+                    TransferReservationConfirmedTermFields+                        { reservationId = d.reservationId+                        , hospitalId = d.hospitalId+                        , commandId = d.commandId+                        }+                B.goto ReservationConfirmed+  where+    isTerminal = \case+        ReservationExpired -> True+        ReservationAdmitted -> True+        ReservationReleased -> True+        _ -> False++-- HOLE (DB-coupled, out of scope for EP-1): the read-model SQL for the+-- transfer_decisions projection. The pure event->status mapping is generated as+-- transfer_decisionsStatusFor. Left as a typed hole; the harness does not pin it.+applyTransfer_decisions :: ReservationEvent -> recorded -> txn ()+applyTransfer_decisions _event _recorded = error "HOLE: fill transfer_decisions projection apply"
+ test/conformance/Main.hs view
@@ -0,0 +1,26 @@+{- | Conformance driver for the captured HospitalCapacity/Reservation aggregate.+It runs the spec-derived harness emitted by 'Keiro.Dsl.Harness.harnessFor'+(the @Generated.…Harness@ module) over the hand-filled @Holes.hs@, printing+each labelled assertion and exiting non-zero if any is False. Compiling this+component at all proves the scaffolded Generated modules + filled holes build+against keiki/keiro; running it proves the filled transducer is valid, every+event round-trips, and the guarded transition behaves as specified.++The mutation check (flip @./=@ to @.==@ in Holes, rebuild) turns the+"accepts RequestTransferReservation …" assertion red, proving the harness —+not the scaffold — pins behaviour.+-}+module Main (main) where++import Control.Monad (forM_, unless)+import Generated.HospitalCapacity.Reservation.Harness (harnessAssertions)+import System.Exit (exitFailure)++main :: IO ()+main = do+    forM_ harnessAssertions $ \(label, ok) ->+        putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)+    let failed = [label | (label, ok) <- harnessAssertions, not ok]+    unless (null failed) $ do+        putStrLn ("harness: " <> show (length failed) <> " assertion(s) failed")+        exitFailure