keiro-dsl 0.3.0.0 → 0.4.0.1

raw patch · 83 files changed

+17466/−4775 lines, 83 filesdep +bytestringdep +deepseqdep +keiro-coredep ~aesondep ~containersdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, deepseq, keiro-core, tasty-bench

Dependency ranges changed: aeson, containers, directory, filepath, keiki, megaparsec, optparse-applicative, parser-combinators, prettyprinter, process, text, time, uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +94/−1
• app/Main.hs +188/−37
• bench/structural-codec/Main.hs +146/−0
• keiro-dsl.cabal +226/−67
• src/Keiro/Dsl/CodecCompare.hs +742/−0
• src/Keiro/Dsl/Coverage.hs +650/−0
• src/Keiro/Dsl/Diff.hs +842/−45
• src/Keiro/Dsl/DiffReport.hs +331/−0
• src/Keiro/Dsl/ExplainBindings.hs +293/−0
• src/Keiro/Dsl/FoldFingerprint.hs +167/−0
• src/Keiro/Dsl/Goldens.hs +228/−0
• src/Keiro/Dsl/Grammar.hs +180/−7
• src/Keiro/Dsl/Harness.hs +637/−50
• src/Keiro/Dsl/Manifest.hs +19/−3
• src/Keiro/Dsl/MappedConsumer.hs +162/−0
• src/Keiro/Dsl/MappedDiff.hs +539/−0
• src/Keiro/Dsl/Parser.hs +261/−2
• src/Keiro/Dsl/PrettyPrint.hs +166/−5
• src/Keiro/Dsl/ReadModelShape.hs +8/−2
• src/Keiro/Dsl/ReplayImpact.hs +236/−0
• src/Keiro/Dsl/Scaffold.hs +3274/−1999
• src/Keiro/Dsl/ScaffoldRecord.hs +51/−10
• src/Keiro/Dsl/ScaffoldRun.hs +219/−23
• src/Keiro/Dsl/TypeGraph.hs +664/−0
• src/Keiro/Dsl/Validate.hs +676/−10
• test/Main.hs +4203/−2459
• test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs +101/−0
• test/conformance-codec-compare/Main.hs +53/−0
• test/conformance-coldstart/Generated/Billing/ReplayAudit.hs +25/−0
• test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs +24/−1
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +33/−0
• test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs +2/−7
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs +24/−3
• test/conformance-newsurface/Generated/TransferRouting/ReplayAudit.hs +25/−0
• test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs +32/−0
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +33/−0
• test/conformance-queue-runtime/Main.hs +3/−3
• test/conformance-queue/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +33/−0
• test/conformance-queue/Main.hs +14/−1
• test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs +50/−0
• test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs +48/−0
• test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs +44/−0
• test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs +56/−0
• test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs +2/−0
• test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs +25/−0
• test/conformance-replay/Main.hs +19/−0
• test/conformance-replay/ReplayDivergence/Note/Holes.hs +63/−0
• test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs +25/−0
• test/conformance-skeletons/SkelAggregate/Generated/MyService/ReplayAudit.hs +25/−0
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs +24/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs +22/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/ReplayAudit.hs +32/−0
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs +45/−5
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueueCodec.hs +33/−0
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs +24/−3
• test/conformance-skeletons/SkelRouter/Generated/MyService/ReplayAudit.hs +25/−0
• test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs +25/−0
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs +2/−1
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs +10/−2
• test/conformance-snapshot/Main.hs +9/−4
• test/conformance-structural/Conformance/Structural/Bindings.hs +132/−0
• test/conformance-structural/Conformance/Structural/Domain.hs +69/−0
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs +218/−0
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs +63/−0
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs +44/−0
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs +240/−0
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs +2/−0
• test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs +25/−0
• test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs +80/−0
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs +23/−0
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs +9/−0
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs +15/−0
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs +13/−0
• test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs +43/−0
• test/conformance-structural/Main.hs +56/−0
• test/conformance-structural/StructuralConformance/ArtifactCatalog/Holes.hs +46/−0
• test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs +25/−0
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs +7/−1
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs +38/−7
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs +13/−11
• test/conformance-v2/Main.hs +42/−3
• test/conformance/Generated/HospitalCapacity/ReplayAudit.hs +25/−0
• test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs +26/−1

@@ -6,7 +6,100 @@  ## [Unreleased] -_No unreleased changes._+## 0.4.0.1 — 2026-07-28++### Other Changes++- Adds PVP upper bounds to every dependency that previously carried a lower+  bound only, so `cabal check` reports no packaging warnings. No API or+  behaviour change from 0.4.0.0, which was tagged but never published.+++## 0.4.0.0 — 2026-07-28++### New Features++- Structural scaffolding now creates hand-owned binding/fixture/initial+  skeletons grouped by their declared owner modules, persists granular hole+  obligations for non-overwriting re-scaffold reports, derives `Generic` for+  private shape types, and provides `check --explain-bindings` for deterministic+  package/module/signature/use-site reports.++- Adds `Keiro.Dsl.CodecCompare`, a historical-codec comparison engine that+  classifies RFC 8785 canonical-JSON parity between a declared codec and a+  historical one, reports structured migration differences and declared-versus-+  observed branch coverage gaps, and writes stable reports atomically.+  `scaffold --codec-comparison MAPPED-NAME --comparison-out FILE` emits a+  non-production comparison module and runner for one structural mapped type.++- Adds `Keiro.Dsl.Coverage` and reporting-only `--coverage-report FILE` on both+  `check` and `diff`, recording structural and opaque mapped-root coverage as+  JSON. `check --fail-on-opaque` fails when a private persisted root still+  contains an opaque boundary; `diff --fail-on-opaque-increase` fails when a+  change adds a named opaque boundary. Without the flags, coverage is purely+  informational.++- Adds checked `mapped structural` and `mapped opaque` declarations with a+  resolved, total type-expression graph. Validation rejects recursive,+  ambiguous, non-injective, or incomplete mappings; recursive diff findings+  carry six-surface compatibility vectors and complete command/event/register+  use-site paths.++- Structural consumer-type scaffolding now emits private+  `Generated.<Context>.Structural.Shape.*` wire representations, generates+  structural codecs from declared keys/defaults/tags, delegates opaque values+  only at their declared JSON boundary, imports consumer types into aggregate+  domains, and exposes eligible total scalar getters through a narrow Keiki+  0.4 `StructuralProjections` witness facade.+- Scaffold preflight now reports consumer packages/modules, refuses consumer+  modules inside the generated namespace before writing, includes consumer+  requirements in manifests, persists canonical structural/opaque mapping+  identities as forward-compatible JSON rows, and reports mapping drift on+  subsequent runs. Mapped register wire/binding/initial identities now+  participate in the aggregate fold fingerprint.+- Generated harnesses exercise both structural binding laws, declared codec+  policy and current payload goldens, enum/union/optional fixture coverage,+  canonical projection witness agreement, and forward-versus-replay equality+  over every mapped and scalar register. The committed structural conformance+  suite includes opaque-boundary checks and three falsifying mutations.+- `Keiro.Dsl.ReplayImpact` and `diff --replay-impact-out FILE`. Diffs now+  print whether stored-data replay is unchanged and can emit a stable JSON+  affected set for targeted auditing. New aggregates, events, transitions,+  and syntactically proven guard loosenings are replay-neutral; changed+  decode/fold surfaces identify conservative event types and whether+  snapshot-bearing streams must be included.+- Scaffolding now emits one context-wide+  `Generated.<Context>.ReplayAudit` module. Its typed target list includes+  every aggregate, validates discovered stream names against the generated+  category, and documents the replay-neutral/targeted/full deployment tiers.+- `diff` now emits non-breaking, coded advisories when a router resolve or+  dispatch surface, process handle surface, or unversioned process-timer+  payload changes. The advisories explain the subscription drain and+  dead-letter procedure needed to avoid mixed old/new deterministic fan-out+  during a deployment.++- First-class replay-only transitions for guard evolution (plan 143). A+  `replay-only` prefix on a transition line marks it as serving inversion+  only: the parser accepts it, the pretty-printer round-trips it, and the+  scaffolder lowers it to `B.replayOnly` (keiki's `ReplayOnly` edge mode) in+  the transducer skeleton. New validator rules: `ReplayOnlyEmitsNothing`+  (error — a replay-only transition with no emit can invert nothing) and+  `ReplayOnlyCommandStillLive` (warning — no live sibling for the (source,+  command) pair; the fuller procedure is event retirement). A deprecated+  event may keep being emitted by a replay-only transition — replay-only+  transitions are not the write path.+- `diff` computes the guard-tightening remedy (`AggGuardTightened`+  advisory): on any live-transition guard change without a replay-only twin,+  it prints a paste-ready `replay-only` twin whose guard is the removed+  region `old ∧ ¬new`, negation eliminated inside the guard grammar by the+  new total `Keiro.Dsl.Grammar.complementExpr` (De Morgan, comparison+  flipping, `x == false` for bare boolean atoms). The twin carries the old+  transition's writes/emits/goto and re-parses as-is; it is printed, never+  auto-applied.+- `Keiro.Dsl.PrettyPrint.renderTransition` renders one transition in+  concrete `.keiro` syntax (used by the advisory).+- Requires `keiki >=0.4 && <0.5`, including `EdgeMode` and the typed structural+  projection contracts.  ## 0.3.0.0 — 2026-07-14 

@@ -5,31 +5,47 @@ module Main (main) where  import Control.Monad (when)+import Data.Aeson qualified as Aeson import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO-import Keiro.Dsl.Diff (Change (..), ChangeKind (..), diffSpecs, isBreaking)+import Keiro.Dsl.Coverage qualified as Coverage+import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSpecs, gateWith, gatedBreaking)+import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding)+import Keiro.Dsl.ExplainBindings (bindingObligations, renderBindingObligations)+import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads) import Keiro.Dsl.Grammar (Placement (..), Spec (..)) import Keiro.Dsl.Parser (parseSpec) import Keiro.Dsl.PrettyPrint (renderSpec)-import Keiro.Dsl.Scaffold (Context (..))-import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffold, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpact)+import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule)+import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffoldWithGoldens, renderRefusals, renderScaffoldReport) import Keiro.Dsl.Skeleton (skeletonFor) import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec) import Options.Applicative-import System.Directory (canonicalizePath)+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist) import System.Exit (ExitCode (..), exitFailure)-import System.FilePath (makeRelative, takeDirectory)+import System.FilePath (makeRelative, normalise, takeDirectory, (</>)) import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode)  data Command     = Parse FilePath-    | Check FilePath Bool-    | Scaffold FilePath FilePath (Maybe String) Bool Bool-    | Diff FilePath String+    | Check FilePath Bool Bool (Maybe CheckCoverageOptions)+    | 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 CheckCoverageOptions = CheckCoverageOptions+    { checkCoveragePath :: !FilePath+    , checkFailOnOpaque :: !Bool+    }++data DiffCoverageOptions = DiffCoverageOptions+    { diffCoveragePath :: !FilePath+    , diffFailOnOpaqueIncrease :: !Bool+    }+ main :: IO () main = run =<< execParser opts   where@@ -46,13 +62,13 @@             (info (Parse <$> fileArg <**> helper) (progDesc "Parse a .keiro file and pretty-print it back"))             <> command                 "check"-                (info (Check <$> fileArg <*> emitSwitch <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error"))+                (info (Check <$> fileArg <*> emitSwitch <*> explainBindingsSwitch <*> checkCoverageOptions <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error"))             <> command                 "scaffold"-                (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))+                (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))             <> command                 "diff"-                (info (Diff <$> fileArg <*> sinceOpt <**> helper) (progDesc "Classify spec changes since a git ref as ADDITIVE/WARNING/BREAKING over the decode and identity surface; exit non-zero on any BREAKING change"))+                (info (Diff <$> fileArg <*> sinceOpt <*> optional emitGoldensOpt <*> optional replayImpactOutOpt <*> many gateOpt <*> explainSwitch <*> optional reportOutOpt <*> diffCoverageOptions <**> helper) (progDesc "Classify spec changes since a git ref as per-surface compatibility vectors; exit non-zero on any gated BREAKING surface"))             <> command                 "new"                 (info (New <$> kindArg <**> helper) (progDesc "Print a minimal valid .keiro skeleton for a node kind (aggregate, process, router, contract, intake, emit, publisher, workqueue, dispatch, workflow, operation)"))@@ -70,9 +86,57 @@ forceGeneratedOverwriteSwitch :: Parser Bool forceGeneratedOverwriteSwitch = switch (long "force-generated-overwrite" <> help "Overwrite a Generated path even when the existing file lacks the @generated banner") +goldensOpt :: Parser FilePath+goldensOpt = strOption (long "goldens" <> metavar "DIR" <> help "Golden-payload root to embed in generated aggregate harnesses")++codecComparisonOpts :: Parser (Maybe (String, FilePath))+codecComparisonOpts =+    optional+        ( (,)+            <$> strOption (long "codec-comparison" <> metavar "MAPPED-NAME" <> help "Emit a non-production historical-codec comparison module for one structural mapped type (requires --comparison-out)")+            <*> strOption (long "comparison-out" <> metavar "FILE" <> help "Exact generated comparison-module path under --out (requires --codec-comparison)")+        )++emitGoldensOpt :: Parser FilePath+emitGoldensOpt = strOption (long "emit-goldens" <> metavar "DIR" <> help "Write old-shape payload fixtures for event version bumps without overwriting existing files")++replayImpactOutOpt :: Parser FilePath+replayImpactOutOpt = strOption (long "replay-impact-out" <> metavar "FILE" <> help "Write the replay-neutral or affected audit input as JSON")++gateOpt :: Parser CompatibilitySurface+gateOpt = option (eitherReader parseSurfaceName) (long "gate" <> metavar "SURFACE" <> help "Also fail on a breaking verdict for this compatibility surface (repeatable)")++explainSwitch :: Parser Bool+explainSwitch = switch (long "explain" <> help "Print containing paths, failing directions, and remediation choices")++reportOutOpt :: Parser FilePath+reportOutOpt = strOption (long "report-out" <> metavar "FILE" <> help "Write the full keiro-dsl/diff-report/1 compatibility report as JSON")++coverageReportOpt :: Parser FilePath+coverageReportOpt = strOption (long "coverage-report" <> metavar "FILE" <> help "Write reporting-only structural/opaque mapped-root coverage as JSON")++checkCoverageOptions :: Parser (Maybe CheckCoverageOptions)+checkCoverageOptions =+    optional+        ( CheckCoverageOptions+            <$> coverageReportOpt+            <*> switch (long "fail-on-opaque" <> help "Fail when a private persisted root contains an opaque boundary (requires --coverage-report)")+        )++diffCoverageOptions :: Parser (Maybe DiffCoverageOptions)+diffCoverageOptions =+    optional+        ( DiffCoverageOptions+            <$> coverageReportOpt+            <*> switch (long "fail-on-opaque-increase" <> help "Fail when diff adds a named opaque boundary (requires --coverage-report)")+        )+ emitSwitch :: Parser Bool emitSwitch = switch (long "emit" <> help "On success, pretty-print the parsed spec to stdout (folds parse + check into one call)") +explainBindingsSwitch :: Parser Bool+explainBindingsSwitch = switch (long "explain-bindings" <> help "On success, list the consumer-owned binding, fixture, and register-initial symbols required by structural mapped types")+ sinceOpt :: Parser String sinceOpt = strOption (long "since" <> metavar "GIT-REF" <> help "Git ref to diff the spec against (e.g. HEAD, a tag, a branch)") @@ -90,7 +154,7 @@             hPutStrLn stderr (T.unpack err)             exitFailure         Right spec -> TIO.putStrLn (renderSpec spec)-run (Check fp emit) = do+run (Check fp emit explainBindings coverageOptions) = do     input <- TIO.readFile fp     case parseSpec fp input of         Left err -> do@@ -101,11 +165,19 @@             mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags             if any ((== Error) . severity) diags                 then exitFailure-                else-                    if emit-                        then TIO.putStrLn (renderSpec spec)-                        else putStrLn "OK"-run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite) = do+                else do+                    when emit (TIO.putStrLn (renderSpec spec))+                    if explainBindings+                        then case bindingObligations spec of+                            Left graphErrors -> do+                                hPutStrLn stderr ("validated spec did not resolve its mapped type graph: " <> show graphErrors)+                                exitFailure+                            Right obligations -> TIO.putStrLn (renderBindingObligations (specContext spec) obligations)+                        else pure ()+                    coverageOk <- runCheckCoverage fp spec coverageOptions+                    when (coverageOk && not emit && not explainBindings) (putStrLn "OK")+                    when (not coverageOk) exitFailure+run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) = do     input <- TIO.readFile fp     case parseSpec fp input of         Left err -> do@@ -118,22 +190,31 @@             mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags             when (any ((== Error) . severity) diags) exitFailure             let ctx = mkContext cliRoot cliCollocate spec-            case planScaffold ctx spec of-                Left refusals -> do+                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+                (Left refusals, _) -> do                     mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)                     exitFailure-                Right modules -> do-                    result <- executeScaffold out forceGeneratedOverwrite fp ctx spec modules-                    case result of-                        Left refusals -> do-                            mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)-                            exitFailure-                        Right report -> mapM_ (TIO.hPutStrLn stderr) (renderScaffoldReport report)+                (_, Left comparisonError) -> TIO.hPutStrLn stderr comparisonError >> exitFailure+                (Right modules, Right comparisonModule) -> do+                    comparisonReady <- preflightComparison out comparisonRequest comparisonModule+                    case comparisonReady of+                        Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure+                        Right () -> do+                            result <- executeScaffold out forceGeneratedOverwrite fp ctx spec modules+                            case result of+                                Left refusals -> do+                                    mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)+                                    exitFailure+                                Right report -> do+                                    mapM_ (TIO.hPutStrLn stderr) (renderScaffoldReport report)+                                    writeComparison comparisonRequest comparisonModule run (New kind) =     case skeletonFor (T.pack kind) of         Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure         Right skel -> TIO.putStr skel-run (Diff fp ref) = do+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     rootRes <- git dir ["rev-parse", "--show-toplevel"]@@ -151,18 +232,24 @@                     case (,) <$> parseSpec (ref <> ":" <> relPath) (T.pack oldText) <*> parseSpec fp newText of                         Left perr -> hPutStrLn stderr (T.unpack perr) >> exitFailure                         Right (oldSpec, newSpec) -> do+                            written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot+                            mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written                             let changes = diffSpecs oldSpec newSpec-                            mapM_ (putStrLn . renderChange) changes-                            if any isBreaking changes then exitFailure else pure ()+                                impact = replayImpact oldSpec newSpec+                                effectiveGate = gateWith gatedSurfaces+                            mapM_ (TIO.putStrLn . renderFinding) changes+                            when explain $+                                mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)+                            TIO.putStrLn (renderReplayImpact impact)+                            mapM_ (`Aeson.encodeFile` impact) replayImpactOut+                            mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut+                            coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions+                            if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () -renderChange :: Change -> String-renderChange c = case c of-    Additive k -> "ADDITIVE: " <> body k-    Advisory k -> "WARNING: " <> body k <> codeSuffix k-    Breaking k -> "BREAKING: " <> body k <> codeSuffix k-  where-    body k = T.unpack (ckNode k) <> " " <> T.unpack (ckFacet k) <> " " <> T.unpack (ckSubject k) <> ": " <> T.unpack (ckDetail k)-    codeSuffix k = maybe "" (\dc -> " [" <> show dc <> "]") (ckCode k)+shouldExplain :: Change -> Bool+shouldExplain Additive{} = False+shouldExplain Advisory{} = True+shouldExplain Breaking{} = True  -- | Run git in a directory, returning trimmed stdout or stderr. git :: FilePath -> [String] -> IO (Either String String)@@ -174,6 +261,70 @@  trim :: String -> String trim = f . f where f = reverse . dropWhile (`elem` (" \t\r\n" :: String))++preflightComparison :: FilePath -> Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO (Either T.Text ())+preflightComparison _ Nothing Nothing = pure (Right ())+preflightComparison out (Just (_, requestedPath)) (Just comparisonModule) = do+    let expectedPath = normalise (out </> modulePath comparisonModule)+        actualPath = normalise requestedPath+    if actualPath /= expectedPath+        then+            pure+                ( Left+                    ( "--comparison-out must match the generated module path under --out: expected "+                        <> T.pack expectedPath+                    )+                )+        else do+            exists <- doesFileExist actualPath+            if not exists+                then pure (Right ())+                else do+                    existing <- TIO.readFile actualPath+                    pure+                        ( if codecComparisonBanner `elem` T.lines existing+                            then Right ()+                            else Left ("refusing to overwrite non-comparison output: " <> T.pack actualPath)+                        )+preflightComparison _ _ _ = pure (Left "internal error: incomplete codec-comparison option pair")++writeComparison :: Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO ()+writeComparison Nothing Nothing = pure ()+writeComparison (Just (_, path)) (Just comparisonModule) = do+    createDirectoryIfMissing True (takeDirectory path)+    TIO.writeFile path (moduleText comparisonModule)+    TIO.hPutStrLn stderr ("comparison generated " <> T.pack path <> " (migration evidence only)")+writeComparison _ _ = hPutStrLn stderr "internal error: incomplete codec-comparison output" >> exitFailure++runCheckCoverage :: FilePath -> Spec -> Maybe CheckCoverageOptions -> IO Bool+runCheckCoverage _ _ Nothing = pure True+runCheckCoverage specPath spec (Just options) =+    case Coverage.coverageReport specPath spec of+        Left graphErrors -> do+            hPutStrLn stderr ("validated spec did not resolve its mapped type graph for coverage: " <> show graphErrors)+            pure False+        Right baseReport -> do+            let report = if checkFailOnOpaque options then Coverage.failOnOpaque baseReport else baseReport+            emitCoverageReport (checkCoveragePath options) report++runDiffCoverage :: FilePath -> T.Text -> Spec -> Spec -> Maybe DiffCoverageOptions -> IO Bool+runDiffCoverage _ _ _ _ Nothing = pure True+runDiffCoverage specPath reference oldSpec newSpec (Just options) =+    case Coverage.coverageDiffReport specPath reference oldSpec newSpec of+        Left graphErrors -> do+            hPutStrLn stderr ("diff specs did not resolve their mapped type graph for coverage: " <> show graphErrors)+            pure False+        Right baseReport -> do+            let report = if diffFailOnOpaqueIncrease options then Coverage.failOnOpaqueIncrease baseReport else baseReport+            emitCoverageReport (diffCoveragePath options) report++emitCoverageReport :: FilePath -> Coverage.CoverageReport -> IO Bool+emitCoverageReport path report = do+    mapM_ (TIO.hPutStrLn stderr . Coverage.renderCoverageFinding (Coverage.coverageSpec report)) (Coverage.coverageFindings report)+    TIO.putStr (Coverage.renderCoverageSummary report)+    Coverage.writeCoverageReport path report+    putStrLn ("coverage report written to " <> path)+    pure (Coverage.coverageSucceeded report)  {- | Fold the spec's @module@/@layout@ clauses with the CLI overrides to a 'Context'. Precedence is CLI flag > spec clause > built-in default.

@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Main (main) where++import Conformance.Structural.Bindings qualified as Bindings+import Conformance.Structural.Domain qualified as Domain+import Control.DeepSeq (NFData)+import Control.Monad (unless, (>=>))+import Data.Aeson (Value (..), object, withObject, (.!=), (.:), (.:?), (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, parseEither)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import Data.Text qualified as Text+import Generated.StructuralConformance.ArtifactCatalog.Codec (decodeArtifactInfoMapped, encodeArtifactInfoMapped)+import Keiro.Codec.Structural (FixtureCases (..))+import Test.Tasty.Bench (Benchmark, bcompareWithin, bench, bgroup, defaultMain, nf)++main :: IO ()+main = defaultMain benchmarks++benchmarks :: [Benchmark]+benchmarks =+    [ bgroup+        "encode"+        [ comparison "encode-small-record" baselineEncodeArtifact encodeArtifactInfoMapped smallArtifact+        , comparison "encode-nested-union" (map baselineEncodeArtifact) (map encodeArtifactInfoMapped) unionArtifacts+        , comparison "encode-large-list" (map baselineEncodeArtifact) (map encodeArtifactInfoMapped) largeArtifacts+        ]+    , bgroup+        "decode"+        [ comparison "decode-small-record" baselineDecodeArtifact decodeArtifactInfoMapped smallEncoded+        , comparison "decode-nested-union" baselineDecodeArtifacts generatedDecodeArtifacts unionEncoded+        , comparison "decode-large-list" baselineDecodeArtifacts generatedDecodeArtifacts largeEncoded+        ]+    ]++comparison :: (NFData result) => String -> (input -> result) -> (input -> result) -> input -> Benchmark+comparison label baseline generated input =+    bgroup+        label+        [ bench ("baseline-" <> label) (nf baseline input)+        , bcompareWithin 0 2 ("baseline-" <> label) $ bench ("generated-" <> label) (nf generated input)+        ]++allArtifacts :: [Domain.ArtifactInfo]+allArtifacts = map snd (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases))++smallArtifact :: Domain.ArtifactInfo+smallArtifact = snd (NonEmpty.head (fixtureCases Bindings.artifactInfoCases))++unionArtifacts :: [Domain.ArtifactInfo]+unionArtifacts = allArtifacts++largeArtifacts :: [Domain.ArtifactInfo]+largeArtifacts = take 2000 (cycle allArtifacts)++smallEncoded :: Value+smallEncoded = encodeArtifactInfoMapped smallArtifact++unionEncoded :: Value+unionEncoded = Aeson.toJSON (map encodeArtifactInfoMapped unionArtifacts)++largeEncoded :: Value+largeEncoded = Aeson.toJSON (map encodeArtifactInfoMapped largeArtifacts)++generatedDecodeArtifacts :: Value -> Either Text [Domain.ArtifactInfo]+generatedDecodeArtifacts value = do+    values <- firstText (parseEither Aeson.parseJSON value)+    traverse decodeArtifactInfoMapped values++baselineDecodeArtifacts :: Value -> Either Text [Domain.ArtifactInfo]+baselineDecodeArtifacts = firstText . parseEither (Aeson.parseJSON >=> traverse baselineParseArtifact)++baselineDecodeArtifact :: Value -> Either Text Domain.ArtifactInfo+baselineDecodeArtifact = firstText . parseEither baselineParseArtifact++firstText :: Either String value -> Either Text value+firstText = either (Left . Text.pack) Right++baselineEncodeArtifact :: Domain.ArtifactInfo -> Value+baselineEncodeArtifact value =+    object+        [ "artifact_key" .= value.artifactKey+        , "display_name" .= value.displayName+        , "artifact_hash" .= value.artifactHash+        , "artifact_kind" .= encodeKind value.artifactKind+        , "location" .= encodeLocation value.location+        , "metadata" .= object ["note" .= value.metadata.note]+        , "active" .= value.active+        , "tags" .= value.tags+        ]++baselineParseArtifact :: Value -> Parser Domain.ArtifactInfo+baselineParseArtifact = withObject "ArtifactInfo" $ \value -> do+    rejectUnknownFields "ArtifactInfo" ["artifact_key", "display_name", "artifact_hash", "artifact_kind", "location", "metadata", "active", "tags"] value+    Domain.ArtifactInfo+        <$> value .: "artifact_key"+        <*> value .: "display_name"+        <*> value .:? "artifact_hash"+        <*> (value .:? "artifact_kind" .!= String "guide" >>= parseKind)+        <*> (value .: "location" >>= parseLocation)+        <*> (value .: "metadata" >>= withObject "ArtifactMetadata" (\metadata -> Domain.ArtifactMetadata <$> metadata .: "note"))+        <*> (value .:? "active" .!= False)+        <*> (value .:? "tags" .!= [])++encodeKind :: Domain.ArtifactKind -> Value+encodeKind = \case+    Domain.Guide -> String "guide"+    Domain.Reference -> String "reference"++parseKind :: Value -> Parser Domain.ArtifactKind+parseKind = \case+    String "guide" -> pure Domain.Guide+    String "reference" -> pure Domain.Reference+    _ -> fail "unknown ArtifactKind"++encodeLocation :: Domain.ArtifactLocation -> Value+encodeLocation = \case+    Domain.LocalFile path -> tagged "local_file" (Just path)+    Domain.LocalDir path -> tagged "local_dir" (Just path)+    Domain.RepoPath path -> tagged "repo_path" (Just path)+    Domain.LocUrl url -> tagged "url" (Just url)+    Domain.Canonical -> tagged "canonical" Nothing+  where+    tagged :: Text -> Maybe Text -> Value+    tagged tag contents = object (["tag" .= tag] <> maybe [] (pure . ("contents" .=)) contents)++parseLocation :: Value -> Parser Domain.ArtifactLocation+parseLocation = withObject "ArtifactLocation" $ \value -> do+    tag <- value .: "tag" :: Parser Text+    case tag of+        "local_file" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.LocalFile <$> value .: "contents")+        "local_dir" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.LocalDir <$> value .: "contents")+        "repo_path" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.RepoPath <$> value .: "contents")+        "url" -> rejectUnknownFields "ArtifactLocation" ["tag", "contents"] value >> (Domain.LocUrl <$> value .: "contents")+        "canonical" -> rejectUnknownFields "ArtifactLocation" ["tag"] value >> pure Domain.Canonical+        _ -> fail "unknown ArtifactLocation"++rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()+rejectUnknownFields label allowed value =+    unless (null extras) (fail (label <> " contains unknown fields: " <> show extras))+  where+    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys value))

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-dsl-version:         0.3.0.0+version:         0.4.0.1 synopsis:        Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro@@ -18,11 +18,12 @@ extra-doc-files: CHANGELOG.md  common warnings-  ghc-options: -Wall+  ghc-options: -Wall -Werror=missing-fields  common shared   default-language:   GHC2024   default-extensions:+    DuplicateRecordFields     LambdaCase     OverloadedStrings @@ -30,41 +31,54 @@   import:          warnings, shared   hs-source-dirs:  src   exposed-modules:+    Keiro.Dsl.CodecCompare+    Keiro.Dsl.Coverage     Keiro.Dsl.Diff+    Keiro.Dsl.DiffReport+    Keiro.Dsl.ExplainBindings+    Keiro.Dsl.FoldFingerprint+    Keiro.Dsl.Goldens     Keiro.Dsl.Grammar     Keiro.Dsl.Harness     Keiro.Dsl.Manifest+    Keiro.Dsl.MappedConsumer+    Keiro.Dsl.MappedDiff     Keiro.Dsl.Parser     Keiro.Dsl.PrettyPrint     Keiro.Dsl.ReadModelShape+    Keiro.Dsl.ReplayImpact     Keiro.Dsl.Scaffold     Keiro.Dsl.ScaffoldRecord     Keiro.Dsl.ScaffoldRun     Keiro.Dsl.Skeleton+    Keiro.Dsl.TypeGraph     Keiro.Dsl.Validate    build-depends:-    , base                >=4.21 && <5-    , containers          >=0.6-    , directory           >=1.3-    , filepath            >=1.4-    , megaparsec          >=9.6-    , parser-combinators  >=1.3-    , prettyprinter       >=1.7-    , text                >=2.1+    , 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+    , parser-combinators  >=1.3   && <1.4+    , prettyprinter       >=1.7   && <1.8+    , text                >=2.1   && <2.2  executable keiro-dsl   import:         warnings, shared   hs-source-dirs: app   main-is:        Main.hs   build-depends:+    , aeson                 >=2.2  && <2.3     , base                  >=4.21 && <5-    , directory             >=1.3-    , filepath              >=1.4+    , directory             >=1.3  && <1.4+    , filepath              >=1.4  && <1.6     , keiro-dsl-    , optparse-applicative  >=0.18-    , process               >=1.6-    , text                  >=2.1+    , optparse-applicative  >=0.18 && <0.20+    , process               >=1.6  && <1.7+    , text                  >=2.1  && <2.2  test-suite keiro-dsl-test   import:         warnings, shared@@ -72,14 +86,17 @@   hs-source-dirs: test   main-is:        Main.hs   build-depends:+    , aeson       >=2.2  && <2.3     , base        >=4.21 && <5-    , containers  >=0.6-    , directory   >=1.3-    , filepath    >=1.4+    , containers  >=0.6  && <0.8+    , directory   >=1.3  && <1.4+    , filepath    >=1.4  && <1.6     , hspec       >=2.11+    , keiro-core     , keiro-dsl+    , process     >=1.6  && <1.7     , QuickCheck  >=2.14-    , text        >=2.1+    , text        >=2.1  && <2.2  -- Conformance: proves the scaffolded Generated modules plus a hand-filled -- Holes.hs compile against keiki/keiro and that the filled transducer passes@@ -92,6 +109,7 @@   hs-source-dirs: test/conformance   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.ReplayAudit     Generated.HospitalCapacity.Reservation.Codec     Generated.HospitalCapacity.Reservation.Domain     Generated.HospitalCapacity.Reservation.EventStream@@ -100,12 +118,132 @@     HospitalCapacity.Reservation.Holes    build-depends:-    , aeson  >=2.2+    , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.2  && <0.3+    , keiki  >=0.4  && <0.5     , keiro-    , text   >=2.1+    , 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.+test-suite keiro-dsl-conformance-structural+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-structural+  main-is:        Main.hs+  other-modules:+    Conformance.Structural.Bindings+    Conformance.Structural.Domain+    Generated.StructuralConformance.ArtifactCatalog.Codec+    Generated.StructuralConformance.ArtifactCatalog.Domain+    Generated.StructuralConformance.ArtifactCatalog.EventStream+    Generated.StructuralConformance.ArtifactCatalog.Harness+    Generated.StructuralConformance.ArtifactCatalog.Projection+    Generated.StructuralConformance.ReplayAudit+    Generated.StructuralConformance.Structural.Shape.ArtifactInfo+    Generated.StructuralConformance.Structural.Shape.ArtifactKind+    Generated.StructuralConformance.Structural.Shape.ArtifactLocation+    Generated.StructuralConformance.Structural.Shape.ArtifactMetadata+    Generated.StructuralConformance.StructuralProjections+    StructuralConformance.ArtifactCatalog.Holes++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , bytestring  >=0.12 && <0.13+    , containers  >=0.6  && <0.8+    , deepseq     >=1.5  && <1.6+    , keiki       >=0.4  && <0.5+    , keiro+    , text        >=2.1  && <2.2+    , time        >=1.12 && <1.15++-- Plan 152 / Experiment B: a consumer-owned historical codec and finite JSON+-- corpus compared with the generated structural codec. The comparison module+-- is opt-in tooling output and is not part of the production scaffold record.+test-suite keiro-dsl-conformance-codec-compare+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs:+    test/conformance-codec-compare test/conformance-structural++  main-is:        Main.hs+  other-modules:+    Conformance.CodecCompare.Historical+    Conformance.Structural.Bindings+    Conformance.Structural.Domain+    Generated.StructuralConformance.ArtifactCatalog.Codec+    Generated.StructuralConformance.ArtifactCatalog.Domain+    Generated.StructuralConformance.Structural.CodecCompare.ArtifactInfo+    Generated.StructuralConformance.Structural.Shape.ArtifactInfo+    Generated.StructuralConformance.Structural.Shape.ArtifactKind+    Generated.StructuralConformance.Structural.Shape.ArtifactLocation+    Generated.StructuralConformance.Structural.Shape.ArtifactMetadata++  build-depends:+    , aeson       >=2.2.1 && <2.3+    , base        >=4.21  && <5+    , containers  >=0.6   && <0.8+    , deepseq     >=1.5   && <1.6+    , directory   >=1.3   && <1.4+    , filepath    >=1.4   && <1.6+    , keiki       >=0.4   && <0.5+    , keiro+    , keiro-dsl+    , text        >=2.1   && <2.2++-- Plan 147 M2: a dedicated honest-wire baseline plus a dormant idempotent+-- dishonest WireCtor used by replay-mutation-test.sh to prove that generated+-- forward/replay register comparisons catch state divergence missed by the+-- pre-existing validator, codec round-trip, and accept assertions.+test-suite keiro-dsl-conformance-replay+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-replay+  main-is:        Main.hs+  other-modules:+    Generated.ReplayDivergence.Note.Codec+    Generated.ReplayDivergence.Note.Domain+    Generated.ReplayDivergence.Note.EventStream+    Generated.ReplayDivergence.Note.Harness+    Generated.ReplayDivergence.Note.Projection+    Generated.ReplayDivergence.ReplayAudit+    ReplayDivergence.Note.Holes++  build-depends:+    , aeson  >=2.2  && <2.3+    , base   >=4.21 && <5+    , keiki  >=0.4  && <0.5+    , keiro+    , text   >=2.1  && <2.2++benchmark keiro-dsl-codec-bench+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: bench/structural-codec test/conformance-structural+  main-is:        Main.hs+  other-modules:+    Conformance.Structural.Bindings+    Conformance.Structural.Domain+    Generated.StructuralConformance.ArtifactCatalog.Codec+    Generated.StructuralConformance.ArtifactCatalog.Domain+    Generated.StructuralConformance.Structural.Shape.ArtifactInfo+    Generated.StructuralConformance.Structural.Shape.ArtifactKind+    Generated.StructuralConformance.Structural.Shape.ArtifactLocation+    Generated.StructuralConformance.Structural.Shape.ArtifactMetadata++  build-depends:+    , aeson        >=2.2  && <2.3+    , base         >=4.21 && <5+    , containers   >=0.6  && <0.8+    , deepseq      >=1.5  && <1.6+    , keiki        >=0.4  && <0.5+    , keiro+    , tasty-bench  >=0.5  && <0.6+    , text         >=2.1  && <2.2+    , time         >=1.12 && <1.15+ -- EP-109 M2: snapshot-enabled aggregate scaffolding compiled against the live -- defaultStateCodec and stream-construction guards, with the captured codec -- identity checked against keiki's regFileShapeHash.@@ -115,17 +253,18 @@   hs-source-dirs: test/conformance-snapshot   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.ReplayAudit     Generated.HospitalCapacity.Reservation.Codec     Generated.HospitalCapacity.Reservation.Domain     Generated.HospitalCapacity.Reservation.EventStream     HospitalCapacity.Reservation.Holes    build-depends:-    , aeson  >=2.2+    , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.2  && <0.3+    , keiki  >=0.4  && <0.5     , keiro-    , text   >=2.1+    , text   >=2.1  && <2.2  -- EP-106 M6: every distinct `new <kind>` skeleton is scaffolded into this -- committed tree. Compiling the union proves a starter that passes `check`@@ -136,6 +275,7 @@   hs-source-dirs: test/conformance-skeletons   main-is:        Main.hs   other-modules:+    SkelAggregate.Generated.MyService.ReplayAudit     SkelAggregate.Generated.MyService.Thing.Codec     SkelAggregate.Generated.MyService.Thing.Domain     SkelAggregate.Generated.MyService.Thing.EventStream@@ -154,6 +294,7 @@     SkelProcess.Generated.MyService.Hospital.Projection     SkelProcess.Generated.MyService.HospitalSurge.Process     SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness+    SkelProcess.Generated.MyService.ReplayAudit     SkelProcess.Generated.MyService.Surge.Codec     SkelProcess.Generated.MyService.Surge.Domain     SkelProcess.Generated.MyService.Surge.EventStream@@ -166,6 +307,7 @@     SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelHarness     SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable     SkelQueue.Generated.MyService.Reservation_work.Queue+    SkelQueue.Generated.MyService.Reservation_work.QueueCodec     SkelQueue.Generated.MyService.Reservation_work.QueuePolicy     SkelQueue.Generated.MyService.Transfer_decisions.ReadModel     SkelQueue.Generated.MyService.Transfer_decisions.ReadModelHarness@@ -179,23 +321,25 @@     SkelRouter.Generated.MyService.Page.Projection     SkelRouter.Generated.MyService.PagingRouter.Router     SkelRouter.Generated.MyService.PagingRouter.RouterHarness+    SkelRouter.Generated.MyService.ReplayAudit     SkelRouter.MyService.Page.Holes     SkelRouter.MyService.PagingRouter.RouterHoles     SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowFacts     SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowRuntime    build-depends:-    , aeson              >=2.2+    , aeson              >=2.2  && <2.3     , base               >=4.21 && <5     , containers     , effectful-core     , hasql-transaction-    , keiki              >=0.2  && <0.3+    , keiki              >=0.4  && <0.5     , keiro+    , keiro-core     , keiro-pgmq     , kiroku-store     , shibuya-core-    , text               >=2.1+    , text               >=2.1  && <2.2     , time     , uuid @@ -209,6 +353,7 @@   main-is:        Main.hs   other-modules:     Billing.Subscription.Holes+    Generated.Billing.ReplayAudit     Generated.Billing.Subscription.Codec     Generated.Billing.Subscription.Domain     Generated.Billing.Subscription.EventStream@@ -216,11 +361,11 @@     Generated.Billing.Subscription.Projection    build-depends:-    , aeson  >=2.2+    , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.2  && <0.3+    , keiki  >=0.4  && <0.5     , keiro-    , text   >=2.1+    , text   >=2.1  && <2.2  -- Contract codec conformance (EP-4): the scaffolded self-contained contract -- payload ADT + codec, compiled + round-tripped per event type.@@ -231,9 +376,9 @@   main-is:        Main.hs   other-modules:  Generated.HospitalCapacity.Emergency.Contract   build-depends:-    , aeson  >=2.2+    , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , text   >=2.1+    , text   >=2.1  && <2.2  -- EP-4 intake runtime conformance: the scaffolded Inbox disposition + dedupe -- policy compiled against the LIVE Keiro.Inbox.Types (InboxResult / dedupe).@@ -285,11 +430,16 @@   type:           exitcode-stdio-1.0   hs-source-dirs: test/conformance-queue   main-is:        Main.hs-  other-modules:  Generated.HospitalCapacity.Reservation_work.Queue+  other-modules:+    Generated.HospitalCapacity.Reservation_work.Queue+    Generated.HospitalCapacity.Reservation_work.QueueCodec+   build-depends:-    , aeson  >=2.2-    , base   >=4.21 && <5-    , text   >=2.1+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , keiro-core+    , keiro-pgmq+    , text        >=2.1  && <2.2  -- EP-5 pgmq runtime conformance: the scaffolded QueuePolicy (RetryPolicy + -- JobOutcome disposition) compiled against the LIVE Keiro.PGMQ.Job runtime.@@ -300,16 +450,18 @@   main-is:        Main.hs   other-modules:     Generated.HospitalCapacity.Reservation_work.Queue+    Generated.HospitalCapacity.Reservation_work.QueueCodec     Generated.HospitalCapacity.Reservation_work.QueuePolicy    build-depends:-    , aeson        >=2.2+    , aeson        >=2.2  && <2.3     , base         >=4.21 && <5+    , keiro-core     , keiro-dsl     , keiro-pgmq     , pgmq-config     , pgmq-core-    , text         >=2.1+    , text         >=2.1  && <2.2  -- EP-107 read-model runtime conformance: the scaffolded ReadModel record, -- registration/rebuild helpers, AsyncProjection, facts harness, and a filled@@ -331,7 +483,7 @@     , hasql-transaction     , keiro     , kiroku-store-    , text               >=2.1+    , text               >=2.1  && <2.2  -- EP-5 M5 full-service conformance: a complete pgmq dispatch service — scaffolded -- Job codec + retry policy + a filled worker handler assembled into a live@@ -343,15 +495,17 @@   main-is:        Main.hs   other-modules:     Generated.HospitalCapacity.Reservation_work.Queue+    Generated.HospitalCapacity.Reservation_work.QueueCodec     Generated.HospitalCapacity.Reservation_work.QueuePolicy     HospitalCapacity.ReservationWork.WorkqueueJob    build-depends:-    , aeson           >=2.2+    , aeson           >=2.2  && <2.3     , base            >=4.21 && <5     , effectful-core+    , keiro-core     , keiro-pgmq-    , text            >=2.1+    , text            >=2.1  && <2.2  -- Workflow facts harness (EP-6): the scaffolded self-contained WorkflowFacts -- module asserted against a hand-written expectation (mutation-pinnable).@@ -380,7 +534,7 @@     , base        >=4.21 && <5     , containers     , keiro-    , text        >=2.1+    , text        >=2.1  && <2.2  -- EP-3 M5 full-service conformance: a complete process service — the scaffolded -- Surge (saga) + Hospital (target) aggregates with filled transducers, plus a@@ -395,6 +549,7 @@     Generated.SurgeDemo.Hospital.Domain     Generated.SurgeDemo.Hospital.EventStream     Generated.SurgeDemo.Hospital.Projection+    Generated.SurgeDemo.ReplayAudit     Generated.SurgeDemo.Surge.Codec     Generated.SurgeDemo.Surge.Domain     Generated.SurgeDemo.Surge.EventStream@@ -405,14 +560,14 @@     SurgeDemo.SurgeFlow.Manager    build-depends:-    , aeson         >=2.2+    , aeson         >=2.2  && <2.3     , base          >=4.21 && <5-    , keiki         >=0.2  && <0.3+    , keiki         >=0.4  && <0.5     , keiro     , shibuya-core-    , text          >=2.1-    , time          >=1.12-    , uuid          >=1.3+    , text          >=2.1  && <2.2+    , time          >=1.12 && <1.15+    , uuid          >=1.3  && <1.4  -- EP-6 M5 full-service conformance: a complete durable workflow — scaffolded -- WorkflowRuntime + a filled ordered step/await body — compiled against the@@ -427,12 +582,12 @@     HospitalCapacity.HospitalTransferReservation.WorkflowBody    build-depends:-    , aeson           >=2.2+    , aeson           >=2.2  && <2.3     , base            >=4.21 && <5     , containers     , effectful-core     , keiro-    , text            >=2.1+    , text            >=2.1  && <2.2  -- EP-3 process runtime conformance: the scaffolded Process module's -- deterministic wiring (timer-request builder + fire disposition) compiled@@ -444,14 +599,14 @@   main-is:        Main.hs   other-modules:  Generated.HospitalCapacity.HospitalSurge.Process   build-depends:-    , aeson         >=2.2+    , aeson         >=2.2  && <2.3     , base          >=4.21 && <5     , keiro     , keiro-dsl     , shibuya-core-    , text          >=2.1-    , time          >=1.12-    , uuid          >=1.3+    , text          >=2.1  && <2.2+    , time          >=1.12 && <1.15+    , uuid          >=1.3  && <1.4  -- EP-108 router runtime conformance: generated policy lowering and the live -- target-keyed deterministic id contract.@@ -469,8 +624,8 @@     , keiro     , kiroku-store     , shibuya-core-    , text          >=2.1-    , uuid          >=1.3+    , text          >=2.1  && <2.2+    , uuid          >=1.3  && <1.4  -- EP-108 generated router-facts harness with hand-written expectations. test-suite keiro-dsl-conformance-router@@ -494,17 +649,18 @@     Generated.IncidentPaging.Page.EventStream     Generated.IncidentPaging.PagingRouter.Router     Generated.IncidentPaging.PagingRouter.RouterHarness+    Generated.IncidentPaging.ReplayAudit     IncidentPaging.Page.Holes     IncidentPaging.PagingRouter.RouterValue    build-depends:-    , aeson           >=2.2+    , aeson           >=2.2  && <2.3     , base            >=4.21 && <5     , effectful-core-    , keiki           >=0.2  && <0.3+    , keiki           >=0.4  && <0.5     , keiro     , shibuya-core-    , text            >=2.1+    , text            >=2.1  && <2.2  -- MP-15/EP-110 M6 cold-start: a fresh agent, given only the authoring skill -- and feature sentence, produced this aggregate + readmodel + router service.@@ -526,21 +682,22 @@     Generated.TransferRouting.Hospital_load.ReadModelTable     Generated.TransferRouting.HospitalTransferRouter.Router     Generated.TransferRouting.HospitalTransferRouter.RouterHarness+    Generated.TransferRouting.ReplayAudit     TransferRouting.Hospital.Holes     TransferRouting.Hospital_load.ReadModelHoles     TransferRouting.HospitalTransferRouter.RouterHoles     TransferRouting.HospitalTransferRouter.RouterValue    build-depends:-    , aeson              >=2.2+    , aeson              >=2.2  && <2.3     , base               >=4.21 && <5     , effectful-core     , hasql-transaction-    , keiki              >=0.2  && <0.3+    , keiki              >=0.4  && <0.5     , keiro     , kiroku-store     , shibuya-core-    , text               >=2.1+    , text               >=2.1  && <2.2  -- Process-manager facts harness (EP-3 M4): the self-contained, firewall-clean -- ProcessHarness module scaffolded from hospital-surge.keiro, compiled + run to@@ -555,7 +712,7 @@   other-modules:  Generated.HospitalCapacity.HospitalSurge.ProcessHarness   build-depends:     , base  >=4.21 && <5-    , text  >=2.1+    , text  >=2.1  && <2.2  -- Conformance for the evolved (v2) Reservation aggregate: proves the scaffolded -- Codec schemaVersion=2 + upcasters wiring compiles and that the filled upcaster@@ -568,6 +725,7 @@   hs-source-dirs: test/conformance-v2   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.ReplayAudit     Generated.HospitalCapacity.Reservation.Codec     Generated.HospitalCapacity.Reservation.Domain     Generated.HospitalCapacity.Reservation.EventStream@@ -576,8 +734,9 @@     HospitalCapacity.Reservation.Holes    build-depends:-    , aeson  >=2.2-    , base   >=4.21 && <5-    , keiki  >=0.2  && <0.3+    , aeson      >=2.2  && <2.3+    , base       >=4.21 && <5+    , directory  >=1.3  && <1.4+    , keiki      >=0.4  && <0.5     , keiro-    , text   >=2.1+    , text       >=2.1  && <2.2

