keiro-dsl 0.6.0.0 → 0.7.0.0

raw patch · 121 files changed

+13127/−5195 lines, 121 filesdep ~aesondep ~containersdep ~keikiPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, containers, keiki, keiro-core, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +100/−0
• app/Main.hs +108/−26
• keiro-dsl.cabal +142/−28
• src/Keiro/Dsl/AggregateType.hs +5/−0
• src/Keiro/Dsl/BehaviorCoverage.hs +509/−0
• src/Keiro/Dsl/Diff.hs +78/−3
• src/Keiro/Dsl/DiffReport.hs +2/−0
• src/Keiro/Dsl/EventOutput.hs +148/−0
• src/Keiro/Dsl/ExplainBindings.hs +43/−11
• src/Keiro/Dsl/Expression.hs +6/−1
• src/Keiro/Dsl/FoldFingerprint.hs +82/−9
• src/Keiro/Dsl/Harness.hs +137/−17
• src/Keiro/Dsl/IdDomain.hs +51/−0
• src/Keiro/Dsl/LanguageVersion.hs +30/−1
• src/Keiro/Dsl/NominalType.hs +119/−0
• src/Keiro/Dsl/Parser.hs +228/−178
• src/Keiro/Dsl/ReplayImpact.hs +23/−10
• src/Keiro/Dsl/Scaffold.hs +5236/−4032
• src/Keiro/Dsl/ScaffoldRecord.hs +38/−4
• src/Keiro/Dsl/ScaffoldRun.hs +173/−63
• src/Keiro/Dsl/SemanticContract.hs +124/−0
• src/Keiro/Dsl/Validate.hs +75/−10
• src/Keiro/Dsl/Workspace.hs +27/−5
• src/Keiro/Dsl/WorkspaceDiff.hs +3/−3
• src/Keiro/Dsl/WorkspaceRecord.hs +33/−0
• src/Keiro/Dsl/WorkspaceScaffold.hs +73/−14
• test/Main.hs +774/−22
• test/conformance-behavior-complete/BehaviorComplete/Bindings.hs +31/−0
• test/conformance-behavior-complete/BehaviorComplete/Domain.hs +18/−0
• test/conformance-behavior-complete/BehaviorComplete/Journey/BehaviorHoles.hs +73/−0
• test/conformance-behavior-complete/BehaviorComplete/Journey/Holes.hs +29/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/BehaviorContract.hs +296/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs +117/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Domain.hs +106/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/EventStream.hs +58/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Expressions.hs +51/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Harness.hs +149/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Projection.hs +2/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Transducer.hs +108/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/ReplayAudit.hs +24/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/Structural/Shape/StartPayload.hs +13/−0
• test/conformance-behavior-complete/Generated/BehaviorComplete/StructuralProjections.hs +30/−0
• test/conformance-behavior-complete/Main.hs +28/−0
• test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals.hs +18/−0
• test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals/Internal.hs +38/−0
• test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Codec.hs +53/−0
• test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Domain.hs +53/−0
• test/conformance-id-domain-migration/Main.hs +65/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs +4/−8
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/BehaviorContract.hs +281/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs +48/−44
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Domain.hs +49/−42
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/EventStream.hs +58/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Expressions.hs +47/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Harness.hs +88/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Projection.hs +2/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Transducer.hs +74/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalProjections.hs +97/−42
• test/conformance-nominal-scalars/Generated/NominalScalars/ReplayAudit.hs +24/−0
• test/conformance-nominal-scalars/Main.hs +114/−14
• test/conformance-nominal-scalars/NominalScalars/NominalLedger/BehaviorHoles.hs +10/−0
• test/conformance-scalar-expressions/AggregateScalarExpressions/ScalarAccount/BehaviorHoles.hs +14/−0
• test/conformance-scalar-expressions/AggregateScalarExpressions/ScalarAccount/Holes.hs +4/−25
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals.hs +67/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/BehaviorContract.hs +286/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs +2/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs +1/−18
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Expressions.hs +3/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs +3/−2
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs +16/−4
• test/conformance-scalar-expressions/Main.hs +77/−6
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Nominals.hs +19/−0
• test/conformance-skeletons/SkelAggregate/Generated/MyService/ReplayAudit.hs +8/−9
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Codec.hs +26/−22
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Domain.hs +19/−23
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/EventStream.hs +22/−22
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs +26/−26
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Projection.hs +0/−0
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Codec.hs +25/−21
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Domain.hs +14/−24
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/EventStream.hs +22/−22
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs +24/−24
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Projection.hs +0/−0
• test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/Process.hs +27/−28
• test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/ProcessHarness.hs +11/−12
• test/conformance-skeletons/SkelProcess/Generated/MyService/Nominals.hs +28/−0
• test/conformance-skeletons/SkelProcess/Generated/MyService/ReplayAudit.hs +15/−16
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Codec.hs +37/−33
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Domain.hs +32/−44
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/EventStream.hs +22/−22
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs +41/−41
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Projection.hs +0/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals.hs +78/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/BehaviorContract.hs +286/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Codec.hs +67/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Domain.hs +65/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/EventStream.hs +44/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Expressions.hs +31/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Harness.hs +60/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Projection.hs +2/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Transducer.hs +73/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs +281/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs +58/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs +51/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs +44/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Expressions.hs +27/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs +56/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs +2/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs +64/−0
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ReplayAudit.hs +31/−0
• test/conformance-workspace-nominals/Main.hs +81/−0
• test/conformance-workspace-nominals/WorkspaceNominalProof/Project/BehaviorHoles.hs +14/−0
• test/conformance-workspace-nominals/WorkspaceNominalProof/ProjectArtifact/BehaviorHoles.hs +10/−0
• test/conformance/Generated/HospitalCapacity/Nominals.hs +72/−0
• test/conformance/Generated/HospitalCapacity/ReplayAudit.hs +7/−8
• test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs +49/−52
• test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs +1/−44
• test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs +20/−20
• test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs +27/−27
• test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs +11/−12
• test/conformance/HospitalCapacity/Reservation/Holes.hs +1/−0

@@ -6,6 +6,106 @@  ## [Unreleased] +## 0.7.0.0 — 2026-08-01++### Breaking Changes++- Language version 3 makes each generated prefix-bearing ID abstract. Import+  `parseX`, `mkX`, and `xText` from `Generated.<Context>.Nominals`; the raw+  constructor and `unsafeXFromLegacyText` live only in the generated internal+  replay module. Version 1, version 2, and legacy-unversioned generated output+  retain their released constructor and decoder behavior.++- `DiagnosticCode` gains the append-only `IdDomainContractChanged` constructor.+  Exhaustive matches must classify the new command/public-codec, replay,+  snapshot, persisted-identity, and consumer-build vector.++- Generated service-level IDs and enums now live in one context-level+  `Generated.<Context>.Nominals` module instead of being redeclared in every+  aggregate `Domain`. Hand-owned modules that construct these values must import+  the constructors from `Nominals` explicitly. Re-scaffolding overwrites only+  generated files; event wire bytes and canonical nominal identities are+  unchanged.++- Requires `keiki >=0.7 && <0.8`. Keiki 0.7 deliberately treats predicates+  crossing a one-way generated projection as opaque to symbolic proof, so+  verification may now return `UnverifiedOpaque` where an earlier release+  reported `Verified*`. Runtime stepping and replay are unchanged. Supply an+  exact projection with its reverse witness when proof-strength verification is+  required; behavior-conformance reports retain this surface as unverified.++- `DiagnosticCode` gains the append-only `EventOutputCommandMismatch` and+  `AggregateEventlessStateChange` constructors. Exhaustive matches must be+  extended. A version-2 transition that emits no event may no longer change+  control state or registers; only an actual no-op is accepted.++- Requires `keiro-core ^>=0.7.0.0` for the `Keiro.Codec.IdDomain` contract that+  generated version-3 identifier code imports. The bound is now explicit; the+  0.6.0.0 library dependency on `keiro-core` carried no version constraint.++### New Features++- Adds `language keiro-dsl 3`, selecting+  `keiro-dsl/runtime-semantics/2`. Prefix-bearing IDs now use the frozen+  `keiro-dsl/id-domain/typeid-v7/1` contract: canonical lowercase TypeID-v7+  text, the declared prefix and one underscore, a 26-character Crockford+  suffix, UUIDv7 version/variant bits, and JSON strings. Runtime admission and+  Keiki 0.7 exact textual projection domains derive from the same contract.+- Generated and consumer-bound v3 IDs validate before binding conversion,+  current JSON decoding, literals, and scaffold samples. Binding harnesses add+  exact projection, fixture-domain, distinct-representation, wrong-prefix, and+  normalization probes. Scaffold/workspace records and `--explain-bindings`+  persist the ID-domain version independently of nominal equality.+- Historical generated-event decoding retains an explicitly named internal+  legacy constructor, while the same malformed text is rejected at current+  command/public decoding with its JSON field path. Domain adoption emits+  `IdDomainContractChanged`: old history remains readable, old snapshots miss,+  public consumers break, consumer builds are advisory, and rollout is+  producer-last. The compiled `keiro-dsl-conformance-id-domain-migration`+  target and restoring mutation script pin this split.++- Adds the public `CheckedService`/`EffectiveLanguageContract` semantic boundary.+  Single-source and workspace CLI routes now retain the selected contract through+  validation, scaffold and harness planning, generated fold fingerprints, diff,+  replay-impact analysis, inspection JSON, and additive scaffold-record rows.+  `Spec`-only APIs remain explicit legacy/version-1 compatibility wrappers.+  Grammar-only v1/v2 differences preserve generated and fold bytes; a future+  runtime-semantic generation receives its own fingerprint discriminator.++- Plans one deterministic Haskell owner for every generated service-level ID and+  enum across single-file and multi-file services. Aggregate rings import only+  their resolved uses, unused declarations are not imported into unrelated+  domains, and member reordering or ownership moves leave generated nominal type+  identity unchanged. A compiled two-aggregate workspace conformance suite passes+  shared ID and enum values across both rings and round-trips both codecs.++- Generates version-2 events declared as `fields(Command)` directly from one+  checked total identity mapping. The runtime no longer imports a create-once+  identity-copy function for direct, aliased-wire, optional, nominal, `Time`,+  `Natural`, or structural command fields. Explicit event fields remain+  hand-owned, and stale generated-identity hooks are reported as obsolete.+- Adds `behavior-obligations FILE --format=text|json` for single specs and+  workspaces. Schema `keiro-dsl/behavior-obligations/1` inventories stable+  semantic keys for every live transition from a live-reachable state, every+  reachable rejection cell, and every replay-only transition, with owner and+  conservative evidence metadata but no consumer fill claims.+- Generates an aggregate-specific `BehaviorContract` plus create-once+  `BehaviorHoles`. Typed live and replay witnesses execute through the generated+  codec and Keiki 0.7 detailed attribution. Schema+  `keiro/behavior-conformance/1` reports required, filled, pending, missing,+  duplicate, stale, failed, verified, and unverified keys. The default gate+  fails incomplete or false evidence; `--fail-on-unverified` opts into a+  stricter proof policy.++### Bug Fixes++- Parses the optional `language keiro-dsl N` preamble only after leading trivia+  and before `context`. Nested `language` fields and declarations no longer look+  like misplaced or duplicate preambles, and version-2 feature gates now arise+  from their grammar productions instead of raw source substrings. Comments,+  strings, wire keys, and legal identifiers containing `using`, `Integer`,+  `implementation hole`, `reg.`, or `cmd.` remain inert.+ ## 0.6.0.0 — 2026-07-31  ### Breaking Changes

@@ -12,21 +12,23 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Text.Lazy.IO qualified as TLIO+import Keiro.Dsl.BehaviorCoverage qualified as Behavior import Keiro.Dsl.Coverage qualified as Coverage import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSources, gateWith, gatedBreaking) import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding)-import Keiro.Dsl.ExplainBindings (bindingObligations, renderBindingObligations)+import Keiro.Dsl.ExplainBindings (bindingObligationsForService, renderBindingObligations) import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads) import Keiro.Dsl.Grammar (Placement (..), Spec (..)) import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, effectiveLanguageVersion, sourceFormText) import Keiro.Dsl.Parser (parseSource, renderParseFailure) import Keiro.Dsl.PrettyPrint (renderSource, renderSpec)-import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpact)+import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpactServices) import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule)-import Keiro.Dsl.ScaffoldRun (executeScaffoldWithLanguage, planScaffoldWithGoldens, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.ScaffoldRun (executeServiceScaffold, planServiceScaffoldWithGoldens, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource) import Keiro.Dsl.Skeleton (skeletonFor)-import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec)-import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure, WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest)+import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateService)+import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure, WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, checkedWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, nodeOwner, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest) import Keiro.Dsl.WorkspaceDiff (WorkspaceChange (..), WorkspaceMeta (..), diffWorkspaces, renderWorkspaceFinding, workspaceDiffReport) import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffold, planWorkspaceScaffoldWithGoldens, renderWorkspaceScaffoldReport) import Options.Applicative@@ -41,12 +43,15 @@   | Pretty FilePath   | Check FilePath Bool Bool (Maybe CheckCoverageOptions)   | Inspect FilePath InspectionFormat+  | BehaviorObligations FilePath BehaviorFormat   | Scaffold FilePath FilePath (Maybe String) Bool Bool (Maybe FilePath) (Maybe (String, FilePath))   | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions)   | New String  data InspectionFormat = InspectionJson +data BehaviorFormat = BehaviorText | BehaviorJson+ data CheckCoverageOptions = CheckCoverageOptions   { checkCoveragePath :: !FilePath,     checkFailOnOpaque :: !Bool@@ -81,6 +86,9 @@           "inspect"           (info (Inspect <$> fileArg <*> inspectionFormatOpt <**> helper) (progDesc "Inspect source-language provenance for a .keiro file or workspace as JSON"))         <> command+          "behavior-obligations"+          (info (BehaviorObligations <$> fileArg <*> behaviorFormatOpt <**> helper) (progDesc "List static aggregate behavior obligations for a .keiro file or workspace"))+        <> command           "scaffold"           (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))         <> command@@ -172,6 +180,16 @@     parseFormat "json" = Right InspectionJson     parseFormat other = Left ("unsupported inspection format: " <> other <> " (expected json)") +behaviorFormatOpt :: Parser BehaviorFormat+behaviorFormatOpt =+  option+    (eitherReader parseFormat)+    (long "format" <> metavar "text|json" <> value BehaviorText <> help "Behavior obligation output format (text or json)")+  where+    parseFormat "text" = Right BehaviorText+    parseFormat "json" = Right BehaviorJson+    parseFormat other = Left ("unsupported behavior obligation format: " <> other <> " (expected text or json)")+ run :: Command -> IO () run (Pretty fp) = run (Parse fp) -- Workspace dispatch. A @FILE@ ending in @.keiro-workspace@ is a workspace@@ -181,6 +199,8 @@   | isWorkspacePath fp = runWorkspaceCheck fp emit explainBindings coverageOptions run (Inspect fp format)   | isWorkspacePath fp = runWorkspaceInspect fp format+run (BehaviorObligations fp format)+  | isWorkspacePath fp = runWorkspaceBehaviorObligations fp format run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest)   | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions)@@ -199,15 +219,16 @@       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure     Right parsedSource -> do-      let spec = parsedSpec parsedSource-      let diags = validateSpec spec+      let service = checkedSource parsedSource+          spec = checkedSpec service+          diags = validateService service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags       if any ((== Error) . severity) diags         then exitFailure         else do           when emit (TIO.putStrLn (renderSource parsedSource))           if explainBindings-            then case bindingObligations spec of+            then case bindingObligationsForService service of               Left graphErrors -> do                 hPutStrLn stderr ("validated spec did not resolve its mapped type graph: " <> show graphErrors)                 exitFailure@@ -223,16 +244,17 @@       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure     Right parsedSource -> do-      let spec = parsedSpec parsedSource+      let service = checkedSource parsedSource+          spec = checkedSpec service       -- Validation gate: never scaffold an invalid spec. Abort on any       -- error-severity diagnostic before writing a single module.-      let diags = validateSpec spec+      let diags = validateService service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags       when (any ((== Error) . severity) diags) exitFailure       let ctx = mkContext cliRoot cliCollocate spec           goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens       goldens <- loadGoldenPayloads goldenRoot spec-      case (planScaffoldWithGoldens goldens ctx spec, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of+      case (planServiceScaffoldWithGoldens goldens ctx service, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of         (Left refusals, _) -> do           mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)           exitFailure@@ -242,7 +264,7 @@           case comparisonReady of             Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure             Right () -> do-              result <- executeScaffoldWithLanguage out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx spec modules+              result <- executeServiceScaffold out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx service modules               case result of                 Left refusals -> do                   mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)@@ -258,7 +280,23 @@   input <- TIO.readFile fp   case parseSource fp input of     Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure-    Right parsedSource -> TLIO.putStrLn (AesonText.encodeToLazyText (sourceInspection fp (parsedSourceLanguage parsedSource)))+    Right parsedSource ->+      TLIO.putStrLn+        (AesonText.encodeToLazyText (sourceInspection fp (parsedSourceLanguage parsedSource) (checkedSource parsedSource)))+run (BehaviorObligations fp format) = do+  input <- TIO.readFile fp+  case parseSource fp input of+    Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure+    Right parsedSource -> do+      let service = checkedSource parsedSource+          spec = checkedSpec service+          diagnostics = validateService service+      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diagnostics+      if any ((== Error) . severity) diagnostics+        then exitFailure+        else case Behavior.behaviorObligationsReport fp spec of+          Left errors -> renderBehaviorErrors errors+          Right report -> writeBehaviorReport format report run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions) = do   -- Resolve the spec to a repo-relative path so `git show <ref>:<relpath>` works.   let dir = takeDirectory fp@@ -277,12 +315,14 @@           case (,) <$> parseSource (ref <> ":" <> relPath) (T.pack oldText) <*> parseSource fp newText of             Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure             Right (oldSource, newSource) -> do-              let oldSpec = parsedSpec oldSource-                  newSpec = parsedSpec newSource+              let oldService = checkedSource oldSource+                  newService = checkedSource newSource+                  oldSpec = checkedSpec oldService+                  newSpec = checkedSpec newService               written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot               mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written               let changes = diffSources oldSource newSource-                  impact = replayImpact oldSpec newSpec+                  impact = replayImpactServices oldService newService                   effectiveGate = gateWith gatedSurfaces               mapM_ (TIO.putStrLn . renderFinding) changes               when explain $@@ -304,15 +344,16 @@       exitFailure     Right manifest -> TIO.putStrLn (renderWorkspaceManifest manifest) -sourceInspection :: FilePath -> SourceLanguage -> Aeson.Value-sourceInspection path sourceLanguage =+sourceInspection :: FilePath -> SourceLanguage -> CheckedService -> Aeson.Value+sourceInspection path sourceLanguage service =   Aeson.object     [ "schema" .= ("keiro-dsl/source-inspection/1" :: T.Text),       "kind" .= ("source" :: T.Text),       "path" .= path,       "sourceForm" .= sourceFormText sourceLanguage,       "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,-      "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage+      "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage,+      "effectiveSemanticContract" .= checkedLanguageContract service     ]  runWorkspaceInspect :: FilePath -> InspectionFormat -> IO ()@@ -330,6 +371,7 @@                   "kind" .= ("workspace" :: T.Text),                   "path" .= fp,                   "service" .= wsService workspace,+                  "effectiveSemanticContract" .= checkedLanguageContract (checkedWorkspace workspace),                   "members" .= map memberInspection (wsMembers workspace)                 ]             )@@ -345,6 +387,43 @@       where         sourceLanguage = wmSourceLanguage member +runWorkspaceBehaviorObligations :: FilePath -> BehaviorFormat -> IO ()+runWorkspaceBehaviorObligations fp format = do+  loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp+  case loaded of+    Left failure -> mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure) >> exitFailure+    Right workspace -> do+      let diagnostics = checkWorkspace workspace+      mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diagnostics+      if any ((== Error) . wdSeverity) diagnostics+        then exitFailure+        else case workspaceBehaviorReport workspace of+          Left errors -> renderBehaviorErrors errors+          Right report -> writeBehaviorReport format report++workspaceBehaviorReport :: WorkspaceSpec -> Either [Behavior.BehaviorDerivationError] Behavior.BehaviorObligationsReport+workspaceBehaviorReport workspace = do+  requirements <- Behavior.deriveBehaviorRequirements (checkedSpec (checkedWorkspace workspace))+  pure+    Behavior.BehaviorObligationsReport+      { Behavior.behaviorSubject = wsManifestPath workspace,+        Behavior.behaviorWorkspaceService = Just (wsService workspace),+        Behavior.behaviorRequirements =+          map+            (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate"))+            requirements+      }++writeBehaviorReport :: BehaviorFormat -> Behavior.BehaviorObligationsReport -> IO ()+writeBehaviorReport format report = case format of+  BehaviorText -> TIO.putStr (Behavior.renderBehaviorObligationsText report)+  BehaviorJson -> TIO.putStrLn (Behavior.encodeBehaviorObligationsJson report)++renderBehaviorErrors :: [Behavior.BehaviorDerivationError] -> IO ()+renderBehaviorErrors errors = do+  mapM_ (hPutStrLn stderr . ("behavior obligation derivation failed: " <>) . show) errors+  exitFailure+ -- | @check@ on a workspace manifest: compose the whole service from its member -- @.keiro@ files and validate it as one contract. Diagnostics are rendered -- against the member file and line that produced them, and a single diagnostic@@ -362,15 +441,16 @@       mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)       exitFailure     Right workspace -> do-      let diags = checkWorkspace workspace-          spec = wsMergedSpec workspace+      let service = checkedWorkspace workspace+          diags = checkWorkspace workspace+          spec = checkedSpec service       mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags       if any ((== Error) . wdSeverity) diags         then exitFailure         else do           when emit (TIO.putStrLn (renderSpec spec))           if explainBindings-            then case bindingObligations spec of+            then case bindingObligationsForService service of               Left graphErrors -> do                 hPutStrLn stderr ("validated workspace did not resolve its mapped type graph: " <> show graphErrors)                 exitFailure@@ -413,7 +493,7 @@       let diags = checkWorkspace workspace       mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags       when (any ((== Error) . wdSeverity) diags) exitFailure-      let spec = wsMergedSpec workspace+      let spec = checkedSpec (checkedWorkspace workspace)           ctx = workspaceContext cliRoot cliCollocate workspace           goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens       goldens <- loadGoldenPayloads goldenRoot spec@@ -504,14 +584,16 @@                               <> "; composing the old service from the current members' blobs at "                               <> ref                           )-                      let oldSpec = wsMergedSpec oldWorkspace-                          newSpec = wsMergedSpec newWorkspace+                      let oldService = checkedWorkspace oldWorkspace+                          newService = checkedWorkspace newWorkspace+                          oldSpec = checkedSpec oldService+                          newSpec = checkedSpec newService                           goldenRoot = fmap (workspaceGoldenRoot fp) emitGoldensRoot                       written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) goldenRoot                       mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written                       let workspaceChanges = diffWorkspaces oldWorkspace newWorkspace                           changes = map wcChange workspaceChanges-                          impact = replayImpact oldSpec newSpec+                          impact = replayImpactServices oldService newService                           effectiveGate = gateWith gatedSurfaces                           reportMeta =                             WorkspaceMeta

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-dsl-version:         0.6.0.0+version:         0.7.0.0 synopsis:        Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro@@ -33,16 +33,19 @@   hs-source-dirs:  src   exposed-modules:     Keiro.Dsl.AggregateType+    Keiro.Dsl.BehaviorCoverage     Keiro.Dsl.CodecCompare     Keiro.Dsl.Coverage     Keiro.Dsl.Diff     Keiro.Dsl.DiffReport+    Keiro.Dsl.EventOutput     Keiro.Dsl.ExplainBindings     Keiro.Dsl.Expression     Keiro.Dsl.FoldFingerprint     Keiro.Dsl.Goldens     Keiro.Dsl.Grammar     Keiro.Dsl.Harness+    Keiro.Dsl.IdDomain     Keiro.Dsl.LanguageVersion     Keiro.Dsl.Manifest     Keiro.Dsl.MappedConsumer@@ -55,6 +58,7 @@     Keiro.Dsl.Scaffold     Keiro.Dsl.ScaffoldRecord     Keiro.Dsl.ScaffoldRun+    Keiro.Dsl.SemanticContract     Keiro.Dsl.Skeleton     Keiro.Dsl.TypeGraph     Keiro.Dsl.Validate@@ -65,18 +69,20 @@     Keiro.Dsl.WorkspaceScaffold    build-depends:-    , aeson               >=2.2.1 && <2.3-    , base                >=4.21  && <5-    , bytestring          >=0.12  && <0.13-    , containers          >=0.6   && <0.8-    , directory           >=1.3   && <1.4-    , filepath            >=1.4   && <1.6-    , megaparsec          >=9.6   && <9.9-    , mmzk-typeid         >=0.7   && <0.8-    , parser-combinators  >=1.3   && <1.4-    , prettyprinter       >=1.7   && <1.8-    , text                >=2.1   && <2.2-    , time                >=1.12  && <1.15+    , aeson               >=2.2.1    && <2.3+    , base                >=4.21     && <5+    , bytestring          >=0.12     && <0.13+    , containers          >=0.6      && <0.8+    , directory           >=1.3      && <1.4+    , filepath            >=1.4      && <1.6+    , keiki               >=0.7      && <0.8+    , keiro-core          ^>=0.7.0.0+    , megaparsec          >=9.6      && <9.9+    , mmzk-typeid         >=0.7      && <0.8+    , parser-combinators  >=1.3      && <1.4+    , prettyprinter       >=1.7      && <1.8+    , text                >=2.1      && <2.2+    , time                >=1.12     && <1.15  executable keiro-dsl   import:         warnings, shared@@ -104,6 +110,7 @@     , directory   >=1.3  && <1.4     , filepath    >=1.4  && <1.6     , hspec       >=2.11+    , keiki       >=0.7  && <0.8     , keiro-core     , keiro-dsl     , process     >=1.6  && <1.7@@ -121,6 +128,7 @@   hs-source-dirs: test/conformance   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.Nominals     Generated.HospitalCapacity.ReplayAudit     Generated.HospitalCapacity.Reservation.Codec     Generated.HospitalCapacity.Reservation.Domain@@ -132,7 +140,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.6  && <0.7+    , keiki  >=0.7  && <0.8     , keiro     , text   >=2.1  && <2.2 @@ -156,7 +164,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.6  && <0.7+    , keiki  >=0.7  && <0.8     , keiro     , text   >=2.1  && <2.2     , time   >=1.12 && <1.15@@ -170,8 +178,11 @@   hs-source-dirs: test/conformance-scalar-expressions   main-is:        Main.hs   other-modules:+    AggregateScalarExpressions.ScalarAccount.BehaviorHoles     AggregateScalarExpressions.ScalarAccount.Holes+    Generated.AggregateScalarExpressions.Nominals     Generated.AggregateScalarExpressions.ReplayAudit+    Generated.AggregateScalarExpressions.ScalarAccount.BehaviorContract     Generated.AggregateScalarExpressions.ScalarAccount.Codec     Generated.AggregateScalarExpressions.ScalarAccount.Domain     Generated.AggregateScalarExpressions.ScalarAccount.EventStream@@ -188,12 +199,44 @@     , aeson       >=2.2  && <2.3     , base        >=4.21 && <5     , containers  >=0.6  && <0.8-    , keiki       >=0.6  && <0.7+    , keiki       >=0.7  && <0.8     , keiro     , keiro-dsl     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15 +test-suite keiro-dsl-conformance-behavior-complete+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-behavior-complete+  main-is:        Main.hs+  other-modules:+    BehaviorComplete.Bindings+    BehaviorComplete.Domain+    BehaviorComplete.Journey.BehaviorHoles+    BehaviorComplete.Journey.Holes+    Generated.BehaviorComplete.Journey.BehaviorContract+    Generated.BehaviorComplete.Journey.Codec+    Generated.BehaviorComplete.Journey.Domain+    Generated.BehaviorComplete.Journey.EventStream+    Generated.BehaviorComplete.Journey.Expressions+    Generated.BehaviorComplete.Journey.Harness+    Generated.BehaviorComplete.Journey.Projection+    Generated.BehaviorComplete.Journey.Transducer+    Generated.BehaviorComplete.ReplayAudit+    Generated.BehaviorComplete.Structural.Shape.StartPayload+    Generated.BehaviorComplete.StructuralProjections++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , bytestring  >=0.12 && <0.13+    , containers  >=0.6  && <0.8+    , keiki       >=0.7  && <0.8+    , keiro+    , text        >=2.1  && <2.2+    , time        >=1.12 && <1.15+ -- EP-158: consumer-owned direct IDs, enums, and nominal scalar wrappers, -- checked KindID decoding, total bindings, projections, and snapshot caches. test-suite keiro-dsl-conformance-nominal-scalars@@ -203,21 +246,69 @@   main-is:        Main.hs   other-modules:     Generated.NominalScalars.Nominal.Shape.OrderStatus+    Generated.NominalScalars.NominalLedger.BehaviorContract     Generated.NominalScalars.NominalLedger.Codec     Generated.NominalScalars.NominalLedger.Domain+    Generated.NominalScalars.NominalLedger.EventStream+    Generated.NominalScalars.NominalLedger.Expressions+    Generated.NominalScalars.NominalLedger.Harness+    Generated.NominalScalars.NominalLedger.Projection+    Generated.NominalScalars.NominalLedger.Transducer     Generated.NominalScalars.NominalProjections+    Generated.NominalScalars.ReplayAudit     NominalConformance.Bindings     NominalConformance.Domain+    NominalScalars.NominalLedger.BehaviorHoles    build-depends:     , aeson        >=2.2  && <2.3     , base         >=4.21 && <5-    , keiki        >=0.6  && <0.7+    , containers   >=0.6  && <0.8+    , keiki        >=0.7  && <0.8     , keiro     , mmzk-typeid  >=0.7  && <0.8     , text         >=2.1  && <2.2     , time         >=1.12 && <1.15 +-- EP-168 / IR-2: one workspace-level generated ID/enum authority is imported+-- by two aggregate rings. The driver passes values between both domain modules+-- and round-trips both generated event codecs, so duplicate nominal types fail+-- at compile time rather than escaping a path-only scaffold assertion.+test-suite keiro-dsl-conformance-workspace-nominals+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-workspace-nominals+  main-is:        Main.hs+  other-modules:+    Generated.WorkspaceNominalProof.Nominals+    Generated.WorkspaceNominalProof.Project.BehaviorContract+    Generated.WorkspaceNominalProof.Project.Codec+    Generated.WorkspaceNominalProof.Project.Domain+    Generated.WorkspaceNominalProof.Project.EventStream+    Generated.WorkspaceNominalProof.Project.Expressions+    Generated.WorkspaceNominalProof.Project.Harness+    Generated.WorkspaceNominalProof.Project.Projection+    Generated.WorkspaceNominalProof.Project.Transducer+    Generated.WorkspaceNominalProof.ProjectArtifact.BehaviorContract+    Generated.WorkspaceNominalProof.ProjectArtifact.Codec+    Generated.WorkspaceNominalProof.ProjectArtifact.Domain+    Generated.WorkspaceNominalProof.ProjectArtifact.EventStream+    Generated.WorkspaceNominalProof.ProjectArtifact.Expressions+    Generated.WorkspaceNominalProof.ProjectArtifact.Harness+    Generated.WorkspaceNominalProof.ProjectArtifact.Projection+    Generated.WorkspaceNominalProof.ProjectArtifact.Transducer+    Generated.WorkspaceNominalProof.ReplayAudit+    WorkspaceNominalProof.Project.BehaviorHoles+    WorkspaceNominalProof.ProjectArtifact.BehaviorHoles++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , containers  >=0.6  && <0.8+    , keiki       >=0.7  && <0.8+    , keiro+    , text        >=2.1  && <2.2+ -- Plan 150 / IR-1: compiled structural consumer bindings, declared-wire -- codecs, generated projection witnesses, opaque boundaries, fixture branch -- coverage, current payload goldens, and mapped-register replay equality.@@ -248,7 +339,7 @@     , bytestring  >=0.12 && <0.13     , containers  >=0.6  && <0.8     , deepseq     >=1.5  && <1.6-    , keiki       >=0.6  && <0.7+    , keiki       >=0.7  && <0.8     , keiro     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15@@ -282,7 +373,7 @@     , deepseq     >=1.5   && <1.6     , directory   >=1.3   && <1.4     , filepath    >=1.4   && <1.6-    , keiki       >=0.6   && <0.7+    , keiki       >=0.7   && <0.8     , keiro     , keiro-dsl     , text        >=2.1   && <2.2@@ -308,7 +399,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.6  && <0.7+    , keiki  >=0.7  && <0.8     , keiro     , text   >=2.1  && <2.2 @@ -332,7 +423,7 @@     , base         >=4.21 && <5     , containers   >=0.6  && <0.8     , deepseq      >=1.5  && <1.6-    , keiki        >=0.6  && <0.7+    , keiki        >=0.7  && <0.8     , keiro     , tasty-bench  >=0.5  && <0.6     , text         >=2.1  && <2.2@@ -356,7 +447,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.6  && <0.7+    , keiki  >=0.7  && <0.8     , keiro     , text   >=2.1  && <2.2 @@ -369,6 +460,7 @@   hs-source-dirs: test/conformance-skeletons   main-is:        Main.hs   other-modules:+    SkelAggregate.Generated.MyService.Nominals     SkelAggregate.Generated.MyService.ReplayAudit     SkelAggregate.Generated.MyService.Thing.Codec     SkelAggregate.Generated.MyService.Thing.Domain@@ -388,6 +480,7 @@     SkelProcess.Generated.MyService.Hospital.Projection     SkelProcess.Generated.MyService.HospitalSurge.Process     SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness+    SkelProcess.Generated.MyService.Nominals     SkelProcess.Generated.MyService.ReplayAudit     SkelProcess.Generated.MyService.Surge.Codec     SkelProcess.Generated.MyService.Surge.Domain@@ -427,7 +520,7 @@     , containers     , effectful-core     , hasql-transaction-    , keiki              >=0.6  && <0.7+    , keiki              >=0.7  && <0.8     , keiro     , keiro-core     , keiro-pgmq@@ -457,7 +550,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.6  && <0.7+    , keiki  >=0.7  && <0.8     , keiro     , text   >=2.1  && <2.2 @@ -656,7 +749,7 @@   build-depends:     , aeson         >=2.2  && <2.3     , base          >=4.21 && <5-    , keiki         >=0.6  && <0.7+    , keiki         >=0.7  && <0.8     , keiro     , shibuya-core     , text          >=2.1  && <2.2@@ -751,7 +844,7 @@     , aeson           >=2.2  && <2.3     , base            >=4.21 && <5     , effectful-core-    , keiki           >=0.6  && <0.7+    , keiki           >=0.7  && <0.8     , keiro     , shibuya-core     , text            >=2.1  && <2.2@@ -787,7 +880,7 @@     , base               >=4.21 && <5     , effectful-core     , hasql-transaction-    , keiki              >=0.6  && <0.7+    , keiki              >=0.7  && <0.8     , keiro     , kiroku-store     , shibuya-core@@ -831,6 +924,27 @@     , aeson      >=2.2  && <2.3     , base       >=4.21 && <5     , directory  >=1.3  && <1.4-    , keiki      >=0.6  && <0.7+    , keiki      >=0.7  && <0.8     , keiro     , text       >=2.1  && <2.2++-- IR-14 / EP-171 migration conformance. The generated v3 public ID surface+-- rejects malformed current input while its explicitly internal event-replay+-- seam preserves identical malformed text from a legacy payload.+test-suite keiro-dsl-conformance-id-domain-migration+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-id-domain-migration+  main-is:        Main.hs+  other-modules:+    Generated.IdDomainMigration.Nominals+    Generated.IdDomainMigration.Nominals.Internal+    Generated.IdDomainMigration.OrderBook.Codec+    Generated.IdDomainMigration.OrderBook.Domain++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , keiki       >=0.7  && <0.8+    , keiro-core+    , text        >=2.1  && <2.2

@@ -152,6 +152,11 @@ aggregateCapability useSite resolved = case useSite of   EqualityGuardUse -> case resolved of     AggregateMapped {} -> Unsupported+    AggregateNominal nominal -> case resolvedNominalRepresentation nominal of+      ScalarRepresentation {} -> SolverVisible+      _ -> case nominalEqualityContract nominal of+        Just _ -> SolverVisible+        Nothing -> OpaqueOnly     _ -> solverVisibility resolved   OrderingGuardUse -> case resolved of     AggregateInt -> SolverVisible

@@ -0,0 +1,509 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Static behavioral obligations derivable from a validated aggregate graph.+--+-- This module deliberately knows nothing about consumer Haskell witnesses.  It+-- inventories the finite obligations the source graph requires; the generated+-- consumer contract reconciles and executes witness values in a later layer.+module Keiro.Dsl.BehaviorCoverage+  ( BehaviorKey (..),+    ObligationKind (..),+    EvidenceLevel (..),+    GuardCoverage (..),+    OutputEvidence (..),+    BehaviorRequirement (..),+    BehaviorRecordRow (..),+    BehaviorDerivationError (..),+    BehaviorObligationsReport (..),+    deriveAggregateBehaviorRequirements,+    deriveBehaviorRequirements,+    behaviorRecordRows,+    attributeBehaviorOwner,+    behaviorObligationsReport,+    renderBehaviorObligationsText,+    encodeBehaviorObligationsJson,+  )+where++import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as BL+import Data.List (find, groupBy, sortOn)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as Text+import Keiro.Dsl.EventOutput+import Keiro.Dsl.Grammar+import Keiro.Dsl.PrettyPrint (renderExpr)+import Keiro.Dsl.ReadModelShape (fnv1a64)++newtype BehaviorKey = BehaviorKey {unBehaviorKey :: Text}+  deriving stock (Eq, Ord, Show)++data ObligationKind+  = LiveTransition+  | RequiredRejection+  | ReplayTransition+  deriving stock (Eq, Ord, Show)++data EvidenceLevel+  = GeneratedAuthoritative+  | HoleWitnessed+  | LegacyRuntimeWitness+  deriving stock (Eq, Ord, Show)++data GuardCoverage+  = GuardTotal+  | GuardPartial+  | GuardUnknown+  | GuardNotApplicable+  deriving stock (Eq, Ord, Show)++data OutputEvidence+  = GeneratedOutput !Name+  | HandOwnedOutput !OutputObligationKey+  deriving stock (Eq, Ord, Show)++data BehaviorRequirement = BehaviorRequirement+  { requirementKey :: !BehaviorKey,+    requirementKind :: !ObligationKind,+    requirementEvidence :: !EvidenceLevel,+    requirementGuardCoverage :: !GuardCoverage,+    requirementContext :: !Name,+    requirementAggregate :: !Name,+    requirementSource :: !Name,+    requirementCommand :: !Name,+    requirementTarget :: !(Maybe Name),+    requirementMode :: !(Maybe TransitionMode),+    requirementEvents :: ![Name],+    requirementOutputs :: ![OutputEvidence],+    requirementLocation :: !Loc,+    requirementOwner :: !(Maybe FilePath),+    requirementCanonical :: !Text+  }+  deriving stock (Eq, Show)++-- | Forward-compatible record representation of one requirement.  Records+-- retain enough human-readable identity to report additions and removals+-- without re-reading or attempting to understand consumer Haskell.+data BehaviorRecordRow = BehaviorRecordRow+  { behaviorRecordKey :: !BehaviorKey,+    behaviorRecordKind :: !ObligationKind,+    behaviorRecordEvidence :: !EvidenceLevel,+    behaviorRecordAggregate :: !Name,+    behaviorRecordSource :: !Name,+    behaviorRecordCommand :: !Name,+    behaviorRecordOwner :: !(Maybe FilePath),+    behaviorRecordOutputs :: ![OutputEvidence]+  }+  deriving stock (Eq, Ord, Show)++data BehaviorDerivationError+  = InvalidEventOutput !Name !EventOutputError+  | EventlessStateChange !Name !Name !Name+  | DuplicateBehaviorIdentity !Text ![Loc]+  | BehaviorKeyCollision !BehaviorKey ![Text]+  deriving stock (Eq, Show)++data BehaviorObligationsReport = BehaviorObligationsReport+  { behaviorSubject :: !FilePath,+    behaviorWorkspaceService :: !(Maybe Text),+    behaviorRequirements :: ![BehaviorRequirement]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorKey where+  toJSON = toJSON . unBehaviorKey++instance ToJSON ObligationKind where+  toJSON = toJSON . obligationKindText++instance ToJSON EvidenceLevel where+  toJSON = toJSON . evidenceLevelText++instance ToJSON GuardCoverage where+  toJSON = toJSON . guardCoverageText++instance ToJSON OutputEvidence where+  toJSON evidence = case evidence of+    GeneratedOutput command -> object ["ownership" .= ("generated-command-identity" :: Text), "command" .= command]+    HandOwnedOutput key -> object ["ownership" .= ("hand-owned" :: Text), "obligation" .= unOutputObligationKey key]++instance FromJSON BehaviorKey where+  parseJSON value = BehaviorKey <$> parseJSON value++instance FromJSON ObligationKind where+  parseJSON value = parseJSON value >>= parseLabel+    where+      parseLabel ("live-transition" :: Text) = pure LiveTransition+      parseLabel "required-rejection" = pure RequiredRejection+      parseLabel "replay-transition" = pure ReplayTransition+      parseLabel other = fail ("unknown behavior obligation kind: " <> T.unpack other)++instance FromJSON EvidenceLevel where+  parseJSON value = parseJSON value >>= parseLabel+    where+      parseLabel ("generated-authoritative" :: Text) = pure GeneratedAuthoritative+      parseLabel "hole-witnessed" = pure HoleWitnessed+      parseLabel "legacy-runtime-witness" = pure LegacyRuntimeWitness+      parseLabel other = fail ("unknown behavior evidence level: " <> T.unpack other)++instance FromJSON OutputEvidence where+  parseJSON = withObject "OutputEvidence" $ \fields -> do+    ownership <- fields .: "ownership"+    case (ownership :: Text) of+      "generated-command-identity" -> GeneratedOutput <$> fields .: "command"+      "hand-owned" -> HandOwnedOutput . OutputObligationKey <$> fields .: "obligation"+      other -> fail ("unknown event-output ownership: " <> T.unpack other)++instance ToJSON BehaviorRecordRow where+  toJSON row =+    object+      ( [ "key" .= behaviorRecordKey row,+          "kind" .= behaviorRecordKind row,+          "evidence" .= behaviorRecordEvidence row,+          "aggregate" .= behaviorRecordAggregate row,+          "source" .= behaviorRecordSource row,+          "command" .= behaviorRecordCommand row,+          "outputs" .= behaviorRecordOutputs row+        ]+          <> ["owner" .= owner | Just owner <- [behaviorRecordOwner row]]+      )++instance FromJSON BehaviorRecordRow where+  parseJSON = withObject "BehaviorRecordRow" $ \fields ->+    BehaviorRecordRow+      <$> fields .: "key"+      <*> fields .: "kind"+      <*> fields .: "evidence"+      <*> fields .: "aggregate"+      <*> fields .: "source"+      <*> fields .: "command"+      <*> fields .:? "owner"+      <*> fields .: "outputs"++instance ToJSON BehaviorRequirement where+  toJSON requirement =+    object+      [ "key" .= requirementKey requirement,+        "kind" .= requirementKind requirement,+        "evidence" .= requirementEvidence requirement,+        "guardCoverage" .= requirementGuardCoverage requirement,+        "context" .= requirementContext requirement,+        "aggregate" .= requirementAggregate requirement,+        "source" .= requirementSource requirement,+        "command" .= requirementCommand requirement,+        "target" .= requirementTarget requirement,+        "mode" .= fmap transitionModeText (requirementMode requirement),+        "events" .= requirementEvents requirement,+        "outputs" .= requirementOutputs requirement,+        "location" .= object (["line" .= unLoc (requirementLocation requirement)] <> ["member" .= owner | Just owner <- [requirementOwner requirement]])+      ]++instance ToJSON BehaviorObligationsReport where+  toJSON report =+    object+      ( [ "schema" .= ("keiro-dsl/behavior-obligations/1" :: Text),+          "subject" .= behaviorSubject report,+          "requirements" .= behaviorRequirements report+        ]+          <> ["workspace" .= object ["service" .= service] | Just service <- [behaviorWorkspaceService report]]+      )++deriveBehaviorRequirements :: Spec -> Either [BehaviorDerivationError] [BehaviorRequirement]+deriveBehaviorRequirements spec = case fmap concat (traverse (deriveAggregateBehaviorRequirements spec) aggregates) of+  Left derivationError -> Left [derivationError]+  Right raw -> do+    rejectIdentityDefects raw+    pure (sortOn requirementKey raw)+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]++deriveAggregateBehaviorRequirements :: Spec -> Aggregate -> Either BehaviorDerivationError [BehaviorRequirement]+deriveAggregateBehaviorRequirements spec aggregate = do+  let reachable = liveReachableStates aggregate+      liveTransitions =+        [ transition+        | transition <- aggTransitions aggregate,+          tMode transition == TmLive,+          tSource transition `Set.member` reachable+        ]+      replayTransitions = [transition | transition <- aggTransitions aggregate, tMode transition == TmReplayOnly]+      commands = map cmdName (aggCommands aggregate)+      cells = [(state, command) | state <- Set.toAscList reachable, command <- commands]+      cellTransitions state command =+        [ transition+        | transition <- liveTransitions,+          tSource transition == state,+          tCommand transition == command+        ]+      transitionRows =+        [ transitionRequirement spec aggregate (cellGuardCoverage siblings) transition+        | (state, command) <- cells,+          let siblings = cellTransitions state command,+          transition <- siblings+        ]+      rejectionRows =+        [ pure (rejectionRequirement spec aggregate state command)+        | (state, command) <- cells,+          null (cellTransitions state command)+        ]+      replayRows = [transitionRequirement spec aggregate (replayGuardCoverage transition) transition | transition <- replayTransitions]+  sequence (transitionRows <> rejectionRows <> replayRows)++behaviorRecordRows :: [BehaviorRequirement] -> [BehaviorRecordRow]+behaviorRecordRows = map toRow+  where+    toRow requirement =+      BehaviorRecordRow+        { behaviorRecordKey = requirementKey requirement,+          behaviorRecordKind = requirementKind requirement,+          behaviorRecordEvidence = requirementEvidence requirement,+          behaviorRecordAggregate = requirementAggregate requirement,+          behaviorRecordSource = requirementSource requirement,+          behaviorRecordCommand = requirementCommand requirement,+          behaviorRecordOwner = requirementOwner requirement,+          behaviorRecordOutputs = requirementOutputs requirement+        }++attributeBehaviorOwner :: (Name -> Maybe FilePath) -> BehaviorRequirement -> BehaviorRequirement+attributeBehaviorOwner ownerForAggregate requirement =+  requirement {requirementOwner = ownerForAggregate (requirementAggregate requirement)}++behaviorObligationsReport :: FilePath -> Spec -> Either [BehaviorDerivationError] BehaviorObligationsReport+behaviorObligationsReport subject spec =+  BehaviorObligationsReport subject Nothing <$> deriveBehaviorRequirements spec++transitionRequirement :: Spec -> Aggregate -> GuardCoverage -> Transition -> Either BehaviorDerivationError BehaviorRequirement+transitionRequirement spec aggregate guardCoverage transition = do+  if null (tEmits transition) && (tSource transition /= tGoto transition || not (null (tWrites transition)))+    then Left (EventlessStateChange (aggName aggregate) (tSource transition) (tCommand transition))+    else pure ()+  mappings <-+    traverse+      (\(emitIndex, eventName) -> either (Left . InvalidEventOutput eventName) Right (eventOutputMapping spec aggregate transition emitIndex eventName))+      (zip [1 ..] (tEmits transition))+  let kind = if tMode transition == TmLive then LiveTransition else ReplayTransition+      outputs = map outputEvidence mappings+      canonical = transitionCanonical spec aggregate kind transition mappings+  pure+    BehaviorRequirement+      { requirementKey = canonicalKey canonical,+        requirementKind = kind,+        requirementEvidence = transitionEvidence transition,+        requirementGuardCoverage = guardCoverage,+        requirementContext = specContext spec,+        requirementAggregate = aggName aggregate,+        requirementSource = tSource transition,+        requirementCommand = tCommand transition,+        requirementTarget = Just (tGoto transition),+        requirementMode = Just (tMode transition),+        requirementEvents = tEmits transition,+        requirementOutputs = outputs,+        requirementLocation = tLoc transition,+        requirementOwner = Nothing,+        requirementCanonical = canonical+      }++rejectionRequirement :: Spec -> Aggregate -> Name -> Name -> BehaviorRequirement+rejectionRequirement spec aggregate state command =+  BehaviorRequirement+    { requirementKey = canonicalKey canonical,+      requirementKind = RequiredRejection,+      requirementEvidence = aggregateEvidence aggregate,+      requirementGuardCoverage = GuardNotApplicable,+      requirementContext = specContext spec,+      requirementAggregate = aggName aggregate,+      requirementSource = state,+      requirementCommand = command,+      requirementTarget = Nothing,+      requirementMode = Nothing,+      requirementEvents = [],+      requirementOutputs = [],+      requirementLocation = maybe (aggLoc aggregate) stLoc (find ((== state) . stName) (aggStates aggregate)),+      requirementOwner = Nothing,+      requirementCanonical = canonical+    }+  where+    canonical =+      T.intercalate+        "|"+        [ "behavior-v1",+          "kind=rejection",+          "context=" <> specContext spec,+          "aggregate=" <> aggName aggregate,+          "source=" <> state,+          "command=" <> command+        ]++transitionCanonical :: Spec -> Aggregate -> ObligationKind -> Transition -> [EventOutputMapping] -> Text+transitionCanonical spec aggregate kind transition mappings =+  T.intercalate+    "|"+    [ "behavior-v1",+      "kind=" <> obligationKindText kind,+      "context=" <> specContext spec,+      "aggregate=" <> aggName aggregate,+      "mode=" <> transitionModeText (tMode transition),+      "source=" <> tSource transition,+      "command=" <> tCommand transition,+      "implementation=" <> implementationText (tImplementation transition),+      "guard=" <> maybe "" renderExpr (tGuard transition),+      "writes=" <> T.intercalate ";" [name <> ":=" <> renderExpr expression | (name, expression) <- tWrites transition],+      "events=" <> T.intercalate "," (tEmits transition),+      "outputs=" <> T.intercalate "," (map eventOutputCanonical mappings),+      "target=" <> tGoto transition+    ]++canonicalKey :: Text -> BehaviorKey+canonicalKey canonical = BehaviorKey ("behavior-v1-" <> fnv1a64 canonical)++outputEvidence :: EventOutputMapping -> OutputEvidence+outputEvidence mapping = case mapping of+  GeneratedCommandIdentity command _ -> GeneratedOutput command+  HandOwnedEventOutput obligation -> HandOwnedOutput obligation++transitionEvidence :: Transition -> EvidenceLevel+transitionEvidence transition = case tImplementation transition of+  LegacyHoleImplementation -> LegacyRuntimeWitness+  GeneratedImplementation -> GeneratedAuthoritative+  HoleImplementation -> HoleWitnessed++aggregateEvidence :: Aggregate -> EvidenceLevel+aggregateEvidence aggregate+  | any ((/= LegacyHoleImplementation) . tImplementation) (aggTransitions aggregate) = GeneratedAuthoritative+  | otherwise = LegacyRuntimeWitness++cellGuardCoverage :: [Transition] -> GuardCoverage+cellGuardCoverage transitions+  | any ((== Nothing) . tGuard) transitions = GuardTotal+  | any crossesOneWayProjection guards = GuardUnknown+  | complementary = GuardTotal+  | all isLiteralFalse guards = GuardPartial+  | otherwise = GuardUnknown+  where+    guards = [guard | transition <- transitions, Just guard <- [tGuard transition]]+    complementary = or [left == complementExpr right | left <- guards, right <- guards, left /= right]+    isLiteralFalse (EAtom (ABool False)) = True+    isLiteralFalse _ = False++crossesOneWayProjection :: Expr -> Bool+crossesOneWayProjection expression = case expression of+  EOr left right -> crossesOneWayProjection left || crossesOneWayProjection right+  EAnd left right -> crossesOneWayProjection left || crossesOneWayProjection right+  ECmp _ left right -> crossesOneWayProjection left || crossesOneWayProjection right+  EAdd _ left right -> crossesOneWayProjection left || crossesOneWayProjection right+  ESubtract _ left right -> crossesOneWayProjection left || crossesOneWayProjection right+  EMultiply _ left right -> crossesOneWayProjection left || crossesOneWayProjection right+  EPath _ _ (_ : _ : _) -> True+  EPath {} -> False+  ELiteral {} -> False+  EAtom {} -> False++replayGuardCoverage :: Transition -> GuardCoverage+replayGuardCoverage transition+  | maybe False crossesOneWayProjection (tGuard transition) = GuardUnknown+  | otherwise = GuardNotApplicable++liveReachableStates :: Aggregate -> Set Name+liveReachableStates aggregate = case map stName (aggStates aggregate) of+  [] -> Set.empty+  initial : _ -> go (Set.singleton initial) [initial]+  where+    go seen [] = seen+    go seen (source : remaining) =+      let next =+            [ tGoto transition+            | transition <- aggTransitions aggregate,+              tMode transition == TmLive,+              tSource transition == source,+              tGoto transition `Set.notMember` seen+            ]+       in go (foldr Set.insert seen next) (remaining <> next)++rejectIdentityDefects :: [BehaviorRequirement] -> Either [BehaviorDerivationError] ()+rejectIdentityDefects requirements = case duplicateErrors <> collisionErrors of+  [] -> Right ()+  errors -> Left errors+  where+    byCanonical = groupsOn requirementCanonical requirements+    duplicateErrors =+      [ DuplicateBehaviorIdentity canonical (map requirementLocation duplicates)+      | duplicates@(first : _ : _) <- byCanonical,+        let canonical = requirementCanonical first+      ]+    byKey = groupsOn requirementKey requirements+    collisionErrors =+      [ BehaviorKeyCollision key canonicals+      | collisions@(first : _ : _) <- byKey,+        let key = requirementKey first,+        let canonicals = Set.toAscList (Set.fromList (map requirementCanonical collisions)),+        length canonicals > 1+      ]++groupsOn :: (Ord key) => (value -> key) -> [value] -> [[value]]+groupsOn key = groupBy (\left right -> key left == key right) . sortOn key++renderBehaviorObligationsText :: BehaviorObligationsReport -> Text+renderBehaviorObligationsText report =+  T.unlines+    ( [ "behavior obligations: " <> T.pack (behaviorSubject report),+        "schema: keiro-dsl/behavior-obligations/1",+        "required: " <> tshow (length (behaviorRequirements report))+      ]+        <> map renderRequirement (behaviorRequirements report)+    )+  where+    renderRequirement requirement =+      unBehaviorKey (requirementKey requirement)+        <> " "+        <> obligationKindText (requirementKind requirement)+        <> " "+        <> requirementAggregate requirement+        <> ":"+        <> requirementSource requirement+        <> " -- "+        <> requirementCommand requirement+        <> " ["+        <> evidenceLevelText (requirementEvidence requirement)+        <> ", guard="+        <> guardCoverageText (requirementGuardCoverage requirement)+        <> "]"++encodeBehaviorObligationsJson :: BehaviorObligationsReport -> Text+encodeBehaviorObligationsJson = Text.decodeUtf8 . BL.toStrict . Aeson.encode++obligationKindText :: ObligationKind -> Text+obligationKindText kind = case kind of+  LiveTransition -> "live-transition"+  RequiredRejection -> "required-rejection"+  ReplayTransition -> "replay-transition"++evidenceLevelText :: EvidenceLevel -> Text+evidenceLevelText evidence = case evidence of+  GeneratedAuthoritative -> "generated-authoritative"+  HoleWitnessed -> "hole-witnessed"+  LegacyRuntimeWitness -> "legacy-runtime-witness"++guardCoverageText :: GuardCoverage -> Text+guardCoverageText coverage = case coverage of+  GuardTotal -> "proved-total"+  GuardPartial -> "provably-partial"+  GuardUnknown -> "unknown"+  GuardNotApplicable -> "not-applicable"++transitionModeText :: TransitionMode -> Text+transitionModeText mode = case mode of+  TmLive -> "live"+  TmReplayOnly -> "replay-only"++implementationText :: TransitionImplementation -> Text+implementationText implementation = case implementation of+  LegacyHoleImplementation -> "legacy-hole"+  GeneratedImplementation -> "generated"+  HoleImplementation -> "hole"++tshow :: (Show value) => value -> Text+tshow = T.pack . show

@@ -40,6 +40,7 @@     isAdvisory,     diffSources,     sourceLanguageChange,+    diffServices,     diffSpecs,     DiffEnv (..),     NodeFamily (..),@@ -61,8 +62,9 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType (typeExprCanonicalName)-import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface)+import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface, aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar+import Keiro.Dsl.IdDomain (IdDomainContract (..), idDomainContractFor) import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, languageVersionText, sourceFormText) import Keiro.Dsl.MappedDiff (MappedFinding (..), diffMapped, renderMappedSubject) import Keiro.Dsl.PrettyPrint@@ -73,6 +75,7 @@     renderTransition,   ) import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)+import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource, effectiveLanguageContract, effectiveRuntimeSemantics, legacyCheckedService) import Keiro.Dsl.TypeGraph (UsePath (..), UseSite (..)) import Keiro.Dsl.Validate (DiagnosticCode (..)) @@ -276,6 +279,7 @@   | code == NominalRepresentationChanged = mappedWireBreakingVector context   | code == NominalIdDecoderTightened =       (advisoryVector PrivateHistoryRead Set.empty) {cvConsumerBuild = VAdvisory}+  | code == IdDomainContractChanged = idDomainContractVector   | code == MappedDeclAdded = compatibleVector   | code `elem` privateDecodeCodes = privateDecodeBreakingVector   | code `elem` identityCodes = persistedIdentityBreakingVector@@ -328,6 +332,7 @@         WorkflowPatchRemoved,         WorkflowContinueSeedChanged       ]+     identityCodes =       [ DerivedIdentityChanged,         IdPrefixChanged,@@ -360,6 +365,18 @@         WorkflowEvolutionGuardAdded       ] +idDomainContractVector :: CompatibilityVector+idDomainContractVector =+  CompatibilityVector+    { cvPrivateHistoryRead = VCompatible,+      cvOldBinaryReadNewEvents = VCompatible,+      cvSnapshotHydration = VAdvisory,+      cvPublicConsumer = VBreaking,+      cvPersistedIdentity = VCompatible,+      cvConsumerBuild = VAdvisory,+      cvRollout = Set.singleton RolloutProducerLast+    }+ mappedWireBreakingCodes :: [DiagnosticCode] mappedWireBreakingCodes =   [ MappedFieldAddedNoDefault,@@ -616,8 +633,62 @@     (FamOperation, OutOfDiffScope "operations own no persisted decode or identity surface; their references and workflow signal/await pairing are single-spec validation concerns")   ] +-- | Compare two graphs under their effective semantic contracts. Current+-- released contracts share runtime semantics, so the selected policy delegates+-- to the graph differ; successor semantics extend this boundary rather than+-- teaching CLI callers to recover versions from provenance.+diffServices :: CheckedService -> CheckedService -> [Change]+diffServices oldService newService =+  diffCheckedSpecs oldSpec newSpec <> idDomainContractChanges <> semanticContractFoldChanges+  where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService+    oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes oldSpec]+    newAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes newSpec]+    idDomainContractChanges =+      [ breaking+          (idName newDeclaration)+          "id-domain-contract"+          (idName newDeclaration)+          IdDomainContractChanged+          ( "ID admission contract changed "+              <> renderIdDomainContract oldContract+              <> " -> "+              <> renderIdDomainContract newContract+              <> "; public construction, command decoding, current JSON codecs, and literals use the new contract; historical event replay retains its legacy decoder; old snapshots miss and rebuild from readable events, while rebuilt state that still contains legacy-invalid text remains intentionally uncacheable until overwritten or explicitly migrated"+          )+      | newDeclaration <- specIds newSpec,+        Just oldDeclaration <- [find ((== idName newDeclaration) . idName) (specIds oldSpec)],+        let oldContract = idDomainContractFor (checkedLanguageContract oldService) (idPrefix oldDeclaration),+        let newContract = idDomainContractFor (checkedLanguageContract newService) (idPrefix newDeclaration),+        oldContract /= newContract+      ]+    semanticContractFoldChanges =+      [ advisory+          name+          "semantic-contract"+          name+          AggFoldSurfaceChanged+          "effective runtime semantics changed the aggregate fold surface even though the normalized graph is unchanged; re-scaffold, redeploy, and audit replay under the candidate contract"+      | (name, oldAggregate) <- oldAggregates,+        Just newAggregate <- [lookup name newAggregates],+        aggregateFoldSurface oldSpec oldAggregate == aggregateFoldSurface newSpec newAggregate,+        aggregateFoldSurfaceForService oldService oldAggregate /= aggregateFoldSurfaceForService newService newAggregate+      ]++renderIdDomainContract :: Maybe IdDomainContract -> Text+renderIdDomainContract Nothing = "legacy-unchecked"+renderIdDomainContract (Just contract) =+  idDomainVersion contract <> "(prefix=" <> idDomainPrefix contract <> ",json=" <> idDomainJsonRepresentation contract <> ")"++-- | Compatibility wrapper for graph-only callers, explicitly using+-- legacy/version-1 semantics on both sides. diffSpecs :: Spec -> Spec -> [Change] diffSpecs old new =+  diffServices (legacyCheckedService old) (legacyCheckedService new)++diffCheckedSpecs :: Spec -> Spec -> [Change]+diffCheckedSpecs old new =   sharedDeclarationDiff env     ++ concatMap (runFamily env . snd) familyRegistry   where@@ -631,7 +702,7 @@     "declaration"     (parsedSourceLanguage old)     (parsedSourceLanguage new)-    <> diffSpecs (parsedSpec old) (parsedSpec new)+    <> diffServices (checkedSource old) (checkedSource new)  -- | One all-compatible source-provenance finding, reusable per workspace member. sourceLanguageChange :: Name -> Text -> SourceLanguage -> SourceLanguage -> [Change]@@ -649,10 +720,14 @@               <> renderSourceLanguage old               <> " -> "               <> renderSourceLanguage new-              <> "; the effective semantic contract is unchanged"+              <> if oldRuntime == newRuntime+                then "; normalized runtime semantics are unchanged"+                else "; effective runtime semantics changed " <> oldRuntime <> " -> " <> newRuntime <> "; see the accompanying semantic-contract findings"           )       ]   where+    oldRuntime = effectiveRuntimeSemantics (effectiveLanguageContract old)+    newRuntime = effectiveRuntimeSemantics (effectiveLanguageContract new)     renderSourceLanguage sourceLanguage =       sourceFormText sourceLanguage         <> maybe "" ((" v" <>) . languageVersionText) (declaredLanguageVersionMaybe sourceLanguage)

@@ -182,6 +182,8 @@   | code == WorkspaceAuthorityChanged = RemedyRescaffoldWorkspace :| [RemedyRecompileConsumers]   | code == AggGuardTightened = RemedyReplayOnlyEdge :| [RemedyRunConformance]   | code == AggFoldSurfaceChanged = RemedyStateCodecBump :| [RemedyRunConformance]+  | code == IdDomainContractChanged =+      RemedyDeploymentOrder RolloutProducerLast :| [RemedyStateCodecBump, RemedyRecompileConsumers, RemedyRunConformance]   | code `elem` mappedWireCodes = mappedWireRemedy   | code `elem` [MappedFieldAddedWithDefault, MappedArmAdded, MappedEnumValueAdded] = mappedAdditionRemedy   | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged] =

@@ -0,0 +1,148 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Checked ownership for values emitted by aggregate transitions.+--+-- The source grammar preserves whether an event copied a command with+-- @fields(Command)@ or declared an explicit field list.  This module turns that+-- provenance into the one semantic model consumed by validation, fingerprints,+-- scaffolding, and behavior coverage.  No downstream consumer may infer+-- ownership merely from coincidentally equal field names.+module Keiro.Dsl.EventOutput+  ( CheckedFieldCopy (..),+    OutputObligationKey (..),+    EventOutputMapping (..),+    EventOutputError (..),+    eventOutputMapping,+    eventOutputCanonical,+  )+where++import Data.List (find)+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.AggregateType+import Keiro.Dsl.Grammar+import Keiro.Dsl.PrettyPrint (renderExpr)++-- | One field in a checked identity copy.  The selector and current wire name+-- are retained separately so a future aggregate-field alias can change the wire+-- identity without changing how generated Haskell reads the command payload.+data CheckedFieldCopy = CheckedFieldCopy+  { outputSelector :: !Name,+    outputWireName :: !Text,+    outputFieldType :: !ResolvedAggregateType+  }+  deriving stock (Eq, Ord, Show)++-- | Stable, semantic name for one consumer-owned event-output obligation.+newtype OutputObligationKey = OutputObligationKey {unOutputObligationKey :: Text}+  deriving stock (Eq, Ord, Show)++-- | Exclusive ownership of one event term emitted by one transition.+data EventOutputMapping+  = GeneratedCommandIdentity+      { outputSourceCommand :: !Name,+        outputFields :: ![CheckedFieldCopy]+      }+  | HandOwnedEventOutput+      { outputObligation :: !OutputObligationKey+      }+  deriving stock (Eq, Ord, Show)++data EventOutputError+  = OutputEventMissing !Name+  | OutputSourceCommandMissing !Name+  | OutputCommandMismatch+      { declaredSourceCommand :: !Name,+        consumingTransitionCommand :: !Name,+        emittedEventName :: !Name+      }+  | OutputFieldTypeInvalid !AggregateTypeError+  | OutputFieldTypeMismatch !Name !ResolvedAggregateType !ResolvedAggregateType+  deriving stock (Eq, Show)++-- | Resolve one transition/event pair.  @fields(Command)@ is generated-owned+-- only for a transition consuming that exact command.  Explicit event fields+-- remain hand-owned even when their names happen to match command fields.+eventOutputMapping :: Spec -> Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping+eventOutputMapping spec aggregate transition emitIndex eventName = do+  event <- maybe (Left (OutputEventMissing eventName)) Right (find ((== eventName) . evName) (aggEvents aggregate))+  case (tImplementation transition, evBody event) of+    (LegacyHoleImplementation, _) -> pure handOwned+    (_, EventFields _) -> pure handOwned+    (_, EventFromCommand sourceCommand)+      | sourceCommand /= tCommand transition ->+          Left+            OutputCommandMismatch+              { declaredSourceCommand = sourceCommand,+                consumingTransitionCommand = tCommand transition,+                emittedEventName = eventName+              }+      | otherwise -> do+          command <- maybe (Left (OutputSourceCommandMissing sourceCommand)) Right (find ((== sourceCommand) . cmdName) (aggCommands aggregate))+          fields <- traverse checkedCopy (cmdFields command)+          pure+            GeneratedCommandIdentity+              { outputSourceCommand = sourceCommand,+                outputFields = fields+              }+  where+    symbols = aggregateSymbols spec+    handOwned =+      HandOwnedEventOutput+        { outputObligation =+            OutputObligationKey+              ( T.intercalate+                  "/"+                  [ "event-output-v1",+                    aggName aggregate,+                    transitionModeName (tMode transition),+                    tSource transition,+                    tCommand transition,+                    maybe "unguarded" renderExpr (tGuard transition),+                    T.intercalate ";" [register <> ":=" <> renderExpr expression | (register, expression) <- tWrites transition],+                    T.intercalate "," (tEmits transition),+                    tGoto transition,+                    T.pack (show emitIndex),+                    eventName+                  ]+              )+        }+    checkedCopy field = do+      commandType <- mapLeft OutputFieldTypeInvalid (inferAggregateFieldType symbols aggregate CommandFieldUse field)+      eventType <- mapLeft OutputFieldTypeInvalid (inferAggregateFieldType symbols aggregate EventFieldUse field)+      if commandType == eventType+        then+          pure+            CheckedFieldCopy+              { outputSelector = aggregateFieldName field,+                outputWireName = aggregateFieldName field,+                outputFieldType = commandType+              }+        else Left (OutputFieldTypeMismatch (aggregateFieldName field) commandType eventType)++-- | Canonical ownership text used by fold and behavior fingerprints.+eventOutputCanonical :: EventOutputMapping -> Text+eventOutputCanonical mapping = case mapping of+  GeneratedCommandIdentity command fields ->+    "generated-command-identity:"+      <> command+      <> "["+      <> T.intercalate+        ","+        [ outputSelector field+            <> "="+            <> outputWireName field+            <> ":"+            <> aggregateCanonicalName (outputFieldType field)+        | field <- fields+        ]+      <> "]"+  HandOwnedEventOutput obligation -> "hand-owned:" <> unOutputObligationKey obligation++mapLeft :: (left -> other) -> Either left right -> Either other right+mapLeft f = either (Left . f) Right++transitionModeName :: TransitionMode -> Text+transitionModeName TmLive = "live"+transitionModeName TmReplayOnly = "replay-only"

@@ -9,7 +9,9 @@     BindingObligation (..),     BindingHole (..),     bindingObligations,+    bindingObligationsForService,     bindingHoles,+    bindingHolesForService,     renderBindingObligations,   ) where@@ -23,7 +25,10 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar+import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainVersion)+import Keiro.Dsl.LanguageVersion (SourceLanguage (..)) import Keiro.Dsl.NominalType+import Keiro.Dsl.SemanticContract (CheckedService (..), effectiveLanguageContract) import Keiro.Dsl.TypeGraph  data BindingResolutionError@@ -47,6 +52,8 @@     obligationUseSites :: ![Text],     obligationBindingVersion :: !(Maybe Text),     obligationCanonicalType :: !(Maybe Text),+    obligationEqualityContract :: !(Maybe Text),+    obligationIdDomainContract :: !(Maybe Text),     obligationCategory :: !Text   }   deriving stock (Eq, Ord, Show)@@ -74,6 +81,8 @@         "useSites" .= obligationUseSites obligation,         "bindingVersion" .= obligationBindingVersion obligation,         "canonicalType" .= obligationCanonicalType obligation,+        "equalityContract" .= obligationEqualityContract obligation,+        "idDomainContract" .= obligationIdDomainContract obligation,         "category" .= obligationCategory obligation       ] @@ -95,6 +104,8 @@           <*> value .: "useSites"           <*> value .:? "bindingVersion"           <*> value .:? "canonicalType"+          <*> value .:? "equalityContract"+          <*> value .:? "idDomainContract"           <*> (value .:? "category" >>= pure . maybe "structural" id)  instance ToJSON BindingHole where@@ -126,7 +137,10 @@           <*> value .: "signature"  bindingObligations :: Spec -> Either (NonEmpty BindingResolutionError) [BindingObligation]-bindingObligations spec = do+bindingObligations spec = bindingObligationsForService (CheckedService (effectiveLanguageContract LegacyUnversioned) spec)++bindingObligationsForService :: CheckedService -> Either (NonEmpty BindingResolutionError) [BindingObligation]+bindingObligationsForService service = do   graph <- first (fmap BindingTypeGraphError) (resolveTypeGraph spec)   nominalRegistry <- first (fmap BindingNominalTypeError) (resolveNominalTypes spec)   pure . sortOn obligationSortKey $@@ -134,12 +148,17 @@       [ obligationsFor graph declaration       | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph)       ]-      <> concatMap (nominalObligationsFor spec) (Map.elems (nominalTypes nominalRegistry))+      <> concatMap (nominalObligationsFor service) (Map.elems (nominalTypes nominalRegistry))+  where+    spec = checkedSpec service  bindingHoles :: Spec -> Either (NonEmpty BindingResolutionError) [BindingHole]-bindingHoles spec = do+bindingHoles spec = bindingHolesForService (CheckedService (effectiveLanguageContract LegacyUnversioned) spec)++bindingHolesForService :: CheckedService -> Either (NonEmpty BindingResolutionError) [BindingHole]+bindingHolesForService service = do   graph <- first (fmap BindingTypeGraphError) (resolveTypeGraph spec)-  obligations <- bindingObligations spec+  obligations <- bindingObligationsForService service   pure . sortOn holeSortKey $     concat       [ holesFor graph declaration shape obligations@@ -156,6 +175,8 @@          | obligation <- obligations,            obligationCategory obligation /= "structural"          ]+  where+    spec = checkedSpec service  holesFor :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [BindingObligation] -> [BindingHole] holesFor _graph declaration shape obligations = bindingEntries <> auxiliaryEntries@@ -267,13 +288,15 @@       obligationUseSites = paths,       obligationBindingVersion = version,       obligationCanonicalType = canonical,+      obligationEqualityContract = Nothing,+      obligationIdDomainContract = Nothing,       obligationCategory = "structural"     }   where     (ownerModule, symbol) = splitQualified (unQualifiedValueName qualified) -nominalObligationsFor :: Spec -> ResolvedNominalType -> [BindingObligation]-nominalObligationsFor spec nominal = case resolvedNominalOwnership nominal of+nominalObligationsFor :: CheckedService -> ResolvedNominalType -> [BindingObligation]+nominalObligationsFor service nominal = case resolvedNominalOwnership nominal of   GeneratedNominal -> []   ConsumerNominal binding -> bindingEntry : fixtureEntry : initialEntries     where@@ -295,17 +318,22 @@         ScalarRepresentation NominalBool -> "Bool"         ScalarRepresentation NominalTime -> "UTCTime"       canonical = Just (unCanonicalTypeId (consumerNominalCanonical binding))-      bindingEntry = nominalObligation name binding category (consumerNominalBinding binding) BindingValue ("NominalBinding " <> consumerType <> " " <> representation) paths (Just (unBindingVersion (consumerNominalBindingVersion binding))) canonical-      fixtureEntry = nominalObligation name binding category (consumerNominalFixtures binding) FixtureValue ("NominalFixtureCases " <> consumerType) paths Nothing canonical+      equalityContract = nominalEqualityIdentityForService (checkedLanguageContract service) nominal+      idContract = case resolvedNominalRepresentation nominal of+        IdRepresentation prefix -> idDomainVersion <$> idDomainContractFor (checkedLanguageContract service) prefix+        _ -> Nothing+      bindingEntry = nominalObligation name binding category (consumerNominalBinding binding) BindingValue ("NominalBinding " <> consumerType <> " " <> representation) paths (Just (unBindingVersion (consumerNominalBindingVersion binding))) canonical equalityContract idContract+      fixtureEntry = nominalObligation name binding category (consumerNominalFixtures binding) FixtureValue ("NominalFixtureCases " <> consumerType) paths Nothing canonical Nothing Nothing       initialEntries = case (registerPaths, consumerNominalInitial binding) of         ([], _) -> []         (_, Nothing) -> []-        (_, Just initialValue) -> [nominalObligation name binding category initialValue InitialValue consumerType registerPaths Nothing canonical]+        (_, Just initialValue) -> [nominalObligation name binding category initialValue InitialValue consumerType registerPaths Nothing canonical Nothing Nothing]   where+    spec = checkedSpec service     quoted value = T.pack (show value) -nominalObligation :: Name -> ConsumerNominalBinding -> Text -> QualifiedValueName -> BindingObligationKind -> Text -> [Text] -> Maybe Text -> Maybe Text -> BindingObligation-nominalObligation name binding category qualified kindValue signature paths version canonical =+nominalObligation :: Name -> ConsumerNominalBinding -> Text -> QualifiedValueName -> BindingObligationKind -> Text -> [Text] -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> BindingObligation+nominalObligation name binding category qualified kindValue signature paths version canonical equalityContract idDomainContract =   BindingObligation     { obligationMappedName = name,       obligationPackage = hsPackage (consumerNominalHaskell binding),@@ -316,6 +344,8 @@       obligationUseSites = paths,       obligationBindingVersion = version,       obligationCanonicalType = canonical,+      obligationEqualityContract = equalityContract,+      obligationIdDomainContract = idDomainContract,       obligationCategory = category     }   where@@ -375,6 +405,8 @@       ]         <> maybe [] (\version -> ["      provenance: binding-version " <> quoted version]) (obligationBindingVersion obligation)         <> maybe [] (\canonical -> ["      canonical-type: " <> quoted canonical]) (obligationCanonicalType obligation)+        <> maybe [] (\contract -> ["      equality-contract: " <> quoted contract]) (obligationEqualityContract obligation)+        <> maybe [] (\contract -> ["      id-domain-contract: " <> quoted contract]) (obligationIdDomainContract obligation)     renderPaths [] = " (not currently used by an aggregate root)"     renderPaths paths = " (" <> T.intercalate "; " paths <> ")"     quoted value = T.pack (show value)

@@ -362,7 +362,12 @@       failure         loc         ScalarRootUnknown-        ("scalar root '" <> name <> "' resolves to no register or field of command '" <> tCommand transition <> "'")+        ( "scalar root '"+            <> name+            <> "' resolves to no register or field of command '"+            <> tCommand transition+            <> "'; qualify enum values as Type.Constructor"+        )  resolveProjectionPath :: ExpressionEnvironment -> Loc -> ScalarRootProvenance -> [Name] -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr resolveProjectionPath environment loc provenance fields = do

@@ -3,7 +3,9 @@ -- projections, snapshot policy, and source locations: those inputs do not change -- how an existing event log becomes aggregate state. module Keiro.Dsl.FoldFingerprint-  ( aggregateFoldFingerprint,+  ( aggregateFoldFingerprintForService,+    aggregateFoldSurfaceForService,+    aggregateFoldFingerprint,     aggregateFoldSurface,   ) where@@ -16,15 +18,24 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType+import Keiro.Dsl.EventOutput+import Keiro.Dsl.Expression import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType import Keiro.Dsl.PrettyPrint (renderExpr) import Keiro.Dsl.ReadModelShape (fnv1a64)+import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, legacyCheckedService, runtimeSemanticsFingerprintSegment) import Keiro.Dsl.TypeGraph +-- | The sixteen-hex-digit identity of an aggregate's replay fold under the+-- service's effective runtime semantics.+aggregateFoldFingerprintForService :: CheckedService -> Aggregate -> Text+aggregateFoldFingerprintForService service = fnv1a64 . aggregateFoldSurfaceForService service+ -- | The sixteen-hex-digit identity of an aggregate's replay fold.+-- This compatibility wrapper selects legacy/version-1 runtime semantics. aggregateFoldFingerprint :: Spec -> Aggregate -> Text-aggregateFoldFingerprint spec = fnv1a64 . aggregateFoldSurface spec+aggregateFoldFingerprint spec = aggregateFoldFingerprintForService (legacyCheckedService spec)  -- | Canonical pre-hash text for an aggregate's replay fold. --@@ -32,17 +43,26 @@ -- spec is required. Only rules reached from transition guards and writes are -- included, transitively, in declaration order. aggregateFoldSurface :: Spec -> Aggregate -> Text-aggregateFoldSurface spec aggregate =+aggregateFoldSurface spec = aggregateFoldSurfaceForService (legacyCheckedService spec)++-- | Canonical pre-hash text under a checked semantic contract. A runtime+-- discriminator is included only for a contract that can change fold behavior;+-- source declaration provenance and grammar-only versions never enter it.+aggregateFoldSurfaceForService :: CheckedService -> Aggregate -> Text+aggregateFoldSurfaceForService service aggregate =   T.intercalate     "\n"-    ( map stateSegment (aggStates aggregate)+    ( maybe [] pure (runtimeSemanticsFingerprintSegment (checkedLanguageContract service))+        ++ map stateSegment (aggStates aggregate)         ++ map (registerSegment symbols) (aggRegs aggregate)         ++ mappedRegisterSegments         ++ nominalSegments-        ++ map transitionSegment (aggTransitions aggregate)+        ++ nominalEqualitySegments+        ++ map (transitionSegment spec aggregate) (aggTransitions aggregate)         ++ map ruleSegment referencedRules     )   where+    spec = checkedSpec service     symbols = aggregateSymbols spec     referencedRules =       [ rule@@ -65,7 +85,52 @@           Just nominal <- [lookupNominalType typeName registry],           ConsumerNominal binding <- [resolvedNominalOwnership nominal]         ]+    nominalEqualitySegments =+      [ "nominal-equality-use:" <> identity+      | identity <- Set.toAscList (nominalEqualityUses service aggregate)+      ] +-- | Equality representation belongs in the fold identity only when a guard+-- actually compares that declaration. This keeps unrelated binding metadata out+-- of replay compatibility while ensuring a witness/domain change cannot silently+-- retain the old fold fingerprint.+nominalEqualityUses :: CheckedService -> Aggregate -> Set Text+nominalEqualityUses service aggregate =+  Set.fromList+    [ identity+    | transition <- aggTransitions aggregate,+      guardSyntax <- maybeToList (tGuard transition),+      Right guardExpression <- [resolveGuardExpr (expressionEnvironment spec aggregate transition) guardSyntax],+      identity <- equalityIdentities (checkedLanguageContract service) guardExpression+    ]+  where+    spec = checkedSpec service++equalityIdentities :: EffectiveLanguageContract -> TypedScalarExpr -> [Text]+equalityIdentities languageContract expression =+  current <> children+  where+    current = case typedScalarNode expression of+      TypedEqual left _ -> equalityIdentity left+      TypedNotEqual left _ -> equalityIdentity left+      _ -> []+    equalityIdentity operand = case typedScalarType operand of+      AggregateNominal nominal -> maybeToList (nominalEqualityIdentityForService languageContract nominal)+      _ -> []+    children = case typedScalarNode expression of+      TypedLiteral {} -> []+      TypedRoot {} -> []+      TypedProject {} -> []+      TypedAdd _ left right -> recurse left right+      TypedSubtract _ left right -> recurse left right+      TypedMultiply _ left right -> recurse left right+      TypedEqual left right -> recurse left right+      TypedNotEqual left right -> recurse left right+      TypedCompare _ left right -> recurse left right+      TypedAnd left right -> recurse left right+      TypedOr left right -> recurse left right+    recurse left right = equalityIdentities languageContract left <> equalityIdentities languageContract right+ nominalUseNames :: Aggregate -> [(Text, Name)] nominalUseNames aggregate =   [ ("register:" <> regName register, typeName)@@ -161,8 +226,8 @@   '\r' -> "\\r"   character -> T.singleton character -transitionSegment :: Transition -> Text-transitionSegment transition =+transitionSegment :: Spec -> Aggregate -> Transition -> Text+transitionSegment spec aggregate transition =   T.intercalate     "|"     ( [ "transition:" <> renderMode (tMode transition),@@ -172,12 +237,20 @@         ++ implementationSegment         ++ [ "guard=" <> maybe "" renderExpr (tGuard transition),              "writes=" <> T.intercalate ";" (map renderWrite (tWrites transition)),-             "emits=" <> T.intercalate "," (tEmits transition),-             "goto=" <> tGoto transition+             "emits=" <> T.intercalate "," (tEmits transition)            ]+        ++ outputOwnershipSegment+        ++ ["goto=" <> tGoto transition]     )   where     renderWrite (registerName, expression) = registerName <> ":=" <> renderExpr expression+    outputSegment emitIndex eventName = case eventOutputMapping spec aggregate transition emitIndex eventName of+      Right mapping -> eventName <> "=" <> eventOutputCanonical mapping+      Left problem -> eventName <> "=invalid:" <> T.pack (show problem)+    outputOwnershipSegment = case tImplementation transition of+      LegacyHoleImplementation -> []+      GeneratedImplementation -> ["outputs=" <> T.intercalate "," [outputSegment emitIndex eventName | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)]]+      HoleImplementation -> ["outputs=" <> T.intercalate "," [outputSegment emitIndex eventName | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)]]     implementationSegment = case tImplementation transition of       LegacyHoleImplementation -> []       GeneratedImplementation -> ["implementation=generated"]

@@ -22,7 +22,9 @@ -- to the replay check. Other sample kinds remain uniform until fixture bindings can -- supply a wider, consumer-owned corpus. module Keiro.Dsl.Harness-  ( harnessFor,+  ( harnessForService,+    harnessForServiceWithGoldens,+    harnessFor,     harnessForWithGoldens,     harnessProcess,     harnessRouter,@@ -33,19 +35,32 @@  import Data.List (find) import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType import Keiro.Dsl.Goldens (GoldenPayload (..)) import Keiro.Dsl.Grammar+import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainSampleText) import Keiro.Dsl.NominalType import Keiro.Dsl.ReadModelShape (deriveShapeHash, registryNameFor, subscriptionNameFor) import Keiro.Dsl.Scaffold+import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService) import Keiro.Dsl.TypeGraph +-- | Emit the aggregate harness after selecting the service's effective+-- semantic contract.+harnessForService :: Context -> CheckedService -> Aggregate -> [ScaffoldModule]+harnessForService = harnessForServiceWithGoldens []++-- | Contract-aware aggregate harness planning with embedded golden payloads.+harnessForServiceWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Aggregate -> [ScaffoldModule]+harnessForServiceWithGoldens = harnessForCheckedWithGoldens+ -- | Emit the harness test module for one aggregate. Like 'scaffoldAggregate',--- it takes the 'Spec' for the shared id\/enum declarations.+-- it takes the 'Spec' for the shared id\/enum declarations. This compatibility+-- wrapper selects legacy/version-1 runtime semantics. harnessFor :: Context -> Spec -> Aggregate -> [ScaffoldModule] harnessFor = harnessForWithGoldens [] @@ -53,7 +68,11 @@ -- as string literals. Embedding keeps the generated test independent of runtime -- file paths while retaining the golden file as regeneration source of truth. harnessForWithGoldens :: [GoldenPayload] -> Context -> Spec -> Aggregate -> [ScaffoldModule]-harnessForWithGoldens goldens ctx spec agg =+harnessForWithGoldens goldens ctx spec =+  harnessForServiceWithGoldens goldens ctx (legacyCheckedService spec)++harnessForCheckedWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Aggregate -> [ScaffoldModule]+harnessForCheckedWithGoldens goldens ctx service agg =   [ ScaffoldModule       { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/Harness.hs"),         moduleText = emitHarness relevantGoldens a,@@ -62,7 +81,8 @@       }   ]   where-    a = resolveAgg ctx spec agg+    spec = checkedSpec service+    a = resolveAggForService ctx service agg     relevantGoldens =       [ golden       | golden <- goldens,@@ -384,6 +404,7 @@            "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")",            codecDecodeRawImport          ]+      ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (generatedNominalHarnessTypes a)       ++ mappedHarnessImports a       ++ nominalHarnessImports a       ++ aggregateHarnessImports a@@ -442,7 +463,7 @@     coreImports =       ["applyEventsEither" | not (null replayTransitions)]         ++ ["defaultValidationOptions", "step", "validateTransducer"]-        ++ ["fieldWitnessAgrees" | not (null (mappedProjectionSpecs a)) || not (null (nominalScalarHarnessTypes a))]+        ++ ["fieldWitnessAgrees" | not (null (mappedProjectionSpecs a)) || not (null (nominalScalarHarnessTypes a)) || not (null (enforcedConsumerNominalIdHarnessTypes a))]         ++ ["(!)" | not (null replayTransitions) && not (null (aRegs a))]     upcastAssertions =       [ "(" <> tshow (upcastLabel e m) <> ", upcasts" <> rcName e <> ")"@@ -581,7 +602,7 @@   ]   where     cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of-      (c : _) -> "(" <> ctorExpr a c <> ")"+      (c : _) -> "(" <> commandCtorExpr a c <> ")"       [] -> "(error \"no command\")"  forwardReplayDecl :: Agg -> Transition -> [Text]@@ -619,7 +640,7 @@     forwardRegsName = if null (aRegs a) then "_forwardRegs" else "forwardRegs"     replayRegsName = if null (aRegs a) then "_replayRegs" else "replayRegs"     cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of-      (c : _) -> "(" <> ctorExpr a c <> ")"+      (c : _) -> "(" <> commandCtorExpr a c <> ")"       [] -> "(error \"no command\")"  -- | @(<Ctor> (<Ctor>Data v1 v2 …))@ with positional sample field values.@@ -629,16 +650,47 @@   where     args = T.concat [" " <> sampleValue a fieldName ty | (fieldName, ty) <- rcFields rc] +-- | A transition command sample prefers the initial value of a same-named,+-- same-typed register. This makes the generated acceptance/replay probes honest+-- for declaration-exact @cmd.field == reg.field@ guards while retaining the+-- field-distinct samples used by standalone event codec probes.+commandCtorExpr :: Agg -> ResolvedCtor -> Text+commandCtorExpr a rc =+  "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))"+  where+    args = T.concat [" " <> commandSampleValue a fieldName ty | (fieldName, ty) <- rcFields rc]++commandSampleValue :: Agg -> Text -> ResolvedAggregateType -> Text+commandSampleValue aggregate fieldName fieldType = case fieldType of+  AggregateNominal nominal+    | nominalEqualityUsedInGeneratedExpressions nominal aggregate -> case find matchesRegister (aRegs aggregate) of+        Just register -> regInitialValueForHarness aggregate register+        Nothing -> fallback+  _ -> fallback+  where+    fallback = sampleValue aggregate fieldName fieldType+    matchesRegister register = rrName register == fieldName && rrType register == fieldType+    regInitialValueForHarness owner register = case rrType register of+      AggregateNominal nominal -> fromMaybe (renderRegisterInitial (rrInitial register)) (generatedIdSampleHaskell owner nominal)+      _ -> renderRegisterInitial (rrInitial register)+ sampleValue :: Agg -> Text -> ResolvedAggregateType -> Text-sampleValue a fieldName ty = case fieldCat a ty of-  IdCat -> aggregateSampleHaskell (aSymbols a) fieldName ty-  EnumCat -> aggregateSampleHaskell (aSymbols a) fieldName ty-  MappedStructuralCat declaration _ -> fixtureSample (sdFixtures declaration)-  MappedOpaqueCat declaration -> fixtureSample (odFixtures declaration)-  OtherCat -> case ty of-    AggregateVertex vertexType-      | vertexType == aVertexType a -> initialVertex a-    _ -> aggregateSampleHaskell (aSymbols a) fieldName ty+sampleValue a fieldName ty = case ty of+  AggregateNominal nominal+    | GeneratedNominal <- resolvedNominalOwnership nominal,+      Just sample <- generatedIdSampleHaskell a nominal ->+        sample+  _ -> fallback+  where+    fallback = case fieldCat a ty of+      IdCat -> aggregateSampleHaskell (aSymbols a) fieldName ty+      EnumCat -> aggregateSampleHaskell (aSymbols a) fieldName ty+      MappedStructuralCat declaration _ -> fixtureSample (sdFixtures declaration)+      MappedOpaqueCat declaration -> fixtureSample (odFixtures declaration)+      OtherCat -> case ty of+        AggregateVertex vertexType+          | vertexType == aVertexType a -> initialVertex a+        _ -> aggregateSampleHaskell (aSymbols a) fieldName ty  aggregateHarnessImports :: Agg -> [Text] aggregateHarnessImports aggregate =@@ -656,10 +708,15 @@       [ "import Data.List.NonEmpty qualified as NonEmpty",         "import Keiro.Codec.Nominal (nominalDomainRoundTrip, nominalFixtureCases, nominalFixtureDomain, nominalRepresentationRoundTrip, nominalToRepresentation)"       ]+        <> ( if null enforcedIds+               then []+               else ["import Data.KindID qualified as KindID", "import Data.Text qualified as T", "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)"]+           )         <> ["import " <> moduleName <> " qualified" | moduleName <- unique (fixtureModules <> bindingModules)]-        <> ["import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections" | not (null (nominalScalarHarnessTypes aggregate))]+        <> ["import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections" | not (null (nominalScalarHarnessTypes aggregate)) || not (null enforcedIds)]   where     nominals = consumerNominalHarnessTypes aggregate+    enforcedIds = enforcedConsumerNominalIdHarnessTypes aggregate     bindings = [binding | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]]     fixtureModules =       [ fst (splitQualifiedHarness (unQualifiedValueName (consumerNominalFixtures binding)))@@ -682,6 +739,11 @@       ConsumerNominal {} <- [resolvedNominalOwnership nominal]     ] +generatedNominalHarnessTypes :: Agg -> [ResolvedNominalType]+generatedNominalHarnessTypes aggregate =+  generatedNominalsInTypes+    (map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)))+ nominalScalarHarnessTypes :: Agg -> [ResolvedNominalType] nominalScalarHarnessTypes aggregate =   [ nominal@@ -689,6 +751,14 @@     ScalarRepresentation {} <- [resolvedNominalRepresentation nominal]   ] +enforcedConsumerNominalIdHarnessTypes :: Agg -> [ResolvedNominalType]+enforcedConsumerNominalIdHarnessTypes aggregate =+  [ nominal+  | nominal <- consumerNominalHarnessTypes aggregate,+    IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+    idDomainContractFor (aLanguageContract aggregate) prefix /= Nothing+  ]+ nominalHarnessDeclarations :: Agg -> [Text] nominalHarnessDeclarations aggregate   | null nominals = []@@ -721,11 +791,61 @@                )              | ScalarRepresentation {} <- [resolvedNominalRepresentation nominal]              ]+          <> idDomainAssertions name bindingName fixtures nominal         where           name = resolvedNominalName nominal           bindingName = unQualifiedValueName (consumerNominalBinding binding)           fixtureName = unQualifiedValueName (consumerNominalFixtures binding)           fixtures = "(NonEmpty.toList (nominalFixtureCases " <> fixtureName <> "))"+    idDomainAssertions name bindingName fixtures nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix+        | Just contract <- idDomainContractFor (aLanguageContract aggregate) prefix ->+            let firstSample = idDomainSampleText contract+                samples = [firstSample, T.dropEnd 1 firstSample <> "r"]+                wrongPrefix = "wrong_" <> T.drop (T.length prefix + 1) firstSample+             in [ ( "nominal ID projection agreement: " <> name,+                    "all (\\fixture -> fieldWitnessAgrees NominalProjections."+                      <> lowerFirst name+                      <> "EqualityWitness (KindID.toText . nominalToRepresentation "+                      <> bindingName+                      <> ") (nominalFixtureDomain fixture)) "+                      <> fixtures+                  ),+                  ( "nominal ID fixture domain agreement: " <> name,+                    "all (\\fixture -> case validateIdDomainText (typeIdV7Domain "+                      <> tshow prefix+                      <> ") (KindID.toText (nominalToRepresentation "+                      <> bindingName+                      <> " (nominalFixtureDomain fixture))) of Right () -> True; Left _ -> False) "+                      <> fixtures+                  ),+                  ( "nominal ID binding preserves canonical representations: " <> name,+                    "all (nominalRepresentationRoundTrip "+                      <> bindingName+                      <> ") ["+                      <> T.intercalate ", " (map (renderKindId prefix) samples)+                      <> "]"+                  ),+                  ( "nominal ID boundary rejects wrong-prefix and normalized text: " <> name,+                    "case (validateIdDomainText (typeIdV7Domain "+                      <> tshow prefix+                      <> ") "+                      <> tshow wrongPrefix+                      <> ", validateIdDomainText (typeIdV7Domain "+                      <> tshow prefix+                      <> ") (T.toUpper "+                      <> tshow firstSample+                      <> ")) of (Left _, Left _) -> True; _ -> False"+                  )+                ]+      _ -> []+      where+        renderKindId prefix value =+          "(case KindID.parseText @"+            <> tshow prefix+            <> " "+            <> tshow value+            <> " of Right parsed -> parsed; Left _ -> error \"generated canonical ID conformance probe failed to parse\")"     renderList values =       [ (if index == (0 :: Int) then "  [ " else "  , ") <> "(" <> tshow labelText <> ", " <> expression <> ")"       | (index, (labelText, expression)) <- zip [0 ..] values

@@ -0,0 +1,51 @@+-- | Semantic selection of the published ID runtime contract.+module Keiro.Dsl.IdDomain+  ( IdNormalization (..),+    IdDomainContract (..),+    IdDomainFailure (..),+    enforcedIdDomainVersion,+    idDomainContractFor,+    idDomainIdentity,+    idDomainIdentitiesForService,+    idDomainAcceptsText,+    validateIdDomainText,+    idDomainTextPattern,+    idDomainSampleText,+  )+where++import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Codec.IdDomain+import Keiro.Dsl.Grammar (IdDecl (..), Spec (..))+import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeSemantics)++-- | Versions 1 and 2 intentionally return 'Nothing': their generated IDs+-- admitted arbitrary text. Runtime-semantics generation 2 is the first+-- enforcing contract.+idDomainContractFor :: EffectiveLanguageContract -> Text -> Maybe IdDomainContract+idDomainContractFor languageContract prefix+  | effectiveRuntimeSemantics languageContract /= "keiro-dsl/runtime-semantics/2" = Nothing+  | otherwise = Just (typeIdV7Domain prefix)++-- | Durable identity for the runtime admission domain of one declaration.+-- This is deliberately separate from nominal equality: IDs without equality+-- expressions still have a construction and codec contract.+idDomainIdentity :: Text -> IdDomainContract -> Text+idDomainIdentity name contract =+  T.intercalate+    "|"+    [ "id-domain",+      "name=" <> name,+      "contract=" <> idDomainVersion contract,+      "prefix=" <> idDomainPrefix contract,+      "separator=" <> T.singleton (idDomainSeparator contract),+      "json=" <> idDomainJsonRepresentation contract+    ]++idDomainIdentitiesForService :: CheckedService -> [Text]+idDomainIdentitiesForService service =+  [ idDomainIdentity (idName declaration) contract+  | declaration <- specIds (checkedSpec service),+    Just contract <- [idDomainContractFor (checkedLanguageContract service) (idPrefix declaration)]+  ]

@@ -18,6 +18,9 @@     languageRegistry,     supportedLanguageVersions,     lookupLanguageDefinition,+    LanguageFeature (..),+    languageFeatureMinimumVersion,+    languageSupportsFeature,     SourceLanguageErrorCode (..),     sourceLanguageErrorCodeText,     SourceLanguageDiagnostic (..),@@ -101,11 +104,16 @@ version2 :: LanguageVersion version2 = LanguageVersion 2 +version3 :: LanguageVersion+version3 = LanguageVersion 3+ -- | The authoritative, append-only registry of released language contracts. languageRegistry :: NonEmpty LanguageDefinition languageRegistry =   LanguageDefinition version1 Nothing LanguageBodyParserV1-    :| [LanguageDefinition version2 (Just version1) LanguageBodyParserV2]+    :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2,+         LanguageDefinition version3 (Just version2) LanguageBodyParserV2+       ]  -- | Supported versions, derived from 'languageRegistry'. supportedLanguageVersions :: NonEmpty LanguageVersion@@ -114,6 +122,27 @@ lookupLanguageDefinition :: LanguageVersion -> Maybe LanguageDefinition lookupLanguageDefinition version =   find ((== version) . definitionVersion) (NE.toList languageRegistry)++-- | Grammar-owned syntax introduced after the frozen version-1 contract.+-- Keeping these gates beside the released-language registry prevents the+-- parser from growing an independent list of textual spellings.+data LanguageFeature+  = NominalBindingSyntax+  | IntegerScalarSyntax+  | TypedAggregateExpressionSyntax+  | ExplicitTransitionImplementationSyntax+  deriving stock (Eq, Ord, Show)++-- | The first released contract that owns each grammar feature.+languageFeatureMinimumVersion :: LanguageFeature -> LanguageVersion+languageFeatureMinimumVersion = \case+  NominalBindingSyntax -> version2+  IntegerScalarSyntax -> version2+  TypedAggregateExpressionSyntax -> version2+  ExplicitTransitionImplementationSyntax -> version2++languageSupportsFeature :: LanguageVersion -> LanguageFeature -> Bool+languageSupportsFeature version feature = version >= languageFeatureMinimumVersion feature  effectiveLanguageVersion :: SourceLanguage -> LanguageVersion effectiveLanguageVersion LegacyUnversioned = version1

@@ -10,12 +10,21 @@ module Keiro.Dsl.NominalType   ( NominalScalarRepresentation (..),     NominalRepresentation (..),+    NominalEqualityKey (..),+    NominalEqualityDomain (..),+    CheckedNominalEquality (..),     NominalOwnership (..),     ConsumerNominalBinding (..),     ResolvedNominalType (..),     NominalTypeRegistry,     nominalTypes,     lookupNominalType,+    nominalEqualityContract,+    nominalEqualityContractForService,+    nominalEqualityIdentity,+    nominalEqualityIdentityForService,+    nominalEqualityIdentities,+    nominalEqualityIdentitiesForService,     NominalTypeError (..),     resolveNominalTypes,   )@@ -32,6 +41,9 @@ import Data.TypeID qualified as TypeID import GHC.Generics (Generic) import Keiro.Dsl.Grammar+import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainVersion)+import Keiro.Dsl.LanguageVersion (SourceLanguage (..))+import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveLanguageContract) import Keiro.Dsl.TypeGraph  data NominalScalarRepresentation@@ -48,6 +60,32 @@   | ScalarRepresentation !NominalScalarRepresentation   deriving stock (Eq, Ord, Show, Generic) +-- | The canonical carrier compared by generated nominal equality. IDs and+-- enums deliberately share their stable textual wire key while remaining+-- type-distinct in the checked expression tree.+data NominalEqualityKey+  = NominalTextEqualityKey+  deriving stock (Eq, Ord, Show, Generic)++-- | The exactness Keiro can honestly claim for a nominal equality projection.+-- Released generated IDs still wrap arbitrary 'Text', so their projection is+-- total but unconstrained until the enforcing language contract lands. A+-- consumer-bound ID is backed by a checked @KindID prefix@ representation and+-- therefore has the exact TypeID text image. Enums always have a finite image.+data NominalEqualityDomain+  = LegacyUnrestrictedTextDomain+  | TypeIdTextDomain !Text+  | EnforcedTypeIdV7TextDomain !Text !Text+  | FiniteTextDomain !(NonEmpty Text)+  deriving stock (Eq, Ord, Show, Generic)++data CheckedNominalEquality = CheckedNominalEquality+  { equalityKeyRepresentation :: !NominalEqualityKey,+    equalityDomain :: !NominalEqualityDomain,+    equalityContractVersion :: !Text+  }+  deriving stock (Eq, Ord, Show, Generic)+ data ConsumerNominalBinding = ConsumerNominalBinding   { consumerNominalHaskell :: !HaskellSource,     consumerNominalBinding :: !QualifiedValueName,@@ -84,6 +122,87 @@  lookupNominalType :: Name -> NominalTypeRegistry -> Maybe ResolvedNominalType lookupNominalType name = Map.lookup name . nominalTypes++-- | Resolve the declaration-scoped equality contract. Nominal scalar wrappers+-- keep their existing scalar projection behavior; this contract is the new+-- authority only for IDs and enums.+nominalEqualityContract :: ResolvedNominalType -> Maybe CheckedNominalEquality+nominalEqualityContract = nominalEqualityContractForService (effectiveLanguageContract LegacyUnversioned)++nominalEqualityContractForService :: EffectiveLanguageContract -> ResolvedNominalType -> Maybe CheckedNominalEquality+nominalEqualityContractForService languageContract nominal = case resolvedNominalRepresentation nominal of+  IdRepresentation prefix ->+    Just+      CheckedNominalEquality+        { equalityKeyRepresentation = NominalTextEqualityKey,+          equalityDomain = case idDomainContractFor languageContract prefix of+            Just contract -> EnforcedTypeIdV7TextDomain prefix (idDomainVersion contract)+            Nothing -> case resolvedNominalOwnership nominal of+              GeneratedNominal -> LegacyUnrestrictedTextDomain+              ConsumerNominal {} -> TypeIdTextDomain prefix,+          equalityContractVersion = case idDomainContractFor languageContract prefix of+            Just _ -> "keiro-dsl/nominal-equality/2"+            Nothing -> nominalEqualityContractVersion+        }+  EnumRepresentation constructors ->+    Just+      CheckedNominalEquality+        { equalityKeyRepresentation = NominalTextEqualityKey,+          equalityDomain = FiniteTextDomain (snd <$> constructors),+          equalityContractVersion = nominalEqualityContractVersion+        }+  ScalarRepresentation {} -> Nothing++-- | Stable, checked identity used by generated projection tags, fingerprints,+-- scaffold history, and explain output. It includes the existing binding+-- authority rather than introducing a second consumer equality function.+nominalEqualityIdentity :: ResolvedNominalType -> Maybe Text+nominalEqualityIdentity = nominalEqualityIdentityForService (effectiveLanguageContract LegacyUnversioned)++nominalEqualityIdentityForService :: EffectiveLanguageContract -> ResolvedNominalType -> Maybe Text+nominalEqualityIdentityForService languageContract nominal = do+  equality <- nominalEqualityContractForService languageContract nominal+  pure . T.intercalate "|" $+    [ "nominal-equality",+      "name=" <> resolvedNominalName nominal,+      "contract=" <> equalityContractVersion equality,+      "key=" <> renderEqualityKey (equalityKeyRepresentation equality),+      "domain=" <> renderEqualityDomain (equalityDomain equality),+      renderOwnership (resolvedNominalOwnership nominal)+    ]+  where+    renderEqualityKey NominalTextEqualityKey = "Text"+    renderEqualityDomain LegacyUnrestrictedTextDomain = "legacy-unrestricted-text"+    renderEqualityDomain (TypeIdTextDomain prefix) = "typeid-text:" <> prefix+    renderEqualityDomain (EnforcedTypeIdV7TextDomain prefix contractVersion) =+      "typeid-v7-text:" <> prefix <> ":" <> contractVersion+    renderEqualityDomain (FiniteTextDomain values) = "finite-text:" <> T.intercalate "," (NE.toList values)+    renderOwnership GeneratedNominal = "owner=generated"+    renderOwnership (ConsumerNominal binding) =+      T.intercalate+        ";"+        [ "owner=consumer",+          "canonical=" <> unCanonicalTypeId (consumerNominalCanonical binding),+          "binding=" <> unQualifiedValueName (consumerNominalBinding binding),+          "binding-version=" <> unBindingVersion (consumerNominalBindingVersion binding)+        ]++nominalEqualityIdentities :: Spec -> [Text]+nominalEqualityIdentities spec = nominalEqualityIdentitiesForService (CheckedService (effectiveLanguageContract LegacyUnversioned) spec)++nominalEqualityIdentitiesForService :: CheckedService -> [Text]+nominalEqualityIdentitiesForService service = case resolveNominalTypes spec of+  Left _ -> []+  Right registry ->+    [ identity+    | nominal <- Map.elems (nominalTypes registry),+      Just identity <- [nominalEqualityIdentityForService (checkedLanguageContract service) nominal]+    ]+  where+    spec = checkedSpec service++nominalEqualityContractVersion :: Text+nominalEqualityContractVersion = "keiro-dsl/nominal-equality/1"  data NominalTypeError   = NominalMissingIngredient !Name !Loc !Text

@@ -18,11 +18,12 @@ import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) import Data.Bifunctor (first) import Data.Char (isAlpha, isAlphaNum, isAscii, isDigit, isUpper)+import Data.List.NonEmpty qualified as NE import Data.Maybe (mapMaybe)+import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Read qualified as TR-import Data.Void (Void) import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion import Numeric.Natural (Natural)@@ -33,8 +34,17 @@ -- | A rendered, line-numbered parse error, ready to print to the user. type ParseError = Text -type P = Parsec Void Text+data ContextualParseFailure = ContextualParseFailure+  { contextualFailureCode :: !SourceLanguageErrorCode,+    contextualFailureLine :: !Int+  }+  deriving stock (Eq, Ord, Show) +instance ShowErrorComponent ContextualParseFailure where+  showErrorComponent contextual = T.unpack (sourceLanguageErrorCodeText (contextualFailureCode contextual))++type P = Parsec ContextualParseFailure 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.@@ -50,7 +60,6 @@ parseSource :: FilePath -> Text -> Either ParseFailure ParsedSource parseSource src input = do   sourceLanguage <- selectSourceLanguage src input-  ensureBodyFeatures src sourceLanguage input   definition <- case lookupLanguageDefinition (effectiveLanguageVersion sourceLanguage) of     Just value -> Right value     Nothing -> Left (unsupportedDiagnostic src sourceLanguage)@@ -58,62 +67,101 @@   pure ParsedSource {parsedSourceLanguage = sourceLanguage, parsedSpec = spec}   where     parseSelectedBody definition sourceLanguage =-      let parser = case definitionBodyParser definition of+      let version = definitionVersion definition+          laterPreambleCode = case sourceLanguage of+            LegacyUnversioned -> MisplacedLanguagePreamble+            DeclaredLanguage {} -> DuplicateLanguagePreamble+          parser = case definitionBodyParser definition of             LanguageBodyParserV1 ->               sc                 *> case sourceLanguage of-                  LegacyUnversioned -> pSpec False <* eof-                  DeclaredLanguage {} -> pDeclaredPreamble *> pSpec False <* eof+                  LegacyUnversioned -> pSpec version laterPreambleCode <* eof+                  DeclaredLanguage {} -> pDeclaredPreamble *> pSpec version laterPreambleCode <* eof             LanguageBodyParserV2 ->-              sc *> pDeclaredPreamble *> pSpec True <* eof+              sc *> pDeclaredPreamble *> pSpec version laterPreambleCode <* eof        in case runParser parser src input of-            Left bundle -> Left (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))+            Left bundle -> case firstContextualFailure bundle of+              Just contextual -> Left (SourceLanguageFailure (contextualDiagnostic src sourceLanguage contextual))+              Nothing -> Left (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))             Right spec -> Right spec --- | Consume a preamble already validated by 'selectSourceLanguage'.+firstContextualFailure :: ParseErrorBundle Text ContextualParseFailure -> Maybe ContextualParseFailure+firstContextualFailure bundle =+  case [ contextual+       | FancyError _ fancy <- NE.toList (bundleErrors bundle),+         ErrorCustom contextual <- Set.toList fancy+       ] of+    contextual : _ -> Just contextual+    [] -> Nothing++contextualDiagnostic :: FilePath -> SourceLanguage -> ContextualParseFailure -> SourceLanguageDiagnostic+contextualDiagnostic src sourceLanguage contextual =+  SourceLanguageDiagnostic+    { sourceLanguageErrorCode = code,+      sourceLanguageSource = src,+      sourceLanguageLoc = Loc (contextualFailureLine contextual),+      sourceLanguageToken = case code of+        LanguageFeatureRequiresVersion -> Just (languageVersionText effectiveVersion)+        _ -> Nothing,+      sourceLanguageDeclaredVersion = case code of+        LanguageFeatureRequiresVersion -> Just effectiveVersion+        _ -> Nothing,+      sourceLanguageSupportedVersions = supportedLanguageVersions+    }+  where+    code = contextualFailureCode contextual+    effectiveVersion = effectiveLanguageVersion sourceLanguage++contextualFailureAt :: Loc -> SourceLanguageErrorCode -> P a+contextualFailureAt (Loc line) code = customFailure ContextualParseFailure {contextualFailureCode = code, contextualFailureLine = line}++requireLanguageFeatureAt :: LanguageVersion -> LanguageFeature -> Loc -> P ()+requireLanguageFeatureAt version feature loc+  | languageSupportsFeature version feature = pure ()+  | otherwise = contextualFailureAt loc LanguageFeatureRequiresVersion++-- | Consume a preamble already validated by 'selectSourceLanguage'. This+-- parser is also reused at grammar boundaries to recognize only complete+-- preamble syntax, never a nested identifier whose spelling is @language@. pDeclaredPreamble :: P () pDeclaredPreamble = do   keyword "language"   keyword "keiro-dsl"-  _ <- lexeme (some digitChar)+  _ <- lexeme (some asciiDigit)   pure () -data SignificantLine = SignificantLine-  { significantLineNumber :: !Int,-    significantLineText :: !Text+-- | The source-selection pass inspects only the first grammar clause after+-- leading whitespace and comments. Body lines are left entirely to 'pSpec'.+data InitialLanguageClause = InitialLanguageClause+  { initialLanguageLine :: !Int,+    initialLanguageText :: !Text   }  selectSourceLanguage :: FilePath -> Text -> Either ParseFailure SourceLanguage-selectSourceLanguage src input =-  case significantLines input of-    [] -> Right LegacyUnversioned-    firstLine : rest ->-      case filter isLanguageLine (firstLine : rest) of-        [] -> Right LegacyUnversioned-        languageLine : laterLanguageLines-          | significantLineNumber languageLine /= significantLineNumber firstLine ->-              Left (sourceFailure MisplacedLanguagePreamble languageLine Nothing Nothing)-          | otherwise -> do-              version <- parsePreamble languageLine-              case laterLanguageLines of-                duplicateLine : _ ->-                  Left (sourceFailure DuplicateLanguagePreamble duplicateLine Nothing Nothing)-                [] -> case lookupLanguageDefinition version of-                  Nothing -> Left (sourceFailure UnsupportedLanguageVersion languageLine (Just (languageVersionText version)) (Just version))-                  Just _ -> Right (DeclaredLanguage version (Loc (significantLineNumber languageLine)))+selectSourceLanguage src input = do+  initialClause <- case runParser pInitialLanguageClause src input of+    Left bundle -> Left (BodyGrammarFailure (T.pack (errorBundlePretty bundle)))+    Right value -> Right value+  case initialClause of+    Nothing -> Right LegacyUnversioned+    Just languageClause -> do+      version <- parsePreamble languageClause+      case lookupLanguageDefinition version of+        Nothing -> Left (sourceFailure UnsupportedLanguageVersion languageClause (Just (languageVersionText version)) (Just version))+        Just _ -> Right (DeclaredLanguage version (Loc (initialLanguageLine languageClause)))   where     sourceFailure code line tokenText declared =       SourceLanguageFailure         SourceLanguageDiagnostic           { sourceLanguageErrorCode = code,             sourceLanguageSource = src,-            sourceLanguageLoc = Loc (significantLineNumber line),+            sourceLanguageLoc = Loc (initialLanguageLine line),             sourceLanguageToken = tokenText,             sourceLanguageDeclaredVersion = declared,             sourceLanguageSupportedVersions = supportedLanguageVersions           } -    parsePreamble line = case T.words (significantLineText line) of+    parsePreamble line = case T.words (initialLanguageText line) of       ["language", "keiro-dsl", tokenText]         | T.all (\c -> isAscii c && isDigit c) tokenText && not (T.null tokenText) ->             case TR.decimal tokenText :: Either String (Natural, Text) of@@ -126,6 +174,16 @@     invalid line tokenText =       Left (sourceFailure InvalidLanguageVersion line (Just tokenText) Nothing) +pInitialLanguageClause :: P (Maybe InitialLanguageClause)+pInitialLanguageClause = sc *> optional pLanguageClause+  where+    pLanguageClause = do+      position <- getSourcePos+      _ <- lookAhead (chunk "language" *> notFollowedBy (identChar <|> (char '-' *> identChar)))+      rawLine <- takeWhileP (Just "language preamble") (\c -> c /= '\n' && c /= '\r')+      let content = T.strip (T.takeWhile (/= '#') rawLine)+      pure InitialLanguageClause {initialLanguageLine = unPos (sourceLine position), initialLanguageText = content}+ unsupportedDiagnostic :: FilePath -> SourceLanguage -> ParseFailure unsupportedDiagnostic src sourceLanguage =   SourceLanguageFailure@@ -140,54 +198,6 @@         sourceLanguageSupportedVersions = supportedLanguageVersions       } -significantLines :: Text -> [SignificantLine]-significantLines =-  mapMaybe significant . zip [1 ..] . T.lines-  where-    significant (lineNumber, line) =-      let content = T.strip (T.takeWhile (/= '#') line)-       in if T.null content-            then Nothing-            else Just SignificantLine {significantLineNumber = lineNumber, significantLineText = content}--isLanguageLine :: SignificantLine -> Bool-isLanguageLine line = case T.words (significantLineText line) of-  "language" : _ -> True-  _ -> False---- | Reject syntax owned by a successor before the frozen predecessor grammar--- can turn it into generic parser noise.-ensureBodyFeatures :: FilePath -> SourceLanguage -> Text -> Either ParseFailure ()-ensureBodyFeatures src sourceLanguage input =-  case filter requiresSuccessorSyntax (significantLines input) of-    marker : _-      | languageVersionNumber (effectiveLanguageVersion sourceLanguage) < 2 ->-          Left-            ( SourceLanguageFailure-                SourceLanguageDiagnostic-                  { sourceLanguageErrorCode = LanguageFeatureRequiresVersion,-                    sourceLanguageSource = src,-                    sourceLanguageLoc = Loc (significantLineNumber marker),-                    sourceLanguageToken = Just (languageVersionText (effectiveLanguageVersion sourceLanguage)),-                    sourceLanguageDeclaredVersion = Just (effectiveLanguageVersion sourceLanguage),-                    sourceLanguageSupportedVersions = supportedLanguageVersions-                  }-            )-    _ -> Right ()-  where-    requiresSuccessorSyntax line =-      case wordsFound of-        "mapped" : "nominal" : _ -> True-        _ ->-          "using" `elem` wordsFound-            || "Integer" `elem` wordsFound-            || "implementation hole" `T.isInfixOf` content-            || "reg." `T.isInfixOf` content-            || "cmd." `T.isInfixOf` content-      where-        content = significantLineText line-        wordsFound = T.words content- -------------------------------------------------------------------------------- -- Lexer --------------------------------------------------------------------------------@@ -379,13 +389,20 @@   | TIMapped MappedDecl   | TINode Node -pSpec :: Bool -> P Spec-pSpec nominalSyntax = do+pContextualPreamble :: SourceLanguageErrorCode -> P a+pContextualPreamble code = do+  loc <- getLoc+  _ <- try pDeclaredPreamble+  contextualFailureAt loc code++pSpec :: LanguageVersion -> SourceLanguageErrorCode -> P Spec+pSpec version laterPreambleCode = do+  pContextualPreamble laterPreambleCode <|> pure ()   keyword "context"   ctx <- wireWord   mroot <- optional pModuleClause   mlayout <- optional pLayoutClause-  items <- many (pTopItem nominalSyntax)+  items <- many (pTopItem version laterPreambleCode)   pure     Spec       { specContext = ctx,@@ -425,13 +442,14 @@       cs <- many identChar       pure (T.pack (c : cs)) -pTopItem :: Bool -> P TopItem-pTopItem nominalSyntax =+pTopItem :: LanguageVersion -> SourceLanguageErrorCode -> P TopItem+pTopItem version laterPreambleCode =   choice-    ( [ TIId <$> pIdDecl nominalSyntax,-        TIEnum <$> pEnumDecl nominalSyntax,-        TIRule <$> pRuleDecl nominalSyntax,-        pMappedTopItem nominalSyntax+    ( [ pContextualPreamble laterPreambleCode,+        TIId <$> pIdDecl version,+        TIEnum <$> pEnumDecl version,+        TIRule <$> pRuleDecl version,+        pMappedTopItem version       ]         ++ [ TINode . NRouter <$> pRouter,              TINode . NProcess <$> pProcess,@@ -444,28 +462,28 @@              TINode . NReadModel <$> pReadModel,              TINode . NWorkflow <$> pWorkflow,              TINode . NOperation <$> pOperation,-             TINode . NAggregate <$> pAggregate nominalSyntax+             TINode . NAggregate <$> pAggregate version            ]     ) -pIdDecl :: Bool -> P IdDecl-pIdDecl nominalSyntax = do+pIdDecl :: LanguageVersion -> P IdDecl+pIdDecl version = do   loc <- getLoc   keyword "id"   name <- ident   _ <- symbol "prefix"   _ <- symbol "="   pfx <- wireWord-  binding <- if nominalSyntax then optional pUsingNominalBinding else pure Nothing+  binding <- optionalLanguageFeature version NominalBindingSyntax "using" pUsingNominalBinding   pure IdDecl {idName = name, idPrefix = pfx, idBinding = binding, idLoc = loc} -pEnumDecl :: Bool -> P EnumDecl-pEnumDecl nominalSyntax = do+pEnumDecl :: LanguageVersion -> P EnumDecl+pEnumDecl version = do   loc <- getLoc   keyword "enum"   name <- ident   ctors <- braces (many pEnumCtor)-  binding <- if nominalSyntax then optional pUsingNominalBinding else pure Nothing+  binding <- optionalLanguageFeature version NominalBindingSyntax "using" pUsingNominalBinding   pure EnumDecl {enumName = name, enumCtors = ctors, enumBinding = binding, enumLoc = loc}   where     pEnumCtor = do@@ -474,8 +492,8 @@       w <- wireWord       pure (c, w) -pRuleDecl :: Bool -> P RuleDecl-pRuleDecl scalarSyntax = do+pRuleDecl :: LanguageVersion -> P RuleDecl+pRuleDecl version = do   loc <- getLoc   keyword "rule"   name <- ident@@ -497,9 +515,19 @@     pCase = do       c <- ident       _ <- symbol "=>"-      e <- pExpr scalarSyntax+      e <- pExpr version       pure (c, e) +optionalLanguageFeature :: LanguageVersion -> LanguageFeature -> Text -> P a -> P (Maybe a)+optionalLanguageFeature version feature marker parser+  | languageSupportsFeature version feature = optional parser+  | otherwise = reject <|> pure Nothing+  where+    reject = do+      loc <- getLoc+      _ <- try (keyword marker)+      contextualFailureAt loc LanguageFeatureRequiresVersion+ -------------------------------------------------------------------------------- -- Consumer-owned mapped and nominal types --------------------------------------------------------------------------------@@ -517,19 +545,22 @@   | MCCodecVersion Text   | MCShape MappedShape -pMappedTopItem :: Bool -> P TopItem-pMappedTopItem nominalSyntax = do+pMappedTopItem :: LanguageVersion -> P TopItem+pMappedTopItem version = do   loc <- getLoc   keyword "mapped"   choice-    ( [TINominalScalar <$> pNominalScalarAfterMapped loc | nominalSyntax]-        ++ [ TIMapped <$> pMappedStructural loc,-             TIMapped <$> pMappedOpaque loc-           ]-    )+    [ if languageSupportsFeature version NominalBindingSyntax+        then TINominalScalar <$> pNominalScalarAfterMapped loc+        else do+          _ <- try (keyword "nominal")+          contextualFailureAt loc LanguageFeatureRequiresVersion,+      TIMapped <$> pMappedStructural version loc,+      TIMapped <$> pMappedOpaque loc+    ] -pMappedStructural :: Loc -> P MappedDecl-pMappedStructural loc = do+pMappedStructural :: LanguageVersion -> Loc -> P MappedDecl+pMappedStructural version loc = do   keyword "structural"   kind <-     choice@@ -538,7 +569,7 @@         MappedUnion <$ keyword "union"       ]   name <- ident-  clauses <- braces (many (pStructuralClause kind))+  clauses <- braces (many (pStructuralClause version kind))   hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses   binding <- oneClause "binding" (\case MCBinding value -> Just value; _ -> Nothing) clauses   bindingVersion <- oneClause "binding-version" (\case MCBindingVersion value -> Just value; _ -> Nothing) clauses@@ -632,8 +663,8 @@       MCInitial <$> pQuotedFact "initial"     ] -pStructuralClause :: MappedKind -> P MappedClause-pStructuralClause kind =+pStructuralClause :: LanguageVersion -> MappedKind -> P MappedClause+pStructuralClause version kind =   choice     [ MCHaskell <$> pHaskellSource,       MCBindingVersion <$> pQuotedFact "binding-version",@@ -641,7 +672,7 @@       MCCanonical <$> pQuotedFact "canonical-type",       MCFixtures <$> pQuotedFact "fixtures",       MCInitial <$> pQuotedFact "initial",-      MCShape <$> pMappedShape kind+      MCShape <$> pMappedShape version kind     ]  pOpaqueClause :: P MappedClause@@ -671,8 +702,8 @@ pQuotedFact :: Text -> P Text pQuotedFact factName = keyword factName *> symbol "=" *> stringLit -pMappedShape :: MappedKind -> P MappedShape-pMappedShape kind = do+pMappedShape :: LanguageVersion -> MappedKind -> P MappedShape+pMappedShape version kind = do   keyword "wire"   case kind of     MappedRecord -> do@@ -681,7 +712,7 @@       _ <- symbol "="       constructor <- ident       unknownFields <- pUnknownFieldsFact-      fields <- braces (many pWireField)+      fields <- braces (many (pWireField version))       pure (ShapeRecord constructor unknownFields fields)     MappedEnum -> do       keyword "string"@@ -695,7 +726,7 @@       _ <- symbol "="       contentsField <- stringLit       unknownFields <- pUnknownFieldsFact-      arms <- braces (many pWireArm)+      arms <- braces (many (pWireArm version))       pure (ShapeUnion (TaggedObject tagField contentsField unknownFields) arms)  pUnknownFieldsFact :: P UnknownFields@@ -704,14 +735,14 @@   _ <- symbol "="   choice [RejectUnknown <$ keyword "reject", IgnoreUnknown <$ keyword "ignore"] -pWireField :: P WireField-pWireField = do+pWireField :: LanguageVersion -> P WireField+pWireField version = do   loc <- getLoc   haskellName <- ident   keyword "as"   wireKey <- stringLit   _ <- symbol ":"-  fieldType <- pMappedTypeExpr+  fieldType <- pMappedTypeExpr version   presence <- choice [PRequired <$ keyword "required", POptional <$ keyword "optional"]   onMissing <- optional (keyword "on-missing" *> symbol "=" *> pOnMissing)   pure@@ -732,24 +763,24 @@   wireTag <- stringLit   pure WireEnum {weCtor = constructor, weTag = wireTag, weLoc = loc} -pWireArm :: P WireArm-pWireArm = do+pWireArm :: LanguageVersion -> P WireArm+pWireArm version = do   loc <- getLoc   constructor <- ident   keyword "as"   wireTag <- stringLit-  payload <- optional (symbol ":" *> pMappedTypeExpr)+  payload <- optional (symbol ":" *> pMappedTypeExpr version)   pure WireArm {waCtor = constructor, waTag = wireTag, waPayload = payload, waLoc = loc} -pMappedTypeExpr :: P TypeExpr-pMappedTypeExpr =+pMappedTypeExpr :: LanguageVersion -> P TypeExpr+pMappedTypeExpr version =   choice     [ TOptional <$> (keyword "Optional" *> pTypeArgument),       TList <$> (keyword "List" *> pTypeArgument),       TMap <$> (keyword "Map" *> pTypeArgument),       TText <$ keyword "Text",       TInt <$ keyword "Int",-      TInteger <$ keyword "Integer",+      TInteger <$ languageFeatureKeyword version IntegerScalarSyntax "Integer",       TBool <$ keyword "Bool",       TNatural <$ keyword "Natural",       TTime <$ (keyword "Time" <|> keyword "UTCTime"),@@ -757,12 +788,12 @@       TRef <$> ident     ]   where-    pTypeArgument = parens pMappedTypeExpr <|> pTypeAtom+    pTypeArgument = parens (pMappedTypeExpr version) <|> pTypeAtom     pTypeAtom =       choice         [ TText <$ keyword "Text",           TInt <$ keyword "Int",-          TInteger <$ keyword "Integer",+          TInteger <$ languageFeatureKeyword version IntegerScalarSyntax "Integer",           TBool <$ keyword "Bool",           TNatural <$ keyword "Natural",           TTime <$ (keyword "Time" <|> keyword "UTCTime"),@@ -770,6 +801,12 @@           TRef <$> ident         ] +languageFeatureKeyword :: LanguageVersion -> LanguageFeature -> Text -> P ()+languageFeatureKeyword version feature spelling = do+  loc <- getLoc+  keyword spelling+  requireLanguageFeatureAt version feature loc+ pOnMissing :: P OnMissing pOnMissing =   choice@@ -810,14 +847,14 @@   | BISnapshot SnapshotSpec   | BITransition Transition -pAggregate :: Bool -> P Aggregate-pAggregate scalarSyntax = do+pAggregate :: LanguageVersion -> P Aggregate+pAggregate version = do   loc <- getLoc   keyword "aggregate"   name <- ident-  regs <- pRegsBlock+  regs <- pRegsBlock version   states <- pStatesLine-  positionedItems <- many ((,) <$> getOffset <*> pBodyItem scalarSyntax)+  positionedItems <- many ((,) <$> getOffset <*> pBodyItem version)   let items = map snd positionedItems       wireOffsets = [offset | (offset, BIWire _) <- positionedItems]       projectionOffsets = [offset | (offset, BIProjection _) <- positionedItems]@@ -850,16 +887,16 @@   where     listToMaybe xs = case xs of (x : _) -> Just x; [] -> Nothing -pRegsBlock :: P [RegDecl]-pRegsBlock = do+pRegsBlock :: LanguageVersion -> P [RegDecl]+pRegsBlock version = do   keyword "regs"-  many pRegDecl+  many (pRegDecl version) -pRegDecl :: P RegDecl-pRegDecl = do+pRegDecl :: LanguageVersion -> P RegDecl+pRegDecl version = do   loc <- getLoc   name <- ident-  ty <- pMappedTypeExpr+  ty <- pMappedTypeExpr version   _ <- symbol "="   initial <- (RegInitText <$> stringLit) <|> (RegInitBare <$> (ident <|> signedDecimalText))   pure RegDecl {regName = name, regType = ty, regInitial = initial, regLoc = loc}@@ -886,15 +923,15 @@       notFollowedBy (symbol "--")       pure StateDecl {stName = n, stTerminal = term, stLoc = loc} -pBodyItem :: Bool -> P BodyItem-pBodyItem scalarSyntax =+pBodyItem :: LanguageVersion -> P BodyItem+pBodyItem version =   choice-    [ BICommand <$> pCommand,-      BIEvent <$> pEvent,+    [ BICommand <$> pCommand version,+      BIEvent <$> pEvent version,       BIWire <$> pWire,       BIProjection <$> pProjection,       BISnapshot <$> pSnapshot,-      BITransition <$> pTransition scalarSyntax+      BITransition <$> pTransition version     ]  pSnapshot :: P SnapshotSpec@@ -913,19 +950,19 @@   hash <- stringLit   pure SnapshotSpec {snapPolicy = policy, snapCodecVersion = version, snapShapeHash = hash, snapLoc = loc} -pCommand :: P Command-pCommand = do+pCommand :: LanguageVersion -> P Command+pCommand version = do   loc <- getLoc   keyword "command"   name <- ident-  fs <- braces (many pAggregateField)+  fs <- braces (many (pAggregateField version))   pure Command {cmdName = name, cmdFields = fs, cmdLoc = loc} -pAggregateField :: P AggregateField-pAggregateField = do+pAggregateField :: LanguageVersion -> P AggregateField+pAggregateField version = do   loc <- getLoc   n <- ident-  mty <- optional (symbol ":" *> pMappedTypeExpr)+  mty <- optional (symbol ":" *> pMappedTypeExpr version)   pure AggregateField {aggregateFieldName = n, aggregateFieldType = mty, aggregateFieldLoc = loc}  pField :: P Field@@ -934,8 +971,8 @@   mty <- optional (symbol ":" *> ident)   pure Field {fieldName = n, fieldType = mty} -pEvent :: P Event-pEvent = do+pEvent :: LanguageVersion -> P Event+pEvent version = do   loc <- getLoc   (retiring, deprecated) <-     option@@ -951,7 +988,7 @@   body <-     choice       [ EventFromCommand <$> (symbol "=" *> keyword "fields" *> parens ident),-        EventFields <$> braces (many pAggregateField)+        EventFields <$> braces (many (pAggregateField version))       ]   up <- optional pUpcast   pure@@ -1921,8 +1958,8 @@   | CGoto Name   | CImplementationHole -pTransition :: Bool -> P Transition-pTransition scalarSyntax = do+pTransition :: LanguageVersion -> P Transition+pTransition version = do   startOffset <- getOffset   loc <- getLoc   -- Plan 143: a @replay-only@ prefix marks the transition as serving@@ -1932,7 +1969,7 @@   _ <- symbol "--"   cmd <- ident   _ <- symbol "-->"-  positionedClauses <- many ((,) <$> getOffset <*> (pClause scalarSyntax <* optional (symbol ";")))+  positionedClauses <- many ((,) <$> getOffset <*> (pClause version <* optional (symbol ";")))   let clauses = map snd positionedClauses       gotos = [(offset, target) | (offset, CGoto target) <- positionedClauses]       holeOffsets = [offset | (offset, CImplementationHole) <- positionedClauses]@@ -1954,7 +1991,7 @@         tCommand = cmd,         tImplementation = case holeOffsets of           _ : _ -> HoleImplementation-          [] | scalarSyntax -> GeneratedImplementation+          [] | languageSupportsFeature version TypedAggregateExpressionSyntax -> GeneratedImplementation           [] -> LegacyHoleImplementation,         tGuard = case guards of [] -> Nothing; es -> Just (foldr1 EAnd es),         tWrites = [(r, e) | CWrite r e <- clauses],@@ -1964,38 +2001,51 @@         tLoc = loc       } -pClause :: Bool -> P Clause-pClause scalarSyntax =+pClause :: LanguageVersion -> P Clause+pClause version =   choice-    ( [CImplementationHole <$ (keyword "implementation" *> keyword "hole") | scalarSyntax]-        ++ [ CGuard <$> (keyword "guard" *> pExpr scalarSyntax),-             (\r e -> CWrite r e) <$> (keyword "write" *> ident) <*> (symbol ":=" *> pExpr scalarSyntax),-             try $ do-               keyword "emit"-               eventName <- ident-               notFollowedBy (symbol "{")-               pure (CEmit eventName),-             CGoto <$> (keyword "goto" *> ident)-           ]-    )+    [ do+        loc <- getLoc+        keyword "implementation"+        keyword "hole"+        requireLanguageFeatureAt version ExplicitTransitionImplementationSyntax loc+        pure CImplementationHole,+      CGuard <$> (keyword "guard" *> pExpr version),+      (\r e -> CWrite r e) <$> (keyword "write" *> ident) <*> (symbol ":=" *> pExpr version),+      try $ do+        keyword "emit"+        eventName <- ident+        notFollowedBy (symbol "{")+        pure (CEmit eventName),+      CGoto <$> (keyword "goto" *> ident)+    ]  -------------------------------------------------------------------------------- -- Expr sublanguage -------------------------------------------------------------------------------- -pExpr :: Bool -> P Expr-pExpr scalarSyntax-  | scalarSyntax = makeExprParser pScalarTerm scalarOperatorTable-  | otherwise = makeExprParser pLegacyTerm legacyOperatorTable+pExpr :: LanguageVersion -> P Expr+pExpr version+  | languageSupportsFeature version TypedAggregateExpressionSyntax = makeExprParser (pScalarTerm version) scalarOperatorTable+  | otherwise = makeExprParser (pLegacyTerm version) legacyOperatorTable -pLegacyTerm :: P Expr-pLegacyTerm =+pLegacyTerm :: LanguageVersion -> P Expr+pLegacyTerm version =   choice-    [ parens (pExpr False),+    [ parens (pExpr version),+      pUnsupportedScalarTerm version,       EAtom . ABool <$> (True <$ keyword "true" <|> False <$ keyword "false"),       EAtom . AName <$> ident     ] +pUnsupportedScalarTerm :: LanguageVersion -> P Expr+pUnsupportedScalarTerm version = do+  loc <- getLoc+  _ <-+    try ((keyword "reg" <|> keyword "cmd") *> symbol ".")+  requireLanguageFeatureAt version TypedAggregateExpressionSyntax loc+  fail "unreachable supported scalar term in predecessor grammar"+ -- | Highest precedence first: relational comparisons bind tighter than @&&@, -- which binds tighter than @||@. legacyOperatorTable :: [[Operator P Expr]]@@ -2018,10 +2068,10 @@       operator <- lexeme (oneOf ['+', '-', '*', '/'])       failAt offset ("aggregate arithmetic operator '" <> [operator] <> "' is unsupported; compare or copy whole values instead") -pScalarTerm :: P Expr-pScalarTerm =+pScalarTerm :: LanguageVersion -> P Expr+pScalarTerm version =   choice-    [ parens (pExpr True),+    [ parens (pExpr version),       collectionTermUnsupported,       try pIdLiteral,       do

@@ -12,6 +12,7 @@ module Keiro.Dsl.ReplayImpact   ( AggregateImpact (..),     ReplayImpact (..),+    replayImpactServices,     replayImpact,     renderReplayImpact,   )@@ -27,10 +28,11 @@ import Data.Text (Text) import Data.Text qualified as Text import Keiro.Dsl.AggregateType-import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface)+import Keiro.Dsl.FoldFingerprint (aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType import Keiro.Dsl.PrettyPrint (renderTransition)+import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService) import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), MappedKey (..), QualifiedValueName (..), TypeGraph (..), resolveTypeGraph, wireFingerprint)  -- | The smallest conservative audit input for one aggregate.@@ -61,22 +63,31 @@         "aggregates" .= aggregates       ] --- | Compute replay impact for every aggregate that existed in the old spec.-replayImpact :: Spec -> Spec -> ReplayImpact-replayImpact oldSpec newSpec =+-- | Compute replay impact for every aggregate that existed under the old+-- effective semantic contract.+replayImpactServices :: CheckedService -> CheckedService -> ReplayImpact+replayImpactServices oldService newService =   case Map.filter hasImpact impacts of     filtered       | Map.null filtered -> ReplayNeutral       | otherwise -> ReplayAffected filtered   where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService     oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes oldSpec]     newAggregates = Map.fromList [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes newSpec]     impacts =       Map.fromList-        [ (name, maybe (removedAggregateImpact oldAggregate) (matchedAggregateImpact oldSpec newSpec oldAggregate) (Map.lookup name newAggregates))+        [ (name, maybe (removedAggregateImpact oldAggregate) (matchedAggregateImpact oldService newService oldAggregate) (Map.lookup name newAggregates))         | (name, oldAggregate) <- oldAggregates         ] +-- | Compatibility wrapper for graph-only callers. It explicitly compares both+-- sides under legacy/version-1 runtime semantics.+replayImpact :: Spec -> Spec -> ReplayImpact+replayImpact oldSpec newSpec =+  replayImpactServices (legacyCheckedService oldSpec) (legacyCheckedService newSpec)+ hasImpact :: AggregateImpact -> Bool hasImpact impact =   not (Set.null (eventTypes impact))@@ -89,8 +100,8 @@       includeSnapshotStreams = True     } -matchedAggregateImpact :: Spec -> Spec -> Aggregate -> Aggregate -> AggregateImpact-matchedAggregateImpact oldSpec newSpec oldAggregate newAggregate =+matchedAggregateImpact :: CheckedService -> CheckedService -> Aggregate -> Aggregate -> AggregateImpact+matchedAggregateImpact oldService newService oldAggregate newAggregate =   AggregateImpact     { eventTypes =         decodeAffected@@ -99,6 +110,8 @@       includeSnapshotStreams = transitionFoldChanged || nonTransitionFoldChanged || mappedRegisterChanged     }   where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService     oldEventTypes = Set.fromList (evName <$> aggEvents oldAggregate)     decodeAffected = decodeSurfaceAffected oldSpec newSpec oldAggregate newAggregate     mappedRegisterChanged =@@ -107,9 +120,9 @@     (transitionAffected, transitionFoldChanged) =       changedTransitionEvents (aggTransitions oldAggregate) (aggTransitions newAggregate)     nonTransitionFoldChanged =-      aggregateFoldSurface oldSpec oldAggregate-        /= aggregateFoldSurface-          newSpec+      aggregateFoldSurfaceForService oldService oldAggregate+        /= aggregateFoldSurfaceForService+          newService           newAggregate             { aggTransitions = aggTransitions oldAggregate             }

@@ -24,4038 +24,5242 @@     defaultContext,     genPrefixFor,     holePrefixFor,-    scaffoldReplayAudit,-    scaffoldStructural,-    scaffoldStructuralOwners,-    codecComparisonModule,-    codecComparisonBanner,-    bindingSkeletonModules,-    bindingSkeletonOwners,-    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 (..),-    ResolvedRegister (..),-    ResolvedCtor (..),-    StructuralProjection (..),-    resolveAgg,-    projectionSpecs,-    resolveProjectionModules,-    nominalProjectionModule,-    codecMappedDeclarations,-    FieldCat (..),-    fieldCat,-    vertexCtor,-    initialVertex,-    firstEnumCtor,-    lowerFirst,-    pascal,-    pascalFromKebab,-    generatedBanner,-  )-where--import Data.Char (isAlpha, isAlphaNum, isUpper, ord, toLower, toUpper)-import Data.List (find, groupBy, isSuffixOf, nub, sort, sortOn)-import Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe, mapMaybe)-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Keiro.Dsl.AggregateType-import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..))-import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations)-import Keiro.Dsl.Expression-import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint)-import Keiro.Dsl.Grammar-import Keiro.Dsl.NominalType-import Keiro.Dsl.PrettyPrint (renderExpr)-import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)-import Keiro.Dsl.TypeGraph-import Keiro.Dsl.Validate (sagaCategoryError)-import Numeric (showHex)-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,-    -- | @""@ means no namespace prefix (the historical default).-    moduleRoot :: !Text,-    -- | 'GeneratedPrefix' is the historical default.-    placement :: !Placement-  }-  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 validate, step, and replay filled holes register by register.-      restrictedImports =-        [ ( "Keiki.Core",-            [ "RegFile",-              "HsPred",-              "FieldProjection",-              "FieldWitness",-              "fieldWitness",-              "fieldWitnessAgrees",-              "applyEventsEither",-              "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,-    not (authoritativeScalarModule (modulePath m)),-    (n, line) <- zip [1 ..] (T.lines (moduleText m)),-    breach <- lineBreaches line-  ]---- Version-2 aggregate expression and transducer modules are the narrow,--- intentional exception to the generated symbolic-operator firewall: they--- are precisely the generated authority that constructs Keiki terms. Every--- other generated module remains subject to the original firewall.-authoritativeScalarModule :: FilePath -> Bool-authoritativeScalarModule path =-  any (`isSuffixOf` path) ["/Expressions.hs", "/Transducer.hs"]--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,-    aSpec :: !Spec,-    aAggregate :: !Aggregate,-    aCtxPascal :: !Text,-    aName :: !Text,-    aLoc :: !Loc,-    aVertexType :: !Text,-    aIds :: ![IdDecl],-    aEnums :: ![EnumDecl],-    aRegs :: ![ResolvedRegister],-    aStates :: ![StateDecl],-    aCommands :: ![ResolvedCtor],-    aEvents :: ![ResolvedCtor],-    aTransitions :: ![Transition],-    aWire :: !WireSpec,-    aProjection :: !(Maybe ProjectionSpec),-    aSnapshot :: !(Maybe SnapshotSpec),-    aFoldFingerprint :: !Text,-    aReadModels :: ![ReadModelNode],-    aTypeGraph :: !(Maybe TypeGraph),-    aSymbols :: !AggregateSymbols,-    -- | e.g. @Generated.HospitalCapacity.Reservation@-    aGenPrefix :: !Text,-    -- | e.g. @HospitalCapacity.Reservation@-    aHolePrefix :: !Text-  }--data ResolvedRegister = ResolvedRegister-  { rrName :: !Name,-    rrType :: !ResolvedAggregateType,-    rrInitial :: !ResolvedRegisterInitial,-    rrLoc :: !Loc-  }-  deriving stock (Eq, Show)---- | A command or event constructor with its fully-resolved field types.-data ResolvedCtor = ResolvedCtor-  { rcName :: !Text,-    -- | (field name, canonical aggregate type)-    rcFields :: ![(Text, ResolvedAggregateType)],-    -- | EP-2: schema version (1 for commands and unversioned events).-    rcVersion :: !Int,-    -- | EP-2: the source version this event migrates from (the upcaster step).-    rcUpcastFrom :: !(Maybe Int)-  }--defaultWire :: WireSpec-defaultWire = WireSpec {wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1}--resolveAgg :: Context -> Spec -> Aggregate -> Agg-resolveAgg ctx spec agg =-  Agg-    { aContext = ctx,-      aSpec = spec,-      aAggregate = agg,-      aCtxPascal = ctxPascal,-      aName = nm,-      aLoc = aggLoc agg,-      aVertexType = vertexType,-      aIds = specIds spec,-      aEnums = specEnums spec,-      aRegs = map resolveRegister (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,-      aFoldFingerprint = aggregateFoldFingerprint spec agg,-      aReadModels = [readModel | NReadModel readModel <- specNodes spec],-      aTypeGraph = either (const Nothing) Just (resolveTypeGraph spec),-      aSymbols = symbols,-      aGenPrefix = genPrefixFor ctx nm,-      aHolePrefix = holePrefixFor ctx nm-    }-  where-    nm = aggName agg-    symbols = aggregateSymbols spec-    ctxPascal = pascalFromKebab (contextName ctx)-    vertexType = nm <> "Vertex"-    commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg]-    resolveCommand c = (mkCtor CommandFieldUse (cmdName c) (cmdFields c)) {rcVersion = 1, rcUpcastFrom = Nothing}-    resolveEvent e =-      (mkCtor EventFieldUse (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 useSite cn fs =-      ResolvedCtor-        { rcName = cn,-          rcFields = map (\field -> (aggregateFieldName field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,-          rcVersion = 1,-          rcUpcastFrom = Nothing-        }-    resolveRegister register =-      let resolvedType = orDie (resolveAggregateType symbols (regLoc register) RegisterUse (regType register))-          resolvedInitial = orDie (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register))-       in ResolvedRegister-            { rrName = regName register,-              rrType = resolvedType,-              rrInitial = resolvedInitial,-              rrLoc = regLoc register-            }-    orDie = either (error . ("validated aggregate resolution failed: " <>) . show) id------------------------------------------------------------------------------------- Entry point------------------------------------------------------------------------------------- | Emit the context-level private structural stratum. Shape modules contain--- only generated wire representations. The projection facade contains only--- schema-derived Keiki field witnesses; neither layer owns consumer behavior.-scaffoldStructural :: Context -> Spec -> [ScaffoldModule]-scaffoldStructural ctx spec = map fst (scaffoldStructuralOwners ctx spec)---- | 'scaffoldStructural' paired with the mapped declarations each module was--- emitted for. A shape module names exactly one declaration; a binding skeleton--- names every declaration whose obligations it carries (several declarations may--- share one leaf binding module); the projection facade names __none__, because it--- is emitted once for the whole context from the complete resolved graph.------ This is the attribution seam whole-workspace scaffolding needs: a workspace--- emits from one merged spec, and this list says which declaration — and therefore--- which member file — produced each structural module, without parsing the--- human-readable 'origin' string.-scaffoldStructuralOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]-scaffoldStructuralOwners ctx spec = case resolveTypeGraph spec of-  Left _ -> []-  Right graph ->-    [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural]-      <> projectionModules-      <> nominalRepresentationOwners ctx spec-      <> nominalProjectionOwners ctx spec-      <> bindingSkeletonOwners ctx spec graph-    where-      structural =-        [ (declaration, shape)-        | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)-        ]-      projectionModules =-        [ ( ScaffoldModule-              { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"),-                moduleText = emitStructuralProjections ctx graph,-                kind = Generated,-                origin = "context " <> specContext spec <> " mapped structural facade"-              },-            []-          )-        | not (null (projectionSpecs graph))-        ]---- | Plan one opt-in, non-production historical-codec comparison module.------ The module is intentionally absent from 'scaffoldStructural' and therefore--- from production manifests and scaffold records. It must be requested by name--- and is compiled only by consumer-owned test/tool components.-codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule-codecComparisonModule ctx spec requestedName = do-  graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec)-  (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of-    Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName)-    Just (ResolvedOpaque _) ->-      Left-        ( "codec comparison target "-            <> requestedName-            <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim"-        )-    Just (ResolvedStructural declaration shape) -> Right (declaration, shape)-  owner <- case sortOn aggName (comparisonOwners declaration) of-    [] ->-      Left-        ( "codec comparison target "-            <> requestedName-            <> " is not reachable from a persisted private event payload"-        )-    aggregate : _ -> Right aggregate-  let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName-  pure-    ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-        moduleText = emitCodecComparison ctx moduleName graph declaration shape owner,-        kind = Generated,-        origin = "non-production codec comparison " <> requestedName-      }-  where-    comparisonOwners declaration =-      [ aggregate-      | NAggregate aggregate <- specNodes spec,-        let resolved = resolveAgg ctx spec aggregate,-        any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved)-      ]-      where-        mappedName (ResolvedStructural structural _) = sdName structural-        mappedName (ResolvedOpaque opaque) = odName opaque--codecComparisonBanner :: Text-codecComparisonBanner =-  "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit."--emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text-emitCodecComparison ctx moduleName graph declaration shape owner =-  nl-    [ "",-      codecComparisonBanner,-      "-- This module compares historical and generated codecs in consumer-owned tests only.",-      "-- It is never a runtime fallback and never changes the generated codec's authority.",-      "module " <> moduleName <> " (compareWithHistorical) where",-      "",-      "import Control.Monad (filterM)",-      "import Data.Aeson (Value)",-      "import Data.Aeson qualified as Aeson",-      "import Data.List (sort)",-      "import Data.List.NonEmpty qualified as NonEmpty",-      "import Data.Text (Text)",-      "import Data.Text qualified",-      "import " <> codecModule <> " qualified as GeneratedCodec",-      "import Keiro.Codec.Structural (FixtureCases (..))",-      "import Keiro.Dsl.CodecCompare",-      "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))",-      "import System.Directory (doesFileExist, listDirectory)",-      "import System.FilePath (takeExtension, (</>))",-      "",-      "import " <> fixtureModule <> " qualified as ConsumerFixtures",-      "import " <> hsModule (sdHaskell declaration) <> " qualified as ConsumerDomain",-      "",-      "compareWithHistorical :: HistoricalCodec " <> domainType <> " -> FilePath -> IO CompareReport",-      "compareWithHistorical historicalCodec goldenDirectory = do",-      "  names <- sort . filter ((== \".json\") . takeExtension) <$> listDirectory goldenDirectory",-      "  files <- filterM doesFileExist [goldenDirectory </> name | name <- names]",-      "  loaded <- traverse (loadGolden historicalCodec) files",-      "  let inputIssues = [issue | Left issue <- loaded]",-      "      entries = [entry | Right entry <- loaded]",-      "      typedCases = NonEmpty.toList (fixtureCases ConsumerFixtures." <> fixtureSymbol <> ")",-      "      encodeObservations =",-      "        [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encode" <> name <> "Mapped value)",-      "        | (label, value) <- typedCases",-      "        ]",-      "      decodeObservations = [observation | (observation, _) <- entries]",-      "      typedObserved =",-      "        concat",-      "          [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encode" <> name <> "Mapped value)",-      "          | (_, value) <- typedCases",-      "          ]",-      "      historicalObserved =",-      "        concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values]",-      "      declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema",-      "      provenance =",-      "        CompareProvenance",-      "          { cpHistoricalCodecIdentity = hcIdentity historicalCodec",-      "          , cpHistoricalCodecVersion = hcVersion historicalCodec",-      "          , cpCanonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId (sdCanonical declaration)),-      "          , cpBindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName (sdBinding declaration)),-      "          , cpBindingVersion = BindingVersion " <> tshow (unBindingVersion (sdBindingVersion declaration)),-      "          , cpWireFingerprint = " <> tshow (wireFingerprint graph name),-      "          }",-      "  pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved))",-      "",-      "loadGolden :: HistoricalCodec " <> domainType <> " -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value]))",-      "loadGolden historicalCodec path = do",-      "  decoded <- Aeson.eitherDecodeFileStrict path",-      "  pure $ case decoded of",-      "    Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason))",-      "    Right inputValue ->",-      "      let historicalDecoded = hcDecode historicalCodec inputValue",-      "          historicalOutcome = normalizeDecode historicalDecoded",-      "          generatedOutcome = normalizeDecode (GeneratedCodec.decode" <> name <> "Mapped inputValue)",-      "          observation = DecodeObservation path inputValue historicalOutcome generatedOutcome",-      "          coveredValues = case historicalDecoded of",-      "            Right value -> [inputValue, GeneratedCodec.encode" <> name <> "Mapped value]",-      "            Left _ -> []",-      "       in Right (observation, coveredValues)",-      "",-      "normalizeDecode :: Either Text " <> domainType <> " -> DecodeOutcome",-      "normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encode" <> name <> "Mapped)",-      "",-      "fromString :: String -> Text",-      "fromString = Data.Text.pack",-      "",-      "branchSchema :: BranchSchema",-      "branchSchema = " <> renderBranchSchema (branchSchemaFor graph (ResolvedStructural declaration shape))-    ]-  where-    name = sdName declaration-    domainType = "ConsumerDomain." <> hsType (sdHaskell declaration)-    codecModule = genPrefixFor ctx (aggName owner) <> ".Codec"-    fixtureModule = qualifiedModule (sdFixtures declaration)-    fixtureSymbol = lastSegment (unQualifiedValueName (sdFixtures declaration))--branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema-branchSchemaFor graph =-  foldMappedDecl-    MappedDeclAlgebra-      { onStructuralDecl = \_ shape ->-          foldMappedShape-            MappedShapeAlgebra-              { onRecord = \_ _ fields ->-                  BranchRecord-                    [ BranchField-                        (rwfKey field)-                        (rwfPresence field == POptional)-                        (branchExpr graph (rwfType field))-                    | field <- fields-                    ],-                onEnum = const BranchScalar,-                onUnion = \encoding arms ->-                  BranchUnion-                    (ueTagField encoding)-                    (ueContentsField encoding)-                    [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms]-              }-            shape,-        onOpaqueDecl = const BranchScalar-      }--branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema-branchExpr graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = BranchScalar,-        onInt = BranchScalar,-        onInteger = BranchScalar,-        onBool = BranchScalar,-        onNatural = BranchScalar,-        onTime = BranchScalar,-        onJson = BranchScalar,-        onOptional = BranchOptional,-        onList = BranchList,-        onMap = BranchMap,-        onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph))-      }--renderBranchSchema :: BranchSchema -> Text-renderBranchSchema schema = case schema of-  BranchScalar -> "BranchScalar"-  BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")"-  BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")"-  BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")"-  BranchRecord fields ->-    "BranchRecord ["-      <> T.intercalate-        ", "-        [ "BranchField "-            <> tshow (bfWireKey field)-            <> " "-            <> (if bfPresenceOptional field then "True" else "False")-            <> " ("-            <> renderBranchSchema (bfSchema field)-            <> ")"-        | field <- fields-        ]-      <> "]"-  BranchUnion tagField contentsField arms ->-    "BranchUnion "-      <> tshow tagField-      <> " "-      <> tshow contentsField-      <> " ["-      <> T.intercalate-        ", "-        [ "BranchArm "-            <> tshow (baWireTag arm)-            <> " "-            <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm)-        | arm <- arms-        ]-      <> "]"---- | Emit one create-once consumer module per distinct qualified obligation--- owner. Multiple mapped declarations may intentionally share a leaf binding--- module, so grouping happens by module rather than by declaration.-bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule]-bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph)---- | 'bindingSkeletonModules' paired with the mapped declarations whose--- obligations each skeleton carries, in first-appearance order. A skeleton shared--- by declarations from different member files therefore names all of them, which--- is what lets whole-workspace scaffolding treat it as context-level rather than--- attributing it to an arbitrary member.-bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])]-bindingSkeletonOwners ctx spec graph = case bindingObligations spec of-  Left _ -> []-  Right obligations ->-    [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries))-    | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations])-    ]--emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule-emitBindingSkeleton ctx spec graph owner obligations =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"),-      moduleText =-        nl $-          [ "{-# LANGUAGE DataKinds #-}",-            "{-# LANGUAGE LambdaCase #-}",-            "",-            "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once",-            "-- and never overwrites it. Fill each HOLE and run the generated harness.",-            "module " <> owner <> " ("-          ]-            <> exportLines-            <> [") where", ""]-            <> map ("import " <>) imports-            <> [""]-            <> intercalateBlank (map renderObligation obligations),-      kind = HoleStub,-      origin = "consumer binding skeleton " <> owner-    }-  where-    exportLines =-      [ (if index == (0 :: Int) then "    " else "  , ") <> obligationSymbol obligation-      | (index, obligation) <- zip [0 ..] obligations-      ]-    imports =-      sort . nub $-        [ hsModule (sdHaskell declaration) <> " qualified"-        | obligation <- obligations,-          Just (declaration, _) <- [structuralFor obligation]-        ]-          <> [ structuralShapeModule ctx (sdName declaration) <> " qualified"-             | obligation <- obligations,-               obligationKind obligation == BindingValue,-               Just (declaration, _) <- [structuralFor obligation]-             ]-          <> [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))"-             | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations-             ]-          <> [ hsModule (consumerNominalHaskell binding) <> " qualified"-             | obligation <- obligations,-               Just (_, binding) <- [nominalFor obligation]-             ]-          <> [ nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified"-             | obligation <- obligations,-               obligationKind obligation == BindingValue,-               Just (nominal, _) <- [nominalFor obligation],-               EnumRepresentation {} <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Keiro.Codec.Nominal (NominalBinding (..), NominalFixtureCases)"-             | any ((/= "structural") . obligationCategory) obligations-             ]-          <> [ "Data.KindID (KindID)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               IdRepresentation {} <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Data.Text (Text)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               ScalarRepresentation NominalText <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Data.Time (UTCTime)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               ScalarRepresentation NominalTime <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Numeric.Natural (Natural)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               ScalarRepresentation NominalNatural <- [resolvedNominalRepresentation nominal]-             ]-    renderObligation obligation = case structuralFor obligation of-      Nothing -> case nominalFor obligation of-        Just (nominal, _) -> renderNominalObligation nominal obligation-        Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"]-      Just (declaration, shape) -> case obligationKind obligation of-        BindingValue -> renderBinding ctx declaration shape obligation-        FixtureValue ->-          [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration,-            obligationSignature obligation,-            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures")-          ]-        InitialValue ->-          [ "-- HOLE: provide the initial register value for " <> sdName declaration,-            obligationSignature obligation,-            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " initial value")-          ]-    structuralFor obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of-      Just (ResolvedStructural declaration shape) -> Just (declaration, shape)-      _ -> Nothing-    nominalFor obligation = do-      registry <- either (const Nothing) Just (resolveNominalTypes spec)-      nominal <- lookupNominalType (obligationMappedName obligation) registry-      binding <- case resolvedNominalOwnership nominal of-        ConsumerNominal value -> Just value-        GeneratedNominal -> Nothing-      pure (nominal, binding)-    renderNominalObligation nominal obligation = case obligationKind obligation of-      BindingValue ->-        [ "-- HOLE: complete both total directions; the generated codec remains wire authority.",-          obligationSignature obligation,-          obligationSymbol obligation <> " =",-          "  NominalBinding",-          "    { nominalToRepresentation = \\_domainValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalToRepresentation"),-          "    , nominalFromRepresentation = \\_representationValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalFromRepresentation"),-          "    }"-        ]-      FixtureValue ->-        [ "-- HOLE: provide deterministic labelled expected-wire fixtures for " <> resolvedNominalName nominal,-          obligationSignature obligation,-          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures")-        ]-      InitialValue ->-        [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal,-          obligationSignature obligation,-          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value")-        ]-    intercalateBlank [] = []-    intercalateBlank (section : rest) = section <> concatMap ("" :) rest--renderBinding :: Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text]-renderBinding ctx declaration shape obligation =-  [ "-- HOLE: complete both total directions; wire policy remains in the generated codec.",-    obligationSymbol obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType,-    obligationSymbol obligation <> " =",-    "  StructuralBinding",-    "    { bindingToShape = \\case"-  ]-    <> indentCases (bindingCases True)-    <> ["    , bindingFromShape = \\case"]-    <> indentCases (bindingCases False)-    <> ["    }"]-  where-    domainModule = hsModule (sdHaskell declaration)-    domainType = domainModule <> "." <> hsType (sdHaskell declaration)-    shapeModuleName = structuralShapeModule ctx (sdName declaration)-    shapeType = shapeModuleName <> "." <> sdName declaration <> "Shape"-    domainCtor constructor = domainModule <> "." <> constructor-    shapeCtor constructor = shapeModuleName <> "." <> constructor-    indentCases = map ("      " <>)-    bindingCases toShapeDirection =-      foldMappedShape-        MappedShapeAlgebra-          { onRecord = \constructor _ fields -> [recordCase toShapeDirection constructor fields],-            onEnum = \entries -> map (enumCase toShapeDirection . weCtor) entries,-            onUnion = \_ arms -> map (unionCase toShapeDirection) arms-          }-        shape-    recordCase toShapeDirection constructor fields =-      sourceCtor-        <> arguments variables-        <> " -> "-        <> targetCtor-        <> arguments (map (holeFor toShapeDirection . rwfHaskell) fields)-      where-        variables = map (("_" <>) . (<> "Value") . rwfHaskell) fields-        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor-        targetCtor = if toShapeDirection then shapeCtor constructor else domainCtor constructor-    enumCase toShapeDirection constructor =-      sourceCtor <> " -> " <> holeFor toShapeDirection constructor-      where-        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor-    unionCase toShapeDirection arm =-      sourceCtor-        <> maybe "" (const " _payloadValue") (rwaPayload arm)-        <> " -> "-        <> case rwaPayload arm of-          Nothing -> holeFor toShapeDirection (rwaCtor arm)-          Just _ -> targetCtor <> " " <> holeFor toShapeDirection (rwaCtor arm <> ".payload")-      where-        sourceCtor = if toShapeDirection then domainCtor (rwaCtor arm) else shapeCtor (rwaCtor arm)-        targetCtor = if toShapeDirection then shapeCtor (rwaCtor arm) else domainCtor (rwaCtor arm)-    arguments [] = ""-    arguments values = " " <> T.unwords values-    holeFor toShapeDirection fieldName =-      "(error "-        <> tshow-          ( "HOLE: fill "-              <> sdName declaration-              <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.")-              <> fieldName-          )-        <> ")"--shapeModule :: Context -> TypeGraph -> (StructuralDecl, ResolvedMappedShape) -> ScaffoldModule-shapeModule ctx graph (declaration, shape) =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" (structuralShapeModule ctx (sdName declaration)) <> ".hs"),-      moduleText = emitShape ctx graph declaration shape,-      kind = Generated,-      origin = nodeOrigin "mapped structural" (sdName declaration) (sdLoc declaration)-    }--structuralPrefix :: Context -> Text-structuralPrefix ctx = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Structural"-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Structural"--structuralShapeModule :: Context -> Name -> Text-structuralShapeModule ctx name = structuralPrefix ctx <> ".Shape." <> name--nominalRepresentationModule :: Context -> Name -> Text-nominalRepresentationModule ctx name = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominal.Shape." <> name-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Nominal.Shape." <> name <> ".Generated"--nominalRepresentationOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]-nominalRepresentationOwners ctx spec = case resolveNominalTypes spec of-  Left _ -> []-  Right registry ->-    [ (nominalRepresentationModuleValue ctx nominal constructors, [resolvedNominalName nominal])-    | nominal <- Map.elems (nominalTypes registry),-      ConsumerNominal {} <- [resolvedNominalOwnership nominal],-      EnumRepresentation constructors <- [resolvedNominalRepresentation nominal]-    ]--nominalRepresentationModuleValue :: Context -> ResolvedNominalType -> NonEmpty (Name, Text) -> ScaffoldModule-nominalRepresentationModuleValue ctx nominal constructors =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-      moduleText =-        nl-          [ "{-# LANGUAGE DeriveGeneric #-}",-            "{-# LANGUAGE LambdaCase #-}",-            generatedBanner,-            "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where",-            "",-            "import Data.Text (Text)",-            "import GHC.Generics (Generic)",-            "",-            "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),-            "  deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)",-            "",-            encoderName <> " :: " <> representationType <> " -> Text",-            encoderName <> " = \\case",-            nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]-          ],-      kind = Generated,-      origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal)-    }-  where-    moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal)-    representationType = resolvedNominalName nominal <> "Representation"-    encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText"--nominalProjectionModule :: Context -> Text-nominalProjectionModule ctx = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections"-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections"--nominalProjectionOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]-nominalProjectionOwners ctx spec = case nominalProjectionTypes spec of-  [] -> []-  nominals ->-    [ ( ScaffoldModule-          { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"),-            moduleText = emitNominalProjections ctx nominals,-            kind = Generated,-            origin = "context " <> specContext spec <> " nominal scalar projection facade"-          },-        []-      )-    ]--nominalProjectionTypes :: Spec -> [ResolvedNominalType]-nominalProjectionTypes spec =-  Map.elems . Map.fromList $-    [ (resolvedNominalName nominal, nominal)-    | aggregate <- [value | NAggregate value <- specNodes spec],-      resolved <- registerTypes aggregate <> commandTypes aggregate,-      AggregateNominal nominal <- [resolved],-      ConsumerNominal {} <- [resolvedNominalOwnership nominal],-      ScalarRepresentation {} <- [resolvedNominalRepresentation nominal]-    ]-  where-    symbols = aggregateSymbols spec-    registerTypes aggregate =-      [ resolved-      | register <- aggRegs aggregate,-        Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]-      ]-    commandTypes aggregate =-      [ resolved-      | command <- aggCommands aggregate,-        field <- cmdFields command,-        Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]-      ]--emitNominalProjections :: Context -> [ResolvedNominalType] -> Text-emitNominalProjections ctx nominals =-  nl $-    [ "{-# LANGUAGE DataKinds #-}",-      "{-# LANGUAGE TypeApplications #-}",-      "{-# LANGUAGE TypeFamilies #-}",-      generatedBanner,-      "module " <> moduleName <> " where",-      ""-    ]-      <> map ("import " <>) imports-      <> [""]-      <> [T.intercalate "\n\n" (map emitNominalProjection nominals)]-  where-    moduleName = nominalProjectionModule ctx-    imports =-      sort . nub $-        [ "Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)",-          "Keiro.Codec.Nominal (nominalToRepresentation)"-        ]-          <> [hsModule (consumerNominalHaskell binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]]-          <> [qualifiedModule (consumerNominalBinding binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]]-          <> ["Data.Text (Text)" | any (hasScalar NominalText) nominals]-          <> ["Data.Time (UTCTime)" | any (hasScalar NominalTime) nominals]-          <> ["Numeric.Natural (Natural)" | any (hasScalar NominalNatural) nominals]-    hasScalar wanted nominal = resolvedNominalRepresentation nominal == ScalarRepresentation wanted-    emitNominalProjection nominal = case resolvedNominalOwnership nominal of-      GeneratedNominal -> ""-      ConsumerNominal binding ->-        nl-          [ "data " <> tagName,-            "",-            "instance FieldProjection " <> tagName <> " where",-            "  type FieldName " <> tagName <> " = " <> tshow name,-            "  type FieldOwner " <> tagName <> " = " <> renderHaskellSource (consumerNominalHaskell binding),-            "  type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal),-            "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)),-            "  projectFieldValue _ = nominalToRepresentation " <> unQualifiedValueName (consumerNominalBinding binding),-            "",-            witnessName <> " :: FieldWitness " <> tagName,-            witnessName <> " = fieldWitness @" <> tagName-          ]-        where-          name = resolvedNominalName nominal-          tagName = name <> "NominalProjection"-          witnessName = lowerFirst name <> "Witness"-    scalarHaskellType representation = case representation of-      ScalarRepresentation NominalText -> "Text"-      ScalarRepresentation NominalInt -> "Int"-      ScalarRepresentation NominalNatural -> "Natural"-      ScalarRepresentation NominalBool -> "Bool"-      ScalarRepresentation NominalTime -> "UTCTime"-      IdRepresentation {} -> "()"-      EnumRepresentation {} -> "()"--structuralProjectionModule :: Context -> Text-structuralProjectionModule ctx = structuralPrefix ctx <> "Projections"--emitShape :: Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitShape ctx graph declaration shape =-  nl $-    languagePragmas-      <> [ generatedBanner,-           "module " <> moduleName <> " (" <> shapeType <> " (..)) where",-           ""-         ]-      <> map ("import " <>) imports-      <> ["" | not (null imports)]-      <> [shapeDeclaration]-  where-    moduleName = structuralShapeModule ctx (sdName declaration)-    shapeType = sdName declaration <> "Shape"-    requirements = shapeRequirements ctx graph shape-    languagePragmas =-      ["{-# LANGUAGE DeriveGeneric #-}"]-        <> ["{-# LANGUAGE DuplicateRecordFields #-}" | shapeHasRecord shape]-    imports =-      sort . nub $-        ["Data.Aeson (Value)" | ReqJson `elem` requirements]-          <> ["Data.Map.Strict (Map)" | ReqMap `elem` requirements]-          <> ["Data.Text (Text)" | ReqText `elem` requirements]-          <> ["Data.Time (UTCTime)" | ReqTime `elem` requirements]-          <> ["GHC.Generics (Generic)"]-          <> ["Numeric.Natural (Natural)" | ReqNatural `elem` requirements]-          <> [m <> " qualified" | ReqModule m <- requirements]-    shapeDeclaration =-      foldMappedShape-        MappedShapeAlgebra-          { onRecord = \constructor _ fields ->-              nl $-                ["data " <> shapeType <> " = " <> constructor]-                  <> recordFields-                    [ (rwfHaskell field, renderShapeType ctx graph (rwfType field))-                    | field <- fields-                    ]-                  <> ["  deriving stock (Eq, Generic, Show)"],-            onEnum = \entries ->-              "data "-                <> shapeType-                <> " = "-                <> T.intercalate " | " (map weCtor entries)-                <> "\n  deriving stock (Eq, Generic, Show)",-            onUnion = \_ arms ->-              nl $-                case arms of-                  [] -> ["data " <> shapeType <> " = " <> shapeType <> "Empty", "  deriving stock (Eq, Generic, Show)"]-                  firstArm : rest ->-                    ["data " <> shapeType <> " = " <> renderArm firstArm]-                      <> ["  | " <> renderArm arm | arm <- rest]-                      <> ["  deriving stock (Eq, Generic, Show)"]-          }-        shape-    renderArm arm = rwaCtor arm <> maybe "" ((" !" <>) . renderShapeType ctx graph) (rwaPayload arm)--data ShapeRequirement-  = ReqJson-  | ReqMap-  | ReqText-  | ReqTime-  | ReqNatural-  | ReqModule !Text-  deriving stock (Eq, Ord, Show)--shapeHasRecord :: ResolvedMappedShape -> Bool-shapeHasRecord =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ _ -> True,-        onEnum = const False,-        onUnion = \_ _ -> False-      }--shapeRequirements :: Context -> TypeGraph -> ResolvedMappedShape -> [ShapeRequirement]-shapeRequirements ctx graph =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ fields -> concatMap (exprRequirements ctx graph . rwfType) fields,-        onEnum = const [],-        onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . rwaPayload) arms-      }--exprRequirements :: Context -> TypeGraph -> ResolvedTypeExpr -> [ShapeRequirement]-exprRequirements ctx graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = [ReqText],-        onInt = [],-        onInteger = [],-        onBool = [],-        onNatural = [ReqNatural],-        onTime = [ReqTime],-        onJson = [ReqJson],-        onOptional = id,-        onList = id,-        onMap = (ReqMap :) . (ReqText :),-        onRef = \key -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural declaration _) -> [ReqModule (structuralShapeModule ctx (sdName declaration))]-          Just (ResolvedOpaque declaration) -> [ReqModule (hsModule (odHaskell declaration))]-          Nothing -> []-      }--renderShapeType :: Context -> TypeGraph -> ResolvedTypeExpr -> Text-renderShapeType ctx graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = "Text",-        onInt = "Int",-        onInteger = "Integer",-        onBool = "Bool",-        onNatural = "Natural",-        onTime = "UTCTime",-        onJson = "Value",-        onOptional = \value -> "(Maybe (" <> value <> "))",-        onList = \value -> "([" <> value <> "])",-        onMap = \value -> "(Map Text (" <> value <> "))",-        onRef = \key -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural nested _) ->-            structuralShapeModule ctx (sdName nested) <> "." <> sdName nested <> "Shape"-          Just (ResolvedOpaque opaque) ->-            hsModule (odHaskell opaque) <> "." <> hsType (odHaskell opaque)-          Nothing -> "()"-      }--data StructuralProjection = StructuralProjection-  { spTag :: !Text,-    spWitness :: !Text,-    spPointer :: !Text,-    spOwner :: !HaskellSource,-    spResult :: !Text,-    spCanonical :: !CanonicalTypeId,-    spBinding :: !QualifiedValueName,-    spSelectors :: ![(Text, Text)]-  }-  deriving stock (Eq, Show)--projectionSpecs :: TypeGraph -> [StructuralProjection]-projectionSpecs graph =-  sortOn spTag . concat $-    [ projectionsForRoot graph declaration shape-    | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)-    ]--projectionsForRoot :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [StructuralProjection]-projectionsForRoot graph root rootShape = case rootShape of-  RRecord _ _ fields -> concatMap (walkField [] []) fields-  REnum {} -> []-  RUnion {} -> []-  where-    walkField keys selectors field-      | rwfPresence field /= PRequired = []-      | otherwise = case projectionScalar (rwfType field) of-          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]) result]-          Nothing -> case rwfType field of-            RRef key -> case Map.lookup key (tgDeclarations graph) of-              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->-                concatMap-                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]))-                  nestedFields-              _ -> []-            _ -> []-      where-        shapeModuleForOwner = "__SHAPE__." <> sdName root--    walkNested owner keys selectors field-      | rwfPresence field /= PRequired = []-      | otherwise = case projectionScalar (rwfType field) of-          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]) result]-          Nothing -> case rwfType field of-            RRef key -> case Map.lookup key (tgDeclarations graph) of-              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->-                concatMap-                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]))-                  nestedFields-              _ -> []-            _ -> []--    -- Context is supplied when rendering; this marker is replaced there.-    shapeModuleFor declaration = "__SHAPE__." <> sdName declaration-    mkProjection keys selectors result =-      StructuralProjection-        { spTag = projectionTag (sdName root) pointer,-          spWitness = lowerFirst (projectionTag (sdName root) pointer) <> "Witness",-          spPointer = pointer,-          spOwner = sdHaskell root,-          spResult = result,-          spCanonical = sdCanonical root,-          spBinding = sdBinding root,-          spSelectors = selectors-        }-      where-        pointer = T.concat ["/" <> escapePointer key | key <- keys]--projectionScalar :: ResolvedTypeExpr -> Maybe Text-projectionScalar = \case-  RText -> Just "Text"-  RInt -> Just "Int"-  RInteger -> Just "Integer"-  RBool -> Just "Bool"-  RTime -> Just "UTCTime"-  RNatural -> Just "Natural"-  RJson -> Nothing-  ROptional {} -> Nothing-  RList {} -> Nothing-  RMap {} -> Nothing-  RRef {} -> Nothing--escapePointer :: Text -> Text-escapePointer = T.replace "/" "~1" . T.replace "~" "~0"--projectionTag :: Name -> Text -> Text-projectionTag owner pointer = "StructuralProjection" <> encodeIdentifier (owner <> pointer)--encodeIdentifier :: Text -> Text-encodeIdentifier = T.concatMap (\character -> "C" <> T.pack (showHex (ord character) "") <> "Z")--emitStructuralProjections :: Context -> TypeGraph -> Text-emitStructuralProjections ctx graph =-  nl $-    [ "{-# LANGUAGE DataKinds #-}",-      "{-# LANGUAGE TypeApplications #-}",-      "{-# LANGUAGE TypeFamilies #-}",-      generatedBanner,-      "-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.",-      "-- Int, Natural, and UTCTime belong to Keiki's ordered subset.",-      "module " <> moduleName,-      "  ( " <> T.intercalate "\n  , " (map spWitness specs),-      "  ) where",-      "",-      "import Data.Text (Text)",-      "import Data.Time (UTCTime)",-      "import Numeric.Natural (Natural)",-      "import Keiro.Codec.Structural (bindingToShape)",-      "import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)"-    ]-      <> map ("import " <>) imports-      <> concatMap renderProjection specs-  where-    moduleName = structuralProjectionModule ctx-    specs = map (resolveProjectionModules ctx) (projectionSpecs graph)-    imports =-      sort . nub $-        [hsModule (spOwner spec) <> " qualified" | spec <- specs]-          <> [qualifiedModule (spBinding spec) <> " qualified" | spec <- specs]-          <> [shapeModuleName <> " qualified" | spec <- specs, (shapeModuleName, _) <- spSelectors spec]-    renderProjection spec =-      [ "",-        "data " <> spTag spec,-        "",-        "instance FieldProjection " <> spTag spec <> " where",-        "  type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec),-        "  type FieldOwner " <> spTag spec <> " = " <> renderHaskellSource (spOwner spec),-        "  type FieldResult " <> spTag spec <> " = " <> spResult spec,-        "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (spCanonical spec)),-        "  projectFieldValue _ owner = " <> renderGetter spec,-        "",-        spWitness spec <> " :: FieldWitness " <> spTag spec,-        spWitness spec <> " = fieldWitness @" <> spTag spec-      ]-    renderGetter spec =-      foldl-        (\value (shapeModuleName, selector) -> shapeModuleName <> "." <> selector <> " (" <> value <> ")")-        ("bindingToShape " <> unQualifiedValueName (spBinding spec) <> " owner")-        (spSelectors spec)--resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection-resolveProjectionModules ctx spec =-  spec-    { spSelectors =-        [ (replaceModule marker, selector)-        | (marker, selector) <- spSelectors spec-        ]-    }-  where-    replaceModule marker-      | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name-      | otherwise = structuralShapeModule ctx (lastSegment marker)--qualifiedModule :: QualifiedValueName -> Text-qualifiedModule = fst . splitQualified . unQualifiedValueName--renderHaskellSource :: HaskellSource -> Text-renderHaskellSource source = hsModule source <> "." <> hsType source--splitQualified :: Text -> (Text, Text)-splitQualified value =-  let (prefix, name) = T.breakOnEnd "." value-   in (T.dropEnd 1 prefix, name)--lastSegment :: Text -> Text-lastSegment = snd . T.breakOnEnd "."---- | 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)-  ]-    ++ ( if hasVersion2Ownership a-           then-             [ genModule a "Expressions" (emitExpressions a),-               genModule a "Transducer" (emitGeneratedTransducer a)-             ]-           else []-       )-    ++ [ genModule a "EventStream" (emitEventStream a),-         genModule a "Projection" (emitProjection a),-         holeModule a (emitHoles a)-       ]-  where-    a = resolveAgg ctx spec agg---- | Emit the context-wide replay-audit target assembly.------ There is one existential target per aggregate declaration. Process saga--- aggregates are ordinary aggregate nodes referenced by 'SagaRef', so they are--- included by the same single source of truth rather than being duplicated from--- the process declaration.-scaffoldReplayAudit :: Context -> Spec -> [ScaffoldModule]-scaffoldReplayAudit ctx spec-  | null aggregates = []-  | otherwise =-      [ ScaffoldModule-          { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-            moduleText = emitReplayAudit,-            kind = Generated,-            origin = "context " <> specContext spec <> " replay-audit assembly"-          }-      ]-  where-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]-    moduleName = contextGeneratedPrefix ctx <> ".ReplayAudit"-    contextGeneratedPrefix context = case placement context of-      GeneratedPrefix -> rootPrefix context <> "Generated." <> ctxPascalOf context-      CollocatedLeaf -> rootPrefix context <> ctxPascalOf context <> ".Generated"-    emitReplayAudit =-      nl $-        [ "{-# LANGUAGE GADTs #-}",-          generatedBanner,-          "--",-          "-- Deployment contract:",-          "--   * replay-neutral diff: no data audit is required;",-          "--   * affected diff: run AuditTargeted with the emitted affected set",-          "--     against a production copy under the candidate binary;",-          "--   * one-time runtime cutover: run AuditFull;",-          "--   * any non-zero audit exit blocks deployment.",-          "module " <> moduleName <> " (auditTargets) where",-          ""-        ]-          ++ [ "import " <> genPrefixFor ctx (aggName aggregate) <> ".EventStream qualified as " <> aggName aggregate-             | aggregate <- aggregates-             ]-          ++ [ "import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)",-               "import Keiro.Stream qualified as Stream",-               "",-               "auditTargets :: [SomeAuditTarget]",-               "auditTargets ="-             ]-          ++ concat-            [ [ if index == (0 :: Int) then "  [ SomeAuditTarget" else "  , SomeAuditTarget",-                "      AuditTarget",-                "        { eventStream = " <> aggregateName <> "." <> lowerFirst aggregateName <> "EventStream",-                "        , category = Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category",-                "        , mkStream = streamInCategory (Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category)",-                "        }"-              ]-            | (index, aggregate) <- zip [0 ..] aggregates,-              let aggregateName = aggName aggregate-            ]-          ++ ["  ]"]--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 #-}",-      "{-# 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)-      },-    ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"),-        moduleText = emitQueueCodec 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 #-}",-      "{-# 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 versioned PGMQ envelope adapter.  The payload record remains--- symbol-free and dependency-light in Queue.hs; this runtime-facing module is--- the opt-in assembly point applications import into their Job values.-emitQueueCodec :: Text -> WorkqueueNode -> Text-emitQueueCodec genPrefix w =-  nl-    [ generatedBanner,-      "{- | Versioned job payload envelope: @{\\\"v\\\",\\\"t\\\",\\\"data\\\"}@.",-      "",-      "Deploy workers before producers when raising its schema version. Do not",-      "adopt this codec on a non-empty bare-payload queue without draining it",-      "(or supplying a transitional codec), or in-flight messages will",-      "dead-letter. This is telemetry-neutral:",-      "docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns",-      "spans and acknowledgement vocabulary.",-      "-}",-      "module " <> genPrefix <> ".QueueCodec (" <> stem <> "PayloadCodec, " <> stem <> "JobCodec) where",-      "",-      "import Data.List.NonEmpty (NonEmpty (..))",-      "import Keiro.Codec (Codec (..), EventType (..))",-      "import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)",-      "import " <> genPrefix <> ".Queue (" <> payloadTy <> ", encode" <> payloadTy <> ", parse" <> payloadTy <> ")",-      "",-      stem <> "PayloadCodec :: Codec " <> payloadTy,-      stem <> "PayloadCodec =",-      "  Codec",-      "    { eventTypes = EventType " <> tshow payloadTy <> " :| []",-      "    , eventType = \\_ -> EventType " <> tshow payloadTy,-      "    , schemaVersion = 1",-      "    , encode = encode" <> payloadTy,-      "    , decode = \\_ -> parse" <> payloadTy,-      "    , upcasters = []",-      "    }",-      "",-      stem <> "JobCodec :: JobCodec " <> payloadTy,-      stem <> "JobCodec = keiroJobCodec " <> stem <> "PayloadCodec"-    ]-  where-    payloadTy = wqPayloadName w-    stem = lowerFirst (T.concat (map pascal (T.splitOn "_" (wqName w))))---- | 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 $-    [ 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-    [ 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 #-}",-      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 $-    [ 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 $-    [ 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 DeriveAnyClass #-}" | hasSnapshot a]-      ++ [ "{-# LANGUAGE DuplicateRecordFields #-}",-           "{-# 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 (CanonicalStateShape, CanonicalTypeName)" | hasSnapshot a]-      ++ map ("import " <>) (domainConsumerImports a)-      ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)",-           "",-           sectionsOf-             [ map (emitId a) [declaration | declaration <- aIds a, idBinding declaration == Nothing],-               map (emitEnum a) [declaration | declaration <- aEnums a, enumBinding declaration == Nothing],-               [emitVertex a],-               map (emitRecord a) (aCommands a),-               [emitSum (aName a <> "Command") (aCommands a)],-               map (emitRecord a) (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]-      ++ [ line-         | hasSnapshot a,-           line <--             [ "instance CanonicalStateShape " <> aVertexType a,-               "instance CanonicalTypeName " <> aVertexType a-             ]-         ]--emitRecord :: Agg -> ResolvedCtor -> Text-emitRecord a rc =-  nl $-    [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data"-    ]-      ++ recordFields [(name, renderDomainType a fieldType) | (name, fieldType) <- 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 a (aRegs a)--regListLines :: Agg -> [ResolvedRegister] -> [Text]-regListLines _ [] = ["  '[]"]-regListLines a rs =-  [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType a (rrType 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 (rrName r) <> ") " <> regInitialValue r <> " $"-      | r <- init rs-      ]-        ++ ["  RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue lastR <> " RNil"]-      where-        lastR = last rs---- | The Haskell initial value for a register, by the category of its type.-regInitialValue :: ResolvedRegister -> Text-regInitialValue = renderRegisterInitial . rrInitial--domainConsumerImports :: Agg -> [Text]-domainConsumerImports a =-  sort . nub $-    Set.toList (Set.unions [aggregateImports (aSymbols a) resolved | resolved <- aggregateTypes])-      <> [ qualifiedModule initialValue <> " qualified"-         | declaration <- mappedUses a,-           initialValue <- maybeToListText (mappedInitial declaration)-         ]-      <> [ qualifiedModule initialValue <> " qualified"-         | resolvedType <- aggregateTypes,-           AggregateNominal nominal <- [resolvedType],-           ConsumerNominal binding <- [resolvedNominalOwnership nominal],-           initialValue <- maybeToListText (consumerNominalInitial binding)-         ]-  where-    aggregateTypes = map snd (concatMap rcFields (aCommands a <> aEvents a)) <> map rrType (aRegs a)--mappedUses :: Agg -> [ResolvedMappedDecl]-mappedUses a =-  [ declaration-  | resolvedType <--      map snd (concatMap rcFields (aCommands a <> aEvents a))-        <> map rrType (aRegs a),-    declaration <- maybeToListText (mappedDeclFor a resolvedType)-  ]--mappedDeclFor :: Agg -> ResolvedAggregateType -> Maybe ResolvedMappedDecl-mappedDeclFor a resolvedType = do-  key <- case resolvedType of-    AggregateMapped mappedKey -> Just mappedKey-    _ -> Nothing-  graph <- aTypeGraph a-  Map.lookup key (tgDeclarations graph)--mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName-mappedInitial (ResolvedStructural declaration _) = sdInitial declaration-mappedInitial (ResolvedOpaque declaration) = odInitial declaration--renderDomainType :: Agg -> ResolvedAggregateType -> Text-renderDomainType a = aggregateHaskellType (aSymbols a)--maybeToListText :: Maybe value -> [value]-maybeToListText = maybe [] pure------------------------------------------------------------------------------------- Codec module-----------------------------------------------------------------------------------emitCodec :: Agg -> Text-emitCodec a =-  nl $-    ["{-# LANGUAGE DataKinds #-}" | hasConsumerNominalIdCodec a]-      ++ ["{-# LANGUAGE TypeApplications #-}" | hasConsumerNominalIdCodec a]-      ++ ["{-# LANGUAGE LambdaCase #-}" | hasConsumerNominalCodec a]-      ++ [ "{-# LANGUAGE OverloadedRecordDot #-}",-           generatedBanner,-           "module " <> aGenPrefix a <> ".Codec (",-           "    " <> lowerFirst (aName a) <> "Codec,",-           "    parse" <> aName a <> "Event,",-           "    encode" <> aName a <> "Event,"-         ]-      ++ concatMap mappedExports (codecMappedDeclarations a)-      ++ [ ") where",-           "",-           "import " <> aGenPrefix a <> ".Domain"-         ]-      ++ ( if hasMappedCodec a-             then-               [ "import Control.Monad (unless)",-                 "import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))",-                 "import Data.Aeson.Key qualified as Key",-                 "import Data.Aeson.KeyMap qualified as KeyMap"-               ]-             else ["import Data.Aeson (Value, object, withObject, (.:), (.=))"]-         )-      ++ [ "import Data.Aeson.Types (Parser, parseEither)",-           "import Data.List.NonEmpty (NonEmpty (..))"-         ]-      ++ ( if hasMappedCodec a-             then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"]-             else []-         )-      ++ [ "import Data.Text (Text)",-           "import qualified Data.Text as T"-         ]-      ++ ["import Data.KindID qualified as KindID" | hasConsumerNominalIdCodec a]-      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" | hasConsumerNominalCodec a]-      ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasMappedCodec a]-      ++ [ "import Keiro.Codec (Codec (..), EventType (..))",-           upcasterImport a-         ]-      ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a]-      ++ [nl (map ("import " <>) (codecNominalImports a)) | hasConsumerNominalCodec a]-      ++ [ "",-           emitEnumParsers a,-           emitConsumerNominalParsers a-         ]-      ++ [emitMappedCodecs a | hasMappedCodec a]-      ++ [ "",-           emitCodecValue a,-           "",-           emitEncode a,-           "",-           emitDecode a,-           "",-           "mapLeftText :: Either String b -> Either Text b",-           "mapLeftText = either (Left . T.pack) Right"-         ]-      ++ ( if hasMappedCodec a-             then-               [ "",-                 "rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()",-                 "rejectUnknownFields label allowed objectValue =",-                 "  unless (null extras) (fail (label <> \" contains unknown fields: \" <> show extras))",-                 "  where",-                 "    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))"-               ]-             else []-         )-  where-    mappedExports (ResolvedStructural declaration _) =-      [ "    encode" <> sdName declaration <> "Mapped,",-        "    decode" <> sdName declaration <> "Mapped,"-      ]-    mappedExports ResolvedOpaque {} = []--hasMappedCodec :: Agg -> Bool-hasMappedCodec = not . null . codecMappedDeclarations--hasConsumerNominalCodec :: Agg -> Bool-hasConsumerNominalCodec = not . null . codecConsumerNominals--hasConsumerNominalIdCodec :: Agg -> Bool-hasConsumerNominalIdCodec aggregate =-  any-    (\nominal -> case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False)-    (codecConsumerNominals aggregate)--emitEnumParsers :: Agg -> Text-emitEnumParsers a = sectionsOf [[emitEnumParser declaration | declaration <- aEnums a, enumBinding declaration == Nothing]]--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)]--emitConsumerNominalParsers :: Agg -> Text-emitConsumerNominalParsers aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)]-  where-    emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of-      (IdRepresentation prefix, ConsumerNominal binding) ->-        nl-          [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding),-            parserName nominal <> " input = case KindID.parseText @" <> tshow prefix <> " input of",-            "  Left reason -> fail (show reason)",-            "  Right representation -> pure (nominalFromRepresentation " <> unQualifiedValueName (consumerNominalBinding binding) <> " representation)"-          ]-      (EnumRepresentation constructors, ConsumerNominal binding) ->-        nl $-          [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding),-            parserName nominal <> " = \\case"-          ]-            <> [ "  "-                   <> tshow wire-                   <> " -> pure (nominalFromRepresentation "-                   <> unQualifiedValueName (consumerNominalBinding binding)-                   <> " "-                   <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal)-                   <> "."-                   <> constructor-                   <> ")"-               | (constructor, wire) <- NE.toList constructors-               ]-            <> ["  _ -> fail " <> tshow ("unknown " <> resolvedNominalName nominal <> " wire value")]-      _ -> ""-    parserName nominal = "parse" <> resolvedNominalName nominal <> "Nominal"--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,-           "    }"-         ]-      ++ upcasterRungDecls 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, Text)]-upcasterEntries a =-  [ (m, rcName e, "upcast" <> rcName e <> "V" <> tshow' m)-  | e <- aEvents a,-    Just m <- [rcUpcastFrom e]-  ]--upcastersExpr :: Agg -> Text-upcastersExpr a =-  "[" <> T.intercalate ", " ["(" <> tshow' m <> ", upcastRungV" <> tshow' m <> ")" | (m, _) <- upcasterRungs a] <> "]"---- | Group event-specific holes into one migration rung per aggregate-global--- source version.  Event metadata stamps every kind with the aggregate's--- schema version, so a rung must explicitly pass foreign event kinds through.-upcasterRungs :: Agg -> [(Int, [(Text, Text)])]-upcasterRungs a =-  [ (source, [(eventName, fn) | (_, eventName, fn) <- entries])-  | entries@((source, _, _) : _) <- groupBy sameSource (sortOn firstSource (upcasterEntries a))-  ]-  where-    firstSource (source, _, _) = source-    sameSource (source, _, _) (otherSource, _, _) = source == otherSource--upcasterRungDecls :: Agg -> [Text]-upcasterRungDecls a = concatMap rung (upcasterRungs a)-  where-    rung (source, entries) =-      [ "",-        "upcastRungV" <> tshow' source <> " :: EventType -> Value -> Either Text Value"-      ]-        ++ [ "upcastRungV" <> tshow' source <> " (EventType " <> tshow eventName <> ") value = " <> fn <> " value"-           | (eventName, fn) <- entries-           ]-        ++ [ "-- Kinds whose shape did not change at this rung pass through unchanged; their",-             "-- stamped version is aggregate-global, not their own shape history.",-             "upcastRungV" <> tshow' source <> " _ value = Right value"-           ]---- | 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 ", " [fn | (_, _, fn) <- 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-        <> " .= "-        <> encodeFieldValue n ty-    encodeFieldValue name ty = case ty of-      AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> name)-      _ -> case fieldCat a ty of-        MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> name-        MappedOpaqueCat {} -> "toJSON payload." <> name-        _ -> "payload." <> name-    encodeNominalValue nominal value = case resolvedNominalOwnership nominal of-      GeneratedNominal -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value-        EnumRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value-        ScalarRepresentation {} -> value-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> "KindID.toText (nominalToRepresentation " <> bindingName binding <> " " <> value <> ")"-        EnumRepresentation {} ->-          nominalRepresentationModule (aContext a) (resolvedNominalName nominal)-            <> "."-            <> lowerFirst (resolvedNominalName nominal)-            <> "RepresentationText (nominalToRepresentation "-            <> bindingName binding-            <> " "-            <> value-            <> ")"-        ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value-    bindingName = unQualifiedValueName . consumerNominalBinding--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 ty of-      AggregateNominal nominal -> decodeNominalField n nominal-      _ -> case fieldCat a ty of-        MappedStructuralCat declaration _ -> "(o .: " <> tshow n <> " >>= parse" <> sdName declaration <> "Mapped)"-        MappedOpaqueCat {} -> "o .: " <> tshow n-        _ -> "o .: " <> tshow n-    decodeNominalField name nominal = case resolvedNominalOwnership nominal of-      GeneratedNominal -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> "(" <> resolvedNominalName nominal <> " <$> o .: " <> tshow name <> ")"-        EnumRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> ")"-        ScalarRepresentation {} -> "o .: " <> tshow name-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> "Nominal)"-        EnumRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> "Nominal)"-        ScalarRepresentation {} -> "(nominalFromRepresentation " <> unQualifiedValueName (consumerNominalBinding binding) <> " <$> o .: " <> tshow name <> ")"--codecConsumerNominals :: Agg -> [ResolvedNominalType]-codecConsumerNominals aggregate =-  Map.elems . Map.fromList $-    [ (resolvedNominalName nominal, nominal)-    | event <- aEvents aggregate,-      (_, AggregateNominal nominal) <- rcFields event,-      ConsumerNominal {} <- [resolvedNominalOwnership nominal]-    ]--codecNominalImports :: Agg -> [Text]-codecNominalImports aggregate =-  sort . nub $-    concat-      [ [ hsModule (consumerNominalHaskell binding) <> " qualified",-          qualifiedModule (consumerNominalBinding binding) <> " qualified"-        ]-          <> [ nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified"-             | EnumRepresentation {} <- [resolvedNominalRepresentation nominal]-             ]-      | nominal <- codecConsumerNominals aggregate,-        ConsumerNominal binding <- [resolvedNominalOwnership nominal]-      ]--codecMappedImports :: Agg -> [Text]-codecMappedImports a = case aTypeGraph a of-  Nothing -> []-  Just graph ->-    sort . nub $-      [ structuralShapeModule (aContext a) (sdName declaration) <> " qualified"-      | ResolvedStructural declaration _ <- codecMappedDeclarations a-      ]-        <> [ hsModule (sdHaskell declaration) <> " qualified"-           | ResolvedStructural declaration _ <- codecMappedDeclarations a-           ]-        <> [ qualifiedModule (sdBinding declaration) <> " qualified"-           | ResolvedStructural declaration _ <- codecMappedDeclarations a-           ]-        <> [ hsModule (odHaskell declaration) <> " qualified"-           | ResolvedOpaque declaration <- codecMappedDeclarations a-           ]-        <> [ hsModule (odHaskell declaration) <> " qualified"-           | ResolvedStructural _ shape <- codecMappedDeclarations a,-             key <- directShapeRefs shape,-             Just (ResolvedOpaque declaration) <- [Map.lookup key (tgDeclarations graph)]-           ]--codecMappedDeclarations :: Agg -> [ResolvedMappedDecl]-codecMappedDeclarations a = case aTypeGraph a of-  Nothing -> []-  Just graph ->-    mapMaybe (\key -> Map.lookup key (tgDeclarations graph)) (sort (Map.keys selected))-    where-      roots =-        [ key-        | event <- aEvents a,-          (_, AggregateMapped key) <- rcFields event,-          Map.member key (tgDeclarations graph)-        ]-      selected =-        Map.fromList-          [ (key, ())-          | root <- roots,-            key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root (tgReachability graph))-          ]--directShapeRefs :: ResolvedMappedShape -> [MappedKey]-directShapeRefs =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ fields -> concatMap (exprRefs . rwfType) fields,-        onEnum = const [],-        onUnion = \_ arms -> concatMap (maybe [] exprRefs . rwaPayload) arms-      }--exprRefs :: ResolvedTypeExpr -> [MappedKey]-exprRefs =-  foldTypeExpr-    TypeExprAlgebra-      { onText = [],-        onInt = [],-        onInteger = [],-        onBool = [],-        onNatural = [],-        onTime = [],-        onJson = [],-        onOptional = id,-        onList = id,-        onMap = id,-        onRef = pure-      }--emitMappedCodecs :: Agg -> Text-emitMappedCodecs a = case aTypeGraph a of-  Nothing -> ""-  Just graph ->-    T.intercalate-      "\n\n"-      [ emitStructuralCodec a graph declaration shape-      | ResolvedStructural declaration shape <- codecMappedDeclarations a-      ]--emitStructuralCodec :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitStructuralCodec a graph declaration shape =-  nl-    [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value",-      "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding,-      "",-      "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType,-      "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value",-      "",-      "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType,-      "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped",-      "",-      "encode" <> name <> "Shape :: " <> shapeType <> " -> Value",-      emitShapeEncoder a graph declaration shape,-      "",-      "parse" <> name <> "Shape :: Value -> Parser " <> shapeType,-      emitShapeDecoder a graph declaration shape-    ]-  where-    name = sdName declaration-    consumerType = renderHaskellSource (sdHaskell declaration)-    shapeType = structuralShapeModule (aContext a) name <> "." <> name <> "Shape"-    binding = unQualifiedValueName (sdBinding declaration)--emitShapeEncoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitShapeEncoder a graph declaration =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ fields ->-          nl $-            ["encode" <> name <> "Shape shape =", "  object"]-              <> objectEntries-                [ tshow (rwfKey field)-                    <> " .= "-                    <> encodeShapeExpr a graph (rwfType field) (shapeModuleName <> "." <> rwfHaskell field <> " shape")-                | field <- fields-                ],-        onEnum = \entries ->-          nl $-            ["encode" <> name <> "Shape = \\case"]-              <> ["  " <> shapeModuleName <> "." <> weCtor entry <> " -> String " <> tshow (weTag entry) | entry <- entries],-        onUnion = \encoding arms ->-          nl $-            ["encode" <> name <> "Shape = \\case"]-              <> concatMap (unionEncodeArm encoding) arms-      }-  where-    name = sdName declaration-    shapeModuleName = structuralShapeModule (aContext a) name-    unionEncodeArm encoding arm =-      [ "  " <> shapeModuleName <> "." <> rwaCtor arm <> payloadPattern <> " ->",-        "    object"-      ]-        <> objectEntries-          ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"]-              <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload"-                 | payload <- maybeToListText (rwaPayload arm)-                 ]-          )-      where-        payloadPattern = maybe "" (const " payload") (rwaPayload arm)--emitShapeDecoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitShapeDecoder a graph declaration =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \constructor unknownFields fields ->-          nl $-            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do"-            ]-              <> rejectLine "  " unknownFields (map rwfKey fields) "objectValue"-              <> [ "  " <> shapeModuleName <> "." <> constructor,-                   "    <$> " <> T.intercalate "\n    <*> " (map (decodeRecordField a graph) fields)-                 ],-        onEnum = \entries ->-          nl $-            [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of"-            ]-              <> ["  " <> tshow (weTag entry) <> " -> pure " <> shapeModuleName <> "." <> weCtor entry | entry <- entries]-              <> ["  _ -> fail " <> tshow ("unknown " <> name <> " wire value")],-        onUnion = \encoding arms ->-          nl $-            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do",-              "  tag <- objectValue .: " <> tshow (ueTagField encoding) <> " :: Parser Text",-              "  case tag of"-            ]-              <> concatMap (unionDecodeArm encoding) arms-              <> ["    _ -> fail " <> tshow ("unknown " <> name <> " union tag")]-      }-  where-    name = sdName declaration-    shapeModuleName = structuralShapeModule (aContext a) name-    rejectLine _ IgnoreUnknown _ _ = []-    rejectLine indent RejectUnknown allowed objectName =-      [indent <> "rejectUnknownFields " <> tshow name <> " " <> renderTextList allowed <> " " <> objectName]-    unionDecodeArm encoding arm =-      ["    " <> tshow (rwaTag arm) <> " -> do"]-        <> rejectLine "      " (ueUnknownFields encoding) allowed "objectValue"-        <> [ case rwaPayload arm of-               Nothing -> "      pure " <> shapeModuleName <> "." <> rwaCtor arm-               Just payload ->-                 "      "-                   <> shapeModuleName-                   <> "."-                   <> rwaCtor arm-                   <> " <$> (objectValue .: "-                   <> tshow (ueContentsField encoding)-                   <> " >>= ("-                   <> decodeShapeExpr a graph payload-                   <> "))"-           ]-      where-        allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing]--decodeRecordField :: Agg -> TypeGraph -> ResolvedWireField -> Text-decodeRecordField a graph field = case rwfPresence field of-  PRequired ->-    "((objectValue .: " <> key <> " :: Parser Value) >>= (" <> decoder <> "))"-  POptional ->-    "(case KeyMap.lookup (Key.fromText "-      <> key-      <> ") objectValue of Nothing -> "-      <> missing-      <> "; Just presentValue -> "-      <> "("-      <> decoder-      <> ") presentValue)"-  where-    key = tshow (rwfKey field)-    decoder = decodeShapeExpr a graph (rwfType field)-    missing = case rwfOnMissing field of-      Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field)-      Just onMissing -> "pure " <> renderMissingDefault a graph (rwfType field) onMissing--encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text-encodeShapeExpr _a graph expression value =-  foldTypeExpr-    TypeExprAlgebra-      { onText = \v -> "toJSON (" <> v <> ")",-        onInt = \v -> "toJSON (" <> v <> ")",-        onInteger = \v -> "toJSON (" <> v <> ")",-        onBool = \v -> "toJSON (" <> v <> ")",-        onNatural = \v -> "toJSON (" <> v <> ")",-        onTime = \v -> "toJSON (" <> v <> ")",-        onJson = id,-        onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")",-        onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))",-        onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))",-        onRef = \key v -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")"-          Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")"-          Nothing -> "toJSON (" <> v <> ")"-      }-    expression-    value--decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text-decodeShapeExpr _a graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = "parseJSON",-        onInt = "parseJSON",-        onInteger = "parseJSON",-        onBool = "parseJSON",-        onNatural = "parseJSON",-        onTime = "parseJSON",-        onJson = "pure",-        onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other",-        onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")",-        onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")",-        onRef = \key -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape"-          Just (ResolvedOpaque _) -> "parseJSON"-          Nothing -> "parseJSON"-      }--renderMissingDefault :: Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text-renderMissingDefault a graph expression = \case-  OmNull -> "Nothing"-  OmText value -> tshow value-  OmInt value -> T.pack (show value)-  OmBool value -> if value then "True" else "False"-  OmEmptyList -> "[]"-  OmEmptyMap -> "Map.empty"-  OmCtor constructor -> case expression of-    RRef key -> case Map.lookup key (tgDeclarations graph) of-      Just (ResolvedStructural declaration _) -> structuralShapeModule (aContext a) (sdName declaration) <> "." <> constructor-      _ -> constructor-    _ -> constructor--objectEntries :: [Text] -> [Text]-objectEntries entries =-  [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries]-    <> ["      ]"]-  where-    lead 0 = "      [ "-    lead _ = "      , "--renderTextList :: [Text] -> Text-renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"------------------------------------------------------------------------------------- Authoritative version-2 expressions and transducer-----------------------------------------------------------------------------------hasVersion2Ownership :: Agg -> Bool-hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions--transitionEntries :: Agg -> [(Int, Transition)]-transitionEntries aggregate = zip [1 ..] (aTransitions aggregate)--transitionStem :: Int -> Transition -> Text-transitionStem index transition =-  "transition"-    <> tshow' index-    <> pascal (tSource transition)-    <> pascal (tCommand transition)--guardFunctionName :: Int -> Transition -> Text-guardFunctionName index transition = transitionStem index transition <> "Guard"--writeFunctionName :: Int -> Transition -> Name -> Text-writeFunctionName index transition registerName =-  transitionStem index transition <> "Write" <> pascal registerName--holeFunctionName :: Int -> Transition -> Text-holeFunctionName index transition = transitionStem index transition <> "Hole"--holeFoldVersionName :: Int -> Transition -> Text-holeFoldVersionName index transition = holeFunctionName index transition <> "FoldVersion"--outputFunctionName :: Int -> Transition -> Int -> Name -> Text-outputFunctionName transitionIndex transition emitIndex eventName =-  transitionStem transitionIndex transition-    <> "Output"-    <> tshow' emitIndex-    <> pascal eventName--commandForTransition :: Agg -> Transition -> ResolvedCtor-commandForTransition aggregate transition =-  fromMaybe-    (error ("validated aggregate command disappeared: " <> T.unpack (tCommand transition)))-    (find ((== tCommand transition) . rcName) (aCommands aggregate))--eventForName :: Agg -> Name -> ResolvedCtor-eventForName aggregate eventName =-  fromMaybe-    (error ("validated aggregate event disappeared: " <> T.unpack eventName))-    (find ((== eventName) . rcName) (aEvents aggregate))--commandFieldsType :: Transition -> Text-commandFieldsType transition = "RegFieldsOf " <> tCommand transition <> "Data"--payloadProjectionType :: Agg -> Transition -> Text-payloadProjectionType aggregate transition =-  "B.PayloadProj "-    <> aName aggregate-    <> "Regs "-    <> aName aggregate-    <> "Command ("-    <> commandFieldsType transition-    <> ")"--expressionFunctionNames :: Agg -> [Text]-expressionFunctionNames aggregate =-  concat-    [ maybe [] (const [guardFunctionName index transition]) (tGuard transition)-        <> [writeFunctionName index transition registerName | (registerName, _) <- tWrites transition]-    | (index, transition) <- transitionEntries aggregate,-      tImplementation transition == GeneratedImplementation-    ]--emitExpressions :: Agg -> Text-emitExpressions aggregate-  | null exports = nl [generatedBanner, "module " <> aGenPrefix aggregate <> ".Expressions () where"]-  | otherwise =-      nl $-        [ "{-# LANGUAGE DataKinds #-}",-          "{-# LANGUAGE OverloadedLabels #-}",-          "{-# LANGUAGE OverloadedRecordDot #-}",-          "{-# LANGUAGE TypeApplications #-}",-          generatedBanner-        ]-          ++ moduleDeclaration-          ++ [ "",-               "import " <> aGenPrefix aggregate <> ".Domain",-               "import Keiki.Builder qualified as B",-               "import Keiki.Core qualified as K",-               "import Keiki.Generics (RegFieldsOf)"-             ]-          ++ ["import Data.Text (Text)" | expressionUsesType AggregateText]-          ++ ["import Data.Time.Clock (UTCTime)" | expressionUsesType AggregateTime && not expressionUsesTimeLiteral]-          ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral]-          ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral]-          ++ ["import Numeric.Natural (Natural)" | expressionUsesType AggregateNatural]-          ++ structuralProjectionImport-          ++ nominalProjectionImport-          ++ consumerImports-          ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral]-          ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral]-          ++ consumerLiteralImports-          ++ concatMap (uncurry (emitTransitionExpressions aggregate)) (transitionEntries aggregate)-  where-    exports = expressionFunctionNames aggregate-    moduleDeclaration = case exports of-      firstExport : rest ->-        [ "module " <> aGenPrefix aggregate <> ".Expressions",-          "  ( " <> firstExport-        ]-          ++ ["  , " <> value | value <- rest]-          ++ ["  ) where"]-      [] -> error "non-empty expression export invariant"-    structuralProjectionImport =-      [ "import " <> structuralProjectionModule (aContext aggregate) <> " qualified as StructuralProjections"-      | maybe False (not . null . projectionSpecs) (aTypeGraph aggregate)-      ]-    nominalProjectionImport =-      [ "import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections"-      | any expressionUsesNominalProjection resolvedExpressions-      ]-    consumerImports =-      map ("import " <>)-        . filter (not . builtinExpressionImport)-        . sort-        . nub-        . Set.toList-        . Set.unions-        $ [ aggregateImports (aSymbols aggregate) resolvedType-          | resolvedType <- map rrType (aRegs aggregate) <> map snd (concatMap rcFields (aCommands aggregate))-          ]-    consumerLiteralImports =-      [ "import " <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified"-      | nominal <- consumerLiteralNominals,-        EnumRepresentation {} <- [resolvedNominalRepresentation nominal]-      ]-        <> [ "import " <> qualifiedModule (consumerNominalBinding binding) <> " qualified"-           | nominal <- consumerLiteralNominals,-             ConsumerNominal binding <- [resolvedNominalOwnership nominal]-           ]-    resolvedExpressions = resolvedGeneratedExpressions aggregate-    expressionUsesType wanted = any (anyTypedExpression ((== wanted) . typedScalarType)) resolvedExpressions-    expressionUsesTimeLiteral = any (anyTypedExpression isTimeLiteral) resolvedExpressions-    expressionUsesConsumerNominalLiteral = not (null consumerLiteralNominals)-    expressionUsesConsumerIdLiteral = any (isIdRepresentation . resolvedNominalRepresentation) consumerLiteralNominals-    consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression]-    isTimeLiteral expression = case typedScalarNode expression of-      TypedLiteral ScalarTimeValue {} -> True-      _ -> False-    isIdRepresentation IdRepresentation {} = True-    isIdRepresentation _ = False--builtinExpressionImport :: Text -> Bool-builtinExpressionImport imported =-  any (`T.isPrefixOf` imported) ["Data.Text", "Data.Time", "Numeric.Natural"]--resolvedGeneratedExpressions :: Agg -> [TypedScalarExpr]-resolvedGeneratedExpressions aggregate =-  concat-    [ maybe [] (pure . resolvedGuard index transition) (tGuard transition)-        <> [ resolvedWrite index transition registerName expression-           | (registerName, expression) <- tWrites transition-           ]-    | (index, transition) <- transitionEntries aggregate,-      tImplementation transition == GeneratedImplementation-    ]-  where-    environment transition = expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition-    resolvedGuard index transition expression =-      expressionOrDie (guardFunctionName index transition) (resolveGuardExpr (environment transition) expression)-    resolvedWrite index transition registerName expression =-      expressionOrDie (writeFunctionName index transition registerName) (resolveWriteExpr (environment transition) registerName expression)--anyTypedExpression :: (TypedScalarExpr -> Bool) -> TypedScalarExpr -> Bool-anyTypedExpression predicate expression =-  predicate expression || any (anyTypedExpression predicate) (typedExpressionChildren expression)--typedExpressionChildren :: TypedScalarExpr -> [TypedScalarExpr]-typedExpressionChildren expression = case typedScalarNode expression of-  TypedLiteral {} -> []-  TypedRoot {} -> []-  TypedProject {} -> []-  TypedAdd _ left right -> [left, right]-  TypedSubtract _ left right -> [left, right]-  TypedMultiply _ left right -> [left, right]-  TypedEqual left right -> [left, right]-  TypedNotEqual left right -> [left, right]-  TypedCompare _ left right -> [left, right]-  TypedAnd left right -> [left, right]-  TypedOr left right -> [left, right]--expressionUsesNominalProjection :: TypedScalarExpr -> Bool-expressionUsesNominalProjection = anyTypedExpression $ \expression -> case (typedScalarType expression, typedScalarNode expression) of-  (AggregateNominal nominal, TypedRoot {}) -> case (resolvedNominalOwnership nominal, resolvedNominalRepresentation nominal) of-    (ConsumerNominal {}, ScalarRepresentation {}) -> True-    _ -> False-  _ -> False--typedConsumerLiteralNominals :: TypedScalarExpr -> [ResolvedNominalType]-typedConsumerLiteralNominals expression = own <> concatMap typedConsumerLiteralNominals (typedExpressionChildren expression)-  where-    own = case (typedScalarType expression, typedScalarNode expression) of-      (AggregateNominal nominal, TypedLiteral ScalarEnumValue {})-        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]-      (AggregateNominal nominal, TypedLiteral ScalarIdValue {})-        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]-      _ -> []--emitTransitionExpressions :: Agg -> Int -> Transition -> [Text]-emitTransitionExpressions aggregate index transition-  | tImplementation transition /= GeneratedImplementation = []-  | otherwise =-      concat-        [ maybe [] (emitGuardDefinition aggregate index transition) (tGuard transition),-          concatMap (uncurry (emitWriteDefinition aggregate index transition)) (tWrites transition)-        ]--emitGuardDefinition :: Agg -> Int -> Transition -> Expr -> [Text]-emitGuardDefinition aggregate index transition expression =-  [ "",-    functionName <> " :: " <> payloadProjectionType aggregate transition <> " -> K.HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command",-    functionName <> " d = " <> renderKeikiPredicate aggregate transition resolved-  ]-  where-    functionName = guardFunctionName index transition-    resolved = expressionOrDie functionName (resolveGuardExpr (expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition) expression)--emitWriteDefinition :: Agg -> Int -> Transition -> Name -> Expr -> [Text]-emitWriteDefinition aggregate index transition registerName expression =-  [ "",-    functionName-      <> " :: "-      <> payloadProjectionType aggregate transition-      <> " -> K.Term "-      <> aName aggregate-      <> "Regs "-      <> aName aggregate-      <> "Command ("-      <> commandFieldsType transition-      <> ") "-      <> renderDomainType aggregate (typedScalarType resolved),-    functionName <> " d = " <> renderKeikiTerm aggregate transition resolved-  ]-  where-    functionName = writeFunctionName index transition registerName-    resolved = expressionOrDie functionName (resolveWriteExpr (expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition) registerName expression)--expressionOrDie :: Text -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr -> TypedScalarExpr-expressionOrDie owner = either (error . (("validated expression disappeared for " <> T.unpack owner <> ": ") <>) . show) id--renderKeikiPredicate :: Agg -> Transition -> TypedScalarExpr -> Text-renderKeikiPredicate aggregate transition expression = case typedScalarNode expression of-  TypedEqual left right -> "K.PEq " <> atom (renderComparisonTerm aggregate transition left) <> " " <> atom (renderComparisonTerm aggregate transition right)-  TypedNotEqual left right -> "K.pnot (K.PEq " <> atom (renderComparisonTerm aggregate transition left) <> " " <> atom (renderComparisonTerm aggregate transition right) <> ")"-  TypedCompare operator left right ->-    "K.PCmp "-      <> renderKeikiCmp operator-      <> " "-      <> atom (renderComparisonTerm aggregate transition left)-      <> " "-      <> atom (renderComparisonTerm aggregate transition right)-  TypedAnd left right -> "K.PAnd " <> atom (renderKeikiPredicate aggregate transition left) <> " " <> atom (renderKeikiPredicate aggregate transition right)-  TypedOr left right -> "K.POr " <> atom (renderKeikiPredicate aggregate transition left) <> " " <> atom (renderKeikiPredicate aggregate transition right)-  _ -> "K.PEq " <> atom (renderKeikiTerm aggregate transition expression) <> " (K.lit True)"-  where-    atom value = "(" <> value <> ")"--renderKeikiCmp :: CmpOp -> Text-renderKeikiCmp = \case-  OpEq -> error "equality is rendered as PEq"-  OpNeq -> error "inequality is rendered as pnot PEq"-  OpLt -> "K.CmpLt"-  OpLe -> "K.CmpLe"-  OpGt -> "K.CmpGt"-  OpGe -> "K.CmpGe"--renderComparisonTerm :: Agg -> Transition -> TypedScalarExpr -> Text-renderComparisonTerm aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of-  (AggregateNominal nominal, TypedRoot provenance)-    | ConsumerNominal {} <- resolvedNominalOwnership nominal,-      ScalarRepresentation {} <- resolvedNominalRepresentation nominal ->-        renderNominalProjectionTerm aggregate transition nominal provenance-  _ -> renderKeikiTerm aggregate transition expression--renderNominalProjectionTerm :: Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text-renderNominalProjectionTerm aggregate transition nominal provenance = case provenance of-  ScalarRegisterRoot registerName ownerType ->-    "K.regProj NominalProjections."-      <> witness-      <> " (#"-      <> registerName-      <> " :: K.Index "-      <> aName aggregate-      <> "Regs "-      <> renderDomainType aggregate ownerType-      <> ")"-  ScalarCommandRoot fieldName ownerType ->-    "K.inpProj NominalProjections."-      <> witness-      <> " inCtor"-      <> tCommand transition-      <> " (#"-      <> fieldName-      <> " :: K.Index ("-      <> commandFieldsType transition-      <> ") "-      <> renderDomainType aggregate ownerType-      <> ")"-  where-    witness = lowerFirst (resolvedNominalName nominal) <> "Witness"--renderKeikiTerm :: Agg -> Transition -> TypedScalarExpr -> Text-renderKeikiTerm aggregate transition expression = case typedScalarNode expression of-  TypedLiteral value -> renderKeikiLiteral aggregate (typedScalarType expression) value-  TypedRoot (ScalarRegisterRoot registerName _) -> "B.reg @" <> tshow registerName-  TypedRoot (ScalarCommandRoot fieldName _) -> "d." <> fieldName-  TypedProject provenance projection -> renderStructuralProjectionTerm aggregate transition provenance projection-  TypedAdd _ left right -> binary "K.tadd" left right-  TypedSubtract _ left right -> binary "K.tsub" left right-  TypedMultiply _ left right -> binary "K.tmul" left right-  TypedEqual {} -> impossiblePredicate-  TypedNotEqual {} -> impossiblePredicate-  TypedCompare {} -> impossiblePredicate-  TypedAnd {} -> impossiblePredicate-  TypedOr {} -> impossiblePredicate-  where-    binary operator left right = operator <> " " <> parenthesized left <> " " <> parenthesized right-    parenthesized = (\value -> "(" <> value <> ")") . renderKeikiTerm aggregate transition-    impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms"--renderStructuralProjectionTerm :: Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text-renderStructuralProjectionTerm aggregate transition provenance projection = case provenance of-  ScalarRegisterRoot registerName ownerType ->-    "K.regProj StructuralProjections."-      <> witness-      <> " (#"-      <> registerName-      <> " :: K.Index "-      <> aName aggregate-      <> "Regs "-      <> renderDomainType aggregate ownerType-      <> ")"-  ScalarCommandRoot fieldName ownerType ->-    "K.inpProj StructuralProjections."-      <> witness-      <> " inCtor"-      <> tCommand transition-      <> " (#"-      <> fieldName-      <> " :: K.Index ("-      <> commandFieldsType transition-      <> ") "-      <> renderDomainType aggregate ownerType-      <> ")"-  where-    witness = lowerFirst (projectionTag (unMappedKey (scalarProjectionOwner projection)) (scalarProjectionPointer projection)) <> "Witness"--renderKeikiLiteral :: Agg -> ResolvedAggregateType -> ScalarValue -> Text-renderKeikiLiteral aggregate scalarType = \case-  ScalarTextValue value -> "K.lit (" <> tshow value <> " :: Text)"-  ScalarIntValue value -> "K.lit (" <> tshow' value <> " :: Int)"-  ScalarIntegerValue value -> "K.lit (" <> T.pack (show value) <> " :: Integer)"-  ScalarNaturalValue value -> "K.lit (" <> T.pack (show value) <> " :: Natural)"-  ScalarBoolValue value -> "K.lit " <> if value then "True" else "False"-  ScalarTimeValue value -> "K.lit " <> renderRegisterInitial (InitialTime value)-  ScalarEnumValue typeName constructor -> case scalarType of-    AggregateNominal nominal -> case resolvedNominalOwnership nominal of-      GeneratedNominal -> "K.lit " <> constructor-      ConsumerNominal binding ->-        "K.lit (nominalFromRepresentation "-          <> unQualifiedValueName (consumerNominalBinding binding)-          <> " "-          <> nominalRepresentationModule (aContext aggregate) typeName-          <> "."-          <> constructor-          <> ")"-    _ -> error "validated enum literal lost its nominal type"-  ScalarIdValue typeName value -> case scalarType of-    AggregateNominal nominal -> case resolvedNominalOwnership nominal of-      GeneratedNominal -> "K.lit (" <> typeName <> " " <> tshow value <> ")"-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        IdRepresentation prefix ->-          "K.lit (nominalFromRepresentation "-            <> unQualifiedValueName (consumerNominalBinding binding)-            <> " (case KindID.parseText @"-            <> tshow prefix-            <> " "-            <> tshow value-            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\"))"-        _ -> error "validated ID literal lost its ID representation"-    _ -> error "validated ID literal lost its nominal type"--emitGeneratedTransducer :: Agg -> Text-emitGeneratedTransducer aggregate =-  nl $-    [ "{-# LANGUAGE BlockArguments #-}",-      "{-# LANGUAGE DataKinds #-}",-      "{-# LANGUAGE GADTs #-}",-      "{-# LANGUAGE OverloadedRecordDot #-}",-      "{-# LANGUAGE QualifiedDo #-}",-      "{-# LANGUAGE TypeApplications #-}",-      generatedBanner,-      "module " <> aGenPrefix aggregate <> ".Transducer",-      "  ( " <> lowerFirst (aName aggregate) <> "Transducer",-      "  , " <> lowerFirst (aName aggregate) <> "FoldFingerprint",-      "  , BehaviorOwnership (..)",-      "  , " <> lowerFirst (aName aggregate) <> "PredicateVerifications",-      "  ) where",-      "",-      "import " <> aGenPrefix aggregate <> ".Domain",-      "import " <> aHolePrefix aggregate <> ".Holes qualified as Holes",-      "import Data.Text (Text)",-      "import Keiki.Builder qualified as B",-      "import Keiki.Core (HsPred, SymTransducer)",-      "import Keiki.Core qualified as K",-      "import Keiki.Symbolic qualified as S"-    ]-      ++ ["import " <> aGenPrefix aggregate <> ".Expressions qualified as Expressions" | not (null (expressionFunctionNames aggregate))]-      ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate]-      ++ ["import Keiki.Builder ((=:))" | any (not . null . tWrites . snd) (transitionEntries aggregate)]-      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]-      ++ [ "",-           lowerFirst (aName aggregate) <> "Transducer",-           "  :: SymTransducer",-           "       (HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command)",-           "       " <> aName aggregate <> "Regs",-           "       " <> aVertexType aggregate,-           "       " <> aName aggregate <> "Command",-           "       " <> aName aggregate <> "Event",-           lowerFirst (aName aggregate) <> "Transducer =",-           "  B.buildTransducer " <> initialVertex aggregate <> " initial" <> aName aggregate <> "Regs isTerminal do",-           nl (concatMap (generatedFromBlock aggregate) (groupTransitionEntriesBySource aggregate)),-           " where",-           "  isTerminal = \\case",-           nl ["    " <> vertexCtor aggregate (stName state) <> " -> True" | state <- aStates aggregate, stTerminal state],-           "    _ -> False",-           "",-           lowerFirst (aName aggregate) <> "FoldFingerprint :: Text",-           lowerFirst (aName aggregate) <> "FoldFingerprint = " <> foldFingerprintExpression aggregate,-           "",-           "data BehaviorOwnership = GeneratedOwned | HoleOwned",-           "  deriving stock (Eq, Show)",-           "",-           "-- Every checked transition predicate is audited through Keiki's conservative",-           "-- symbolic verifier. Opaque Hole terms remain explicitly unverified.",-           lowerFirst (aName aggregate) <> "PredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]",-           lowerFirst (aName aggregate) <> "PredicateVerifications = sequence",-           nl (renderVerificationList aggregate),-           " where",-           "  verifyTransition label owner source edgeIndex =",-           "    case drop edgeIndex (K.edgesOut " <> lowerFirst (aName aggregate) <> "Transducer source) of",-           "      K.Edge predicate _ _ _ _ : _ -> (\\result -> (label, owner, result)) <$> S.verifyPredicate predicate",-           "      [] -> pure (label, owner, S.UnverifiedSolverFailure \"generated transition edge missing\")"-         ]--anyHoleOwned :: Agg -> Bool-anyHoleOwned = any ((== HoleImplementation) . tImplementation) . aTransitions--renderVerificationList :: Agg -> [Text]-renderVerificationList aggregate =-  [ (if listIndex == (0 :: Int) then "  [ " else "  , ")-      <> "verifyTransition "-      <> tshow (transitionStem transitionIndex transition)-      <> " "-      <> ownership-      <> " "-      <> vertexCtor aggregate source-      <> " "-      <> tshow' edgeIndex-  | (listIndex, (source, edgeIndex, transitionIndex, transition)) <- zip [0 ..] entries,-    let ownership = case tImplementation transition of-          GeneratedImplementation -> "GeneratedOwned"-          HoleImplementation -> "HoleOwned"-          LegacyHoleImplementation -> error "legacy transition reached version-2 verification generation"-  ]-    <> ["  ]"]-  where-    entries =-      [ (source, edgeIndex, transitionIndex, transition)-      | (source, transitions) <- groupTransitionEntriesBySource aggregate,-        (edgeIndex, (transitionIndex, transition)) <- zip [0 ..] transitions-      ]--foldFingerprintExpression :: Agg -> Text-foldFingerprintExpression aggregate = case holeVersions of-  [] -> tshow (aFoldFingerprint aggregate)-  _ ->-    "T.intercalate \"|\" ("-      <> tshow (aFoldFingerprint aggregate)-      <> " : [foldToken "-      <> T.intercalate ", foldToken " holeVersions-      <> "] ) where foldToken (FoldVersion token) = T.pack (show (T.length token)) <> \":\" <> token"-  where-    holeVersions =-      [ "Holes." <> holeFoldVersionName index transition-      | (index, transition) <- transitionEntries aggregate,-        tImplementation transition == HoleImplementation-      ]--groupTransitionEntriesBySource :: Agg -> [(Text, [(Int, Transition)])]-groupTransitionEntriesBySource aggregate = go [] (transitionEntries aggregate)-  where-    go accumulated [] = reverse accumulated-    go accumulated (entry@(_, transition) : remaining) =-      let source = tSource transition-          (same, rest) = span ((== source) . tSource . snd) remaining-       in go ((source, entry : same) : accumulated) rest--generatedFromBlock :: Agg -> (Text, [(Int, Transition)]) -> [Text]-generatedFromBlock aggregate (source, transitions) =-  ["    B.from " <> vertexCtor aggregate source <> " do"]-    ++ concatMap (uncurry (generatedOnCmdBlock aggregate)) transitions--generatedOnCmdBlock :: Agg -> Int -> Transition -> [Text]-generatedOnCmdBlock aggregate index transition =-  ["      B.onCmd inCtor" <> tCommand transition <> " $ \\d -> B.do"]-    ++ ["        B.replayOnly" | tMode transition == TmReplayOnly]-    ++ generatedBehavior-    ++ outputLines-    ++ ["        B.noEmit" | null (tEmits transition)]-    ++ ["        B.goto " <> vertexCtor aggregate (tGoto transition)]-  where-    generatedBehavior = case tImplementation transition of-      GeneratedImplementation ->-        maybe [] (const ["        B.requireGuard (Expressions." <> guardFunctionName index transition <> " d)"]) (tGuard transition)-          ++ [ "        B.slot @" <> tshow registerName <> " =: Expressions." <> writeFunctionName index transition registerName <> " d"-             | (registerName, _) <- tWrites transition-             ]-      HoleImplementation -> ["        Holes." <> holeFunctionName index transition <> " d"]-      LegacyHoleImplementation -> error "legacy transition reached version-2 transducer generation"-    outputLines =-      [ "        B.emit wire"-          <> eventName-          <> " (Holes."-          <> outputFunctionName index transition emitIndex eventName-          <> " d)"-      | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)-      ]------------------------------------------------------------------------------------- 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)",-           transducerImport a,-           "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, withFoldFingerprint)" | 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-         ]-      ++ stateCodecFieldLines 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 (withFoldFingerprint "-      <> foldFingerprintValue aggregate-      <> " (defaultStateCodec "-      <> tshow' (snapCodecVersion snapshot)-      <> "))"--transducerImport :: Agg -> Text-transducerImport aggregate-  | hasVersion2Ownership aggregate =-      "import "-        <> aGenPrefix aggregate-        <> ".Transducer ("-        <> lowerFirst (aName aggregate)-        <> "FoldFingerprint, "-        <> lowerFirst (aName aggregate)-        <> "Transducer)"-  | otherwise =-      "import "-        <> aHolePrefix aggregate-        <> ".Holes ("-        <> lowerFirst (aName aggregate)-        <> "Transducer)"--foldFingerprintValue :: Agg -> Text-foldFingerprintValue aggregate-  | hasVersion2Ownership aggregate = lowerFirst (aName aggregate) <> "FoldFingerprint"-  | otherwise = tshow (aFoldFingerprint aggregate)--stateCodecFieldLines :: Agg -> [Text]-stateCodecFieldLines aggregate = case aSnapshot aggregate of-  Nothing -> ["    , stateCodec = Nothing"]-  Just _-    | hasVersion2Ownership aggregate ->-        [ "    -- The snapshot discriminator composes: the spec's state-codec version (bump it",-          "    -- in the spec's `state-codec version=` clause), keiki's register and",-          "    -- control-state shape hashes, and this fold fingerprint derived from the",-          "    -- spec's transition surface (guards, writes, emits, states, register",-          "    -- initials, referenced rules). Spec-visible fold changes invalidate old",-          "    -- snapshots automatically. Version-2 Hole-owned transitions additionally",-          "    -- compose their explicit hand-owned FoldVersion tokens here; bump the",-          "    -- corresponding token whenever that Hole behavior changes.",-          "    , stateCodec = " <> stateCodecExpr aggregate-        ]-    | otherwise ->-        [ "    -- The snapshot discriminator composes: the spec's state-codec version (bump it",-          "    -- in the spec's `state-codec version=` clause), keiki's register and",-          "    -- control-state shape hashes, and this fold fingerprint derived from the",-          "    -- spec's transition surface (guards, writes, emits, states, register",-          "    -- initials, referenced rules). Spec-visible fold changes invalidate old",-          "    -- snapshots automatically. Fold changes made ONLY in the hand-owned Holes",-          "    -- module are invisible here: bump `state-codec version=` manually or old",-          "    -- snapshots will be served stale.",-          "    , stateCodec = " <> stateCodecExpr aggregate-        ]--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 #-}",-        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 aggregate-  | hasVersion2Ownership aggregate = emitVersion2Holes aggregate-  | otherwise = emitLegacyHoles aggregate--emitLegacyHoles :: Agg -> Text-emitLegacyHoles 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-    ]--emitVersion2Holes :: Agg -> Text-emitVersion2Holes aggregate =-  nl $-    [ "{-# LANGUAGE BlockArguments #-}",-      "{-# LANGUAGE DataKinds #-}",-      "{-# LANGUAGE DuplicateRecordFields #-}",-      "{-# LANGUAGE OverloadedRecordDot #-}",-      "{-# LANGUAGE QualifiedDo #-}",-      "{-# LANGUAGE TypeApplications #-}",-      "-- This is a HAND-OWNED version-2 hook module. keiro-dsl creates it once",-      "-- and never overwrites it. Generated code owns every transition envelope",-      "-- and every declared guard/write; this module supplies event fields and",-      "-- explicitly selected Hole behavior only."-    ]-      ++ version2HoleModuleDeclaration aggregate-      ++ [ "",-           "import " <> aGenPrefix aggregate <> ".Domain",-           "import Keiki.Builder qualified as B",-           "import Keiki.Generics (RegFieldsOf)",-           holeUpcasterImports aggregate,-           holeProjectionImports aggregate-         ]-      ++ ["import Keiki.Core qualified as K" | anyHoleOwned aggregate || anyZeroFieldOutput aggregate]-      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]-      ++ concatMap (uncurry (emitOutputHooks aggregate)) (transitionEntries aggregate)-      ++ concatMap (uncurry (emitHoleImplementation aggregate)) (transitionEntries aggregate)-      ++ [holeProjectionStub aggregate, holeUpcasterStubs aggregate]--anyZeroFieldOutput :: Agg -> Bool-anyZeroFieldOutput aggregate =-  any (null . rcFields . eventForName aggregate) (concatMap tEmits (aTransitions aggregate))--version2HoleModuleDeclaration :: Agg -> [Text]-version2HoleModuleDeclaration aggregate = case version2HoleExports aggregate of-  [] -> ["module " <> aHolePrefix aggregate <> ".Holes () where"]-  firstExport : rest ->-    [ "module " <> aHolePrefix aggregate <> ".Holes",-      "  ( " <> firstExport-    ]-      ++ ["  , " <> value | value <- rest]-      ++ ["  ) where"]--version2HoleExports :: Agg -> [Text]-version2HoleExports aggregate =-  outputExports-    <> holeExports-    <> projectionExports-    <> [functionName | (_, _, functionName) <- upcasterEntries aggregate]-  where-    outputExports =-      [ outputFunctionName transitionIndex transition emitIndex eventName-      | (transitionIndex, transition) <- transitionEntries aggregate,-        (emitIndex, eventName) <- zip [1 ..] (tEmits transition)-      ]-    holeExports =-      concat-        [ [holeFunctionName index transition, holeFoldVersionName index transition]-        | (index, transition) <- transitionEntries aggregate,-          tImplementation transition == HoleImplementation-        ]-    projectionExports = case aProjection aggregate of-      Nothing -> []-      Just projection -> ["apply" <> pascal (projTable projection)]--emitOutputHooks :: Agg -> Int -> Transition -> [Text]-emitOutputHooks aggregate transitionIndex transition =-  concat-    [ emitOutputHook aggregate transitionIndex transition emitIndex (eventForName aggregate eventName)-    | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+    generatedNominalModule,+    NominalUseSite (..),+    NominalGenerationOwner (..),+    planNominalGeneration,+    planNominalGenerationForService,+    generatedNominalsInTypes,+    generatedNominalTypeImports,+    generatedNominalTypeImportsForService,+    generatedIdSampleHaskell,+    scaffoldReplayAudit,+    scaffoldStructural,+    scaffoldStructuralForService,+    scaffoldStructuralOwners,+    scaffoldStructuralOwnersForService,+    codecComparisonModule,+    codecComparisonBanner,+    bindingSkeletonModules,+    bindingSkeletonOwners,+    scaffoldAggregateForService,+    scaffoldAggregate,+    obsoleteGeneratedOutputHooks,+    scaffoldProcess,+    scaffoldRouter,+    scaffoldContract,+    scaffoldIntake,+    scaffoldPublisher,+    scaffoldWorkqueue,+    scaffoldReadModel,+    scaffoldRefusals,+    windowSeconds,++    -- * Firewall self-check (M3)+    FirewallSurface (..),+    firewallSurface,+    firewallBreaches,++    -- * Internal resolution, shared with "Keiro.Dsl.Harness"+    Agg (..),+    aggregateCheckedService,+    ResolvedRegister (..),+    ResolvedCtor (..),+    StructuralProjection (..),+    resolveAggForService,+    resolveAgg,+    nominalEqualityUsedInGeneratedExpressions,+    projectionSpecs,+    resolveProjectionModules,+    nominalProjectionModule,+    codecMappedDeclarations,+    FieldCat (..),+    fieldCat,+    vertexCtor,+    initialVertex,+    firstEnumCtor,+    lowerFirst,+    pascal,+    pascalFromKebab,+    generatedBanner,+  )+where++import Data.Char (isAlpha, isAlphaNum, isUpper, ord, toLower, toUpper)+import Data.List (find, findIndex, groupBy, isSuffixOf, nub, sort, sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.AggregateType+import Keiro.Dsl.BehaviorCoverage qualified as Behavior+import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..))+import Keiro.Dsl.EventOutput+import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations)+import Keiro.Dsl.Expression+import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprintForService)+import Keiro.Dsl.Grammar+import Keiro.Dsl.IdDomain (IdDomainContract, idDomainContractFor, idDomainPrefix, idDomainSampleText)+import Keiro.Dsl.NominalType+import Keiro.Dsl.PrettyPrint (renderExpr)+import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)+import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, legacyCheckedService)+import Keiro.Dsl.TypeGraph+import Keiro.Dsl.Validate (sagaCategoryError)+import Numeric (showHex)+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,+    -- | @""@ means no namespace prefix (the historical default).+    moduleRoot :: !Text,+    -- | 'GeneratedPrefix' is the historical default.+    placement :: !Placement+  }+  deriving stock (Eq, Show)++-- | One aggregate-level reason a generated nominal declaration must be visible.+-- The declaration itself is context-owned; these use sites determine the+-- aggregate modules that import it.+data NominalUseSite = NominalUseSite+  { nominalUseAggregate :: !Name,+    nominalUseKind :: !AggregateUseSite+  }+  deriving stock (Eq, Ord, Show)++-- | The checked generation owner for one unbound ID or enum. Every owner in a+-- service points at the same context-level module, while retaining its source+-- location through 'ResolvedNominalType' and all aggregate use sites explicitly.+data NominalGenerationOwner = NominalGenerationOwner+  { nominalDeclaration :: !ResolvedNominalType,+    nominalModule :: !Text,+    nominalUseSites :: !(Set.Set NominalUseSite),+    nominalEqualityUsed :: !Bool+  }+  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 one context-level Haskell owner for generated IDs and enums.+generatedNominalModule :: Context -> Text+generatedNominalModule ctx = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominals"+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Nominals"++-- | 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 validate, step, and replay filled holes register by register.+      restrictedImports =+        [ ( "Keiki.Core",+            [ "RegFile",+              "HsPred",+              "FieldProjection",+              "ExactFieldProjection",+              "FieldWitness",+              "fieldWitness",+              "exactFieldWitness",+              "fieldWitnessAgrees",+              "applyEventsEither",+              "defaultValidationOptions",+              "step",+              "validateTransducer",+              "EdgeMode",+              "EdgeRef",+              "StepSuccess",+              "StepFailure",+              "ReplayEventSpan",+              "ReplayAttribution",+              "ReplaySuccess",+              "applyEventsDetailedEither",+              "stepDetailedEither",+              "!"+            ]+          )+        ]+    }++-- | 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,+    not (authoritativeScalarModule (modulePath m)),+    (n, line) <- zip [1 ..] (T.lines (moduleText m)),+    breach <- lineBreaches line+  ]++-- Version-2 aggregate expression and transducer modules are the narrow,+-- intentional exception to the generated symbolic-operator firewall: they+-- are precisely the generated authority that constructs Keiki terms. Every+-- other generated module remains subject to the original firewall.+authoritativeScalarModule :: FilePath -> Bool+authoritativeScalarModule path =+  any (`isSuffixOf` path) ["/Expressions.hs", "/Transducer.hs"]++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,+    aLanguageContract :: !EffectiveLanguageContract,+    aSpec :: !Spec,+    aAggregate :: !Aggregate,+    aCtxPascal :: !Text,+    aName :: !Text,+    aLoc :: !Loc,+    aVertexType :: !Text,+    aIds :: ![IdDecl],+    aEnums :: ![EnumDecl],+    aRegs :: ![ResolvedRegister],+    aStates :: ![StateDecl],+    aCommands :: ![ResolvedCtor],+    aEvents :: ![ResolvedCtor],+    -- | Generated IDs and enums used by this aggregate, in stable name order.+    aGeneratedNominals :: ![ResolvedNominalType],+    aTransitions :: ![Transition],+    aOutputMappings :: !(Map.Map (Int, Int) EventOutputMapping),+    aWire :: !WireSpec,+    aProjection :: !(Maybe ProjectionSpec),+    aSnapshot :: !(Maybe SnapshotSpec),+    aFoldFingerprint :: !Text,+    aReadModels :: ![ReadModelNode],+    aTypeGraph :: !(Maybe TypeGraph),+    aSymbols :: !AggregateSymbols,+    -- | e.g. @Generated.HospitalCapacity.Reservation@+    aGenPrefix :: !Text,+    -- | e.g. @HospitalCapacity.Reservation@+    aHolePrefix :: !Text+  }++aggregateCheckedService :: Agg -> CheckedService+aggregateCheckedService aggregate =+  CheckedService+    { checkedLanguageContract = aLanguageContract aggregate,+      checkedSpec = aSpec aggregate+    }++data ResolvedRegister = ResolvedRegister+  { rrName :: !Name,+    rrType :: !ResolvedAggregateType,+    rrInitial :: !ResolvedRegisterInitial,+    rrLoc :: !Loc+  }+  deriving stock (Eq, Show)++-- | A command or event constructor with its fully-resolved field types.+data ResolvedCtor = ResolvedCtor+  { rcName :: !Text,+    -- | (field name, canonical aggregate type)+    rcFields :: ![(Text, ResolvedAggregateType)],+    -- | EP-2: schema version (1 for commands and unversioned events).+    rcVersion :: !Int,+    -- | EP-2: the source version this event migrates from (the upcaster step).+    rcUpcastFrom :: !(Maybe Int)+  }++defaultWire :: WireSpec+defaultWire = WireSpec {wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1}++resolveAgg :: Context -> Spec -> Aggregate -> Agg+resolveAgg ctx spec = resolveAggForService ctx (legacyCheckedService spec)++-- | Resolve one aggregate under the service's effective runtime semantics.+resolveAggForService :: Context -> CheckedService -> Aggregate -> Agg+resolveAggForService ctx service agg =+  Agg+    { aContext = ctx,+      aLanguageContract = checkedLanguageContract service,+      aSpec = spec,+      aAggregate = agg,+      aCtxPascal = ctxPascal,+      aName = nm,+      aLoc = aggLoc agg,+      aVertexType = vertexType,+      aIds = specIds spec,+      aEnums = specEnums spec,+      aRegs = map resolveRegister (aggRegs agg),+      aStates = aggStates agg,+      aCommands = map resolveCommand (aggCommands agg),+      aEvents = map resolveEvent (aggEvents agg),+      aGeneratedNominals = generatedNominalsInTypes aggregateResolvedTypes,+      aTransitions = aggTransitions agg,+      aOutputMappings =+        Map.fromList+          [ ( (transitionIndex, emitIndex),+              orDieOutput (eventOutputMapping spec agg transition emitIndex eventName)+            )+          | (transitionIndex, transition) <- zip [1 ..] (aggTransitions agg),+            (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+          ],+      aWire = fromMaybe defaultWire (aggWire agg),+      aProjection = aggProjection agg,+      aSnapshot = aggSnapshot agg,+      aFoldFingerprint = aggregateFoldFingerprintForService service agg,+      aReadModels = [readModel | NReadModel readModel <- specNodes spec],+      aTypeGraph = either (const Nothing) Just (resolveTypeGraph spec),+      aSymbols = symbols,+      aGenPrefix = genPrefixFor ctx nm,+      aHolePrefix = holePrefixFor ctx nm+    }+  where+    spec = checkedSpec service+    nm = aggName agg+    symbols = aggregateSymbols spec+    ctxPascal = pascalFromKebab (contextName ctx)+    vertexType = nm <> "Vertex"+    commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg]+    resolveCommand c = (mkCtor CommandFieldUse (cmdName c) (cmdFields c)) {rcVersion = 1, rcUpcastFrom = Nothing}+    resolveEvent e =+      (mkCtor EventFieldUse (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 useSite cn fs =+      ResolvedCtor+        { rcName = cn,+          rcFields = map (\field -> (aggregateFieldName field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,+          rcVersion = 1,+          rcUpcastFrom = Nothing+        }+    aggregateResolvedTypes =+      map rrType (map resolveRegister (aggRegs agg))+        <> map snd (concatMap rcFields (map resolveCommand (aggCommands agg)))+        <> map snd (concatMap rcFields (map resolveEvent (aggEvents agg)))+    resolveRegister register =+      let resolvedType = orDie (resolveAggregateType symbols (regLoc register) RegisterUse (regType register))+          resolvedInitial = orDie (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register))+       in ResolvedRegister+            { rrName = regName register,+              rrType = resolvedType,+              rrInitial = resolvedInitial,+              rrLoc = regLoc register+            }+    orDie = either (error . ("validated aggregate resolution failed: " <>) . show) id+    orDieOutput = either (error . ("validated aggregate output resolution failed: " <>) . show) id++-- | Keep only generated nominal IDs/enums from a resolved aggregate type list.+-- The map both deduplicates and makes declaration/import order independent of+-- member and field order.+generatedNominalsInTypes :: [ResolvedAggregateType] -> [ResolvedNominalType]+generatedNominalsInTypes resolvedTypes =+  Map.elems . Map.fromList $+    [ (resolvedNominalName nominal, nominal)+    | AggregateNominal nominal <- resolvedTypes,+      GeneratedNominal <- [resolvedNominalOwnership nominal]+    ]++-- | Plan declaration ownership and use closure without emitting text. Parsing+-- and validation already reject malformed declarations; retaining the checked+-- error here keeps this function total for direct library callers.+planNominalGeneration :: Context -> Spec -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner]+planNominalGeneration ctx spec = planNominalGenerationForService ctx (legacyCheckedService spec)++planNominalGenerationForService :: Context -> CheckedService -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner]+planNominalGenerationForService ctx service = do+  registry <- resolveNominalTypes spec+  let aggregates = [resolveAggForService ctx service aggregate | NAggregate aggregate <- specNodes spec]+      generated =+        [ nominal+        | nominal <- Map.elems (nominalTypes registry),+          GeneratedNominal <- [resolvedNominalOwnership nominal]+        ]+  pure+    [ NominalGenerationOwner+        { nominalDeclaration = nominal,+          nominalModule = generatedNominalModule ctx,+          nominalUseSites = Set.fromList (concatMap (usesFor nominal) aggregates),+          nominalEqualityUsed = any (nominalEqualityUsedInGeneratedExpressions nominal) aggregates+        }+    | nominal <- generated+    ]+  where+    spec = checkedSpec service+    usesFor nominal aggregate =+      [ NominalUseSite (aName aggregate) useKind+      | useKind <- aggregateUseKinds nominal aggregate+      ]++nominalEqualityUsedInGeneratedExpressions :: ResolvedNominalType -> Agg -> Bool+nominalEqualityUsedInGeneratedExpressions nominal aggregate =+  any (anyTypedExpression comparesNominal) (resolvedGeneratedExpressions aggregate)+  where+    comparesNominal expression = case typedScalarNode expression of+      TypedEqual left _ -> typedScalarType left == AggregateNominal nominal+      TypedNotEqual left _ -> typedScalarType left == AggregateNominal nominal+      _ -> False++aggregateUseKinds :: ResolvedNominalType -> Agg -> [AggregateUseSite]+aggregateUseKinds nominal aggregate =+  nub $+    [RegisterUse | nominal `elem` registerNominals]+      <> [CommandFieldUse | nominal `elem` commandNominals]+      <> [EventFieldUse | nominal `elem` eventNominals]+      <> [CodecUse | nominal `elem` eventNominals]+      <> [SnapshotUse | hasSnapshot aggregate && nominal `elem` registerNominals]+      <> [HarnessSampleUse | nominal `elem` commandNominals || nominal `elem` eventNominals]+      <> [HaskellLoweringUse | nominal `elem` aGeneratedNominals aggregate]+  where+    registerNominals = generatedNominalsInTypes (map rrType (aRegs aggregate))+    commandNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aCommands aggregate)))+    eventNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aEvents aggregate)))++--------------------------------------------------------------------------------+-- Entry point+--------------------------------------------------------------------------------++-- | Emit the context-level private structural stratum. Shape modules contain+-- only generated wire representations. The projection facade contains only+-- schema-derived Keiki field witnesses; neither layer owns consumer behavior.+scaffoldStructural :: Context -> Spec -> [ScaffoldModule]+scaffoldStructural ctx spec = scaffoldStructuralForService ctx (legacyCheckedService spec)++scaffoldStructuralForService :: Context -> CheckedService -> [ScaffoldModule]+scaffoldStructuralForService ctx service = map fst (scaffoldStructuralOwnersForService ctx service)++-- | 'scaffoldStructural' paired with the mapped declarations each module was+-- emitted for. A shape module names exactly one declaration; a binding skeleton+-- names every declaration whose obligations it carries (several declarations may+-- share one leaf binding module); the projection facade names __none__, because it+-- is emitted once for the whole context from the complete resolved graph.+--+-- This is the attribution seam whole-workspace scaffolding needs: a workspace+-- emits from one merged spec, and this list says which declaration — and therefore+-- which member file — produced each structural module, without parsing the+-- human-readable 'origin' string.+scaffoldStructuralOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]+scaffoldStructuralOwners ctx spec = scaffoldStructuralOwnersForService ctx (legacyCheckedService spec)++scaffoldStructuralOwnersForService :: Context -> CheckedService -> [(ScaffoldModule, [Name])]+scaffoldStructuralOwnersForService ctx service = case resolveTypeGraph (checkedSpec service) of+  Left _ -> []+  Right graph ->+    [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural]+      <> projectionModules+      <> generatedNominalOwners ctx service+      <> nominalRepresentationOwners ctx spec+      <> nominalProjectionOwners ctx service+      <> bindingSkeletonOwners ctx spec graph+    where+      structural =+        [ (declaration, shape)+        | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)+        ]+      projectionModules =+        [ ( ScaffoldModule+              { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"),+                moduleText = emitStructuralProjections ctx graph,+                kind = Generated,+                origin = "context " <> specContext spec <> " mapped structural facade"+              },+            []+          )+        | not (null (projectionSpecs graph))+        ]+      spec = checkedSpec service++-- | Plan one opt-in, non-production historical-codec comparison module.+--+-- The module is intentionally absent from 'scaffoldStructural' and therefore+-- from production manifests and scaffold records. It must be requested by name+-- and is compiled only by consumer-owned test/tool components.+codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule+codecComparisonModule ctx spec requestedName = do+  graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec)+  (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of+    Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName)+    Just (ResolvedOpaque _) ->+      Left+        ( "codec comparison target "+            <> requestedName+            <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim"+        )+    Just (ResolvedStructural declaration shape) -> Right (declaration, shape)+  owner <- case sortOn aggName (comparisonOwners declaration) of+    [] ->+      Left+        ( "codec comparison target "+            <> requestedName+            <> " is not reachable from a persisted private event payload"+        )+    aggregate : _ -> Right aggregate+  let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName+  pure+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+        moduleText = emitCodecComparison ctx moduleName graph declaration shape owner,+        kind = Generated,+        origin = "non-production codec comparison " <> requestedName+      }+  where+    comparisonOwners declaration =+      [ aggregate+      | NAggregate aggregate <- specNodes spec,+        let resolved = resolveAgg ctx spec aggregate,+        any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved)+      ]+      where+        mappedName (ResolvedStructural structural _) = sdName structural+        mappedName (ResolvedOpaque opaque) = odName opaque++codecComparisonBanner :: Text+codecComparisonBanner =+  "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit."++emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text+emitCodecComparison ctx moduleName graph declaration shape owner =+  nl+    [ "",+      codecComparisonBanner,+      "-- This module compares historical and generated codecs in consumer-owned tests only.",+      "-- It is never a runtime fallback and never changes the generated codec's authority.",+      "module " <> moduleName <> " (compareWithHistorical) where",+      "",+      "import Control.Monad (filterM)",+      "import Data.Aeson (Value)",+      "import Data.Aeson qualified as Aeson",+      "import Data.List (sort)",+      "import Data.List.NonEmpty qualified as NonEmpty",+      "import Data.Text (Text)",+      "import Data.Text qualified",+      "import " <> codecModule <> " qualified as GeneratedCodec",+      "import Keiro.Codec.Structural (FixtureCases (..))",+      "import Keiro.Dsl.CodecCompare",+      "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))",+      "import System.Directory (doesFileExist, listDirectory)",+      "import System.FilePath (takeExtension, (</>))",+      "",+      "import " <> fixtureModule <> " qualified as ConsumerFixtures",+      "import " <> hsModule (sdHaskell declaration) <> " qualified as ConsumerDomain",+      "",+      "compareWithHistorical :: HistoricalCodec " <> domainType <> " -> FilePath -> IO CompareReport",+      "compareWithHistorical historicalCodec goldenDirectory = do",+      "  names <- sort . filter ((== \".json\") . takeExtension) <$> listDirectory goldenDirectory",+      "  files <- filterM doesFileExist [goldenDirectory </> name | name <- names]",+      "  loaded <- traverse (loadGolden historicalCodec) files",+      "  let inputIssues = [issue | Left issue <- loaded]",+      "      entries = [entry | Right entry <- loaded]",+      "      typedCases = NonEmpty.toList (fixtureCases ConsumerFixtures." <> fixtureSymbol <> ")",+      "      encodeObservations =",+      "        [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encode" <> name <> "Mapped value)",+      "        | (label, value) <- typedCases",+      "        ]",+      "      decodeObservations = [observation | (observation, _) <- entries]",+      "      typedObserved =",+      "        concat",+      "          [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encode" <> name <> "Mapped value)",+      "          | (_, value) <- typedCases",+      "          ]",+      "      historicalObserved =",+      "        concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values]",+      "      declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema",+      "      provenance =",+      "        CompareProvenance",+      "          { cpHistoricalCodecIdentity = hcIdentity historicalCodec",+      "          , cpHistoricalCodecVersion = hcVersion historicalCodec",+      "          , cpCanonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId (sdCanonical declaration)),+      "          , cpBindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName (sdBinding declaration)),+      "          , cpBindingVersion = BindingVersion " <> tshow (unBindingVersion (sdBindingVersion declaration)),+      "          , cpWireFingerprint = " <> tshow (wireFingerprint graph name),+      "          }",+      "  pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved))",+      "",+      "loadGolden :: HistoricalCodec " <> domainType <> " -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value]))",+      "loadGolden historicalCodec path = do",+      "  decoded <- Aeson.eitherDecodeFileStrict path",+      "  pure $ case decoded of",+      "    Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason))",+      "    Right inputValue ->",+      "      let historicalDecoded = hcDecode historicalCodec inputValue",+      "          historicalOutcome = normalizeDecode historicalDecoded",+      "          generatedOutcome = normalizeDecode (GeneratedCodec.decode" <> name <> "Mapped inputValue)",+      "          observation = DecodeObservation path inputValue historicalOutcome generatedOutcome",+      "          coveredValues = case historicalDecoded of",+      "            Right value -> [inputValue, GeneratedCodec.encode" <> name <> "Mapped value]",+      "            Left _ -> []",+      "       in Right (observation, coveredValues)",+      "",+      "normalizeDecode :: Either Text " <> domainType <> " -> DecodeOutcome",+      "normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encode" <> name <> "Mapped)",+      "",+      "fromString :: String -> Text",+      "fromString = Data.Text.pack",+      "",+      "branchSchema :: BranchSchema",+      "branchSchema = " <> renderBranchSchema (branchSchemaFor graph (ResolvedStructural declaration shape))+    ]+  where+    name = sdName declaration+    domainType = "ConsumerDomain." <> hsType (sdHaskell declaration)+    codecModule = genPrefixFor ctx (aggName owner) <> ".Codec"+    fixtureModule = qualifiedModule (sdFixtures declaration)+    fixtureSymbol = lastSegment (unQualifiedValueName (sdFixtures declaration))++branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema+branchSchemaFor graph =+  foldMappedDecl+    MappedDeclAlgebra+      { onStructuralDecl = \_ shape ->+          foldMappedShape+            MappedShapeAlgebra+              { onRecord = \_ _ fields ->+                  BranchRecord+                    [ BranchField+                        (rwfKey field)+                        (rwfPresence field == POptional)+                        (branchExpr graph (rwfType field))+                    | field <- fields+                    ],+                onEnum = const BranchScalar,+                onUnion = \encoding arms ->+                  BranchUnion+                    (ueTagField encoding)+                    (ueContentsField encoding)+                    [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms]+              }+            shape,+        onOpaqueDecl = const BranchScalar+      }++branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema+branchExpr graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = BranchScalar,+        onInt = BranchScalar,+        onInteger = BranchScalar,+        onBool = BranchScalar,+        onNatural = BranchScalar,+        onTime = BranchScalar,+        onJson = BranchScalar,+        onOptional = BranchOptional,+        onList = BranchList,+        onMap = BranchMap,+        onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph))+      }++renderBranchSchema :: BranchSchema -> Text+renderBranchSchema schema = case schema of+  BranchScalar -> "BranchScalar"+  BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")"+  BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")"+  BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")"+  BranchRecord fields ->+    "BranchRecord ["+      <> T.intercalate+        ", "+        [ "BranchField "+            <> tshow (bfWireKey field)+            <> " "+            <> (if bfPresenceOptional field then "True" else "False")+            <> " ("+            <> renderBranchSchema (bfSchema field)+            <> ")"+        | field <- fields+        ]+      <> "]"+  BranchUnion tagField contentsField arms ->+    "BranchUnion "+      <> tshow tagField+      <> " "+      <> tshow contentsField+      <> " ["+      <> T.intercalate+        ", "+        [ "BranchArm "+            <> tshow (baWireTag arm)+            <> " "+            <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm)+        | arm <- arms+        ]+      <> "]"++-- | Emit one create-once consumer module per distinct qualified obligation+-- owner. Multiple mapped declarations may intentionally share a leaf binding+-- module, so grouping happens by module rather than by declaration.+bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule]+bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph)++-- | 'bindingSkeletonModules' paired with the mapped declarations whose+-- obligations each skeleton carries, in first-appearance order. A skeleton shared+-- by declarations from different member files therefore names all of them, which+-- is what lets whole-workspace scaffolding treat it as context-level rather than+-- attributing it to an arbitrary member.+bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])]+bindingSkeletonOwners ctx spec graph = case bindingObligations spec of+  Left _ -> []+  Right obligations ->+    [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries))+    | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations])+    ]++emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule+emitBindingSkeleton ctx spec graph owner obligations =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"),+      moduleText =+        nl $+          [ "{-# LANGUAGE DataKinds #-}",+            "{-# LANGUAGE LambdaCase #-}",+            "",+            "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once",+            "-- and never overwrites it. Fill each HOLE and run the generated harness.",+            "module " <> owner <> " ("+          ]+            <> exportLines+            <> [") where", ""]+            <> map ("import " <>) imports+            <> [""]+            <> intercalateBlank (map renderObligation obligations),+      kind = HoleStub,+      origin = "consumer binding skeleton " <> owner+    }+  where+    exportLines =+      [ (if index == (0 :: Int) then "    " else "  , ") <> obligationSymbol obligation+      | (index, obligation) <- zip [0 ..] obligations+      ]+    imports =+      sort . nub $+        [ hsModule (sdHaskell declaration) <> " qualified"+        | obligation <- obligations,+          Just (declaration, _) <- [structuralFor obligation]+        ]+          <> [ structuralShapeModule ctx (sdName declaration) <> " qualified"+             | obligation <- obligations,+               obligationKind obligation == BindingValue,+               Just (declaration, _) <- [structuralFor obligation]+             ]+          <> [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))"+             | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations+             ]+          <> [ hsModule (consumerNominalHaskell binding) <> " qualified"+             | obligation <- obligations,+               Just (_, binding) <- [nominalFor obligation]+             ]+          <> [ nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified"+             | obligation <- obligations,+               obligationKind obligation == BindingValue,+               Just (nominal, _) <- [nominalFor obligation],+               EnumRepresentation {} <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Keiro.Codec.Nominal (NominalBinding (..), NominalFixtureCases)"+             | any ((/= "structural") . obligationCategory) obligations+             ]+          <> [ "Data.KindID (KindID)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               IdRepresentation {} <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Data.Text (Text)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalText <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Data.Time (UTCTime)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalTime <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Numeric.Natural (Natural)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalNatural <- [resolvedNominalRepresentation nominal]+             ]+    renderObligation obligation = case structuralFor obligation of+      Nothing -> case nominalFor obligation of+        Just (nominal, _) -> renderNominalObligation nominal obligation+        Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"]+      Just (declaration, shape) -> case obligationKind obligation of+        BindingValue -> renderBinding ctx declaration shape obligation+        FixtureValue ->+          [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration,+            obligationSignature obligation,+            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures")+          ]+        InitialValue ->+          [ "-- HOLE: provide the initial register value for " <> sdName declaration,+            obligationSignature obligation,+            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " initial value")+          ]+    structuralFor obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of+      Just (ResolvedStructural declaration shape) -> Just (declaration, shape)+      _ -> Nothing+    nominalFor obligation = do+      registry <- either (const Nothing) Just (resolveNominalTypes spec)+      nominal <- lookupNominalType (obligationMappedName obligation) registry+      binding <- case resolvedNominalOwnership nominal of+        ConsumerNominal value -> Just value+        GeneratedNominal -> Nothing+      pure (nominal, binding)+    renderNominalObligation nominal obligation = case obligationKind obligation of+      BindingValue ->+        [ "-- HOLE: complete both total directions; the generated codec remains wire authority.",+          obligationSignature obligation,+          obligationSymbol obligation <> " =",+          "  NominalBinding",+          "    { nominalToRepresentation = \\_domainValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalToRepresentation"),+          "    , nominalFromRepresentation = \\_representationValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalFromRepresentation"),+          "    }"+        ]+      FixtureValue ->+        [ "-- HOLE: provide deterministic labelled expected-wire fixtures for " <> resolvedNominalName nominal,+          obligationSignature obligation,+          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures")+        ]+      InitialValue ->+        [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal,+          obligationSignature obligation,+          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value")+        ]+    intercalateBlank [] = []+    intercalateBlank (section : rest) = section <> concatMap ("" :) rest++renderBinding :: Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text]+renderBinding ctx declaration shape obligation =+  [ "-- HOLE: complete both total directions; wire policy remains in the generated codec.",+    obligationSymbol obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType,+    obligationSymbol obligation <> " =",+    "  StructuralBinding",+    "    { bindingToShape = \\case"+  ]+    <> indentCases (bindingCases True)+    <> ["    , bindingFromShape = \\case"]+    <> indentCases (bindingCases False)+    <> ["    }"]+  where+    domainModule = hsModule (sdHaskell declaration)+    domainType = domainModule <> "." <> hsType (sdHaskell declaration)+    shapeModuleName = structuralShapeModule ctx (sdName declaration)+    shapeType = shapeModuleName <> "." <> sdName declaration <> "Shape"+    domainCtor constructor = domainModule <> "." <> constructor+    shapeCtor constructor = shapeModuleName <> "." <> constructor+    indentCases = map ("      " <>)+    bindingCases toShapeDirection =+      foldMappedShape+        MappedShapeAlgebra+          { onRecord = \constructor _ fields -> [recordCase toShapeDirection constructor fields],+            onEnum = \entries -> map (enumCase toShapeDirection . weCtor) entries,+            onUnion = \_ arms -> map (unionCase toShapeDirection) arms+          }+        shape+    recordCase toShapeDirection constructor fields =+      sourceCtor+        <> arguments variables+        <> " -> "+        <> targetCtor+        <> arguments (map (holeFor toShapeDirection . rwfHaskell) fields)+      where+        variables = map (("_" <>) . (<> "Value") . rwfHaskell) fields+        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor+        targetCtor = if toShapeDirection then shapeCtor constructor else domainCtor constructor+    enumCase toShapeDirection constructor =+      sourceCtor <> " -> " <> holeFor toShapeDirection constructor+      where+        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor+    unionCase toShapeDirection arm =+      sourceCtor+        <> maybe "" (const " _payloadValue") (rwaPayload arm)+        <> " -> "+        <> case rwaPayload arm of+          Nothing -> holeFor toShapeDirection (rwaCtor arm)+          Just _ -> targetCtor <> " " <> holeFor toShapeDirection (rwaCtor arm <> ".payload")+      where+        sourceCtor = if toShapeDirection then domainCtor (rwaCtor arm) else shapeCtor (rwaCtor arm)+        targetCtor = if toShapeDirection then shapeCtor (rwaCtor arm) else domainCtor (rwaCtor arm)+    arguments [] = ""+    arguments values = " " <> T.unwords values+    holeFor toShapeDirection fieldName =+      "(error "+        <> tshow+          ( "HOLE: fill "+              <> sdName declaration+              <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.")+              <> fieldName+          )+        <> ")"++shapeModule :: Context -> TypeGraph -> (StructuralDecl, ResolvedMappedShape) -> ScaffoldModule+shapeModule ctx graph (declaration, shape) =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" (structuralShapeModule ctx (sdName declaration)) <> ".hs"),+      moduleText = emitShape ctx graph declaration shape,+      kind = Generated,+      origin = nodeOrigin "mapped structural" (sdName declaration) (sdLoc declaration)+    }++structuralPrefix :: Context -> Text+structuralPrefix ctx = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Structural"+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Structural"++structuralShapeModule :: Context -> Name -> Text+structuralShapeModule ctx name = structuralPrefix ctx <> ".Shape." <> name++nominalRepresentationModule :: Context -> Name -> Text+nominalRepresentationModule ctx name = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominal.Shape." <> name+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Nominal.Shape." <> name <> ".Generated"++-- | Emit the one generated nominal authority for the complete context. The+-- empty declaration attribution is intentional: in a workspace this module is+-- context-level even when all declarations currently happen to live in one+-- member, so moving that member cannot move Haskell type ownership.+generatedNominalOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])]+generatedNominalOwners ctx service = case planNominalGenerationForService ctx service of+  Left _ -> []+  Right [] -> []+  Right owners ->+    [ ( ScaffoldModule+          { modulePath = T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs"),+            moduleText = emitGeneratedNominals languageContract ctx owners,+            kind = Generated,+            origin = "context " <> specContext spec <> " generated nominal declarations"+          },+        []+      )+    ]+      <> [ ( ScaffoldModule+               { modulePath = T.unpack (T.replace "." "/" (generatedNominalInternalModule ctx) <> ".hs"),+                 moduleText = emitGeneratedNominalInternals ctx enforcingIds,+                 kind = Generated,+                 origin = "context " <> specContext spec <> " generated nominal ID internals"+               },+             []+           )+         | not (null enforcingIds)+         ]+    where+      enforcingIds =+        [ (nominal, contract)+        | owner <- owners,+          let nominal = nominalDeclaration owner,+          IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+          Just contract <- [idDomainContractFor languageContract prefix]+        ]+  where+    spec = checkedSpec service+    languageContract = checkedLanguageContract service++generatedNominalInternalModule :: Context -> Text+generatedNominalInternalModule ctx = generatedNominalModule ctx <> ".Internal"++emitGeneratedNominals :: EffectiveLanguageContract -> Context -> [NominalGenerationOwner] -> Text+emitGeneratedNominals languageContract ctx owners =+  nl+    ( equalityPragmas+        <> [ "{-# LANGUAGE DeriveAnyClass #-}",+             "{-# LANGUAGE DeriveGeneric #-}",+             "{-# LANGUAGE LambdaCase #-}",+             generatedBanner,+             moduleHeader,+             "",+             "import Data.Aeson (FromJSON, ToJSON)",+             "import Data.Text (Text)",+             "import GHC.Generics (Generic)",+             "import Keiki.Shape (CanonicalTypeName)"+           ]+        <> internalImports+        <> equalityImports+        <> [ "",+             sectionsOf [map emitOwner owners]+           ]+    )+  where+    usesEquality = any nominalEqualityUsed owners+    usesExactEquality = any (\owner -> nominalEqualityUsed owner && exactOwner (nominalDeclaration owner)) owners+    enforcingIds =+      [ nominal+      | owner <- owners,+        let nominal = nominalDeclaration owner,+        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+        Just _ <- [idDomainContractFor languageContract prefix]+      ]+    moduleHeader+      | null enforcingIds = "module " <> generatedNominalModule ctx <> " where"+      | otherwise =+          nl+            [ "module " <> generatedNominalModule ctx,+              "  ( " <> T.intercalate "\n  , " (concatMap ownerExports owners),+              "  ) where"+            ]+    ownerExports owner =+      baseExports <> equalityExports+      where+        nominal = nominalDeclaration owner+        name = resolvedNominalName nominal+        baseExports = case resolvedNominalRepresentation nominal of+          IdRepresentation prefix+            | Just _ <- idDomainContractFor languageContract prefix ->+                [name, "parse" <> name, "mk" <> name, nominalTextName nominal]+          _ -> [name <> " (..)", nominalTextName nominal]+        equalityExports =+          if nominalEqualityUsed owner+            then [nominalEqualityTagName nominal, nominalEqualityWitnessName nominal]+            else []+    equalityPragmas =+      if usesEquality+        then+          [ "{-# LANGUAGE DataKinds #-}",+            "{-# LANGUAGE TypeApplications #-}",+            "{-# LANGUAGE TypeFamilies #-}"+          ]+        else []+    equalityImports =+      ["import Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)" | usesEquality]+        <> ["import Data.List.NonEmpty (NonEmpty (..))" | usesExactEquality]+        <> ["import Keiki.ProjectionDomain (finiteProjectionDomain)" | usesExactEquality && null enforcingIds]+        <> ["import Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, textProjectionDomain)" | usesExactEquality && not (null enforcingIds)]+        <> ["import Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain)" | not (null enforcingIds)]+    internalImports =+      [ "import "+          <> generatedNominalInternalModule ctx+          <> " ("+          <> T.intercalate+            ", "+            (concatMap (\nominal -> [resolvedNominalName nominal, "mk" <> resolvedNominalName nominal, "parse" <> resolvedNominalName nominal, nominalTextName nominal]) enforcingIds)+          <> ")"+      | not (null enforcingIds)+      ]+    emitOwner owner = emitGeneratedNominal languageContract (nominalEqualityUsed owner) (nominalDeclaration owner)+    exactOwner nominal = case resolvedNominalRepresentation nominal of+      EnumRepresentation {} -> True+      IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)+      ScalarRepresentation {} -> False++emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text+emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of+  IdRepresentation prefix+    | Just _ <- idDomainContractFor languageContract prefix ->+        nl $+          ["instance CanonicalTypeName " <> name]+            <> equalitySection+  IdRepresentation {} ->+    nl $+      [ "newtype " <> name <> " = " <> name <> " Text",+        "  deriving stock (Generic, Eq, Ord, Show)",+        "  deriving anyclass (ToJSON, FromJSON)",+        "",+        "instance CanonicalTypeName " <> name,+        "",+        nominalTextName nominal <> " :: " <> name <> " -> Text",+        nominalTextName nominal <> " (" <> name <> " value) = value"+      ]+        <> equalitySection+  EnumRepresentation constructors ->+    nl $+      [ "data " <> name <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),+        "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)",+        "  deriving anyclass (ToJSON, FromJSON)",+        "",+        "instance CanonicalTypeName " <> name,+        "",+        nominalTextName nominal <> " :: " <> name <> " -> Text",+        nominalTextName nominal <> " = \\case",+        nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]+      ]+        <> equalitySection+  ScalarRepresentation {} ->+    error "generated nominal scalar reached generated declaration emission"+  where+    name = resolvedNominalName nominal+    equalitySection = if equalityUsed then ["", emitGeneratedNominalEquality languageContract nominal] else []++emitGeneratedNominalEquality :: EffectiveLanguageContract -> ResolvedNominalType -> Text+emitGeneratedNominalEquality languageContract nominal =+  nl $+    [ "data " <> tagName,+      "",+      "instance FieldProjection " <> tagName <> " where",+      "  type FieldName " <> tagName <> " = " <> tshow name,+      "  type FieldOwner " <> tagName <> " = " <> name,+      "  type FieldResult " <> tagName <> " = Text",+      "  fieldShapeId _ = " <> tshow equalityIdentity,+      "  projectFieldValue _ = " <> nominalTextName nominal+    ]+      <> exactInstance+      <> [ "",+           witnessName <> " :: FieldWitness " <> tagName,+           witnessName <> " = " <> witnessConstructor <> " @" <> tagName+         ]+  where+    name = resolvedNominalName nominal+    tagName = nominalEqualityTagName nominal+    witnessName = nominalEqualityWitnessName nominal+    equalityIdentity = fromMaybe (error "generated nominal equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+    (exactInstance, witnessConstructor) = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> case idDomainContractFor languageContract prefix of+        Nothing -> ([], "fieldWitness")+        Just _ ->+          ( [ "",+              patternName <> " :: TextPattern",+              patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))",+              "",+              "instance ExactFieldProjection " <> tagName <> " where",+              "  fieldProjectionDomain _ = textProjectionDomain " <> patternName,+              "  reconstructFieldOwner _ = either (const Nothing) Just . parse" <> name+            ],+            "exactFieldWitness"+          )+      EnumRepresentation constructors ->+        ( [ "",+            "instance ExactFieldProjection " <> tagName <> " where",+            "  fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")",+            "  reconstructFieldOwner _ = \\case"+          ]+            <> ["    " <> tshow wire <> " -> Just " <> constructor | (constructor, wire) <- NE.toList constructors]+            <> ["    _ -> Nothing"],+          "exactFieldWitness"+        )+      ScalarRepresentation {} -> error "generated nominal scalar equality emission"+    patternName = lowerFirst name <> "IdDomainPattern"++emitGeneratedNominalInternals :: Context -> [(ResolvedNominalType, IdDomainContract)] -> Text+emitGeneratedNominalInternals ctx nominals =+  nl+    [ "{-# LANGUAGE DeriveGeneric #-}",+      generatedBanner,+      "module " <> generatedNominalInternalModule ctx,+      "  ( " <> T.intercalate "\n  , " (concatMap exportsFor nominals),+      "  ) where",+      "",+      "import Data.Aeson (FromJSON (..), ToJSON (..), withText)",+      "import Data.Text (Text)",+      "import Data.Text qualified as T",+      "import GHC.Generics (Generic)",+      "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)",+      "",+      sectionsOf [map emitInternal nominals]+    ]+  where+    exportsFor (nominal, _) =+      [ resolvedNominalName nominal,+        "parse" <> resolvedNominalName nominal,+        "mk" <> resolvedNominalName nominal,+        nominalTextName nominal,+        legacyNominalConstructorName nominal+      ]+    emitInternal (nominal, contract) =+      nl+        [ "newtype " <> name <> " = " <> name <> " Text",+          "  deriving stock (Generic, Eq, Ord, Show)",+          "",+          "instance ToJSON " <> name <> " where",+          "  toJSON = toJSON . " <> textName,+          "",+          "instance FromJSON " <> name <> " where",+          "  parseJSON = withText " <> tshow name <> " (either (fail . T.unpack) pure . parse" <> name <> ")",+          "",+          "parse" <> name <> " :: Text -> Either Text " <> name,+          "parse" <> name <> " input = case validateIdDomainText (typeIdV7Domain " <> tshow (idDomainPrefix contract) <> ") input of",+          "  Left reason -> Left (T.pack (show reason))",+          "  Right () -> Right (" <> name <> " input)",+          "",+          "mk" <> name <> " :: Text -> Either Text " <> name,+          "mk" <> name <> " = parse" <> name,+          "",+          textName <> " :: " <> name <> " -> Text",+          textName <> " (" <> name <> " value) = value",+          "",+          legacyNominalConstructorName nominal <> " :: Text -> " <> name,+          legacyNominalConstructorName nominal <> " = " <> name+        ]+      where+        name = resolvedNominalName nominal+        textName = nominalTextName nominal++nominalEqualityTagName :: ResolvedNominalType -> Text+nominalEqualityTagName nominal = resolvedNominalName nominal <> "EqualityProjection"++nominalEqualityWitnessName :: ResolvedNominalType -> Text+nominalEqualityWitnessName nominal = lowerFirst (resolvedNominalName nominal) <> "EqualityWitness"++renderNonEmpty :: [Text] -> Text+renderNonEmpty values = case values of+  [] -> error "cannot render an empty exact projection domain"+  firstValue : rest -> firstValue <> " :| [" <> T.intercalate ", " rest <> "]"++nominalTextName :: ResolvedNominalType -> Text+nominalTextName = (<> "Text") . lowerFirst . resolvedNominalName++-- | Explicit type/constructor imports for exactly the generated declarations a+-- generated aggregate module uses. Keeping an import list avoids making every+-- aggregate depend on every service declaration merely because they share the+-- one owner module.+generatedNominalTypeImports :: Context -> [ResolvedNominalType] -> [Text]+generatedNominalTypeImports _ [] = []+generatedNominalTypeImports ctx nominals =+  [ "import "+      <> generatedNominalModule ctx+      <> " ("+      <> T.intercalate ", " [resolvedNominalName nominal <> " (..)" | nominal <- stableNominals nominals]+      <> ")"+  ]++generatedNominalTypeImportsForService :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]+generatedNominalTypeImportsForService _ _ [] = []+generatedNominalTypeImportsForService service ctx nominals =+  [ "import "+      <> generatedNominalModule ctx+      <> " ("+      <> T.intercalate ", " (concatMap importsFor (stableNominals nominals))+      <> ")"+  ]+  where+    importsFor nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix ->+            [resolvedNominalName nominal, "parse" <> resolvedNominalName nominal]+      _ -> [resolvedNominalName nominal <> " (..)"]++generatedNominalCodecImports :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]+generatedNominalCodecImports _ _ [] = []+generatedNominalCodecImports service ctx nominals =+  [ "import "+      <> generatedNominalModule ctx+      <> " ("+      <> T.intercalate+        ", "+        ( concat+            [ [typeImport nominal, nominalTextName nominal]+            | nominal <- stableNominals nominals+            ]+        )+      <> ")"+  ]+    <> [ "import "+           <> generatedNominalInternalModule ctx+           <> " ("+           <> T.intercalate ", " [legacyNominalConstructorName nominal | nominal <- enforcingIds]+           <> ")"+       | not (null enforcingIds)+       ]+  where+    typeImport nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> resolvedNominalName nominal+      _ -> resolvedNominalName nominal <> " (..)"+    enforcingIds =+      [ nominal+      | nominal <- stableNominals nominals,+        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+        Just _ <- [idDomainContractFor (checkedLanguageContract service) prefix]+      ]++legacyNominalConstructorName :: ResolvedNominalType -> Text+legacyNominalConstructorName nominal = "unsafe" <> resolvedNominalName nominal <> "FromLegacyText"++stableNominals :: [ResolvedNominalType] -> [ResolvedNominalType]+stableNominals = Map.elems . Map.fromList . map (\nominal -> (resolvedNominalName nominal, nominal))++nominalRepresentationOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]+nominalRepresentationOwners ctx spec = case resolveNominalTypes spec of+  Left _ -> []+  Right registry ->+    [ (nominalRepresentationModuleValue ctx nominal constructors, [resolvedNominalName nominal])+    | nominal <- Map.elems (nominalTypes registry),+      ConsumerNominal {} <- [resolvedNominalOwnership nominal],+      EnumRepresentation constructors <- [resolvedNominalRepresentation nominal]+    ]++nominalRepresentationModuleValue :: Context -> ResolvedNominalType -> NonEmpty (Name, Text) -> ScaffoldModule+nominalRepresentationModuleValue ctx nominal constructors =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+      moduleText =+        nl+          [ "{-# LANGUAGE DeriveGeneric #-}",+            "{-# LANGUAGE LambdaCase #-}",+            generatedBanner,+            "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where",+            "",+            "import Data.Text (Text)",+            "import GHC.Generics (Generic)",+            "",+            "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),+            "  deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)",+            "",+            encoderName <> " :: " <> representationType <> " -> Text",+            encoderName <> " = \\case",+            nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]+          ],+      kind = Generated,+      origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal)+    }+  where+    moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal)+    representationType = resolvedNominalName nominal <> "Representation"+    encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText"++nominalProjectionModule :: Context -> Text+nominalProjectionModule ctx = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections"+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections"++nominalProjectionOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])]+nominalProjectionOwners ctx service = case nominalProjectionTypes spec of+  [] -> []+  nominals ->+    [ ( ScaffoldModule+          { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"),+            moduleText = emitNominalProjections (checkedLanguageContract service) ctx nominals,+            kind = Generated,+            origin = "context " <> specContext spec <> " nominal scalar projection facade"+          },+        []+      )+    ]+  where+    spec = checkedSpec service++nominalProjectionTypes :: Spec -> [ResolvedNominalType]+nominalProjectionTypes spec =+  Map.elems . Map.fromList $+    [ (resolvedNominalName nominal, nominal)+    | aggregate <- [value | NAggregate value <- specNodes spec],+      resolved <- registerTypes aggregate <> commandTypes aggregate,+      AggregateNominal nominal <- [resolved],+      ConsumerNominal {} <- [resolvedNominalOwnership nominal]+    ]+  where+    symbols = aggregateSymbols spec+    registerTypes aggregate =+      [ resolved+      | register <- aggRegs aggregate,+        Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]+      ]+    commandTypes aggregate =+      [ resolved+      | command <- aggCommands aggregate,+        field <- cmdFields command,+        Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]+      ]++emitNominalProjections :: EffectiveLanguageContract -> Context -> [ResolvedNominalType] -> Text+emitNominalProjections languageContract ctx nominals =+  nl $+    [ "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE TypeApplications #-}",+      "{-# LANGUAGE TypeFamilies #-}",+      generatedBanner,+      "module " <> moduleName <> " where",+      ""+    ]+      <> map ("import " <>) imports+      <> [""]+      <> [T.intercalate "\n\n" (map emitNominalProjection nominals)]+  where+    moduleName = nominalProjectionModule ctx+    imports =+      sort . nub $+        [ "Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)",+          "Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)"+        ]+          <> [hsModule (consumerNominalHaskell binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]]+          <> [qualifiedModule (consumerNominalBinding binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]]+          <> [nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified" | nominal <- nominals, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]]+          <> ["Data.KindID qualified as KindID" | any hasId nominals]+          <> ["Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain, validateIdDomainText)" | any hasEnforcedId nominals]+          <> ["Data.List.NonEmpty (NonEmpty (..))" | any hasExactDomain nominals]+          <> ["Data.Text (Text)" | any usesText nominals]+          <> ["Data.Time (UTCTime)" | any (hasScalar NominalTime) nominals]+          <> ["Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, matchesTextPattern, textCharSet, textConcat, textLiteral, textProjectionDomain, textRepeatBetween)" | any hasExactDomain nominals]+          <> ["Numeric.Natural (Natural)" | any (hasScalar NominalNatural) nominals]+    hasScalar wanted nominal = resolvedNominalRepresentation nominal == ScalarRepresentation wanted+    hasId nominal = case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False+    hasEnforcedId nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)+      _ -> False+    hasExactDomain nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation {} -> False; _ -> True+    usesText nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation NominalText -> True; IdRepresentation {} -> True; EnumRepresentation {} -> True; _ -> False+    emitNominalProjection nominal = case resolvedNominalOwnership nominal of+      GeneratedNominal -> ""+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        ScalarRepresentation {} -> emitScalarProjection nominal binding+        IdRepresentation prefix -> emitConsumerIdProjection nominal binding prefix+        EnumRepresentation constructors -> emitConsumerEnumProjection nominal binding constructors+    emitScalarProjection nominal binding =+      nl+        [ "data " <> tagName,+          "",+          "instance FieldProjection " <> tagName <> " where",+          "  type FieldName " <> tagName <> " = " <> tshow name,+          "  type FieldOwner " <> tagName <> " = " <> renderHaskellSource (consumerNominalHaskell binding),+          "  type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal),+          "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)),+          "  projectFieldValue _ = nominalToRepresentation " <> unQualifiedValueName (consumerNominalBinding binding),+          "",+          witnessName <> " :: FieldWitness " <> tagName,+          witnessName <> " = fieldWitness @" <> tagName+        ]+      where+        name = resolvedNominalName nominal+        tagName = name <> "NominalProjection"+        witnessName = lowerFirst name <> "Witness"+    emitConsumerIdProjection nominal binding prefix =+      nl+        ( patternLines+            <> [ "",+                 "data " <> tagName,+                 "",+                 "instance FieldProjection " <> tagName <> " where",+                 "  type FieldName " <> tagName <> " = " <> tshow name,+                 "  type FieldOwner " <> tagName <> " = " <> ownerType,+                 "  type FieldResult " <> tagName <> " = Text",+                 "  fieldShapeId _ = " <> tshow equalityIdentity,+                 "  projectFieldValue _ = KindID.toText . nominalToRepresentation " <> bindingName,+                 "",+                 "instance ExactFieldProjection " <> tagName <> " where",+                 "  fieldProjectionDomain _ = textProjectionDomain " <> patternName,+                 "  reconstructFieldOwner _ value"+               ]+            <> validationGuard+            <> [ "    | not (matchesTextPattern " <> patternName <> " value) = Nothing",+                 "    | otherwise = case KindID.parseText @" <> tshow prefix <> " value of",+                 "        Left _ -> Nothing",+                 "        Right representation -> Just (nominalFromRepresentation " <> bindingName <> " representation)",+                 "",+                 witnessName <> " :: FieldWitness " <> tagName,+                 witnessName <> " = exactFieldWitness @" <> tagName+               ]+        )+      where+        name = resolvedNominalName nominal+        tagName = nominalEqualityTagName nominal+        witnessName = nominalEqualityWitnessName nominal+        patternName = lowerFirst name <> "EqualityPattern"+        ownerType = renderHaskellSource (consumerNominalHaskell binding)+        bindingName = unQualifiedValueName (consumerNominalBinding binding)+        equalityIdentity = fromMaybe (error "consumer ID equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+        enforced = isJust (idDomainContractFor languageContract prefix)+        patternLines+          | enforced =+              [ patternName <> " :: TextPattern",+                patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))"+              ]+          | otherwise =+              [ patternName <> " :: TextPattern",+                patternName <> " = either (error . show) id $ do",+                "  prefix <- textLiteral " <> tshow (prefix <> "_"),+                "  leading <- textCharSet ('0' :| \"1234567\")",+                "  crockford <- textCharSet ('0' :| \"123456789abcdefghjkmnpqrstvwxyz\")",+                "  suffix <- textRepeatBetween 25 25 crockford",+                "  pure (textConcat (prefix :| [leading, suffix]))"+              ]+        validationGuard =+          [ "    | Left _ <- validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") value = Nothing"+          | enforced+          ]+    emitConsumerEnumProjection nominal binding constructors =+      nl $+        [ "data " <> tagName,+          "",+          "instance FieldProjection " <> tagName <> " where",+          "  type FieldName " <> tagName <> " = " <> tshow name,+          "  type FieldOwner " <> tagName <> " = " <> ownerType,+          "  type FieldResult " <> tagName <> " = Text",+          "  fieldShapeId _ = " <> tshow equalityIdentity,+          "  projectFieldValue _ = " <> encoderName <> " . nominalToRepresentation " <> bindingName,+          "",+          "instance ExactFieldProjection " <> tagName <> " where",+          "  fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")",+          "  reconstructFieldOwner _ = \\case"+        ]+          <> [ "    " <> tshow wire <> " -> Just (nominalFromRepresentation " <> bindingName <> " " <> representationModule <> "." <> constructor <> ")"+             | (constructor, wire) <- NE.toList constructors+             ]+          <> [ "    _ -> Nothing",+               "",+               witnessName <> " :: FieldWitness " <> tagName,+               witnessName <> " = exactFieldWitness @" <> tagName+             ]+      where+        name = resolvedNominalName nominal+        tagName = nominalEqualityTagName nominal+        witnessName = nominalEqualityWitnessName nominal+        ownerType = renderHaskellSource (consumerNominalHaskell binding)+        bindingName = unQualifiedValueName (consumerNominalBinding binding)+        representationModule = nominalRepresentationModule ctx name+        encoderName = representationModule <> "." <> lowerFirst name <> "RepresentationText"+        equalityIdentity = fromMaybe (error "consumer enum equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+    scalarHaskellType representation = case representation of+      ScalarRepresentation NominalText -> "Text"+      ScalarRepresentation NominalInt -> "Int"+      ScalarRepresentation NominalNatural -> "Natural"+      ScalarRepresentation NominalBool -> "Bool"+      ScalarRepresentation NominalTime -> "UTCTime"+      IdRepresentation {} -> "()"+      EnumRepresentation {} -> "()"++structuralProjectionModule :: Context -> Text+structuralProjectionModule ctx = structuralPrefix ctx <> "Projections"++emitShape :: Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitShape ctx graph declaration shape =+  nl $+    languagePragmas+      <> [ generatedBanner,+           "module " <> moduleName <> " (" <> shapeType <> " (..)) where",+           ""+         ]+      <> map ("import " <>) imports+      <> ["" | not (null imports)]+      <> [shapeDeclaration]+  where+    moduleName = structuralShapeModule ctx (sdName declaration)+    shapeType = sdName declaration <> "Shape"+    requirements = shapeRequirements ctx graph shape+    languagePragmas =+      ["{-# LANGUAGE DeriveGeneric #-}"]+        <> ["{-# LANGUAGE DuplicateRecordFields #-}" | shapeHasRecord shape]+    imports =+      sort . nub $+        ["Data.Aeson (Value)" | ReqJson `elem` requirements]+          <> ["Data.Map.Strict (Map)" | ReqMap `elem` requirements]+          <> ["Data.Text (Text)" | ReqText `elem` requirements]+          <> ["Data.Time (UTCTime)" | ReqTime `elem` requirements]+          <> ["GHC.Generics (Generic)"]+          <> ["Numeric.Natural (Natural)" | ReqNatural `elem` requirements]+          <> [m <> " qualified" | ReqModule m <- requirements]+    shapeDeclaration =+      foldMappedShape+        MappedShapeAlgebra+          { onRecord = \constructor _ fields ->+              nl $+                ["data " <> shapeType <> " = " <> constructor]+                  <> recordFields+                    [ (rwfHaskell field, renderShapeType ctx graph (rwfType field))+                    | field <- fields+                    ]+                  <> ["  deriving stock (Eq, Generic, Show)"],+            onEnum = \entries ->+              "data "+                <> shapeType+                <> " = "+                <> T.intercalate " | " (map weCtor entries)+                <> "\n  deriving stock (Eq, Generic, Show)",+            onUnion = \_ arms ->+              nl $+                case arms of+                  [] -> ["data " <> shapeType <> " = " <> shapeType <> "Empty", "  deriving stock (Eq, Generic, Show)"]+                  firstArm : rest ->+                    ["data " <> shapeType <> " = " <> renderArm firstArm]+                      <> ["  | " <> renderArm arm | arm <- rest]+                      <> ["  deriving stock (Eq, Generic, Show)"]+          }+        shape+    renderArm arm = rwaCtor arm <> maybe "" ((" !" <>) . renderShapeType ctx graph) (rwaPayload arm)++data ShapeRequirement+  = ReqJson+  | ReqMap+  | ReqText+  | ReqTime+  | ReqNatural+  | ReqModule !Text+  deriving stock (Eq, Ord, Show)++shapeHasRecord :: ResolvedMappedShape -> Bool+shapeHasRecord =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ _ -> True,+        onEnum = const False,+        onUnion = \_ _ -> False+      }++shapeRequirements :: Context -> TypeGraph -> ResolvedMappedShape -> [ShapeRequirement]+shapeRequirements ctx graph =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields -> concatMap (exprRequirements ctx graph . rwfType) fields,+        onEnum = const [],+        onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . rwaPayload) arms+      }++exprRequirements :: Context -> TypeGraph -> ResolvedTypeExpr -> [ShapeRequirement]+exprRequirements ctx graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = [ReqText],+        onInt = [],+        onInteger = [],+        onBool = [],+        onNatural = [ReqNatural],+        onTime = [ReqTime],+        onJson = [ReqJson],+        onOptional = id,+        onList = id,+        onMap = (ReqMap :) . (ReqText :),+        onRef = \key -> case Map.lookup key (tgDeclarations graph) of+          Just (ResolvedStructural declaration _) -> [ReqModule (structuralShapeModule ctx (sdName declaration))]+          Just (ResolvedOpaque declaration) -> [ReqModule (hsModule (odHaskell declaration))]+          Nothing -> []+      }++renderShapeType :: Context -> TypeGraph -> ResolvedTypeExpr -> Text+renderShapeType ctx graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = "Text",+        onInt = "Int",+        onInteger = "Integer",+        onBool = "Bool",+        onNatural = "Natural",+        onTime = "UTCTime",+        onJson = "Value",+        onOptional = \value -> "(Maybe (" <> value <> "))",+        onList = \value -> "([" <> value <> "])",+        onMap = \value -> "(Map Text (" <> value <> "))",+        onRef = \key -> case Map.lookup key (tgDeclarations graph) of+          Just (ResolvedStructural nested _) ->+            structuralShapeModule ctx (sdName nested) <> "." <> sdName nested <> "Shape"+          Just (ResolvedOpaque opaque) ->+            hsModule (odHaskell opaque) <> "." <> hsType (odHaskell opaque)+          Nothing -> "()"+      }++data StructuralProjection = StructuralProjection+  { spTag :: !Text,+    spWitness :: !Text,+    spPointer :: !Text,+    spOwner :: !HaskellSource,+    spResult :: !Text,+    spCanonical :: !CanonicalTypeId,+    spBinding :: !QualifiedValueName,+    spSelectors :: ![(Text, Text)]+  }+  deriving stock (Eq, Show)++projectionSpecs :: TypeGraph -> [StructuralProjection]+projectionSpecs graph =+  sortOn spTag . concat $+    [ projectionsForRoot graph declaration shape+    | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)+    ]++projectionsForRoot :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [StructuralProjection]+projectionsForRoot graph root rootShape = case rootShape of+  RRecord _ _ fields -> concatMap (walkField [] []) fields+  REnum {} -> []+  RUnion {} -> []+  where+    walkField keys selectors field+      | rwfPresence field /= PRequired = []+      | otherwise = case projectionScalar (rwfType field) of+          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]) result]+          Nothing -> case rwfType field of+            RRef key -> case Map.lookup key (tgDeclarations graph) of+              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->+                concatMap+                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]))+                  nestedFields+              _ -> []+            _ -> []+      where+        shapeModuleForOwner = "__SHAPE__." <> sdName root++    walkNested owner keys selectors field+      | rwfPresence field /= PRequired = []+      | otherwise = case projectionScalar (rwfType field) of+          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]) result]+          Nothing -> case rwfType field of+            RRef key -> case Map.lookup key (tgDeclarations graph) of+              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->+                concatMap+                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]))+                  nestedFields+              _ -> []+            _ -> []++    -- Context is supplied when rendering; this marker is replaced there.+    shapeModuleFor declaration = "__SHAPE__." <> sdName declaration+    mkProjection keys selectors result =+      StructuralProjection+        { spTag = projectionTag (sdName root) pointer,+          spWitness = lowerFirst (projectionTag (sdName root) pointer) <> "Witness",+          spPointer = pointer,+          spOwner = sdHaskell root,+          spResult = result,+          spCanonical = sdCanonical root,+          spBinding = sdBinding root,+          spSelectors = selectors+        }+      where+        pointer = T.concat ["/" <> escapePointer key | key <- keys]++projectionScalar :: ResolvedTypeExpr -> Maybe Text+projectionScalar = \case+  RText -> Just "Text"+  RInt -> Just "Int"+  RInteger -> Just "Integer"+  RBool -> Just "Bool"+  RTime -> Just "UTCTime"+  RNatural -> Just "Natural"+  RJson -> Nothing+  ROptional {} -> Nothing+  RList {} -> Nothing+  RMap {} -> Nothing+  RRef {} -> Nothing++escapePointer :: Text -> Text+escapePointer = T.replace "/" "~1" . T.replace "~" "~0"++projectionTag :: Name -> Text -> Text+projectionTag owner pointer = "StructuralProjection" <> encodeIdentifier (owner <> pointer)++encodeIdentifier :: Text -> Text+encodeIdentifier = T.concatMap (\character -> "C" <> T.pack (showHex (ord character) "") <> "Z")++emitStructuralProjections :: Context -> TypeGraph -> Text+emitStructuralProjections ctx graph =+  nl $+    [ "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE TypeApplications #-}",+      "{-# LANGUAGE TypeFamilies #-}",+      generatedBanner,+      "-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.",+      "-- Int, Natural, and UTCTime belong to Keiki's ordered subset.",+      "module " <> moduleName,+      "  ( " <> T.intercalate "\n  , " (map spWitness specs),+      "  ) where",+      "",+      "import Data.Text (Text)",+      "import Data.Time (UTCTime)",+      "import Numeric.Natural (Natural)",+      "import Keiro.Codec.Structural (bindingToShape)",+      "import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)"+    ]+      <> map ("import " <>) imports+      <> concatMap renderProjection specs+  where+    moduleName = structuralProjectionModule ctx+    specs = map (resolveProjectionModules ctx) (projectionSpecs graph)+    imports =+      sort . nub $+        [hsModule (spOwner spec) <> " qualified" | spec <- specs]+          <> [qualifiedModule (spBinding spec) <> " qualified" | spec <- specs]+          <> [shapeModuleName <> " qualified" | spec <- specs, (shapeModuleName, _) <- spSelectors spec]+    renderProjection spec =+      [ "",+        "data " <> spTag spec,+        "",+        "instance FieldProjection " <> spTag spec <> " where",+        "  type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec),+        "  type FieldOwner " <> spTag spec <> " = " <> renderHaskellSource (spOwner spec),+        "  type FieldResult " <> spTag spec <> " = " <> spResult spec,+        "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (spCanonical spec)),+        "  projectFieldValue _ owner = " <> renderGetter spec,+        "",+        spWitness spec <> " :: FieldWitness " <> spTag spec,+        spWitness spec <> " = fieldWitness @" <> spTag spec+      ]+    renderGetter spec =+      foldl+        (\value (shapeModuleName, selector) -> shapeModuleName <> "." <> selector <> " (" <> value <> ")")+        ("bindingToShape " <> unQualifiedValueName (spBinding spec) <> " owner")+        (spSelectors spec)++resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection+resolveProjectionModules ctx spec =+  spec+    { spSelectors =+        [ (replaceModule marker, selector)+        | (marker, selector) <- spSelectors spec+        ]+    }+  where+    replaceModule marker+      | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name+      | otherwise = structuralShapeModule ctx (lastSegment marker)++qualifiedModule :: QualifiedValueName -> Text+qualifiedModule = fst . splitQualified . unQualifiedValueName++renderHaskellSource :: HaskellSource -> Text+renderHaskellSource source = hsModule source <> "." <> hsType source++splitQualified :: Text -> (Text, Text)+splitQualified value =+  let (prefix, name) = T.breakOnEnd "." value+   in (T.dropEnd 1 prefix, name)++lastSegment :: Text -> Text+lastSegment = snd . T.breakOnEnd "."++-- | Emit all modules for one aggregate. The 'Spec' is needed for the shared+-- id\/enum declarations.+scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule]+scaffoldAggregate ctx spec = scaffoldAggregateForService ctx (legacyCheckedService spec)++-- | Emit all modules for one aggregate after selecting the effective semantic+-- contract. This is the normal source/workspace generation entry point.+scaffoldAggregateForService :: Context -> CheckedService -> Aggregate -> [ScaffoldModule]+scaffoldAggregateForService ctx service agg =+  [ genModule a "Domain" (emitDomain a),+    genModule a "Codec" (emitCodec a)+  ]+    ++ ( if hasVersion2Ownership a+           then+             [ genModule a "Expressions" (emitExpressions a),+               genModule a "Transducer" (emitGeneratedTransducer a),+               genModule a "BehaviorContract" (emitBehaviorContract a),+               behaviorHoleModule a+             ]+           else []+       )+    ++ [ genModule a "EventStream" (emitEventStream a),+         genModule a "Projection" (emitProjection a)+       ]+    ++ [holeModule a (emitHoles a) | aggregateNeedsHoleModule a]+  where+    a = resolveAggForService ctx service agg++aggregateNeedsHoleModule :: Agg -> Bool+aggregateNeedsHoleModule aggregate+  | hasVersion2Ownership aggregate = not (null (version2HoleExports aggregate))+  | otherwise = True++-- | The generated behavioral contract is deliberately separate from both the+-- authoritative transducer and the create-once witness list.  Regeneration can+-- replace this module freely while stale textual keys in @BehaviorHoles@ keep+-- compiling and are reported by reconciliation.+emitBehaviorContract :: Agg -> Text+emitBehaviorContract aggregate =+  nl $+    [ "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE OverloadedLabels #-}",+      "{-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-}",+      generatedBanner,+      "module " <> aGenPrefix aggregate <> ".BehaviorContract where",+      "",+      "import " <> aGenPrefix aggregate <> ".Codec (encode" <> name <> "Event, parse" <> name <> "Event, " <> valueStem <> "Codec)",+      "import " <> aGenPrefix aggregate <> ".Domain",+      "import " <> aGenPrefix aggregate <> ".Transducer (" <> valueStem <> "Transducer)",+      "import Data.Aeson (ToJSON (..), object, (.=))",+      "import Data.List (sortOn)",+      "import Data.List.NonEmpty (NonEmpty)",+      "import Data.List.NonEmpty qualified as NonEmpty",+      "import Data.Map.Strict qualified as Map",+      "import Data.Text (Text)",+      "import Data.Text qualified as T",+      "import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))",+      "import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))",+      "",+      "newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }",+      "  deriving stock (Eq, Ord, Show)",+      "",+      "data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition",+      "  deriving stock (Eq, Ord, Show)",+      "",+      "data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness",+      "  deriving stock (Eq, Ord, Show)",+      "",+      "data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable",+      "  deriving stock (Eq, Ord, Show)",+      "",+      "data BehaviorRequirement = BehaviorRequirement",+      "  { requirementKey :: !BehaviorKey",+      "  , requirementKind :: !ObligationKind",+      "  , requirementEvidence :: !EvidenceLevel",+      "  , requirementGuardCoverage :: !GuardCoverage",+      "  , requirementSource :: !" <> aVertexType aggregate,+      "  , requirementCommandName :: !Text",+      "  , requirementExpectedEdge :: !(Maybe (K.EdgeRef " <> aVertexType aggregate <> "))",+      "  , requirementTarget :: !(Maybe " <> aVertexType aggregate <> ")",+      "  , requirementEventKinds :: ![Text]",+      "  , requirementLine :: !Int",+      "  }",+      "  deriving stock (Eq, Show)",+      "",+      "data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge",+      "  deriving stock (Eq, Show)",+      "",+      "data LiveExpectation",+      "  = Emits (NonEmpty " <> name <> "Event)",+      "  | Rejects RejectionClass",+      "  | NoOp",+      "  deriving stock (Eq, Show)",+      "",+      "data BehaviorWitness",+      "  = Pending BehaviorKey",+      "  | LiveWitness",+      "      { witnessKey :: BehaviorKey",+      "      , witnessHistory :: [" <> name <> "Event]",+      "      , witnessCommand :: " <> name <> "Command",+      "      , witnessExpected :: LiveExpectation",+      "      }",+      "  | ReplayWitness",+      "      { witnessKey :: BehaviorKey",+      "      , witnessHistoryPrefix :: [" <> name <> "Event]",+      "      , witnessObservedChunk :: [" <> name <> "Event]",+      "      }",+      "  deriving stock (Eq, Show)",+      "",+      "data BehaviorFailure = BehaviorFailure",+      "  { failureKey :: !BehaviorKey",+      "  , failureCode :: !Text",+      "  , failureDetail :: !Text",+      "  }",+      "  deriving stock (Eq, Show)",+      "",+      "instance ToJSON BehaviorFailure where",+      "  toJSON failure = object",+      "    [ \"key\" .= unBehaviorKey (failureKey failure)",+      "    , \"code\" .= failureCode failure",+      "    , \"detail\" .= failureDetail failure",+      "    ]",+      "",+      "data BehaviorConformanceReport = BehaviorConformanceReport",+      "  { reportRequired :: ![BehaviorKey]",+      "  , reportFilled :: ![BehaviorKey]",+      "  , reportPending :: ![BehaviorKey]",+      "  , reportMissing :: ![BehaviorKey]",+      "  , reportDuplicate :: ![BehaviorKey]",+      "  , reportStale :: ![BehaviorKey]",+      "  , reportFailed :: ![BehaviorFailure]",+      "  , reportVerified :: ![BehaviorKey]",+      "  , reportUnverified :: ![BehaviorKey]",+      "  }",+      "  deriving stock (Eq, Show)",+      "",+      "instance ToJSON BehaviorConformanceReport where",+      "  toJSON report = object",+      "    [ \"schema\" .= (\"keiro/behavior-conformance/1\" :: Text)",+      "    , \"required\" .= keyTexts (reportRequired report)",+      "    , \"filled\" .= keyTexts (reportFilled report)",+      "    , \"pending\" .= keyTexts (reportPending report)",+      "    , \"missing\" .= keyTexts (reportMissing report)",+      "    , \"duplicate\" .= keyTexts (reportDuplicate report)",+      "    , \"stale\" .= keyTexts (reportStale report)",+      "    , \"failed\" .= reportFailed report",+      "    , \"verified\" .= keyTexts (reportVerified report)",+      "    , \"unverified\" .= keyTexts (reportUnverified report)",+      "    ]",+      "",+      "behaviorRequirements :: [BehaviorRequirement]",+      "behaviorRequirements ="+    ]+      <> renderBehaviorRequirementList aggregate+      <> [ "",+           "behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport",+           "behaviorCoverageReport witnesses =",+           "  BehaviorConformanceReport",+           "    { reportRequired = sortedKeys (Map.keys requiredByKey)",+           "    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]",+           "    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]",+           "    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]",+           "    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]",+           "    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]",+           "    , reportFailed = sortOn (unBehaviorKey . failureKey) failures",+           "    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]",+           "    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]",+           "    }",+           " where",+           "  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]",+           "  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]",+           "  executions =",+           "    [ (requirement, runWitness requirement witness)",+           "    | (key, [witness]) <- Map.toList witnessGroups",+           "    , not (isPending witness)",+           "    , Just requirement <- [Map.lookup key requiredByKey]",+           "    ]",+           "  failures = [failure | (_, Left failure) <- executions]",+           "",+           "behaviorConformancePassed :: BehaviorConformanceReport -> Bool",+           "behaviorConformancePassed = behaviorConformancePassedWith False",+           "",+           "behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool",+           "behaviorConformancePassedWith failOnUnverified report =",+           "  null (reportPending report)",+           "    && null (reportMissing report)",+           "    && null (reportDuplicate report)",+           "    && null (reportStale report)",+           "    && null (reportFailed report)",+           "    && (not failOnUnverified || null (reportUnverified report))",+           "",+           "renderBehaviorConformanceText :: BehaviorConformanceReport -> Text",+           "renderBehaviorConformanceText report = T.unlines",+           "  [ \"behavior conformance: " <> name <> "\"",+           "  , \"schema: keiro/behavior-conformance/1\"",+           "  , countLine \"required\" (reportRequired report)",+           "  , countLine \"filled\" (reportFilled report)",+           "  , countLine \"pending\" (reportPending report)",+           "  , countLine \"missing\" (reportMissing report)",+           "  , countLine \"duplicate\" (reportDuplicate report)",+           "  , countLine \"stale\" (reportStale report)",+           "  , \"failed: \" <> tshow (length (reportFailed report))",+           "  , countLine \"verified\" (reportVerified report)",+           "  , countLine \"unverified\" (reportUnverified report)",+           "  ] <> T.unlines [\"FAIL \" <> unBehaviorKey (failureKey failure) <> \" [\" <> failureCode failure <> \"] \" <> failureDetail failure | failure <- reportFailed report]",+           "",+           "runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()",+           "runWitness requirement witness = case witness of",+           "  Pending _ -> failure requirement \"pending\" \"witness is still Pending\"",+           "  LiveWitness _ history command expectation -> runLive requirement history command expectation",+           "  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk",+           "",+           "runLive :: BehaviorRequirement -> [" <> name <> "Event] -> " <> name <> "Command -> LiveExpectation -> Either BehaviorFailure ()",+           "runLive requirement history command expectation = do",+           "  settled <- settleHistory requirement \"history\" history",+           "  ensure requirement (K.replaySuccessState settled == requirementSource requirement) \"history-wrong-source\" \"history does not settle at the required source vertex\"",+           "  ensure requirement (commandKind command == requirementCommandName requirement) \"command-mismatch\" \"witness command constructor does not match the required state/command cell\"",+           "  case requirementKind requirement of",+           "    ReplayTransition -> failure requirement \"witness-kind\" \"a replay-only requirement needs ReplayWitness\"",+           "    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",+           "    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",+           "",+           "runRejection requirement seed command expectation = case expectation of",+           "  Emits _ -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect emitted events\"",+           "  NoOp -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect an accepted no-op\"",+           "  Rejects expectedClass -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+           "    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) \"rejection-class\" \"expected NoMatchingEdge but runtime returned NoOutgoingEdges\"",+           "    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) \"rejection-class\" \"expected NoOutgoingEdges but runtime returned NoMatchingEdge\"",+           "    Left K.AmbiguousEdges {} -> failure requirement \"ambiguous-edges\" \"AmbiguousEdges can never satisfy a rejection witness\"",+           "    Right _ -> failure requirement \"unexpected-acceptance\" \"runtime accepted a command required to reject\"",+           "",+           "runAcceptance requirement seed command expectation = case expectation of",+           "  Rejects _ -> failure requirement \"expectation-kind\" \"a live-transition requirement needs Emits or NoOp\"",+           "  NoOp -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+           "    Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",+           "    Right success -> do",+           "      checkAcceptedEnvelope requirement success",+           "      ensure requirement (null (K.stepSuccessOutputs success)) \"noop-emitted\" \"NoOp emitted one or more events\"",+           "      ensure requirement (K.stepSuccessState success == fst seed) \"noop-vertex-change\" \"NoOp changed the control vertex\"",+           "      ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) \"noop-register-change\" \"NoOp changed one or more registers\"",+           "  Emits expectedEvents -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+           "    Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",+           "    Right success -> do",+           "      checkAcceptedEnvelope requirement success",+           "      let expected = NonEmpty.toList expectedEvents",+           "          actual = K.stepSuccessOutputs success",+           "      ensure requirement (actual == expected) \"event-value-mismatch\" \"runtime event values differ from the exact witness expectation\"",+           "      ensure requirement (map eventKind actual == requirementEventKinds requirement) \"event-envelope-mismatch\" \"runtime event kinds differ from the declared ordered envelope\"",+           "      decoded <- either (failure requirement \"emitted-codec-decode\") Right (decodeEvents actual)",+           "      replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer seed decoded of",+           "        Left replayFailure -> failure requirement \"emitted-replay-failed\" (tshow replayFailure)",+           "        Right replaySuccess -> Right replaySuccess",+           "      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) \"forward-replay-vertex\" \"decoded emissions replay to a different vertex\"",+           "      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) \"forward-replay-registers\" \"decoded emissions replay to different registers\"",+           "      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)",+           "",+           "checkAcceptedEnvelope requirement success = do",+           "  ensure requirement (K.stepSuccessMode success == K.Live) \"forward-mode\" \"forward execution selected a non-live edge\"",+           "  ensure requirement (Just (K.stepSuccessEdge success) == requirementExpectedEdge requirement) \"edge-attribution\" \"runtime selected a different guarded sibling\"",+           "  ensure requirement (Just (K.stepSuccessState success) == requirementTarget requirement) \"target-mismatch\" \"runtime reached a different target vertex\"",+           "",+           "runReplay :: BehaviorRequirement -> [" <> name <> "Event] -> [" <> name <> "Event] -> Either BehaviorFailure ()",+           "runReplay requirement prefix chunk = case requirementKind requirement of",+           "  ReplayTransition -> do",+           "    settled <- settleHistory requirement \"history-prefix\" prefix",+           "    ensure requirement (K.replaySuccessState settled == requirementSource requirement) \"history-wrong-source\" \"history prefix does not settle at the replay edge source\"",+           "    ensure requirement (not (null chunk)) \"empty-replay-chunk\" \"a replay-only edge has no observable empty chunk\"",+           "    decoded <- either (failure requirement \"replay-chunk-codec-decode\") Right (decodeEvents chunk)",+           "    replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer (K.replaySuccessState settled, K.replaySuccessRegs settled) decoded of",+           "      Left replayFailure -> failure requirement \"replay-chunk-failed\" (tshow replayFailure)",+           "      Right replaySuccess -> Right replaySuccess",+           "    ensure requirement (Just (K.replaySuccessState replayed) == requirementTarget requirement) \"target-mismatch\" \"replay chunk reached a different target vertex\"",+           "    checkSingleAttribution requirement K.ReplayOnly (length decoded) (K.replaySuccessTrace replayed)",+           "  _ -> failure requirement \"witness-kind\" \"ReplayWitness supplied for a non-replay requirement\"",+           "",+           "checkSingleAttribution requirement expectedMode eventCount trace = case trace of",+           "  [attribution] -> do",+           "    ensure requirement (Just (K.replayAttributionEdge attribution) == requirementExpectedEdge requirement) \"replay-edge-attribution\" \"replay selected a different edge\"",+           "    ensure requirement (K.replayAttributionMode attribution == expectedMode) \"replay-mode-attribution\" \"replay selected the wrong live/replay-only phase\"",+           "    ensure requirement (K.replayAttributionSource attribution == requirementSource requirement) \"replay-source-attribution\" \"replay attribution starts at the wrong source\"",+           "    ensure requirement (Just (K.replayAttributionTarget attribution) == requirementTarget requirement) \"replay-target-attribution\" \"replay attribution ends at the wrong target\"",+           "    ensure requirement (K.replayAttributionSpan attribution == K.ReplayEventSpan 0 eventCount) \"replay-span-attribution\" \"replay attribution did not consume the exact chunk\"",+           "  _ -> failure requirement \"replay-trace-cardinality\" \"expected exactly one completed-edge attribution\"",+           "",+           "settleHistory requirement label history = do",+           "  decoded <- either (failure requirement (label <> \"-codec-decode\")) Right (decodeEvents history)",+           "  case K.applyEventsDetailedEither " <> valueStem <> "Transducer (" <> initialVertex aggregate <> ", initial" <> name <> "Regs) decoded of",+           "    Left replayFailure -> failure requirement (label <> \"-replay-failed\") (tshow replayFailure)",+           "    Right replaySuccess -> Right replaySuccess",+           "",+           "decodeEvents :: [" <> name <> "Event] -> Either Text [" <> name <> "Event]",+           "decodeEvents = traverse (\\event -> parse" <> name <> "Event (Codec.eventType " <> valueStem <> "Codec event) (encode" <> name <> "Event event))"+         ]+      <> renderCommandKind aggregate+      <> [ "",+           "eventKind event = case Codec.eventType " <> valueStem <> "Codec event of Codec.EventType tag -> tag",+           "",+           "regsEqual :: K.RegFile " <> name <> "Regs -> K.RegFile " <> name <> "Regs -> Bool",+           regsEqualityExpression aggregate,+           "",+           "proofStrength requirement =",+           "  requirementEvidence requirement == GeneratedAuthoritative",+           "    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]",+           "",+           "behaviorWitnessKey witness = case witness of",+           "  Pending key -> key",+           "  LiveWitness { witnessKey = key } -> key",+           "  ReplayWitness { witnessKey = key } -> key",+           "",+           "isPending Pending {} = True",+           "isPending _ = False",+           "",+           "ensure requirement condition code detail = if condition then Right () else failure requirement code detail",+           "failure requirement code detail = Left (BehaviorFailure (requirementKey requirement) code detail)",+           "sortedKeys = sortOn unBehaviorKey",+           "keyTexts = map unBehaviorKey",+           "countLine label values = label <> \": \" <> tshow (length values)",+           "tshow :: Show value => value -> Text",+           "tshow = T.pack . show"+         ]+  where+    name = aName aggregate+    valueStem = lowerFirst name++renderCommandKind :: Agg -> [Text]+renderCommandKind aggregate = case aCommands aggregate of+  [] -> ["", "commandKind _ = \"\""]+  commands ->+    [ "",+      "commandKind command = case command of"+    ]+      <> ["  " <> rcName command <> " _ -> " <> tshow (rcName command) | command <- commands]++renderBehaviorRequirementList :: Agg -> [Text]+renderBehaviorRequirementList aggregate =+  case behaviorRequirementsFor aggregate of+    [] -> ["  []"]+    requirements ->+      [ (if index == (0 :: Int) then "  [ " else "  , ") <> render requirement+      | (index, requirement) <- zip [0 ..] requirements+      ]+        <> ["  ]"]+  where+    render requirement =+      "BehaviorRequirement "+        <> keyExpr requirement+        <> " "+        <> T.pack (show (Behavior.requirementKind requirement))+        <> " "+        <> T.pack (show (Behavior.requirementEvidence requirement))+        <> " "+        <> T.pack (show (Behavior.requirementGuardCoverage requirement))+        <> " "+        <> vertexCtor aggregate (Behavior.requirementSource requirement)+        <> " "+        <> tshow (Behavior.requirementCommand requirement)+        <> " "+        <> edgeExpr aggregate requirement+        <> " "+        <> maybe "Nothing" (\target -> "(Just " <> vertexCtor aggregate target <> ")") (Behavior.requirementTarget requirement)+        <> " "+        <> renderBehaviorTextList (Behavior.requirementEvents requirement)+        <> " "+        <> tshow' (unLoc (Behavior.requirementLocation requirement))+    keyExpr requirement = "(BehaviorKey " <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)) <> ")"++edgeExpr :: Agg -> Behavior.BehaviorRequirement -> Text+edgeExpr aggregate requirement = case Behavior.requirementKind requirement of+  Behavior.RequiredRejection -> "Nothing"+  _ -> case behaviorEdgeIndex aggregate requirement of+    Nothing -> error ("required behavior transition missing from resolved aggregate: " <> T.unpack (Behavior.requirementCanonical requirement))+    Just edgeIndex ->+      "(Just (K.EdgeRef "+        <> vertexCtor aggregate (Behavior.requirementSource requirement)+        <> " "+        <> tshow' edgeIndex+        <> "))"++behaviorEdgeIndex :: Agg -> Behavior.BehaviorRequirement -> Maybe Int+behaviorEdgeIndex aggregate requirement =+  findIndex+    matches+    [ transition+    | transition <- aTransitions aggregate,+      tSource transition == Behavior.requirementSource requirement+    ]+  where+    matches transition =+      unLoc (tLoc transition) == unLoc (Behavior.requirementLocation requirement)+        && tCommand transition == Behavior.requirementCommand requirement++behaviorRequirementsFor :: Agg -> [Behavior.BehaviorRequirement]+behaviorRequirementsFor aggregate =+  case Behavior.deriveAggregateBehaviorRequirements (aSpec aggregate) (aAggregate aggregate) of+    Left derivationError -> error ("validated aggregate failed behavior derivation: " <> show derivationError)+    Right requirements -> sortOn Behavior.requirementKey requirements++renderBehaviorTextList :: [Text] -> Text+renderBehaviorTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"++regsEqualityExpression :: Agg -> Text+regsEqualityExpression aggregate = case aRegs aggregate of+  [] -> "regsEqual _ _ = True"+  registers ->+    "regsEqual left right = "+      <> T.intercalate+        " && "+        [ "(left K.! #" <> rrName register <> ") == (right K.! #" <> rrName register <> ")"+        | register <- registers+        ]++behaviorHoleModule :: Agg -> ScaffoldModule+behaviorHoleModule aggregate =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" (aHolePrefix aggregate) <> "/BehaviorHoles.hs"),+      moduleText = emitBehaviorHoles aggregate,+      kind = HoleStub,+      origin = nodeOrigin "aggregate behavior witnesses" (aName aggregate) (aLoc aggregate)+    }++emitBehaviorHoles :: Agg -> Text+emitBehaviorHoles aggregate =+  nl $+    [ "-- Consumer-owned behavioral witnesses. Created once; never overwritten.",+      "module " <> aHolePrefix aggregate <> ".BehaviorHoles (behaviorWitnesses) where",+      "",+      "import " <> aGenPrefix aggregate <> ".BehaviorContract",+      "",+      "behaviorWitnesses :: [BehaviorWitness]",+      "behaviorWitnesses ="+    ]+      <> case behaviorRequirementsFor aggregate of+        [] -> ["  []"]+        requirements ->+          [ (if index == (0 :: Int) then "  [ " else "  , ")+              <> "Pending (BehaviorKey "+              <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement))+              <> ")"+          | (index, requirement) <- zip [0 ..] requirements+          ]+            <> ["  ]"]++-- | Emit the context-wide replay-audit target assembly.+--+-- There is one existential target per aggregate declaration. Process saga+-- aggregates are ordinary aggregate nodes referenced by 'SagaRef', so they are+-- included by the same single source of truth rather than being duplicated from+-- the process declaration.+scaffoldReplayAudit :: Context -> Spec -> [ScaffoldModule]+scaffoldReplayAudit ctx spec+  | null aggregates = []+  | otherwise =+      [ ScaffoldModule+          { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+            moduleText = emitReplayAudit,+            kind = Generated,+            origin = "context " <> specContext spec <> " replay-audit assembly"+          }+      ]+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    moduleName = contextGeneratedPrefix ctx <> ".ReplayAudit"+    contextGeneratedPrefix context = case placement context of+      GeneratedPrefix -> rootPrefix context <> "Generated." <> ctxPascalOf context+      CollocatedLeaf -> rootPrefix context <> ctxPascalOf context <> ".Generated"+    emitReplayAudit =+      nl $+        [ "{-# LANGUAGE GADTs #-}",+          generatedBanner,+          "--",+          "-- Deployment contract:",+          "--   * replay-neutral diff: no data audit is required;",+          "--   * affected diff: run AuditTargeted with the emitted affected set",+          "--     against a production copy under the candidate binary;",+          "--   * one-time runtime cutover: run AuditFull;",+          "--   * any non-zero audit exit blocks deployment.",+          "module " <> moduleName <> " (auditTargets) where",+          ""+        ]+          ++ [ "import " <> genPrefixFor ctx (aggName aggregate) <> ".EventStream qualified as " <> aggName aggregate+             | aggregate <- aggregates+             ]+          ++ [ "import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)",+               "import Keiro.Stream qualified as Stream",+               "",+               "auditTargets :: [SomeAuditTarget]",+               "auditTargets ="+             ]+          ++ concat+            [ [ if index == (0 :: Int) then "  [ SomeAuditTarget" else "  , SomeAuditTarget",+                "      AuditTarget",+                "        { eventStream = " <> aggregateName <> "." <> lowerFirst aggregateName <> "EventStream",+                "        , category = Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category",+                "        , mkStream = streamInCategory (Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category)",+                "        }"+              ]+            | (index, aggregate) <- zip [0 ..] aggregates,+              let aggregateName = aggName aggregate+            ]+          ++ ["  ]"]++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 #-}",+      "{-# 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)+      },+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"),+        moduleText = emitQueueCodec 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 #-}",+      "{-# 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 versioned PGMQ envelope adapter.  The payload record remains+-- symbol-free and dependency-light in Queue.hs; this runtime-facing module is+-- the opt-in assembly point applications import into their Job values.+emitQueueCodec :: Text -> WorkqueueNode -> Text+emitQueueCodec genPrefix w =+  nl+    [ generatedBanner,+      "{- | Versioned job payload envelope: @{\\\"v\\\",\\\"t\\\",\\\"data\\\"}@.",+      "",+      "Deploy workers before producers when raising its schema version. Do not",+      "adopt this codec on a non-empty bare-payload queue without draining it",+      "(or supplying a transitional codec), or in-flight messages will",+      "dead-letter. This is telemetry-neutral:",+      "docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns",+      "spans and acknowledgement vocabulary.",+      "-}",+      "module " <> genPrefix <> ".QueueCodec (" <> stem <> "PayloadCodec, " <> stem <> "JobCodec) where",+      "",+      "import Data.List.NonEmpty (NonEmpty (..))",+      "import Keiro.Codec (Codec (..), EventType (..))",+      "import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)",+      "import " <> genPrefix <> ".Queue (" <> payloadTy <> ", encode" <> payloadTy <> ", parse" <> payloadTy <> ")",+      "",+      stem <> "PayloadCodec :: Codec " <> payloadTy,+      stem <> "PayloadCodec =",+      "  Codec",+      "    { eventTypes = EventType " <> tshow payloadTy <> " :| []",+      "    , eventType = \\_ -> EventType " <> tshow payloadTy,+      "    , schemaVersion = 1",+      "    , encode = encode" <> payloadTy,+      "    , decode = \\_ -> parse" <> payloadTy,+      "    , upcasters = []",+      "    }",+      "",+      stem <> "JobCodec :: JobCodec " <> payloadTy,+      stem <> "JobCodec = keiroJobCodec " <> stem <> "PayloadCodec"+    ]+  where+    payloadTy = wqPayloadName w+    stem = lowerFirst (T.concat (map pascal (T.splitOn "_" (wqName w))))++-- | 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 $+    [ 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+    [ 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 #-}",+      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 $+    [ 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 $+    [ 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 DeriveAnyClass #-}" | hasSnapshot a]+      ++ [ "{-# LANGUAGE DuplicateRecordFields #-}",+           "{-# 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 (CanonicalStateShape, CanonicalTypeName)" | hasSnapshot a]+      ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (aGeneratedNominals a)+      ++ map ("import " <>) (domainConsumerImports a)+      ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)",+           "",+           sectionsOf+             [ [emitVertex a],+               map (emitRecord a) (aCommands a),+               [emitSum (aName a <> "Command") (aCommands a)],+               map (emitRecord a) (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++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]+      ++ [ line+         | hasSnapshot a,+           line <-+             [ "instance CanonicalStateShape " <> aVertexType a,+               "instance CanonicalTypeName " <> aVertexType a+             ]+         ]++emitRecord :: Agg -> ResolvedCtor -> Text+emitRecord a rc =+  nl $+    [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data"+    ]+      ++ recordFields [(name, renderDomainType a fieldType) | (name, fieldType) <- 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 a (aRegs a)++regListLines :: Agg -> [ResolvedRegister] -> [Text]+regListLines _ [] = ["  '[]"]+regListLines a rs =+  [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType a (rrType 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 (rrName r) <> ") " <> regInitialValue a r <> " $"+      | r <- init rs+      ]+        ++ ["  RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue a lastR <> " RNil"]+      where+        lastR = last rs++-- | The Haskell initial value for a register, by the category of its type.+regInitialValue :: Agg -> ResolvedRegister -> Text+regInitialValue aggregate register = case rrInitial register of+  InitialId name -> case find ((== name) . resolvedNominalName) (aGeneratedNominals aggregate) >>= generatedIdSampleHaskell aggregate of+    Just value -> value+    Nothing -> renderRegisterInitial (rrInitial register)+  _ -> renderRegisterInitial (rrInitial register)++domainConsumerImports :: Agg -> [Text]+domainConsumerImports a =+  sort . nub $+    Set.toList (Set.unions [aggregateImports (aSymbols a) resolved | resolved <- aggregateTypes])+      <> [ qualifiedModule initialValue <> " qualified"+         | declaration <- mappedUses a,+           initialValue <- maybeToListText (mappedInitial declaration)+         ]+      <> [ qualifiedModule initialValue <> " qualified"+         | resolvedType <- aggregateTypes,+           AggregateNominal nominal <- [resolvedType],+           ConsumerNominal binding <- [resolvedNominalOwnership nominal],+           initialValue <- maybeToListText (consumerNominalInitial binding)+         ]+  where+    aggregateTypes = map snd (concatMap rcFields (aCommands a <> aEvents a)) <> map rrType (aRegs a)++mappedUses :: Agg -> [ResolvedMappedDecl]+mappedUses a =+  [ declaration+  | resolvedType <-+      map snd (concatMap rcFields (aCommands a <> aEvents a))+        <> map rrType (aRegs a),+    declaration <- maybeToListText (mappedDeclFor a resolvedType)+  ]++mappedDeclFor :: Agg -> ResolvedAggregateType -> Maybe ResolvedMappedDecl+mappedDeclFor a resolvedType = do+  key <- case resolvedType of+    AggregateMapped mappedKey -> Just mappedKey+    _ -> Nothing+  graph <- aTypeGraph a+  Map.lookup key (tgDeclarations graph)++mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName+mappedInitial (ResolvedStructural declaration _) = sdInitial declaration+mappedInitial (ResolvedOpaque declaration) = odInitial declaration++renderDomainType :: Agg -> ResolvedAggregateType -> Text+renderDomainType a = aggregateHaskellType (aSymbols a)++maybeToListText :: Maybe value -> [value]+maybeToListText = maybe [] pure++--------------------------------------------------------------------------------+-- Codec module+--------------------------------------------------------------------------------++emitCodec :: Agg -> Text+emitCodec a =+  nl $+    ["{-# LANGUAGE DataKinds #-}" | hasConsumerNominalIdCodec a]+      ++ ["{-# LANGUAGE TypeApplications #-}" | hasConsumerNominalIdCodec a]+      ++ ["{-# LANGUAGE LambdaCase #-}" | hasConsumerNominalCodec a || hasGeneratedNominalEnumCodec a]+      ++ [ "{-# LANGUAGE OverloadedRecordDot #-}",+           generatedBanner,+           "module " <> aGenPrefix a <> ".Codec (",+           "    " <> lowerFirst (aName a) <> "Codec,",+           "    parse" <> aName a <> "Event,",+           "    encode" <> aName a <> "Event,"+         ]+      ++ concatMap mappedExports (codecMappedDeclarations a)+      ++ [ ") where",+           "",+           "import " <> aGenPrefix a <> ".Domain"+         ]+      ++ generatedNominalCodecImports (aggregateCheckedService a) (aContext a) (codecGeneratedNominals a)+      ++ ( if hasMappedCodec a+             then+               [ "import Control.Monad (unless)",+                 "import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))",+                 "import Data.Aeson.Key qualified as Key",+                 "import Data.Aeson.KeyMap qualified as KeyMap"+               ]+             else ["import Data.Aeson (Value, object, withObject, (.:), (.=))"]+         )+      ++ [ "import Data.Aeson.Types (Parser, parseEither)",+           "import Data.List.NonEmpty (NonEmpty (..))"+         ]+      ++ ( if hasMappedCodec a+             then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"]+             else []+         )+      ++ [ "import Data.Text (Text)",+           "import qualified Data.Text as T"+         ]+      ++ ["import Data.KindID qualified as KindID" | hasConsumerNominalIdCodec a]+      ++ ["import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)" | hasEnforcedConsumerNominalIdCodec a]+      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" | hasConsumerNominalCodec a]+      ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasMappedCodec a]+      ++ [ "import Keiro.Codec (Codec (..), EventType (..))",+           upcasterImport a+         ]+      ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a]+      ++ [nl (map ("import " <>) (codecNominalImports a)) | hasConsumerNominalCodec a]+      ++ [ "",+           emitEnumParsers a,+           emitConsumerNominalParsers a+         ]+      ++ [emitMappedCodecs a | hasMappedCodec a]+      ++ [ "",+           emitCodecValue a,+           "",+           emitEncode a,+           "",+           emitDecode a,+           "",+           "mapLeftText :: Either String b -> Either Text b",+           "mapLeftText = either (Left . T.pack) Right"+         ]+      ++ ( if hasMappedCodec a+             then+               [ "",+                 "rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()",+                 "rejectUnknownFields label allowed objectValue =",+                 "  unless (null extras) (fail (label <> \" contains unknown fields: \" <> show extras))",+                 "  where",+                 "    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))"+               ]+             else []+         )+  where+    mappedExports (ResolvedStructural declaration _) =+      [ "    encode" <> sdName declaration <> "Mapped,",+        "    decode" <> sdName declaration <> "Mapped,"+      ]+    mappedExports ResolvedOpaque {} = []++hasMappedCodec :: Agg -> Bool+hasMappedCodec = not . null . codecMappedDeclarations++hasConsumerNominalCodec :: Agg -> Bool+hasConsumerNominalCodec = not . null . codecConsumerNominals++hasConsumerNominalIdCodec :: Agg -> Bool+hasConsumerNominalIdCodec aggregate =+  any+    (\nominal -> case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False)+    (codecConsumerNominals aggregate)++hasEnforcedConsumerNominalIdCodec :: Agg -> Bool+hasEnforcedConsumerNominalIdCodec aggregate =+  any+    ( \nominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation prefix -> isJust (idDomainContractFor (aLanguageContract aggregate) prefix)+        _ -> False+    )+    (codecConsumerNominals aggregate)++hasGeneratedNominalEnumCodec :: Agg -> Bool+hasGeneratedNominalEnumCodec aggregate =+  any+    (\nominal -> case resolvedNominalRepresentation nominal of EnumRepresentation {} -> True; _ -> False)+    (codecGeneratedNominals aggregate)++emitEnumParsers :: Agg -> Text+emitEnumParsers a =+  sectionsOf+    [ [emitEnumParser nominal | nominal <- codecGeneratedNominals a, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]]+    ]++emitEnumParser :: ResolvedNominalType -> Text+emitEnumParser nominal = case resolvedNominalRepresentation nominal of+  EnumRepresentation constructors ->+    nl $+      [ "parse" <> name <> " :: Text -> Parser " <> name,+        "parse" <> name <> " = \\case"+      ]+        ++ ["  " <> tshow wire <> " -> pure " <> constructor | (constructor, wire) <- NE.toList constructors]+        ++ ["  _ -> fail " <> tshow ("unknown " <> name)]+  _ -> error "non-enum reached generated enum parser emission"+  where+    name = resolvedNominalName nominal++emitConsumerNominalParsers :: Agg -> Text+emitConsumerNominalParsers aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)]+  where+    emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of+      (IdRepresentation prefix, ConsumerNominal binding) ->+        nl+          [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding),+            parserName nominal <> " input = " <> validationPrefix prefix <> "case KindID.parseText @" <> tshow prefix <> " input of",+            "  Left reason -> fail (show reason)",+            "  Right representation -> pure (nominalFromRepresentation " <> unQualifiedValueName (consumerNominalBinding binding) <> " representation)"+          ]+      (EnumRepresentation constructors, ConsumerNominal binding) ->+        nl $+          [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding),+            parserName nominal <> " = \\case"+          ]+            <> [ "  "+                   <> tshow wire+                   <> " -> pure (nominalFromRepresentation "+                   <> unQualifiedValueName (consumerNominalBinding binding)+                   <> " "+                   <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal)+                   <> "."+                   <> constructor+                   <> ")"+               | (constructor, wire) <- NE.toList constructors+               ]+            <> ["  _ -> fail " <> tshow ("unknown " <> resolvedNominalName nominal <> " wire value")]+      _ -> ""+    parserName nominal = "parse" <> resolvedNominalName nominal <> "Nominal"+    validationPrefix prefix = case idDomainContractFor (aLanguageContract aggregate) prefix of+      Nothing -> ""+      Just _ ->+        "case validateIdDomainText (typeIdV7Domain "+          <> tshow prefix+          <> ") input of Left reason -> fail (show reason); Right () -> "++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,+           "    }"+         ]+      ++ upcasterRungDecls 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, Text)]+upcasterEntries a =+  [ (m, rcName e, "upcast" <> rcName e <> "V" <> tshow' m)+  | e <- aEvents a,+    Just m <- [rcUpcastFrom e]+  ]++upcastersExpr :: Agg -> Text+upcastersExpr a =+  "[" <> T.intercalate ", " ["(" <> tshow' m <> ", upcastRungV" <> tshow' m <> ")" | (m, _) <- upcasterRungs a] <> "]"++-- | Group event-specific holes into one migration rung per aggregate-global+-- source version.  Event metadata stamps every kind with the aggregate's+-- schema version, so a rung must explicitly pass foreign event kinds through.+upcasterRungs :: Agg -> [(Int, [(Text, Text)])]+upcasterRungs a =+  [ (source, [(eventName, fn) | (_, eventName, fn) <- entries])+  | entries@((source, _, _) : _) <- groupBy sameSource (sortOn firstSource (upcasterEntries a))+  ]+  where+    firstSource (source, _, _) = source+    sameSource (source, _, _) (otherSource, _, _) = source == otherSource++upcasterRungDecls :: Agg -> [Text]+upcasterRungDecls a = concatMap rung (upcasterRungs a)+  where+    rung (source, entries) =+      [ "",+        "upcastRungV" <> tshow' source <> " :: EventType -> Value -> Either Text Value"+      ]+        ++ [ "upcastRungV" <> tshow' source <> " (EventType " <> tshow eventName <> ") value = " <> fn <> " value"+           | (eventName, fn) <- entries+           ]+        ++ [ "-- Kinds whose shape did not change at this rung pass through unchanged; their",+             "-- stamped version is aggregate-global, not their own shape history.",+             "upcastRungV" <> tshow' source <> " _ value = Right value"+           ]++-- | 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 ", " [fn | (_, _, fn) <- 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+        <> " .= "+        <> encodeFieldValue n ty+    encodeFieldValue name ty = case ty of+      AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> name)+      _ -> case fieldCat a ty of+        MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> name+        MappedOpaqueCat {} -> "toJSON payload." <> name+        _ -> "payload." <> name+    encodeNominalValue nominal value = case resolvedNominalOwnership nominal of+      GeneratedNominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value+        EnumRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value+        ScalarRepresentation {} -> value+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> "KindID.toText (nominalToRepresentation " <> bindingName binding <> " " <> value <> ")"+        EnumRepresentation {} ->+          nominalRepresentationModule (aContext a) (resolvedNominalName nominal)+            <> "."+            <> lowerFirst (resolvedNominalName nominal)+            <> "RepresentationText (nominalToRepresentation "+            <> bindingName binding+            <> " "+            <> value+            <> ")"+        ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value+    bindingName = unQualifiedValueName . consumerNominalBinding++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 ty of+      AggregateNominal nominal -> decodeNominalField n nominal+      _ -> case fieldCat a ty of+        MappedStructuralCat declaration _ -> "(o .: " <> tshow n <> " >>= parse" <> sdName declaration <> "Mapped)"+        MappedOpaqueCat {} -> "o .: " <> tshow n+        _ -> "o .: " <> tshow n+    decodeNominalField name nominal = case resolvedNominalOwnership nominal of+      GeneratedNominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation prefix -> case idDomainContractFor (aLanguageContract a) prefix of+          Nothing -> "(" <> resolvedNominalName nominal <> " <$> o .: " <> tshow name <> ")"+          Just _ -> "(" <> legacyNominalConstructorName nominal <> " <$> o .: " <> tshow name <> ")"+        EnumRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> ")"+        ScalarRepresentation {} -> "o .: " <> tshow name+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> "Nominal)"+        EnumRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> "Nominal)"+        ScalarRepresentation {} -> "(nominalFromRepresentation " <> unQualifiedValueName (consumerNominalBinding binding) <> " <$> o .: " <> tshow name <> ")"++codecConsumerNominals :: Agg -> [ResolvedNominalType]+codecConsumerNominals aggregate =+  Map.elems . Map.fromList $+    [ (resolvedNominalName nominal, nominal)+    | event <- aEvents aggregate,+      (_, AggregateNominal nominal) <- rcFields event,+      ConsumerNominal {} <- [resolvedNominalOwnership nominal]+    ]++codecGeneratedNominals :: Agg -> [ResolvedNominalType]+codecGeneratedNominals aggregate =+  generatedNominalsInTypes+    [ resolvedType+    | event <- aEvents aggregate,+      (_, resolvedType) <- rcFields event+    ]++codecNominalImports :: Agg -> [Text]+codecNominalImports aggregate =+  sort . nub $+    concat+      [ [ hsModule (consumerNominalHaskell binding) <> " qualified",+          qualifiedModule (consumerNominalBinding binding) <> " qualified"+        ]+          <> [ nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified"+             | EnumRepresentation {} <- [resolvedNominalRepresentation nominal]+             ]+      | nominal <- codecConsumerNominals aggregate,+        ConsumerNominal binding <- [resolvedNominalOwnership nominal]+      ]++codecMappedImports :: Agg -> [Text]+codecMappedImports a = case aTypeGraph a of+  Nothing -> []+  Just graph ->+    sort . nub $+      [ structuralShapeModule (aContext a) (sdName declaration) <> " qualified"+      | ResolvedStructural declaration _ <- codecMappedDeclarations a+      ]+        <> [ hsModule (sdHaskell declaration) <> " qualified"+           | ResolvedStructural declaration _ <- codecMappedDeclarations a+           ]+        <> [ qualifiedModule (sdBinding declaration) <> " qualified"+           | ResolvedStructural declaration _ <- codecMappedDeclarations a+           ]+        <> [ hsModule (odHaskell declaration) <> " qualified"+           | ResolvedOpaque declaration <- codecMappedDeclarations a+           ]+        <> [ hsModule (odHaskell declaration) <> " qualified"+           | ResolvedStructural _ shape <- codecMappedDeclarations a,+             key <- directShapeRefs shape,+             Just (ResolvedOpaque declaration) <- [Map.lookup key (tgDeclarations graph)]+           ]++codecMappedDeclarations :: Agg -> [ResolvedMappedDecl]+codecMappedDeclarations a = case aTypeGraph a of+  Nothing -> []+  Just graph ->+    mapMaybe (\key -> Map.lookup key (tgDeclarations graph)) (sort (Map.keys selected))+    where+      roots =+        [ key+        | event <- aEvents a,+          (_, AggregateMapped key) <- rcFields event,+          Map.member key (tgDeclarations graph)+        ]+      selected =+        Map.fromList+          [ (key, ())+          | root <- roots,+            key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root (tgReachability graph))+          ]++directShapeRefs :: ResolvedMappedShape -> [MappedKey]+directShapeRefs =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields -> concatMap (exprRefs . rwfType) fields,+        onEnum = const [],+        onUnion = \_ arms -> concatMap (maybe [] exprRefs . rwaPayload) arms+      }++exprRefs :: ResolvedTypeExpr -> [MappedKey]+exprRefs =+  foldTypeExpr+    TypeExprAlgebra+      { onText = [],+        onInt = [],+        onInteger = [],+        onBool = [],+        onNatural = [],+        onTime = [],+        onJson = [],+        onOptional = id,+        onList = id,+        onMap = id,+        onRef = pure+      }++emitMappedCodecs :: Agg -> Text+emitMappedCodecs a = case aTypeGraph a of+  Nothing -> ""+  Just graph ->+    T.intercalate+      "\n\n"+      [ emitStructuralCodec a graph declaration shape+      | ResolvedStructural declaration shape <- codecMappedDeclarations a+      ]++emitStructuralCodec :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitStructuralCodec a graph declaration shape =+  nl+    [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value",+      "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding,+      "",+      "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType,+      "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value",+      "",+      "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType,+      "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped",+      "",+      "encode" <> name <> "Shape :: " <> shapeType <> " -> Value",+      emitShapeEncoder a graph declaration shape,+      "",+      "parse" <> name <> "Shape :: Value -> Parser " <> shapeType,+      emitShapeDecoder a graph declaration shape+    ]+  where+    name = sdName declaration+    consumerType = renderHaskellSource (sdHaskell declaration)+    shapeType = structuralShapeModule (aContext a) name <> "." <> name <> "Shape"+    binding = unQualifiedValueName (sdBinding declaration)++emitShapeEncoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitShapeEncoder a graph declaration =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields ->+          nl $+            ["encode" <> name <> "Shape shape =", "  object"]+              <> objectEntries+                [ tshow (rwfKey field)+                    <> " .= "+                    <> encodeShapeExpr a graph (rwfType field) (shapeModuleName <> "." <> rwfHaskell field <> " shape")+                | field <- fields+                ],+        onEnum = \entries ->+          nl $+            ["encode" <> name <> "Shape = \\case"]+              <> ["  " <> shapeModuleName <> "." <> weCtor entry <> " -> String " <> tshow (weTag entry) | entry <- entries],+        onUnion = \encoding arms ->+          nl $+            ["encode" <> name <> "Shape = \\case"]+              <> concatMap (unionEncodeArm encoding) arms+      }+  where+    name = sdName declaration+    shapeModuleName = structuralShapeModule (aContext a) name+    unionEncodeArm encoding arm =+      [ "  " <> shapeModuleName <> "." <> rwaCtor arm <> payloadPattern <> " ->",+        "    object"+      ]+        <> objectEntries+          ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"]+              <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload"+                 | payload <- maybeToListText (rwaPayload arm)+                 ]+          )+      where+        payloadPattern = maybe "" (const " payload") (rwaPayload arm)++emitShapeDecoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitShapeDecoder a graph declaration =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \constructor unknownFields fields ->+          nl $+            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do"+            ]+              <> rejectLine "  " unknownFields (map rwfKey fields) "objectValue"+              <> [ "  " <> shapeModuleName <> "." <> constructor,+                   "    <$> " <> T.intercalate "\n    <*> " (map (decodeRecordField a graph) fields)+                 ],+        onEnum = \entries ->+          nl $+            [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of"+            ]+              <> ["  " <> tshow (weTag entry) <> " -> pure " <> shapeModuleName <> "." <> weCtor entry | entry <- entries]+              <> ["  _ -> fail " <> tshow ("unknown " <> name <> " wire value")],+        onUnion = \encoding arms ->+          nl $+            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do",+              "  tag <- objectValue .: " <> tshow (ueTagField encoding) <> " :: Parser Text",+              "  case tag of"+            ]+              <> concatMap (unionDecodeArm encoding) arms+              <> ["    _ -> fail " <> tshow ("unknown " <> name <> " union tag")]+      }+  where+    name = sdName declaration+    shapeModuleName = structuralShapeModule (aContext a) name+    rejectLine _ IgnoreUnknown _ _ = []+    rejectLine indent RejectUnknown allowed objectName =+      [indent <> "rejectUnknownFields " <> tshow name <> " " <> renderTextList allowed <> " " <> objectName]+    unionDecodeArm encoding arm =+      ["    " <> tshow (rwaTag arm) <> " -> do"]+        <> rejectLine "      " (ueUnknownFields encoding) allowed "objectValue"+        <> [ case rwaPayload arm of+               Nothing -> "      pure " <> shapeModuleName <> "." <> rwaCtor arm+               Just payload ->+                 "      "+                   <> shapeModuleName+                   <> "."+                   <> rwaCtor arm+                   <> " <$> (objectValue .: "+                   <> tshow (ueContentsField encoding)+                   <> " >>= ("+                   <> decodeShapeExpr a graph payload+                   <> "))"+           ]+      where+        allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing]++decodeRecordField :: Agg -> TypeGraph -> ResolvedWireField -> Text+decodeRecordField a graph field = case rwfPresence field of+  PRequired ->+    "((objectValue .: " <> key <> " :: Parser Value) >>= (" <> decoder <> "))"+  POptional ->+    "(case KeyMap.lookup (Key.fromText "+      <> key+      <> ") objectValue of Nothing -> "+      <> missing+      <> "; Just presentValue -> "+      <> "("+      <> decoder+      <> ") presentValue)"+  where+    key = tshow (rwfKey field)+    decoder = decodeShapeExpr a graph (rwfType field)+    missing = case rwfOnMissing field of+      Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field)+      Just onMissing -> "pure " <> renderMissingDefault a graph (rwfType field) onMissing++encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text+encodeShapeExpr _a graph expression value =+  foldTypeExpr+    TypeExprAlgebra+      { onText = \v -> "toJSON (" <> v <> ")",+        onInt = \v -> "toJSON (" <> v <> ")",+        onInteger = \v -> "toJSON (" <> v <> ")",+        onBool = \v -> "toJSON (" <> v <> ")",+        onNatural = \v -> "toJSON (" <> v <> ")",+        onTime = \v -> "toJSON (" <> v <> ")",+        onJson = id,+        onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")",+        onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))",+        onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))",+        onRef = \key v -> case Map.lookup key (tgDeclarations graph) of+          Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")"+          Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")"+          Nothing -> "toJSON (" <> v <> ")"+      }+    expression+    value++decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text+decodeShapeExpr _a graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = "parseJSON",+        onInt = "parseJSON",+        onInteger = "parseJSON",+        onBool = "parseJSON",+        onNatural = "parseJSON",+        onTime = "parseJSON",+        onJson = "pure",+        onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other",+        onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")",+        onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")",+        onRef = \key -> case Map.lookup key (tgDeclarations graph) of+          Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape"+          Just (ResolvedOpaque _) -> "parseJSON"+          Nothing -> "parseJSON"+      }++renderMissingDefault :: Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text+renderMissingDefault a graph expression = \case+  OmNull -> "Nothing"+  OmText value -> tshow value+  OmInt value -> T.pack (show value)+  OmBool value -> if value then "True" else "False"+  OmEmptyList -> "[]"+  OmEmptyMap -> "Map.empty"+  OmCtor constructor -> case expression of+    RRef key -> case Map.lookup key (tgDeclarations graph) of+      Just (ResolvedStructural declaration _) -> structuralShapeModule (aContext a) (sdName declaration) <> "." <> constructor+      _ -> constructor+    _ -> constructor++objectEntries :: [Text] -> [Text]+objectEntries entries =+  [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries]+    <> ["      ]"]+  where+    lead 0 = "      [ "+    lead _ = "      , "++renderTextList :: [Text] -> Text+renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"++--------------------------------------------------------------------------------+-- Authoritative version-2 expressions and transducer+--------------------------------------------------------------------------------++hasVersion2Ownership :: Agg -> Bool+hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions++transitionEntries :: Agg -> [(Int, Transition)]+transitionEntries aggregate = zip [1 ..] (aTransitions aggregate)++transitionStem :: Int -> Transition -> Text+transitionStem index transition =+  "transition"+    <> tshow' index+    <> pascal (tSource transition)+    <> pascal (tCommand transition)++guardFunctionName :: Int -> Transition -> Text+guardFunctionName index transition = transitionStem index transition <> "Guard"++writeFunctionName :: Int -> Transition -> Name -> Text+writeFunctionName index transition registerName =+  transitionStem index transition <> "Write" <> pascal registerName++holeFunctionName :: Int -> Transition -> Text+holeFunctionName index transition = transitionStem index transition <> "Hole"++holeFoldVersionName :: Int -> Transition -> Text+holeFoldVersionName index transition = holeFunctionName index transition <> "FoldVersion"++outputFunctionName :: Int -> Transition -> Int -> Name -> Text+outputFunctionName transitionIndex transition emitIndex eventName =+  transitionStem transitionIndex transition+    <> "Output"+    <> tshow' emitIndex+    <> pascal eventName++-- | Legacy create-once output-hook names made obsolete by authoritative+-- version-2 @fields(Command)@ generation.  Scaffolding reports these names as+-- safe-to-remove candidates without parsing or modifying consumer Haskell.+obsoleteGeneratedOutputHooks :: Spec -> [(Name, Text)]+obsoleteGeneratedOutputHooks spec =+  [ ( aggName aggregate,+      outputFunctionName transitionIndex transition emitIndex eventName+    )+  | aggregate <- [value | NAggregate value <- specNodes spec],+    (transitionIndex, transition) <- zip [1 ..] (aggTransitions aggregate),+    (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+    Right GeneratedCommandIdentity {} <- [eventOutputMapping spec aggregate transition emitIndex eventName]+  ]++commandForTransition :: Agg -> Transition -> ResolvedCtor+commandForTransition aggregate transition =+  fromMaybe+    (error ("validated aggregate command disappeared: " <> T.unpack (tCommand transition)))+    (find ((== tCommand transition) . rcName) (aCommands aggregate))++eventForName :: Agg -> Name -> ResolvedCtor+eventForName aggregate eventName =+  fromMaybe+    (error ("validated aggregate event disappeared: " <> T.unpack eventName))+    (find ((== eventName) . rcName) (aEvents aggregate))++commandFieldsType :: Transition -> Text+commandFieldsType transition = "RegFieldsOf " <> tCommand transition <> "Data"++payloadProjectionType :: Agg -> Transition -> Text+payloadProjectionType aggregate transition =+  "B.PayloadProj "+    <> aName aggregate+    <> "Regs "+    <> aName aggregate+    <> "Command ("+    <> commandFieldsType transition+    <> ")"++expressionFunctionNames :: Agg -> [Text]+expressionFunctionNames aggregate =+  concat+    [ maybe [] (const [guardFunctionName index transition]) (tGuard transition)+        <> [writeFunctionName index transition registerName | (registerName, _) <- tWrites transition]+    | (index, transition) <- transitionEntries aggregate,+      tImplementation transition == GeneratedImplementation+    ]++emitExpressions :: Agg -> Text+emitExpressions aggregate+  | null exports = nl [generatedBanner, "module " <> aGenPrefix aggregate <> ".Expressions () where"]+  | otherwise =+      nl $+        [ "{-# LANGUAGE DataKinds #-}",+          "{-# LANGUAGE OverloadedLabels #-}",+          "{-# LANGUAGE OverloadedRecordDot #-}",+          "{-# LANGUAGE TypeApplications #-}",+          generatedBanner+        ]+          ++ moduleDeclaration+          ++ [ "",+               "import " <> aGenPrefix aggregate <> ".Domain",+               "import Keiki.Builder qualified as B",+               "import Keiki.Core qualified as K",+               "import Keiki.Generics (RegFieldsOf)"+             ]+          ++ ["import Data.Text (Text)" | expressionUsesType AggregateText || expressionUsesNominalEqualityKey]+          ++ ["import Data.Time.Clock (UTCTime)" | expressionUsesType AggregateTime && not expressionUsesTimeLiteral]+          ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral]+          ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral]+          ++ ["import Numeric.Natural (Natural)" | expressionUsesType AggregateNatural]+          ++ generatedNominalTypeImportsForService (aggregateCheckedService aggregate) (aContext aggregate) generatedExpressionNominals+          ++ structuralProjectionImport+          ++ generatedNominalProjectionImport+          ++ consumerNominalProjectionImport+          ++ consumerImports+          ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral]+          ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral]+          ++ consumerLiteralImports+          ++ concatMap (uncurry (emitTransitionExpressions aggregate)) (transitionEntries aggregate)+  where+    exports = expressionFunctionNames aggregate+    moduleDeclaration = case exports of+      firstExport : rest ->+        [ "module " <> aGenPrefix aggregate <> ".Expressions",+          "  ( " <> firstExport+        ]+          ++ ["  , " <> value | value <- rest]+          ++ ["  ) where"]+      [] -> error "non-empty expression export invariant"+    structuralProjectionImport =+      [ "import " <> structuralProjectionModule (aContext aggregate) <> " qualified as StructuralProjections"+      | maybe False (not . null . projectionSpecs) (aTypeGraph aggregate)+      ]+    generatedNominalProjectionImport =+      [ "import " <> generatedNominalModule (aContext aggregate) <> " qualified as GeneratedNominals"+      | any expressionUsesGeneratedNominalProjection resolvedExpressions+      ]+    consumerNominalProjectionImport =+      [ "import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections"+      | any expressionUsesConsumerNominalProjection resolvedExpressions+      ]+    consumerImports =+      map ("import " <>)+        . filter (not . builtinExpressionImport)+        . sort+        . nub+        . Set.toList+        . Set.unions+        $ [ aggregateImports (aSymbols aggregate) resolvedType+          | resolvedType <- map rrType (aRegs aggregate) <> map snd (concatMap rcFields (aCommands aggregate))+          ]+    consumerLiteralImports =+      [ "import " <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified"+      | nominal <- consumerLiteralNominals,+        EnumRepresentation {} <- [resolvedNominalRepresentation nominal]+      ]+        <> [ "import " <> qualifiedModule (consumerNominalBinding binding) <> " qualified"+           | nominal <- consumerLiteralNominals,+             ConsumerNominal binding <- [resolvedNominalOwnership nominal]+           ]+    resolvedExpressions = resolvedGeneratedExpressions aggregate+    expressionUsesType wanted = any (anyTypedExpression ((== wanted) . typedScalarType)) resolvedExpressions+    expressionUsesTimeLiteral = any (anyTypedExpression isTimeLiteral) resolvedExpressions+    expressionUsesConsumerNominalLiteral = not (null consumerLiteralNominals)+    expressionUsesConsumerIdLiteral = any (isIdRepresentation . resolvedNominalRepresentation) consumerLiteralNominals+    expressionUsesNominalEqualityKey = any (anyTypedExpression isNominalEqualityOperand) resolvedExpressions+    consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression]+    generatedExpressionNominals =+      stableNominals+        [ nominal+        | expression <- resolvedExpressions,+          nominal <- typedGeneratedNominals expression+        ]+    isTimeLiteral expression = case typedScalarNode expression of+      TypedLiteral ScalarTimeValue {} -> True+      _ -> False+    isIdRepresentation IdRepresentation {} = True+    isIdRepresentation _ = False++builtinExpressionImport :: Text -> Bool+builtinExpressionImport imported =+  any (`T.isPrefixOf` imported) ["Data.Text", "Data.Time", "Numeric.Natural"]++resolvedGeneratedExpressions :: Agg -> [TypedScalarExpr]+resolvedGeneratedExpressions aggregate =+  concat+    [ maybe [] (pure . resolvedGuard index transition) (tGuard transition)+        <> [ resolvedWrite index transition registerName expression+           | (registerName, expression) <- tWrites transition+           ]+    | (index, transition) <- transitionEntries aggregate,+      tImplementation transition == GeneratedImplementation+    ]+  where+    environment transition = expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition+    resolvedGuard index transition expression =+      expressionOrDie (guardFunctionName index transition) (resolveGuardExpr (environment transition) expression)+    resolvedWrite index transition registerName expression =+      expressionOrDie (writeFunctionName index transition registerName) (resolveWriteExpr (environment transition) registerName expression)++anyTypedExpression :: (TypedScalarExpr -> Bool) -> TypedScalarExpr -> Bool+anyTypedExpression predicate expression =+  predicate expression || any (anyTypedExpression predicate) (typedExpressionChildren expression)++typedExpressionChildren :: TypedScalarExpr -> [TypedScalarExpr]+typedExpressionChildren expression = case typedScalarNode expression of+  TypedLiteral {} -> []+  TypedRoot {} -> []+  TypedProject {} -> []+  TypedAdd _ left right -> [left, right]+  TypedSubtract _ left right -> [left, right]+  TypedMultiply _ left right -> [left, right]+  TypedEqual left right -> [left, right]+  TypedNotEqual left right -> [left, right]+  TypedCompare _ left right -> [left, right]+  TypedAnd left right -> [left, right]+  TypedOr left right -> [left, right]++isNominalEqualityOperand :: TypedScalarExpr -> Bool+isNominalEqualityOperand expression = case (typedScalarType expression, typedScalarNode expression) of+  (AggregateNominal nominal, TypedRoot {}) -> case (resolvedNominalOwnership nominal, resolvedNominalRepresentation nominal) of+    (ConsumerNominal {}, ScalarRepresentation {}) -> True+    (_, IdRepresentation {}) -> True+    (_, EnumRepresentation {}) -> True+    _ -> False+  _ -> False++expressionUsesGeneratedNominalProjection :: TypedScalarExpr -> Bool+expressionUsesGeneratedNominalProjection = anyTypedExpression $ \expression -> case (typedScalarType expression, typedScalarNode expression) of+  (AggregateNominal nominal, TypedRoot {}) -> case (resolvedNominalOwnership nominal, resolvedNominalRepresentation nominal) of+    (GeneratedNominal, IdRepresentation {}) -> True+    (GeneratedNominal, EnumRepresentation {}) -> True+    _ -> False+  _ -> False++expressionUsesConsumerNominalProjection :: TypedScalarExpr -> Bool+expressionUsesConsumerNominalProjection = anyTypedExpression $ \expression -> case (typedScalarType expression, typedScalarNode expression) of+  (AggregateNominal nominal, TypedRoot {}) -> case resolvedNominalOwnership nominal of+    ConsumerNominal {} -> True+    GeneratedNominal -> False+  _ -> False++typedConsumerLiteralNominals :: TypedScalarExpr -> [ResolvedNominalType]+typedConsumerLiteralNominals expression = own <> concatMap typedConsumerLiteralNominals (typedExpressionChildren expression)+  where+    own = case (typedScalarType expression, typedScalarNode expression) of+      (AggregateNominal nominal, TypedLiteral ScalarEnumValue {})+        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]+      (AggregateNominal nominal, TypedLiteral ScalarIdValue {})+        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]+      _ -> []++typedGeneratedNominals :: TypedScalarExpr -> [ResolvedNominalType]+typedGeneratedNominals expression = own <> concatMap typedGeneratedNominals (typedExpressionChildren expression)+  where+    own = case typedScalarType expression of+      AggregateNominal nominal+        | GeneratedNominal <- resolvedNominalOwnership nominal -> [nominal]+      _ -> []++emitTransitionExpressions :: Agg -> Int -> Transition -> [Text]+emitTransitionExpressions aggregate index transition+  | tImplementation transition /= GeneratedImplementation = []+  | otherwise =+      concat+        [ maybe [] (emitGuardDefinition aggregate index transition) (tGuard transition),+          concatMap (uncurry (emitWriteDefinition aggregate index transition)) (tWrites transition)+        ]++emitGuardDefinition :: Agg -> Int -> Transition -> Expr -> [Text]+emitGuardDefinition aggregate index transition expression =+  [ "",+    functionName <> " :: " <> payloadProjectionType aggregate transition <> " -> K.HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command",+    functionName <> " d = " <> renderKeikiPredicate aggregate transition resolved+  ]+  where+    functionName = guardFunctionName index transition+    resolved = expressionOrDie functionName (resolveGuardExpr (expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition) expression)++emitWriteDefinition :: Agg -> Int -> Transition -> Name -> Expr -> [Text]+emitWriteDefinition aggregate index transition registerName expression =+  [ "",+    functionName+      <> " :: "+      <> payloadProjectionType aggregate transition+      <> " -> K.Term "+      <> aName aggregate+      <> "Regs "+      <> aName aggregate+      <> "Command ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType aggregate (typedScalarType resolved),+    functionName <> " d = " <> renderKeikiTerm aggregate transition resolved+  ]+  where+    functionName = writeFunctionName index transition registerName+    resolved = expressionOrDie functionName (resolveWriteExpr (expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition) registerName expression)++expressionOrDie :: Text -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr -> TypedScalarExpr+expressionOrDie owner = either (error . (("validated expression disappeared for " <> T.unpack owner <> ": ") <>) . show) id++renderKeikiPredicate :: Agg -> Transition -> TypedScalarExpr -> Text+renderKeikiPredicate aggregate transition expression = case typedScalarNode expression of+  TypedEqual left right -> "K.PEq " <> atom (renderComparisonTerm aggregate transition left) <> " " <> atom (renderComparisonTerm aggregate transition right)+  TypedNotEqual left right -> "K.pnot (K.PEq " <> atom (renderComparisonTerm aggregate transition left) <> " " <> atom (renderComparisonTerm aggregate transition right) <> ")"+  TypedCompare operator left right ->+    "K.PCmp "+      <> renderKeikiCmp operator+      <> " "+      <> atom (renderComparisonTerm aggregate transition left)+      <> " "+      <> atom (renderComparisonTerm aggregate transition right)+  TypedAnd left right -> "K.PAnd " <> atom (renderKeikiPredicate aggregate transition left) <> " " <> atom (renderKeikiPredicate aggregate transition right)+  TypedOr left right -> "K.POr " <> atom (renderKeikiPredicate aggregate transition left) <> " " <> atom (renderKeikiPredicate aggregate transition right)+  _ -> "K.PEq " <> atom (renderKeikiTerm aggregate transition expression) <> " (K.lit True)"+  where+    atom value = "(" <> value <> ")"++renderKeikiCmp :: CmpOp -> Text+renderKeikiCmp = \case+  OpEq -> error "equality is rendered as PEq"+  OpNeq -> error "inequality is rendered as pnot PEq"+  OpLt -> "K.CmpLt"+  OpLe -> "K.CmpLe"+  OpGt -> "K.CmpGt"+  OpGe -> "K.CmpGe"++renderComparisonTerm :: Agg -> Transition -> TypedScalarExpr -> Text+renderComparisonTerm aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of+  (AggregateNominal nominal, TypedRoot provenance)+    | nominalComparisonProjection nominal -> renderNominalProjectionTerm aggregate transition nominal provenance+  (AggregateNominal nominal, TypedLiteral (ScalarEnumValue _ constructor)) ->+    "K.lit (" <> tshow (enumWireFor nominal constructor) <> " :: Text)"+  (AggregateNominal _, TypedLiteral (ScalarIdValue _ value)) ->+    "K.lit (" <> tshow value <> " :: Text)"+  _ -> renderKeikiTerm aggregate transition expression++nominalComparisonProjection :: ResolvedNominalType -> Bool+nominalComparisonProjection nominal = case resolvedNominalRepresentation nominal of+  IdRepresentation {} -> True+  EnumRepresentation {} -> True+  ScalarRepresentation {} -> case resolvedNominalOwnership nominal of+    ConsumerNominal {} -> True+    GeneratedNominal -> False++enumWireFor :: ResolvedNominalType -> Name -> Text+enumWireFor nominal constructor = case resolvedNominalRepresentation nominal of+  EnumRepresentation constructors -> fromMaybe (error "validated enum literal lost its wire spelling") (lookup constructor (NE.toList constructors))+  _ -> error "validated enum literal lost its enum representation"++renderNominalProjectionTerm :: Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text+renderNominalProjectionTerm aggregate transition nominal provenance = case provenance of+  ScalarRegisterRoot registerName ownerType ->+    "K.regProj "+      <> projectionQualifier+      <> "."+      <> witness+      <> " (#"+      <> registerName+      <> " :: K.Index "+      <> aName aggregate+      <> "Regs "+      <> renderDomainType aggregate ownerType+      <> ")"+  ScalarCommandRoot fieldName ownerType ->+    "K.inpProj "+      <> projectionQualifier+      <> "."+      <> witness+      <> " inCtor"+      <> tCommand transition+      <> " (#"+      <> fieldName+      <> " :: K.Index ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType aggregate ownerType+      <> ")"+  where+    projectionQualifier = case resolvedNominalOwnership nominal of+      GeneratedNominal -> "GeneratedNominals"+      ConsumerNominal {} -> "NominalProjections"+    witness = case resolvedNominalRepresentation nominal of+      ScalarRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Witness"+      IdRepresentation {} -> nominalEqualityWitnessName nominal+      EnumRepresentation {} -> nominalEqualityWitnessName nominal++renderKeikiTerm :: Agg -> Transition -> TypedScalarExpr -> Text+renderKeikiTerm aggregate transition expression = case typedScalarNode expression of+  TypedLiteral value -> renderKeikiLiteral aggregate (typedScalarType expression) value+  TypedRoot (ScalarRegisterRoot registerName _) -> "B.reg @" <> tshow registerName+  TypedRoot (ScalarCommandRoot fieldName _) -> "d." <> fieldName+  TypedProject provenance projection -> renderStructuralProjectionTerm aggregate transition provenance projection+  TypedAdd _ left right -> binary "K.tadd" left right+  TypedSubtract _ left right -> binary "K.tsub" left right+  TypedMultiply _ left right -> binary "K.tmul" left right+  TypedEqual {} -> impossiblePredicate+  TypedNotEqual {} -> impossiblePredicate+  TypedCompare {} -> impossiblePredicate+  TypedAnd {} -> impossiblePredicate+  TypedOr {} -> impossiblePredicate+  where+    binary operator left right = operator <> " " <> parenthesized left <> " " <> parenthesized right+    parenthesized = (\value -> "(" <> value <> ")") . renderKeikiTerm aggregate transition+    impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms"++renderStructuralProjectionTerm :: Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text+renderStructuralProjectionTerm aggregate transition provenance projection = case provenance of+  ScalarRegisterRoot registerName ownerType ->+    "K.regProj StructuralProjections."+      <> witness+      <> " (#"+      <> registerName+      <> " :: K.Index "+      <> aName aggregate+      <> "Regs "+      <> renderDomainType aggregate ownerType+      <> ")"+  ScalarCommandRoot fieldName ownerType ->+    "K.inpProj StructuralProjections."+      <> witness+      <> " inCtor"+      <> tCommand transition+      <> " (#"+      <> fieldName+      <> " :: K.Index ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType aggregate ownerType+      <> ")"+  where+    witness = lowerFirst (projectionTag (unMappedKey (scalarProjectionOwner projection)) (scalarProjectionPointer projection)) <> "Witness"++renderKeikiLiteral :: Agg -> ResolvedAggregateType -> ScalarValue -> Text+renderKeikiLiteral aggregate scalarType = \case+  ScalarTextValue value -> "K.lit (" <> tshow value <> " :: Text)"+  ScalarIntValue value -> "K.lit (" <> tshow' value <> " :: Int)"+  ScalarIntegerValue value -> "K.lit (" <> T.pack (show value) <> " :: Integer)"+  ScalarNaturalValue value -> "K.lit (" <> T.pack (show value) <> " :: Natural)"+  ScalarBoolValue value -> "K.lit " <> if value then "True" else "False"+  ScalarTimeValue value -> "K.lit " <> renderRegisterInitial (InitialTime value)+  ScalarEnumValue typeName constructor -> case scalarType of+    AggregateNominal nominal -> case resolvedNominalOwnership nominal of+      GeneratedNominal -> "K.lit " <> constructor+      ConsumerNominal binding ->+        "K.lit (nominalFromRepresentation "+          <> unQualifiedValueName (consumerNominalBinding binding)+          <> " "+          <> nominalRepresentationModule (aContext aggregate) typeName+          <> "."+          <> constructor+          <> ")"+    _ -> error "validated enum literal lost its nominal type"+  ScalarIdValue typeName value -> case scalarType of+    AggregateNominal nominal -> case resolvedNominalOwnership nominal of+      GeneratedNominal -> case idDomainContractFor (aLanguageContract aggregate) =<< idPrefixOf nominal of+        Nothing -> "K.lit (" <> typeName <> " " <> tshow value <> ")"+        Just _ ->+          "K.lit (case parse"+            <> typeName+            <> " "+            <> tshow value+            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\")"+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        IdRepresentation prefix ->+          "K.lit (nominalFromRepresentation "+            <> unQualifiedValueName (consumerNominalBinding binding)+            <> " (case KindID.parseText @"+            <> tshow prefix+            <> " "+            <> tshow value+            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\"))"+        _ -> error "validated ID literal lost its ID representation"+    _ -> error "validated ID literal lost its nominal type"+  where+    idPrefixOf nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> Just prefix+      _ -> Nothing++generatedIdSampleHaskell :: Agg -> ResolvedNominalType -> Maybe Text+generatedIdSampleHaskell aggregate nominal = do+  prefix <- case resolvedNominalRepresentation nominal of+    IdRepresentation value -> Just value+    _ -> Nothing+  contract <- idDomainContractFor (aLanguageContract aggregate) prefix+  let name = resolvedNominalName nominal+      sample = idDomainSampleText contract+  pure+    ( "(case parse"+        <> name+        <> " "+        <> tshow sample+        <> " of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\")"+    )++emitGeneratedTransducer :: Agg -> Text+emitGeneratedTransducer aggregate =+  nl $+    [ "{-# LANGUAGE BlockArguments #-}",+      "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE GADTs #-}",+      "{-# LANGUAGE OverloadedRecordDot #-}",+      "{-# LANGUAGE QualifiedDo #-}",+      "{-# LANGUAGE TypeApplications #-}",+      generatedBanner,+      "module " <> aGenPrefix aggregate <> ".Transducer",+      "  ( " <> lowerFirst (aName aggregate) <> "Transducer",+      "  , " <> lowerFirst (aName aggregate) <> "FoldFingerprint",+      "  , BehaviorOwnership (..)",+      "  , " <> lowerFirst (aName aggregate) <> "PredicateVerifications",+      "  ) where",+      "",+      "import " <> aGenPrefix aggregate <> ".Domain",+      "import Data.Text (Text)",+      "import Keiki.Builder qualified as B",+      "import Keiki.Core (HsPred, SymTransducer)",+      "import Keiki.Core qualified as K",+      "import Keiki.Symbolic qualified as S"+    ]+      ++ ["import " <> aHolePrefix aggregate <> ".Holes qualified as Holes" | transducerUsesHoles aggregate]+      ++ ["import " <> aGenPrefix aggregate <> ".Expressions qualified as Expressions" | not (null (expressionFunctionNames aggregate))]+      ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate]+      ++ ["import Keiki.Builder ((=:))" | any (not . null . tWrites . snd) (transitionEntries aggregate)]+      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]+      ++ [ "",+           lowerFirst (aName aggregate) <> "Transducer",+           "  :: SymTransducer",+           "       (HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command)",+           "       " <> aName aggregate <> "Regs",+           "       " <> aVertexType aggregate,+           "       " <> aName aggregate <> "Command",+           "       " <> aName aggregate <> "Event",+           lowerFirst (aName aggregate) <> "Transducer =",+           "  B.buildTransducer " <> initialVertex aggregate <> " initial" <> aName aggregate <> "Regs isTerminal do",+           nl (concatMap (generatedFromBlock aggregate) (groupTransitionEntriesBySource aggregate)),+           " where",+           "  isTerminal = \\case",+           nl ["    " <> vertexCtor aggregate (stName state) <> " -> True" | state <- aStates aggregate, stTerminal state],+           "    _ -> False",+           "",+           lowerFirst (aName aggregate) <> "FoldFingerprint :: Text",+           lowerFirst (aName aggregate) <> "FoldFingerprint = " <> foldFingerprintExpression aggregate,+           "",+           "data BehaviorOwnership = GeneratedOwned | HoleOwned",+           "  deriving stock (Eq, Show)",+           "",+           "-- Every checked transition predicate is audited through Keiki's conservative",+           "-- symbolic verifier. Opaque Hole terms remain explicitly unverified.",+           lowerFirst (aName aggregate) <> "PredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]",+           lowerFirst (aName aggregate) <> "PredicateVerifications = sequence",+           nl (renderVerificationList aggregate),+           " where",+           "  verifyTransition label owner source edgeIndex =",+           "    case drop edgeIndex (K.edgesOut " <> lowerFirst (aName aggregate) <> "Transducer source) of",+           "      K.Edge predicate _ _ _ _ : _ -> (\\result -> (label, owner, result)) <$> S.verifyPredicate predicate",+           "      [] -> pure (label, owner, S.UnverifiedSolverFailure \"generated transition edge missing\")"+         ]++anyHoleOwned :: Agg -> Bool+anyHoleOwned = any ((== HoleImplementation) . tImplementation) . aTransitions++transducerUsesHoles :: Agg -> Bool+transducerUsesHoles aggregate =+  anyHoleOwned aggregate+    || any isHandOwned (Map.elems (aOutputMappings aggregate))+  where+    isHandOwned HandOwnedEventOutput {} = True+    isHandOwned GeneratedCommandIdentity {} = False++renderVerificationList :: Agg -> [Text]+renderVerificationList aggregate =+  [ (if listIndex == (0 :: Int) then "  [ " else "  , ")+      <> "verifyTransition "+      <> tshow (transitionStem transitionIndex transition)+      <> " "+      <> ownership+      <> " "+      <> vertexCtor aggregate source+      <> " "+      <> tshow' edgeIndex+  | (listIndex, (source, edgeIndex, transitionIndex, transition)) <- zip [0 ..] entries,+    let ownership = case tImplementation transition of+          GeneratedImplementation -> "GeneratedOwned"+          HoleImplementation -> "HoleOwned"+          LegacyHoleImplementation -> error "legacy transition reached version-2 verification generation"+  ]+    <> ["  ]"]+  where+    entries =+      [ (source, edgeIndex, transitionIndex, transition)+      | (source, transitions) <- groupTransitionEntriesBySource aggregate,+        (edgeIndex, (transitionIndex, transition)) <- zip [0 ..] transitions+      ]++foldFingerprintExpression :: Agg -> Text+foldFingerprintExpression aggregate = case holeVersions of+  [] -> tshow (aFoldFingerprint aggregate)+  _ ->+    "T.intercalate \"|\" ("+      <> tshow (aFoldFingerprint aggregate)+      <> " : [foldToken "+      <> T.intercalate ", foldToken " holeVersions+      <> "] ) where foldToken (FoldVersion token) = T.pack (show (T.length token)) <> \":\" <> token"+  where+    holeVersions =+      [ "Holes." <> holeFoldVersionName index transition+      | (index, transition) <- transitionEntries aggregate,+        tImplementation transition == HoleImplementation+      ]++groupTransitionEntriesBySource :: Agg -> [(Text, [(Int, Transition)])]+groupTransitionEntriesBySource aggregate = go [] (transitionEntries aggregate)+  where+    go accumulated [] = reverse accumulated+    go accumulated (entry@(_, transition) : remaining) =+      let source = tSource transition+          (same, rest) = span ((== source) . tSource . snd) remaining+       in go ((source, entry : same) : accumulated) rest++generatedFromBlock :: Agg -> (Text, [(Int, Transition)]) -> [Text]+generatedFromBlock aggregate (source, transitions) =+  ["    B.from " <> vertexCtor aggregate source <> " do"]+    ++ concatMap (uncurry (generatedOnCmdBlock aggregate)) transitions++generatedOnCmdBlock :: Agg -> Int -> Transition -> [Text]+generatedOnCmdBlock aggregate index transition =+  ["      B.onCmd inCtor" <> tCommand transition <> " $ \\d -> B.do"]+    ++ ["        B.replayOnly" | tMode transition == TmReplayOnly]+    ++ generatedBehavior+    ++ outputLines+    ++ ["        B.noEmit" | null (tEmits transition)]+    ++ ["        B.goto " <> vertexCtor aggregate (tGoto transition)]+  where+    generatedBehavior = case tImplementation transition of+      GeneratedImplementation ->+        maybe [] (const ["        B.requireGuard (Expressions." <> guardFunctionName index transition <> " d)"]) (tGuard transition)+          ++ [ "        B.slot @" <> tshow registerName <> " =: Expressions." <> writeFunctionName index transition registerName <> " d"+             | (registerName, _) <- tWrites transition+             ]+      HoleImplementation -> ["        Holes." <> holeFunctionName index transition <> " d"]+      LegacyHoleImplementation -> error "legacy transition reached version-2 transducer generation"+    outputLines =+      concat+        [ generatedOutputLines aggregate index transition emitIndex eventName+        | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+        ]++generatedOutputLines :: Agg -> Int -> Transition -> Int -> Name -> [Text]+generatedOutputLines aggregate transitionIndex transition emitIndex eventName =+  case outputMappingFor aggregate transitionIndex emitIndex of+    GeneratedCommandIdentity _ fields -> case fields of+      [] -> ["        B.emit wire" <> eventName <> " B.oNil"]+      _ ->+        [ "        B.emit wire" <> eventName <> " (" <> eventName <> "TermFields"+        ]+          <> [ lead fieldIndex+                 <> outputSelector field+                 <> " = d."+                 <> outputSelector field+             | (fieldIndex, field) <- zip [0 :: Int ..] fields+             ]+          <> ["          })"]+    HandOwnedEventOutput {} ->+      [ "        B.emit wire"+          <> eventName+          <> " (Holes."+          <> outputFunctionName transitionIndex transition emitIndex eventName+          <> " d)"+      ]+  where+    lead 0 = "          { "+    lead _ = "          , "++outputMappingFor :: Agg -> Int -> Int -> EventOutputMapping+outputMappingFor aggregate transitionIndex emitIndex =+  fromMaybe+    (error ("missing checked event-output mapping for transition " <> show transitionIndex <> ", emit " <> show emitIndex))+    (Map.lookup (transitionIndex, emitIndex) (aOutputMappings aggregate))++--------------------------------------------------------------------------------+-- 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)",+           transducerImport a,+           "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, withFoldFingerprint)" | 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+         ]+      ++ stateCodecFieldLines 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 (withFoldFingerprint "+      <> foldFingerprintValue aggregate+      <> " (defaultStateCodec "+      <> tshow' (snapCodecVersion snapshot)+      <> "))"++transducerImport :: Agg -> Text+transducerImport aggregate+  | hasVersion2Ownership aggregate =+      "import "+        <> aGenPrefix aggregate+        <> ".Transducer ("+        <> lowerFirst (aName aggregate)+        <> "FoldFingerprint, "+        <> lowerFirst (aName aggregate)+        <> "Transducer)"+  | otherwise =+      "import "+        <> aHolePrefix aggregate+        <> ".Holes ("+        <> lowerFirst (aName aggregate)+        <> "Transducer)"++foldFingerprintValue :: Agg -> Text+foldFingerprintValue aggregate+  | hasVersion2Ownership aggregate = lowerFirst (aName aggregate) <> "FoldFingerprint"+  | otherwise = tshow (aFoldFingerprint aggregate)++stateCodecFieldLines :: Agg -> [Text]+stateCodecFieldLines aggregate = case aSnapshot aggregate of+  Nothing -> ["    , stateCodec = Nothing"]+  Just _+    | hasVersion2Ownership aggregate ->+        [ "    -- The snapshot discriminator composes: the spec's state-codec version (bump it",+          "    -- in the spec's `state-codec version=` clause), keiki's register and",+          "    -- control-state shape hashes, and this fold fingerprint derived from the",+          "    -- spec's transition surface (guards, writes, emits, states, register",+          "    -- initials, referenced rules). Spec-visible fold changes invalidate old",+          "    -- snapshots automatically. Version-2 Hole-owned transitions additionally",+          "    -- compose their explicit hand-owned FoldVersion tokens here; bump the",+          "    -- corresponding token whenever that Hole behavior changes.",+          "    , stateCodec = " <> stateCodecExpr aggregate+        ]+    | otherwise ->+        [ "    -- The snapshot discriminator composes: the spec's state-codec version (bump it",+          "    -- in the spec's `state-codec version=` clause), keiki's register and",+          "    -- control-state shape hashes, and this fold fingerprint derived from the",+          "    -- spec's transition surface (guards, writes, emits, states, register",+          "    -- initials, referenced rules). Spec-visible fold changes invalidate old",+          "    -- snapshots automatically. Fold changes made ONLY in the hand-owned Holes",+          "    -- module are invisible here: bump `state-codec version=` manually or old",+          "    -- snapshots will be served stale.",+          "    , stateCodec = " <> stateCodecExpr aggregate+        ]++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 #-}",+        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 aggregate+  | hasVersion2Ownership aggregate = emitVersion2Holes aggregate+  | otherwise = emitLegacyHoles aggregate++emitLegacyHoles :: Agg -> Text+emitLegacyHoles 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+    ]++emitVersion2Holes :: Agg -> Text+emitVersion2Holes aggregate =+  nl $+    [ "{-# LANGUAGE BlockArguments #-}",+      "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE DuplicateRecordFields #-}",+      "{-# LANGUAGE OverloadedRecordDot #-}",+      "{-# LANGUAGE QualifiedDo #-}",+      "{-# LANGUAGE TypeApplications #-}",+      "-- This is a HAND-OWNED version-2 hook module. keiro-dsl creates it once",+      "-- and never overwrites it. Generated code owns every transition envelope",+      "-- and every declared guard/write. This module supplies explicit event-field",+      "-- mappings and explicitly selected Hole behavior only; fields(Command)",+      "-- identity mappings are generated directly and have no hook."+    ]+      ++ version2HoleModuleDeclaration aggregate+      ++ [ "",+           "import " <> aGenPrefix aggregate <> ".Domain",+           "import Keiki.Builder qualified as B",+           "import Keiki.Generics (RegFieldsOf)",+           holeUpcasterImports aggregate,+           holeProjectionImports aggregate+         ]+      ++ ["import Keiki.Core qualified as K" | anyHoleOwned aggregate || anyZeroFieldOutput aggregate]+      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]+      ++ concatMap (uncurry (emitOutputHooks aggregate)) (transitionEntries aggregate)+      ++ concatMap (uncurry (emitHoleImplementation aggregate)) (transitionEntries aggregate)+      ++ [holeProjectionStub aggregate, holeUpcasterStubs aggregate]++anyZeroFieldOutput :: Agg -> Bool+anyZeroFieldOutput aggregate =+  or+    [ isHandOwned (outputMappingFor aggregate transitionIndex emitIndex)+        && null (rcFields (eventForName aggregate eventName))+    | (transitionIndex, transition) <- transitionEntries aggregate,+      (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+    ]+  where+    isHandOwned HandOwnedEventOutput {} = True+    isHandOwned GeneratedCommandIdentity {} = False++version2HoleModuleDeclaration :: Agg -> [Text]+version2HoleModuleDeclaration aggregate = case version2HoleExports aggregate of+  [] -> ["module " <> aHolePrefix aggregate <> ".Holes () where"]+  firstExport : rest ->+    [ "module " <> aHolePrefix aggregate <> ".Holes",+      "  ( " <> firstExport+    ]+      ++ ["  , " <> value | value <- rest]+      ++ ["  ) where"]++version2HoleExports :: Agg -> [Text]+version2HoleExports aggregate =+  outputExports+    <> holeExports+    <> projectionExports+    <> [functionName | (_, _, functionName) <- upcasterEntries aggregate]+  where+    outputExports =+      [ outputFunctionName transitionIndex transition emitIndex eventName+      | (transitionIndex, transition) <- transitionEntries aggregate,+        (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+        HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]+      ]+    holeExports =+      concat+        [ [holeFunctionName index transition, holeFoldVersionName index transition]+        | (index, transition) <- transitionEntries aggregate,+          tImplementation transition == HoleImplementation+        ]+    projectionExports = case aProjection aggregate of+      Nothing -> []+      Just projection -> ["apply" <> pascal (projTable projection)]++emitOutputHooks :: Agg -> Int -> Transition -> [Text]+emitOutputHooks aggregate transitionIndex transition =+  concat+    [ emitOutputHook aggregate transitionIndex transition emitIndex (eventForName aggregate eventName)+    | (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+      HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]     ]  emitOutputHook :: Agg -> Int -> Transition -> Int -> ResolvedCtor -> [Text]