@@ -0,0 +1,742 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++{- | Pure historical-codec comparison and migration-evidence reports.++The comparison is deliberately finite evidence over typed fixture cases and+historical JSON goldens. It never changes which codec owns the wire schema and+never upgrades an opaque declaration to a structural claim.+-}+module Keiro.Dsl.CodecCompare (+    FixtureOrigin (..),+    DecodeOutcome (..),+    JsonPointer (..),+    ComparisonDifference (..),+    HistoricalCodec (..),+    CompareObservation (..),+    FixtureVerdict (..),+    CompareInputIssue (..),+    BranchKind (..),+    DeclaredBranch (..),+    ObservedBranch (..),+    CoverageGap (..),+    BranchSchema (..),+    BranchField (..),+    BranchArm (..),+    CompareProvenance (..),+    ClassifiedObservation (..),+    CompareReport (..),+    ReportWriteError (..),+    authorityStatement,+    canonicalJsonBytes,+    classifyObservation,+    declaredBranchesFor,+    observedBranchesFor,+    compareReport,+    renderCompareReport,+    reportSucceeded,+    writeCompareReportAtomic,+) where++import Control.Exception (IOException, bracketOnError, displayException, try)+import Control.Monad (when)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, withText, (.:), (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.RFC8785 qualified as RFC8785+import Data.Aeson.Types (Parser)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Foldable (toList)+import Data.List (sort)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))+import Keiro.Dsl.Validate (DiagnosticCode (..))+import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)+import System.FilePath (takeDirectory, takeFileName)+import System.IO (Handle, hClose, openBinaryTempFile)++data FixtureOrigin = HistoricalGolden | FromBinding+    deriving stock (Eq, Ord, Show)++data DecodeOutcome+    = DecodedShape !Value+    | DecodeFailed !Text+    deriving stock (Eq, Show)++newtype JsonPointer = JsonPointer {unJsonPointer :: Text}+    deriving stock (Eq, Ord, Show)++data ComparisonDifference+    = EncodedValueDifference !JsonPointer !Value !Value+    | DecodedValueDifference !JsonPointer !Value !Value+    | GeneratedDecodeRejected !Text+    deriving stock (Eq, Show)++{- | A historical codec is an explicit value supplied by consumer-owned test+code. Its identity and version are report provenance, not dispatch keys.+-}+data HistoricalCodec a = HistoricalCodec+    { hcIdentity :: !Text+    , hcVersion :: !Text+    , hcEncode :: !(a -> Value)+    , hcDecode :: !(Value -> Either Text a)+    }++data CompareObservation+    = EncodeObservation+        { coCaseName :: !Text+        , coHistoricalValue :: !Value+        , coGeneratedValue :: !Value+        }+    | DecodeObservation+        { coFixturePath :: !FilePath+        , coInputValue :: !Value+        , coHistoricalDecode :: !DecodeOutcome+        , coGeneratedDecode :: !DecodeOutcome+        }+    deriving stock (Eq, Show)++data FixtureVerdict+    = JsonParity+    | RequiresVersionWork !ComparisonDifference+    deriving stock (Eq, Show)++data CompareInputIssue+    = HistoricalGoldenUnreadable !FilePath !Text+    | HistoricalCodecRejected !FilePath !Text+    | HistoricalCodecProvenanceInvalid !Text+    deriving stock (Eq, Show)++data BranchKind+    = UnionArm !Text+    | OptionalPresent+    | OptionalMissing+    | ExplicitNull+    deriving stock (Eq, Ord, Show)++data DeclaredBranch = DeclaredBranch+    { dbOrigin :: !FixtureOrigin+    , dbPointer :: !JsonPointer+    , dbKind :: !BranchKind+    }+    deriving stock (Eq, Ord, Show)++data ObservedBranch = ObservedBranch+    { obOrigin :: !FixtureOrigin+    , obPointer :: !JsonPointer+    , obKind :: !BranchKind+    }+    deriving stock (Eq, Ord, Show)++data CoverageGap = CoverageGap+    { cgOrigin :: !FixtureOrigin+    , cgPointer :: !JsonPointer+    , cgKind :: !BranchKind+    }+    deriving stock (Eq, Ord, Show)++{- | A codec-independent branch description embedded into generated+comparison runners. The generator constructs it through the checked type+graph's total algebras, so this module never has to interpret a consumer type.+-}+data BranchSchema+    = BranchScalar+    | BranchOptional !BranchSchema+    | BranchList !BranchSchema+    | BranchMap !BranchSchema+    | BranchRecord ![BranchField]+    | BranchUnion !Text !Text ![BranchArm]+    deriving stock (Eq, Show)++data BranchField = BranchField+    { bfWireKey :: !Text+    , bfPresenceOptional :: !Bool+    , bfSchema :: !BranchSchema+    }+    deriving stock (Eq, Show)++data BranchArm = BranchArm+    { baWireTag :: !Text+    , baPayloadSchema :: !(Maybe BranchSchema)+    }+    deriving stock (Eq, Show)++data CompareProvenance = CompareProvenance+    { cpHistoricalCodecIdentity :: !Text+    , cpHistoricalCodecVersion :: !Text+    , cpCanonicalType :: !CanonicalTypeId+    , cpBindingSymbol :: !QualifiedValueName+    , cpBindingVersion :: !BindingVersion+    , cpWireFingerprint :: !Text+    }+    deriving stock (Eq, Show)++data ClassifiedObservation = ClassifiedObservation+    { classifiedOrigin :: !FixtureOrigin+    , classifiedName :: !Text+    , classifiedVerdict :: !FixtureVerdict+    }+    deriving stock (Eq, Show)++data CompareReport = CompareReport+    { crProvenance :: !CompareProvenance+    , crObservations :: ![ClassifiedObservation]+    , crInputIssues :: ![CompareInputIssue]+    , crCoverageGaps :: ![CoverageGap]+    , crAuthority :: !Text+    }+    deriving stock (Eq, Show)++data ReportWriteError = ReportWriteError+    { reportWritePath :: !FilePath+    , reportWriteMessage :: !Text+    }+    deriving stock (Eq, Show)++authorityStatement :: Text+authorityStatement =+    "This comparison is MIGRATION EVIDENCE ONLY. After cutover the generated structural codec is the sole wire authority. This runner is never a runtime fallback and never upgrades an opaque declaration to structural. Resolve each difference with an explicit version bump and upcaster, or correct the declaration to match the historical wire contract; \"close enough\" is not an outcome."++-- | Render a JSON value in RFC 8785 canonical form.+canonicalJsonBytes :: Value -> ByteString+canonicalJsonBytes = LazyByteString.toStrict . RFC8785.encodeCanonical++classifyObservation :: CompareObservation -> Either CompareInputIssue FixtureVerdict+classifyObservation observation = case observation of+    EncodeObservation _ historical generated ->+        Right (classifyValues EncodedValueDifference historical generated)+    DecodeObservation fixturePath _ historical generated -> case historical of+        DecodeFailed reason -> Left (HistoricalCodecRejected fixturePath reason)+        DecodedShape historicalValue -> case generated of+            DecodeFailed reason -> Right (RequiresVersionWork (GeneratedDecodeRejected reason))+            DecodedShape generatedValue ->+                Right (classifyValues DecodedValueDifference historicalValue generatedValue)++classifyValues :: (JsonPointer -> Value -> Value -> ComparisonDifference) -> Value -> Value -> FixtureVerdict+classifyValues difference historical generated+    | canonicalJsonBytes historical == canonicalJsonBytes generated = JsonParity+    | otherwise = RequiresVersionWork (difference (firstDivergentPointer historical generated) historical generated)++compareReport ::+    CompareProvenance ->+    [CompareInputIssue] ->+    [CompareObservation] ->+    [DeclaredBranch] ->+    [ObservedBranch] ->+    CompareReport+compareReport provenance suppliedIssues observations declaredBranches observedBranches =+    CompareReport+        { crProvenance = provenance+        , crObservations = classified+        , crInputIssues = provenanceIssues provenance <> suppliedIssues <> classificationIssues+        , crCoverageGaps = coverageGaps declaredBranches observedBranches+        , crAuthority = authorityStatement+        }+  where+    outcomes = map classify observations+    classified = [value | Right value <- outcomes]+    classificationIssues = [issue | Left issue <- outcomes]++    classify observation = case classifyObservation observation of+        Left issue -> Left issue+        Right verdict ->+            Right+                ClassifiedObservation+                    { classifiedOrigin = observationOrigin observation+                    , classifiedName = observationName observation+                    , classifiedVerdict = verdict+                    }++observationOrigin :: CompareObservation -> FixtureOrigin+observationOrigin EncodeObservation{} = FromBinding+observationOrigin DecodeObservation{} = HistoricalGolden++observationName :: CompareObservation -> Text+observationName EncodeObservation{coCaseName = name} = name+observationName DecodeObservation{coFixturePath = path} = T.pack path++provenanceIssues :: CompareProvenance -> [CompareInputIssue]+provenanceIssues provenance =+    [ HistoricalCodecProvenanceInvalid "historical codec identity must not be blank"+    | T.null (T.strip (cpHistoricalCodecIdentity provenance))+    ]+        <> [ HistoricalCodecProvenanceInvalid "historical codec version must not be blank"+           | T.null (T.strip (cpHistoricalCodecVersion provenance))+           ]++coverageGaps :: [DeclaredBranch] -> [ObservedBranch] -> [CoverageGap]+coverageGaps declared observed =+    [ CoverageGap (dbOrigin branch) (dbPointer branch) (dbKind branch)+    | branch <- declared+    , branchKey branch `Set.notMember` observedKeys+    ]+  where+    observedKeys = Set.fromList (map observedBranchKey observed)+    branchKey branch = (dbOrigin branch, dbPointer branch, dbKind branch)+    observedBranchKey branch = (obOrigin branch, obPointer branch, obKind branch)++declaredBranchesFor :: FixtureOrigin -> BranchSchema -> [DeclaredBranch]+declaredBranchesFor origin = Set.toAscList . go ""+  where+    declared pointer kind = Set.singleton (DeclaredBranch origin (JsonPointer pointer) kind)+    go pointer schema = case schema of+        BranchScalar -> Set.empty+        BranchOptional nested ->+            declared pointer OptionalPresent+                <> declared pointer ExplicitNull+                <> go pointer nested+        BranchList nested -> go (appendPointer pointer "*") nested+        BranchMap nested -> go (appendPointer pointer "*") nested+        BranchRecord fields ->+            Set.unions+                [ presenceBranches pointer field <> go (appendPointer pointer (bfWireKey field)) (bfSchema field)+                | field <- fields+                ]+        BranchUnion _tagField contentsField arms ->+            Set.unions+                [ declared pointer (UnionArm (baWireTag arm))+                    <> maybe Set.empty (go (appendPointer pointer contentsField)) (baPayloadSchema arm)+                | arm <- arms+                ]+    presenceBranches pointer field+        | bfPresenceOptional field =+            let fieldPointer = appendPointer pointer (bfWireKey field)+             in case origin of+                    HistoricalGolden -> declared fieldPointer OptionalMissing <> declared fieldPointer OptionalPresent+                    FromBinding -> declared fieldPointer OptionalPresent+        | otherwise = Set.empty++observedBranchesFor :: FixtureOrigin -> BranchSchema -> Value -> [ObservedBranch]+observedBranchesFor origin schema = Set.toAscList . go "" schema+  where+    observed pointer kind = Set.singleton (ObservedBranch origin (JsonPointer pointer) kind)+    go pointer branchSchema value = case branchSchema of+        BranchScalar -> Set.empty+        BranchOptional nested -> case value of+            Null -> observed pointer ExplicitNull+            _ -> observed pointer OptionalPresent <> go pointer nested value+        BranchList nested -> case value of+            Array values -> Set.unions [go (appendPointer pointer "*") nested item | item <- toList values]+            _ -> Set.empty+        BranchMap nested -> case value of+            Object values -> Set.unions [go (appendPointer pointer "*") nested item | item <- KeyMap.elems values]+            _ -> Set.empty+        BranchRecord fields -> case value of+            Object values -> Set.unions (map (observeField pointer values) fields)+            _ -> Set.empty+        BranchUnion tagField contentsField arms -> case value of+            Object values -> case KeyMap.lookup (Key.fromText tagField) values of+                Just (String tag) -> case filter ((== tag) . baWireTag) arms of+                    arm : _ ->+                        observed pointer (UnionArm tag)+                            <> case (baPayloadSchema arm, KeyMap.lookup (Key.fromText contentsField) values) of+                                (Just nested, Just payload) -> go (appendPointer pointer contentsField) nested payload+                                _ -> Set.empty+                    [] -> Set.empty+                _ -> Set.empty+            _ -> Set.empty+    observeField pointer values field =+        let fieldPointer = appendPointer pointer (bfWireKey field)+         in case KeyMap.lookup (Key.fromText (bfWireKey field)) values of+                Nothing+                    | bfPresenceOptional field -> observed fieldPointer OptionalMissing+                    | otherwise -> Set.empty+                Just fieldValue ->+                    (if bfPresenceOptional field then observed fieldPointer OptionalPresent else Set.empty)+                        <> go fieldPointer (bfSchema field) fieldValue++reportSucceeded :: CompareReport -> Bool+reportSucceeded report =+    null (crInputIssues report)+        && null (crCoverageGaps report)+        && all ((== JsonParity) . classifiedVerdict) (crObservations report)++renderCompareReport :: CompareReport -> Text+renderCompareReport report =+    T.unlines+        ( [ "codec comparison: "+                <> unCanonicalTypeId (cpCanonicalType provenance)+                <> " (binding-version \""+                <> unBindingVersion (cpBindingVersion provenance)+                <> "\")"+          , "historical codec: \""+                <> cpHistoricalCodecIdentity provenance+                <> "\" version \""+                <> cpHistoricalCodecVersion provenance+                <> "\""+          , "observations: " <> tshow (length observations)+          , "  encode parity: " <> ratio FromBinding+          , "  structural decode agreement: " <> ratio HistoricalGolden+          , "requires explicit version/upcaster work: " <> tshow (length differences) <> " observations  [" <> codeText CodecCompareDifference <> "]"+          ]+            <> concatMap renderDifference differences+            <> [ "input issues: " <> tshow (length (crInputIssues report)) <> "  [" <> codeText CodecCompareInvalidInput <> "]"+               ]+            <> map ("  " <>) (map renderInputIssue (crInputIssues report))+            <> [ "coverage gaps: " <> tshow (length (crCoverageGaps report)) <> "  [" <> codeText CodecCompareCoverageGap <> "]"+               ]+            <> map ("  " <>) (map renderCoverageGap (crCoverageGaps report))+            <> [ if reportSucceeded report+                    then "result: PARITY"+                    else "result: NOT PARITY — " <> tshow (length differences) <> " differences"+               , crAuthority report+               ]+        )+  where+    provenance = crProvenance report+    observations = crObservations report+    differences = filter ((/= JsonParity) . classifiedVerdict) observations+    ratio origin =+        let matching = filter ((== origin) . classifiedOrigin) observations+            parityCount = length (filter ((== JsonParity) . classifiedVerdict) matching)+         in tshow parityCount <> "/" <> tshow (length matching) <> suffix origin+    suffix FromBinding = " (RFC 8785 canonical form)"+    suffix HistoricalGolden = ""++renderDifference :: ClassifiedObservation -> [Text]+renderDifference observation = case classifiedVerdict observation of+    JsonParity -> []+    RequiresVersionWork difference ->+        [ "  " <> classifiedName observation <> " [" <> direction <> "] at " <> pointerOf difference+        , "    " <> reasonOf difference+        ]+  where+    direction = case classifiedOrigin observation of+        FromBinding -> "encode"+        HistoricalGolden -> "decode"++renderInputIssue :: CompareInputIssue -> Text+renderInputIssue issue = case issue of+    HistoricalGoldenUnreadable path reason -> T.pack path <> ": unreadable historical golden: " <> reason+    HistoricalCodecRejected path reason -> T.pack path <> ": historical codec rejected its alleged golden: " <> reason+    HistoricalCodecProvenanceInvalid reason -> reason++renderCoverageGap :: CoverageGap -> Text+renderCoverageGap gap =+    originName (cgOrigin gap)+        <> " "+        <> renderPointer (cgPointer gap)+        <> ": "+        <> branchKindName (cgKind gap)++pointerOf :: ComparisonDifference -> Text+pointerOf difference = case difference of+    EncodedValueDifference pointer _ _ -> renderPointer pointer+    DecodedValueDifference pointer _ _ -> renderPointer pointer+    GeneratedDecodeRejected _ -> "<root>"++reasonOf :: ComparisonDifference -> Text+reasonOf difference = case difference of+    EncodedValueDifference _ historical generated ->+        "historical and generated encoders produced different JSON values: " <> valuePair historical generated+    DecodedValueDifference _ historical generated ->+        "historical and generated decoders normalized to different structural values: " <> valuePair historical generated+    GeneratedDecodeRejected reason -> "generated structural decoder rejected historical JSON: " <> reason++valuePair :: Value -> Value -> Text+valuePair historical generated = "historical=" <> tshow historical <> "; generated=" <> tshow generated++renderPointer :: JsonPointer -> Text+renderPointer (JsonPointer pointer)+    | T.null pointer = "<root>"+    | otherwise = pointer++writeCompareReportAtomic :: FilePath -> CompareReport -> IO (Either ReportWriteError ())+writeCompareReportAtomic path report = do+    let directory = takeDirectory path+        template = takeFileName path <> ".tmp"+    result <- try $ do+        createDirectoryIfMissing True directory+        bracketOnError+            (openBinaryTempFile directory template)+            cleanupTemporary+            ( \(temporary, handle) -> do+                LazyByteString.hPut handle (Aeson.encode report)+                hClose handle+                renameFile temporary path+            )+    pure $ case result of+        Left err -> Left (ReportWriteError path (T.pack (displayException (err :: IOException))))+        Right () -> Right ()++cleanupTemporary :: (FilePath, Handle) -> IO ()+cleanupTemporary (temporary, handle) = do+    _ <- try (hClose handle) :: IO (Either IOException ())+    exists <- doesFileExist temporary+    when exists (removeFile temporary)++firstDivergentPointer :: Value -> Value -> JsonPointer+firstDivergentPointer = go ""+  where+    go pointer (Object historical) (Object generated) =+        case firstDifferentKey historical generated of+            Nothing -> JsonPointer pointer+            Just key -> case (KeyMap.lookup (Key.fromText key) historical, KeyMap.lookup (Key.fromText key) generated) of+                (Just historicalValue, Just generatedValue) -> go (appendPointer pointer key) historicalValue generatedValue+                _ -> JsonPointer (appendPointer pointer key)+    go pointer (Array historical) (Array generated) =+        let historicalValues = toList historical+            generatedValues = toList generated+         in case firstDifferentIndex historicalValues generatedValues of+                Nothing -> JsonPointer pointer+                Just index -> case (indexMaybe index historicalValues, indexMaybe index generatedValues) of+                    (Just historicalValue, Just generatedValue) -> go (appendPointer pointer (tshow index)) historicalValue generatedValue+                    _ -> JsonPointer (appendPointer pointer (tshow index))+    go pointer _ _ = JsonPointer pointer++firstDifferentKey :: KeyMap.KeyMap Value -> KeyMap.KeyMap Value -> Maybe Text+firstDifferentKey historical generated =+    firstMatch differs allKeys+  where+    allKeys = sort (map Key.toText (KeyMap.keys historical <> KeyMap.keys generated))+    differs key = KeyMap.lookup (Key.fromText key) historical /= KeyMap.lookup (Key.fromText key) generated++firstDifferentIndex :: [Value] -> [Value] -> Maybe Int+firstDifferentIndex historical generated =+    firstMatch differs [0 .. max (length historical) (length generated) - 1]+  where+    differs index = indexMaybe index historical /= indexMaybe index generated++indexMaybe :: Int -> [a] -> Maybe a+indexMaybe index values = case drop index values of+    value : _ -> Just value+    [] -> Nothing++firstMatch :: (a -> Bool) -> [a] -> Maybe a+firstMatch predicate = \case+    [] -> Nothing+    value : rest+        | predicate value -> Just value+        | otherwise -> firstMatch predicate rest++appendPointer :: Text -> Text -> Text+appendPointer base segment = base <> "/" <> escapePointerSegment segment++escapePointerSegment :: Text -> Text+escapePointerSegment = T.replace "/" "~1" . T.replace "~" "~0"++tshow :: (Show a) => a -> Text+tshow = T.pack . show++codeText :: DiagnosticCode -> Text+codeText = T.pack . show++originName :: FixtureOrigin -> Text+originName HistoricalGolden = "historical-golden"+originName FromBinding = "typed-fixture"++parseOrigin :: Text -> Parser FixtureOrigin+parseOrigin "historical-golden" = pure HistoricalGolden+parseOrigin "typed-fixture" = pure FromBinding+parseOrigin value = fail ("unknown fixture origin: " <> T.unpack value)++branchKindName :: BranchKind -> Text+branchKindName kind = case kind of+    UnionArm arm -> "union-arm:" <> arm+    OptionalPresent -> "optional-present"+    OptionalMissing -> "optional-missing"+    ExplicitNull -> "explicit-null"++parseBranchKind :: Text -> Parser BranchKind+parseBranchKind value+    | Just arm <- T.stripPrefix "union-arm:" value = pure (UnionArm arm)+    | value == "optional-present" = pure OptionalPresent+    | value == "optional-missing" = pure OptionalMissing+    | value == "explicit-null" = pure ExplicitNull+    | otherwise = fail ("unknown branch kind: " <> T.unpack value)++instance ToJSON FixtureOrigin where+    toJSON = String . originName++instance FromJSON FixtureOrigin where+    parseJSON = withText "FixtureOrigin" parseOrigin++instance ToJSON JsonPointer where+    toJSON = String . unJsonPointer++instance FromJSON JsonPointer where+    parseJSON = withText "JsonPointer" (pure . JsonPointer)++instance ToJSON BranchKind where+    toJSON = String . branchKindName++instance FromJSON BranchKind where+    parseJSON = withText "BranchKind" parseBranchKind++instance ToJSON ComparisonDifference where+    toJSON difference = case difference of+        EncodedValueDifference pointer historical generated ->+            differenceObject "encoded-value-difference" pointer "encoder outputs differ" historical generated+        DecodedValueDifference pointer historical generated ->+            differenceObject "decoded-value-difference" pointer "normalized decoder outputs differ" historical generated+        GeneratedDecodeRejected reason ->+            object+                [ "kind" .= ("generated-decode-rejected" :: Text)+                , "pointer" .= JsonPointer ""+                , "reason" .= reason+                ]+      where+        differenceObject kind pointer reason historical generated =+            object+                [ "kind" .= (kind :: Text)+                , "pointer" .= pointer+                , "reason" .= (reason :: Text)+                , "historical" .= historical+                , "generated" .= generated+                ]++instance FromJSON ComparisonDifference where+    parseJSON = withObject "ComparisonDifference" $ \value -> do+        kind <- value .: "kind" :: Parser Text+        case kind of+            "encoded-value-difference" -> EncodedValueDifference <$> value .: "pointer" <*> value .: "historical" <*> value .: "generated"+            "decoded-value-difference" -> DecodedValueDifference <$> value .: "pointer" <*> value .: "historical" <*> value .: "generated"+            "generated-decode-rejected" -> GeneratedDecodeRejected <$> value .: "reason"+            _ -> fail ("unknown comparison difference: " <> T.unpack kind)++instance ToJSON FixtureVerdict where+    toJSON JsonParity = object ["verdict" .= ("json-parity" :: Text)]+    toJSON (RequiresVersionWork difference) =+        object+            [ "verdict" .= ("requires-version-work" :: Text)+            , "code" .= codeText CodecCompareDifference+            , "difference" .= difference+            ]++instance FromJSON FixtureVerdict where+    parseJSON = withObject "FixtureVerdict" $ \value -> do+        verdict <- value .: "verdict" :: Parser Text+        case verdict of+            "json-parity" -> pure JsonParity+            "requires-version-work" -> RequiresVersionWork <$> value .: "difference"+            _ -> fail ("unknown fixture verdict: " <> T.unpack verdict)++instance ToJSON CompareInputIssue where+    toJSON issue = case issue of+        HistoricalGoldenUnreadable path reason -> issueObject "historical-golden-unreadable" path reason+        HistoricalCodecRejected path reason -> issueObject "historical-codec-rejected" path reason+        HistoricalCodecProvenanceInvalid reason ->+            object+                [ "code" .= codeText CodecCompareInvalidInput+                , "kind" .= ("historical-codec-provenance-invalid" :: Text)+                , "reason" .= reason+                ]+      where+        issueObject kind path reason =+            object+                [ "code" .= codeText CodecCompareInvalidInput+                , "kind" .= (kind :: Text)+                , "path" .= path+                , "reason" .= reason+                ]++instance FromJSON CompareInputIssue where+    parseJSON = withObject "CompareInputIssue" $ \value -> do+        kind <- value .: "kind" :: Parser Text+        case kind of+            "historical-golden-unreadable" -> HistoricalGoldenUnreadable <$> value .: "path" <*> value .: "reason"+            "historical-codec-rejected" -> HistoricalCodecRejected <$> value .: "path" <*> value .: "reason"+            "historical-codec-provenance-invalid" -> HistoricalCodecProvenanceInvalid <$> value .: "reason"+            _ -> fail ("unknown comparison input issue: " <> T.unpack kind)++instance ToJSON DeclaredBranch where+    toJSON branch =+        object+            [ "origin" .= dbOrigin branch+            , "pointer" .= dbPointer branch+            , "branch" .= dbKind branch+            ]++instance FromJSON DeclaredBranch where+    parseJSON = withObject "DeclaredBranch" $ \value ->+        DeclaredBranch <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch"++instance ToJSON ObservedBranch where+    toJSON branch =+        object+            [ "origin" .= obOrigin branch+            , "pointer" .= obPointer branch+            , "branch" .= obKind branch+            ]++instance FromJSON ObservedBranch where+    parseJSON = withObject "ObservedBranch" $ \value ->+        ObservedBranch <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch"++instance ToJSON CoverageGap where+    toJSON gap =+        object+            [ "code" .= codeText CodecCompareCoverageGap+            , "origin" .= cgOrigin gap+            , "pointer" .= cgPointer gap+            , "branch" .= cgKind gap+            ]++instance FromJSON CoverageGap where+    parseJSON = withObject "CoverageGap" $ \value ->+        CoverageGap <$> value .: "origin" <*> value .: "pointer" <*> value .: "branch"++instance ToJSON CompareProvenance where+    toJSON provenance =+        object+            [ "historicalCodecIdentity" .= cpHistoricalCodecIdentity provenance+            , "historicalCodecVersion" .= cpHistoricalCodecVersion provenance+            , "canonicalType" .= unCanonicalTypeId (cpCanonicalType provenance)+            , "bindingSymbol" .= unQualifiedValueName (cpBindingSymbol provenance)+            , "bindingVersion" .= unBindingVersion (cpBindingVersion provenance)+            , "wireFingerprint" .= cpWireFingerprint provenance+            ]++instance FromJSON CompareProvenance where+    parseJSON = withObject "CompareProvenance" $ \value ->+        CompareProvenance+            <$> value .: "historicalCodecIdentity"+            <*> value .: "historicalCodecVersion"+            <*> (CanonicalTypeId <$> value .: "canonicalType")+            <*> (QualifiedValueName <$> value .: "bindingSymbol")+            <*> (BindingVersion <$> value .: "bindingVersion")+            <*> value .: "wireFingerprint"++instance ToJSON ClassifiedObservation where+    toJSON observation =+        object+            [ "origin" .= classifiedOrigin observation+            , "name" .= classifiedName observation+            , "result" .= classifiedVerdict observation+            ]++instance FromJSON ClassifiedObservation where+    parseJSON = withObject "ClassifiedObservation" $ \value ->+        ClassifiedObservation <$> value .: "origin" <*> value .: "name" <*> value .: "result"++instance ToJSON CompareReport where+    toJSON report =+        object+            [ "schema" .= ("keiro-dsl/codec-compare-report/1" :: Text)+            , "authority" .= crAuthority report+            , "provenance" .= crProvenance report+            , "success" .= reportSucceeded report+            , "summary"+                .= object+                    [ "observations" .= length (crObservations report)+                    , "parity" .= length (filter ((== JsonParity) . classifiedVerdict) (crObservations report))+                    , "differences" .= length (filter ((/= JsonParity) . classifiedVerdict) (crObservations report))+                    , "inputIssues" .= length (crInputIssues report)+                    , "coverageGaps" .= length (crCoverageGaps report)+                    ]+            , "observations" .= crObservations report+            , "inputIssues" .= crInputIssues report+            , "coverageGaps" .= crCoverageGaps report+            ]++instance FromJSON CompareReport where+    parseJSON = withObject "CompareReport" $ \value ->+        CompareReport+            <$> value .: "provenance"+            <*> value .: "observations"+            <*> value .: "inputIssues"+            <*> value .: "coverageGaps"+            <*> value .: "authority"

@@ -0,0 +1,650 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++{- | Reporting-only structural coverage over the checked mapped-type graph.++The report intentionally has no aggregate percentage. Private persisted event+payloads and mapped register cache boundaries have different authorities, and+queue/public-contract payloads are not represented by this graph at all.+-}+module Keiro.Dsl.Coverage (+    CoverageSurface (..),+    CoverageMode (..),+    CoverageRoot (..),+    StructuralBoundary (..),+    OpaqueBoundary (..),+    JsonBoundary (..),+    SnapshotBoundary (..),+    UnsupportedSurface (..),+    CoverageCounts (..),+    CoverageSummary (..),+    CoverageFinding (..),+    CoveragePrevious (..),+    CoverageDelta (..),+    CoverageReport (..),+    coverageReport,+    coverageDiffReport,+    failOnOpaque,+    failOnOpaqueIncrease,+    coverageSucceeded,+    renderCoverageSummary,+    renderCoverageFinding,+    writeCoverageReport,+) where++import Data.Aeson (ToJSON (..), object, (.=))+import Data.Aeson qualified as Aeson+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.TypeGraph+import Keiro.Dsl.Validate (DiagnosticCode (..), Severity (..))+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory)++data CoverageSurface = PrivateEventPayload | SnapshotRegister+    deriving stock (Eq, Ord, Show)++data CoverageMode = StructuralCoverage | OpaqueCoverage+    deriving stock (Eq, Ord, Show)++data CoverageRoot = CoverageRoot+    { rootSurface :: !CoverageSurface+    , rootPath :: !Text+    , rootMappedType :: !Text+    , rootMode :: !CoverageMode+    , rootCanonicalType :: !(Maybe Text)+    , rootCodecIdentity :: !(Maybe Text)+    , rootCodecVersion :: !(Maybe Text)+    , rootWireFingerprint :: !Text+    }+    deriving stock (Eq, Ord, Show)++data StructuralBoundary = StructuralBoundary+    { structuralRoot :: !Text+    , structuralPath :: !Text+    , structuralMappedType :: !Text+    , structuralCanonicalType :: !Text+    , structuralWireFingerprint :: !Text+    }+    deriving stock (Eq, Ord, Show)++data OpaqueBoundary = OpaqueBoundary+    { opaqueRoot :: !Text+    , opaquePath :: !Text+    , opaqueMappedType :: !Text+    , opaqueCodecIdentity :: !Text+    , opaqueCodecVersion :: !Text+    }+    deriving stock (Eq, Ord, Show)++data JsonBoundary = JsonBoundary+    { jsonRoot :: !Text+    , jsonPath :: !Text+    }+    deriving stock (Eq, Ord, Show)++data SnapshotBoundary = SnapshotBoundary+    { snapshotRoot :: !Text+    , snapshotAggregate :: !Text+    , snapshotRegister :: !Text+    , snapshotMappedType :: !Text+    , snapshotMode :: !CoverageMode+    , snapshotEncoding :: !Text+    , snapshotInvalidation :: !Text+    , snapshotWireFingerprint :: !Text+    , snapshotEnabled :: !Bool+    }+    deriving stock (Eq, Ord, Show)++data UnsupportedSurface = UnsupportedSurface+    { unsupportedSurface :: !Text+    , unsupportedSupport :: !Text+    , unsupportedReason :: !Text+    }+    deriving stock (Eq, Ord, Show)++data CoverageCounts = CoverageCounts+    { totalRoots :: !Int+    , structuralRoots :: !Int+    , opaqueRoots :: !Int+    , jsonBoundaries :: !Int+    }+    deriving stock (Eq, Show)++data CoverageSummary = CoverageSummary+    { privateEventPayloads :: !CoverageCounts+    , snapshotRegisters :: !CoverageCounts+    }+    deriving stock (Eq, Show)++data CoverageFinding = CoverageFinding+    { findingSeverity :: !Severity+    , findingCode :: !DiagnosticCode+    , findingRoots :: ![Text]+    , findingMessage :: !Text+    }+    deriving stock (Eq, Show)++data CoveragePrevious = CoveragePrevious+    { previousReference :: !Text+    , previousSummary :: !CoverageSummary+    , previousOpaqueBoundaries :: ![OpaqueBoundary]+    }+    deriving stock (Eq, Show)++data CoverageDelta = CoverageDelta+    { privateEventRootDelta :: !Int+    , snapshotRegisterRootDelta :: !Int+    , opaqueBoundaryDelta :: !Int+    , addedOpaqueBoundaries :: ![OpaqueBoundary]+    , removedOpaqueBoundaries :: ![OpaqueBoundary]+    }+    deriving stock (Eq, Show)++data CoverageReport = CoverageReport+    { coverageSpec :: !FilePath+    , coverageRoots :: ![CoverageRoot]+    , coverageStructuralBoundaries :: ![StructuralBoundary]+    , coverageOpaqueBoundaries :: ![OpaqueBoundary]+    , coverageJsonBoundaries :: ![JsonBoundary]+    , coverageSnapshotBoundaries :: ![SnapshotBoundary]+    , coverageUnsupportedSurfaces :: ![UnsupportedSurface]+    , coverageSummary :: !CoverageSummary+    , coverageFindings :: ![CoverageFinding]+    , coveragePrevious :: !(Maybe CoveragePrevious)+    , coverageDelta :: !(Maybe CoverageDelta)+    }+    deriving stock (Eq, Show)++coverageReport :: FilePath -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport+coverageReport specPath spec = do+    graph <- resolveTypeGraph spec+    let roots = sortOn rootPath (map (coverageRoot graph) (persistedSites graph))+        structural = structuralBoundaryInventory graph+        opaque = opaqueBoundaryInventory graph+        json = jsonBoundaryInventory graph+        snapshots = snapshotBoundaryInventory spec graph+        summary = summarize roots json+        findings = opaqueSurfaceFindings opaque+    pure+        CoverageReport+            { coverageSpec = specPath+            , coverageRoots = roots+            , coverageStructuralBoundaries = structural+            , coverageOpaqueBoundaries = opaque+            , coverageJsonBoundaries = json+            , coverageSnapshotBoundaries = snapshots+            , coverageUnsupportedSurfaces = unsupportedInventory+            , coverageSummary = summary+            , coverageFindings = findings+            , coveragePrevious = Nothing+            , coverageDelta = Nothing+            }++coverageDiffReport :: FilePath -> Text -> Spec -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport+coverageDiffReport specPath reference oldSpec newSpec = do+    oldReport <- coverageReport (T.unpack reference <> ":" <> specPath) oldSpec+    newReport <- coverageReport specPath newSpec+    let oldOpaque = Set.fromList (coverageOpaqueBoundaries oldReport)+        newOpaque = Set.fromList (coverageOpaqueBoundaries newReport)+        added = Set.toAscList (newOpaque `Set.difference` oldOpaque)+        removed = Set.toAscList (oldOpaque `Set.difference` newOpaque)+        oldSummary = coverageSummary oldReport+        newSummary = coverageSummary newReport+        delta =+            CoverageDelta+                { privateEventRootDelta = totalRoots (privateEventPayloads newSummary) - totalRoots (privateEventPayloads oldSummary)+                , snapshotRegisterRootDelta = totalRoots (snapshotRegisters newSummary) - totalRoots (snapshotRegisters oldSummary)+                , opaqueBoundaryDelta = length added - length removed+                , addedOpaqueBoundaries = added+                , removedOpaqueBoundaries = removed+                }+        addedFindings =+            [ CoverageFinding+                { findingSeverity = Warning+                , findingCode = CoverageOpaqueBoundaryAdded+                , findingRoots = [opaqueRoot boundary]+                , findingMessage = "opaque boundary added at " <> opaquePath boundary+                }+            | boundary <- added+            ]+    pure+        newReport+            { coverageFindings = coverageFindings newReport <> addedFindings+            , coveragePrevious =+                Just+                    CoveragePrevious+                        { previousReference = reference+                        , previousSummary = oldSummary+                        , previousOpaqueBoundaries = coverageOpaqueBoundaries oldReport+                        }+            , coverageDelta = Just delta+            }++failOnOpaque :: CoverageReport -> CoverageReport+failOnOpaque report+    | null boundaries = report+    | otherwise = report{coverageFindings = coverageFindings report <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]}+  where+    boundaries = coverageOpaqueBoundaries report++failOnOpaqueIncrease :: CoverageReport -> CoverageReport+failOnOpaqueIncrease report = case coverageDelta report of+    Just delta+        | not (null (addedOpaqueBoundaries delta)) ->+            report+                { coverageFindings =+                    coverageFindings report+                        <> [gateFinding "new opaque persisted boundaries are forbidden by --fail-on-opaque-increase" (addedOpaqueBoundaries delta)]+                }+    _ -> report++coverageSucceeded :: CoverageReport -> Bool+coverageSucceeded = all ((/= Error) . findingSeverity) . coverageFindings++renderCoverageSummary :: CoverageReport -> Text+renderCoverageSummary report =+    T.unlines+        [ "structural/opaque boundaries (reporting only):"+        , "  private-event-payloads: " <> renderCounts (privateEventPayloads summary)+        , "  snapshot-registers: " <> renderCounts (snapshotRegisters summary) <> "; encoding=consumer-json-cache; invalidation=tracked"+        , "  queue-payloads: unsupported"+        , "  public-contracts: not-applicable (separately owned grammar)"+        ]+  where+    summary = coverageSummary report+    renderCounts counts =+        T.pack (show (totalRoots counts))+            <> " mapped roots ("+            <> T.pack (show (structuralRoots counts))+            <> " structural, "+            <> T.pack (show (opaqueRoots counts))+            <> " opaque, "+            <> T.pack (show (jsonBoundaries counts))+            <> " Json boundaries)"++renderCoverageFinding :: FilePath -> CoverageFinding -> Text+renderCoverageFinding specPath finding =+    T.pack specPath+        <> ":0: "+        <> severityText (findingSeverity finding)+        <> "["+        <> T.pack (show (findingCode finding))+        <> "]: "+        <> findingMessage finding+        <> rootsSuffix+  where+    severityText Error = "error"+    severityText Warning = "warning"+    rootsSuffix = case findingRoots finding of+        [] -> ""+        roots -> " (roots: " <> T.intercalate ", " roots <> ")"++writeCoverageReport :: FilePath -> CoverageReport -> IO ()+writeCoverageReport path report = do+    createDirectoryIfMissing True (takeDirectory path)+    Aeson.encodeFile path report++persistedSites :: TypeGraph -> [UseSite]+persistedSites = filter isPersisted . tgUseSites+  where+    isPersisted RootEventField{} = True+    isPersisted RootRegister{} = True+    isPersisted RootCommandField{} = False++coverageRoot :: TypeGraph -> UseSite -> CoverageRoot+coverageRoot graph site =+    let key = useSiteKey site+        path = renderUsePath (UsePath site [])+        fingerprint = wireFingerprint graph (unMappedKey key)+     in case Map.lookup key (tgDeclarations graph) of+            Just (ResolvedStructural declaration _) ->+                CoverageRoot+                    { rootSurface = useSiteSurface site+                    , rootPath = path+                    , rootMappedType = unMappedKey key+                    , rootMode = StructuralCoverage+                    , rootCanonicalType = Just (unCanonicalTypeId (sdCanonical declaration))+                    , rootCodecIdentity = Nothing+                    , rootCodecVersion = Nothing+                    , rootWireFingerprint = fingerprint+                    }+            Just (ResolvedOpaque declaration) ->+                CoverageRoot+                    { rootSurface = useSiteSurface site+                    , rootPath = path+                    , rootMappedType = unMappedKey key+                    , rootMode = OpaqueCoverage+                    , rootCanonicalType = Nothing+                    , rootCodecIdentity = Just (unCodecIdentity (odCodecIdentity declaration))+                    , rootCodecVersion = Just (unCodecVersion (odCodecVersion declaration))+                    , rootWireFingerprint = fingerprint+                    }+            Nothing -> error "coverageRoot: resolved use-site key missing from graph"++structuralBoundaryInventory :: TypeGraph -> [StructuralBoundary]+structuralBoundaryInventory graph =+    sortOn+        structuralPath+        [ StructuralBoundary+            { structuralRoot = rootText (upRoot path)+            , structuralPath = renderUsePath path+            , structuralMappedType = sdName declaration+            , structuralCanonicalType = unCanonicalTypeId (sdCanonical declaration)+            , structuralWireFingerprint = wireFingerprint graph (sdName declaration)+            }+        | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph)+        , path <- usePaths graph (sdName declaration)+        , isEventSite (upRoot path)+        ]++opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary]+opaqueBoundaryInventory graph =+    sortOn+        opaquePath+        [ OpaqueBoundary+            { opaqueRoot = rootText (upRoot path)+            , opaquePath = renderUsePath path+            , opaqueMappedType = odName declaration+            , opaqueCodecIdentity = unCodecIdentity (odCodecIdentity declaration)+            , opaqueCodecVersion = unCodecVersion (odCodecVersion declaration)+            }+        | ResolvedOpaque declaration <- Map.elems (tgDeclarations graph)+        , path <- usePaths graph (odName declaration)+        , isEventSite (upRoot path)+        ]++jsonBoundaryInventory :: TypeGraph -> [JsonBoundary]+jsonBoundaryInventory graph =+    sortOn+        jsonPath+        [ JsonBoundary+            { jsonRoot = rootText site+            , jsonPath = renderUsePath (UsePath site segments)+            }+        | site <- persistedSites graph+        , isEventSite site+        , segments <- jsonPathsFromDecl graph Set.empty (useSiteKey site)+        ]++snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary]+snapshotBoundaryInventory spec graph =+    sortOn+        snapshotRoot+        [ SnapshotBoundary+            { snapshotRoot = renderUsePath (UsePath site [])+            , snapshotAggregate = aggregate+            , snapshotRegister = register+            , snapshotMappedType = unMappedKey key+            , snapshotMode = declarationMode declaration+            , snapshotEncoding = "consumer-json-cache"+            , snapshotInvalidation = "tracked-by-mapped-wire-fingerprint"+            , snapshotWireFingerprint = wireFingerprint graph (unMappedKey key)+            , snapshotEnabled = aggregateHasSnapshot aggregate+            }+        | site@(RootRegister aggregate register key) <- persistedSites graph+        , Just declaration <- [Map.lookup key (tgDeclarations graph)]+        ]+  where+    aggregateHasSnapshot name =+        any+            (\case NAggregate aggregate -> aggName aggregate == name && maybe False (const True) (aggSnapshot aggregate); _ -> False)+            (specNodes spec)++jsonPathsFromDecl :: TypeGraph -> Set.Set MappedKey -> MappedKey -> [[PathSeg]]+jsonPathsFromDecl graph visited key+    | key `Set.member` visited = []+    | otherwise = case Map.lookup key (tgDeclarations graph) of+        Nothing -> []+        Just declaration ->+            foldMappedDecl+                MappedDeclAlgebra+                    { onStructuralDecl = \_ shape -> jsonPathsFromShape graph (Set.insert key visited) shape+                    , onOpaqueDecl = const []+                    }+                declaration++jsonPathsFromShape :: TypeGraph -> Set.Set MappedKey -> ResolvedMappedShape -> [[PathSeg]]+jsonPathsFromShape graph visited =+    foldMappedShape+        MappedShapeAlgebra+            { onRecord = \_ _ fields ->+                concat+                    [ map (SegField (rwfHaskell field) (rwfKey field) :) (jsonPathsFromExpr graph visited (rwfType field))+                    | field <- fields+                    ]+            , onEnum = const []+            , onUnion = \_ arms ->+                concat+                    [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (jsonPathsFromExpr graph visited) (rwaPayload arm))+                    | arm <- arms+                    ]+            }++jsonPathsFromExpr :: TypeGraph -> Set.Set MappedKey -> ResolvedTypeExpr -> [[PathSeg]]+jsonPathsFromExpr graph visited =+    foldTypeExpr+        TypeExprAlgebra+            { onText = []+            , onInt = []+            , onBool = []+            , onNatural = []+            , onTime = []+            , onJson = [[]]+            , onOptional = map (SegOptional :)+            , onList = map (SegElem :)+            , onMap = map (SegMapValue :)+            , onRef = \key -> map (SegDecl (unMappedKey key) :) (jsonPathsFromDecl graph visited key)+            }++summarize :: [CoverageRoot] -> [JsonBoundary] -> CoverageSummary+summarize roots json =+    CoverageSummary+        { privateEventPayloads = countsFor PrivateEventPayload+        , snapshotRegisters = countsFor SnapshotRegister+        }+  where+    countsFor surface =+        let matching = filter ((== surface) . rootSurface) roots+            jsonCount = case surface of+                PrivateEventPayload -> length json+                SnapshotRegister -> 0+         in CoverageCounts+                { totalRoots = length matching+                , structuralRoots = length (filter ((== StructuralCoverage) . rootMode) matching)+                , opaqueRoots = length (filter ((== OpaqueCoverage) . rootMode) matching)+                , jsonBoundaries = jsonCount+                }++opaqueSurfaceFindings :: [OpaqueBoundary] -> [CoverageFinding]+opaqueSurfaceFindings boundaries =+    [ CoverageFinding+        { findingSeverity = Warning+        , findingCode = CoverageOpaqueSurface+        , findingRoots = [root]+        , findingMessage = "persisted private-event root contains opaque mapped boundaries"+        }+    | root <- Set.toAscList (Set.fromList (map opaqueRoot boundaries))+    ]++gateFinding :: Text -> [OpaqueBoundary] -> CoverageFinding+gateFinding message boundaries =+    CoverageFinding+        { findingSeverity = Error+        , findingCode = CoverageOpaqueGateExceeded+        , findingRoots = Set.toAscList (Set.fromList (map opaqueRoot boundaries))+        , findingMessage = message+        }++unsupportedInventory :: [UnsupportedSurface]+unsupportedInventory =+    [ UnsupportedSurface+        { unsupportedSurface = "queue-payloads"+        , unsupportedSupport = "unsupported"+        , unsupportedReason = "queue payloads are not roots in the mapped-type graph"+        }+    , UnsupportedSurface+        { unsupportedSurface = "public-contracts"+        , unsupportedSupport = "not-applicable"+        , unsupportedReason = "public contracts have a separately owned grammar and compatibility surface"+        }+    ]++useSiteKey :: UseSite -> MappedKey+useSiteKey (RootCommandField _ _ _ key) = key+useSiteKey (RootEventField _ _ _ key) = key+useSiteKey (RootRegister _ _ key) = key++useSiteSurface :: UseSite -> CoverageSurface+useSiteSurface RootEventField{} = PrivateEventPayload+useSiteSurface RootRegister{} = SnapshotRegister+useSiteSurface RootCommandField{} = error "command fields are not persisted coverage roots"++isEventSite :: UseSite -> Bool+isEventSite RootEventField{} = True+isEventSite RootRegister{} = False+isEventSite RootCommandField{} = False++rootText :: UseSite -> Text+rootText site = renderUsePath (UsePath site [])++declarationMode :: ResolvedMappedDecl -> CoverageMode+declarationMode =+    foldMappedDecl+        MappedDeclAlgebra+            { onStructuralDecl = \_ _ -> StructuralCoverage+            , onOpaqueDecl = const OpaqueCoverage+            }++instance ToJSON CoverageSurface where+    toJSON PrivateEventPayload = toJSON ("private-event-payload" :: Text)+    toJSON SnapshotRegister = toJSON ("snapshot-register" :: Text)++instance ToJSON CoverageMode where+    toJSON StructuralCoverage = toJSON ("structural" :: Text)+    toJSON OpaqueCoverage = toJSON ("opaque" :: Text)++instance ToJSON CoverageRoot where+    toJSON root =+        object+            [ "surface" .= rootSurface root+            , "path" .= rootPath root+            , "mappedType" .= rootMappedType root+            , "mode" .= rootMode root+            , "canonicalType" .= rootCanonicalType root+            , "codecIdentity" .= rootCodecIdentity root+            , "codecVersion" .= rootCodecVersion root+            , "wireFingerprint" .= rootWireFingerprint root+            ]++instance ToJSON StructuralBoundary where+    toJSON boundary =+        object+            [ "root" .= structuralRoot boundary+            , "path" .= structuralPath boundary+            , "mappedType" .= structuralMappedType boundary+            , "canonicalType" .= structuralCanonicalType boundary+            , "wireFingerprint" .= structuralWireFingerprint boundary+            ]++instance ToJSON OpaqueBoundary where+    toJSON boundary =+        object+            [ "root" .= opaqueRoot boundary+            , "path" .= opaquePath boundary+            , "mappedType" .= opaqueMappedType boundary+            , "codecIdentity" .= opaqueCodecIdentity boundary+            , "codecVersion" .= opaqueCodecVersion boundary+            ]++instance ToJSON JsonBoundary where+    toJSON boundary = object ["root" .= jsonRoot boundary, "path" .= jsonPath boundary]++instance ToJSON SnapshotBoundary where+    toJSON boundary =+        object+            [ "root" .= snapshotRoot boundary+            , "aggregate" .= snapshotAggregate boundary+            , "register" .= snapshotRegister boundary+            , "mappedType" .= snapshotMappedType boundary+            , "mode" .= snapshotMode boundary+            , "snapshotEncoding" .= snapshotEncoding boundary+            , "invalidation" .= snapshotInvalidation boundary+            , "wireFingerprint" .= snapshotWireFingerprint boundary+            , "snapshotEnabled" .= snapshotEnabled boundary+            ]++instance ToJSON UnsupportedSurface where+    toJSON surface =+        object+            [ "surface" .= unsupportedSurface surface+            , "support" .= unsupportedSupport surface+            , "reason" .= unsupportedReason surface+            ]++instance ToJSON CoverageCounts where+    toJSON counts =+        object+            [ "totalRoots" .= totalRoots counts+            , "structuralRoots" .= structuralRoots counts+            , "opaqueRoots" .= opaqueRoots counts+            , "jsonBoundaries" .= jsonBoundaries counts+            ]++instance ToJSON CoverageSummary where+    toJSON summary =+        object+            [ "privateEventPayloads" .= privateEventPayloads summary+            , "snapshotRegisters" .= snapshotRegisters summary+            ]++instance ToJSON CoverageFinding where+    toJSON finding =+        object+            [ "severity" .= severityValue (findingSeverity finding)+            , "code" .= show (findingCode finding)+            , "roots" .= findingRoots finding+            , "message" .= findingMessage finding+            ]+      where+        severityValue Error = "error" :: Text+        severityValue Warning = "advisory"++instance ToJSON CoveragePrevious where+    toJSON previous =+        object+            [ "reference" .= previousReference previous+            , "summary" .= previousSummary previous+            , "opaqueBoundaries" .= previousOpaqueBoundaries previous+            ]++instance ToJSON CoverageDelta where+    toJSON delta =+        object+            [ "privateEventRootDelta" .= privateEventRootDelta delta+            , "snapshotRegisterRootDelta" .= snapshotRegisterRootDelta delta+            , "opaqueBoundaryDelta" .= opaqueBoundaryDelta delta+            , "addedOpaqueBoundaries" .= addedOpaqueBoundaries delta+            , "removedOpaqueBoundaries" .= removedOpaqueBoundaries delta+            ]++instance ToJSON CoverageReport where+    toJSON report =+        object+            [ "schema" .= ("keiro-dsl/coverage-report/1" :: Text)+            , "spec" .= coverageSpec report+            , "roots" .= coverageRoots report+            , "structuralBoundaries" .= coverageStructuralBoundaries report+            , "opaqueBoundaries" .= coverageOpaqueBoundaries report+            , "jsonBoundaries" .= coverageJsonBoundaries report+            , "snapshotBoundaries" .= coverageSnapshotBoundaries report+            , "unsupportedSurfaces" .= coverageUnsupportedSurfaces report+            , "summary" .= coverageSummary report+            , "findings" .= coverageFindings report+            , "previous" .= coveragePrevious report+            , "delta" .= coverageDelta report+            ]

@@ -15,6 +15,27 @@ module Keiro.Dsl.Diff (     Change (..),     ChangeKind (..),+    Label (..),+    CompatibilitySurface (..),+    SurfaceVerdict (..),+    RolloutConstraint (..),+    CompatibilityVector (..),+    ChangeContext,+    privateEventContext,+    privateEventAdditionContext,+    snapshotContext,+    queueContext,+    publicContractContext,+    persistedIdentityContext,+    consumerBuildContext,+    changeContextRoot,+    changeContextPaths,+    classifyCompatibility,+    verdictFor,+    defaultGate,+    gateWith,+    deriveLabel,+    gatedBreaking,     isBreaking,     isAdvisory,     diffSpecs,@@ -31,10 +52,22 @@  import Data.List (find, (\\)) import Data.Maybe (isJust, isNothing, mapMaybe)+import Data.Set (Set)+import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface) import Keiro.Dsl.Grammar+import Keiro.Dsl.MappedDiff (MappedFinding (..), diffMapped, renderMappedSubject)+import Keiro.Dsl.PrettyPrint (+    renderHandleSurface,+    renderResolveSurface,+    renderRouterDispatchSurface,+    renderTimerPayloadSurface,+    renderTransition,+ ) import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)+import Keiro.Dsl.TypeGraph (UsePath (..), UseSite (..)) import Keiro.Dsl.Validate (DiagnosticCode (..))  -- | A classified spec change.@@ -44,15 +77,419 @@     | Breaking ChangeKind     deriving stock (Eq, Show) +-- | The stable headline classification retained by the text interface.+data Label = LabelAdditive | LabelAdvisory | LabelBreaking+    deriving stock (Eq, Show)++-- | Independently gateable compatibility questions for one finding.+data CompatibilitySurface+    = PrivateHistoryRead+    | OldBinaryReadNewEvents+    | SnapshotHydration+    | PublicConsumer+    | PersistedIdentity+    | ConsumerBuild+    deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | A verdict on one surface.  Constructor order is deliberately not policy.+data SurfaceVerdict = VCompatible | VAdvisory | VBreaking | VNotApplicable+    deriving stock (Eq, Show)++-- | Deployment ordering that remains after byte compatibility is classified.+data RolloutConstraint+    = RolloutStopTheWorld+    | RolloutWorkersFirst+    | RolloutDrainRequired+    | RolloutProducerLast+    deriving stock (Eq, Ord, Show)++-- | The explicit, compile-forcing compatibility result for one finding.+data CompatibilityVector = CompatibilityVector+    { cvPrivateHistoryRead :: !SurfaceVerdict+    , cvOldBinaryReadNewEvents :: !SurfaceVerdict+    , cvSnapshotHydration :: !SurfaceVerdict+    , cvPublicConsumer :: !SurfaceVerdict+    , cvPersistedIdentity :: !SurfaceVerdict+    , cvConsumerBuild :: !SurfaceVerdict+    , cvRollout :: !(Set RolloutConstraint)+    }+    deriving stock (Eq, Show)++data ContextKind+    = ContextGeneral+    | ContextPrivateEvent+    | ContextPrivateEventAddition+    | ContextSnapshot+    | ContextQueue+    | ContextPublicContract+    | ContextPersistedIdentity+    | ContextConsumerBuild+    deriving stock (Eq, Show)++{- | Facts that select a compatibility row.  The constructor stays private so+callers cannot manufacture contradictory ownership and surface claims.+-}+data ChangeContext = ChangeContext+    { changeContextRoot :: !Name+    , changeContextPaths :: ![Text]+    , contextKind :: !ContextKind+    , contextOriginalLabel :: !Label+    }+    deriving stock (Eq, Show)+ data ChangeKind = ChangeKind     { ckNode :: !Name     , ckFacet :: !Text     , ckSubject :: !Text-    , ckCode :: !(Maybe DiagnosticCode)+    , ckCode :: !DiagnosticCode+    , ckContext :: !ChangeContext+    , ckVector :: !CompatibilityVector+    , ckPaths :: ![Text]     , ckDetail :: !Text     }     deriving stock (Eq, Show) +privateEventContext :: Name -> [Text] -> ChangeContext+privateEventContext root paths = ChangeContext root paths ContextPrivateEvent LabelBreaking++privateEventAdditionContext :: Name -> [Text] -> ChangeContext+privateEventAdditionContext root paths = ChangeContext root paths ContextPrivateEventAddition LabelAdvisory++snapshotContext :: Name -> [Text] -> ChangeContext+snapshotContext root paths = ChangeContext root paths ContextSnapshot LabelAdvisory++queueContext :: Name -> [Text] -> ChangeContext+queueContext root paths = ChangeContext root paths ContextQueue LabelBreaking++publicContractContext :: Name -> [Text] -> ChangeContext+publicContractContext root paths = ChangeContext root paths ContextPublicContract LabelBreaking++persistedIdentityContext :: Name -> [Text] -> ChangeContext+persistedIdentityContext root paths = ChangeContext root paths ContextPersistedIdentity LabelBreaking++consumerBuildContext :: Name -> [Text] -> ChangeContext+consumerBuildContext root paths = ChangeContext root paths ContextConsumerBuild LabelAdvisory++compatibleVector :: CompatibilityVector+compatibleVector =+    CompatibilityVector+        VCompatible+        VCompatible+        VNotApplicable+        VNotApplicable+        VNotApplicable+        VNotApplicable+        Set.empty++privateDecodeBreakingVector :: CompatibilityVector+privateDecodeBreakingVector =+    CompatibilityVector+        VBreaking+        VBreaking+        VAdvisory+        VNotApplicable+        VNotApplicable+        VNotApplicable+        (Set.singleton RolloutStopTheWorld)++persistedIdentityBreakingVector :: CompatibilityVector+persistedIdentityBreakingVector =+    CompatibilityVector+        VNotApplicable+        VNotApplicable+        VNotApplicable+        VNotApplicable+        VBreaking+        VNotApplicable+        Set.empty++publicBreakingVector :: CompatibilityVector+publicBreakingVector =+    CompatibilityVector+        VNotApplicable+        VNotApplicable+        VNotApplicable+        VBreaking+        VNotApplicable+        VNotApplicable+        (Set.singleton RolloutProducerLast)++queueBreakingVector :: CompatibilityVector+queueBreakingVector =+    CompatibilityVector+        VBreaking+        VBreaking+        VNotApplicable+        VNotApplicable+        VAdvisory+        VNotApplicable+        (Set.singleton RolloutWorkersFirst)++advisoryVector :: CompatibilitySurface -> Set RolloutConstraint -> CompatibilityVector+advisoryVector surface rollout =+    compatibleVector+        { cvPrivateHistoryRead = verdict PrivateHistoryRead+        , cvOldBinaryReadNewEvents = verdict OldBinaryReadNewEvents+        , cvSnapshotHydration = verdict SnapshotHydration+        , cvPublicConsumer = verdict PublicConsumer+        , cvPersistedIdentity = verdict PersistedIdentity+        , cvConsumerBuild = verdict ConsumerBuild+        , cvRollout = rollout+        }+  where+    verdict candidate+        | candidate == surface = VAdvisory+        | otherwise = verdictFor candidate compatibleVector++{- | Classify one code at an explicitly owned use site.  Codes emitted by the+differ are grouped by their actual persisted/public surface; the context is+load-bearing for codes such as 'EnumCtorAdded' that vary by use site.+-}+classifyCompatibility :: ChangeContext -> DiagnosticCode -> CompatibilityVector+classifyCompatibility context code+    | code == MappedFieldAddedWithDefault = mappedFieldAdditionVector context+    | code `elem` [MappedArmAdded, MappedEnumValueAdded] = mappedDirectionalAdditionVector context+    | code `elem` mappedWireBreakingCodes = mappedWireBreakingVector context+    | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] = mappedBuildVector+    | code == MappedBindingChanged = mappedBindingVector context+    | code `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] = mappedSnapshotBuildVector context+    | code == MappedDeclAdded = compatibleVector+    | code `elem` privateDecodeCodes = privateDecodeBreakingVector+    | code `elem` identityCodes = persistedIdentityBreakingVector+    | code `elem` publicBreakingCodes = publicBreakingVector+    | code `elem` queueBreakingCodes = queueBreakingVector+    | code `elem` readModelBreakingCodes = persistedIdentityBreakingVector+    | code == ContractSchemaVersionBumped = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast)+    | code == AggFoldSurfaceChanged =+        (advisoryVector PrivateHistoryRead Set.empty){cvSnapshotHydration = VAdvisory}+    | code == AggGuardTightened = advisoryVector PrivateHistoryRead Set.empty+    | code `elem` [RouterDecideSurfaceChanged, ProcessDecideSurfaceChanged] =+        compatibleVector{cvRollout = Set.singleton RolloutDrainRequired}+    | code == ProcessTimerPayloadChanged = advisoryVector PrivateHistoryRead (Set.singleton RolloutProducerLast)+    | code == TimerWindowChanged = advisoryVector PrivateHistoryRead Set.empty+    | code == ProjectionChanged = advisoryVector PersistedIdentity Set.empty+    | code == EmitMappingChanged = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast)+    | code == DecodePostureChanged = advisoryVector PublicConsumer Set.empty+    | code == IntakePersistenceChanged = advisoryVector PrivateHistoryRead Set.empty+    | code `elem` [PublisherPolicyChanged, DispatchRetargeted] = advisoryVector PersistedIdentity Set.empty+    | code `elem` [DeprecatedEventReplayHazard, EventRetirementInProgress] = advisoryVector PrivateHistoryRead Set.empty+    | code == EventUndeprecated = advisoryVector OldBinaryReadNewEvents (Set.singleton RolloutProducerLast)+    | code == EnumCtorAdded = case contextKind context of+        ContextPrivateEventAddition ->+            compatibleVector+                { cvOldBinaryReadNewEvents = VBreaking+                , cvRollout = Set.singleton RolloutProducerLast+                }+        ContextSnapshot -> advisoryVector SnapshotHydration Set.empty+        _ -> compatibleVector+    | code `elem` additiveCodes = compatibleVector+    | otherwise = case contextOriginalLabel context of+        LabelAdditive -> compatibleVector+        LabelAdvisory -> advisoryVector (surfaceForContext context) Set.empty+        LabelBreaking -> breakingVectorForContext context+  where+    privateDecodeCodes =+        [ EvtFieldAddedWithoutBump+        , EvtFieldRemovedSameVersion+        , EvtFieldTypeChanged+        , EvtVersionDecreased+        , EvtVersionMissingUpcaster+        , UpcasterChainGap+        , EvtRemovedNotDeprecated+        , EnumCtorRemoved+        , EnumWireSpellingChanged+        , WireSpecChanged+        , ProcessInputChanged+        , WorkflowShapeChanged+        , WorkflowBodyChanged+        , WorkflowPatchRemoved+        , WorkflowContinueSeedChanged+        ]+    identityCodes =+        [ DerivedIdentityChanged+        , IdPrefixChanged+        , DedupeIdentityChanged+        , QueueIdentityChanged+        , RouterStableNameChanged+        , WorkflowStableNameChanged+        ]+    publicBreakingCodes =+        [ ContractEventRemoved+        , ContractFieldChanged+        , ContractDiscriminatorChanged+        , ContractTopicChanged+        , ContractSchemaVersionDecreased+        ]+    queueBreakingCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged]+    readModelBreakingCodes =+        [ ReadModelVersionDecreased+        , ReadModelShapeChangedWithoutBump+        , ReadModelFeedChanged+        , ReadModelConsistencyWeakened+        ]+    additiveCodes =+        [ DeclarationAdded+        , VersionBumped+        , CompatibilityStrengthened+        , EventRetirementAbandoned+        , ContractEventAdded+        , ContractTopicAdded+        , WorkflowEvolutionGuardAdded+        ]++mappedWireBreakingCodes :: [DiagnosticCode]+mappedWireBreakingCodes =+    [ MappedFieldAddedNoDefault+    , MappedFieldRemoved+    , MappedFieldTypeChanged+    , MappedPresenceChanged+    , MappedNullabilityChanged+    , MappedDefaultRemoved+    , MappedDefaultChanged+    , MappedWireKeyChanged+    , MappedUnionEncodingChanged+    , MappedArmRemoved+    , MappedArmTagChanged+    , MappedEnumValueRemoved+    , MappedEnumSpellingChanged+    , MappedOpaqueCodecChanged+    , MappedModeCrossed+    , MappedDeclRemoved+    ]++mappedFieldAdditionVector :: ChangeContext -> CompatibilityVector+mappedFieldAdditionVector context = case contextKind context of+    ContextPrivateEvent ->+        compatibleVector+            { cvOldBinaryReadNewEvents = oldBinaryVerdict+            , cvRollout = rollout+            }+      where+        rejectsUnknown = contextOriginalLabel context == LabelBreaking+        oldBinaryVerdict = if rejectsUnknown then VBreaking else VCompatible+        rollout = if rejectsUnknown then Set.singleton RolloutProducerLast else Set.empty+    ContextSnapshot -> mappedSnapshotVector+    ContextConsumerBuild -> mappedBuildVector+    _ -> compatibleVector++mappedDirectionalAdditionVector :: ChangeContext -> CompatibilityVector+mappedDirectionalAdditionVector context = case contextKind context of+    ContextPrivateEvent ->+        compatibleVector+            { cvOldBinaryReadNewEvents = VBreaking+            , cvRollout = Set.singleton RolloutProducerLast+            }+    ContextSnapshot -> mappedSnapshotVector+    ContextConsumerBuild -> mappedBuildVector+    _ -> compatibleVector++mappedWireBreakingVector :: ChangeContext -> CompatibilityVector+mappedWireBreakingVector context = case contextKind context of+    ContextPrivateEvent ->+        CompatibilityVector+            VBreaking+            VBreaking+            VNotApplicable+            VNotApplicable+            VNotApplicable+            VNotApplicable+            (Set.singleton RolloutStopTheWorld)+    ContextSnapshot -> mappedSnapshotVector+    ContextConsumerBuild -> mappedBuildVector+    _ -> mappedBuildVector++mappedBuildVector :: CompatibilityVector+mappedBuildVector =+    CompatibilityVector+        VCompatible+        VCompatible+        VNotApplicable+        VNotApplicable+        VNotApplicable+        VAdvisory+        Set.empty++mappedSnapshotVector :: CompatibilityVector+mappedSnapshotVector =+    CompatibilityVector+        VCompatible+        VCompatible+        VAdvisory+        VNotApplicable+        VNotApplicable+        VNotApplicable+        Set.empty++mappedBindingVector :: ChangeContext -> CompatibilityVector+mappedBindingVector context = case contextKind context of+    ContextPrivateEvent ->+        CompatibilityVector+            VAdvisory+            VAdvisory+            VNotApplicable+            VNotApplicable+            VNotApplicable+            VAdvisory+            Set.empty+    ContextSnapshot ->+        mappedSnapshotVector{cvConsumerBuild = VAdvisory}+    _ -> mappedBuildVector++mappedSnapshotBuildVector :: ChangeContext -> CompatibilityVector+mappedSnapshotBuildVector context = case contextKind context of+    ContextSnapshot -> mappedSnapshotVector{cvConsumerBuild = VAdvisory}+    _ -> mappedBuildVector++surfaceForContext :: ChangeContext -> CompatibilitySurface+surfaceForContext context = case contextKind context of+    ContextPrivateEvent -> PrivateHistoryRead+    ContextPrivateEventAddition -> OldBinaryReadNewEvents+    ContextSnapshot -> SnapshotHydration+    ContextQueue -> PrivateHistoryRead+    ContextPublicContract -> PublicConsumer+    ContextPersistedIdentity -> PersistedIdentity+    ContextConsumerBuild -> ConsumerBuild+    ContextGeneral -> PrivateHistoryRead++breakingVectorForContext :: ChangeContext -> CompatibilityVector+breakingVectorForContext context = case contextKind context of+    ContextPublicContract -> publicBreakingVector+    ContextPersistedIdentity -> persistedIdentityBreakingVector+    ContextQueue -> queueBreakingVector+    ContextConsumerBuild -> (advisoryVector ConsumerBuild Set.empty){cvConsumerBuild = VBreaking}+    _ -> privateDecodeBreakingVector++verdictFor :: CompatibilitySurface -> CompatibilityVector -> SurfaceVerdict+verdictFor surface vector = case surface of+    PrivateHistoryRead -> cvPrivateHistoryRead vector+    OldBinaryReadNewEvents -> cvOldBinaryReadNewEvents vector+    SnapshotHydration -> cvSnapshotHydration vector+    PublicConsumer -> cvPublicConsumer vector+    PersistedIdentity -> cvPersistedIdentity vector+    ConsumerBuild -> cvConsumerBuild vector++defaultGate :: Set CompatibilitySurface+defaultGate = Set.delete OldBinaryReadNewEvents (Set.fromList [minBound .. maxBound])++gateWith :: [CompatibilitySurface] -> Set CompatibilitySurface+gateWith surfaces = defaultGate <> Set.fromList surfaces++deriveLabel :: Set CompatibilitySurface -> CompatibilityVector -> Label+deriveLabel gate vector+    | any ((== VBreaking) . (`verdictFor` vector)) (Set.toList gate) = LabelBreaking+    | any (`elem` [VAdvisory, VBreaking]) verdicts || not (Set.null (cvRollout vector)) = LabelAdvisory+    | otherwise = LabelAdditive+  where+    verdicts = [verdictFor surface vector | surface <- [minBound .. maxBound]]++gatedBreaking :: Set CompatibilitySurface -> Change -> Bool+gatedBreaking gate change = deriveLabel gate (ckVector (changeKind change)) == LabelBreaking++changeKind :: Change -> ChangeKind+changeKind (Additive kind) = kind+changeKind (Advisory kind) = kind+changeKind (Breaking kind) = kind+ isBreaking :: Change -> Bool isBreaking (Breaking _) = True isBreaking (Additive _) = False@@ -168,12 +605,75 @@ runFamily env (DiffFamily f) = f env runFamily _ (OutOfDiffScope _) = [] --- Rules are intentionally outside the decode/identity axes: they alter guard--- behaviour but neither interpret stored bytes nor derive persisted keys.--- Shared id and enum declarations become diffed in Milestones 2 and 4.+-- Rules are outside the decode and persisted-identity axes, but referenced+-- rule bodies are compared as part of each aggregate's replay fold surface. sharedDeclarationDiff :: DiffEnv -> [Change]-sharedDeclarationDiff env = enumDiff env ++ idDiff env+sharedDeclarationDiff env = enumDiff env ++ idDiff env ++ mappedDeclarationDiff env +mappedDeclarationDiff :: DiffEnv -> [Change]+mappedDeclarationDiff env = concatMap mappedFindingChanges (diffMapped (deOld env) (deNew env))++mappedFindingChanges :: MappedFinding -> [Change]+mappedFindingChanges finding+    | mfCode finding == MappedDeclAdded = [mappedDeclarationChange LabelAdditive finding]+    | mfCode finding `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] =+        [mappedBuildChange finding]+    | mfCode finding `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] =+        mappedBuildChange finding : map (mappedUseChange finding) registerPaths+    | null paths = [mappedBuildChange finding]+    | otherwise = map (mappedUseChange finding) paths+  where+    paths = mfUsePaths finding+    registerPaths = [path | path@UsePath{upRoot = RootRegister{}} <- paths]++mappedBuildChange :: MappedFinding -> Change+mappedBuildChange finding =+    mappedChange context (mfDeclaration finding) "mapped-build" subject finding+  where+    subject = declarationSubject finding+    renderedPaths = map (\path -> renderMappedSubject path (mfLeaf finding)) (mfUsePaths finding)+    context = (consumerBuildContext (mfDeclaration finding) renderedPaths){contextOriginalLabel = LabelAdvisory}++mappedDeclarationChange :: Label -> MappedFinding -> Change+mappedDeclarationChange label finding =+    mappedChange context (mfDeclaration finding) "mapped-declaration" (declarationSubject finding) finding+  where+    context = ChangeContext (mfDeclaration finding) [] ContextGeneral label++mappedUseChange :: MappedFinding -> UsePath -> Change+mappedUseChange finding path =+    mappedChange context root facet subject finding+  where+    subject = renderMappedSubject path (mfLeaf finding)+    (root, facet, kind) = case upRoot path of+        RootCommandField aggregate _ _ _ -> (aggregate, "mapped-command", ContextConsumerBuild)+        RootEventField aggregate _ _ _ -> (aggregate, "mapped-event", ContextPrivateEvent)+        RootRegister aggregate _ _ -> (aggregate, "mapped-register", ContextSnapshot)+    context = ChangeContext root [subject] kind (mappedContextHint finding kind)++mappedContextHint :: MappedFinding -> ContextKind -> Label+mappedContextHint finding kind = case kind of+    ContextSnapshot -> LabelAdvisory+    ContextConsumerBuild -> LabelAdvisory+    ContextPrivateEvent+        | mfCode finding == MappedFieldAddedWithDefault -> case mfOldUnknownFields finding of+            Just IgnoreUnknown -> LabelAdditive+            _ -> LabelBreaking+        | mfCode finding `elem` [MappedArmAdded, MappedEnumValueAdded] -> LabelAdvisory+        | mfCode finding `elem` [MappedBindingChanged, MappedInitialChanged, MappedCanonicalTypeChanged] -> LabelAdvisory+        | otherwise -> LabelBreaking+    _ -> LabelAdvisory++mappedChange :: ChangeContext -> Name -> Text -> Text -> MappedFinding -> Change+mappedChange context node facet subject finding =+    mkChange label context node facet subject (mfCode finding) (mfDetail finding)+  where+    label = deriveLabel defaultGate (classifyCompatibility context (mfCode finding))++declarationSubject :: MappedFinding -> Text+declarationSubject finding =+    mfDeclaration finding <> if T.null (mfLeaf finding) then "" else " " <> mfLeaf finding+ nodeAggregate :: Node -> Maybe Aggregate nodeAggregate (NAggregate a) = Just a nodeAggregate _ = Nothing@@ -224,13 +724,17 @@ routerDiff :: DiffEnv -> [Change] routerDiff env =     concatMap (uncurry routerPairDiff) (prMatched paired)-        ++ [additive (rtId router) "router" (rtId router) "new router declaration" | router <- prAdded paired]+        ++ [additive (rtId router) "router" (rtId router) DeclarationAdded "new router declaration" | router <- prAdded paired]         ++ [breaking (rtId router) "router-identity" (rtId router) RouterStableNameChanged "router removed while replayable source events may still derive target-keyed dispatch ids from its stable identity" | router <- prRemoved paired]   where     paired = pairByName nodeRouter rtId env  routerPairDiff :: RouterNode -> RouterNode -> [Change]-routerPairDiff oldRouter newRouter = stableName ++ keyDerivation ++ target+routerPairDiff oldRouter newRouter =+    stableName+        ++ keyDerivation+        ++ target+        ++ routerDecideSurfaceDiff oldRouter newRouter   where     nodeName = rtId newRouter     stableName =@@ -247,6 +751,26 @@         | rtTarget oldRouter /= rtTarget newRouter         ] +routerDecideSurfaceDiff :: RouterNode -> RouterNode -> [Change]+routerDecideSurfaceDiff oldRouter newRouter =+    [ advisory+        (rtId newRouter)+        "router-decide"+        (rtId newRouter)+        RouterDecideSurfaceChanged+        "router dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the router's subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too."+    | oldSurface /= newSurface+    ]+  where+    oldSurface =+        ( renderResolveSurface (rtResolve oldRouter)+        , renderRouterDispatchSurface (rtDispatch oldRouter)+        )+    newSurface =+        ( renderResolveSurface (rtResolve newRouter)+        , renderRouterDispatchSurface (rtDispatch newRouter)+        )+ readModelDiff :: DiffEnv -> [Change] readModelDiff env =     concatMap (uncurry (readModelPairDiff env)) (prMatched paired)@@ -270,7 +794,7 @@             [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel))             ]         | rmVersion newReadModel > rmVersion oldReadModel =-            [ additive nodeName "read-model-version" nodeName ("version increased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel) <> "; register and rebuild the new shape before serving it")+            [ additive nodeName "read-model-version" nodeName VersionBumped ("version increased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel) <> "; register and rebuild the new shape before serving it")             ]         | otherwise = []     oldShape = (rmColumns oldReadModel, rmShape oldReadModel)@@ -302,20 +826,20 @@         (Strong, Eventual) ->             [breaking nodeName "read-model-consistency" nodeName ReadModelConsistencyWeakened "default consistency changed Strong -> Eventual; callers lose the cursor-wait guarantee"]         (Eventual, Strong) ->-            [additive nodeName "read-model-consistency" nodeName "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"]+            [additive nodeName "read-model-consistency" nodeName CompatibilityStrengthened "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"]         _ -> []     oldScope = effectiveScope (rmScope oldReadModel)     newScope = effectiveScope (rmScope newReadModel)     scopeChanges         | oldScope == newScope = []         | scopeStrengthened oldScope newScope =-            [additive nodeName "read-model-scope" nodeName ("Strong scope widened " <> renderScope oldScope <> " -> " <> renderScope newScope)]+            [additive nodeName "read-model-scope" nodeName CompatibilityStrengthened ("Strong scope widened " <> renderScope oldScope <> " -> " <> renderScope newScope)]         | otherwise =             [breaking nodeName "read-model-scope" nodeName ReadModelConsistencyWeakened ("Strong scope changed " <> renderScope oldScope <> " -> " <> renderScope newScope <> "; callers no longer wait on the same event surface")]  addedReadModelDiff :: ReadModelNode -> [Change] addedReadModelDiff readModel =-    [additive (rmName readModel) "read-model" (rmName readModel) "new read model"]+    [additive (rmName readModel) "read-model" (rmName readModel) DeclarationAdded "new read model"]  removedReadModelDiff :: ReadModelNode -> [Change] removedReadModelDiff readModel =@@ -342,22 +866,92 @@  aggregateDiff :: DiffEnv -> [Change] aggregateDiff env =-    concatMap (uncurry aggregatePairDiff) (prMatched paired)+    concatMap+        (\(oldAggregate, newAggregate) -> aggregatePairDiff (deOld env) (deNew env) oldAggregate newAggregate)+        (prMatched paired)         ++ concatMap addedAggregateDiff (prAdded paired)         ++ concatMap removedAggregateDiff (prRemoved paired)   where     paired = pairByName nodeAggregate aggName env -aggregatePairDiff :: Aggregate -> Aggregate -> [Change]-aggregatePairDiff oldAgg newAgg =+aggregatePairDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change]+aggregatePairDiff oldSpec newSpec oldAgg newAgg =     concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg)         ++ removedEvents oldAgg newAgg         ++ wireDiff oldAgg newAgg         ++ projectionDiff oldAgg newAgg+        ++ guardTighteningDiff oldAgg newAgg+        ++ transitionSurfaceDiff oldSpec newSpec oldAgg newAgg +{- | Report replay-fold evolution. Regenerated scaffold code carries the new+fingerprint and invalidates old snapshots, so this remains advisory.+-}+transitionSurfaceDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change]+transitionSurfaceDiff oldSpec newSpec oldAgg newAgg+    | aggregateFoldSurface oldSpec oldAgg == aggregateFoldSurface newSpec newAgg = []+    | otherwise =+        [ advisory+            (aggName newAgg)+            "transitions"+            (aggName newAgg)+            AggFoldSurfaceChanged+            "aggregate fold surface changed: replay now interprets the existing log under the new fold. Old snapshots are invalidated automatically once the regenerated fold fingerprint deploys; if the change is fold-neutral confirm it, otherwise re-scaffold and redeploy, and bump `state-codec version=` for any accompanying Holes-only change."+        ]++{- | Plan 143: guard changes are replay-relevant. Hydration re-inverts each+stored event and re-checks the edge guard, so a stored event legally appended+under the old guard may no longer satisfy the new one — the next command on+any stream containing such an event fails hydration with no inverting edge.+The remedy is mechanical, so the tool computes it: the removed region is+@old-guard ∧ ¬new-guard@ ('complementExpr' eliminates the negation inside the+existing grammar), and the advisory prints a paste-ready replay-only twin+carrying that region with the OLD transition's writes\/emits\/goto. Whether+history should stay replayable (paste the twin) or be truncated instead is a+business decision, so the twin is never auto-applied.++Detection is conservative: any guard change on a paired live (source,+command) transition where the new spec declares a guard and does not already+contain a replay-only twin for the pair. A pure loosening also matches; the+advisory says how to confirm no stored data is affected (the replay audit,+docs/plans/142) rather than guessing.+-}+guardTighteningDiff :: Aggregate -> Aggregate -> [Change]+guardTighteningDiff oldAgg newAgg =+    [ advisory (aggName newAgg) "transition" subject AggGuardTightened detail+    | newT <- aggTransitions newAgg+    , tMode newT == TmLive+    , Just oldT <-+        [ find+            (\o -> tSource o == tSource newT && tCommand o == tCommand newT && tMode o == TmLive)+            (aggTransitions oldAgg)+        ]+    , tGuard newT /= tGuard oldT+    , Just newGuard <- [tGuard newT]+    , not (hasReplayOnlyTwin newT)+    , let subject = tSource newT <> " -- " <> tCommand newT+    , let removedRegion =+            maybe (complementExpr newGuard) (\o -> EAnd o (complementExpr newGuard)) (tGuard oldT)+    , let twin = oldT{tGuard = Just removedRegion, tMode = TmReplayOnly}+    , let detail =+            "guard changed on "+                <> subject+                <> ". Stored events appended under the old guard may no longer invert: "+                <> "the next command on any stream containing one fails hydration with "+                <> "no inverting edge. Either confirm via the replay audit that no stored "+                <> "stream exercises the removed region, or keep history replayable by "+                <> "adding the computed replay-only twin (the removed region with the old "+                <> "transition's writes/emits/goto):\n\n"+                <> renderTransition twin+    ]+  where+    hasReplayOnlyTwin newT =+        any+            (\t -> tMode t == TmReplayOnly && tSource t == tSource newT && tCommand t == tCommand newT)+            (aggTransitions newAgg)+ addedAggregateDiff :: Aggregate -> [Change] addedAggregateDiff newAgg =-    [ additive (aggName newAgg) "event" (evName e) "new event type (new aggregate)"+    [ additive (aggName newAgg) "event" (evName e) DeclarationAdded "new event type (new aggregate)"     | e <- aggEvents newAgg     ] @@ -372,11 +966,30 @@ eventDiff oldAgg newAgg e =     case find ((== evName e) . evName) (aggEvents oldAgg) of         Nothing ->-            [additive (aggName newAgg) "event" (evName e) "new event type"]+            [additive (aggName newAgg) "event" (evName e) DeclarationAdded "new event type"]         Just oldE             | evVersion e > evVersion oldE ->                 if evVersion e == evVersion oldE + 1 && evUpcastFrom e `hasSource` evVersion oldE-                    then [additive (aggName newAgg) "event" (evName e) ("new version v" <> tInt (evVersion e) <> " with upcaster from v" <> tInt (evVersion oldE))]+                    then+                        [additive (aggName newAgg) "event" (evName e) VersionBumped ("new version v" <> tInt (evVersion e) <> " with upcaster from v" <> tInt (evVersion oldE))]+                            ++ [ breaking+                                    (aggName newAgg)+                                    "event"+                                    (evName e)+                                    UpcasterChainGap+                                    ( "bumping v"+                                        <> tInt (evVersion oldE)+                                        <> " to v"+                                        <> tInt (evVersion e)+                                        <> " replaced the 'upcast from v"+                                        <> tInt vanishedSource+                                        <> "' rung; stored v"+                                        <> tInt vanishedSource+                                        <> " payloads can no longer decode"+                                    )+                               | Just (vanishedSource, _) <- [evUpcastFrom oldE]+                               , not (aggregateHasUpcasterSource newAgg vanishedSource)+                               ]                     else                         [ breaking                             (aggName newAgg)@@ -397,11 +1010,12 @@                 sameVersionEventDiff oldAgg newAgg oldE e  {- | Events present in the old aggregate but absent in the new one. Removing a-tag entirely is breaking; keeping it as a deprecated event is safe.+tag entirely is breaking; deprecation preserves decoding but needs a retained+replay-only emitter to preserve replay. -} removedEvents :: Aggregate -> Aggregate -> [Change] removedEvents oldAgg newAgg =-    [ breaking (aggName newAgg) "event" (evName oldE) EvtRemovedNotDeprecated "event removed entirely; keep it as a 'deprecated event' so old payloads still decode"+    [ breaking (aggName newAgg) "event" (evName oldE) EvtRemovedNotDeprecated "event removed entirely; its stored payloads can neither decode nor replay. Deprecating instead restores decode-ability only — replay still fails on live streams unless an equivalent replay-only emitting transition is retained; truncate or terminalize affected streams before deleting it"     | oldE <- aggEvents oldAgg     , isNothing (find ((== evName oldE) . evName) (aggEvents newAgg))     ]@@ -410,6 +1024,16 @@ hasSource (Just (m, _)) n = m == n hasSource Nothing _ = False +aggregateHasUpcasterSource :: Aggregate -> Int -> Bool+aggregateHasUpcasterSource aggregate source =+    any ((== Just source) . fmap fst . evUpcastFrom) (aggEvents aggregate)++hasReplayOnlyEmitter :: Aggregate -> Name -> Bool+hasReplayOnlyEmitter aggregate eventName =+    any+        (\transition -> tMode transition == TmReplayOnly && eventName `elem` tEmits transition)+        (aggTransitions aggregate)+ eventFieldSigs :: Aggregate -> Event -> [(Name, Maybe Name)] eventFieldSigs agg e = case evBody e of     EventFields fs -> map fieldSig fs@@ -424,6 +1048,7 @@         ++ removedChanges         ++ typeChanges         ++ deprecationChanges+        ++ retirementChanges   where     oldFields = eventFieldSigs oldAgg oldE     newFields = eventFieldSigs newAgg newE@@ -456,10 +1081,33 @@         ]     deprecationChanges         | not (evDeprecated oldE) && evDeprecated newE =-            [additive (aggName newAgg) "event" (evName newE) "event deprecated (still decodable)"]-        | evDeprecated oldE && not (evDeprecated newE) =+            [ if hasReplayOnlyEmitter newAgg (evName newE)+                then+                    advisory+                        (aggName newAgg)+                        "event"+                        (evName newE)+                        EventRetirementInProgress+                        "event deprecated and removed from the live write path, while an equivalent replay-only transition preserves hydration. Retain that transition until every affected stream is terminal, truncated, or passes the replay audit"+                else+                    advisory+                        (aggName newAgg)+                        "event"+                        (evName newE)+                        DeprecatedEventReplayHazard+                        ( "event deprecated: old payloads remain decodable but are no longer replayable — hydration of live streams containing them fails at the first command (HydrationNoInvertingEdge). Add an equivalent replay-only emitting transition or confirm every affected stream is terminal or truncated before deploying"+                            <> if evRetiring oldE then "" else "; consider a 'retiring event' stage first"+                        )+            ]+        | evDeprecated oldE && not (evDeprecated newE) && not (evRetiring newE) =             [advisory (aggName newAgg) "event" (evName newE) EventUndeprecated "event returned to the write surface; old payloads remain decodable but new writes resume"]         | otherwise = []+    retirementChanges+        | not (evRetiring oldE) && evRetiring newE =+            [advisory (aggName newAgg) "event" (evName newE) EventRetirementInProgress "retirement started; keep the live emitting transition until affected streams are terminal or truncated, then cut over to deprecated plus an equivalent replay-only emitting transition"]+        | evRetiring oldE && not (evRetiring newE) && not (evDeprecated newE) =+            [additive (aggName newAgg) "event" (evName newE) EventRetirementAbandoned "event retirement abandoned; ordinary live writes continue"]+        | otherwise = []  renderFieldType :: Maybe Name -> Text renderFieldType Nothing = "(declared)"@@ -516,7 +1164,7 @@     ]  addedIdDiff :: IdDecl -> [Change]-addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) "new id declaration"]+addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) DeclarationAdded "new id declaration"]  removedIdDiff :: IdDecl -> [Change] removedIdDiff declaration = [breaking (idName declaration) "id-prefix" (idName declaration) IdPrefixChanged "id declaration removed; persisted ids still use its prefix"]@@ -540,15 +1188,46 @@            , Just newWire <- [lookup ctor (enumCtors newEnum)]            , oldWire /= newWire            ]-        ++ [ additive (enumName newEnum) "enum-constructor" ctor ("new constructor with wire spelling '" <> wire <> "'")-           | (ctor, wire) <- enumCtors newEnum-           , isNothing (lookup ctor (enumCtors oldEnum))-           ]+        ++ concat+            [ enumAdditionDiff oldSpec newEnum ctor wire+            | (ctor, wire) <- enumCtors newEnum+            , isNothing (lookup ctor (enumCtors oldEnum))+            ]  addedEnumDiff :: EnumDecl -> [Change] addedEnumDiff enumDecl =-    [additive (enumName enumDecl) "enum-constructor" ctor ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl]+    [additive (enumName enumDecl) "enum-constructor" ctor EnumCtorAdded ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl] +enumAdditionDiff :: Spec -> EnumDecl -> Name -> Text -> [Change]+enumAdditionDiff oldSpec enumDecl ctor wire = case enumUsages oldSpec (enumName enumDecl) of+    [] ->+        [ additive+            (enumName enumDecl)+            "enum-constructor"+            ctor+            EnumCtorAdded+            ("new constructor with wire spelling '" <> wire <> "'")+        ]+    usages -> map finding usages+  where+    finding usage+        | ".reg." `T.isInfixOf` usage =+            advisoryAt+                (snapshotContext (enumName enumDecl) [usage])+                (enumName enumDecl)+                "enum-constructor"+                ctor+                EnumCtorAdded+                ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; invalidate or rebuild snapshots before values using the new arm hydrate")+        | otherwise =+            advisoryAt+                (privateEventAdditionContext (enumName enumDecl) [usage])+                (enumName enumDecl)+                "enum-constructor"+                ctor+                EnumCtorAdded+                ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; deploy consumers before producers emit the new arm")+ removedEnumDiff :: Spec -> EnumDecl -> [Change] removedEnumDiff oldSpec enumDecl =     [ breaking (enumName enumDecl) "enum-constructor" ctor EnumCtorRemoved ("enum removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName enumDecl))@@ -626,13 +1305,13 @@     removedEvents' = prRemoved eventPairs     eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent     addedEventChanges event =-        [additive (ctrName newContract) "contract-event" (ceName event) "new contract event"]+        [additive (ctrName newContract) "contract-event" (ceName event) ContractEventAdded "new contract event"]     removedEventChanges event =         [breaking (ctrName newContract) "contract-event" (ceName event) ContractEventRemoved "contract event removed; existing cross-service payloads no longer have a declared decoder"]  addedContractDiff :: ContractNode -> [Change] addedContractDiff contract =-    [additive (ctrName contract) "contract-event" (ceName event) "new event in a new contract" | event <- ctrEvents contract]+    [additive (ctrName contract) "contract-event" (ceName event) ContractEventAdded "new event in a new contract" | event <- ctrEvents contract]  removedContractDiff :: ContractNode -> [Change] removedContractDiff contract =@@ -659,7 +1338,7 @@            , Just newTopic <- [lookup alias (ctrTopics newContract)]            , oldTopic /= newTopic            ]-        ++ [ additive (ctrName newContract) "contract-topic" alias ("new topic alias for '" <> topic <> "'")+        ++ [ additive (ctrName newContract) "contract-topic" alias ContractTopicAdded ("new topic alias for '" <> topic <> "'")            | (alias, topic) <- ctrTopics newContract            , isNothing (lookup alias (ctrTopics oldContract))            ]@@ -730,17 +1409,17 @@         | wqfWire oldField /= wqfWire newField = [payloadBreaking newField ("wire name changed '" <> wqfWire oldField <> "' -> '" <> wqfWire newField <> "'")]         | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> wqfType oldField <> " -> " <> wqfType newField)]         | not (wqfRequired oldField) && wqfRequired newField = [payloadBreaking newField "field changed from optional to required; queued jobs may omit it"]-        | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) "field changed from required to optional"]+        | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) CompatibilityStrengthened "field changed from required to optional"]         | otherwise = []     addedFieldDiff field         | wqfRequired field = [payloadBreaking field "new required field; queued jobs do not contain it"]-        | otherwise = [additive (wqName newQueue) "payload-field" (wqfName field) "new optional field"]+        | otherwise = [additive (wqName newQueue) "payload-field" (wqfName field) CompatibilityStrengthened "new optional field"]     removedFieldDiff field = [payloadBreaking field "field removed; queued jobs still contain the old payload shape"]     payloadBreaking field detail = breaking (wqName newQueue) "payload-field" (wqfName field) WqPayloadFieldChanged detail  addedWorkqueueDiff :: WorkqueueNode -> [Change] addedWorkqueueDiff queue =-    [additive (wqName queue) "payload-field" (wqfName field) "field belongs to a new workqueue payload" | field <- wqPayload queue]+    [additive (wqName queue) "payload-field" (wqfName field) DeclarationAdded "field belongs to a new workqueue payload" | field <- wqPayload queue]  removedWorkqueueDiff :: WorkqueueNode -> [Change] removedWorkqueueDiff queue =@@ -814,6 +1493,8 @@         ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields)         ++ processIdentityDiff oldProcess newProcess         ++ processTimerWindowDiff oldProcess newProcess+        ++ processDecideSurfaceDiff oldProcess newProcess+        ++ processTimerPayloadDiff oldProcess newProcess   where     -- inName is a generated Haskell type name; the wire shape is inFields.     fields = pairDeclarations fieldName (inFields (procInput oldProcess)) (inFields (procInput newProcess))@@ -824,7 +1505,7 @@  addedProcessDiff :: ProcessNode -> [Change] addedProcessDiff process =-    [additive (procId process) "input-field" (fieldName field) "field belongs to a new process input" | field <- inFields (procInput process)]+    [additive (procId process) "input-field" (fieldName field) DeclarationAdded "field belongs to a new process input" | field <- inFields (procInput process)]  removedProcessDiff :: ProcessNode -> [Change] removedProcessDiff process =@@ -868,6 +1549,30 @@     | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess)     ] +processDecideSurfaceDiff :: ProcessNode -> ProcessNode -> [Change]+processDecideSurfaceDiff oldProcess newProcess =+    [ advisory+        (procId newProcess)+        "process-decide"+        (procId newProcess)+        ProcessDecideSurfaceChanged+        "process dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the process subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too."+    | renderHandleSurface (procHandle oldProcess)+        /= renderHandleSurface (procHandle newProcess)+    ]++processTimerPayloadDiff :: ProcessNode -> ProcessNode -> [Change]+processTimerPayloadDiff oldProcess newProcess =+    [ advisory+        (procId newProcess)+        "timer-payload"+        (tmName (procTimer newProcess))+        ProcessTimerPayloadChanged+        "timer payload shape changed: rows scheduled before the deploy carry the old shape, unversioned, and fire under new code — the fire decoder must accept every historically scheduled shape or the timer dead-letters after maxAttempts. Hole-only timer-decoder changes are not visible to diff; the same drain rule applies to those too."+    | renderTimerPayloadSurface (procTimer oldProcess)+        /= renderTimerPayloadSurface (procTimer newProcess)+    ]+ renderFireAt :: FireAtExpr -> Text renderFireAt expression = "input." <> faField expression <> " + " <> faWindow expression @@ -901,7 +1606,7 @@     workflowShape field detail = breaking (wfId newWorkflow) "workflow-input" (fieldName field) WorkflowShapeChanged detail  addedWorkflowDiff :: WorkflowNode -> [Change]-addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) "new workflow"]+addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) DeclarationAdded "new workflow"]  removedWorkflowDiff :: WorkflowNode -> [Change] removedWorkflowDiff workflow = [breaking (wfId workflow) "workflow" (wfId workflow) WorkflowShapeChanged "workflow removed while in-flight journals and outcomes may still require its decoder"]@@ -965,7 +1670,7 @@ renderInkPersist InkPersistDedupeOnly = "dedupe-only"  addedIntakeDiff :: IntakeNode -> [Change]-addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) "new intake"]+addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) DeclarationAdded "new intake"]  removedIntakeDiff :: IntakeNode -> [Change] removedIntakeDiff intake = [breaking (inkName intake) "dedupe-identity" (inkName intake) DedupeIdentityChanged "intake removed while persisted dedupe records and redeliveries may remain"]@@ -1009,7 +1714,7 @@ emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit)  addedEmitDiff :: EmitNode -> [Change]-addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) "new emit mapping"]+addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) DeclarationAdded "new emit mapping"]  removedEmitDiff :: EmitNode -> [Change] removedEmitDiff emit = [breaking (emName emit) "derived-identity" (emName emit) DerivedIdentityChanged "emit removed while persisted outbox identities may still retry"]@@ -1043,7 +1748,7 @@            ]  addedPublisherDiff :: PublisherNode -> [Change]-addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) "new publisher"]+addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) DeclarationAdded "new publisher"]  removedPublisherDiff :: PublisherNode -> [Change] removedPublisherDiff publisher = [breaking (pubName publisher) "derived-identity" (pubName publisher) DerivedIdentityChanged "publisher removed while persisted outbox rows may still require its stable identity"]@@ -1088,7 +1793,7 @@ dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch)  addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]-addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) "new pgmq dispatch"]+addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) DeclarationAdded "new pgmq dispatch"]  removedPgmqDispatchDiff :: PgmqDispatchNode -> [Change] removedPgmqDispatchDiff dispatch = [breaking (pdName dispatch) "dedupe-identity" (pdName dispatch) DedupeIdentityChanged "dispatch removed while persisted queue and read-model dedupe records may remain"]@@ -1106,7 +1811,7 @@         ]     | safeAdditions =         map addedPatch newPatchIds-            ++ [ additive nodeName "workflow-continue-as-new" seedType "terminal continueAsNew is additive; old generations carry no rotation marker"+            ++ [ additive nodeName "workflow-continue-as-new" seedType WorkflowEvolutionGuardAdded "terminal continueAsNew is additive; old generations carry no rotation marker"                | Just seedType <- [appendedSeed]                ]     | otherwise =@@ -1144,7 +1849,7 @@     removedPatch patchId =         breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch"     addedPatch patchId =-        additive nodeName "workflow-patch" patchId "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"+        additive nodeName "workflow-patch" patchId WorkflowEvolutionGuardAdded "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"  normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem] normaliseWorkflowBody = map go@@ -1179,14 +1884,106 @@     WfContinueAsNew{} : rest -> reverse rest     _ -> items -additive :: Name -> Text -> Text -> Text -> Change-additive n facet subj detail = Additive (ChangeKind n facet subj Nothing detail)+additive :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change+additive n facet subj code detail =+    mkChange LabelAdditive (contextFor LabelAdditive n facet subj code) n facet subj code detail  breaking :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change-breaking n facet subj c detail = Breaking (ChangeKind n facet subj (Just c) detail)+breaking n facet subj code detail =+    mkChange LabelBreaking (contextFor LabelBreaking n facet subj code) n facet subj code detail  advisory :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change-advisory n facet subj c detail = Advisory (ChangeKind n facet subj (Just c) detail)+advisory n facet subj code detail =+    mkChange LabelAdvisory (contextFor LabelAdvisory n facet subj code) n facet subj code detail++advisoryAt :: ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change+advisoryAt context n facet subj code detail =+    mkChange LabelAdvisory context n facet subj code detail++mkChange :: Label -> ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change+mkChange label context n facet subj code detail =+    wrap+        ChangeKind+            { ckNode = n+            , ckFacet = facet+            , ckSubject = subj+            , ckCode = code+            , ckContext = context+            , ckVector = classifyCompatibility context code+            , ckPaths = changeContextPaths context+            , ckDetail = detail+            }+  where+    wrap = case label of+        LabelAdditive -> Additive+        LabelAdvisory -> Advisory+        LabelBreaking -> Breaking++contextFor :: Label -> Name -> Text -> Text -> DiagnosticCode -> ChangeContext+contextFor label root facet subject code =+    setLabel $ case () of+        _+            | code `elem` publicCodes -> publicContractContext root paths+            | code `elem` queueCodes -> queueContext root paths+            | code `elem` identityCodes -> persistedIdentityContext root paths+            | code == AggFoldSurfaceChanged -> snapshotContext root paths+            | code == EnumCtorAdded -> ChangeContext root paths ContextGeneral label+            | code `elem` privateCodes -> privateEventContext root paths+            | otherwise -> ChangeContext root paths ContextGeneral label+  where+    paths = [pathFor root facet subject]+    setLabel context = context{contextOriginalLabel = label}+    publicCodes =+        [ ContractEventRemoved+        , ContractFieldChanged+        , ContractDiscriminatorChanged+        , ContractTopicChanged+        , ContractSchemaVersionDecreased+        , ContractSchemaVersionBumped+        , ContractEventAdded+        , ContractTopicAdded+        ]+    queueCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged, QueueIdentityChanged]+    identityCodes =+        [ DerivedIdentityChanged+        , IdPrefixChanged+        , DedupeIdentityChanged+        , RouterStableNameChanged+        , WorkflowStableNameChanged+        , ReadModelVersionDecreased+        , ReadModelShapeChangedWithoutBump+        , ReadModelFeedChanged+        , ReadModelConsistencyWeakened+        ]+    privateCodes =+        [ EvtFieldAddedWithoutBump+        , EvtFieldRemovedSameVersion+        , EvtFieldTypeChanged+        , EvtVersionDecreased+        , EvtVersionMissingUpcaster+        , UpcasterChainGap+        , EvtRemovedNotDeprecated+        , EnumCtorRemoved+        , EnumWireSpellingChanged+        , WireSpecChanged+        , ProcessInputChanged+        , WorkflowShapeChanged+        , WorkflowBodyChanged+        , WorkflowPatchRemoved+        , WorkflowContinueSeedChanged+        , AggGuardTightened+        , DeprecatedEventReplayHazard+        , EventRetirementInProgress+        , EventUndeprecated+        , ProcessTimerPayloadChanged+        ]++pathFor :: Name -> Text -> Text -> Text+pathFor root facet subject+    | facet `elem` ["event", "event-field"] = root <> ".event." <> subject+    | facet `elem` ["contract-event", "contract-field"] = root <> ".event." <> subject+    | root == subject = root <> "." <> facet+    | otherwise = root <> "." <> facet <> "." <> subject  commas :: [Text] -> Text commas = T.intercalate ", "

@@ -0,0 +1,331 @@+{- | Pure rendering and JSON encoding for compatibility-vector diff reports.++The JSON schema identifier is @keiro-dsl/diff-report/1@.  Consumers must+ignore unknown object keys.  Vector keys and entries in the @paths@ array are+append-only so later nested type-expression work can refine findings without+invalidating version-1 readers.+-}+module Keiro.Dsl.DiffReport (+    Remedy (..),+    DiffReport,+    diffReport,+    remediationFor,+    renderRemedy,+    renderFinding,+    renderVectorLine,+    renderExplainBlock,+    surfaceName,+    parseSurfaceName,+    verdictName,+    rolloutName,+) where++import Data.Aeson (ToJSON (..), Value, object, (.=))+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Diff+import Keiro.Dsl.Validate (DiagnosticCode (..))++data Remedy+    = RemedyVersionBump+    | RemedyUpcaster+    | RemedyDeploymentOrder RolloutConstraint+    | RemedyContractRevision+    | RemedyReplayOnlyEdge+    | RemedyStateCodecBump+    | RemedyRecompileConsumers+    | RemedyRunConformance+    | RemedyDoNotDeploy Text+    deriving stock (Eq, Show)++data DiffReport = DiffReport+    { reportGate :: !(Set CompatibilitySurface)+    , reportFindings :: ![Change]+    }+    deriving stock (Eq, Show)++diffReport :: Set CompatibilitySurface -> [Change] -> DiffReport+diffReport = DiffReport++instance ToJSON DiffReport where+    toJSON report =+        object+            [ "schema" .= ("keiro-dsl/diff-report/1" :: Text)+            , "gate" .= map surfaceName (Set.toAscList (reportGate report))+            , "breaking" .= any (gatedBreaking (reportGate report)) (reportFindings report)+            , "findings" .= map (findingValue (reportGate report)) (reportFindings report)+            ]++findingValue :: Set CompatibilitySurface -> Change -> Value+findingValue gate change =+    object+        [ "label" .= labelName (deriveLabel gate (ckVector kind))+        , "node" .= ckNode kind+        , "facet" .= ckFacet kind+        , "subject" .= ckSubject kind+        , "code" .= T.pack (show (ckCode kind))+        , "paths" .= ckPaths kind+        , "vector" .= vectorValue (ckVector kind)+        , "detail" .= ckDetail kind+        , "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor (ckContext kind) (ckCode kind)))+        ]+  where+    kind = changeKind change++vectorValue :: CompatibilityVector -> Value+vectorValue vector =+    object+        [ "private-history-read" .= verdictName (cvPrivateHistoryRead vector)+        , "old-binary-read-new-events" .= verdictName (cvOldBinaryReadNewEvents vector)+        , "snapshot-hydration" .= verdictName (cvSnapshotHydration vector)+        , "public-consumer" .= verdictName (cvPublicConsumer vector)+        , "persisted-identity" .= verdictName (cvPersistedIdentity vector)+        , "consumer-build" .= verdictName (cvConsumerBuild vector)+        , "rollout" .= map rolloutName (Set.toAscList (cvRollout vector))+        ]++remediationFor :: ChangeContext -> DiagnosticCode -> NonEmpty Remedy+remediationFor context code+    | code == AggGuardTightened = RemedyReplayOnlyEdge :| [RemedyRunConformance]+    | code == AggFoldSurfaceChanged = RemedyStateCodecBump :| [RemedyRunConformance]+    | code `elem` mappedWireCodes = mappedWireRemedy+    | code `elem` [MappedFieldAddedWithDefault, MappedArmAdded, MappedEnumValueAdded] = mappedAdditionRemedy+    | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged] =+        RemedyRecompileConsumers :| [RemedyRunConformance]+    | code == MappedBindingChanged = mappedConformanceRemedy+    | code == MappedFixturesChanged = RemedyRunConformance :| []+    | code == MappedInitialChanged = mappedSnapshotConformanceRemedy+    | code == MappedCanonicalTypeChanged = mappedCanonicalRemedy+    | code == MappedDeclAdded = RemedyRunConformance :| []+    | code `elem` eventDecodeCodes =+        RemedyVersionBump :| [RemedyUpcaster, RemedyDeploymentOrder RolloutStopTheWorld]+    | code `elem` contractCodes =+        RemedyContractRevision :| [RemedyDeploymentOrder RolloutProducerLast]+    | code `elem` queueCodes =+        RemedyDeploymentOrder RolloutWorkersFirst :| [RemedyRunConformance]+    | code `elem` identityCodes =+        RemedyDoNotDeploy "revert the re-keying change or perform an explicit operational identity migration" :| []+    | code == EnumCtorAdded = case Set.toAscList (cvRollout vector) of+        rollout : _ -> RemedyDeploymentOrder rollout :| [snapshotRemedy]+        [] -> snapshotRemedy :| []+    | cvConsumerBuild vector `elem` [VAdvisory, VBreaking] =+        RemedyRecompileConsumers :| [RemedyRunConformance]+    | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance]+    | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+    | otherwise = RemedyRunConformance :| []+  where+    vector = classifyCompatibility context code+    firstRollout = case Set.toAscList (cvRollout vector) of+        rollout : _ -> Just rollout+        [] -> Nothing+    snapshotRemedy+        | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump+        | otherwise = RemedyRunConformance+    mappedWireRemedy+        | cvPrivateHistoryRead vector == VBreaking =+            RemedyVersionBump :| [RemedyUpcaster, RemedyDeploymentOrder RolloutStopTheWorld]+        | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+        | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance]+    mappedAdditionRemedy+        | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+        | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance]+        | otherwise = RemedyRunConformance :| []+    mappedConformanceRemedy+        | cvSnapshotHydration vector == VAdvisory = RemedyRunConformance :| [RemedyStateCodecBump]+        | otherwise = RemedyRunConformance :| []+    mappedSnapshotConformanceRemedy+        | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+        | otherwise = RemedyRunConformance :| []+    mappedCanonicalRemedy+        | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRecompileConsumers, RemedyRunConformance]+        | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance]+    mappedWireCodes =+        [ MappedFieldAddedNoDefault+        , MappedFieldRemoved+        , MappedFieldTypeChanged+        , MappedPresenceChanged+        , MappedNullabilityChanged+        , MappedDefaultRemoved+        , MappedDefaultChanged+        , MappedWireKeyChanged+        , MappedUnionEncodingChanged+        , MappedArmRemoved+        , MappedArmTagChanged+        , MappedEnumValueRemoved+        , MappedEnumSpellingChanged+        , MappedOpaqueCodecChanged+        , MappedModeCrossed+        , MappedDeclRemoved+        ]+    eventDecodeCodes =+        [ EvtFieldAddedWithoutBump+        , EvtFieldRemovedSameVersion+        , EvtFieldTypeChanged+        , EvtVersionDecreased+        , EvtVersionMissingUpcaster+        , UpcasterChainGap+        , EvtRemovedNotDeprecated+        , EnumCtorRemoved+        , EnumWireSpellingChanged+        , WireSpecChanged+        , ProcessInputChanged+        , WorkflowShapeChanged+        , WorkflowBodyChanged+        , WorkflowPatchRemoved+        , WorkflowContinueSeedChanged+        ]+    contractCodes =+        [ ContractEventRemoved+        , ContractFieldChanged+        , ContractDiscriminatorChanged+        , ContractTopicChanged+        , ContractSchemaVersionDecreased+        , ContractSchemaVersionBumped+        ]+    queueCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged, QueueIdentityChanged]+    identityCodes =+        [ DerivedIdentityChanged+        , IdPrefixChanged+        , DedupeIdentityChanged+        , RouterStableNameChanged+        , WorkflowStableNameChanged+        , ReadModelVersionDecreased+        , ReadModelShapeChangedWithoutBump+        , ReadModelFeedChanged+        , ReadModelConsistencyWeakened+        ]++renderRemedy :: Remedy -> Text+renderRemedy remedy = case remedy of+    RemedyVersionBump -> "bump the owning schema or event version"+    RemedyUpcaster -> "add and retain a contiguous upcaster for every historical version"+    RemedyDeploymentOrder rollout -> "deploy in " <> rolloutName rollout <> " order"+    RemedyContractRevision -> "revise the independently owned public contract"+    RemedyReplayOnlyEdge -> "add the computed replay-only edge described by docs/adr/0002-replay-only-edges-are-the-sanctioned-remedy-for-guard-tightening.md"+    RemedyStateCodecBump -> "invalidate and rebuild snapshots by bumping state-codec version when automatic fingerprinting cannot see the change"+    RemedyRecompileConsumers -> "recompile every affected consumer against the generated interface"+    RemedyRunConformance -> "run the generated conformance and historical fixture suites"+    RemedyDoNotDeploy detail -> detail++renderFinding :: Change -> Text+renderFinding change =+    headline+        <> if vectorIsUniform (ckVector kind)+            then ""+            else "\n" <> renderVectorLine (ckVector kind)+  where+    kind = changeKind change+    headline =+        headlineName change+            <> ": "+            <> ckNode kind+            <> " "+            <> ckFacet kind+            <> " "+            <> ckSubject kind+            <> ": "+            <> ckDetail kind+            <> codeSuffix change kind++renderVectorLine :: CompatibilityVector -> Text+renderVectorLine vector =+    "    vector: "+        <> T.unwords+            ( [ surfaceName surface <> "=" <> verdictName verdict+              | surface <- [minBound .. maxBound]+              , let verdict = verdictFor surface vector+              , verdict /= VNotApplicable+              ]+                <> ["rollout=" <> T.intercalate "," (map rolloutName (Set.toAscList (cvRollout vector))) | not (Set.null (cvRollout vector))]+            )++renderExplainBlock :: Change -> Text+renderExplainBlock change =+    "explain ["+        <> T.pack (show (ckCode kind))+        <> "]\n"+        <> T.unlines ["  path: " <> path | path <- ckPaths kind]+        <> T.unlines (map ("  direction: " <>) directions)+        <> T.unlines ["  remedy: " <> renderRemedy remedy | remedy <- NonEmpty.toList remedies]+  where+    kind = changeKind change+    vector = ckVector kind+    directions =+        [ surfaceName surface <> " is " <> verdictName verdict <> "; " <> directionMeaning surface verdict+        | surface <- [minBound .. maxBound]+        , let verdict = verdictFor surface vector+        , verdict `elem` [VAdvisory, VBreaking]+        ]+    remedies = remediationFor (ckContext kind) (ckCode kind)++surfaceName :: CompatibilitySurface -> Text+surfaceName surface = case surface of+    PrivateHistoryRead -> "private-history-read"+    OldBinaryReadNewEvents -> "old-binary-read-new-events"+    SnapshotHydration -> "snapshot-hydration"+    PublicConsumer -> "public-consumer"+    PersistedIdentity -> "persisted-identity"+    ConsumerBuild -> "consumer-build"++parseSurfaceName :: String -> Either String CompatibilitySurface+parseSurfaceName raw = case lookup (T.pack raw) [(surfaceName surface, surface) | surface <- [minBound .. maxBound]] of+    Just surface -> Right surface+    Nothing ->+        Left+            ( "unknown compatibility surface '"+                <> raw+                <> "'; expected one of: "+                <> T.unpack (T.intercalate ", " (map surfaceName [minBound .. maxBound]))+            )++verdictName :: SurfaceVerdict -> Text+verdictName verdict = case verdict of+    VCompatible -> "compatible"+    VAdvisory -> "advisory"+    VBreaking -> "breaking"+    VNotApplicable -> "n/a"++rolloutName :: RolloutConstraint -> Text+rolloutName rollout = case rollout of+    RolloutStopTheWorld -> "stop-the-world"+    RolloutWorkersFirst -> "workers-first"+    RolloutDrainRequired -> "drain-required"+    RolloutProducerLast -> "producer-last"++labelName :: Label -> Text+labelName label = case label of+    LabelAdditive -> "additive"+    LabelAdvisory -> "warning"+    LabelBreaking -> "breaking"++headlineName :: Change -> Text+headlineName Additive{} = "ADDITIVE"+headlineName Advisory{} = "WARNING"+headlineName Breaking{} = "BREAKING"++codeSuffix :: Change -> ChangeKind -> Text+codeSuffix Additive{} _ = ""+codeSuffix _ kind = " [" <> T.pack (show (ckCode kind)) <> "]"++changeKind :: Change -> ChangeKind+changeKind (Additive kind) = kind+changeKind (Advisory kind) = kind+changeKind (Breaking kind) = kind++vectorIsUniform :: CompatibilityVector -> Bool+vectorIsUniform vector =+    Set.null (cvRollout vector)+        && all (`elem` [VCompatible, VNotApplicable]) [verdictFor surface vector | surface <- [minBound .. maxBound]]++directionMeaning :: CompatibilitySurface -> SurfaceVerdict -> Text+directionMeaning surface verdict = case (surface, verdict) of+    (PrivateHistoryRead, _) -> "the candidate binary may reinterpret or fail to read stored private history"+    (OldBinaryReadNewEvents, _) -> "a still-running old binary may reject events emitted by the candidate"+    (SnapshotHydration, _) -> "persisted snapshot seeds require invalidation or rebuild"+    (PublicConsumer, _) -> "an independently deployed consumer may reject the candidate contract"+    (PersistedIdentity, _) -> "replay or retry may derive a different persisted identity"+    (ConsumerBuild, _) -> "consumer or generated source must be rebuilt"

@@ -0,0 +1,293 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++{- | Consumer-owned Haskell obligations implied by checked structural mapped+declarations. The same values drive create-once skeletons, scaffold-record+diffs, and the @check --explain-bindings@ report.+-}+module Keiro.Dsl.ExplainBindings (+    BindingObligationKind (..),+    BindingObligation (..),+    BindingHole (..),+    bindingObligations,+    bindingHoles,+    renderBindingObligations,+) where++import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))+import Data.List (groupBy, sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar (HaskellSource (..), Name, Spec (..), WireEnum (..))+import Keiro.Dsl.TypeGraph++data BindingObligationKind+    = BindingValue+    | FixtureValue+    | InitialValue+    deriving stock (Eq, Ord, Show)++data BindingObligation = BindingObligation+    { obligationMappedName :: !Name+    , obligationPackage :: !Text+    , obligationModule :: !Text+    , obligationSymbol :: !Text+    , obligationKind :: !BindingObligationKind+    , obligationSignature :: !Text+    , obligationUseSites :: ![Text]+    , obligationBindingVersion :: !(Maybe Text)+    }+    deriving stock (Eq, Ord, Show)++data BindingHole = BindingHole+    { holeMappedName :: !Name+    , holeModule :: !Text+    , holeSymbol :: !Text+    , holeKind :: !BindingObligationKind+    , holePath :: !(Maybe Text)+    , holeSignature :: !Text+    }+    deriving stock (Eq, Ord, Show)++instance ToJSON BindingObligation where+    toJSON obligation =+        object+            [ "schema" .= (1 :: Int)+            , "mappedName" .= obligationMappedName obligation+            , "package" .= obligationPackage obligation+            , "module" .= obligationModule obligation+            , "symbol" .= obligationSymbol obligation+            , "kind" .= renderKind (obligationKind obligation)+            , "signature" .= obligationSignature obligation+            , "useSites" .= obligationUseSites obligation+            , "bindingVersion" .= obligationBindingVersion obligation+            ]++instance FromJSON BindingObligation where+    parseJSON = withObject "keiro-dsl binding obligation" $ \value -> do+        schema <- value .: "schema"+        if schema /= (1 :: Int)+            then fail "unsupported binding obligation schema"+            else do+                kindText <- value .: "kind"+                kindValue <- maybe (fail "unknown binding obligation kind") pure (parseKind kindText)+                BindingObligation+                    <$> value .: "mappedName"+                    <*> value .: "package"+                    <*> value .: "module"+                    <*> value .: "symbol"+                    <*> pure kindValue+                    <*> value .: "signature"+                    <*> value .: "useSites"+                    <*> value .:? "bindingVersion"++instance ToJSON BindingHole where+    toJSON hole =+        object+            [ "schema" .= (1 :: Int)+            , "mappedName" .= holeMappedName hole+            , "module" .= holeModule hole+            , "symbol" .= holeSymbol hole+            , "kind" .= renderKind (holeKind hole)+            , "path" .= holePath hole+            , "signature" .= holeSignature hole+            ]++instance FromJSON BindingHole where+    parseJSON = withObject "keiro-dsl binding hole" $ \value -> do+        schema <- value .: "schema"+        if schema /= (1 :: Int)+            then fail "unsupported binding hole schema"+            else do+                kindText <- value .: "kind"+                kindValue <- maybe (fail "unknown binding hole kind") pure (parseKind kindText)+                BindingHole+                    <$> value .: "mappedName"+                    <*> value .: "module"+                    <*> value .: "symbol"+                    <*> pure kindValue+                    <*> value .:? "path"+                    <*> value .: "signature"++bindingObligations :: Spec -> Either (NonEmpty TypeGraphError) [BindingObligation]+bindingObligations spec = do+    graph <- resolveTypeGraph spec+    pure . sortOn obligationSortKey . concat $+        [ obligationsFor graph declaration+        | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph)+        ]++bindingHoles :: Spec -> Either (NonEmpty TypeGraphError) [BindingHole]+bindingHoles spec = do+    graph <- resolveTypeGraph spec+    obligations <- bindingObligations spec+    pure . sortOn holeSortKey . concat $+        [ holesFor graph declaration shape obligations+        | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)+        ]++holesFor :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [BindingObligation] -> [BindingHole]+holesFor _graph declaration shape obligations = bindingEntries <> auxiliaryEntries+  where+    own = filter ((== sdName declaration) . obligationMappedName) obligations+    binding = onlyKind BindingValue+    bindingEntries = case binding of+        Nothing -> []+        Just obligation -> map (bindingHole obligation) (shapeHolePaths shape)+    auxiliaryEntries =+        [ BindingHole+            { holeMappedName = obligationMappedName obligation+            , holeModule = obligationModule obligation+            , holeSymbol = obligationSymbol obligation+            , holeKind = obligationKind obligation+            , holePath = Nothing+            , holeSignature = obligationSignature obligation+            }+        | obligation <- own+        , obligationKind obligation /= BindingValue+        ]+    onlyKind wanted = case filter ((== wanted) . obligationKind) own of+        entry : _ -> Just entry+        [] -> Nothing+    bindingHole obligation (path, expectedType) =+        BindingHole+            { holeMappedName = obligationMappedName obligation+            , holeModule = obligationModule obligation+            , holeSymbol = obligationSymbol obligation+            , holeKind = BindingValue+            , holePath = Just path+            , holeSignature = obligationSymbol obligation <> "." <> path <> " :: " <> expectedType+            }++shapeHolePaths :: ResolvedMappedShape -> [(Text, Text)]+shapeHolePaths =+    foldMappedShape+        MappedShapeAlgebra+            { onRecord = \_ _ fields -> [(rwfHaskell field, renderExprType (rwfType field)) | field <- fields]+            , onEnum = \entries -> [(weCtor entry, "constructor case") | entry <- entries]+            , onUnion = \_ arms ->+                [ (rwaCtor arm, maybe "constructor case" renderExprType (rwaPayload arm))+                | arm <- arms+                ]+            }++renderExprType :: ResolvedTypeExpr -> Text+renderExprType =+    foldTypeExpr+        TypeExprAlgebra+            { onText = "Text"+            , onInt = "Int"+            , onBool = "Bool"+            , onNatural = "Natural"+            , onTime = "UTCTime"+            , onJson = "Value"+            , onOptional = \value -> "Maybe (" <> value <> ")"+            , onList = \value -> "[" <> value <> "]"+            , onMap = \value -> "Map Text (" <> value <> ")"+            , onRef = unMappedKey+            }++obligationsFor :: TypeGraph -> StructuralDecl -> [BindingObligation]+obligationsFor graph declaration = bindingEntry : fixtureEntry : initialEntries+  where+    source = sdHaskell declaration+    consumerType = hsModule source <> "." <> hsType source+    shapeType = sdName declaration <> "Shape"+    paths = map renderUsePath (usePaths graph (sdName declaration))+    registerPaths =+        [ renderUsePath path+        | path@UsePath{upRoot = RootRegister{}} <- usePaths graph (sdName declaration)+        ]+    bindingEntry =+        obligationFor+            declaration+            (sdBinding declaration)+            BindingValue+            ("StructuralBinding " <> consumerType <> " " <> shapeType)+            paths+            (Just (unBindingVersion (sdBindingVersion declaration)))+    fixtureEntry =+        obligationFor+            declaration+            (sdFixtures declaration)+            FixtureValue+            ("FixtureCases " <> consumerType)+            paths+            Nothing+    initialEntries = case (registerPaths, sdInitial declaration) of+        ([], _) -> []+        (_, Nothing) -> []+        (_, Just initialValue) ->+            [ obligationFor declaration initialValue InitialValue consumerType registerPaths Nothing+            ]++obligationFor :: StructuralDecl -> QualifiedValueName -> BindingObligationKind -> Text -> [Text] -> Maybe Text -> BindingObligation+obligationFor declaration qualified kindValue signature paths version =+    BindingObligation+        { obligationMappedName = sdName declaration+        , obligationPackage = hsPackage (sdHaskell declaration)+        , obligationModule = ownerModule+        , obligationSymbol = symbol+        , obligationKind = kindValue+        , obligationSignature = symbol <> " :: " <> signature+        , obligationUseSites = paths+        , obligationBindingVersion = version+        }+  where+    (ownerModule, symbol) = splitQualified (unQualifiedValueName qualified)++renderBindingObligations :: Text -> [BindingObligation] -> Text+renderBindingObligations context obligations = case obligations of+    [] -> "no binding obligations for context " <> context+    _ ->+        T.unlines $+            ["binding obligations for context " <> context]+                <> concatMap renderGroup grouped+  where+    grouped = groupBy sameOwner (sortOn obligationSortKey obligations)+    sameOwner left right = ownerKey left == ownerKey right+    renderGroup [] = []+    renderGroup entries@(first : _) =+        ("  " <> obligationModule first <> " (package " <> obligationPackage first <> ")")+            : concatMap renderEntry entries+    renderEntry obligation =+        [ "    " <> obligationSignature obligation+        , "      reason: " <> renderKind (obligationKind obligation) <> " — structural mapped type " <> obligationMappedName obligation <> renderPaths (obligationUseSites obligation)+        ]+            <> maybe [] (\version -> ["      provenance: binding-version " <> quoted version]) (obligationBindingVersion obligation)+    renderPaths [] = " (not currently used by an aggregate root)"+    renderPaths paths = " (" <> T.intercalate "; " paths <> ")"+    quoted value = T.pack (show value)++obligationSortKey :: BindingObligation -> (Text, Text, Text, BindingObligationKind, Text)+obligationSortKey obligation =+    ( obligationPackage obligation+    , obligationModule obligation+    , obligationMappedName obligation+    , obligationKind obligation+    , obligationSymbol obligation+    )++ownerKey :: BindingObligation -> (Text, Text)+ownerKey obligation = (obligationPackage obligation, obligationModule obligation)++holeSortKey :: BindingHole -> (Text, Name, BindingObligationKind, Maybe Text, Text)+holeSortKey hole =+    (holeModule hole, holeMappedName hole, holeKind hole, holePath hole, holeSymbol hole)++renderKind :: BindingObligationKind -> Text+renderKind BindingValue = "binding"+renderKind FixtureValue = "fixtures"+renderKind InitialValue = "initial-value"++parseKind :: Text -> Maybe BindingObligationKind+parseKind "binding" = Just BindingValue+parseKind "fixtures" = Just FixtureValue+parseKind "initial-value" = Just InitialValue+parseKind _ = Nothing++splitQualified :: Text -> (Text, Text)+splitQualified value =+    let (prefix, name) = T.breakOnEnd "." value+     in (T.dropEnd 1 prefix, name)

@@ -0,0 +1,167 @@+{- | Canonical identities for the aggregate fold surface used while hydrating+event streams. The fingerprint deliberately excludes payload codecs,+projections, snapshot policy, and source locations: those inputs do not change+how an existing event log becomes aggregate state.+-}+module Keiro.Dsl.FoldFingerprint (+    aggregateFoldFingerprint,+    aggregateFoldSurface,+) where++import Data.List (find)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.PrettyPrint (renderExpr)+import Keiro.Dsl.ReadModelShape (fnv1a64)+import Keiro.Dsl.TypeGraph++-- | The sixteen-hex-digit identity of an aggregate's replay fold.+aggregateFoldFingerprint :: Spec -> Aggregate -> Text+aggregateFoldFingerprint spec = fnv1a64 . aggregateFoldSurface spec++{- | Canonical pre-hash text for an aggregate's replay fold.++Rules are declarations on 'Spec', not children of 'Aggregate', so the complete+spec is required. Only rules reached from transition guards and writes are+included, transitively, in declaration order.+-}+aggregateFoldSurface :: Spec -> Aggregate -> Text+aggregateFoldSurface spec aggregate =+    T.intercalate+        "\n"+        ( map stateSegment (aggStates aggregate)+            ++ map registerSegment (aggRegs aggregate)+            ++ mappedRegisterSegments+            ++ map transitionSegment (aggTransitions aggregate)+            ++ map ruleSegment referencedRules+        )+  where+    referencedRules =+        [ rule+        | rule <- specRules spec+        , ruleName rule `Set.member` referencedRuleNames spec aggregate+        ]+    mappedRegisterSegments = case resolveTypeGraph spec of+        Left _ -> []+        Right graph ->+            [ mappedRegisterSegment graph declaration+            | register <- aggRegs aggregate+            , Just declaration <- [Map.lookup (MappedKey (regType register)) (tgDeclarations graph)]+            ]++mappedRegisterSegment :: TypeGraph -> ResolvedMappedDecl -> Text+mappedRegisterSegment graph (ResolvedStructural declaration _) =+    T.intercalate+        "|"+        [ "mapped-register:" <> sdName declaration+        , "wire=" <> wireFingerprint graph (sdName declaration)+        , "canonical=" <> unCanonicalTypeId (sdCanonical declaration)+        , "binding=" <> unQualifiedValueName (sdBinding declaration)+        , "binding-version=" <> unBindingVersion (sdBindingVersion declaration)+        , "initial=" <> maybe "(missing)" unQualifiedValueName (sdInitial declaration)+        ]+mappedRegisterSegment _ (ResolvedOpaque declaration) =+    T.intercalate+        "|"+        [ "mapped-register:" <> odName declaration+        , "codec=" <> unCodecIdentity (odCodecIdentity declaration)+        , "codec-version=" <> unCodecVersion (odCodecVersion declaration)+        , "initial=" <> maybe "(missing)" unQualifiedValueName (odInitial declaration)+        ]++stateSegment :: StateDecl -> Text+stateSegment state =+    "state:"+        <> stName state+        <> "|terminal="+        <> if stTerminal state then "true" else "false"++registerSegment :: RegDecl -> Text+registerSegment register =+    "reg:"+        <> regName register+        <> ":"+        <> regType register+        <> "="+        <> renderInitial (regInitial register)++renderInitial :: RegInitial -> Text+renderInitial (RegInitBare value) = value+renderInitial (RegInitText value) = "\"" <> escapeText value <> "\""++escapeText :: Text -> Text+escapeText = T.concatMap $ \case+    '"' -> "\\\""+    '\\' -> "\\\\"+    '\n' -> "\\n"+    '\t' -> "\\t"+    '\r' -> "\\r"+    character -> T.singleton character++transitionSegment :: Transition -> Text+transitionSegment transition =+    T.intercalate+        "|"+        [ "transition:" <> renderMode (tMode transition)+        , tSource transition+        , tCommand transition+        , "guard=" <> maybe "" renderExpr (tGuard transition)+        , "writes=" <> T.intercalate ";" (map renderWrite (tWrites transition))+        , "emits=" <> T.intercalate "," (tEmits transition)+        , "goto=" <> tGoto transition+        ]+  where+    renderWrite (registerName, expression) = registerName <> ":=" <> renderExpr expression++renderMode :: TransitionMode -> Text+renderMode TmLive = "live"+renderMode TmReplayOnly = "replay-only"++ruleSegment :: RuleDecl -> Text+ruleSegment rule =+    T.intercalate+        "|"+        [ "rule:" <> ruleName rule+        , ruleDomain rule+        , ruleCodomain rule+        , "cases=" <> T.intercalate ";" (map renderCase (ruleCases rule))+        ]+  where+    renderCase (constructorName, expression) = constructorName <> "=>" <> renderExpr expression++referencedRuleNames :: Spec -> Aggregate -> Set Name+referencedRuleNames spec aggregate = close directNames+  where+    rules = specRules spec+    directNames =+        Set.unions+            [ exprNames expression+            | transition <- aggTransitions aggregate+            , expression <- maybeToList (tGuard transition) ++ map snd (tWrites transition)+            ]+    close names =+        let expanded =+                Set.unions+                    ( names+                        : [ Set.unions (map (exprNames . snd) (ruleCases rule))+                          | name <- Set.toList names+                          , Just rule <- [find ((== name) . ruleName) rules]+                          ]+                    )+         in if expanded == names then names else close expanded++exprNames :: Expr -> Set Name+exprNames = \case+    EOr left right -> exprNames left <> exprNames right+    EAnd left right -> exprNames left <> exprNames right+    ECmp _ left right -> exprNames left <> exprNames right+    EAtom (AName name) -> Set.singleton name+    EAtom (ABool _) -> Set.empty++maybeToList :: Maybe a -> [a]+maybeToList Nothing = []+maybeToList (Just value) = [value]

@@ -0,0 +1,228 @@+{- | Versioned event-payload fixtures captured at spec-diff time.++The current aggregate specification cannot reconstruct an older payload shape,+so golden payloads are synthesized while both the old and new specifications+are available. Existing files are never overwritten: a hand-captured+production payload is always more authoritative than a synthesized sample.+-}+module Keiro.Dsl.Goldens (+    GoldenEvidence (..),+    GoldenPayload (..),+    goldensForDiff,+    emitGoldenPayloads,+    loadGoldenPayloads,+    goldenRelativePath,+) where++import Data.Aeson (Value (..))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Text qualified as AesonText+import Data.List (find)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Text.Lazy qualified as TL+import Keiro.Dsl.Grammar+import Keiro.Dsl.Scaffold (Agg (..), ResolvedCtor (..), defaultContext, resolveAgg)+import Keiro.Dsl.TypeGraph+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)+import System.FilePath (dropTrailingPathSeparator, takeDirectory, takeFileName, (</>))++data GoldenEvidence = SynthesizedWeakStandIn | FileOwnedFixture+    deriving stock (Eq, Show)++data GoldenPayload = GoldenPayload+    { goldenContext :: !Text+    , goldenAggregate :: !Text+    , goldenEvent :: !Text+    , goldenVersion :: !Int+    , goldenJson :: !Text+    , goldenEvidence :: !GoldenEvidence+    }+    deriving stock (Eq, Show)++{- | Synthesize one old-shape payload for each event whose version increases.+The result is deterministic and ordered like the old specification.+-}+goldensForDiff :: Spec -> Spec -> [GoldenPayload]+goldensForDiff oldSpec newSpec =+    [ GoldenPayload+        { goldenContext = specContext oldSpec+        , goldenAggregate = aggName oldAggregate+        , goldenEvent = evName oldEvent+        , goldenVersion = evVersion oldEvent+        , goldenJson = renderGolden oldSpec oldResolved oldResolvedEvent+        , goldenEvidence = SynthesizedWeakStandIn+        }+    | oldAggregate <- aggregates oldSpec+    , Just newAggregate <- [find ((== aggName oldAggregate) . aggName) (aggregates newSpec)]+    , let oldResolved = resolveAgg (defaultContext (specContext oldSpec)) oldSpec oldAggregate+    , oldEvent <- aggEvents oldAggregate+    , Just newEvent <- [find ((== evName oldEvent) . evName) (aggEvents newAggregate)]+    , evVersion newEvent > evVersion oldEvent+    , Just oldResolvedEvent <- [find ((== evName oldEvent) . rcName) (aEvents oldResolved)]+    ]+  where+    aggregates spec = [aggregate | NAggregate aggregate <- specNodes spec]++{- | Write newly synthesized fixtures below+@<root>/<context>/<aggregate>/<event>.v<version>.json@. Existing files are+left untouched and omitted from the returned path list.+-}+emitGoldenPayloads :: FilePath -> Spec -> Spec -> IO [FilePath]+emitGoldenPayloads root oldSpec newSpec =+    fmap concat . traverse writeIfMissing $ goldensForDiff oldSpec newSpec+  where+    writeIfMissing golden = do+        let path = root </> goldenRelativePath golden+        exists <- doesFileExist path+        if exists+            then pure []+            else do+                createDirectoryIfMissing True (takeDirectory path)+                TIO.writeFile path (goldenJson golden)+                pure [path]++{- | Load only the fixtures relevant to declared upcasters in @spec@.+@root@ may name the global golden root or its context child directory.+-}+loadGoldenPayloads :: FilePath -> Spec -> IO [GoldenPayload]+loadGoldenPayloads root spec = do+    contextRoot <- resolveContextRoot root (T.unpack (specContext spec))+    fmap concat . traverse (loadAggregate contextRoot) $ aggregates spec+  where+    aggregates current = [aggregate | NAggregate aggregate <- specNodes current]++    loadAggregate contextRoot aggregate =+        fmap concat . traverse (loadEvent contextRoot aggregate) $ aggEvents aggregate++    loadEvent contextRoot aggregate event = case evUpcastFrom event of+        Nothing -> pure []+        Just (sourceVersion, _) -> do+            let golden =+                    GoldenPayload+                        { goldenContext = specContext spec+                        , goldenAggregate = aggName aggregate+                        , goldenEvent = evName event+                        , goldenVersion = sourceVersion+                        , goldenJson = ""+                        , goldenEvidence = FileOwnedFixture+                        }+                path = contextRoot </> aggregateRelativePath golden+            exists <- doesFileExist path+            if exists+                then do+                    contents <- TIO.readFile path+                    pure [golden{goldenJson = contents}]+                else pure []++goldenRelativePath :: GoldenPayload -> FilePath+goldenRelativePath golden =+    T.unpack (goldenContext golden) </> aggregateRelativePath golden++aggregateRelativePath :: GoldenPayload -> FilePath+aggregateRelativePath golden =+    T.unpack (goldenAggregate golden)+        </> T.unpack (goldenEvent golden)+            <> ".v"+            <> show (goldenVersion golden)+            <> ".json"++resolveContextRoot :: FilePath -> FilePath -> IO FilePath+resolveContextRoot root contextName = do+    let nested = root </> contextName+    nestedExists <- doesDirectoryExist nested+    pure $+        if nestedExists+            then nested+            else+                if takeFileName (dropTrailingPathSeparator root) == contextName+                    then root+                    else nested++renderGolden :: Spec -> Agg -> ResolvedCtor -> Text+renderGolden spec aggregate event =+    TL.toStrict (AesonText.encodeToLazyText (Object (KeyMap.fromList entries))) <> "\n"+  where+    graph = either (const Nothing) Just (resolveTypeGraph spec)+    entries =+        (Key.fromText "kind", String (rcName event))+            : [(Key.fromText fieldName, sampleValue graph spec aggregate fieldType) | (fieldName, fieldType) <- rcFields event]++sampleValue :: Maybe TypeGraph -> Spec -> Agg -> Text -> Value+sampleValue graph spec _aggregate fieldType+    | Just identifier <- find ((== fieldType) . idName) (specIds spec) =+        String (idPrefix identifier <> "_01hzy3v7q2e8kaw2m5x0d41n9c")+    | Just enum <- find ((== fieldType) . enumName) (specEnums spec)+    , (_, wireValue) : _ <- enumCtors enum =+        String wireValue+    | Just resolved <- graph+    , Just declaration <- Map.lookup (MappedKey fieldType) (tgDeclarations resolved) =+        sampleMappedDeclaration resolved declaration+    | fieldType == "Int" = Number 1+    | fieldType == "Bool" = Bool True+    | fieldType `elem` ["Time", "UTCTime"] = String "2026-01-01T00:00:00Z"+    | otherwise = String "sample"++sampleMappedDeclaration :: TypeGraph -> ResolvedMappedDecl -> Value+sampleMappedDeclaration graph =+    foldMappedDecl+        MappedDeclAlgebra+            { onStructuralDecl = \_ -> sampleMappedShape graph+            , onOpaqueDecl = const emptyObject+            }++sampleMappedShape :: TypeGraph -> ResolvedMappedShape -> Value+sampleMappedShape graph =+    foldMappedShape+        MappedShapeAlgebra+            { onRecord = \_ _ fields ->+                Object . KeyMap.fromList $+                    [ (Key.fromText (rwfKey field), sampleMappedExpression graph (rwfType field))+                    | field <- fields+                    , includeField field+                    ]+            , onEnum = \entries -> case entries of+                firstEntry : _ -> String (weTag firstEntry)+                [] -> String "sample"+            , onUnion = \encoding arms -> case arms of+                firstArm : _ ->+                    Object . KeyMap.fromList $+                        [(Key.fromText (ueTagField encoding), String (rwaTag firstArm))]+                            <> [ (Key.fromText (ueContentsField encoding), sampleMappedExpression graph payload)+                               | payload <- maybeToList (rwaPayload firstArm)+                               ]+                [] -> emptyObject+            }+  where+    includeField field = case rwfPresence field of+        PRequired -> True+        POptional -> isNothingValue (rwfOnMissing field)++sampleMappedExpression :: TypeGraph -> ResolvedTypeExpr -> Value+sampleMappedExpression graph =+    foldTypeExpr+        TypeExprAlgebra+            { onText = String "sample"+            , onInt = Number 1+            , onBool = Bool True+            , onNatural = Number 1+            , onTime = String "2026-01-01T00:00:00Z"+            , onJson = emptyObject+            , onOptional = id+            , onList = \value -> Array (pure value)+            , onMap = \value -> Object (KeyMap.singleton (Key.fromText "sample") value)+            , onRef = \key -> maybe emptyObject (sampleMappedDeclaration graph) (Map.lookup key (tgDeclarations graph))+            }++emptyObject :: Value+emptyObject = Object KeyMap.empty++maybeToList :: Maybe a -> [a]+maybeToList = maybe [] pure++isNothingValue :: Maybe a -> Bool+isNothingValue Nothing = True+isNothingValue Just{} = False

@@ -15,6 +15,20 @@     EnumDecl (..),     RuleDecl (..), +    -- * Consumer-owned mapped types (EP-149)+    TypeExpr (..),+    Presence (..),+    UnknownFields (..),+    OnMissing (..),+    WireField (..),+    wireFieldLoc,+    UnionEncoding (..),+    WireEnum (..),+    WireArm (..),+    MappedShape (..),+    HaskellSource (..),+    MappedDecl (..),+     -- * The eight hole-kind types     Derivation (..),     DerivStrategy (..),@@ -28,6 +42,7 @@     Expr (..),     CmpOp (..),     Atom (..),+    complementExpr,      -- * The aggregate node     RegInitial (..),@@ -39,6 +54,7 @@     EventBody (..),     Hole (..),     Transition (..),+    TransitionMode (..),     WireSpec (..),     ProjectionSpec (..),     Consistency (..),@@ -112,6 +128,7 @@     -- * The workflow/operation nodes (EP-6)     WfBodyItem (..),     WorkflowNode (..),+    workflowNodeLoc,     OperationShape (..),     OperationNode (..), @@ -179,6 +196,111 @@     }     deriving stock (Eq, Show, Generic) +-- Consumer-owned mapped types (EP-149). The parser-facing declarations keep+-- required facts optional so `keiro-dsl check` can report stable, located+-- diagnostics for omissions. Keiro.Dsl.TypeGraph turns valid values into a+-- checked representation before downstream consumers inspect them.++data TypeExpr+    = TText+    | TInt+    | TBool+    | TNatural+    | TTime+    | TJson+    | TOptional !TypeExpr+    | TList !TypeExpr+    | TMap !TypeExpr+    | TRef !Name+    deriving stock (Eq, Show, Generic)++data Presence = PRequired | POptional+    deriving stock (Eq, Show, Generic)++data UnknownFields = RejectUnknown | IgnoreUnknown+    deriving stock (Eq, Show, Generic)++data OnMissing+    = OmNull+    | OmText !Text+    | OmInt !Integer+    | OmBool !Bool+    | OmEmptyList+    | OmEmptyMap+    | OmCtor !Name+    deriving stock (Eq, Show, Generic)++data WireField = WireField+    { wfHaskell :: !Name+    , wfKey :: !Text+    , wfType :: !TypeExpr+    , wfPresence :: !Presence+    , wfOnMissing :: !(Maybe OnMissing)+    , wfLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++wireFieldLoc :: WireField -> Loc+wireFieldLoc WireField{wfLoc = loc} = loc++data UnionEncoding = TaggedObject+    { ueTagField :: !Text+    , ueContentsField :: !Text+    , ueUnknownFields :: !UnknownFields+    }+    deriving stock (Eq, Show, Generic)++data WireEnum = WireEnum+    { weCtor :: !Name+    , weTag :: !Text+    , weLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++data WireArm = WireArm+    { waCtor :: !Name+    , waTag :: !Text+    , waPayload :: !(Maybe TypeExpr)+    , waLoc :: !Loc+    }+    deriving stock (Eq, Show, Generic)++data MappedShape+    = ShapeRecord !Name !UnknownFields ![WireField]+    | ShapeEnum ![WireEnum]+    | ShapeUnion !UnionEncoding ![WireArm]+    deriving stock (Eq, Show, Generic)++data HaskellSource = HaskellSource+    { hsPackage :: !Text+    , hsModule :: !Text+    , hsType :: !Name+    }+    deriving stock (Eq, Show, Generic)++data MappedDecl+    = MappedStructural+        { msName :: !Name+        , msHaskell :: !(Maybe HaskellSource)+        , msBinding :: !(Maybe Text)+        , msBindingVersion :: !(Maybe Text)+        , msCanonical :: !(Maybe Text)+        , msFixtures :: !(Maybe Text)+        , msInitial :: !(Maybe Text)+        , msShape :: !MappedShape+        , msLoc :: !Loc+        }+    | MappedOpaque+        { moName :: !Name+        , moHaskell :: !(Maybe HaskellSource)+        , moCodecId :: !(Maybe Text)+        , moCodecVersion :: !(Maybe Text)+        , moFixtures :: !(Maybe Text)+        , moInitial :: !(Maybe Text)+        , moLoc :: !Loc+        }+    deriving stock (Eq, Show, Generic)+ -- The eight hole-kind types. EP-1 only exercises hole-kinds 1–3 against the -- aggregate vertical; the rest exist so EP-3…EP-6 reuse the same types. @@ -257,6 +379,33 @@     | ABool !Bool     deriving stock (Eq, Show, Generic) +{- | The logical complement of a guard, expressed inside the existing grammar —+'Expr' has no negation constructor, but negation is eliminable: De Morgan over+'EOr'\/'EAnd', comparison-operator flipping, boolean-literal flip, and+@x == false@ for a bare name atom (guards are boolean-valued, so a bare name+in guard position is a boolean read). Used by @diff@ to compute the+replay-only twin of a tightened guard (@old ∧ ¬new@, plan 143): the printed+complement re-parses as a valid guard today.++Caveat: comparison flipping is classical — @¬(a < b) = a >= b@ — which is+correct over the DSL's total ordered domains.+-}+complementExpr :: Expr -> Expr+complementExpr = \case+    EOr l r -> EAnd (complementExpr l) (complementExpr r)+    EAnd l r -> EOr (complementExpr l) (complementExpr r)+    ECmp op l r -> ECmp (complementCmp op) l r+    EAtom (ABool b) -> EAtom (ABool (not b))+    e@(EAtom (AName _)) -> ECmp OpEq e (EAtom (ABool False))+  where+    complementCmp = \case+        OpEq -> OpNeq+        OpNeq -> OpEq+        OpLt -> OpGe+        OpLe -> OpGt+        OpGt -> OpLe+        OpGe -> OpLt+ {- | @name Type = initial@ — a named register with its declared type and the initial value (an identifier: a literal like @placeholder@, an enum constructor, or a state name).@@ -303,10 +452,10 @@     deriving stock (Eq, Show, Generic)  {- | @event Name { … }@ or @event Name = fields(Command)@. EP-2 (evolution) adds-the version/upcaster/deprecation fields: an unversioned event is @evVersion = 1@,-@evUpcastFrom = Nothing@, @evDeprecated = False@, reproducing the EP-1 surface.-These fields live on the shared 'Event' so every node family's events inherit-schema-versioning for free.+the version/upcaster/retirement fields: an unversioned event is @evVersion = 1@,+@evUpcastFrom = Nothing@, @evRetiring = False@, and @evDeprecated = False@,+reproducing the EP-1 surface. These fields live on the shared 'Event' so every+node family's events inherit schema-versioning for free. -} data Event = Event     { evName :: !Name@@ -317,9 +466,16 @@     {- ^ The source version this shape migrates /from/, paired with the upcaster     hole. @Just (n-1, …)@ for a @vN@ shape; 'Nothing' for v1.     -}+    , evRetiring :: !Bool+    {- ^ Retirement is in progress. The event must keep at least one live+    emitting transition while operators terminalize or truncate affected+    streams; cut over to @deprecated@ plus a replay-only emitting transition+    afterwards.+    -}     , evDeprecated :: !Bool-    {- ^ Retired from the write path (no transition may @emit@ it) but still-    decodable from the log.+    {- ^ Retired from the write path (no live transition may @emit@ it) but+    still decodable from the log. A replay-only emitting transition must remain+    while live streams can still contain the event.     -}     , evLoc :: !Loc     }@@ -346,10 +502,23 @@     , tWrites :: ![(Name, Expr)]     , tEmits :: ![Name]     , tGoto :: !Name+    , tMode :: !TransitionMode     , tLoc :: !Loc     }     deriving stock (Eq, Show, Generic) +{- | Whether a transition serves forward execution or replay only (plan 143).+A @replay-only@ transition lowers to a keiki 'ReplayOnly' edge: it is never+taken by a new command and exists so events emitted under a retired rule keep+an inverting edge. Spelled as a @replay-only@ prefix on the transition line:++@+replay-only Held -- ConfirmReservation --> guard … ; emit … ; goto …+@+-}+data TransitionMode = TmLive | TmReplayOnly+    deriving stock (Eq, Show, Generic)+ {- | @wire kind=ctorName fields=camelCase schemaVersion=1@ — how events serialize. -}@@ -927,6 +1096,9 @@     }     deriving stock (Eq, Show, Generic) +workflowNodeLoc :: WorkflowNode -> Loc+workflowNodeLoc WorkflowNode{wfLoc = loc} = loc+ -- | The four operation shapes. data OperationShape     = -- | @command on <Agg> stream from <field> via <fn> project [ … ]@@@ -981,7 +1153,7 @@     deriving stock (Eq, Show, Generic)  {- | A whole @.keiro@ file: one context name, an optional module-placement-override (the @module@/@layout@ clauses), the shared id/enum/rule declarations,+override (the @module@/@layout@ clauses), the shared id/enum/rule/mapped declarations, and the list of nodes. 'specModuleRoot' and 'specLayout' are 'Nothing' when the spec omits the clauses, reproducing the historical default. -}@@ -992,6 +1164,7 @@     , specIds :: ![IdDecl]     , specEnums :: ![EnumDecl]     , specRules :: ![RuleDecl]+    , specMapped :: ![MappedDecl]     , specNodes :: ![Node]     }     deriving stock (Eq, Show, Generic)

@@ -14,35 +14,60 @@      stepping a sample command lands on the declared @goto@ vertex. This is the      check a wrong guard fails — flipping @./=@ to @.==@ in the filled body turns      it red while leaving the scaffold untouched.+  5. a forward/replay equality check per live, event-emitting transition out of+     the initial state: emitted events cross the generated codec boundary, then+     replay must reconstruct the forward vertex and every declared register.++@Text@ samples include their field name so same-typed field swaps remain visible+to the replay check. Other sample kinds remain uniform until fixture bindings can+supply a wider, consumer-owned corpus. -} module Keiro.Dsl.Harness (     harnessFor,+    harnessForWithGoldens,     harnessProcess,     harnessRouter,     harnessReadModel,     harnessWorkflow, ) where +import Data.List (find)+import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T+import Keiro.Dsl.Goldens (GoldenPayload (..)) import Keiro.Dsl.Grammar import Keiro.Dsl.ReadModelShape (deriveShapeHash, registryNameFor, subscriptionNameFor) import Keiro.Dsl.Scaffold+import Keiro.Dsl.TypeGraph  {- | Emit the harness test module for one aggregate. Like 'scaffoldAggregate', it takes the 'Spec' for the shared id\/enum declarations. -} harnessFor :: Context -> Spec -> Aggregate -> [ScaffoldModule]-harnessFor ctx spec agg =+harnessFor = harnessForWithGoldens []++{- | Emit an aggregate harness with checked-in old-payload fixtures embedded+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 =     [ ScaffoldModule         { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/Harness.hs")-        , moduleText = emitHarness a+        , moduleText = emitHarness relevantGoldens a         , kind = Generated         , origin = "aggregate " <> aggName agg <> locSuffix (aggLoc agg)         }     ]   where     a = resolveAgg ctx spec agg+    relevantGoldens =+        [ golden+        | golden <- goldens+        , goldenContext golden == specContext spec+        , goldenAggregate golden == aggName agg+        ]  {- | Emit a self-contained, firewall-clean facts harness for a process manager, pinning the spec's deterministic decisions: the time-injection formula, the@@ -239,13 +264,13 @@         { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowFacts.hs")         , moduleText = emitWorkflowFacts genPrefix w         , kind = Generated-        , origin = "workflow " <> wfId w <> locSuffix (wfLoc w)+        , origin = "workflow " <> wfId w <> locSuffix (workflowNodeLoc w)         }     , ScaffoldModule         { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowRuntime.hs")         , moduleText = emitWorkflowRuntime genPrefix w         , kind = Generated-        , origin = "workflow " <> wfId w <> locSuffix (wfLoc w)+        , origin = "workflow " <> wfId w <> locSuffix (workflowNodeLoc w)         }     ]   where@@ -351,75 +376,141 @@     go (WfPatch patchId items _) = patchId : workflowPatchIds items     go _ = [] -emitHarness :: Agg -> Text-emitHarness a =+emitHarness :: [GoldenPayload] -> Agg -> Text+emitHarness goldens a =     nl $-        [ "{-# LANGUAGE OverloadedStrings #-}"-        , generatedBanner-        , "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where"-        , ""-        , "import " <> aGenPrefix a <> ".Domain"-        , "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> ")"-        , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst nm <> "Transducer)"-        , "import Keiki.Core (defaultValidationOptions, step, validateTransducer)"-        , codecDecodeRawImport-        , ""-        , "{- | (label, passed). A driver runs these and exits non-zero on any False,"-        , "naming the failing assertion. Filling a hole wrongly turns a specific"-        , "entry False; the scaffold cannot."-        , "-}"-        , "harnessAssertions :: [(String, Bool)]"-        , "harnessAssertions ="-        , "  [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))"-        , "  , (\"clock-free: spec samples no wall clock\", " <> clockFreeLit <> ")"+        [ "{-# LANGUAGE DataKinds #-}"+        , "{-# LANGUAGE OverloadedLabels #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"         ]+            ++ ["{-# LANGUAGE TypeApplications #-}" | hasMappedHarness a]+            ++ [ generatedBanner+               , "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where"+               , ""+               , "import " <> aGenPrefix a <> ".Domain"+               , "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> mappedCodecHarnessExports a <> ")"+               , "import " <> aHolePrefix a <> ".Holes (" <> lowerFirst nm <> "Transducer)"+               , "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")"+               , codecDecodeRawImport+               ]+            ++ mappedHarnessImports a+            ++ goldenImports+            ++ [ ""+               , "{- | (label, passed). A driver runs these and exits non-zero on any False,"+               , "naming the failing assertion. Filling a hole wrongly turns a specific"+               , "entry False; the scaffold cannot."+               , "-}"+               , "harnessAssertions :: [(String, Bool)]"+               , "harnessAssertions ="+               , "  [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))"+               , "  , (\"clock-free: spec samples no wall clock\", " <> clockFreeLit <> ")"+               ]             ++ [ "  , (\"golden round-trip: " <> rcName e <> "\", roundTrips sampleEvent" <> rcName e <> ")"                | e <- aEvents a                ]             ++ [ "  , (\"accepts " <> tCommand t <> " from " <> initialVertex a <> "\", accept" <> tCommand t <> ")"                | t <- initialTransitions a                ]-            ++ [ "  , (\"upcaster wired: a v" <> tInt m <> " " <> rcName e <> " payload decodes through the chain\", upcasts" <> rcName e <> ")"-               | e <- upcastEvents-               , Just m <- [rcUpcastFrom e]-               ]             ++ [ "  ]"-               , ""+               ]+            ++ ["  ++ mappedConformanceAssertions" | hasMappedHarness a]+            ++ [ "  ++ forwardReplay" <> tCommand t+               | t <- replayTransitions+               ]+            ++ ( if null upcastEvents+                    then []+                    else+                        [ "  ++ [ " <> T.intercalate "\n     , " upcastAssertions+                        , "     ]"+                        ]+               )+            ++ [ ""                , "roundTrips :: " <> nm <> "Event -> Bool"                , "roundTrips e = parse" <> nm <> "Event (eventType " <> lowerFirst nm <> "Codec e) (encode" <> nm <> "Event e) == Right e"                ]             ++ concatMap (sampleEventDecl a) (aEvents a)             ++ concatMap (acceptDecl a) (initialTransitions a)-            ++ concatMap (upcastDecl a) upcastEvents+            ++ concatMap (forwardReplayDecl a) replayTransitions+            ++ concatMap (upcastDecl goldens a) upcastEvents+            ++ mappedHarnessDeclarations a   where     nm = aName a     -- Bake the clock-free result computed from the spec at scaffold time.     clockFreeLit = if specIsClockFree a then "True" else "False"     upcastEvents = [e | e <- aEvents a, rcUpcastFrom e /= Nothing]+    replayTransitions =+        [ t+        | t <- initialTransitions a+        , tMode t == TmLive+        , not (null (tEmits t))+        ]+    coreImports =+        ["applyEventsEither" | not (null replayTransitions)]+            ++ ["defaultValidationOptions", "step", "validateTransducer"]+            ++ ["fieldWitnessAgrees" | not (null (mappedProjectionSpecs a))]+            ++ ["(!)" | not (null replayTransitions) && not (null (aRegs a))]+    upcastAssertions =+        [ "(" <> tshow (upcastLabel e m) <> ", upcasts" <> rcName e <> ")"+        | e <- upcastEvents+        , Just m <- [rcUpcastFrom e]+        ]     codecValueImport = ", " <> lowerFirst nm <> "Codec"     codecDecodeRawImport =         if null upcastEvents             then "import Keiro.Codec (eventType)"             else "import Keiro.Codec (EventType (..), decodeRaw, eventType)"+    goldenImports =+        if any (hasGolden goldens) upcastEvents+            then+                [ "import Data.Aeson (eitherDecodeStrict)"+                , "import Data.Text.Encoding (encodeUtf8)"+                ]+            else []+    upcastLabel event source =+        case goldenFor goldens event of+            Just _ -> "golden " <> rcName event <> ".v" <> tInt source <> " decodes"+            Nothing ->+                "upcast "+                    <> rcName event+                    <> " chain wired (current-shape stand-in; add a golden payload)" -{- | A wiring-proof assertion: feed a current-shape payload tagged at the-upcaster's source version through @decodeRaw@, which runs the upcaster chain-then @decode@. Red while the upcaster hole returns @Left@; green once filled.-(The grammar records only the current event shape, not the per-version field-delta, so this proves the chain is wired and the hole must be filled rather-than re-deriving the exact old payload.)+{- | Decode a genuine embedded old payload when available. Without a golden,+retain the weaker current-shape wiring assertion and label it honestly. -}-upcastDecl :: Agg -> ResolvedCtor -> [Text]-upcastDecl a e = case rcUpcastFrom e of+upcastDecl :: [GoldenPayload] -> Agg -> ResolvedCtor -> [Text]+upcastDecl goldens a e = case rcUpcastFrom e of     Nothing -> []-    Just m ->-        [ ""-        , "upcasts" <> rcName e <> " :: Bool"-        , "upcasts" <> rcName e <> " ="-        , "  either (const False) (const True)"-        , "    (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " (encode" <> aName a <> "Event sampleEvent" <> rcName e <> "))"-        ]+    Just m -> case goldenFor goldens e of+        Just golden ->+            [ ""+            , "upcasts" <> rcName e <> " :: Bool"+            , "upcasts" <> rcName e <> " ="+            , "  case eitherDecodeStrict (encodeUtf8 " <> tshow (goldenJson golden) <> ") of"+            , "    Left _ -> False"+            , "    Right payload ->"+            , "      either (const False) (const True)"+            , "        (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " payload)"+            ]+        Nothing ->+            [ ""+            , "upcasts" <> rcName e <> " :: Bool"+            , "upcasts" <> rcName e <> " ="+            , "  either (const False) (const True)"+            , "    (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " (encode" <> aName a <> "Event sampleEvent" <> rcName e <> "))"+            ] +hasGolden :: [GoldenPayload] -> ResolvedCtor -> Bool+hasGolden goldens event = case goldenFor goldens event of+    Just _ -> True+    Nothing -> False++goldenFor :: [GoldenPayload] -> ResolvedCtor -> Maybe GoldenPayload+goldenFor goldens event = do+    source <- rcUpcastFrom event+    find+        (\golden -> goldenEvent golden == rcName event && goldenVersion golden == source)+        goldens+ tInt :: Int -> Text tInt = T.pack . show @@ -451,7 +542,8 @@     [] -> []  {- | @sampleEvent<Ctor> :: <Agg>Event@ — a sample built from per-field sample-values (enum→first constructor, Bool→False, id→placeholder, Text→\"sample\").+values (enum→first constructor, Bool→False, id→placeholder,+Text→\"sample-<fieldName>\"). -} sampleEventDecl :: Agg -> ResolvedCtor -> [Text] sampleEventDecl a e =@@ -474,20 +566,515 @@         (c : _) -> "(" <> ctorExpr a c <> ")"         [] -> "(error \"no command\")" +forwardReplayDecl :: Agg -> Transition -> [Text]+forwardReplayDecl a t =+    [ ""+    , "-- forward/replay equality (plan 147): cross the persisted codec boundary,"+    , "-- replay the emitted chain, and compare the final vertex and every register."+    , helperName <> " :: [(String, Bool)]"+    , helperName <> " ="+    , "  case step " <> transducer <> " (" <> initial <> ", " <> initialRegs <> ") " <> cmdSample <> " of"+    , "    Nothing -> [(prefix <> \"forward step accepted\", False)]"+    , "    Just (forwardVertex, " <> forwardRegsName <> ", emitted) ->"+    , "      case mapM (\\event -> parse" <> nm <> "Event (eventType " <> codec <> " event) (encode" <> nm <> "Event event)) emitted of"+    , "        Left _ -> [(prefix <> \"emitted chain decodes\", False)]"+    , "        Right decodedEvents ->"+    , "          case applyEventsEither " <> transducer <> " (" <> initial <> ", " <> initialRegs <> ") decodedEvents of"+    , "            Left _ -> [(prefix <> \"replay succeeds\", False)]"+    , "            Right (replayVertex, " <> replayRegsName <> ") ->"+    , "              [ (prefix <> \"final vertex\", replayVertex == forwardVertex)"+    ]+        ++ [ "              , (prefix <> \"register " <> regName reg <> "\", (replayRegs ! #" <> regName reg <> ") == (forwardRegs ! #" <> regName reg <> "))"+           | reg <- aRegs a+           ]+        ++ [ "              ]"+           , "  where"+           , "    prefix = \"forward/replay equality: " <> tCommand t <> " from " <> initial <> " -- \""+           ]+  where+    nm = aName a+    helperName = "forwardReplay" <> tCommand t+    transducer = lowerFirst nm <> "Transducer"+    codec = lowerFirst nm <> "Codec"+    initial = initialVertex a+    initialRegs = "initial" <> nm <> "Regs"+    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 <> ")"+        [] -> "(error \"no command\")"+ -- | @(<Ctor> (<Ctor>Data v1 v2 …))@ with positional sample field values. ctorExpr :: Agg -> ResolvedCtor -> Text ctorExpr a rc =     "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))"   where-    args = T.concat [" " <> sampleValue a ty | (_, ty) <- rcFields rc]+    args = T.concat [" " <> sampleValue a fieldName ty | (fieldName, ty) <- rcFields rc] -sampleValue :: Agg -> Text -> Text-sampleValue a ty = case fieldCat a ty of+sampleValue :: Agg -> Text -> Text -> Text+sampleValue a fieldName ty = case fieldCat a ty of     IdCat -> "(" <> ty <> " \"sample\")"     EnumCat -> maybe ("(error \"no enum ctor\")") id (firstEnumCtor a ty)+    MappedStructuralCat declaration _ -> fixtureSample (sdFixtures declaration)+    MappedOpaqueCat declaration -> fixtureSample (odFixtures declaration)     OtherCat         | ty == "Bool" -> "False"         | ty == "Int" -> "0"-        | ty == "Text" -> "\"sample\""+        | ty == "Text" -> tshow ("sample-" <> fieldName)         | ty == aVertexType a -> initialVertex a         | otherwise -> "(error \"sample: unsupported type " <> ty <> "\")"++mappedHarnessImports :: Agg -> [Text]+mappedHarnessImports aggregate+    | null fixtures = []+    | otherwise =+        [ "import Data.Aeson qualified as Aeson"+        , "import Data.Aeson.Key qualified as AesonKey"+        , "import Data.Aeson.KeyMap qualified as AesonKeyMap"+        , "import Data.Either (isLeft, isRight)"+        , "import Data.List (nub)"+        , "import Data.List.NonEmpty qualified as NonEmpty"+        , "import Data.Maybe (isJust, isNothing)"+        , "import Data.Proxy (Proxy (..))"+        , "import Data.Text qualified as T"+        , "import Keiki.Shape (CanonicalTypeName (..))"+        , "import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)"+        ]+            ++ map (\moduleName -> "import " <> moduleName <> " qualified") (unique (modules <> bindingModules <> shapeModules <> consumerModules))+            ++ ["import " <> structuralProjectionModuleName (aContext aggregate) <> " qualified as StructuralProjections" | not (null (mappedProjectionSpecs aggregate))]+  where+    fixtures = [mappedFixtures declaration | declaration <- mappedHarnessDeclarationsResolved aggregate]+    modules = unique [fst (splitQualifiedHarness (unQualifiedValueName qualified)) | qualified <- fixtures]+    bindingModules =+        [ fst (splitQualifiedHarness (unQualifiedValueName (sdBinding declaration)))+        | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate+        ]+    shapeModules =+        [ structuralShapeModuleName (aContext aggregate) (sdName declaration)+        | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate+        ]+    consumerModules =+        [ hsModule (sdHaskell declaration)+        | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate+        ]++mappedCodecHarnessExports :: Agg -> Text+mappedCodecHarnessExports aggregate =+    T.concat+        [ ", encode" <> sdName declaration <> "Mapped, decode" <> sdName declaration <> "Mapped"+        | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate+        ]++fixtureSample :: QualifiedValueName -> Text+fixtureSample qualified =+    "(snd (NonEmpty.head (fixtureCases " <> unQualifiedValueName qualified <> ")))"++splitQualifiedHarness :: Text -> (Text, Text)+splitQualifiedHarness value =+    let (prefix, name) = T.breakOnEnd "." value+     in (T.dropEnd 1 prefix, name)++unique :: (Eq value) => [value] -> [value]+unique = foldr (\value values -> if value `elem` values then values else value : values) []++hasMappedHarness :: Agg -> Bool+hasMappedHarness = not . null . mappedHarnessDeclarationsResolved++mappedHarnessDeclarationsResolved :: Agg -> [ResolvedMappedDecl]+mappedHarnessDeclarationsResolved aggregate = case aTypeGraph aggregate of+    Nothing -> []+    Just graph -> Map.elems (tgDeclarations graph)++mappedProjectionSpecs :: Agg -> [StructuralProjection]+mappedProjectionSpecs aggregate = case aTypeGraph aggregate of+    Nothing -> []+    Just graph -> map (resolveProjectionModules (aContext aggregate)) (projectionSpecs graph)++structuralShapeModuleName :: Context -> Name -> Text+structuralShapeModuleName context name = case placement context of+    GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".Structural.Shape." <> name+    CollocatedLeaf -> root <> contextSegment <> ".Generated.Structural.Shape." <> name+  where+    root = if T.null (moduleRoot context) then "" else moduleRoot context <> "."+    contextSegment = pascalFromKebab (contextName context)++structuralProjectionModuleName :: Context -> Text+structuralProjectionModuleName context = case placement context of+    GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".StructuralProjections"+    CollocatedLeaf -> root <> contextSegment <> ".Generated.StructuralProjections"+  where+    root = if T.null (moduleRoot context) then "" else moduleRoot context <> "."+    contextSegment = pascalFromKebab (contextName context)++mappedHarnessDeclarations :: Agg -> [Text]+mappedHarnessDeclarations aggregate+    | not (hasMappedHarness aggregate) = []+    | otherwise =+        [ ""+        , "mappedConformanceAssertions :: [(String, Bool)]"+        , "mappedConformanceAssertions ="+        , "  concat"+        , "    [ " <> T.intercalate "\n    , " assertionLists+        , "    ]"+        , ""+        , "validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool"+        , "validFixtureLabels cases ="+        , "  all (not . T.null) labels && length labels == length (nub labels)"+        , "  where"+        , "    labels = map fst (NonEmpty.toList cases)"+        ]+            ++ concatMap (bindingAssertionDecl aggregate) structural+            ++ concatMap (opaqueAssertionDecl aggregate) opaque+            ++ concatMap (coverageDecl aggregate) structural+            ++ concatMap (mappedEventAssertionDecl aggregate) mappedEventFields+            ++ wirePolicyAssertionDecls aggregate structuralWire+            ++ projectionAssertionDecls aggregate structural+            ++ wirePolicyHelpers structuralWire+  where+    declarations = mappedHarnessDeclarationsResolved aggregate+    structural = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]+    opaque = [declaration | ResolvedOpaque declaration <- declarations]+    structuralWire = [(declaration, shape) | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate]+    mappedEventFields =+        [ (event, fieldName, fieldType, declaration)+        | event <- aEvents aggregate+        , (fieldName, fieldType) <- rcFields event+        , declaration <- maybeToListHarness (mappedDeclaration aggregate fieldType)+        ]+    assertionLists =+        [lowerFirst (sdName declaration) <> "BindingAssertions" | (declaration, _) <- structural]+            <> [lowerFirst (odName declaration) <> "OpaqueAssertions" | declaration <- opaque]+            <> [ "[(\"fixture coverage: "+                    <> unCanonicalTypeId (sdCanonical declaration)+                    <> "\", coverage"+                    <> sdName declaration+                    <> ")]"+               | (declaration, _) <- structural+               ]+            <> [ mappedEventAssertionName event fieldName <> "Assertions"+               | (event, fieldName, _, _) <- mappedEventFields+               ]+            <> ["structuralWirePolicyAssertions" | not (null structuralWire)]+            <> ["structuralProjectionAssertions" | not (null (mappedProjectionSpecs aggregate))]++mappedDeclaration :: Agg -> Text -> Maybe ResolvedMappedDecl+mappedDeclaration aggregate name = do+    graph <- aTypeGraph aggregate+    Map.lookup (MappedKey name) (tgDeclarations graph)++bindingAssertionDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text]+bindingAssertionDecl _aggregate (declaration, _shape) =+    [ ""+    , valueName <> " :: [(String, Bool)]"+    , valueName <> " ="+    , "  (\"fixture labels: " <> canonical <> "\", validFixtureLabels cases) :"+    , "  (\"canonical identity: " <> canonical <> "\", canonicalTypeName (Proxy @" <> consumerType <> ") == " <> tshow canonical <> ") :"+    , "  concat"+    , "    [ [ (\"binding domain round-trip: " <> canonical <> "/\" <> T.unpack label, bindingDomainRoundTrip " <> binding <> " value)"+    , "      , (\"binding shape round-trip: " <> canonical <> "/\" <> T.unpack label, bindingShapeRoundTrip " <> binding <> " (bindingToShape " <> binding <> " value))"+    , "      ]"+    , "    | (label, value) <- NonEmpty.toList cases"+    , "    ]"+    , "  where"+    , "    cases = fixtureCases " <> fixtures+    ]+  where+    valueName = lowerFirst (sdName declaration) <> "BindingAssertions"+    canonical = unCanonicalTypeId (sdCanonical declaration)+    consumerType = hsModule (sdHaskell declaration) <> "." <> hsType (sdHaskell declaration)+    binding = unQualifiedValueName (sdBinding declaration)+    fixtures = unQualifiedValueName (sdFixtures declaration)++opaqueAssertionDecl :: Agg -> OpaqueDecl -> [Text]+opaqueAssertionDecl _aggregate declaration =+    [ ""+    , valueName <> " :: [(String, Bool)]"+    , valueName <> " ="+    , "  (\"opaque boundary fixtures: " <> label <> "\", validFixtureLabels cases) :"+    , "  [ (\"opaque codec round-trip: " <> label <> "/\" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)"+    , "  | (caseLabel, value) <- NonEmpty.toList cases"+    , "  ]"+    , "  where"+    , "    cases = fixtureCases " <> fixtures+    ]+  where+    valueName = lowerFirst (odName declaration) <> "OpaqueAssertions"+    label = unCodecIdentity (odCodecIdentity declaration) <> "@" <> unCodecVersion (odCodecVersion declaration)+    fixtures = unQualifiedValueName (odFixtures declaration)++coverageDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text]+coverageDecl aggregate (declaration, shape) =+    [ ""+    , "coverage" <> sdName declaration <> " :: Bool"+    , "coverage" <> sdName declaration <> " = " <> coverageExpression aggregate declaration shape+    ]++coverageExpression :: Agg -> StructuralDecl -> ResolvedMappedShape -> Text+coverageExpression aggregate declaration shape = case obligations of+    [] -> "True"+    _ -> T.intercalate " && " obligations <> "\n  where\n    shapes = map (bindingToShape " <> binding <> " . snd) (NonEmpty.toList (fixtureCases " <> fixtures <> "))"+  where+    shapeModule = structuralShapeModuleName (aContext aggregate) (sdName declaration)+    binding = unQualifiedValueName (sdBinding declaration)+    fixtures = unQualifiedValueName (sdFixtures declaration)+    obligations = case shape of+        RRecord _ _ fields -> concatMap (recordFieldObligation shapeModule) fields+        REnum entries ->+            [ "any (\\case " <> shapeModule <> "." <> weCtor entry <> " -> True; _ -> False) shapes"+            | entry <- entries+            ]+        RUnion _ arms -> concatMap (unionArmObligations shapeModule) arms++recordFieldObligation :: Text -> ResolvedWireField -> [Text]+recordFieldObligation shapeModule field = case rwfType field of+    ROptional _ ->+        [ "any (isNothing . " <> selector <> ") shapes"+        , "any (isJust . " <> selector <> ") shapes"+        ]+    _ -> []+  where+    selector = shapeModule <> "." <> rwfHaskell field++unionArmObligations :: Text -> ResolvedWireArm -> [Text]+unionArmObligations shapeModule arm =+    ["any (\\case " <> patternText <> " -> True; _ -> False) shapes"] <> optionalPayload+  where+    constructor = shapeModule <> "." <> rwaCtor arm+    patternText = constructor <> maybe "" (const "{}") (rwaPayload arm)+    optionalPayload = case rwaPayload arm of+        Just (ROptional _) ->+            [ "any (\\case " <> constructor <> " Nothing -> True; _ -> False) shapes"+            , "any (\\case " <> constructor <> " (Just _) -> True; _ -> False) shapes"+            ]+        _ -> []++mappedEventAssertionDecl :: Agg -> (ResolvedCtor, Text, Text, ResolvedMappedDecl) -> [Text]+mappedEventAssertionDecl aggregate (event, fieldName, _fieldType, declaration) =+    [ ""+    , valueName <> "Assertions :: [(String, Bool)]"+    , valueName <> "Assertions ="+    , "  [ (\"mapped codec round-trip: " <> rcName event <> "/" <> fieldName <> "/\" <> T.unpack label, roundTrips " <> eventExpression <> ")"+    , "  | (label, mappedValue) <- NonEmpty.toList (fixtureCases " <> fixtures <> ")"+    , "  ]"+    ]+  where+    valueName = mappedEventAssertionName event fieldName+    fixtures = unQualifiedValueName (mappedFixtures declaration)+    eventExpression = ctorExprWithOverride aggregate event fieldName "mappedValue"++mappedEventAssertionName :: ResolvedCtor -> Text -> Text+mappedEventAssertionName event fieldName = lowerFirst (rcName event) <> pascal fieldName++wirePolicyAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text]+wirePolicyAssertionDecls _aggregate [] = []+wirePolicyAssertionDecls aggregate declarations =+    [ ""+    , "structuralWirePolicyAssertions :: [(String, Bool)]"+    , "structuralWirePolicyAssertions ="+    , "  [ " <> T.intercalate "\n  , " assertions+    , "  ]"+    ]+  where+    assertions = concatMap (wirePolicyAssertions aggregate) declarations++wirePolicyAssertions :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text]+wirePolicyAssertions aggregate (declaration, shape) = case shape of+    RRecord _ unknownFields fields ->+        concatMap (recordMissingAssertions aggregate declaration) [field | field <- fields, rwfPresence field == POptional]+            <> [unknownFieldAssertion declaration unknownFields]+    REnum entries -> map (enumArmAssertion declaration) entries <> [enumUnknownAssertion declaration]+    RUnion encoding arms ->+        map (unionArmAssertion declaration encoding) arms+            <> [unknownFieldAssertion declaration (ueUnknownFields encoding)]++recordMissingAssertions :: Agg -> StructuralDecl -> ResolvedWireField -> [Text]+recordMissingAssertions aggregate declaration field =+    [ "(\"wire policy missing default: "+        <> canonical+        <> "/"+        <> rwfKey field+        <> "\", case "+        <> decoder+        <> " (deleteObjectField "+        <> tshow (rwfKey field)+        <> " ("+        <> encodedSample+        <> ")) of Left _ -> False; Right decoded -> objectField "+        <> tshow (rwfKey field)+        <> " ("+        <> encoder+        <> " decoded) == Just ("+        <> missingExpectedValue aggregate field+        <> "))"+    , "(\"wire policy explicit null: "+        <> canonical+        <> "/"+        <> rwfKey field+        <> "\", "+        <> nullExpectation+        <> " ("+        <> decoder+        <> " (insertObjectField "+        <> tshow (rwfKey field)+        <> " Aeson.Null ("+        <> encodedSample+        <> "))))"+    ]+  where+    canonical = unCanonicalTypeId (sdCanonical declaration)+    encoder = "encode" <> sdName declaration <> "Mapped"+    decoder = "decode" <> sdName declaration <> "Mapped"+    fixtures = unQualifiedValueName (sdFixtures declaration)+    encodedSample = encoder <> " (snd (NonEmpty.head (fixtureCases " <> fixtures <> ")))"+    nullExpectation = case rwfType field of+        ROptional _ -> "isRight"+        _ -> "isLeft"++missingExpectedValue :: Agg -> ResolvedWireField -> Text+missingExpectedValue aggregate field = case rwfOnMissing field of+    Just OmNull -> "Aeson.Null"+    Just (OmText value) -> "Aeson.String " <> tshow value+    Just (OmInt value) -> "Aeson.toJSON (" <> T.pack (show value) <> " :: Int)"+    Just (OmBool value) -> if value then "Aeson.Bool True" else "Aeson.Bool False"+    Just OmEmptyList -> "Aeson.toJSON ([] :: [Aeson.Value])"+    Just OmEmptyMap -> "Aeson.Object mempty"+    Just (OmCtor constructor) -> case (aTypeGraph aggregate, rwfType field) of+        (Just graph, RRef key) -> case Map.lookup key (tgDeclarations graph) of+            Just (ResolvedStructural _ (REnum entries)) -> case find ((== constructor) . weCtor) entries of+                Just entry -> "Aeson.String " <> tshow (weTag entry)+                Nothing -> "error \"missing enum default constructor\""+            _ -> "error \"non-enum constructor default\""+        _ -> "error \"non-reference constructor default\""+    Nothing -> "error \"optional field lacks on-missing policy\""++unknownFieldAssertion :: StructuralDecl -> UnknownFields -> Text+unknownFieldAssertion declaration policy =+    "(\"wire policy unknown fields: "+        <> unCanonicalTypeId (sdCanonical declaration)+        <> "\", all (\\(_, value) -> "+        <> expectation+        <> " (decode"+        <> sdName declaration+        <> "Mapped (insertObjectField \"__keiro_unknown\" (Aeson.Bool True) (encode"+        <> sdName declaration+        <> "Mapped value)))) (NonEmpty.toList (fixtureCases "+        <> unQualifiedValueName (sdFixtures declaration)+        <> ")))"+  where+    expectation = case policy of+        RejectUnknown -> "isLeft"+        IgnoreUnknown -> "isRight"++enumArmAssertion :: StructuralDecl -> WireEnum -> Text+enumArmAssertion declaration entry =+    "(\"wire enum arm: "+        <> unCanonicalTypeId (sdCanonical declaration)+        <> "/"+        <> weTag entry+        <> "\", any (\\(_, value) -> encode"+        <> sdName declaration+        <> "Mapped value == Aeson.String "+        <> tshow (weTag entry)+        <> " && decode"+        <> sdName declaration+        <> "Mapped (Aeson.String "+        <> tshow (weTag entry)+        <> ") == Right value) (NonEmpty.toList (fixtureCases "+        <> unQualifiedValueName (sdFixtures declaration)+        <> ")))"++enumUnknownAssertion :: StructuralDecl -> Text+enumUnknownAssertion declaration =+    "(\"wire enum unknown tag: "+        <> unCanonicalTypeId (sdCanonical declaration)+        <> "\", isLeft (decode"+        <> sdName declaration+        <> "Mapped (Aeson.String \"__keiro_unknown\")))"++unionArmAssertion :: StructuralDecl -> UnionEncoding -> ResolvedWireArm -> Text+unionArmAssertion declaration encoding arm =+    "(\"wire union arm: "+        <> unCanonicalTypeId (sdCanonical declaration)+        <> "/"+        <> rwaTag arm+        <> "\", any (\\(_, value) -> objectField "+        <> tshow (ueTagField encoding)+        <> " (encode"+        <> sdName declaration+        <> "Mapped value) == Just (Aeson.String "+        <> tshow (rwaTag arm)+        <> ") && decode"+        <> sdName declaration+        <> "Mapped (encode"+        <> sdName declaration+        <> "Mapped value) == Right value) (NonEmpty.toList (fixtureCases "+        <> unQualifiedValueName (sdFixtures declaration)+        <> ")))"++wirePolicyHelpers :: [(StructuralDecl, ResolvedMappedShape)] -> [Text]+wirePolicyHelpers [] = []+wirePolicyHelpers _ =+    [ ""+    , "deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value"+    , "deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue)"+    , "deleteObjectField _ value = value"+    , ""+    , "insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value"+    , "insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue)"+    , "insertObjectField _ _ value = value"+    , ""+    , "objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value"+    , "objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue"+    , "objectField _ _ = Nothing"+    ]++mappedFixtures :: ResolvedMappedDecl -> QualifiedValueName+mappedFixtures (ResolvedStructural declaration _) = sdFixtures declaration+mappedFixtures (ResolvedOpaque declaration) = odFixtures declaration++ctorExprWithOverride :: Agg -> ResolvedCtor -> Text -> Text -> Text+ctorExprWithOverride aggregate constructor target replacement =+    "(" <> rcName constructor <> " (" <> rcName constructor <> "Data" <> arguments <> "))"+  where+    arguments =+        T.concat+            [ " " <> if fieldName == target then replacement else sampleValue aggregate fieldName fieldType+            | (fieldName, fieldType) <- rcFields constructor+            ]++projectionAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text]+projectionAssertionDecls aggregate structural+    | null specs = []+    | otherwise =+        [ ""+        , "structuralProjectionAssertions :: [(String, Bool)]"+        , "structuralProjectionAssertions ="+        , "  [ " <> T.intercalate "\n  , " (map assertion specs)+        , "  ]"+        ]+  where+    specs = mappedProjectionSpecs aggregate+    assertion spec =+        "(\"projection witness agreement: "+            <> unCanonicalTypeId (spCanonical spec)+            <> spPointer spec+            <> "\", all (\\(_, owner) -> fieldWitnessAgrees StructuralProjections."+            <> spWitness spec+            <> " (\\referenceOwner -> "+            <> projectionGetter "referenceOwner" spec+            <> ") owner) (NonEmpty.toList (fixtureCases "+            <> ownerFixtures spec+            <> ")))"+    ownerFixtures spec = case find (\(declaration, _) -> sdCanonical declaration == spCanonical spec) structural of+        Just (declaration, _) -> unQualifiedValueName (sdFixtures declaration)+        Nothing -> "error \"projection owner fixtures missing\""++projectionGetter :: Text -> StructuralProjection -> Text+projectionGetter owner spec =+    foldl+        (\value (shapeModule, selector) -> shapeModule <> "." <> selector <> " (" <> value <> ")")+        ("bindingToShape " <> unQualifiedValueName (spBinding spec) <> " " <> owner)+        (spSelectors spec)++maybeToListHarness :: Maybe value -> [value]+maybeToListHarness = maybe [] pure

@@ -16,7 +16,8 @@   * intake/emit/publisher (full integration path)                         => effectful-core, hasql-transaction, keiro, kiroku-store                                                          (…-intake-full)-  * workqueue           => aeson, keiro-pgmq, text       (…-queue, …-queue-runtime)+  * workqueue           => aeson, keiro-core, keiro-pgmq, text+                                                         (…-queue, …-queue-runtime)   * dispatch            => aeson, effectful-core, keiro-pgmq, text                                                          (…-dispatch-full)   * workflow/operation  => containers, effectful-core, keiro, text@@ -35,6 +36,7 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar+import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) import Keiro.Dsl.Scaffold (ScaffoldModule (..))  {- | Render a Cabal-pasteable manifest from the modules a scaffold run produced@@ -56,6 +58,20 @@                , "build-depends:"                ]             ++ map ("    , " <>) (manifestDependencies spec)+            ++ consumerBlocks+  where+    plan = consumerPlan spec+    consumerBlocks+        | null (consumerMappings plan) = []+        | otherwise =+            [ ""+            , "consumer-packages:"+            ]+                ++ map ("    " <>) (consumerPackages plan)+                ++ [ ""+                   , "consumer-modules:"+                   ]+                ++ map ("    " <>) (consumerModules plan)  {- | The dotted module name recovered from a 'ScaffoldModule' path: drop the trailing @.hs@ and replace @/@ with @.@.@@ -68,7 +84,7 @@ -} manifestDependencies :: Spec -> [Text] manifestDependencies spec =-    sort (nub ("base" : concatMap depsForNode (specNodes spec)))+    sort (nub ("base" : consumerPackages (consumerPlan spec) <> concatMap depsForNode (specNodes spec)))  -- | The dependencies a single node kind implies (see the module header table). depsForNode :: Node -> [Text]@@ -80,7 +96,7 @@     NIntake{} -> integration     NEmit{} -> integration     NPublisher{} -> integration-    NWorkqueue{} -> ["aeson", "keiro-pgmq", "text"]+    NWorkqueue{} -> ["aeson", "keiro-core", "keiro-pgmq", "text"]     NPgmqDispatch{} -> ["aeson", "effectful-core", "keiro-pgmq", "text"]     NReadModel{} -> ["effectful-core", "hasql-transaction", "keiro", "kiroku-store", "text"]     NWorkflow{} -> ["containers", "effectful-core", "keiro", "text"]

@@ -0,0 +1,162 @@+{- | One checked projection of mapped declarations for every scaffold+integration surface. Keeping dependency requirements and persisted identities+together prevents the manifest, preflight report, and scaffold record from+silently disagreeing.+-}+module Keiro.Dsl.MappedConsumer (+    ConsumerPlan (..),+    MappingIdentity (..),+    consumerPlan,+) where++import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.List (nub, sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar (HaskellSource (..), Spec)+import Keiro.Dsl.TypeGraph++data ConsumerPlan = ConsumerPlan+    { consumerPackages :: ![Text]+    , consumerModules :: ![Text]+    , consumerMappings :: ![MappingIdentity]+    }+    deriving stock (Eq, Show)++data MappingIdentity+    = StructuralMapping+        { mappingSpecName :: !Text+        , mappingCanonicalType :: !Text+        , mappingPackage :: !Text+        , mappingModule :: !Text+        , mappingType :: !Text+        , mappingBindingSymbol :: !Text+        , mappingBindingVersion :: !Text+        }+    | OpaqueMapping+        { mappingSpecName :: !Text+        , mappingPackage :: !Text+        , mappingModule :: !Text+        , mappingType :: !Text+        , mappingCodecIdentity :: !Text+        , mappingCodecVersion :: !Text+        }+    deriving stock (Eq, Show)++instance ToJSON MappingIdentity where+    toJSON StructuralMapping{mappingSpecName, mappingCanonicalType, mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion} =+        object+            [ "schema" .= (1 :: Int)+            , "mode" .= ("structural" :: Text)+            , "specName" .= mappingSpecName+            , "canonicalType" .= mappingCanonicalType+            , "package" .= mappingPackage+            , "module" .= mappingModule+            , "type" .= mappingType+            , "bindingSymbol" .= mappingBindingSymbol+            , "bindingVersion" .= mappingBindingVersion+            ]+    toJSON OpaqueMapping{mappingSpecName, mappingPackage, mappingModule, mappingType, mappingCodecIdentity, mappingCodecVersion} =+        object+            [ "schema" .= (1 :: Int)+            , "mode" .= ("opaque" :: Text)+            , "specName" .= mappingSpecName+            , "package" .= mappingPackage+            , "module" .= mappingModule+            , "type" .= mappingType+            , "codecIdentity" .= mappingCodecIdentity+            , "codecVersion" .= mappingCodecVersion+            ]++instance FromJSON MappingIdentity where+    parseJSON = withObject "keiro-dsl mapping identity" $ \value -> do+        schema <- value .: "schema"+        if schema /= (1 :: Int)+            then fail "unsupported mapping identity schema"+            else do+                mode <- value .: "mode"+                case (mode :: Text) of+                    "structural" ->+                        StructuralMapping+                            <$> value .: "specName"+                            <*> value .: "canonicalType"+                            <*> value .: "package"+                            <*> value .: "module"+                            <*> value .: "type"+                            <*> value .: "bindingSymbol"+                            <*> value .: "bindingVersion"+                    "opaque" ->+                        OpaqueMapping+                            <$> value .: "specName"+                            <*> value .: "package"+                            <*> value .: "module"+                            <*> value .: "type"+                            <*> value .: "codecIdentity"+                            <*> value .: "codecVersion"+                    _ -> fail "unknown mapping identity mode"++consumerPlan :: Spec -> ConsumerPlan+consumerPlan spec = case resolveTypeGraph spec of+    Left _ -> ConsumerPlan [] [] []+    Right graph ->+        ConsumerPlan+            { consumerPackages = uniqueSorted [hsPackage (mappedSource declaration) | declaration <- declarations]+            , consumerModules = uniqueSorted (concatMap mappedModules declarations)+            , consumerMappings = sortMappings (map mappingIdentity declarations)+            }+      where+        declarations = Map.elems (tgDeclarations graph)++mappedSource :: ResolvedMappedDecl -> HaskellSource+mappedSource (ResolvedStructural declaration _) = sdHaskell declaration+mappedSource (ResolvedOpaque declaration) = odHaskell declaration++mappedModules :: ResolvedMappedDecl -> [Text]+mappedModules (ResolvedStructural declaration _) =+    hsModule (sdHaskell declaration)+        : qualifiedModule (sdBinding declaration)+        : qualifiedModule (sdFixtures declaration)+        : maybe [] (pure . qualifiedModule) (sdInitial declaration)+mappedModules (ResolvedOpaque declaration) =+    hsModule (odHaskell declaration)+        : qualifiedModule (odFixtures declaration)+        : maybe [] (pure . qualifiedModule) (odInitial declaration)++mappingIdentity :: ResolvedMappedDecl -> MappingIdentity+mappingIdentity (ResolvedStructural declaration _) =+    StructuralMapping+        { mappingSpecName = sdName declaration+        , mappingCanonicalType = unCanonicalTypeId (sdCanonical declaration)+        , mappingPackage = hsPackage (sdHaskell declaration)+        , mappingModule = hsModule (sdHaskell declaration)+        , mappingType = hsType (sdHaskell declaration)+        , mappingBindingSymbol = unQualifiedValueName (sdBinding declaration)+        , mappingBindingVersion = unBindingVersion (sdBindingVersion declaration)+        }+mappingIdentity (ResolvedOpaque declaration) =+    OpaqueMapping+        { mappingSpecName = odName declaration+        , mappingPackage = hsPackage (odHaskell declaration)+        , mappingModule = hsModule (odHaskell declaration)+        , mappingType = hsType (odHaskell declaration)+        , mappingCodecIdentity = unCodecIdentity (odCodecIdentity declaration)+        , mappingCodecVersion = unCodecVersion (odCodecVersion declaration)+        }++qualifiedModule :: QualifiedValueName -> Text+qualifiedModule qualified = T.dropEnd 1 (fst (T.breakOnEnd "." (unQualifiedValueName qualified)))++sortMappings :: [MappingIdentity] -> [MappingIdentity]+sortMappings = sortOnName+  where+    sortOnName [] = []+    sortOnName mappings =+        [ mapping+        | name <- sort (map mappingSpecName mappings)+        , mapping <- mappings+        , mappingSpecName mapping == name+        ]++uniqueSorted :: [Text] -> [Text]+uniqueSorted = sort . nub

@@ -0,0 +1,539 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++{- | Recursive, wire-aware differences for consumer-owned mapped types.++This module deliberately returns mapped findings rather than importing the+ordinary 'Change' type: 'Keiro.Dsl.Diff' owns compatibility vectors and turns+each complete mapped use path into the appropriate event, snapshot, or build+finding. Keeping that seam acyclic also makes the recursive comparison usable+by mutation coverage without rendering a report.+-}+module Keiro.Dsl.MappedDiff (+    MappedFinding (..),+    diffMapped,+    renderMappedSubject,+) where++import Data.List (find, nubBy, sortOn)+import Data.Map.Strict qualified as Map+import Data.Maybe (isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar+import Keiro.Dsl.TypeGraph+import Keiro.Dsl.Validate (DiagnosticCode (..))++data MappedFinding = MappedFinding+    { mfDeclaration :: !Name+    , mfLeaf :: !Text+    , mfCode :: !DiagnosticCode+    , mfDetail :: !Text+    , mfUsePaths :: ![UsePath]+    , mfOldUnknownFields :: !(Maybe UnknownFields)+    }+    deriving stock (Eq, Show)++{- | Compare valid old/new mapped graphs. A spec that cannot resolve has+already failed @check@; the ordinary differ therefore emits no speculative+mapped compatibility claim for it.+-}+diffMapped :: Spec -> Spec -> [MappedFinding]+diffMapped oldSpec newSpec = case (resolveTypeGraph oldSpec, resolveTypeGraph newSpec) of+    (Right oldGraph, Right newGraph) ->+        concatMap (uncurry (diffDeclaration oldGraph newGraph)) matched+            ++ map (addedDeclaration newGraph) added+            ++ map (removedDeclaration oldGraph) removed+      where+        oldDeclarations = tgDeclarations oldGraph+        newDeclarations = tgDeclarations newGraph+        matched =+            [ (oldDeclaration, newDeclaration)+            | (key, newDeclaration) <- Map.toList newDeclarations+            , oldDeclaration <- maybeToList (Map.lookup key oldDeclarations)+            ]+        added =+            [ (key, declaration)+            | (key, declaration) <- Map.toList newDeclarations+            , Map.notMember key oldDeclarations+            ]+        removed =+            [ (key, declaration)+            | (key, declaration) <- Map.toList oldDeclarations+            , Map.notMember key newDeclarations+            ]+    _ -> []++renderMappedSubject :: UsePath -> Text -> Text+renderMappedSubject path leaf =+    renderUsePath path <> if T.null leaf then "" else " " <> leaf++data DeclView+    = StructuralView !StructuralDecl !ShapeView+    | OpaqueView !OpaqueDecl++data ShapeView+    = RecordView !Name !UnknownFields ![ResolvedWireField]+    | EnumView ![WireEnum]+    | UnionView !UnionEncoding ![ResolvedWireArm]++data ExprView+    = ExprText+    | ExprInt+    | ExprBool+    | ExprNatural+    | ExprTime+    | ExprJson+    | ExprOptional !ExprView+    | ExprList !ExprView+    | ExprMap !ExprView+    | ExprRef !MappedKey+    deriving stock (Eq, Show)++declView :: ResolvedMappedDecl -> DeclView+declView =+    foldMappedDecl+        MappedDeclAlgebra+            { onStructuralDecl = \declaration shape -> StructuralView declaration (shapeView shape)+            , onOpaqueDecl = OpaqueView+            }++shapeView :: ResolvedMappedShape -> ShapeView+shapeView =+    foldMappedShape+        MappedShapeAlgebra+            { onRecord = RecordView+            , onEnum = EnumView+            , onUnion = UnionView+            }++exprView :: ResolvedTypeExpr -> ExprView+exprView =+    foldTypeExpr+        TypeExprAlgebra+            { onText = ExprText+            , onInt = ExprInt+            , onBool = ExprBool+            , onNatural = ExprNatural+            , onTime = ExprTime+            , onJson = ExprJson+            , onOptional = ExprOptional+            , onList = ExprList+            , onMap = ExprMap+            , onRef = ExprRef+            }++diffDeclaration :: TypeGraph -> TypeGraph -> ResolvedMappedDecl -> ResolvedMappedDecl -> [MappedFinding]+diffDeclaration oldGraph newGraph oldResolved newResolved =+    case (declView oldResolved, declView newResolved) of+        (StructuralView oldDeclaration oldShape, StructuralView newDeclaration newShape) ->+            metadataDiff paths oldDeclaration newDeclaration+                ++ diffShape paths name oldShape newShape+        (OpaqueView oldDeclaration, OpaqueView newDeclaration) ->+            opaqueMetadataDiff paths oldDeclaration newDeclaration+        _ ->+            [ finding+                paths+                name+                ""+                MappedModeCrossed+                "mapped declaration crossed the structural/opaque boundary; no structural proof can establish codec parity"+            ]+  where+    name = resolvedName newResolved+    paths = pathsFor oldGraph newGraph name++metadataDiff :: [UsePath] -> StructuralDecl -> StructuralDecl -> [MappedFinding]+metadataDiff paths oldDeclaration newDeclaration =+    [ finding+        paths+        name+        "haskell"+        MappedHaskellSourceChanged+        "consumer package, module, or type changed without changing declared wire identity; recompile every affected consumer"+    | sdHaskell oldDeclaration /= sdHaskell newDeclaration+    ]+        ++ [ finding+                paths+                name+                "binding"+                MappedBindingChanged+                "binding symbol or binding-version changed; diff cannot inspect binding behavior, so run the two-law, codec, and historical-fixture conformance suite"+           | (sdBinding oldDeclaration, sdBindingVersion oldDeclaration)+                /= (sdBinding newDeclaration, sdBindingVersion newDeclaration)+           ]+        ++ [ finding+                paths+                name+                "fixtures"+                MappedFixturesChanged+                "fixture evidence symbol changed; runtime wire policy is unchanged, but the complete conformance suite must run"+           | sdFixtures oldDeclaration /= sdFixtures newDeclaration+           ]+        ++ [ finding+                paths+                name+                "initial"+                MappedInitialChanged+                "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not"+           | sdInitial oldDeclaration /= sdInitial newDeclaration+           ]+        ++ [ finding+                paths+                name+                "canonical-type"+                MappedCanonicalTypeChanged+                "canonical type identity changed; rebuild generated projections and invalidate mapped snapshots while declared event bytes remain unchanged"+           | sdCanonical oldDeclaration /= sdCanonical newDeclaration+           ]+  where+    name = sdName newDeclaration++opaqueMetadataDiff :: [UsePath] -> OpaqueDecl -> OpaqueDecl -> [MappedFinding]+opaqueMetadataDiff paths oldDeclaration newDeclaration =+    [ finding+        paths+        name+        "haskell"+        MappedHaskellSourceChanged+        "consumer package, module, or type changed without changing the opaque codec claim; recompile every affected consumer"+    | odHaskell oldDeclaration /= odHaskell newDeclaration+    ]+        ++ [ finding+                paths+                name+                "codec"+                MappedOpaqueCodecChanged+                "opaque codec identity or version changed; Keiro cannot inspect the codec and historical payload compatibility is unproven"+           | (odCodecIdentity oldDeclaration, odCodecVersion oldDeclaration)+                /= (odCodecIdentity newDeclaration, odCodecVersion newDeclaration)+           ]+        ++ [ finding+                paths+                name+                "fixtures"+                MappedFixturesChanged+                "fixture evidence symbol changed; runtime codec identity is unchanged, but the complete conformance suite must run"+           | odFixtures oldDeclaration /= odFixtures newDeclaration+           ]+        ++ [ finding+                paths+                name+                "initial"+                MappedInitialChanged+                "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not"+           | odInitial oldDeclaration /= odInitial newDeclaration+           ]+  where+    name = odName newDeclaration++diffShape :: [UsePath] -> Name -> ShapeView -> ShapeView -> [MappedFinding]+diffShape paths declaration oldShape newShape = case (oldShape, newShape) of+    (RecordView oldConstructor oldUnknown oldFields, RecordView newConstructor newUnknown newFields) ->+        [ finding+            paths+            declaration+            "constructor"+            MappedRecordConstructorChanged+            "record constructor changed without changing the JSON wire identity; recompile affected consumers"+        | oldConstructor /= newConstructor+        ]+            ++ [ finding+                    paths+                    declaration+                    "unknown-fields"+                    MappedUnionEncodingChanged+                    "record unknown-fields policy changed; historical and mixed-version decoding posture is no longer the same"+               | oldUnknown /= newUnknown+               ]+            ++ diffRecord paths declaration oldUnknown oldFields newFields+    (EnumView oldEntries, EnumView newEntries) -> diffEnum paths declaration oldEntries newEntries+    (UnionView oldEncoding oldArms, UnionView newEncoding newArms) ->+        [ finding+            paths+            declaration+            "encoding"+            MappedUnionEncodingChanged+            "tagged-object encoding changed; version and upcast every affected private event root"+        | oldEncoding /= newEncoding+        ]+            ++ diffUnion paths declaration oldArms newArms+    _ ->+        [ finding+            paths+            declaration+            "shape"+            MappedUnionEncodingChanged+            "structural shape kind changed; version and upcast every affected private event root"+        ]++diffRecord :: [UsePath] -> Name -> UnknownFields -> [ResolvedWireField] -> [ResolvedWireField] -> [MappedFinding]+diffRecord paths declaration oldUnknown oldFields newFields =+    concatMap (uncurry (diffField paths declaration)) matched+        ++ map addedFinding added+        ++ map removedFinding removed+  where+    (matched, added, removed) = pairFields oldFields newFields+    addedFinding field =+        (findingWithUnknown paths declaration (fieldLeaf field) code detail (Just oldUnknown))+      where+        hasDefault = isJustValue (rwfOnMissing field)+        code+            | hasDefault = MappedFieldAddedWithDefault+            | otherwise = MappedFieldAddedNoDefault+        oldPolicy = case oldUnknown of RejectUnknown -> "reject"; IgnoreUnknown -> "ignore"+        detail+            | hasDefault =+                "field added with an explicit on-missing default; new readers preserve old meaning, while old readers use unknown-fields="+                    <> oldPolicy+            | otherwise =+                "field added without an on-missing default; old payloads do not contain it, so version and upcast every affected private event root"+    removedFinding field =+        finding+            paths+            declaration+            (fieldLeaf field)+            MappedFieldRemoved+            "field removed; replay-relevant removal remains breaking even when a tolerant decoder would ignore the historical key"++pairFields :: [ResolvedWireField] -> [ResolvedWireField] -> ([(ResolvedWireField, ResolvedWireField)], [ResolvedWireField], [ResolvedWireField])+pairFields oldFields newFields = (exact <> fallback, added, removed)+  where+    exact =+        [ (oldField, newField)+        | newField <- newFields+        , oldField <- maybeToList (find ((== rwfHaskell newField) . rwfHaskell) oldFields)+        ]+    matchedOld = map (rwfHaskell . fst) exact+    matchedNew = map (rwfHaskell . snd) exact+    unmatchedOld = [field | field <- oldFields, rwfHaskell field `notElem` matchedOld]+    unmatchedNew = [field | field <- newFields, rwfHaskell field `notElem` matchedNew]+    fallback =+        [ (oldField, newField)+        | newField <- unmatchedNew+        , oldField <- maybeToList (find ((== rwfKey newField) . rwfKey) unmatchedOld)+        ]+    fallbackOld = map (rwfHaskell . fst) fallback+    fallbackNew = map (rwfHaskell . snd) fallback+    removed = [field | field <- unmatchedOld, rwfHaskell field `notElem` fallbackOld]+    added = [field | field <- unmatchedNew, rwfHaskell field `notElem` fallbackNew]++diffField :: [UsePath] -> Name -> ResolvedWireField -> ResolvedWireField -> [MappedFinding]+diffField paths declaration oldField newField =+    [ finding+        paths+        declaration+        leaf+        MappedWireKeyChanged+        ("wire key changed '" <> rwfKey oldField <> "' -> '" <> rwfKey newField <> "'; version and upcast every affected private event root")+    | rwfKey oldField /= rwfKey newField+    ]+        ++ [ finding+                paths+                declaration+                leaf+                MappedPresenceChanged+                "field presence changed between required and optional; historical decode policy changed"+           | rwfPresence oldField /= rwfPresence newField+           ]+        ++ defaultChanges+        ++ diffExpr paths declaration (leaf <> ".type") (rwfType oldField) (rwfType newField)+  where+    leaf = fieldLeaf newField+    defaultChanges = case (rwfOnMissing oldField, rwfOnMissing newField) of+        (Just _, Nothing) ->+            [ finding+                paths+                declaration+                leaf+                MappedDefaultRemoved+                "on-missing default was removed; old payloads may no longer decode with preserved meaning"+            ]+        (oldDefault, newDefault)+            | oldDefault /= newDefault ->+                [ finding+                    paths+                    declaration+                    leaf+                    MappedDefaultChanged+                    "on-missing default changed; the same historical bytes now construct a different consumer value"+                ]+        _ -> []++diffExpr :: [UsePath] -> Name -> Text -> ResolvedTypeExpr -> ResolvedTypeExpr -> [MappedFinding]+diffExpr paths declaration leaf oldExpression newExpression =+    case (exprView oldExpression, exprView newExpression) of+        (oldView, newView)+            | oldView == newView -> []+        (ExprOptional oldValue, ExprOptional newValue) -> recurse ".optional" oldValue newValue+        (ExprList oldValue, ExprList newValue) -> recurse "[]" oldValue newValue+        (ExprMap oldValue, ExprMap newValue) -> recurse "{}" oldValue newValue+        (ExprOptional _, _) -> nullability+        (_, ExprOptional _) -> nullability+        _ ->+            [ finding+                paths+                declaration+                leaf+                MappedFieldTypeChanged+                "wire type changed; version and upcast every affected private event root"+            ]+  where+    recurse suffix oldView newView = diffExprViews paths declaration (leaf <> suffix) oldView newView+    nullability =+        [ finding+            paths+            declaration+            leaf+            MappedNullabilityChanged+            "Optional nullability changed; historical null and non-null meanings are no longer stable"+        ]++diffExprViews :: [UsePath] -> Name -> Text -> ExprView -> ExprView -> [MappedFinding]+diffExprViews paths declaration leaf oldView newView = case (oldView, newView) of+    _ | oldView == newView -> []+    (ExprOptional oldValue, ExprOptional newValue) -> diffExprViews paths declaration (leaf <> ".optional") oldValue newValue+    (ExprList oldValue, ExprList newValue) -> diffExprViews paths declaration (leaf <> "[]") oldValue newValue+    (ExprMap oldValue, ExprMap newValue) -> diffExprViews paths declaration (leaf <> "{}") oldValue newValue+    (ExprOptional _, _) -> nullability+    (_, ExprOptional _) -> nullability+    _ -> [finding paths declaration leaf MappedFieldTypeChanged "wire type changed; version and upcast every affected private event root"]+  where+    nullability = [finding paths declaration leaf MappedNullabilityChanged "Optional nullability changed; historical null and non-null meanings are no longer stable"]++diffEnum :: [UsePath] -> Name -> [WireEnum] -> [WireEnum] -> [MappedFinding]+diffEnum paths declaration oldEntries newEntries =+    [ finding+        paths+        declaration+        (enumLeaf newEntry)+        MappedEnumSpellingChanged+        ("enum wire spelling changed '" <> weTag oldEntry <> "' -> '" <> weTag newEntry <> "'")+    | newEntry <- newEntries+    , oldEntry <- maybeToList (find ((== weCtor newEntry) . weCtor) oldEntries)+    , weTag oldEntry /= weTag newEntry+    ]+        ++ [ finding+                paths+                declaration+                (enumLeaf entry)+                MappedEnumValueAdded+                "enum value added; existing history remains readable, but deploy readers before writers emit the new spelling; a future public surface exposing this closed enum would classify the addition as consumer-breaking"+           | entry <- newEntries+           , isNothing (find ((== weCtor entry) . weCtor) oldEntries)+           ]+        ++ [ finding+                paths+                declaration+                (enumLeaf entry)+                MappedEnumValueRemoved+                "enum value removed; historical payloads carrying its wire spelling no longer decode"+           | entry <- oldEntries+           , isNothing (find ((== weCtor entry) . weCtor) newEntries)+           ]++diffUnion :: [UsePath] -> Name -> [ResolvedWireArm] -> [ResolvedWireArm] -> [MappedFinding]+diffUnion paths declaration oldArms newArms =+    concatMap (uncurry pairedArm) matched+        ++ map addedArm added+        ++ map removedArm removed+  where+    (matched, added, removed) = pairArms oldArms newArms+    pairedArm oldArm newArm =+        [ finding+            paths+            declaration+            (armLeaf newArm)+            MappedArmTagChanged+            ("union arm tag changed '" <> rwaTag oldArm <> "' -> '" <> rwaTag newArm <> "'")+        | rwaTag oldArm /= rwaTag newArm+        ]+            ++ case (rwaPayload oldArm, rwaPayload newArm) of+                (Nothing, Nothing) -> []+                (Just oldPayload, Just newPayload) -> diffExpr paths declaration (armLeaf newArm <> ".payload") oldPayload newPayload+                _ -> [finding paths declaration (armLeaf newArm) MappedFieldTypeChanged "union arm payload presence changed; historical tagged objects no longer share one wire shape"]+    addedArm arm = finding paths declaration (armLeaf arm) MappedArmAdded "union arm added; existing history remains readable, but older binaries cannot read the new arm once emitted, so deploy readers before writers; a future public surface exposing this closed union would classify the addition as consumer-breaking"+    removedArm arm = finding paths declaration (armLeaf arm) MappedArmRemoved "union arm removed; historical tagged objects carrying that tag no longer decode"++pairArms :: [ResolvedWireArm] -> [ResolvedWireArm] -> ([(ResolvedWireArm, ResolvedWireArm)], [ResolvedWireArm], [ResolvedWireArm])+pairArms oldArms newArms = (exact <> fallback, added, removed)+  where+    exact =+        [ (oldArm, newArm)+        | newArm <- newArms+        , oldArm <- maybeToList (find ((== rwaCtor newArm) . rwaCtor) oldArms)+        ]+    matchedOld = map (rwaCtor . fst) exact+    matchedNew = map (rwaCtor . snd) exact+    unmatchedOld = [arm | arm <- oldArms, rwaCtor arm `notElem` matchedOld]+    unmatchedNew = [arm | arm <- newArms, rwaCtor arm `notElem` matchedNew]+    fallback =+        [ (oldArm, newArm)+        | newArm <- unmatchedNew+        , oldArm <- maybeToList (find ((== rwaTag newArm) . rwaTag) unmatchedOld)+        ]+    fallbackOld = map (rwaCtor . fst) fallback+    fallbackNew = map (rwaCtor . snd) fallback+    removed = [arm | arm <- unmatchedOld, rwaCtor arm `notElem` fallbackOld]+    added = [arm | arm <- unmatchedNew, rwaCtor arm `notElem` fallbackNew]++addedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding+addedDeclaration _ (key, _) =+    finding+        []+        (unMappedKey key)+        ""+        MappedDeclAdded+        "new mapped declaration; use-site changes retain their own compatibility classification"++removedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding+removedDeclaration graph (key, _) =+    finding+        (usePaths graph (unMappedKey key))+        (unMappedKey key)+        ""+        MappedDeclRemoved+        "mapped declaration removed; persisted roots using its historical decoder require migration, while an unused source-only declaration requires consumer rebuild only"++pathsFor :: TypeGraph -> TypeGraph -> Name -> [UsePath]+pathsFor oldGraph newGraph name =+    nubBy sameRendered . sortOn renderUsePath $ usePaths oldGraph name <> usePaths newGraph name+  where+    sameRendered left right = renderUsePath left == renderUsePath right++resolvedName :: ResolvedMappedDecl -> Name+resolvedName =+    foldMappedDecl+        MappedDeclAlgebra+            { onStructuralDecl = \declaration _ -> sdName declaration+            , onOpaqueDecl = odName+            }++fieldLeaf :: ResolvedWireField -> Text+fieldLeaf field = ".field " <> rwfHaskell field <> "[\"" <> rwfKey field <> "\"]"++armLeaf :: ResolvedWireArm -> Text+armLeaf arm = ".arm " <> rwaCtor arm <> "[\"" <> rwaTag arm <> "\"]"++enumLeaf :: WireEnum -> Text+enumLeaf entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]"++finding :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> MappedFinding+finding paths declaration leaf code detail =+    findingWithUnknown paths declaration leaf code detail Nothing++findingWithUnknown :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> Maybe UnknownFields -> MappedFinding+findingWithUnknown paths declaration leaf code detail unknownFields =+    MappedFinding+        { mfDeclaration = declaration+        , mfLeaf = leaf+        , mfCode = code+        , mfDetail = detail+        , mfUsePaths = paths+        , mfOldUnknownFields = unknownFields+        }++isJustValue :: Maybe a -> Bool+isJustValue = not . isNothing++maybeToList :: Maybe a -> [a]+maybeToList = maybe [] pure

@@ -14,6 +14,7 @@  import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) import Data.Char (isAlpha, isAlphaNum, isAscii, isDigit, isUpper)+import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Void (Void)@@ -118,6 +119,7 @@     , "id"     , "enum"     , "rule"+    , "mapped"     , "ex"     , "aggregate"     , "regs"@@ -136,6 +138,7 @@     , "status-map"     , "true"     , "false"+    , "retiring"     , "deprecated"     , "upcast"     , "from"@@ -232,6 +235,7 @@     = TIId IdDecl     | TIEnum EnumDecl     | TIRule RuleDecl+    | TIMapped MappedDecl     | TINode Node  pSpec :: P Spec@@ -249,6 +253,7 @@             , specIds = [d | TIId d <- items]             , specEnums = [d | TIEnum d <- items]             , specRules = [d | TIRule d <- items]+            , specMapped = [d | TIMapped d <- items]             , specNodes = [n | TINode n <- items]             } @@ -285,6 +290,7 @@         [ TIId <$> pIdDecl         , TIEnum <$> pEnumDecl         , TIRule <$> pRuleDecl+        , TIMapped <$> pMappedDecl         , TINode . NRouter <$> pRouter         , TINode . NProcess <$> pProcess         , TINode . NContract <$> pContract@@ -350,6 +356,243 @@         pure (c, e)  --------------------------------------------------------------------------------+-- Consumer-owned mapped types (EP-149)+--------------------------------------------------------------------------------++data MappedKind = MappedRecord | MappedEnum | MappedUnion++data MappedClause+    = MCHaskell HaskellSource+    | MCBinding Text+    | MCBindingVersion Text+    | MCCanonical Text+    | MCFixtures Text+    | MCInitial Text+    | MCCodec Text+    | MCCodecVersion Text+    | MCShape MappedShape++pMappedDecl :: P MappedDecl+pMappedDecl = do+    loc <- getLoc+    keyword "mapped"+    choice [pStructural loc, pOpaque loc]+  where+    pStructural loc = do+        keyword "structural"+        kind <-+            choice+                [ MappedRecord <$ keyword "record"+                , MappedEnum <$ keyword "enum"+                , MappedUnion <$ keyword "union"+                ]+        name <- ident+        clauses <- braces (many (pStructuralClause 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+        canonical <- oneClause "canonical-type" (\case MCCanonical value -> Just value; _ -> Nothing) clauses+        fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses+        initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses+        shape <- requiredClause "wire" (\case MCShape value -> Just value; _ -> Nothing) clauses+        pure+            MappedStructural+                { msName = name+                , msHaskell = hs+                , msBinding = binding+                , msBindingVersion = bindingVersion+                , msCanonical = canonical+                , msFixtures = fixtures+                , msInitial = initial+                , msShape = shape+                , msLoc = loc+                }++    pOpaque loc = do+        keyword "opaque"+        name <- ident+        clauses <- braces (many pOpaqueClause)+        hs <- oneClause "haskell" (\case MCHaskell value -> Just value; _ -> Nothing) clauses+        codec <- oneClause "codec" (\case MCCodec value -> Just value; _ -> Nothing) clauses+        version <- oneClause "version" (\case MCCodecVersion value -> Just value; _ -> Nothing) clauses+        fixtures <- oneClause "fixtures" (\case MCFixtures value -> Just value; _ -> Nothing) clauses+        initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses+        pure+            MappedOpaque+                { moName = name+                , moHaskell = hs+                , moCodecId = codec+                , moCodecVersion = version+                , moFixtures = fixtures+                , moInitial = initial+                , moLoc = loc+                }++pStructuralClause :: MappedKind -> P MappedClause+pStructuralClause kind =+    choice+        [ MCHaskell <$> pHaskellSource+        , MCBindingVersion <$> pQuotedFact "binding-version"+        , MCBinding <$> pQuotedFact "binding"+        , MCCanonical <$> pQuotedFact "canonical-type"+        , MCFixtures <$> pQuotedFact "fixtures"+        , MCInitial <$> pQuotedFact "initial"+        , MCShape <$> pMappedShape kind+        ]++pOpaqueClause :: P MappedClause+pOpaqueClause =+    choice+        [ MCHaskell <$> pHaskellSource+        , MCCodec <$> pQuotedFact "codec"+        , MCCodecVersion <$> pQuotedFact "version"+        , MCFixtures <$> pQuotedFact "fixtures"+        , MCInitial <$> pQuotedFact "initial"+        ]++pHaskellSource :: P HaskellSource+pHaskellSource = do+    keyword "haskell"+    keyword "package"+    _ <- symbol "="+    packageName <- wireWord+    keyword "module"+    _ <- symbol "="+    moduleName <- pModulePrefix+    keyword "type"+    _ <- symbol "="+    typeName <- ident+    pure HaskellSource{hsPackage = packageName, hsModule = moduleName, hsType = typeName}++pQuotedFact :: Text -> P Text+pQuotedFact factName = keyword factName *> symbol "=" *> stringLit++pMappedShape :: MappedKind -> P MappedShape+pMappedShape kind = do+    keyword "wire"+    case kind of+        MappedRecord -> do+            keyword "object"+            keyword "constructor"+            _ <- symbol "="+            constructor <- ident+            unknownFields <- pUnknownFieldsFact+            fields <- braces (many pWireField)+            pure (ShapeRecord constructor unknownFields fields)+        MappedEnum -> do+            keyword "string"+            ShapeEnum <$> braces (many pWireEnum)+        MappedUnion -> do+            keyword "tagged-object"+            keyword "tag"+            _ <- symbol "="+            tagField <- stringLit+            keyword "contents"+            _ <- symbol "="+            contentsField <- stringLit+            unknownFields <- pUnknownFieldsFact+            arms <- braces (many pWireArm)+            pure (ShapeUnion (TaggedObject tagField contentsField unknownFields) arms)++pUnknownFieldsFact :: P UnknownFields+pUnknownFieldsFact = do+    keyword "unknown-fields"+    _ <- symbol "="+    choice [RejectUnknown <$ keyword "reject", IgnoreUnknown <$ keyword "ignore"]++pWireField :: P WireField+pWireField = do+    loc <- getLoc+    haskellName <- ident+    keyword "as"+    wireKey <- stringLit+    _ <- symbol ":"+    fieldType <- pMappedTypeExpr+    presence <- choice [PRequired <$ keyword "required", POptional <$ keyword "optional"]+    onMissing <- optional (keyword "on-missing" *> symbol "=" *> pOnMissing)+    pure+        WireField+            { wfHaskell = haskellName+            , wfKey = wireKey+            , wfType = fieldType+            , wfPresence = presence+            , wfOnMissing = onMissing+            , wfLoc = loc+            }++pWireEnum :: P WireEnum+pWireEnum = do+    loc <- getLoc+    constructor <- ident+    keyword "as"+    wireTag <- stringLit+    pure WireEnum{weCtor = constructor, weTag = wireTag, weLoc = loc}++pWireArm :: P WireArm+pWireArm = do+    loc <- getLoc+    constructor <- ident+    keyword "as"+    wireTag <- stringLit+    payload <- optional (symbol ":" *> pMappedTypeExpr)+    pure WireArm{waCtor = constructor, waTag = wireTag, waPayload = payload, waLoc = loc}++pMappedTypeExpr :: P TypeExpr+pMappedTypeExpr =+    choice+        [ TOptional <$> (keyword "Optional" *> pTypeArgument)+        , TList <$> (keyword "List" *> pTypeArgument)+        , TMap <$> (keyword "Map" *> pTypeArgument)+        , TText <$ keyword "Text"+        , TInt <$ keyword "Int"+        , TBool <$ keyword "Bool"+        , TNatural <$ keyword "Natural"+        , TTime <$ (keyword "Time" <|> keyword "UTCTime")+        , TJson <$ keyword "Json"+        , TRef <$> ident+        ]+  where+    pTypeArgument = parens pMappedTypeExpr <|> pTypeAtom+    pTypeAtom =+        choice+            [ TText <$ keyword "Text"+            , TInt <$ keyword "Int"+            , TBool <$ keyword "Bool"+            , TNatural <$ keyword "Natural"+            , TTime <$ (keyword "Time" <|> keyword "UTCTime")+            , TJson <$ keyword "Json"+            , TRef <$> ident+            ]++pOnMissing :: P OnMissing+pOnMissing =+    choice+        [ OmNull <$ keyword "null"+        , OmEmptyList <$ (symbol "[" *> symbol "]")+        , OmEmptyMap <$ (symbol "{" *> symbol "}")+        , OmBool True <$ keyword "true"+        , OmBool False <$ keyword "false"+        , OmText <$> stringLit+        , OmInt <$> integerLiteral+        , OmCtor <$> ident+        ]++integerLiteral :: P Integer+integerLiteral = lexeme (L.signed (pure ()) L.decimal)++oneClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P (Maybe a)+oneClause clauseName select clauses =+    case mapMaybe select clauses of+        [] -> pure Nothing+        [value] -> pure (Just value)+        _ -> fail ("duplicate " <> clauseName <> " clause in mapped declaration")++requiredClause :: String -> (MappedClause -> Maybe a) -> [MappedClause] -> P a+requiredClause clauseName select clauses = do+    found <- oneClause clauseName select clauses+    maybe (fail ("missing " <> clauseName <> " clause in mapped structural declaration")) pure found++-------------------------------------------------------------------------------- -- Aggregate node -------------------------------------------------------------------------------- @@ -428,6 +671,10 @@     -- 'pTransition'.     pStateDecl = try $ do         loc <- getLoc+        -- A @replay-only@ transition marker directly after the states line+        -- must not be swallowed: 'ident' would take @replay@ (hyphens are+        -- not identifier characters) and strand @-only@.+        notFollowedBy (keyword "replay-only")         n <- ident         term <- option False (True <$ symbol "!")         notFollowedBy (symbol "--")@@ -477,7 +724,14 @@ pEvent :: P Event pEvent = do     loc <- getLoc-    dep <- option False (True <$ keyword "deprecated")+    (retiring, deprecated) <-+        option+            (False, False)+            ( choice+                [ (True, False) <$ keyword "retiring"+                , (False, True) <$ keyword "deprecated"+                ]+            )     keyword "event"     name <- ident     ver <- option 1 pVersion@@ -493,7 +747,8 @@             , evBody = body             , evVersion = ver             , evUpcastFrom = up-            , evDeprecated = dep+            , evRetiring = retiring+            , evDeprecated = deprecated             , evLoc = loc             }   where@@ -1458,6 +1713,9 @@ pTransition = do     startOffset <- getOffset     loc <- getLoc+    -- Plan 143: a @replay-only@ prefix marks the transition as serving+    -- inversion only; it lowers to a keiki 'ReplayOnly' edge.+    mode <- option TmLive (TmReplayOnly <$ keyword "replay-only")     src <- ident     _ <- symbol "--"     cmd <- ident@@ -1482,6 +1740,7 @@             , tWrites = [(r, e) | CWrite r e <- clauses]             , tEmits = [n | CEmit n <- clauses]             , tGoto = gt+            , tMode = mode             , tLoc = loc             }