keiro-dsl 0.5.0.0 → 0.6.0.0

raw patch · 162 files changed

+31287/−24024 lines, 162 filesdep +mmzk-typeiddep ~aesondep ~containersdep ~keikiPVP ok

version bump matches the API change (PVP)

Dependencies added: mmzk-typeid

Dependency ranges changed: aeson, containers, keiki, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +112/−0
• app/Main.hs +528/−460
• bench/structural-codec/Main.hs +59/−59
• keiro-dsl.cabal +102/−13
• src/Keiro/Dsl/AggregateType.hs +413/−0
• src/Keiro/Dsl/CodecCompare.hs +461/−463
• src/Keiro/Dsl/Coverage.hs +465/−464
• src/Keiro/Dsl/Diff.hs +2172/−1989
• src/Keiro/Dsl/DiffReport.hs +280/−277
• src/Keiro/Dsl/ExplainBindings.hs +311/−192
• src/Keiro/Dsl/Expression.hs +584/−0
• src/Keiro/Dsl/FoldFingerprint.hs +174/−102
• src/Keiro/Dsl/Goldens.hs +170/−148
• src/Keiro/Dsl/Grammar.hs +1228/−1170
• src/Keiro/Dsl/Harness.hs +1188/−1077
• src/Keiro/Dsl/LanguageVersion.hs +218/−0
• src/Keiro/Dsl/Manifest.hs +114/−80
• src/Keiro/Dsl/MappedConsumer.hs +213/−118
• src/Keiro/Dsl/MappedDiff.hs +377/−376
• src/Keiro/Dsl/NominalType.hs +344/−0
• src/Keiro/Dsl/Parser.hs +2105/−1792
• src/Keiro/Dsl/PrettyPrint.hs +483/−403
• src/Keiro/Dsl/ReadModelShape.hs +36/−37
• src/Keiro/Dsl/ReplayImpact.hs +178/−134
• src/Keiro/Dsl/Scaffold.hs +4417/−3437
• src/Keiro/Dsl/ScaffoldRecord.hs +91/−75
• src/Keiro/Dsl/ScaffoldRun.hs +362/−319
• src/Keiro/Dsl/Skeleton.hs +308/−307
• src/Keiro/Dsl/TypeGraph.hs +404/−395
• src/Keiro/Dsl/Validate.hs +2493/−2242
• src/Keiro/Dsl/Workspace.hs +1426/−1296
• src/Keiro/Dsl/WorkspaceAdoption.hs +190/−194
• src/Keiro/Dsl/WorkspaceDiff.hs +105/−86
• src/Keiro/Dsl/WorkspaceRecord.hs +255/−210
• src/Keiro/Dsl/WorkspaceScaffold.hs +441/−410
• test/Main.hs +6350/−5598
• test/conformance-aggregate-scalars/AggregateScalars/ScalarLedger/Holes.hs +72/−0
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ReplayAudit.hs +24/−0
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Codec.hs +49/−0
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Domain.hs +58/−0
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/EventStream.hs +58/−0
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Harness.hs +58/−0
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Projection.hs +2/−0
• test/conformance-aggregate-scalars/Main.hs +114/−0
• test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs +0/−1
• test/conformance-codec-compare/Main.hs +0/−1
• test/conformance-coldstart/Generated/Billing/Subscription/Codec.hs +0/−1
• test/conformance-coldstart/Generated/Billing/Subscription/Domain.hs +0/−1
• test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs +0/−1
• test/conformance-coldstart/Generated/Billing/Subscription/Projection.hs +0/−1
• test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs +0/−1
• test/conformance-contract/Main.hs +0/−1
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/Queue.hs +0/−1
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +0/−1
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueuePolicy.hs +0/−1
• test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs +0/−1
• test/conformance-dispatch-full/Main.hs +0/−1
• test/conformance-intake-full/Main.hs +0/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Codec.hs +0/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Domain.hs +0/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs +0/−1
• test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/Router.hs +0/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModel.hs +0/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModelTable.hs +0/−1
• test/conformance-newsurface/Main.hs +0/−1
• test/conformance-newsurface/TransferRouting/HospitalTransferRouter/RouterValue.hs +0/−1
• test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs +19/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs +80/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Domain.hs +71/−0
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalProjections.hs +69/−0
• test/conformance-nominal-scalars/Main.hs +281/−0
• test/conformance-nominal-scalars/NominalConformance/Bindings.hs +109/−0
• test/conformance-nominal-scalars/NominalConformance/Domain.hs +64/−0
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Codec.hs +0/−1
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Domain.hs +0/−1
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Projection.hs +0/−1
• test/conformance-process-full/Generated/SurgeDemo/Surge/Codec.hs +0/−1
• test/conformance-process-full/Generated/SurgeDemo/Surge/Domain.hs +0/−1
• test/conformance-process-full/Generated/SurgeDemo/Surge/Projection.hs +0/−1
• test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/Process.hs +0/−1
• test/conformance-process-full/Main.hs +0/−1
• test/conformance-process-full/SurgeDemo/SurgeFlow/Manager.hs +0/−1
• test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs +0/−1
• test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs +0/−1
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/Queue.hs +0/−1
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +0/−1
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueuePolicy.hs +0/−1
• test/conformance-queue/Generated/HospitalCapacity/Reservation_work/Queue.hs +0/−1
• test/conformance-queue/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +0/−1
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModel.hs +0/−1
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModelTable.hs +0/−1
• test/conformance-readmodel-runtime/Main.hs +0/−1
• test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs +0/−1
• test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs +0/−1
• test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs +0/−1
• test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs +0/−1
• test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs +0/−1
• test/conformance-router-full/Generated/IncidentPaging/PagingRouter/Router.hs +0/−1
• test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/Router.hs +0/−1
• test/conformance-scalar-expressions/AggregateScalarExpressions/ScalarAccount/Holes.hs +53/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ReplayAudit.hs +24/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs +110/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs +121/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/EventStream.hs +58/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Expressions.hs +58/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs +147/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Projection.hs +2/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs +77/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Structural/Shape/Limits.hs +13/−0
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralProjections.hs +43/−0
• test/conformance-scalar-expressions/Main.hs +235/−0
• test/conformance-scalar-expressions/ScalarExpressions/Bindings.hs +39/−0
• test/conformance-scalar-expressions/ScalarExpressions/Domain.hs +22/−0
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Codec.hs +0/−1
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Domain.hs +0/−1
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs +0/−1
• test/conformance-skeletons/SkelContract/Generated/MyService/MyContract/Contract.hs +0/−1
• test/conformance-skeletons/SkelEmit/Generated/MyService/MyContract/Contract.hs +0/−1
• test/conformance-skeletons/SkelIntake/Generated/MyService/MyContract/Contract.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Codec.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Domain.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/Process.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/ProcessHarness.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Codec.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Domain.hs +0/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModel.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModelTable.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/Queue.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueueCodec.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueuePolicy.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModel.hs +0/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModelTable.hs +0/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Codec.hs +0/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Domain.hs +0/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs +0/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/PagingRouter/Router.hs +0/−1
• test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowFacts.hs +0/−1
• test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowRuntime.hs +0/−2
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs +0/−1
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs +0/−1
• test/conformance-snapshot/Main.hs +0/−1
• test/conformance-structural/Conformance/Structural/Bindings.hs +0/−1
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs +0/−1
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs +0/−1
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs +0/−1
• test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs +0/−2
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs +0/−1
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs +0/−1
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs +0/−1
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs +0/−1
• test/conformance-v2/HospitalCapacity/Reservation/Holes.hs +0/−1
• test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs +0/−2
• test/conformance-workflow-full/HospitalCapacity/HospitalTransferReservation/WorkflowBody.hs +0/−1
• test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs +0/−2
• test/conformance-workflow-runtime/Main.hs +0/−1
• test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs +0/−1
• test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs +0/−1
• test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs +0/−1
• test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs +0/−1
• test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs +0/−1

@@ -6,6 +6,118 @@  ## [Unreleased] +## 0.6.0.0 — 2026-07-31++### Breaking Changes++- `DiagnosticCode` gains `AggregateTypeUnknown`,+  `AggregateTypeUnsupportedAtUse`, `AggregateRegisterInitialInvalid`,+  `AggregateGuardTypeMismatch`, `AggregateGuardCapabilityUnsupported`,+  `WorkspaceLanguageVersionMismatch`, and `SourceLanguageDeclarationChanged`.+  The additions are append-only, but exhaustive matches must be extended.+- `DiagnosticCode` also gains the nominal-check codes+  `NominalMissingIngredient`, `NominalInvalidHaskellSource`,+  `NominalInvalidQualifiedName`, `NominalInvalidIdentity`,+  `NominalInvalidIdPrefix`, `NominalUnsupportedRepresentation`,+  `NominalEmptyEnumRepresentation`, `NominalMissingInitialValue`, and+  `NominalNameCollision`, plus the nominal diff codes+  `NominalBindingChanged`, `NominalFixturesChanged`,+  `NominalCanonicalTypeChanged`, `NominalInitialChanged`,+  `NominalRepresentationChanged`, and `NominalIdDecoderTightened`.+- `DiagnosticCode` gains `AggregateExpressionRootUnknown`,+  `AggregateExpressionRootAmbiguous`, `AggregateExpressionPathInvalid`,+  `AggregateExpressionPathUnsupported`, `AggregateExpressionLiteralNeedsType`,+  `AggregateExpressionLiteralInvalid`,+  `AggregateExpressionOperandTypeMismatch`,+  `AggregateExpressionOperatorUnsupported`,+  `AggregateExpressionBooleanRequired`,+  `AggregateExpressionGuardBoolRequired`,+  `AggregateExpressionWriteTargetUnknown`,+  `AggregateExpressionWriteTypeMismatch`,+  `AggregateTransitionOwnershipConflict`, and+  `CollectionExpressionUnsupported`. The additions are append-only, but+  exhaustive matches must be extended.+- The public expression AST gains located arithmetic, scalar literals, explicit+  roots/paths, and transition implementation ownership. Exhaustive matches over+  `Expr`, `TypeExpr`, or transition implementation must be extended.+- Aggregate command/event fields now use the located `AggregateField` type and+  aggregate register types use `TypeExpr` instead of a raw `Name`. The library+  requires the exact-Integer/total-Natural `keiki >=0.6 && <0.7` and+  `keiki-codec-json >=0.6 && <0.7` releases.++### New Features++- Adds language version 2 syntax for binding direct aggregate IDs, enums, and+  nominal scalar wrappers to consumer-owned Haskell types. Version 1 and+  legacy-unversioned sources reject these declarations at source-language+  dispatch. The `pretty` command is an explicit alias for canonical parsing and+  rendering.+- Adds the public total `Keiro.Codec.Nominal` binding/fixture API, a checked+  nominal registry, generated prefix-safe `KindID` codecs, closed private enum+  representations, built-in scalar codecs, create-once binding skeletons, and+  context-level nominal scalar projections. Consumer-owned registers retain+  the existing consumer-JSON snapshot cache boundary.+- Nominal consumer provenance is fingerprinted and diff-visible, persisted in+  additive `nominal-mapping` scaffold/workspace rows, and included in generated+  package requirements. Bound-ID adoption at an existing event use reports a+  named decoder-tightening historical-read advisory and targeted replay audit.+- Adds a compiled nominal conformance ring with binding laws, pinned wire bytes,+  malformed/wrong-prefix ID and unknown-enum rejection, snapshot and canonical+  identity checks, projection agreement, forward/replay parity, mutation gates,+  and a compile-fail partial-inverse fixture.+- Adds authoritative version-2 scalar aggregate expressions. Guards and writes+  accept typed `reg.`/`cmd.` roots, required structural scalar paths, all scalar+  literal families, exact `Integer` `+`/`-`/`*`, and total `Natural`+  `+`/monus/`*`. Machine-`Int` arithmetic, coercion, division/remainder, Time+  arithmetic, predicate-valued Bool writes, and collection expressions fail+  before scaffolding.+- Adds generated per-aggregate `Expressions` and `Transducer` modules. Every+  version-2 transition is exclusively generated-owned or explicitly+  `implementation hole`; Hole transitions retain a generated structural+  envelope, require a per-transition `FoldVersion`, and expose conservative+  ownership/predicate-verification reports where opaque terms remain+  unverified. Version-1 generated output remains frozen.+- Adds a compiled scalar-expression conformance service with a 360-case oracle,+  concrete/symbolic/replay/snapshot agreement, all scalar literal families,+  Natural `2 - 5 = 0`, required structural projection identity, and eight+  mutation sentinels for arithmetic, authority, envelope, fold-version, and+  verification drift.++- Adds an explicit source-language contract. A first-significant-clause+  `language keiro-dsl 1` preamble selects the frozen released v1 parser before+  body parsing; unsupported future versions fail at that boundary. Unversioned+  input remains readable as `legacy-unversioned` with effective version 1 and+  is never silently rewritten by parse/pretty.+- Adds `Keiro.Dsl.LanguageVersion`, provenance-preserving parsing/rendering,+  `keiro-dsl inspect FILE --format=json`, and canonical per-member workspace+  inspection. Workspace composition compares effective versions before graph+  merge while keeping the merged `Spec` semantic.+- Single-file and workspace scaffold records now carry additive source-language+  rows, report provenance drift, and interpret missing rows from older records+  as legacy. Source-aware diff reports declaration-only changes with an+  all-compatible vector and no-semantic-action remedy; generated bytes, fold+  fingerprints, and replay impact remain unchanged.+- Every `new <kind>` skeleton and ordinary checked-in `.keiro` fixture now+  declares version 1. Dedicated legacy, future, malformed, zero, duplicate, and+  misplaced fixtures preserve compatibility and rejection coverage. Automated+  upgrades remain deferred to IR-5.+- Adds `Keiro.Dsl.AggregateType`, the single resolution and capability policy+  used by aggregate validation, Haskell lowering, imports, packages, JSON and+  snapshot samples, fold fingerprints, diffs, replay impact, and scaffold+  refusals.+- Direct aggregate `Time` and `Natural` fields and registers now check,+  scaffold, compile, encode, snapshot, and replay. `Time`/`UTCTime` normalize+  to `Time` and lower to exact `UTCTime` constructors; Natural accepts only+  non-negative integral initials. Equality and ordering are checked against+  Keiki's released symbolic capabilities. Version 1 retains the original+  no-arithmetic grammar; version 2 adds only the exact/total arithmetic listed+  above.+- Direct aggregate `Json` and container shapes now parse far enough to receive+  a located remediation toward `mapped structural`, and malformed scalar+  initials, mismatched comparisons, and unsupported ordering fail during+  `check`. Generated imports and Cabal dependencies remain type-directed and+  minimal.+ ## 0.5.0.0 — 2026-07-31  ### Breaking Changes

@@ -1,26 +1,29 @@-{- | The @keiro-dsl@ command-line tool. EP-1 ships the @parse@ and @check@-subcommands; a later milestone adds @scaffold@ to the same-optparse-applicative command tree.--}+-- | The @keiro-dsl@ command-line tool. EP-1 ships the @parse@ and @check@+-- subcommands; a later milestone adds @scaffold@ to the same+-- optparse-applicative command tree. module Main (main) where  import Control.Monad (when)+import Data.Aeson ((.=)) import Data.Aeson qualified as Aeson+import Data.Aeson.Text qualified as AesonText import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO+import Data.Text.Lazy.IO qualified as TLIO import Keiro.Dsl.Coverage qualified as Coverage-import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSpecs, gateWith, gatedBreaking)+import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSources, gateWith, gatedBreaking) import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding) import Keiro.Dsl.ExplainBindings (bindingObligations, renderBindingObligations) import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads) import Keiro.Dsl.Grammar (Placement (..), Spec (..))-import Keiro.Dsl.Parser (parseSpec)-import Keiro.Dsl.PrettyPrint (renderSpec)+import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, effectiveLanguageVersion, sourceFormText)+import Keiro.Dsl.Parser (parseSource, renderParseFailure)+import Keiro.Dsl.PrettyPrint (renderSource, renderSpec) import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpact) import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule)-import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffoldWithGoldens, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.ScaffoldRun (executeScaffoldWithLanguage, planScaffoldWithGoldens, renderRefusals, renderScaffoldReport) import Keiro.Dsl.Skeleton (skeletonFor) import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec) import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure, WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest)@@ -34,49 +37,59 @@ import System.Process (readProcessWithExitCode)  data Command-    = Parse FilePath-    | 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+  = Parse FilePath+  | Pretty FilePath+  | Check FilePath Bool Bool (Maybe CheckCoverageOptions)+  | Inspect FilePath InspectionFormat+  | Scaffold FilePath FilePath (Maybe String) Bool Bool (Maybe FilePath) (Maybe (String, FilePath))+  | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions)+  | New String +data InspectionFormat = InspectionJson+ data CheckCoverageOptions = CheckCoverageOptions-    { checkCoveragePath :: !FilePath-    , checkFailOnOpaque :: !Bool-    }+  { checkCoveragePath :: !FilePath,+    checkFailOnOpaque :: !Bool+  }  data DiffCoverageOptions = DiffCoverageOptions-    { diffCoveragePath :: !FilePath-    , diffFailOnOpaqueIncrease :: !Bool-    }+  { diffCoveragePath :: !FilePath,+    diffFailOnOpaqueIncrease :: !Bool+  }  main :: IO () main = run =<< execParser opts   where     opts =-        info-            (commands <**> helper)-            (fullDesc <> progDesc "keiro-dsl: a typed-specification toolchain for keiro services")+      info+        (commands <**> helper)+        (fullDesc <> progDesc "keiro-dsl: a typed-specification toolchain for keiro services")  commands :: Parser Command commands =-    subparser-        ( command-            "parse"-            (info (Parse <$> fileArg <**> helper) (progDesc "Parse a .keiro file and pretty-print it back"))-            <> command-                "check"-                (info (Check <$> fileArg <*> emitSwitch <*> 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 <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))-            <> command-                "diff"-                (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)"))-        )+  subparser+    ( command+        "parse"+        (info (Parse <$> fileArg <**> helper) (progDesc "Parse a .keiro file and pretty-print it back"))+        <> command+          "pretty"+          (info (Pretty <$> fileArg <**> helper) (progDesc "Parse a .keiro file and print its canonical source form"))+        <> command+          "check"+          (info (Check <$> fileArg <*> emitSwitch <*> explainBindingsSwitch <*> checkCoverageOptions <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error"))+        <> command+          "inspect"+          (info (Inspect <$> fileArg <*> inspectionFormatOpt <**> helper) (progDesc "Inspect source-language provenance for a .keiro file or workspace as JSON"))+        <> command+          "scaffold"+          (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))+        <> command+          "diff"+          (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)"))+    )  outOpt :: Parser FilePath outOpt = strOption (long "out" <> metavar "DIR" <> help "Output directory for the scaffolded modules")@@ -95,11 +108,11 @@  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)")-        )+  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")@@ -121,19 +134,19 @@  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)")-        )+  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)")-        )+  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)")@@ -150,380 +163,437 @@ kindArg :: Parser String kindArg = argument str (metavar "KIND" <> help "Node kind to scaffold a starter spec for") +inspectionFormatOpt :: Parser InspectionFormat+inspectionFormatOpt =+  option+    (eitherReader parseFormat)+    (long "format" <> metavar "json" <> value InspectionJson <> help "Inspection output format (json)")+  where+    parseFormat "json" = Right InspectionJson+    parseFormat other = Left ("unsupported inspection format: " <> other <> " (expected json)")+ run :: Command -> IO ()+run (Pretty fp) = run (Parse fp) -- Workspace dispatch. A @FILE@ ending in @.keiro-workspace@ is a workspace -- manifest; everything else takes the untouched single-file path below. run (Parse fp) | isWorkspacePath fp = runWorkspaceParse fp run (Check fp emit explainBindings coverageOptions)-    | isWorkspacePath fp = runWorkspaceCheck fp emit explainBindings coverageOptions+  | isWorkspacePath fp = runWorkspaceCheck fp emit explainBindings coverageOptions+run (Inspect fp format)+  | isWorkspacePath fp = runWorkspaceInspect fp format run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest)-    | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest+  | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions)-    | isWorkspacePath fp = runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions+  | isWorkspacePath fp = runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions run (Parse fp) = do-    input <- TIO.readFile fp-    case parseSpec fp input of-        Left err -> do-            hPutStrLn stderr (T.unpack err)-            exitFailure-        Right spec -> TIO.putStrLn (renderSpec spec)+  input <- TIO.readFile fp+  case parseSource fp input of+    Left failure -> do+      hPutStrLn stderr (T.unpack (renderParseFailure failure))+      exitFailure+    Right parsedSource -> TIO.putStrLn (renderSource parsedSource) run (Check fp emit explainBindings coverageOptions) = do-    input <- TIO.readFile fp-    case parseSpec fp input of-        Left err -> do-            hPutStrLn stderr (T.unpack err)-            exitFailure-        Right spec -> do-            let diags = validateSpec spec-            mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags-            if any ((== Error) . severity) diags-                then exitFailure-                else 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+  input <- TIO.readFile fp+  case parseSource fp input of+    Left failure -> do+      hPutStrLn stderr (T.unpack (renderParseFailure failure))+      exitFailure+    Right parsedSource -> do+      let spec = parsedSpec parsedSource+      let diags = validateSpec spec+      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags+      if any ((== Error) . severity) diags+        then exitFailure+        else do+          when emit (TIO.putStrLn (renderSource parsedSource))+          if explainBindings+            then case bindingObligations spec of+              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-            hPutStrLn stderr (T.unpack err)-            exitFailure-        Right spec -> do-            -- Validation gate: never scaffold an invalid spec. Abort on any-            -- error-severity diagnostic before writing a single module.-            let diags = validateSpec spec-            mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags-            when (any ((== Error) . severity) diags) exitFailure-            let ctx = mkContext cliRoot cliCollocate spec-                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-                (_, 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+  input <- TIO.readFile fp+  case parseSource fp input of+    Left failure -> do+      hPutStrLn stderr (T.unpack (renderParseFailure failure))+      exitFailure+    Right parsedSource -> do+      let spec = parsedSpec parsedSource+      -- Validation gate: never scaffold an invalid spec. Abort on any+      -- error-severity diagnostic before writing a single module.+      let diags = validateSpec spec+      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags+      when (any ((== Error) . severity) diags) exitFailure+      let ctx = mkContext cliRoot cliCollocate spec+          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+        (_, 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 <- executeScaffoldWithLanguage out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) 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+  case skeletonFor (T.pack kind) of+    Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure+    Right skel -> TIO.putStr skel+run (Inspect fp InspectionJson) = do+  input <- TIO.readFile fp+  case parseSource fp input of+    Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure+    Right parsedSource -> TLIO.putStrLn (AesonText.encodeToLazyText (sourceInspection fp (parsedSourceLanguage parsedSource))) 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"]-    case rootRes of-        Left err -> hPutStrLn stderr err >> exitFailure-        Right rootRaw -> do-            let repoRoot = trim rootRaw-            absFp <- canonicalizePath fp-            let relPath = makeRelative repoRoot absFp-            oldRes <- git repoRoot ["show", ref <> ":" <> relPath]-            case oldRes of-                Left err -> hPutStrLn stderr ("git show " <> ref <> ":" <> relPath <> " failed:\n" <> err) >> exitFailure-                Right oldText -> do-                    newText <- TIO.readFile fp-                    case (,) <$> parseSpec (ref <> ":" <> relPath) (T.pack oldText) <*> parseSpec fp newText of-                        Left perr -> hPutStrLn stderr (T.unpack perr) >> exitFailure-                        Right (oldSpec, newSpec) -> do-                            written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot-                            mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written-                            let changes = diffSpecs oldSpec newSpec-                                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 ()+  -- Resolve the spec to a repo-relative path so `git show <ref>:<relpath>` works.+  let dir = takeDirectory fp+  rootRes <- git dir ["rev-parse", "--show-toplevel"]+  case rootRes of+    Left err -> hPutStrLn stderr err >> exitFailure+    Right rootRaw -> do+      let repoRoot = trim rootRaw+      absFp <- canonicalizePath fp+      let relPath = makeRelative repoRoot absFp+      oldRes <- git repoRoot ["show", ref <> ":" <> relPath]+      case oldRes of+        Left err -> hPutStrLn stderr ("git show " <> ref <> ":" <> relPath <> " failed:\n" <> err) >> exitFailure+        Right oldText -> do+          newText <- TIO.readFile fp+          case (,) <$> parseSource (ref <> ":" <> relPath) (T.pack oldText) <*> parseSource fp newText of+            Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure+            Right (oldSource, newSource) -> do+              let oldSpec = parsedSpec oldSource+                  newSpec = parsedSpec newSource+              written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot+              mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written+              let changes = diffSources oldSource newSource+                  impact = replayImpact oldSpec newSpec+                  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 () -{- | @parse@ on a workspace manifest: read it, parse it, and print it back in-canonical form (clauses in order, members codepoint-sorted).--}+-- | @parse@ on a workspace manifest: read it, parse it, and print it back in+-- canonical form (clauses in order, members codepoint-sorted). runWorkspaceParse :: FilePath -> IO () runWorkspaceParse fp = do-    input <- TIO.readFile fp-    case parseWorkspaceManifest fp input of-        Left err -> do-            hPutStrLn stderr (T.unpack err)-            exitFailure-        Right manifest -> TIO.putStrLn (renderWorkspaceManifest manifest)+  input <- TIO.readFile fp+  case parseWorkspaceManifest fp input of+    Left err -> do+      hPutStrLn stderr (T.unpack err)+      exitFailure+    Right manifest -> TIO.putStrLn (renderWorkspaceManifest manifest) -{- | @check@ on a workspace manifest: compose the whole service from its member-@.keiro@ files and validate it as one contract. Diagnostics are rendered-against the member file and line that produced them, and a single diagnostic-may cite several files at once.+sourceInspection :: FilePath -> SourceLanguage -> Aeson.Value+sourceInspection path sourceLanguage =+  Aeson.object+    [ "schema" .= ("keiro-dsl/source-inspection/1" :: T.Text),+      "kind" .= ("source" :: T.Text),+      "path" .= path,+      "sourceForm" .= sourceFormText sourceLanguage,+      "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,+      "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage+    ] -The success options work against the merged graph, which is an ordinary 'Spec':-@--emit@ prints the canonical whole-service view, @--explain-bindings@ lists the-service's binding obligations, and the coverage options report on the merged-mapped-type graph with the manifest as the report's subject.--}+runWorkspaceInspect :: FilePath -> InspectionFormat -> IO ()+runWorkspaceInspect fp InspectionJson = do+  loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp+  case loaded of+    Left failure -> do+      mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)+      exitFailure+    Right workspace ->+      TLIO.putStrLn+        ( AesonText.encodeToLazyText+            ( Aeson.object+                [ "schema" .= ("keiro-dsl/source-inspection/1" :: T.Text),+                  "kind" .= ("workspace" :: T.Text),+                  "path" .= fp,+                  "service" .= wsService workspace,+                  "members" .= map memberInspection (wsMembers workspace)+                ]+            )+        )+  where+    memberInspection member =+      Aeson.object+        [ "path" .= wmPath member,+          "sourceForm" .= sourceFormText sourceLanguage,+          "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,+          "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage+        ]+      where+        sourceLanguage = wmSourceLanguage member++-- | @check@ on a workspace manifest: compose the whole service from its member+-- @.keiro@ files and validate it as one contract. Diagnostics are rendered+-- against the member file and line that produced them, and a single diagnostic+-- may cite several files at once.+--+-- The success options work against the merged graph, which is an ordinary 'Spec':+-- @--emit@ prints the canonical whole-service view, @--explain-bindings@ lists the+-- service's binding obligations, and the coverage options report on the merged+-- mapped-type graph with the manifest as the report's subject. runWorkspaceCheck :: FilePath -> Bool -> Bool -> Maybe CheckCoverageOptions -> IO () runWorkspaceCheck fp emit explainBindings coverageOptions = do-    loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp-    case loaded of-        Left failure -> do-            mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)-            exitFailure-        Right workspace -> do-            let diags = checkWorkspace workspace-                spec = wsMergedSpec workspace-            mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags-            if any ((== Error) . wdSeverity) diags-                then exitFailure-                else do-                    when emit (TIO.putStrLn (renderSpec spec))-                    if explainBindings-                        then case bindingObligations spec of-                            Left graphErrors -> do-                                hPutStrLn stderr ("validated workspace did not resolve its mapped type graph: " <> show graphErrors)-                                exitFailure-                            Right obligations -> TIO.putStrLn (renderBindingObligations (wsContext workspace) obligations)-                        else pure ()-                    coverageOk <- runCheckCoverage fp spec coverageOptions-                    when (coverageOk && not emit && not explainBindings) (putStrLn "OK")-                    when (not coverageOk) exitFailure--{- | @scaffold@ on a workspace manifest: compose the whole service, then plan-and emit the complete module set for every member in one invocation.--Every refusal — a member that will not parse, a cross-member conflict, a-validation error anywhere in the merged graph, a module-path collision, a golden-fixture stranded beside a member, a Generated target without the banner — is-raised before the first output byte changes, exactly as on the single-file path.+  loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp+  case loaded of+    Left failure -> do+      mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)+      exitFailure+    Right workspace -> do+      let diags = checkWorkspace workspace+          spec = wsMergedSpec workspace+      mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags+      if any ((== Error) . wdSeverity) diags+        then exitFailure+        else do+          when emit (TIO.putStrLn (renderSpec spec))+          if explainBindings+            then case bindingObligations spec of+              Left graphErrors -> do+                hPutStrLn stderr ("validated workspace did not resolve its mapped type graph: " <> show graphErrors)+                exitFailure+              Right obligations -> TIO.putStrLn (renderBindingObligations (wsContext workspace) obligations)+            else pure ()+          coverageOk <- runCheckCoverage fp spec coverageOptions+          when (coverageOk && not emit && not explainBindings) (putStrLn "OK")+          when (not coverageOk) exitFailure -The context is folded with the same precedence the single-file path uses: a CLI-flag beats the workspace authority, which (per EP-153) beats a member clause.-The single-file branch below is not touched, so existing users' bytes are-unchanged by construction.--}+-- | @scaffold@ on a workspace manifest: compose the whole service, then plan+-- and emit the complete module set for every member in one invocation.+--+-- Every refusal — a member that will not parse, a cross-member conflict, a+-- validation error anywhere in the merged graph, a module-path collision, a golden+-- fixture stranded beside a member, a Generated target without the banner — is+-- raised before the first output byte changes, exactly as on the single-file path.+--+-- The context is folded with the same precedence the single-file path uses: a CLI+-- flag beats the workspace authority, which (per EP-153) beats a member clause.+-- The single-file branch below is not touched, so existing users' bytes are+-- unchanged by construction. runWorkspaceScaffold ::-    FilePath ->-    FilePath ->-    Maybe String ->-    Bool ->-    Bool ->-    Maybe FilePath ->-    Maybe (String, FilePath) ->-    IO ()+  FilePath ->+  FilePath ->+  Maybe String ->+  Bool ->+  Bool ->+  Maybe FilePath ->+  Maybe (String, FilePath) ->+  IO () runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest = do-    loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp-    case loaded of-        Left failure -> do-            mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)-            exitFailure-        Right workspace -> do-            -- Validation gate: never scaffold an invalid service. Abort on any-            -- error-severity diagnostic before writing a single module.-            let diags = checkWorkspace workspace-            mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags-            when (any ((== Error) . wdSeverity) diags) exitFailure-            let spec = wsMergedSpec workspace-                ctx = workspaceContext cliRoot cliCollocate workspace-                goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens-            goldens <- loadGoldenPayloads goldenRoot spec-            case ( planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace-                 , traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest-                 ) of-                (Left refusals, _) -> do-                    mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)-                    exitFailure-                (_, Left comparisonError) -> TIO.hPutStrLn stderr comparisonError >> exitFailure-                (Right plan, Right comparisonModule) -> do-                    comparisonReady <- preflightComparison out comparisonRequest comparisonModule-                    case comparisonReady of-                        Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure-                        Right () -> do-                            result <- executeWorkspaceScaffold out forceGeneratedOverwrite plan-                            case result of-                                Left refusals -> do-                                    mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)-                                    exitFailure-                                Right report -> do-                                    mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceScaffoldReport report)-                                    writeComparison comparisonRequest comparisonModule--{- | @diff@ on a workspace manifest: compose the working-tree service and the-service described by the manifest and member blobs at @--since@, then feed both-merged specs through the existing differ, replay-impact analysis, coverage-report, golden emission, and gates.+  loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp+  case loaded of+    Left failure -> do+      mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)+      exitFailure+    Right workspace -> do+      -- Validation gate: never scaffold an invalid service. Abort on any+      -- error-severity diagnostic before writing a single module.+      let diags = checkWorkspace workspace+      mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags+      when (any ((== Error) . wdSeverity) diags) exitFailure+      let spec = wsMergedSpec workspace+          ctx = workspaceContext cliRoot cliCollocate workspace+          goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens+      goldens <- loadGoldenPayloads goldenRoot spec+      case ( planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace,+             traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest+           ) of+        (Left refusals, _) -> do+          mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)+          exitFailure+        (_, Left comparisonError) -> TIO.hPutStrLn stderr comparisonError >> exitFailure+        (Right plan, Right comparisonModule) -> do+          comparisonReady <- preflightComparison out comparisonRequest comparisonModule+          case comparisonReady of+            Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure+            Right () -> do+              result <- executeWorkspaceScaffold out forceGeneratedOverwrite plan+              case result of+                Left refusals -> do+                  mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)+                  exitFailure+                Right report -> do+                  mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceScaffoldReport report)+                  writeComparison comparisonRequest comparisonModule -The historical side is read exclusively through 'ContentSource'.  In-particular, member paths are joined textually beneath the manifest's-repository-relative directory; they are never canonicalized because an old-member may no longer exist in the working tree.--}+-- | @diff@ on a workspace manifest: compose the working-tree service and the+-- service described by the manifest and member blobs at @--since@, then feed both+-- merged specs through the existing differ, replay-impact analysis, coverage+-- report, golden emission, and gates.+--+-- The historical side is read exclusively through 'ContentSource'.  In+-- particular, member paths are joined textually beneath the manifest's+-- repository-relative directory; they are never canonicalized because an old+-- member may no longer exist in the working tree. runWorkspaceDiff ::-    FilePath ->-    String ->-    Maybe FilePath ->-    Maybe FilePath ->-    [CompatibilitySurface] ->-    Bool ->-    Maybe FilePath ->-    Maybe DiffCoverageOptions ->-    IO ()+  FilePath ->+  String ->+  Maybe FilePath ->+  Maybe FilePath ->+  [CompatibilitySurface] ->+  Bool ->+  Maybe FilePath ->+  Maybe DiffCoverageOptions ->+  IO () runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions = do-    let dir = takeDirectory fp-    rootRes <- git dir ["rev-parse", "--show-toplevel"]-    case rootRes of+  let dir = takeDirectory fp+  rootRes <- git dir ["rev-parse", "--show-toplevel"]+  case rootRes of+    Left err -> hPutStrLn stderr err >> exitFailure+    Right rootRaw -> do+      let repoRoot = trim rootRaw+      absFp <- canonicalizePath fp+      let relManifestPath = makeRelative repoRoot absFp+          relManifestDir = takeDirectory relManifestPath+          oldSource = gitContentSource repoRoot ref relManifestDir+      refRes <- git repoRoot ["cat-file", "-e", ref <> "^{commit}"]+      case refRes of         Left err -> hPutStrLn stderr err >> exitFailure-        Right rootRaw -> do-            let repoRoot = trim rootRaw-            absFp <- canonicalizePath fp-            let relManifestPath = makeRelative repoRoot absFp-                relManifestDir = takeDirectory relManifestPath-                oldSource = gitContentSource repoRoot ref relManifestDir-            refRes <- git repoRoot ["cat-file", "-e", ref <> "^{commit}"]-            case refRes of-                Left err -> hPutStrLn stderr err >> exitFailure-                Right _ -> do-                    newLoaded <- loadWorkspace (fileContentSource dir) fp-                    case newLoaded of-                        Left failure -> printWorkspaceFailure fp failure-                        Right newWorkspace -> do-                            currentManifestText <- TIO.readFile fp-                            case parseWorkspaceManifest fp currentManifestText of-                                Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure-                                Right currentManifest -> do-                                    oldManifestRes <- git repoRoot ["show", ref <> ":" <> relManifestPath]-                                    (adoptionBaseline, oldLoaded) <- case oldManifestRes of-                                        Right _ -> do-                                            loaded <- loadWorkspace oldSource fp-                                            pure (False, loaded)-                                        Left _ -> do-                                            loaded <- loadAdoptionBaseline oldSource fp currentManifest newWorkspace-                                            pure (True, loaded)-                                    case oldLoaded of-                                        Left failure -> do-                                            printWorkspaceFailureLines fp failure-                                            when adoptionBaseline $-                                                hPutStrLn stderr "workspace adoption baseline could not be composed; commit the workspace manifest before diffing across it, or fix the member files at the old revision"-                                            exitFailure-                                        Right oldWorkspace -> do-                                            when adoptionBaseline $-                                                putStrLn-                                                    ( "workspace adoption baseline: "-                                                        <> fp-                                                        <> " does not exist at "-                                                        <> ref-                                                        <> "; composing the old service from the current members' blobs at "-                                                        <> ref-                                                    )-                                            let oldSpec = wsMergedSpec oldWorkspace-                                                newSpec = wsMergedSpec newWorkspace-                                                goldenRoot = fmap (workspaceGoldenRoot fp) emitGoldensRoot-                                            written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) goldenRoot-                                            mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written-                                            let workspaceChanges = diffWorkspaces oldWorkspace newWorkspace-                                                changes = map wcChange workspaceChanges-                                                impact = replayImpact oldSpec newSpec-                                                effectiveGate = gateWith gatedSurfaces-                                                reportMeta =-                                                    WorkspaceMeta-                                                        { wmIdentity = wsService newWorkspace-                                                        , wmManifest = fp-                                                        , wmSince = T.pack ref-                                                        , wmMembersOld = map wmPath (wsMembers oldWorkspace)-                                                        , wmMembersNew = map wmPath (wsMembers newWorkspace)-                                                        , wmAdoptionBaseline = adoptionBaseline-                                                        }-                                            mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges-                                            when explain $-                                                mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)-                                            TIO.putStrLn (renderReplayImpact impact)-                                            mapM_ (`Aeson.encodeFile` impact) replayImpactOut-                                            mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReport reportMeta effectiveGate workspaceChanges)) reportOut-                                            coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions-                                            if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure ()+        Right _ -> do+          newLoaded <- loadWorkspace (fileContentSource dir) fp+          case newLoaded of+            Left failure -> printWorkspaceFailure fp failure+            Right newWorkspace -> do+              currentManifestText <- TIO.readFile fp+              case parseWorkspaceManifest fp currentManifestText of+                Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure+                Right currentManifest -> do+                  oldManifestRes <- git repoRoot ["show", ref <> ":" <> relManifestPath]+                  (adoptionBaseline, oldLoaded) <- case oldManifestRes of+                    Right _ -> do+                      loaded <- loadWorkspace oldSource fp+                      pure (False, loaded)+                    Left _ -> do+                      loaded <- loadAdoptionBaseline oldSource fp currentManifest newWorkspace+                      pure (True, loaded)+                  case oldLoaded of+                    Left failure -> do+                      printWorkspaceFailureLines fp failure+                      when adoptionBaseline $+                        hPutStrLn stderr "workspace adoption baseline could not be composed; commit the workspace manifest before diffing across it, or fix the member files at the old revision"+                      exitFailure+                    Right oldWorkspace -> do+                      when adoptionBaseline $+                        putStrLn+                          ( "workspace adoption baseline: "+                              <> fp+                              <> " does not exist at "+                              <> ref+                              <> "; composing the old service from the current members' blobs at "+                              <> ref+                          )+                      let oldSpec = wsMergedSpec oldWorkspace+                          newSpec = wsMergedSpec newWorkspace+                          goldenRoot = fmap (workspaceGoldenRoot fp) emitGoldensRoot+                      written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) goldenRoot+                      mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written+                      let workspaceChanges = diffWorkspaces oldWorkspace newWorkspace+                          changes = map wcChange workspaceChanges+                          impact = replayImpact oldSpec newSpec+                          effectiveGate = gateWith gatedSurfaces+                          reportMeta =+                            WorkspaceMeta+                              { wmIdentity = wsService newWorkspace,+                                wmManifest = fp,+                                wmSince = T.pack ref,+                                wmMembersOld = map wmPath (wsMembers oldWorkspace),+                                wmMembersNew = map wmPath (wsMembers newWorkspace),+                                wmAdoptionBaseline = adoptionBaseline+                              }+                      mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges+                      when explain $+                        mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)+                      TIO.putStrLn (renderReplayImpact impact)+                      mapM_ (`Aeson.encodeFile` impact) replayImpactOut+                      mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReport reportMeta effectiveGate workspaceChanges)) reportOut+                      coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions+                      if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure ()  -- | A @git show@ backed source rooted at a workspace manifest directory. gitContentSource :: FilePath -> String -> FilePath -> ContentSource gitContentSource repoRoot ref relManifestDir =-    ContentSource-        { csRead = \relative -> do-            let relPath = normalise (relManifestDir </> relative)-            result <- git repoRoot ["show", ref <> ":" <> relPath]-            pure $ case result of-                Left err -> Left (T.pack ("git show " <> ref <> ":" <> relPath <> " failed: " <> trim err))-                Right contents -> Right (T.pack contents)-        }+  ContentSource+    { csRead = \relative -> do+        let relPath = normalise (relManifestDir </> relative)+        result <- git repoRoot ["show", ref <> ":" <> relPath]+        pure $ case result of+          Left err -> Left (T.pack ("git show " <> ref <> ":" <> relPath <> " failed: " <> trim err))+          Right contents -> Right (T.pack contents)+    } -{- | Build the historical side for the commit that introduces a workspace-manifest.  Current members absent from the old revision contribute no nodes;-members that do exist are still parsed and composed by the ordinary workspace-loader, so malformed or mutually inconsistent old specs remain hard refusals.--}+-- | Build the historical side for the commit that introduces a workspace+-- manifest.  Current members absent from the old revision contribute no nodes;+-- members that do exist are still parsed and composed by the ordinary workspace+-- loader, so malformed or mutually inconsistent old specs remain hard refusals. loadAdoptionBaseline ::-    ContentSource ->-    FilePath ->-    WorkspaceManifest ->-    WorkspaceSpec ->-    IO (Either WorkspaceFailure WorkspaceSpec)+  ContentSource ->+  FilePath ->+  WorkspaceManifest ->+  WorkspaceSpec ->+  IO (Either WorkspaceFailure WorkspaceSpec) loadAdoptionBaseline oldSource manifestPath currentManifest newWorkspace = do-    present <- traverse presentAtRevision (NE.toList (wmfMembers currentManifest))-    case NE.nonEmpty [member | (member, True) <- present] of-        Nothing -> pure (Right (emptyWorkspaceBaseline newWorkspace))-        Just members ->-            let oldManifest = currentManifest{wmfMembers = members}-                manifestName = takeFileName manifestPath-                baselineSource =-                    ContentSource-                        { csRead = \relative ->-                            if relative == manifestName-                                then pure (Right (renderWorkspaceManifest oldManifest))-                                else csRead oldSource relative-                        }-             in loadWorkspace baselineSource manifestPath+  present <- traverse presentAtRevision (NE.toList (wmfMembers currentManifest))+  case NE.nonEmpty [member | (member, True) <- present] of+    Nothing -> pure (Right (emptyWorkspaceBaseline newWorkspace))+    Just members ->+      let oldManifest = currentManifest {wmfMembers = members}+          manifestName = takeFileName manifestPath+          baselineSource =+            ContentSource+              { csRead = \relative ->+                  if relative == manifestName+                    then pure (Right (renderWorkspaceManifest oldManifest))+                    else csRead oldSource relative+              }+       in loadWorkspace baselineSource manifestPath   where     presentAtRevision member = do-        result <- csRead oldSource (wmrPath member)-        pure (member, either (const False) (const True) result)+      result <- csRead oldSource (wmrPath member)+      pure (member, either (const False) (const True) result)  -- | The sound old side when every current member is new at the adoption ref. emptyWorkspaceBaseline :: WorkspaceSpec -> WorkspaceSpec emptyWorkspaceBaseline workspace =-    workspace-        { wsMembers = []-        , wsMergedSpec =-            (wsMergedSpec workspace)-                { specIds = []-                , specEnums = []-                , specRules = []-                , specMapped = []-                , specNodes = []-                }-        , wsLineMap = LineMap []-        , wsOwnership = OwnershipIndex mempty mempty-        }+  workspace+    { wsMembers = [],+      wsMergedSpec =+        (wsMergedSpec workspace)+          { specIds = [],+            specEnums = [],+            specRules = [],+            specMapped = [],+            specNodes = []+          },+      wsLineMap = LineMap [],+      wsOwnership = OwnershipIndex mempty mempty+    }  workspaceGoldenRoot :: FilePath -> FilePath -> FilePath workspaceGoldenRoot manifestPath requested-    | isAbsolute requested = requested-    | otherwise = normalise (takeDirectory manifestPath </> requested)+  | isAbsolute requested = requested+  | otherwise = normalise (takeDirectory manifestPath </> requested)  printWorkspaceFailure :: FilePath -> WorkspaceFailure -> IO a printWorkspaceFailure fp failure = printWorkspaceFailureLines fp failure >> exitFailure@@ -531,35 +601,34 @@ printWorkspaceFailureLines :: FilePath -> WorkspaceFailure -> IO () printWorkspaceFailureLines fp = mapM_ (TIO.hPutStrLn stderr) . renderWorkspaceFailure fp -{- | Fold the workspace's module-root and layout authority with the CLI-overrides to a 'Context'. Precedence is CLI flag > workspace authority >-built-in default; EP-153 already resolved the manifest-versus-member question-into 'wsModuleRoot' and 'wsLayout', so this mirrors 'mkContext' exactly one-level up.--}+-- | Fold the workspace's module-root and layout authority with the CLI+-- overrides to a 'Context'. Precedence is CLI flag > workspace authority >+-- built-in default; EP-153 already resolved the manifest-versus-member question+-- into 'wsModuleRoot' and 'wsLayout', so this mirrors 'mkContext' exactly one+-- level up. workspaceContext :: Maybe String -> Bool -> WorkspaceSpec -> Context workspaceContext cliRoot cliCollocate workspace =-    Context-        { contextName = wsContext workspace-        , moduleRoot = maybe (fromMaybe "" (wsModuleRoot workspace)) T.pack cliRoot-        , placement =-            if cliCollocate-                then CollocatedLeaf-                else fromMaybe GeneratedPrefix (wsLayout workspace)-        }+  Context+    { contextName = wsContext workspace,+      moduleRoot = maybe (fromMaybe "" (wsModuleRoot workspace)) T.pack cliRoot,+      placement =+        if cliCollocate+          then CollocatedLeaf+          else fromMaybe GeneratedPrefix (wsLayout workspace)+    }  shouldExplain :: Change -> Bool-shouldExplain Additive{} = False-shouldExplain Advisory{} = True-shouldExplain Breaking{} = True+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) git dir args = do-    (ec, out, err) <- readProcessWithExitCode "git" (["-C", dir] <> args) ""-    pure $ case ec of-        ExitSuccess -> Right out-        ExitFailure _ -> Left (if null err then out else err)+  (ec, out, err) <- readProcessWithExitCode "git" (["-C", dir] <> args) ""+  pure $ case ec of+    ExitSuccess -> Right out+    ExitFailure _ -> Left (if null err then out else err)  trim :: String -> String trim = f . f where f = reverse . dropWhile (`elem` (" \t\r\n" :: String))@@ -567,77 +636,76 @@ 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-                    )-                )+  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-            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)-                        )+          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)")+  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+  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+  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)+  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.--}+-- | Fold the spec's @module@/@layout@ clauses with the CLI overrides to a+-- 'Context'. Precedence is CLI flag > spec clause > built-in default. mkContext :: Maybe String -> Bool -> Spec -> Context mkContext cliRoot cliCollocate spec =-    Context-        { contextName = specContext spec-        , moduleRoot = maybe (fromMaybe "" (specModuleRoot spec)) T.pack cliRoot-        , placement =-            if cliCollocate-                then CollocatedLeaf-                else fromMaybe GeneratedPrefix (specLayout spec)-        }+  Context+    { contextName = specContext spec,+      moduleRoot = maybe (fromMaybe "" (specModuleRoot spec)) T.pack cliRoot,+      placement =+        if cliCollocate+          then CollocatedLeaf+          else fromMaybe GeneratedPrefix (specLayout spec)+    }

@@ -23,27 +23,27 @@  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-        ]-    ]+  [ 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)-        ]+  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))@@ -68,8 +68,8 @@  generatedDecodeArtifacts :: Value -> Either Text [Domain.ArtifactInfo] generatedDecodeArtifacts value = do-    values <- firstText (parseEither Aeson.parseJSON value)-    traverse decodeArtifactInfoMapped values+  values <- firstText (parseEither Aeson.parseJSON value)+  traverse decodeArtifactInfoMapped values  baselineDecodeArtifacts :: Value -> Either Text [Domain.ArtifactInfo] baselineDecodeArtifacts = firstText . parseEither (Aeson.parseJSON >=> traverse baselineParseArtifact)@@ -82,65 +82,65 @@  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-        ]+  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" .!= [])+  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"+  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"+  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+  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"+  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))+  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.5.0.0+version:         0.6.0.0 synopsis:        Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro@@ -24,6 +24,7 @@   default-language:   GHC2024   default-extensions:     DuplicateRecordFields+    ImportQualifiedPost     LambdaCase     OverloadedStrings @@ -31,18 +32,22 @@   import:          warnings, shared   hs-source-dirs:  src   exposed-modules:+    Keiro.Dsl.AggregateType     Keiro.Dsl.CodecCompare     Keiro.Dsl.Coverage     Keiro.Dsl.Diff     Keiro.Dsl.DiffReport     Keiro.Dsl.ExplainBindings+    Keiro.Dsl.Expression     Keiro.Dsl.FoldFingerprint     Keiro.Dsl.Goldens     Keiro.Dsl.Grammar     Keiro.Dsl.Harness+    Keiro.Dsl.LanguageVersion     Keiro.Dsl.Manifest     Keiro.Dsl.MappedConsumer     Keiro.Dsl.MappedDiff+    Keiro.Dsl.NominalType     Keiro.Dsl.Parser     Keiro.Dsl.PrettyPrint     Keiro.Dsl.ReadModelShape@@ -67,9 +72,11 @@     , directory           >=1.3   && <1.4     , filepath            >=1.4   && <1.6     , megaparsec          >=9.6   && <9.9+    , mmzk-typeid         >=0.7   && <0.8     , parser-combinators  >=1.3   && <1.4     , prettyprinter       >=1.7   && <1.8     , text                >=2.1   && <2.2+    , time                >=1.12  && <1.15  executable keiro-dsl   import:         warnings, shared@@ -125,10 +132,92 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.4  && <0.5+    , keiki  >=0.6  && <0.7     , keiro     , text   >=2.1  && <2.2 +-- Plan 157: compiled direct Time/Natural aggregate fields and registers,+-- symbolic equality/ordering, codecs, snapshots, forward/replay equality,+-- Natural JSON boundaries, canonical identity, and opaque arithmetic audit.+test-suite keiro-dsl-conformance-aggregate-scalars+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-aggregate-scalars+  main-is:        Main.hs+  other-modules:+    AggregateScalars.ScalarLedger.Holes+    Generated.AggregateScalars.ReplayAudit+    Generated.AggregateScalars.ScalarLedger.Codec+    Generated.AggregateScalars.ScalarLedger.Domain+    Generated.AggregateScalars.ScalarLedger.EventStream+    Generated.AggregateScalars.ScalarLedger.Harness+    Generated.AggregateScalars.ScalarLedger.Projection++  build-depends:+    , aeson  >=2.2  && <2.3+    , base   >=4.21 && <5+    , keiki  >=0.6  && <0.7+    , keiro+    , text   >=2.1  && <2.2+    , time   >=1.12 && <1.15++-- Plan 161: compiled authoritative version-2 scalar expressions, generated+-- transition ownership, explicit Hole opacity/fold identity, and concrete,+-- symbolic, codec-replay, and snapshot-invalidation agreement.+test-suite keiro-dsl-conformance-aggregate-scalar-expressions+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-scalar-expressions+  main-is:        Main.hs+  other-modules:+    AggregateScalarExpressions.ScalarAccount.Holes+    Generated.AggregateScalarExpressions.ReplayAudit+    Generated.AggregateScalarExpressions.ScalarAccount.Codec+    Generated.AggregateScalarExpressions.ScalarAccount.Domain+    Generated.AggregateScalarExpressions.ScalarAccount.EventStream+    Generated.AggregateScalarExpressions.ScalarAccount.Expressions+    Generated.AggregateScalarExpressions.ScalarAccount.Harness+    Generated.AggregateScalarExpressions.ScalarAccount.Projection+    Generated.AggregateScalarExpressions.ScalarAccount.Transducer+    Generated.AggregateScalarExpressions.Structural.Shape.Limits+    Generated.AggregateScalarExpressions.StructuralProjections+    ScalarExpressions.Bindings+    ScalarExpressions.Domain++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , containers  >=0.6  && <0.8+    , keiki       >=0.6  && <0.7+    , keiro+    , keiro-dsl+    , text        >=2.1  && <2.2+    , time        >=1.12 && <1.15++-- EP-158: consumer-owned direct IDs, enums, and nominal scalar wrappers,+-- checked KindID decoding, total bindings, projections, and snapshot caches.+test-suite keiro-dsl-conformance-nominal-scalars+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-nominal-scalars+  main-is:        Main.hs+  other-modules:+    Generated.NominalScalars.Nominal.Shape.OrderStatus+    Generated.NominalScalars.NominalLedger.Codec+    Generated.NominalScalars.NominalLedger.Domain+    Generated.NominalScalars.NominalProjections+    NominalConformance.Bindings+    NominalConformance.Domain++  build-depends:+    , aeson        >=2.2  && <2.3+    , base         >=4.21 && <5+    , keiki        >=0.6  && <0.7+    , keiro+    , mmzk-typeid  >=0.7  && <0.8+    , text         >=2.1  && <2.2+    , time         >=1.12 && <1.15+ -- 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.@@ -159,7 +248,7 @@     , bytestring  >=0.12 && <0.13     , containers  >=0.6  && <0.8     , deepseq     >=1.5  && <1.6-    , keiki       >=0.4  && <0.5+    , keiki       >=0.6  && <0.7     , keiro     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15@@ -193,7 +282,7 @@     , deepseq     >=1.5   && <1.6     , directory   >=1.3   && <1.4     , filepath    >=1.4   && <1.6-    , keiki       >=0.4   && <0.5+    , keiki       >=0.6   && <0.7     , keiro     , keiro-dsl     , text        >=2.1   && <2.2@@ -219,7 +308,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.4  && <0.5+    , keiki  >=0.6  && <0.7     , keiro     , text   >=2.1  && <2.2 @@ -243,7 +332,7 @@     , base         >=4.21 && <5     , containers   >=0.6  && <0.8     , deepseq      >=1.5  && <1.6-    , keiki        >=0.4  && <0.5+    , keiki        >=0.6  && <0.7     , keiro     , tasty-bench  >=0.5  && <0.6     , text         >=2.1  && <2.2@@ -267,7 +356,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.4  && <0.5+    , keiki  >=0.6  && <0.7     , keiro     , text   >=2.1  && <2.2 @@ -338,7 +427,7 @@     , containers     , effectful-core     , hasql-transaction-    , keiki              >=0.4  && <0.5+    , keiki              >=0.6  && <0.7     , keiro     , keiro-core     , keiro-pgmq@@ -368,7 +457,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.4  && <0.5+    , keiki  >=0.6  && <0.7     , keiro     , text   >=2.1  && <2.2 @@ -567,7 +656,7 @@   build-depends:     , aeson         >=2.2  && <2.3     , base          >=4.21 && <5-    , keiki         >=0.4  && <0.5+    , keiki         >=0.6  && <0.7     , keiro     , shibuya-core     , text          >=2.1  && <2.2@@ -662,7 +751,7 @@     , aeson           >=2.2  && <2.3     , base            >=4.21 && <5     , effectful-core-    , keiki           >=0.4  && <0.5+    , keiki           >=0.6  && <0.7     , keiro     , shibuya-core     , text            >=2.1  && <2.2@@ -698,7 +787,7 @@     , base               >=4.21 && <5     , effectful-core     , hasql-transaction-    , keiki              >=0.4  && <0.5+    , keiki              >=0.6  && <0.7     , keiro     , kiroku-store     , shibuya-core@@ -742,6 +831,6 @@     , aeson      >=2.2  && <2.3     , base       >=4.21 && <5     , directory  >=1.3  && <1.4-    , keiki      >=0.4  && <0.5+    , keiki      >=0.6  && <0.7     , keiro     , text       >=2.1  && <2.2

@@ -0,0 +1,413 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Canonical aggregate type resolution and capability policy.+--+-- Parsing a 'TypeExpr' only establishes syntax. This module decides whether that+-- type is legal at an aggregate use site, canonicalizes aliases, validates+-- register initials, and supplies total Haskell lowering for admitted values.+module Keiro.Dsl.AggregateType+  ( AggregateUseSite (..),+    AggregateCapability (..),+    ResolvedAggregateType (..),+    AggregateSymbols,+    aggregateSymbols,+    AggregateTypeErrorReason (..),+    AggregateTypeError (..),+    resolveAggregateType,+    inferAggregateFieldType,+    aggregateCapability,+    aggregateCanonicalName,+    typeExprCanonicalName,+    aggregateHaskellType,+    aggregateImports,+    aggregatePackages,+    aggregateSampleHaskell,+    ResolvedRegisterInitial (..),+    resolveRegisterInitial,+    renderRegisterInitial,+    registerInitialCanonicalName,+  )+where++import Data.Char (toUpper)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time.Calendar (toGregorian)+import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Keiro.Dsl.Grammar+import Keiro.Dsl.NominalType+import Keiro.Dsl.TypeGraph+import Numeric.Natural (Natural)+import Text.Read (readMaybe)++data AggregateUseSite+  = CommandFieldUse+  | EventFieldUse+  | RegisterUse+  | EqualityGuardUse+  | OrderingGuardUse+  | WholeValueWriteUse+  | CodecUse+  | SnapshotUse+  | HarnessSampleUse+  | HaskellLoweringUse+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | Whether a use is solver-visible, legal but opaque, or unsupported.+data AggregateCapability = SolverVisible | OpaqueOnly | Unsupported+  deriving stock (Eq, Ord, Show, Enum, Bounded)++data ResolvedAggregateType+  = AggregateText+  | AggregateInt+  | AggregateInteger+  | AggregateBool+  | AggregateTime+  | AggregateNatural+  | AggregateNominal !ResolvedNominalType+  | AggregateVertex !Name+  | AggregateMapped !MappedKey+  deriving stock (Eq, Ord, Show)++data AggregateSymbols = AggregateSymbols+  { symbolNominals :: !(Map Name ResolvedNominalType),+    symbolVertices :: !(Map Name [Name]),+    symbolMapped :: !(Map MappedKey ResolvedMappedDecl)+  }++aggregateSymbols :: Spec -> AggregateSymbols+aggregateSymbols spec =+  AggregateSymbols+    { symbolNominals = either (const Map.empty) nominalTypes (resolveNominalTypes spec),+      symbolVertices =+        Map.fromList+          [ (aggName aggregate <> "Vertex", map stName (aggStates aggregate))+          | NAggregate aggregate <- specNodes spec+          ],+      symbolMapped = either (const Map.empty) tgDeclarations (resolveTypeGraph spec)+    }++data AggregateTypeErrorReason+  = UnknownAggregateType !Name+  | UnsupportedAggregateShape !TypeExpr+  | UnsupportedAggregateCapability !ResolvedAggregateType+  | InvalidRegisterInitial !ResolvedAggregateType !Text+  deriving stock (Eq, Show)++data AggregateTypeError = AggregateTypeError+  { aggregateTypeErrorLoc :: !Loc,+    aggregateTypeErrorUseSite :: !AggregateUseSite,+    aggregateTypeErrorReason :: !AggregateTypeErrorReason+  }+  deriving stock (Eq, Show)++resolveAggregateType :: AggregateSymbols -> Loc -> AggregateUseSite -> TypeExpr -> Either AggregateTypeError ResolvedAggregateType+resolveAggregateType symbols loc useSite expression = do+  resolved <- case expression of+    TText -> pure AggregateText+    TInt -> pure AggregateInt+    TInteger -> pure AggregateInteger+    TBool -> pure AggregateBool+    TNatural -> pure AggregateNatural+    TTime -> pure AggregateTime+    TJson -> unsupportedShape+    TOptional {} -> unsupportedShape+    TList {} -> unsupportedShape+    TMap {} -> unsupportedShape+    TRef name+      | Just nominal <- Map.lookup name (symbolNominals symbols) -> pure (AggregateNominal nominal)+      | Map.member name (symbolVertices symbols) -> pure (AggregateVertex name)+      | Map.member (MappedKey name) (symbolMapped symbols) -> pure (AggregateMapped (MappedKey name))+      | otherwise -> Left (AggregateTypeError loc useSite (UnknownAggregateType name))+  case aggregateCapability useSite resolved of+    Unsupported -> Left (AggregateTypeError loc useSite (UnsupportedAggregateCapability resolved))+    SolverVisible -> pure resolved+    OpaqueOnly -> pure resolved+  where+    unsupportedShape = Left (AggregateTypeError loc useSite (UnsupportedAggregateShape expression))++inferAggregateFieldType :: AggregateSymbols -> Aggregate -> AggregateUseSite -> AggregateField -> Either AggregateTypeError ResolvedAggregateType+inferAggregateFieldType symbols aggregate useSite field =+  resolveAggregateType symbols (aggregateFieldLoc field) useSite inferred+  where+    inferred = case aggregateFieldType field of+      Just expression -> expression+      Nothing -> case [regType register | register <- aggRegs aggregate, regName register == aggregateFieldName field] of+        expression : _ -> expression+        [] ->+          let candidate = pascal (aggregateFieldName field)+           in if Map.member candidate (symbolNominals symbols)+                || Map.member candidate (symbolVertices symbols)+                || Map.member (MappedKey candidate) (symbolMapped symbols)+                then TRef candidate+                else TText++aggregateCapability :: AggregateUseSite -> ResolvedAggregateType -> AggregateCapability+aggregateCapability useSite resolved = case useSite of+  EqualityGuardUse -> case resolved of+    AggregateMapped {} -> Unsupported+    _ -> solverVisibility resolved+  OrderingGuardUse -> case resolved of+    AggregateInt -> SolverVisible+    AggregateInteger -> SolverVisible+    AggregateTime -> SolverVisible+    AggregateNatural -> SolverVisible+    AggregateNominal nominal -> nominalOrderingCapability nominal+    AggregateText -> Unsupported+    AggregateBool -> Unsupported+    AggregateVertex {} -> Unsupported+    AggregateMapped {} -> Unsupported+  CommandFieldUse -> solverVisibility resolved+  EventFieldUse -> solverVisibility resolved+  RegisterUse -> solverVisibility resolved+  WholeValueWriteUse -> solverVisibility resolved+  CodecUse -> solverVisibility resolved+  SnapshotUse -> solverVisibility resolved+  HarnessSampleUse -> solverVisibility resolved+  HaskellLoweringUse -> solverVisibility resolved++solverVisibility :: ResolvedAggregateType -> AggregateCapability+solverVisibility resolved = case resolved of+  AggregateText -> SolverVisible+  AggregateInt -> SolverVisible+  AggregateInteger -> SolverVisible+  AggregateBool -> SolverVisible+  AggregateTime -> SolverVisible+  AggregateNatural -> SolverVisible+  AggregateNominal nominal -> nominalSolverVisibility nominal+  AggregateVertex {} -> OpaqueOnly+  AggregateMapped {} -> OpaqueOnly++nominalSolverVisibility :: ResolvedNominalType -> AggregateCapability+nominalSolverVisibility nominal = case resolvedNominalRepresentation nominal of+  ScalarRepresentation {} -> SolverVisible+  IdRepresentation {} -> OpaqueOnly+  EnumRepresentation {} -> OpaqueOnly++nominalOrderingCapability :: ResolvedNominalType -> AggregateCapability+nominalOrderingCapability nominal = case resolvedNominalRepresentation nominal of+  ScalarRepresentation NominalInt -> SolverVisible+  ScalarRepresentation NominalNatural -> SolverVisible+  ScalarRepresentation NominalTime -> SolverVisible+  ScalarRepresentation NominalText -> Unsupported+  ScalarRepresentation NominalBool -> Unsupported+  IdRepresentation {} -> Unsupported+  EnumRepresentation {} -> Unsupported++aggregateCanonicalName :: ResolvedAggregateType -> Text+aggregateCanonicalName resolved = case resolved of+  AggregateText -> "Text"+  AggregateInt -> "Int"+  AggregateInteger -> "Integer"+  AggregateBool -> "Bool"+  AggregateTime -> "Time"+  AggregateNatural -> "Natural"+  AggregateNominal nominal -> resolvedNominalName nominal+  AggregateVertex name -> name+  AggregateMapped key -> unMappedKey key++typeExprCanonicalName :: TypeExpr -> Text+typeExprCanonicalName expression = case expression of+  TText -> "Text"+  TInt -> "Int"+  TInteger -> "Integer"+  TBool -> "Bool"+  TNatural -> "Natural"+  TTime -> "Time"+  TJson -> "Json"+  TOptional value -> "Optional(" <> typeExprCanonicalName value <> ")"+  TList value -> "List(" <> typeExprCanonicalName value <> ")"+  TMap value -> "Map(" <> typeExprCanonicalName value <> ")"+  TRef name -> name++aggregateHaskellType :: AggregateSymbols -> ResolvedAggregateType -> Text+aggregateHaskellType symbols resolved = case resolved of+  AggregateTime -> "UTCTime"+  AggregateNominal nominal -> case resolvedNominalOwnership nominal of+    GeneratedNominal -> resolvedNominalName nominal+    ConsumerNominal binding -> renderHaskellSource (consumerNominalHaskell binding)+  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of+    Just declaration -> renderHaskellSource (mappedHaskell declaration)+    Nothing -> unMappedKey key+  _ -> aggregateCanonicalName resolved+  where+    mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration+    mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration+    renderHaskellSource source = hsModule source <> "." <> hsType source++aggregateImports :: AggregateSymbols -> ResolvedAggregateType -> Set Text+aggregateImports symbols resolved = case resolved of+  AggregateTime ->+    Set.fromList+      [ "Data.Time.Calendar (fromGregorian)",+        "Data.Time.Clock (UTCTime(..), picosecondsToDiffTime)"+      ]+  AggregateNatural -> Set.singleton "Numeric.Natural (Natural)"+  AggregateNominal nominal -> case resolvedNominalOwnership nominal of+    GeneratedNominal -> Set.empty+    ConsumerNominal binding -> Set.singleton (hsModule (consumerNominalHaskell binding) <> " qualified")+  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of+    Just declaration -> Set.singleton (hsModule (mappedHaskell declaration) <> " qualified")+    Nothing -> Set.empty+  _ -> Set.empty+  where+    mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration+    mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration++aggregatePackages :: AggregateSymbols -> ResolvedAggregateType -> Set Text+aggregatePackages symbols resolved = case resolved of+  AggregateTime -> Set.singleton "time"+  AggregateNominal nominal -> case resolvedNominalOwnership nominal of+    GeneratedNominal -> Set.empty+    ConsumerNominal binding -> Set.singleton (hsPackage (consumerNominalHaskell binding))+  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of+    Just declaration -> Set.singleton (hsPackage (mappedHaskell declaration))+    Nothing -> Set.empty+  _ -> Set.empty+  where+    mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration+    mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration++aggregateSampleHaskell :: AggregateSymbols -> Text -> ResolvedAggregateType -> Text+aggregateSampleHaskell symbols fieldName resolved = case resolved of+  AggregateText -> tshow ("sample-" <> fieldName)+  AggregateInt -> "0"+  AggregateInteger -> "0"+  AggregateBool -> "False"+  AggregateTime -> "(UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012))"+  AggregateNatural -> "0"+  AggregateNominal nominal -> nominalSample nominal+  AggregateVertex name -> firstConstructor name+  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of+    Just declaration -> "(snd (NonEmpty.head (fixtureCases " <> unQualifiedValueName (mappedFixtures declaration) <> ")))"+    Nothing -> unMappedKey key <> ".sample"+  where+    firstConstructor name = case Map.lookup name (symbolVertices symbols) of+      Just (constructor : _) -> constructor+      _ -> name+    nominalSample nominal = case resolvedNominalOwnership nominal of+      ConsumerNominal binding ->+        "(nominalFixtureDomain (NonEmpty.head (nominalFixtureCases "+          <> unQualifiedValueName (consumerNominalFixtures binding)+          <> ")))"+      GeneratedNominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> "(" <> resolvedNominalName nominal <> " \"sample\")"+        EnumRepresentation constructors -> fst (NE.head constructors)+        ScalarRepresentation {} -> resolvedNominalName nominal <> ".sample"+    mappedFixtures (ResolvedStructural declaration _) = sdFixtures declaration+    mappedFixtures (ResolvedOpaque declaration) = odFixtures declaration++data ResolvedRegisterInitial+  = InitialText !Text+  | InitialInt !Int+  | InitialInteger !Integer+  | InitialBool !Bool+  | InitialTime !UTCTime+  | InitialNatural !Natural+  | InitialId !Name+  | InitialNamed !ResolvedAggregateType !Name+  | InitialNominal !Name !QualifiedValueName+  | InitialMapped !MappedKey !QualifiedValueName+  deriving stock (Eq, Show)++resolveRegisterInitial :: AggregateSymbols -> Loc -> ResolvedAggregateType -> RegInitial -> Either AggregateTypeError ResolvedRegisterInitial+resolveRegisterInitial symbols loc resolved syntax = case resolved of+  AggregateText -> case syntax of+    RegInitText value -> pure (InitialText value)+    RegInitBare _ -> invalid "Text initials must be quoted"+  AggregateInt -> case syntax of+    RegInitBare value -> maybe (invalid "Int initials must be integral literals in the Haskell Int range") (pure . InitialInt) (readMaybe (T.unpack value))+    RegInitText _ -> invalid "Int initials must be unquoted integral literals"+  AggregateInteger -> case syntax of+    RegInitBare value -> maybe (invalid "Integer initials must be integral literals") (pure . InitialInteger) (readMaybe (T.unpack value))+    RegInitText _ -> invalid "Integer initials must be unquoted integral literals"+  AggregateBool -> case syntax of+    RegInitBare "True" -> pure (InitialBool True)+    RegInitBare "False" -> pure (InitialBool False)+    _ -> invalid "Bool initials must be True or False"+  AggregateTime -> case syntax of+    RegInitText value -> maybe (invalid "Time initials must be valid quoted ISO-8601 UTC timestamps") (pure . InitialTime) (iso8601ParseM (T.unpack value))+    RegInitBare _ -> invalid "Time initials must be quoted ISO-8601 UTC timestamps"+  AggregateNatural -> case syntax of+    RegInitBare value -> case readMaybe (T.unpack value) :: Maybe Integer of+      Just number | number >= 0 -> pure (InitialNatural (fromInteger number))+      _ -> invalid "Natural initials must be non-negative integral literals"+    RegInitText _ -> invalid "Natural initials must be unquoted non-negative integral literals"+  AggregateNominal nominal -> case resolvedNominalOwnership nominal of+    ConsumerNominal binding -> case syntax of+      RegInitBare "initial" -> case consumerNominalInitial binding of+        Just value -> pure (InitialNominal (resolvedNominalName nominal) value)+        Nothing -> invalid "consumer-owned nominal register type must declare an initial symbol"+      _ -> invalid "consumer-owned nominal register initials must use the bare initial token"+    GeneratedNominal -> case resolvedNominalRepresentation nominal of+      IdRepresentation {} -> case syntax of+        RegInitBare "placeholder" -> pure (InitialId (resolvedNominalName nominal))+        _ -> invalid "ID initials must use placeholder"+      EnumRepresentation constructors -> namedInitial (resolvedNominalName nominal) (Just (map fst (NE.toList constructors)))+      ScalarRepresentation {} -> invalid "generated nominal scalars are unsupported"+  AggregateVertex name -> namedInitial name (Map.lookup name (symbolVertices symbols))+  AggregateMapped key -> case syntax of+    RegInitBare "initial" -> case Map.lookup key (symbolMapped symbols) >>= mappedInitial of+      Just value -> pure (InitialMapped key value)+      Nothing -> invalid "mapped register type must declare an initial symbol"+    _ -> invalid "mapped register initials must use the bare initial token"+  where+    invalid detail = Left (AggregateTypeError loc RegisterUse (InvalidRegisterInitial resolved detail))+    namedInitial name constructors = case syntax of+      RegInitBare constructor | maybe False (constructor `elem`) constructors -> pure (InitialNamed resolved constructor)+      _ -> invalid ("initial must name a constructor of " <> name)+    mappedInitial (ResolvedStructural declaration _) = sdInitial declaration+    mappedInitial (ResolvedOpaque declaration) = odInitial declaration++renderRegisterInitial :: ResolvedRegisterInitial -> Text+renderRegisterInitial initial = case initial of+  InitialText value -> tshow value+  InitialInt value -> T.pack (show value)+  InitialInteger value -> T.pack (show value)+  InitialBool value -> if value then "True" else "False"+  InitialTime value ->+    let (year, month, day) = toGregorian (utctDay value)+        picoseconds = diffTimeToPicoseconds (utctDayTime value)+     in "(UTCTime (fromGregorian "+          <> T.pack (show year)+          <> " "+          <> T.pack (show month)+          <> " "+          <> T.pack (show day)+          <> ") (picosecondsToDiffTime "+          <> T.pack (show picoseconds)+          <> "))"+  InitialNatural value -> T.pack (show value)+  InitialId name -> "(" <> name <> " \"\")"+  InitialNamed resolved constructor -> case resolved of+    AggregateVertex vertexType -> T.dropEnd (T.length ("Vertex" :: Text)) vertexType <> constructor+    _ -> constructor+  InitialNominal _ value -> unQualifiedValueName value+  InitialMapped _ value -> unQualifiedValueName value++registerInitialCanonicalName :: ResolvedRegisterInitial -> Text+registerInitialCanonicalName initial = case initial of+  InitialText value -> tshow value+  InitialInt value -> T.pack (show value)+  InitialInteger value -> T.pack (show value)+  InitialBool value -> if value then "True" else "False"+  InitialTime {} -> renderRegisterInitial initial+  InitialNatural value -> T.pack (show value)+  InitialId {} -> "placeholder"+  InitialNamed _ constructor -> constructor+  InitialNominal {} -> "initial"+  InitialMapped {} -> "initial"++pascal :: Text -> Text+pascal value = case T.uncons value of+  Just (first, rest) -> T.cons (toUpper first) rest+  Nothing -> value++tshow :: Text -> Text+tshow = T.pack . show

@@ -1,13 +1,12 @@ {-# 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 (..),+-- | 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 (..),@@ -35,7 +34,8 @@     renderCompareReport,     reportSucceeded,     writeCompareReportAtomic,-) where+  )+where  import Control.Exception (IOException, bracketOnError, displayException, try) import Control.Monad (when)@@ -59,146 +59,144 @@ import System.IO (Handle, hClose, openBinaryTempFile)  data FixtureOrigin = HistoricalGolden | FromBinding-    deriving stock (Eq, Ord, Show)+  deriving stock (Eq, Ord, Show)  data DecodeOutcome-    = DecodedShape !Value-    | DecodeFailed !Text-    deriving stock (Eq, Show)+  = DecodedShape !Value+  | DecodeFailed !Text+  deriving stock (Eq, Show)  newtype JsonPointer = JsonPointer {unJsonPointer :: Text}-    deriving stock (Eq, Ord, Show)+  deriving stock (Eq, Ord, Show)  data ComparisonDifference-    = EncodedValueDifference !JsonPointer !Value !Value-    | DecodedValueDifference !JsonPointer !Value !Value-    | GeneratedDecodeRejected !Text-    deriving stock (Eq, Show)+  = 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.--}+-- | 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)-    }+  { 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)+  = 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)+  = JsonParity+  | RequiresVersionWork !ComparisonDifference+  deriving stock (Eq, Show)  data CompareInputIssue-    = HistoricalGoldenUnreadable !FilePath !Text-    | HistoricalCodecRejected !FilePath !Text-    | HistoricalCodecProvenanceInvalid !Text-    deriving stock (Eq, Show)+  = HistoricalGoldenUnreadable !FilePath !Text+  | HistoricalCodecRejected !FilePath !Text+  | HistoricalCodecProvenanceInvalid !Text+  deriving stock (Eq, Show)  data BranchKind-    = UnionArm !Text-    | OptionalPresent-    | OptionalMissing-    | ExplicitNull-    deriving stock (Eq, Ord, Show)+  = UnionArm !Text+  | OptionalPresent+  | OptionalMissing+  | ExplicitNull+  deriving stock (Eq, Ord, Show)  data DeclaredBranch = DeclaredBranch-    { dbOrigin :: !FixtureOrigin-    , dbPointer :: !JsonPointer-    , dbKind :: !BranchKind-    }-    deriving stock (Eq, Ord, Show)+  { 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)+  { 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)+  { 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.--}+-- | 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)+  = 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)+  { bfWireKey :: !Text,+    bfPresenceOptional :: !Bool,+    bfSchema :: !BranchSchema+  }+  deriving stock (Eq, Show)  data BranchArm = BranchArm-    { baWireTag :: !Text-    , baPayloadSchema :: !(Maybe BranchSchema)-    }-    deriving stock (Eq, Show)+  { 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)+  { 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)+  { 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)+  { 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)+  { 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."+  "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@@ -206,73 +204,73 @@  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)+  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)+  | canonicalJsonBytes historical == canonicalJsonBytes generated = JsonParity+  | otherwise = RequiresVersionWork (difference (firstDivergentPointer historical generated) historical generated)  compareReport ::-    CompareProvenance ->-    [CompareInputIssue] ->-    [CompareObservation] ->-    [DeclaredBranch] ->-    [ObservedBranch] ->-    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-        }+  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-                    }+      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+observationOrigin EncodeObservation {} = FromBinding+observationOrigin DecodeObservation {} = HistoricalGolden  observationName :: CompareObservation -> Text-observationName EncodeObservation{coCaseName = name} = name-observationName DecodeObservation{coFixturePath = path} = T.pack path+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))-           ]+  [ 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-    ]+  [ 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)@@ -283,234 +281,234 @@   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-                ]+      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+      | 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+      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+      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)+  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-               ]-        )+  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+      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-        ]+  JsonParity -> []+  RequiresVersionWork difference ->+    [ "  " <> classifiedName observation <> " [" <> direction <> "] at " <> pointerOf difference,+      "    " <> reasonOf difference+    ]   where     direction = case classifiedOrigin observation of-        FromBinding -> "encode"-        HistoricalGolden -> "decode"+      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+  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)+  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>"+  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+  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+  | 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 ()+  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)+  _ <- 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)+      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))+      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+  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]+  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+  value : _ -> Just value+  [] -> Nothing  firstMatch :: (a -> Bool) -> [a] -> Maybe a firstMatch predicate = \case-    [] -> Nothing-    value : rest-        | predicate value -> Just value-        | otherwise -> firstMatch predicate rest+  [] -> Nothing+  value : rest+    | predicate value -> Just value+    | otherwise -> firstMatch predicate rest  appendPointer :: Text -> Text -> Text appendPointer base segment = base <> "/" <> escapePointerSegment segment@@ -535,208 +533,208 @@  branchKindName :: BranchKind -> Text branchKindName kind = case kind of-    UnionArm arm -> "union-arm:" <> arm-    OptionalPresent -> "optional-present"-    OptionalMissing -> "optional-missing"-    ExplicitNull -> "explicit-null"+  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)+  | 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+  toJSON = String . originName  instance FromJSON FixtureOrigin where-    parseJSON = withText "FixtureOrigin" parseOrigin+  parseJSON = withText "FixtureOrigin" parseOrigin  instance ToJSON JsonPointer where-    toJSON = String . unJsonPointer+  toJSON = String . unJsonPointer  instance FromJSON JsonPointer where-    parseJSON = withText "JsonPointer" (pure . JsonPointer)+  parseJSON = withText "JsonPointer" (pure . JsonPointer)  instance ToJSON BranchKind where-    toJSON = String . branchKindName+  toJSON = String . branchKindName  instance FromJSON BranchKind where-    parseJSON = withText "BranchKind" parseBranchKind+  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-                ]+  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)+  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-            ]+  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)+  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-                ]+  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)+  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-            ]+  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"+  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-            ]+  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"+  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-            ]+  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"+  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-            ]+  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"+  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-            ]+  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"+  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-            ]+  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"+  parseJSON = withObject "CompareReport" $ \value ->+    CompareReport+      <$> value .: "provenance"+      <*> value .: "observations"+      <*> value .: "inputIssues"+      <*> value .: "coverageGaps"+      <*> value .: "authority"

@@ -1,13 +1,12 @@ {-# 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 (..),+-- | 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 (..),@@ -29,7 +28,8 @@     renderCoverageSummary,     renderCoverageFinding,     writeCoverageReport,-) where+  )+where  import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson qualified as Aeson@@ -46,453 +46,454 @@ import System.FilePath (takeDirectory)  data CoverageSurface = PrivateEventPayload | SnapshotRegister-    deriving stock (Eq, Ord, Show)+  deriving stock (Eq, Ord, Show)  data CoverageMode = StructuralCoverage | OpaqueCoverage-    deriving stock (Eq, Ord, Show)+  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)+  { 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)+  { 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)+  { 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)+  { 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)+  { 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)+  { 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)+  { totalRoots :: !Int,+    structuralRoots :: !Int,+    opaqueRoots :: !Int,+    jsonBoundaries :: !Int+  }+  deriving stock (Eq, Show)  data CoverageSummary = CoverageSummary-    { privateEventPayloads :: !CoverageCounts-    , snapshotRegisters :: !CoverageCounts-    }-    deriving stock (Eq, Show)+  { privateEventPayloads :: !CoverageCounts,+    snapshotRegisters :: !CoverageCounts+  }+  deriving stock (Eq, Show)  data CoverageFinding = CoverageFinding-    { findingSeverity :: !Severity-    , findingCode :: !DiagnosticCode-    , findingRoots :: ![Text]-    , findingMessage :: !Text-    }-    deriving stock (Eq, Show)+  { 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)+  { 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)+  { 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)+  { 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-            }+  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+  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]}+  | 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+  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)"-        ]+  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)"+      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+  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 <> ")"+      [] -> ""+      roots -> " (roots: " <> T.intercalate ", " roots <> ")"  writeCoverageReport :: FilePath -> CoverageReport -> IO () writeCoverageReport path report = do-    createDirectoryIfMissing True (takeDirectory path)-    Aeson.encodeFile path report+  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+    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"+  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)-        ]+  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)-        ]+  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)-        ]+  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)]-        ]+  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)+      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+  | 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-                    ]-            }+  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)-            }+  foldTypeExpr+    TypeExprAlgebra+      { onText = [],+        onInt = [],+        onInteger = [],+        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-        }+  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-                }+      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))-    ]+  [ 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-        }+  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"-        }-    ]+  [ 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@@ -500,151 +501,151 @@ useSiteKey (RootRegister _ _ key) = key  useSiteSurface :: UseSite -> CoverageSurface-useSiteSurface RootEventField{} = PrivateEventPayload-useSiteSurface RootRegister{} = SnapshotRegister-useSiteSurface RootCommandField{} = error "command fields are not persisted coverage roots"+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+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-            }+  foldMappedDecl+    MappedDeclAlgebra+      { onStructuralDecl = \_ _ -> StructuralCoverage,+        onOpaqueDecl = const OpaqueCoverage+      }  instance ToJSON CoverageSurface where-    toJSON PrivateEventPayload = toJSON ("private-event-payload" :: Text)-    toJSON SnapshotRegister = toJSON ("snapshot-register" :: Text)+  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)+  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-            ]+  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-            ]+  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-            ]+  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]+  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-            ]+  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-            ]+  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-            ]+  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-            ]+  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"+  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-            ]+  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-            ]+  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-            ]+  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+      ]

@@ -1,1992 +1,2175 @@-{- | The spec evolution differ. 'diffSpecs' compares an /old/ and a /new/ 'Spec'-and classifies changes over the persisted decode and identity surfaces.--Changes are __ADDITIVE__ when they preserve stored data, __WARNING__ when they-change forward behaviour without invalidating persisted data, and __BREAKING__-when stored payloads may stop decoding or persisted identities may be re-keyed.-The @diff --since@ CLI exits non-zero only when a breaking change is present.--Every 'Node' constructor maps to a 'NodeFamily', and 'familyRegistry' contains-exactly one entry for each family.  A family is either handled by an explicit-differ or carries a non-empty out-of-scope rationale.  This makes omissions-visible when the grammar grows instead of silently treating new node kinds as-safe.--}-module Keiro.Dsl.Diff (-    Change (..),-    ChangeKind (..),-    Label (..),-    CompatibilitySurface (..),-    SurfaceVerdict (..),-    RolloutConstraint (..),-    CompatibilityVector (..),-    ChangeContext,-    privateEventContext,-    privateEventAdditionContext,-    snapshotContext,-    queueContext,-    publicContractContext,-    persistedIdentityContext,-    consumerBuildContext,-    advisoryAt,-    changeContextRoot,-    changeContextPaths,-    classifyCompatibility,-    verdictFor,-    defaultGate,-    gateWith,-    deriveLabel,-    gatedBreaking,-    isBreaking,-    isAdvisory,-    diffSpecs,-    DiffEnv (..),-    NodeFamily (..),-    familyOf,-    FamilyDiff (..),-    familyRegistry,-    Paired (..),-    pairByName,-    readModelDiff,-    classifyWorkflowBody,-) where--import Data.List (find, (\\))-import Data.Maybe (isJust, isNothing, mapMaybe)-import Data.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.-data Change-    = Additive ChangeKind-    | Advisory ChangeKind-    | 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 :: !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 `elem` [OwnershipMoved, WorkspaceAuthorityChanged] = mappedBuildVector-    | 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-isBreaking (Advisory _) = False--isAdvisory :: Change -> Bool-isAdvisory (Advisory _) = True-isAdvisory (Additive _) = False-isAdvisory (Breaking _) = False---- | Both specs supplied to a node-family differ, always old then new.-data DiffEnv = DiffEnv-    { deOld :: !Spec-    , deNew :: !Spec-    }-    deriving stock (Eq, Show)---- | The closed set of node families currently present in 'Node'.-data NodeFamily-    = FamAggregate-    | FamProcess-    | FamRouter-    | FamContract-    | FamIntake-    | FamEmit-    | FamPublisher-    | FamWorkqueue-    | FamPgmqDispatch-    | FamReadModel-    | FamWorkflow-    | FamOperation-    deriving stock (Eq, Ord, Show, Enum, Bounded)---- | Total by construction: one explicit arm per 'Node' constructor.-familyOf :: Node -> NodeFamily-familyOf (NAggregate _) = FamAggregate-familyOf (NProcess _) = FamProcess-familyOf (NRouter _) = FamRouter-familyOf (NContract _) = FamContract-familyOf (NIntake _) = FamIntake-familyOf (NEmit _) = FamEmit-familyOf (NPublisher _) = FamPublisher-familyOf (NWorkqueue _) = FamWorkqueue-familyOf (NPgmqDispatch _) = FamPgmqDispatch-familyOf (NReadModel _) = FamReadModel-familyOf (NWorkflow _) = FamWorkflow-familyOf (NOperation _) = FamOperation---- | A family either has a differ or an explicit reason it is not compared.-data FamilyDiff-    = DiffFamily (DiffEnv -> [Change])-    | OutOfDiffScope Text---- | Pair the old and new declarations of one node family by stable name.-data Paired n = Paired-    { prMatched :: ![(n, n)]-    , prAdded :: ![n]-    , prRemoved :: ![n]-    }-    deriving stock (Eq, Show)--pairByName :: (Node -> Maybe n) -> (n -> Name) -> DiffEnv -> Paired n-pairByName project nameOf env =-    Paired-        { prMatched =-            [ (oldNode, newNode)-            | newNode <- newNodes-            , Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]-            ]-        , prAdded =-            [ newNode-            | newNode <- newNodes-            , isNothing (find ((== nameOf newNode) . nameOf) oldNodes)-            ]-        , prRemoved =-            [ oldNode-            | oldNode <- oldNodes-            , isNothing (find ((== nameOf oldNode) . nameOf) newNodes)-            ]-        }-  where-    oldNodes = mapMaybe project (specNodes (deOld env))-    newNodes = mapMaybe project (specNodes (deNew env))--{- | Registry invariant: every 'Node' constructor maps to a family via the-total 'familyOf' case, and every family occurs exactly once here.  The unit-suite enforces registry coverage and non-empty out-of-scope rationales.--}-familyRegistry :: [(NodeFamily, FamilyDiff)]-familyRegistry =-    [ (FamAggregate, DiffFamily aggregateDiff)-    , (FamProcess, DiffFamily processDiff)-    , (FamRouter, DiffFamily routerDiff)-    , (FamContract, DiffFamily contractDiff)-    , (FamIntake, DiffFamily intakeDiff)-    , (FamEmit, DiffFamily emitDiff)-    , (FamPublisher, DiffFamily publisherDiff)-    , (FamWorkqueue, DiffFamily workqueueDiff)-    , (FamPgmqDispatch, DiffFamily pgmqDispatchDiff)-    , (FamReadModel, DiffFamily readModelDiff)-    , (FamWorkflow, DiffFamily workflowDiff)-    , (FamOperation, OutOfDiffScope "operations own no persisted decode or identity surface; their references and workflow signal/await pairing are single-spec validation concerns")-    ]--diffSpecs :: Spec -> Spec -> [Change]-diffSpecs old new =-    sharedDeclarationDiff env-        ++ concatMap (runFamily env . snd) familyRegistry-  where-    env = DiffEnv old new--runFamily :: DiffEnv -> FamilyDiff -> [Change]-runFamily env (DiffFamily f) = f env-runFamily _ (OutOfDiffScope _) = []---- Rules are 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 ++ 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--nodeProcess :: Node -> Maybe ProcessNode-nodeProcess (NProcess process) = Just process-nodeProcess _ = Nothing--nodeRouter :: Node -> Maybe RouterNode-nodeRouter (NRouter router) = Just router-nodeRouter _ = Nothing--nodeContract :: Node -> Maybe ContractNode-nodeContract (NContract contract) = Just contract-nodeContract _ = Nothing--nodeIntake :: Node -> Maybe IntakeNode-nodeIntake (NIntake intake) = Just intake-nodeIntake _ = Nothing--nodeEmit :: Node -> Maybe EmitNode-nodeEmit (NEmit emit) = Just emit-nodeEmit _ = Nothing--nodePublisher :: Node -> Maybe PublisherNode-nodePublisher (NPublisher publisher) = Just publisher-nodePublisher _ = Nothing--nodeWorkqueue :: Node -> Maybe WorkqueueNode-nodeWorkqueue (NWorkqueue workqueue) = Just workqueue-nodeWorkqueue _ = Nothing--nodePgmqDispatch :: Node -> Maybe PgmqDispatchNode-nodePgmqDispatch (NPgmqDispatch dispatch) = Just dispatch-nodePgmqDispatch _ = Nothing--nodeReadModel :: Node -> Maybe ReadModelNode-nodeReadModel (NReadModel readModel) = Just readModel-nodeReadModel _ = Nothing--nodeWorkflow :: Node -> Maybe WorkflowNode-nodeWorkflow (NWorkflow workflow) = Just workflow-nodeWorkflow _ = Nothing--{- | Router identity is replay-sensitive: the stable name and key feed every-target-keyed dispatch id, and the target selects the persisted stream family.--}-routerDiff :: DiffEnv -> [Change]-routerDiff env =-    concatMap (uncurry routerPairDiff) (prMatched paired)-        ++ [additive (rtId router) "router" (rtId router) 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-        ++ routerDecideSurfaceDiff oldRouter newRouter-  where-    nodeName = rtId newRouter-    stableName =-        [ breaking nodeName "router-stable-name" nodeName RouterStableNameChanged $-            "router stable name changed from '" <> rtName oldRouter <> "' to '" <> rtName newRouter <> "'; every deterministicRouterCommandId is re-keyed, so redelivery can duplicate the full resolved fan-out"-        | rtName oldRouter /= rtName newRouter-        ]-    keyDerivation =-        [ breaking nodeName "router-key" (corrField (rtKey newRouter)) DerivedIdentityChanged "router key field or derivation changed; replay derives different target dispatch ids"-        | rtKey oldRouter /= rtKey newRouter-        ]-    target =-        [ breaking nodeName "router-target" (rtTarget newRouter) DerivedIdentityChanged "router target aggregate changed; replay addresses a different persisted stream family"-        | rtTarget oldRouter /= rtTarget newRouter-        ]--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)-        ++ concatMap addedReadModelDiff (prAdded paired)-        ++ concatMap removedReadModelDiff (prRemoved paired)-  where-    paired = pairByName nodeReadModel rmName env--readModelPairDiff :: DiffEnv -> ReadModelNode -> ReadModelNode -> [Change]-readModelPairDiff env oldReadModel newReadModel =-    versionChanges-        ++ shapeChanges-        ++ identityChanges-        ++ feedChanges-        ++ consistencyChanges-        ++ scopeChanges-  where-    nodeName = rmName newReadModel-    versionChanges-        | rmVersion newReadModel < rmVersion oldReadModel =-            [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel))-            ]-        | rmVersion newReadModel > rmVersion oldReadModel =-            [ additive nodeName "read-model-version" nodeName 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)-    newShape = (rmColumns newReadModel, rmShape newReadModel)-    shapeChanges =-        [ breaking nodeName "read-model-shape" nodeName ReadModelShapeChangedWithoutBump ("declared columns or captured shape hash changed at version " <> tInt (rmVersion newReadModel) <> "; bump version and rebuild")-        | oldShape /= newShape-        , rmVersion oldReadModel == rmVersion newReadModel-        ]-    oldRegistry = registryNameFor (specContext (deOld env)) oldReadModel-    newRegistry = registryNameFor (specContext (deNew env)) newReadModel-    oldSubscription = subscriptionNameFor (specContext (deOld env)) oldReadModel-    newSubscription = subscriptionNameFor (specContext (deNew env)) newReadModel-    identityChanges =-        [ breaking nodeName "read-model-identity" nodeName DerivedIdentityChanged ("registry name changed '" <> oldRegistry <> "' -> '" <> newRegistry <> "'; the old registration row is orphaned")-        | oldRegistry /= newRegistry-        ]-            ++ [ breaking nodeName "read-model-table" nodeName DerivedIdentityChanged ("qualified table changed '" <> qualifiedIdentity oldReadModel <> "' -> '" <> qualifiedIdentity newReadModel <> "'; existing data remains under the old identity")-               | (rmSchema oldReadModel, rmTable oldReadModel) /= (rmSchema newReadModel, rmTable newReadModel)-               ]-            ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity")-               | oldSubscription /= newSubscription-               ]-    feedChanges =-        [ breaking nodeName "read-model-feed" nodeName ReadModelFeedChanged ("feed changed " <> renderFeed (rmFeed oldReadModel) <> " -> " <> renderFeed (rmFeed newReadModel) <> "; projection wiring and rebuild identities changed")-        | rmFeed oldReadModel /= rmFeed newReadModel-        ]-    consistencyChanges = case (rmConsistency oldReadModel, rmConsistency newReadModel) of-        (Strong, Eventual) ->-            [breaking nodeName "read-model-consistency" nodeName ReadModelConsistencyWeakened "default consistency changed Strong -> Eventual; callers lose the cursor-wait guarantee"]-        (Eventual, Strong) ->-            [additive nodeName "read-model-consistency" nodeName 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 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) DeclarationAdded "new read model"]--removedReadModelDiff :: ReadModelNode -> [Change]-removedReadModelDiff readModel =-    [breaking (rmName readModel) "read-model-identity" (rmName readModel) DerivedIdentityChanged "read model removed while registered metadata, data, subscription cursors, and callers may remain"]--qualifiedIdentity :: ReadModelNode -> Text-qualifiedIdentity readModel = rmSchema readModel <> "." <> rmTable readModel--renderFeed :: RmFeed -> Text-renderFeed RmInline = "inline"-renderFeed RmSubscription = "subscription"--effectiveScope :: Maybe RmScope -> RmScope-effectiveScope Nothing = RmEntireLog-effectiveScope (Just scope) = scope--scopeStrengthened :: RmScope -> RmScope -> Bool-scopeStrengthened (RmCategory _) RmEntireLog = True-scopeStrengthened _ _ = False--renderScope :: RmScope -> Text-renderScope RmEntireLog = "entire-log"-renderScope (RmCategory categoryName) = "category '" <> categoryName <> "'"--aggregateDiff :: DiffEnv -> [Change]-aggregateDiff env =-    concatMap-        (\(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 :: 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) DeclarationAdded "new event type (new aggregate)"-    | e <- aggEvents newAgg-    ]--removedAggregateDiff :: Aggregate -> [Change]-removedAggregateDiff oldAgg =-    [ breaking (aggName oldAgg) "event" (evName e) EvtRemovedNotDeprecated "aggregate removed; its event tags are no longer decodable"-    | e <- aggEvents oldAgg-    ]---- | Per-event classification for an event present in the new aggregate.-eventDiff :: Aggregate -> Aggregate -> Event -> [Change]-eventDiff oldAgg newAgg e =-    case find ((== evName e) . evName) (aggEvents oldAgg) of-        Nothing ->-            [additive (aggName newAgg) "event" (evName e) 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) 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)-                            "event"-                            (evName e)-                            EvtVersionMissingUpcaster-                            ( "version changed from v"-                                <> tInt (evVersion oldE)-                                <> " to v"-                                <> tInt (evVersion e)-                                <> " without the required contiguous upcaster from v"-                                <> tInt (evVersion oldE)-                            )-                        ]-            | evVersion e < evVersion oldE ->-                [breaking (aggName newAgg) "event" (evName e) EvtVersionDecreased ("version decreased from v" <> tInt (evVersion oldE) <> " to v" <> tInt (evVersion e))]-            | otherwise ->-                sameVersionEventDiff oldAgg newAgg oldE e--{- | Events present in the old aggregate but absent in the new one. Removing a-tag entirely is breaking; 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; 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))-    ]--hasSource :: Maybe (Int, Hole) -> Int -> Bool-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-    EventFromCommand cn ->-        maybe [] (map fieldSig . cmdFields) (find ((== cn) . cmdName) (aggCommands agg))-  where-    fieldSig f = (fieldName f, fieldType f)--sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change]-sameVersionEventDiff oldAgg newAgg oldE newE =-    addedChanges-        ++ removedChanges-        ++ typeChanges-        ++ deprecationChanges-        ++ retirementChanges-  where-    oldFields = eventFieldSigs oldAgg oldE-    newFields = eventFieldSigs newAgg newE-    oldNames = map fst oldFields-    newNames = map fst newFields-    added = newNames \\ oldNames-    removed = oldNames \\ newNames-    changed =-        [ (field, oldType, newType)-        | (field, oldType) <- oldFields-        , Just newType <- [lookup field newFields]-        , oldType /= newType-        ]-    addedChanges =-        [ breaking (aggName newAgg) "event" (evName newE) EvtFieldAddedWithoutBump ("field(s) " <> commas added <> " added at the same version v" <> tInt (evVersion newE) <> " without a version bump or upcaster")-        | not (null added)-        ]-    removedChanges =-        [ breaking (aggName newAgg) "event" (evName newE) EvtFieldRemovedSameVersion ("field(s) " <> commas removed <> " removed at the same version v" <> tInt (evVersion newE))-        | not (null removed)-        ]-    typeChanges =-        [ breaking-            (aggName newAgg)-            "event-field"-            (evName newE <> "." <> field)-            EvtFieldTypeChanged-            ("type changed " <> renderFieldType oldType <> " -> " <> renderFieldType newType <> " at the same version v" <> tInt (evVersion newE))-        | (field, oldType, newType) <- changed-        ]-    deprecationChanges-        | not (evDeprecated oldE) && evDeprecated newE =-            [ 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)"-renderFieldType (Just name) = name--wireDiff :: Aggregate -> Aggregate -> [Change]-wireDiff oldAgg newAgg-    | effectiveWire (aggWire oldAgg) == effectiveWire (aggWire newAgg) = []-    | otherwise =-        [ breaking-            (aggName newAgg)-            "wire"-            (aggName newAgg)-            WireSpecChanged-            ("effective wire convention changed " <> renderWire (effectiveWire (aggWire oldAgg)) <> " -> " <> renderWire (effectiveWire (aggWire newAgg)))-        ]--effectiveWire :: Maybe WireSpec -> (Text, Text)-effectiveWire Nothing = ("ctorName", "camelCase")-effectiveWire (Just w) = (wireKind w, wireFields w)--renderWire :: (Text, Text) -> Text-renderWire (kindName, fieldNames) = "kind=" <> kindName <> ", fields=" <> fieldNames--projectionDiff :: Aggregate -> Aggregate -> [Change]-projectionDiff oldAggregate newAggregate-    | projectionSurface (aggProjection oldAggregate) == projectionSurface (aggProjection newAggregate) = []-    | otherwise =-        [ advisory-            (aggName newAggregate)-            "projection"-            (aggName newAggregate)-            ProjectionChanged-            "projection table, consistency, key, or status mapping changed; coordinate the read-model migration"-        ]--projectionSurface :: Maybe ProjectionSpec -> Maybe (Name, Maybe Consistency, Name, Maybe Mapping)-projectionSurface projection = do-    value <- projection-    pure (projTable value, projConsistency value, projKey value, projStatusMap value)--idDiff :: DiffEnv -> [Change]-idDiff env =-    concatMap (uncurry idPairDiff) (prMatched paired)-        ++ concatMap addedIdDiff (prAdded paired)-        ++ concatMap removedIdDiff (prRemoved paired)-  where-    paired = pairDeclarations idName (specIds (deOld env)) (specIds (deNew env))--idPairDiff :: IdDecl -> IdDecl -> [Change]-idPairDiff oldId newId =-    [ breaking (idName newId) "id-prefix" (idName newId) IdPrefixChanged ("prefix changed '" <> idPrefix oldId <> "' -> '" <> idPrefix newId <> "'; stored and newly minted ids no longer share an identity domain")-    | idPrefix oldId /= idPrefix newId-    ]--addedIdDiff :: IdDecl -> [Change]-addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) 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"]--enumDiff :: DiffEnv -> [Change]-enumDiff env =-    concatMap (uncurry (enumPairDiff (deOld env))) (prMatched paired)-        ++ concatMap addedEnumDiff (prAdded paired)-        ++ concatMap (removedEnumDiff (deOld env)) (prRemoved paired)-  where-    paired = pairDeclarations enumName (specEnums (deOld env)) (specEnums (deNew env))--enumPairDiff :: Spec -> EnumDecl -> EnumDecl -> [Change]-enumPairDiff oldSpec oldEnum newEnum =-    [ breaking (enumName newEnum) "enum-constructor" ctor EnumCtorRemoved ("constructor removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName oldEnum))-    | (ctor, wire) <- enumCtors oldEnum-    , isNothing (lookup ctor (enumCtors newEnum))-    ]-        ++ [ breaking (enumName newEnum) "enum-constructor" ctor EnumWireSpellingChanged ("wire spelling changed '" <> oldWire <> "' -> '" <> newWire <> "'; stored values using the old spelling no longer decode" <> enumUsageSuffix oldSpec (enumName oldEnum))-           | (ctor, oldWire) <- enumCtors oldEnum-           , Just newWire <- [lookup ctor (enumCtors newEnum)]-           , oldWire /= newWire-           ]-        ++ 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 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))-    | (ctor, wire) <- enumCtors enumDecl-    ]--enumUsageSuffix :: Spec -> Name -> Text-enumUsageSuffix spec enumType = case enumUsages spec enumType of-    [] -> ""-    usages -> "; used by " <> commas usages--enumUsages :: Spec -> Name -> [Text]-enumUsages spec enumType =-    [aggName agg <> ".reg." <> regName reg | agg <- aggregates, reg <- aggRegs agg, regType reg == enumType]-        ++ [ aggName agg <> ".event." <> evName event <> "." <> field-           | agg <- aggregates-           , event <- aggEvents agg-           , (field, Just fieldTypeName) <- eventFieldSigs agg event-           , fieldTypeName == enumType-           ]-  where-    aggregates = [agg | NAggregate agg <- specNodes spec]--pairDeclarations :: (n -> Name) -> [n] -> [n] -> Paired n-pairDeclarations nameOf oldNodes newNodes =-    Paired-        { prMatched =-            [ (oldNode, newNode)-            | newNode <- newNodes-            , Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]-            ]-        , prAdded = [newNode | newNode <- newNodes, isNothing (find ((== nameOf newNode) . nameOf) oldNodes)]-        , prRemoved = [oldNode | oldNode <- oldNodes, isNothing (find ((== nameOf oldNode) . nameOf) newNodes)]-        }--contractDiff :: DiffEnv -> [Change]-contractDiff env =-    concatMap (uncurry contractPairDiff) (prMatched paired)-        ++ concatMap addedContractDiff (prAdded paired)-        ++ concatMap removedContractDiff (prRemoved paired)-  where-    paired = pairByName nodeContract ctrName env--contractPairDiff :: ContractNode -> ContractNode -> [Change]-contractPairDiff oldContract newContract =-    schemaChanges-        ++ discriminatorChanges-        ++ topicChanges-        ++ concatMap eventPairChanges matchedEvents-        ++ concatMap addedEventChanges addedEvents-        ++ concatMap removedEventChanges removedEvents'-  where-    schemaChanges =-        [ breaking-            (ctrName newContract)-            "schema-version"-            (ctrName newContract)-            ContractSchemaVersionDecreased-            ("schemaVersion decreased from " <> tInt (ctrSchemaVersion oldContract) <> " to " <> tInt (ctrSchemaVersion newContract))-        | ctrSchemaVersion newContract < ctrSchemaVersion oldContract-        ]-    discriminatorChanges =-        [ breaking-            (ctrName newContract)-            "discriminator"-            (ctrName newContract)-            ContractDiscriminatorChanged-            ("discriminator changed " <> ctrDiscriminator oldContract <> " -> " <> ctrDiscriminator newContract)-        | ctrDiscriminator oldContract /= ctrDiscriminator newContract-        ]-    topicChanges = contractTopicDiff oldContract newContract-    eventPairs = pairDeclarations ceName (ctrEvents oldContract) (ctrEvents newContract)-    matchedEvents = prMatched eventPairs-    addedEvents = prAdded eventPairs-    removedEvents' = prRemoved eventPairs-    eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent-    addedEventChanges event =-        [additive (ctrName newContract) "contract-event" (ceName event) 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) ContractEventAdded "new event in a new contract" | event <- ctrEvents contract]--removedContractDiff :: ContractNode -> [Change]-removedContractDiff contract =-    [breaking (ctrName contract) "contract-event" (ceName event) ContractEventRemoved "contract removed; its cross-service event decoder is no longer declared" | event <- ctrEvents contract]--contractTopicDiff :: ContractNode -> ContractNode -> [Change]-contractTopicDiff oldContract newContract =-    [ breaking-        (ctrName newContract)-        "contract-topic"-        alias-        ContractTopicChanged-        ("topic alias removed; previous topic was '" <> oldTopic <> "'")-    | (alias, oldTopic) <- ctrTopics oldContract-    , isNothing (lookup alias (ctrTopics newContract))-    ]-        ++ [ breaking-                (ctrName newContract)-                "contract-topic"-                alias-                ContractTopicChanged-                ("real topic changed '" <> oldTopic <> "' -> '" <> newTopic <> "'")-           | (alias, oldTopic) <- ctrTopics oldContract-           , Just newTopic <- [lookup alias (ctrTopics newContract)]-           , oldTopic /= newTopic-           ]-        ++ [ additive (ctrName newContract) "contract-topic" alias ContractTopicAdded ("new topic alias for '" <> topic <> "'")-           | (alias, topic) <- ctrTopics newContract-           , isNothing (lookup alias (ctrTopics oldContract))-           ]--contractEventDiff :: ContractNode -> ContractNode -> ContractEvent -> ContractEvent -> [Change]-contractEventDiff oldContract newContract oldEvent newEvent =-    topicAliasChange-        ++ removedFieldChanges-        ++ changedFieldChanges-        ++ addedFieldChanges-  where-    fieldPairs = pairDeclarations cfName (ceFields oldEvent) (ceFields newEvent)-    topicAliasChange =-        [ breaking-            (ctrName newContract)-            "contract-topic"-            (ceName newEvent)-            ContractTopicChanged-            ("event topic alias changed " <> ceTopic oldEvent <> " -> " <> ceTopic newEvent)-        | ceTopic oldEvent /= ceTopic newEvent-        ]-    removedFieldChanges =-        [ breaking (ctrName newContract) "contract-field" (ceName newEvent <> "." <> cfName field) ContractFieldChanged "field removed; existing messages still carry the old contract shape"-        | field <- prRemoved fieldPairs-        ]-    changedFieldChanges =-        [ breaking-            (ctrName newContract)-            "contract-field"-            (ceName newEvent <> "." <> cfName newField)-            ContractFieldChanged-            ("field type changed " <> renderContractType (cfType oldField) <> " -> " <> renderContractType (cfType newField))-        | (oldField, newField) <- prMatched fieldPairs-        , cfType oldField /= cfType newField-        ]-    addedFieldChanges =-        [ if ctrSchemaVersion newContract > ctrSchemaVersion oldContract-            then advisory (ctrName newContract) "contract-field" subject ContractSchemaVersionBumped ("field added with schemaVersion bump " <> tInt (ctrSchemaVersion oldContract) <> " -> " <> tInt (ctrSchemaVersion newContract) <> "; coordinate the cross-service rollout")-            else breaking (ctrName newContract) "contract-field" subject ContractFieldChanged "field added without a schemaVersion bump; older in-flight messages do not contain it"-        | field <- prAdded fieldPairs-        , let subject = ceName newEvent <> "." <> cfName field-        ]--renderContractType :: ContractType -> Text-renderContractType (CTypeId prefix) = "typeid '" <> prefix <> "'"-renderContractType CText = "text"-renderContractType CInt = "int"--workqueueDiff :: DiffEnv -> [Change]-workqueueDiff env =-    concatMap (uncurry workqueuePairDiff) (prMatched paired)-        ++ concatMap addedWorkqueueDiff (prAdded paired)-        ++ concatMap removedWorkqueueDiff (prRemoved paired)-  where-    paired = pairByName nodeWorkqueue wqName env--workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change]-workqueuePairDiff oldQueue newQueue =-    concatMap pairedFieldDiff (prMatched fields)-        ++ concatMap addedFieldDiff (prAdded fields)-        ++ concatMap removedFieldDiff (prRemoved fields)-        ++ queueIdentityDiff oldQueue newQueue-        ++ queuePolicyDiff oldQueue newQueue-  where-    -- wqPayloadName is a generated Haskell type name, not a wire-visible name.-    fields = pairDeclarations wqfName (wqPayload oldQueue) (wqPayload newQueue)-    pairedFieldDiff (oldField, newField)-        | wqfWire oldField /= wqfWire newField = [payloadBreaking newField ("wire name changed '" <> wqfWire oldField <> "' -> '" <> wqfWire newField <> "'")]-        | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> wqfType oldField <> " -> " <> wqfType newField)]-        | not (wqfRequired oldField) && wqfRequired newField = [payloadBreaking newField "field changed from optional to required; queued jobs may omit it"]-        | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) 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) 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) DeclarationAdded "field belongs to a new workqueue payload" | field <- wqPayload queue]--removedWorkqueueDiff :: WorkqueueNode -> [Change]-removedWorkqueueDiff queue =-    [breaking (wqName queue) "payload-field" (wqfName field) WqPayloadFieldChanged "workqueue removed while persisted jobs may still carry this payload" | field <- wqPayload queue]-        ++ [breaking (wqName queue) "queue-identity" (wqName queue) QueueIdentityChanged "workqueue removed; its physical queue, DLQ, and pgmq table may still hold state"]--queueIdentityDiff :: WorkqueueNode -> WorkqueueNode -> [Change]-queueIdentityDiff oldQueue newQueue =-    [ breaking-        (wqName newQueue)-        "queue-identity"-        (wqName newQueue)-        QueueIdentityChanged-        "logical, physical, DLQ, or table name changed; queued jobs and dispatch dedupe records remain under the old identity"-    | queueIdentity oldQueue /= queueIdentity newQueue-    ]--queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text)-queueIdentity queue = (wqLogical queue, wqPhysical queue, wqDlq queue, wqTable queue)--queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change]-queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey-  where-    nodeName = wqName newQueue-    ordering =-        [ breaking nodeName "queue-ordering" nodeName WqOrderingChanged $-            "ordering changed " <> renderWqOrdering (wqOrdering oldQueue) <> " -> " <> renderWqOrdering (wqOrdering newQueue) <> "; consumers were written against the old delivery-order contract"-        | wqOrdering oldQueue /= wqOrdering newQueue-        ]-    provision =-        [ breaking nodeName "queue-provision" nodeName WqProvisionChanged $-            "provision changed " <> renderWqProvision (wqProvision oldQueue) <> " -> " <> renderWqProvision (wqProvision newQueue) <> "; provisioning is create-time only, so migrate the existing queue operationally before changing the spec"-        | wqProvision oldQueue /= wqProvision newQueue-        ]-    groupKey =-        [ breaking nodeName "queue-group-key" nodeName WqGroupKeyChanged $-            "group key derivation changed " <> renderWqGroupKey (wqGroupKey oldQueue) <> " -> " <> renderWqGroupKey (wqGroupKey newQueue) <> "; FIFO messages are re-partitioned across durable ordering groups"-        | wqGroupKey oldQueue /= wqGroupKey newQueue-        ]--renderWqOrdering :: WqOrdering -> Text-renderWqOrdering WqUnordered = "unordered"-renderWqOrdering WqFifoThroughput = "fifo-throughput"-renderWqOrdering WqFifoRoundRobin = "fifo-roundrobin"--renderWqProvision :: WqProvision -> Text-renderWqProvision WqStandard = "standard"-renderWqProvision WqUnlogged = "unlogged"-renderWqProvision (WqPartitioned interval duration) = "partitioned(interval=" <> interval <> ", retention=" <> duration <> ")"--renderWqGroupKey :: Maybe WqGroupKey -> Text-renderWqGroupKey Nothing = "none"-renderWqGroupKey (Just groupKey) =-    gkField groupKey-        <> " via "-        <> gkVia groupKey-        <> maybe "" (" fixture " <>) (gkFixture groupKey)--processDiff :: DiffEnv -> [Change]-processDiff env =-    concatMap (uncurry processPairDiff) (prMatched paired)-        ++ concatMap addedProcessDiff (prAdded paired)-        ++ concatMap removedProcessDiff (prRemoved paired)-  where-    paired = pairByName nodeProcess procId env--processPairDiff :: ProcessNode -> ProcessNode -> [Change]-processPairDiff oldProcess newProcess =-    concatMap pairedFieldDiff (prMatched fields)-        ++ map (fieldChange "field added; source events at the old shape cannot populate it") (prAdded fields)-        ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields)-        ++ processIdentityDiff oldProcess newProcess-        ++ processTimerWindowDiff oldProcess newProcess-        ++ 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))-    pairedFieldDiff (oldField, newField)-        | fieldType oldField /= fieldType newField = [fieldChange ("type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField)) newField]-        | otherwise = []-    fieldChange detail field = breaking (procId newProcess) "input-field" (fieldName field) ProcessInputChanged (detail <> "; version the source event before changing process input")--addedProcessDiff :: ProcessNode -> [Change]-addedProcessDiff process =-    [additive (procId process) "input-field" (fieldName field) DeclarationAdded "field belongs to a new process input" | field <- inFields (procInput process)]--removedProcessDiff :: ProcessNode -> [Change]-removedProcessDiff process =-    [breaking (procId process) "input-field" (fieldName field) ProcessInputChanged "process removed while persisted source events may still require this input decoder" | field <- inFields (procInput process)]-        ++ [breaking (procId process) "derived-identity" (procId process) DerivedIdentityChanged "process removed while persisted saga, dispatch, and timer identities may still exist"]--processIdentityDiff :: ProcessNode -> ProcessNode -> [Change]-processIdentityDiff oldProcess newProcess =-    [ breaking-        (procId newProcess)-        "derived-identity"-        (procId newProcess)-        DerivedIdentityChanged-        "process name, correlation derivation, saga stream category, timer id prefix, or fired-event-id prefix changed; replays and retries no longer derive the persisted identity"-    | processIdentity oldProcess /= processIdentity newProcess-    ]--processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Text)-processIdentity process =-    ( procName process-    , corrField (procCorrelate process)-    , corrVia (procCorrelate process)-    , sagaCategory (procSaga process)-    , idePrefix (tmId (procTimer process))-    , idePrefix (fireFiredEventId (tmFire (procTimer process)))-    )--processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change]-processTimerWindowDiff oldProcess newProcess =-    [ advisory-        (procId newProcess)-        "timer"-        (tmName (procTimer newProcess))-        TimerWindowChanged-        ( "fireAt source/window changed "-            <> renderFireAt (tmFireAt (procTimer oldProcess))-            <> " -> "-            <> renderFireAt (tmFireAt (procTimer newProcess))-            <> "; already-scheduled timers keep their persisted deadline"-        )-    | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess)-    ]--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--workflowDiff :: DiffEnv -> [Change]-workflowDiff env =-    concatMap (uncurry workflowPairDiff) (prMatched paired)-        ++ concatMap addedWorkflowDiff (prAdded paired)-        ++ concatMap removedWorkflowDiff (prRemoved paired)-  where-    paired = pairByName nodeWorkflow wfId env--workflowPairDiff :: WorkflowNode -> WorkflowNode -> [Change]-workflowPairDiff oldWorkflow newWorkflow =-    inputChanges-        ++ outputChanges-        ++ classifyWorkflowBody oldWorkflow newWorkflow-        ++ workflowIdentityDiff oldWorkflow newWorkflow-  where-    fields = pairDeclarations fieldName (wfInputFields oldWorkflow) (wfInputFields newWorkflow)-    inputChanges =-        [workflowShape field "input field added; journaled inputs at the old shape do not contain it" | field <- prAdded fields]-            ++ [workflowShape field "input field removed; journaled inputs still contain the old shape" | field <- prRemoved fields]-            ++ [ workflowShape newField ("input field type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField))-               | (oldField, newField) <- prMatched fields-               , fieldType oldField /= fieldType newField-               ]-    outputChanges =-        [ breaking (wfId newWorkflow) "workflow-output" (wfOutput newWorkflow) WorkflowShapeChanged ("output type changed " <> wfOutput oldWorkflow <> " -> " <> wfOutput newWorkflow <> "; persisted outcomes may no longer decode")-        | wfOutput oldWorkflow /= wfOutput newWorkflow-        ]-    workflowShape field detail = breaking (wfId newWorkflow) "workflow-input" (fieldName field) WorkflowShapeChanged detail--addedWorkflowDiff :: WorkflowNode -> [Change]-addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) 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"]--workflowIdentityDiff :: WorkflowNode -> WorkflowNode -> [Change]-workflowIdentityDiff oldWorkflow newWorkflow =-    [ breaking-        (wfId newWorkflow)-        "workflow-name"-        (wfId newWorkflow)-        WorkflowStableNameChanged-        ("stable name changed '" <> wfStable oldWorkflow <> "' -> '" <> wfStable newWorkflow <> "'; in-flight journals remain under the old stream name")-    | wfStable oldWorkflow /= wfStable newWorkflow-    ]-        ++ [ breaking-                (wfId newWorkflow)-                "derived-identity"-                (wfId newWorkflow)-                DerivedIdentityChanged-                "workflow id source field or derivation changed; journal and deterministic child/step identities no longer coalesce with persisted executions"-           | (wfIdField oldWorkflow, wfIdVia oldWorkflow) /= (wfIdField newWorkflow, wfIdVia newWorkflow)-           ]--intakeDiff :: DiffEnv -> [Change]-intakeDiff env =-    concatMap (uncurry intakePairDiff) (prMatched paired)-        ++ concatMap addedIntakeDiff (prAdded paired)-        ++ concatMap removedIntakeDiff (prRemoved paired)-  where-    paired = pairByName nodeIntake inkName env--intakePairDiff :: IntakeNode -> IntakeNode -> [Change]-intakePairDiff oldIntake newIntake =-    [ breaking-        (inkName newIntake)-        "dedupe-identity"-        (inkName newIntake)-        DedupeIdentityChanged-        "dedupe key or policy changed; redelivered messages no longer match their persisted dedupe record"-    | (inkDedupeKey oldIntake, inkDedupePolicy oldIntake) /= (inkDedupeKey newIntake, inkDedupePolicy newIntake)-    ]-        ++ [ advisory-                (inkName newIntake)-                "decode-posture"-                (inkName newIntake)-                DecodePostureChanged-                "envelope/body decode posture changed; future messages are accepted or rejected differently"-           | inkDecode oldIntake /= inkDecode newIntake-           ]-        ++ [ advisory-                (inkName newIntake)-                "inbox-persistence"-                (inkName newIntake)-                IntakePersistenceChanged-                ("success-path envelope persistence changed " <> renderInkPersist (inkPersist oldIntake) <> " -> " <> renderInkPersist (inkPersist newIntake) <> "; existing rows are unchanged while future successful rows retain a different envelope shape")-           | inkPersist oldIntake /= inkPersist newIntake-           ]--renderInkPersist :: InkPersist -> Text-renderInkPersist InkPersistFull = "full-envelope"-renderInkPersist InkPersistDedupeOnly = "dedupe-only"--addedIntakeDiff :: IntakeNode -> [Change]-addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) 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"]--emitDiff :: DiffEnv -> [Change]-emitDiff env =-    concatMap (uncurry emitPairDiff) (prMatched paired)-        ++ concatMap addedEmitDiff (prAdded paired)-        ++ concatMap removedEmitDiff (prRemoved paired)-  where-    paired = pairByName nodeEmit emName env--emitPairDiff :: EmitNode -> EmitNode -> [Change]-emitPairDiff oldEmit newEmit =-    [ breaking-        (emName newEmit)-        "derived-identity"-        "messageId"-        DerivedIdentityChanged-        "messageId derive prefix changed; outbox retries no longer coalesce with persisted messages"-    | emMessageId oldEmit /= emMessageId newEmit-    ]-        ++ [ breaking-                (emName newEmit)-                "derived-identity"-                "idempotencyKey"-                DerivedIdentityChanged-                "idempotencyKey derive prefix changed; downstream dedupe no longer matches persisted messages"-           | emIdempotencyKey oldEmit /= emIdempotencyKey newEmit-           ]-        ++ [ advisory-                (emName newEmit)-                "emit-mapping"-                (emName newEmit)-                EmitMappingChanged-                "emit key, status discriminant, mapping rows, or explicit skip posture changed"-           | emitMapping oldEmit /= emitMapping newEmit-           ]--emitMapping :: EmitNode -> (Name, Name, [EmitMapRow], Bool)-emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit)--addedEmitDiff :: EmitNode -> [Change]-addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) 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"]--publisherDiff :: DiffEnv -> [Change]-publisherDiff env =-    concatMap (uncurry publisherPairDiff) (prMatched paired)-        ++ concatMap addedPublisherDiff (prAdded paired)-        ++ concatMap removedPublisherDiff (prRemoved paired)-  where-    paired = pairByName nodePublisher pubName env--publisherPairDiff :: PublisherNode -> PublisherNode -> [Change]-publisherPairDiff oldPublisher newPublisher =-    -- maxAttempts/backoff are retry tuning, not persisted decode or identity.-    [ breaking-        (pubName newPublisher)-        "derived-identity"-        "outboxId"-        DerivedIdentityChanged-        "stable outbox-id source field changed; retries no longer coalesce with persisted outbox rows"-    | pubOutboxField oldPublisher /= pubOutboxField newPublisher-    ]-        ++ [ advisory-                (pubName newPublisher)-                "publisher-policy"-                (pubName newPublisher)-                PublisherPolicyChanged-                ("ordering changed " <> pubOrdering oldPublisher <> " -> " <> pubOrdering newPublisher)-           | pubOrdering oldPublisher /= pubOrdering newPublisher-           ]--addedPublisherDiff :: PublisherNode -> [Change]-addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) 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"]--pgmqDispatchDiff :: DiffEnv -> [Change]-pgmqDispatchDiff env =-    concatMap (uncurry pgmqDispatchPairDiff) (prMatched paired)-        ++ concatMap addedPgmqDispatchDiff (prAdded paired)-        ++ concatMap removedPgmqDispatchDiff (prRemoved paired)-  where-    paired = pairByName nodePgmqDispatch pdName env--pgmqDispatchPairDiff :: PgmqDispatchNode -> PgmqDispatchNode -> [Change]-pgmqDispatchPairDiff oldDispatch newDispatch =-    [ breaking-        (pdName newDispatch)-        "dedupe-identity"-        (pdName newDispatch)-        DedupeIdentityChanged-        "dispatch dedupe key/read-model/queue surface changed; prior enqueue records no longer match"-    | dispatchDedupe oldDispatch /= dispatchDedupe newDispatch-    ]-        ++ [ advisory-                (pdName newDispatch)-                "retarget"-                (pdName newDispatch)-                DispatchRetargeted-                "source read model or target queue changed; future fan-out is routed differently"-           | dispatchTargets oldDispatch /= dispatchTargets newDispatch-           ]--dispatchDedupe :: PgmqDispatchNode -> (Name, Name, Text, Name, Text)-dispatchDedupe dispatch =-    ( pdDedupKey dispatch-    , pdDedupReadModel dispatch-    , pdDedupReadModelField dispatch-    , pdDedupQueue dispatch-    , pdDedupQueueField dispatch-    )--dispatchTargets :: PgmqDispatchNode -> (Name, Name)-dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch)--addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]-addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) 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"]--{- | Classify the runtime's sanctioned workflow-evolution mechanisms before-falling back to the conservative unguarded-body rule.--}-classifyWorkflowBody :: WorkflowNode -> WorkflowNode -> [Change]-classifyWorkflowBody oldWorkflow newWorkflow-    | oldBody == newBody = []-    | not (null removedPatchIds) = map removedPatch removedPatchIds-    | Just (oldSeedType, newSeedType) <- changedSeed =-        [ breaking nodeName "workflow-continue-as-new" nodeName WorkflowContinueSeedChanged $-            "continueAsNew seed type changed " <> oldSeedType <> " -> " <> newSeedType <> "; the next generation's restoreSeed must decode the seed written by the previous generation"-        ]-    | safeAdditions =-        map addedPatch newPatchIds-            ++ [ additive nodeName "workflow-continue-as-new" seedType WorkflowEvolutionGuardAdded "terminal continueAsNew is additive; old generations carry no rotation marker"-               | Just seedType <- [appendedSeed]-               ]-    | otherwise =-        [ breaking-            nodeName-            "workflow-body"-            nodeName-            WorkflowBodyChanged-            "workflow body labels, kinds, result types, or order changed without a new patch guard; wrap a cross-cutting change in patch, or rename the replay label for one changed step"-        ]-  where-    nodeName = wfId newWorkflow-    oldBody = normaliseWorkflowBody (wfBody oldWorkflow)-    newBody = normaliseWorkflowBody (wfBody newWorkflow)-    oldPatchIds = workflowBodyPatchIds oldBody-    newPatchIdsAll = workflowBodyPatchIds newBody-    newPatchIds = newPatchIdsAll \\ oldPatchIds-    removedPatchIds = oldPatchIds \\ newPatchIdsAll-    oldSeed = terminalContinueSeed oldBody-    newSeed = terminalContinueSeed newBody-    changedSeed = case (oldSeed, newSeed) of-        (Just oldSeedType, Just newSeedType)-            | oldSeedType /= newSeedType -> Just (oldSeedType, newSeedType)-        _ -> Nothing-    appendedSeed = case (oldSeed, newSeed) of-        (Nothing, Just seedType) -> Just seedType-        _ -> Nothing-    strippedNewBody = stripNewPatches newPatchIds newBody-    comparableNewBody = case appendedSeed of-        Just _ -> dropTerminalContinue strippedNewBody-        Nothing -> strippedNewBody-    safeAdditions =-        (not (null newPatchIds) || isJust appendedSeed)-            && comparableNewBody == oldBody-    removedPatch patchId =-        breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch"-    addedPatch patchId =-        additive nodeName "workflow-patch" patchId WorkflowEvolutionGuardAdded "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"--normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem]-normaliseWorkflowBody = map go-  where-    go (WfStep label result _) = WfStep label result noLoc-    go (WfAwait label result _) = WfAwait label result noLoc-    go (WfSleep label delay _) = WfSleep label delay noLoc-    go (WfChild label via result _) = WfChild label via result noLoc-    go (WfPatch patchId items _) = WfPatch patchId (normaliseWorkflowBody items) noLoc-    go (WfContinueAsNew seedType _) = WfContinueAsNew seedType noLoc--workflowBodyPatchIds :: [WfBodyItem] -> [Name]-workflowBodyPatchIds = concatMap go-  where-    go (WfPatch patchId items _) = patchId : workflowBodyPatchIds items-    go _ = []--stripNewPatches :: [Name] -> [WfBodyItem] -> [WfBodyItem]-stripNewPatches newPatchIds = concatMap go-  where-    go (WfPatch patchId _ _) | patchId `elem` newPatchIds = []-    go (WfPatch patchId items loc) = [WfPatch patchId (stripNewPatches newPatchIds items) loc]-    go item = [item]--terminalContinueSeed :: [WfBodyItem] -> Maybe Name-terminalContinueSeed items = case reverse items of-    WfContinueAsNew seedType _ : _ -> Just seedType-    _ -> Nothing--dropTerminalContinue :: [WfBodyItem] -> [WfBodyItem]-dropTerminalContinue items = case reverse items of-    WfContinueAsNew{} : rest -> reverse rest-    _ -> items--additive :: Name -> Text -> Text -> 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 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 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 `elem` [OwnershipMoved, WorkspaceAuthorityChanged] -> consumerBuildContext 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+-- | The spec evolution differ. 'diffSpecs' compares an /old/ and a /new/ 'Spec'+-- and classifies changes over the persisted decode and identity surfaces.+--+-- Changes are __ADDITIVE__ when they preserve stored data, __WARNING__ when they+-- change forward behaviour without invalidating persisted data, and __BREAKING__+-- when stored payloads may stop decoding or persisted identities may be re-keyed.+-- The @diff --since@ CLI exits non-zero only when a breaking change is present.+--+-- Every 'Node' constructor maps to a 'NodeFamily', and 'familyRegistry' contains+-- exactly one entry for each family.  A family is either handled by an explicit+-- differ or carries a non-empty out-of-scope rationale.  This makes omissions+-- visible when the grammar grows instead of silently treating new node kinds as+-- safe.+module Keiro.Dsl.Diff+  ( Change (..),+    ChangeKind (..),+    Label (..),+    CompatibilitySurface (..),+    SurfaceVerdict (..),+    RolloutConstraint (..),+    CompatibilityVector (..),+    ChangeContext,+    privateEventContext,+    privateEventAdditionContext,+    snapshotContext,+    queueContext,+    publicContractContext,+    persistedIdentityContext,+    consumerBuildContext,+    advisoryAt,+    changeContextRoot,+    changeContextPaths,+    classifyCompatibility,+    verdictFor,+    defaultGate,+    gateWith,+    deriveLabel,+    gatedBreaking,+    isBreaking,+    isAdvisory,+    diffSources,+    sourceLanguageChange,+    diffSpecs,+    DiffEnv (..),+    NodeFamily (..),+    familyOf,+    FamilyDiff (..),+    familyRegistry,+    Paired (..),+    pairByName,+    readModelDiff,+    classifyWorkflowBody,+  )+where++import Data.Char (toUpper)+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.AggregateType (typeExprCanonicalName)+import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, languageVersionText, sourceFormText)+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.+data Change+  = Additive ChangeKind+  | Advisory ChangeKind+  | 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 :: !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++sourceProvenanceVector :: CompatibilityVector+sourceProvenanceVector =+  CompatibilityVector+    VCompatible+    VCompatible+    VCompatible+    VCompatible+    VCompatible+    VCompatible+    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 == SourceLanguageDeclarationChanged = sourceProvenanceVector+  | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged] = mappedBuildVector+  | 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 == NominalFixturesChanged = mappedBuildVector+  | code == NominalBindingChanged = mappedBindingVector context+  | code `elem` [NominalInitialChanged, NominalCanonicalTypeChanged] = mappedSnapshotBuildVector context+  | code == NominalRepresentationChanged = mappedWireBreakingVector context+  | code == NominalIdDecoderTightened =+      (advisoryVector PrivateHistoryRead Set.empty) {cvConsumerBuild = VAdvisory}+  | 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+isBreaking (Advisory _) = False++isAdvisory :: Change -> Bool+isAdvisory (Advisory _) = True+isAdvisory (Additive _) = False+isAdvisory (Breaking _) = False++-- | Both specs supplied to a node-family differ, always old then new.+data DiffEnv = DiffEnv+  { deOld :: !Spec,+    deNew :: !Spec+  }+  deriving stock (Eq, Show)++-- | The closed set of node families currently present in 'Node'.+data NodeFamily+  = FamAggregate+  | FamProcess+  | FamRouter+  | FamContract+  | FamIntake+  | FamEmit+  | FamPublisher+  | FamWorkqueue+  | FamPgmqDispatch+  | FamReadModel+  | FamWorkflow+  | FamOperation+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | Total by construction: one explicit arm per 'Node' constructor.+familyOf :: Node -> NodeFamily+familyOf (NAggregate _) = FamAggregate+familyOf (NProcess _) = FamProcess+familyOf (NRouter _) = FamRouter+familyOf (NContract _) = FamContract+familyOf (NIntake _) = FamIntake+familyOf (NEmit _) = FamEmit+familyOf (NPublisher _) = FamPublisher+familyOf (NWorkqueue _) = FamWorkqueue+familyOf (NPgmqDispatch _) = FamPgmqDispatch+familyOf (NReadModel _) = FamReadModel+familyOf (NWorkflow _) = FamWorkflow+familyOf (NOperation _) = FamOperation++-- | A family either has a differ or an explicit reason it is not compared.+data FamilyDiff+  = DiffFamily (DiffEnv -> [Change])+  | OutOfDiffScope Text++-- | Pair the old and new declarations of one node family by stable name.+data Paired n = Paired+  { prMatched :: ![(n, n)],+    prAdded :: ![n],+    prRemoved :: ![n]+  }+  deriving stock (Eq, Show)++pairByName :: (Node -> Maybe n) -> (n -> Name) -> DiffEnv -> Paired n+pairByName project nameOf env =+  Paired+    { prMatched =+        [ (oldNode, newNode)+        | newNode <- newNodes,+          Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]+        ],+      prAdded =+        [ newNode+        | newNode <- newNodes,+          isNothing (find ((== nameOf newNode) . nameOf) oldNodes)+        ],+      prRemoved =+        [ oldNode+        | oldNode <- oldNodes,+          isNothing (find ((== nameOf oldNode) . nameOf) newNodes)+        ]+    }+  where+    oldNodes = mapMaybe project (specNodes (deOld env))+    newNodes = mapMaybe project (specNodes (deNew env))++-- | Registry invariant: every 'Node' constructor maps to a family via the+-- total 'familyOf' case, and every family occurs exactly once here.  The unit+-- suite enforces registry coverage and non-empty out-of-scope rationales.+familyRegistry :: [(NodeFamily, FamilyDiff)]+familyRegistry =+  [ (FamAggregate, DiffFamily aggregateDiff),+    (FamProcess, DiffFamily processDiff),+    (FamRouter, DiffFamily routerDiff),+    (FamContract, DiffFamily contractDiff),+    (FamIntake, DiffFamily intakeDiff),+    (FamEmit, DiffFamily emitDiff),+    (FamPublisher, DiffFamily publisherDiff),+    (FamWorkqueue, DiffFamily workqueueDiff),+    (FamPgmqDispatch, DiffFamily pgmqDispatchDiff),+    (FamReadModel, DiffFamily readModelDiff),+    (FamWorkflow, DiffFamily workflowDiff),+    (FamOperation, OutOfDiffScope "operations own no persisted decode or identity surface; their references and workflow signal/await pairing are single-spec validation concerns")+  ]++diffSpecs :: Spec -> Spec -> [Change]+diffSpecs old new =+  sharedDeclarationDiff env+    ++ concatMap (runFamily env . snd) familyRegistry+  where+    env = DiffEnv old new++-- | Compare provenance first, then delegate semantic graphs to 'diffSpecs'.+diffSources :: ParsedSource -> ParsedSource -> [Change]+diffSources old new =+  sourceLanguageChange+    (specContext (parsedSpec new))+    "declaration"+    (parsedSourceLanguage old)+    (parsedSourceLanguage new)+    <> diffSpecs (parsedSpec old) (parsedSpec new)++-- | One all-compatible source-provenance finding, reusable per workspace member.+sourceLanguageChange :: Name -> Text -> SourceLanguage -> SourceLanguage -> [Change]+sourceLanguageChange root subject old new+  | old == new = []+  | otherwise =+      [ mkChange+          LabelAdditive+          (ChangeContext root [] ContextGeneral LabelAdditive)+          root+          "source-language"+          subject+          SourceLanguageDeclarationChanged+          ( "source form changed "+              <> renderSourceLanguage old+              <> " -> "+              <> renderSourceLanguage new+              <> "; the effective semantic contract is unchanged"+          )+      ]+  where+    renderSourceLanguage sourceLanguage =+      sourceFormText sourceLanguage+        <> maybe "" ((" v" <>) . languageVersionText) (declaredLanguageVersionMaybe sourceLanguage)++runFamily :: DiffEnv -> FamilyDiff -> [Change]+runFamily env (DiffFamily f) = f env+runFamily _ (OutOfDiffScope _) = []++-- 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 ++ nominalScalarDiff 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++nodeProcess :: Node -> Maybe ProcessNode+nodeProcess (NProcess process) = Just process+nodeProcess _ = Nothing++nodeRouter :: Node -> Maybe RouterNode+nodeRouter (NRouter router) = Just router+nodeRouter _ = Nothing++nodeContract :: Node -> Maybe ContractNode+nodeContract (NContract contract) = Just contract+nodeContract _ = Nothing++nodeIntake :: Node -> Maybe IntakeNode+nodeIntake (NIntake intake) = Just intake+nodeIntake _ = Nothing++nodeEmit :: Node -> Maybe EmitNode+nodeEmit (NEmit emit) = Just emit+nodeEmit _ = Nothing++nodePublisher :: Node -> Maybe PublisherNode+nodePublisher (NPublisher publisher) = Just publisher+nodePublisher _ = Nothing++nodeWorkqueue :: Node -> Maybe WorkqueueNode+nodeWorkqueue (NWorkqueue workqueue) = Just workqueue+nodeWorkqueue _ = Nothing++nodePgmqDispatch :: Node -> Maybe PgmqDispatchNode+nodePgmqDispatch (NPgmqDispatch dispatch) = Just dispatch+nodePgmqDispatch _ = Nothing++nodeReadModel :: Node -> Maybe ReadModelNode+nodeReadModel (NReadModel readModel) = Just readModel+nodeReadModel _ = Nothing++nodeWorkflow :: Node -> Maybe WorkflowNode+nodeWorkflow (NWorkflow workflow) = Just workflow+nodeWorkflow _ = Nothing++-- | Router identity is replay-sensitive: the stable name and key feed every+-- target-keyed dispatch id, and the target selects the persisted stream family.+routerDiff :: DiffEnv -> [Change]+routerDiff env =+  concatMap (uncurry routerPairDiff) (prMatched paired)+    ++ [additive (rtId router) "router" (rtId router) 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+    ++ routerDecideSurfaceDiff oldRouter newRouter+  where+    nodeName = rtId newRouter+    stableName =+      [ breaking nodeName "router-stable-name" nodeName RouterStableNameChanged $+          "router stable name changed from '" <> rtName oldRouter <> "' to '" <> rtName newRouter <> "'; every deterministicRouterCommandId is re-keyed, so redelivery can duplicate the full resolved fan-out"+      | rtName oldRouter /= rtName newRouter+      ]+    keyDerivation =+      [ breaking nodeName "router-key" (corrField (rtKey newRouter)) DerivedIdentityChanged "router key field or derivation changed; replay derives different target dispatch ids"+      | rtKey oldRouter /= rtKey newRouter+      ]+    target =+      [ breaking nodeName "router-target" (rtTarget newRouter) DerivedIdentityChanged "router target aggregate changed; replay addresses a different persisted stream family"+      | rtTarget oldRouter /= rtTarget newRouter+      ]++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)+    ++ concatMap addedReadModelDiff (prAdded paired)+    ++ concatMap removedReadModelDiff (prRemoved paired)+  where+    paired = pairByName nodeReadModel rmName env++readModelPairDiff :: DiffEnv -> ReadModelNode -> ReadModelNode -> [Change]+readModelPairDiff env oldReadModel newReadModel =+  versionChanges+    ++ shapeChanges+    ++ identityChanges+    ++ feedChanges+    ++ consistencyChanges+    ++ scopeChanges+  where+    nodeName = rmName newReadModel+    versionChanges+      | rmVersion newReadModel < rmVersion oldReadModel =+          [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel))+          ]+      | rmVersion newReadModel > rmVersion oldReadModel =+          [ additive nodeName "read-model-version" nodeName 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)+    newShape = (rmColumns newReadModel, rmShape newReadModel)+    shapeChanges =+      [ breaking nodeName "read-model-shape" nodeName ReadModelShapeChangedWithoutBump ("declared columns or captured shape hash changed at version " <> tInt (rmVersion newReadModel) <> "; bump version and rebuild")+      | oldShape /= newShape,+        rmVersion oldReadModel == rmVersion newReadModel+      ]+    oldRegistry = registryNameFor (specContext (deOld env)) oldReadModel+    newRegistry = registryNameFor (specContext (deNew env)) newReadModel+    oldSubscription = subscriptionNameFor (specContext (deOld env)) oldReadModel+    newSubscription = subscriptionNameFor (specContext (deNew env)) newReadModel+    identityChanges =+      [ breaking nodeName "read-model-identity" nodeName DerivedIdentityChanged ("registry name changed '" <> oldRegistry <> "' -> '" <> newRegistry <> "'; the old registration row is orphaned")+      | oldRegistry /= newRegistry+      ]+        ++ [ breaking nodeName "read-model-table" nodeName DerivedIdentityChanged ("qualified table changed '" <> qualifiedIdentity oldReadModel <> "' -> '" <> qualifiedIdentity newReadModel <> "'; existing data remains under the old identity")+           | (rmSchema oldReadModel, rmTable oldReadModel) /= (rmSchema newReadModel, rmTable newReadModel)+           ]+        ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity")+           | oldSubscription /= newSubscription+           ]+    feedChanges =+      [ breaking nodeName "read-model-feed" nodeName ReadModelFeedChanged ("feed changed " <> renderFeed (rmFeed oldReadModel) <> " -> " <> renderFeed (rmFeed newReadModel) <> "; projection wiring and rebuild identities changed")+      | rmFeed oldReadModel /= rmFeed newReadModel+      ]+    consistencyChanges = case (rmConsistency oldReadModel, rmConsistency newReadModel) of+      (Strong, Eventual) ->+        [breaking nodeName "read-model-consistency" nodeName ReadModelConsistencyWeakened "default consistency changed Strong -> Eventual; callers lose the cursor-wait guarantee"]+      (Eventual, Strong) ->+        [additive nodeName "read-model-consistency" nodeName 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 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) DeclarationAdded "new read model"]++removedReadModelDiff :: ReadModelNode -> [Change]+removedReadModelDiff readModel =+  [breaking (rmName readModel) "read-model-identity" (rmName readModel) DerivedIdentityChanged "read model removed while registered metadata, data, subscription cursors, and callers may remain"]++qualifiedIdentity :: ReadModelNode -> Text+qualifiedIdentity readModel = rmSchema readModel <> "." <> rmTable readModel++renderFeed :: RmFeed -> Text+renderFeed RmInline = "inline"+renderFeed RmSubscription = "subscription"++effectiveScope :: Maybe RmScope -> RmScope+effectiveScope Nothing = RmEntireLog+effectiveScope (Just scope) = scope++scopeStrengthened :: RmScope -> RmScope -> Bool+scopeStrengthened (RmCategory _) RmEntireLog = True+scopeStrengthened _ _ = False++renderScope :: RmScope -> Text+renderScope RmEntireLog = "entire-log"+renderScope (RmCategory categoryName) = "category '" <> categoryName <> "'"++aggregateDiff :: DiffEnv -> [Change]+aggregateDiff env =+  concatMap+    (\(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 :: 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) DeclarationAdded "new event type (new aggregate)"+  | e <- aggEvents newAgg+  ]++removedAggregateDiff :: Aggregate -> [Change]+removedAggregateDiff oldAgg =+  [ breaking (aggName oldAgg) "event" (evName e) EvtRemovedNotDeprecated "aggregate removed; its event tags are no longer decodable"+  | e <- aggEvents oldAgg+  ]++-- | Per-event classification for an event present in the new aggregate.+eventDiff :: Aggregate -> Aggregate -> Event -> [Change]+eventDiff oldAgg newAgg e =+  case find ((== evName e) . evName) (aggEvents oldAgg) of+    Nothing ->+      [additive (aggName newAgg) "event" (evName e) 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) 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)+                  "event"+                  (evName e)+                  EvtVersionMissingUpcaster+                  ( "version changed from v"+                      <> tInt (evVersion oldE)+                      <> " to v"+                      <> tInt (evVersion e)+                      <> " without the required contiguous upcaster from v"+                      <> tInt (evVersion oldE)+                  )+              ]+      | evVersion e < evVersion oldE ->+          [breaking (aggName newAgg) "event" (evName e) EvtVersionDecreased ("version decreased from v" <> tInt (evVersion oldE) <> " to v" <> tInt (evVersion e))]+      | otherwise ->+          sameVersionEventDiff oldAgg newAgg oldE e++-- | Events present in the old aggregate but absent in the new one. Removing a+-- tag entirely is breaking; 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; 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))+  ]++hasSource :: Maybe (Int, Hole) -> Int -> Bool+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 TypeExpr)]+eventFieldSigs agg e = case evBody e of+  EventFields fs -> map fieldSig fs+  EventFromCommand cn ->+    maybe [] (map fieldSig . cmdFields) (find ((== cn) . cmdName) (aggCommands agg))+  where+    fieldSig f = (aggregateFieldName f, aggregateFieldType f)++sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change]+sameVersionEventDiff oldAgg newAgg oldE newE =+  addedChanges+    ++ removedChanges+    ++ typeChanges+    ++ deprecationChanges+    ++ retirementChanges+  where+    oldFields = eventFieldSigs oldAgg oldE+    newFields = eventFieldSigs newAgg newE+    oldNames = map fst oldFields+    newNames = map fst newFields+    added = newNames \\ oldNames+    removed = oldNames \\ newNames+    changed =+      [ (field, oldType, newType)+      | (field, oldType) <- oldFields,+        Just newType <- [lookup field newFields],+        oldType /= newType+      ]+    addedChanges =+      [ breaking (aggName newAgg) "event" (evName newE) EvtFieldAddedWithoutBump ("field(s) " <> commas added <> " added at the same version v" <> tInt (evVersion newE) <> " without a version bump or upcaster")+      | not (null added)+      ]+    removedChanges =+      [ breaking (aggName newAgg) "event" (evName newE) EvtFieldRemovedSameVersion ("field(s) " <> commas removed <> " removed at the same version v" <> tInt (evVersion newE))+      | not (null removed)+      ]+    typeChanges =+      [ breaking+          (aggName newAgg)+          "event-field"+          (evName newE <> "." <> field)+          EvtFieldTypeChanged+          ("type changed " <> renderAggregateFieldType oldType <> " -> " <> renderAggregateFieldType newType <> " at the same version v" <> tInt (evVersion newE))+      | (field, oldType, newType) <- changed+      ]+    deprecationChanges+      | not (evDeprecated oldE) && 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 = []++renderAggregateFieldType :: Maybe TypeExpr -> Text+renderAggregateFieldType Nothing = "(declared)"+renderAggregateFieldType (Just expression) = typeExprCanonicalName expression++renderFieldType :: Maybe Name -> Text+renderFieldType Nothing = "(declared)"+renderFieldType (Just name) = name++wireDiff :: Aggregate -> Aggregate -> [Change]+wireDiff oldAgg newAgg+  | effectiveWire (aggWire oldAgg) == effectiveWire (aggWire newAgg) = []+  | otherwise =+      [ breaking+          (aggName newAgg)+          "wire"+          (aggName newAgg)+          WireSpecChanged+          ("effective wire convention changed " <> renderWire (effectiveWire (aggWire oldAgg)) <> " -> " <> renderWire (effectiveWire (aggWire newAgg)))+      ]++effectiveWire :: Maybe WireSpec -> (Text, Text)+effectiveWire Nothing = ("ctorName", "camelCase")+effectiveWire (Just w) = (wireKind w, wireFields w)++renderWire :: (Text, Text) -> Text+renderWire (kindName, fieldNames) = "kind=" <> kindName <> ", fields=" <> fieldNames++projectionDiff :: Aggregate -> Aggregate -> [Change]+projectionDiff oldAggregate newAggregate+  | projectionSurface (aggProjection oldAggregate) == projectionSurface (aggProjection newAggregate) = []+  | otherwise =+      [ advisory+          (aggName newAggregate)+          "projection"+          (aggName newAggregate)+          ProjectionChanged+          "projection table, consistency, key, or status mapping changed; coordinate the read-model migration"+      ]++projectionSurface :: Maybe ProjectionSpec -> Maybe (Name, Maybe Consistency, Name, Maybe Mapping)+projectionSurface projection = do+  value <- projection+  pure (projTable value, projConsistency value, projKey value, projStatusMap value)++idDiff :: DiffEnv -> [Change]+idDiff env =+  concatMap (uncurry (idPairDiff (deOld env))) (prMatched paired)+    ++ concatMap addedIdDiff (prAdded paired)+    ++ concatMap removedIdDiff (prRemoved paired)+  where+    paired = pairDeclarations idName (specIds (deOld env)) (specIds (deNew env))++idPairDiff :: Spec -> IdDecl -> IdDecl -> [Change]+idPairDiff oldSpec oldId newId =+  [ breaking (idName newId) "id-prefix" (idName newId) IdPrefixChanged ("prefix changed '" <> idPrefix oldId <> "' -> '" <> idPrefix newId <> "'; stored and newly minted ids no longer share an identity domain")+  | idPrefix oldId /= idPrefix newId+  ]+    <> nominalBindingDeclDiff oldSpec "id" (idName newId) (idBinding oldId) (idBinding newId)+    <> [ nominalUseChange+           use+           NominalIdDecoderTightened+           "adopting a checked KindID binding tightens historical decoding; keep a committed valid old-payload fixture and run the targeted real-log audit for this event"+       | idBinding oldId == Nothing,+         isJust (idBinding newId),+         use@NominalEventUse {} <- nominalUses oldSpec (idName oldId)+       ]++addedIdDiff :: IdDecl -> [Change]+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"]++enumDiff :: DiffEnv -> [Change]+enumDiff env =+  concatMap (uncurry (enumPairDiff (deOld env))) (prMatched paired)+    ++ concatMap addedEnumDiff (prAdded paired)+    ++ concatMap (removedEnumDiff (deOld env)) (prRemoved paired)+  where+    paired = pairDeclarations enumName (specEnums (deOld env)) (specEnums (deNew env))++enumPairDiff :: Spec -> EnumDecl -> EnumDecl -> [Change]+enumPairDiff oldSpec oldEnum newEnum =+  [ breaking (enumName newEnum) "enum-constructor" ctor EnumCtorRemoved ("constructor removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName oldEnum))+  | (ctor, wire) <- enumCtors oldEnum,+    isNothing (lookup ctor (enumCtors newEnum))+  ]+    ++ [ breaking (enumName newEnum) "enum-constructor" ctor EnumWireSpellingChanged ("wire spelling changed '" <> oldWire <> "' -> '" <> newWire <> "'; stored values using the old spelling no longer decode" <> enumUsageSuffix oldSpec (enumName oldEnum))+       | (ctor, oldWire) <- enumCtors oldEnum,+         Just newWire <- [lookup ctor (enumCtors newEnum)],+         oldWire /= newWire+       ]+    ++ concat+      [ enumAdditionDiff oldSpec newEnum ctor wire+      | (ctor, wire) <- enumCtors newEnum,+        isNothing (lookup ctor (enumCtors oldEnum))+      ]+      <> nominalBindingDeclDiff oldSpec "enum" (enumName newEnum) (enumBinding oldEnum) (enumBinding newEnum)++nominalScalarDiff :: DiffEnv -> [Change]+nominalScalarDiff env =+  concatMap (uncurry scalarPairDiff) (prMatched paired)+    <> [nominalDeclarationChange (nominalScalarName declaration) DeclarationAdded "new nominal scalar declaration" | declaration <- prAdded paired]+    <> [nominalDeclarationChange (nominalScalarName declaration) NominalRepresentationChanged "nominal scalar declaration removed while persisted uses may remain" | declaration <- prRemoved paired]+  where+    paired = pairDeclarations nominalScalarName (specNominalScalars (deOld env)) (specNominalScalars (deNew env))+    scalarPairDiff oldDeclaration newDeclaration =+      [ nominalDeclarationChange+          (nominalScalarName newDeclaration)+          NominalRepresentationChanged+          ( "nominal scalar representation changed '"+              <> nominalScalarRepresentation oldDeclaration+              <> "' -> '"+              <> nominalScalarRepresentation newDeclaration+              <> "'"+          )+      | nominalScalarRepresentation oldDeclaration /= nominalScalarRepresentation newDeclaration+      ]+        <> nominalBindingDeclDiff+          (deOld env)+          "scalar"+          (nominalScalarName newDeclaration)+          (Just (nominalScalarBinding oldDeclaration))+          (Just (nominalScalarBinding newDeclaration))++data NominalUse+  = NominalCommandUse !Name !Name !Name+  | NominalEventUse !Name !Name !Name+  | NominalRegisterUse !Name !Name++nominalUses :: Spec -> Name -> [NominalUse]+nominalUses spec target = concatMap usesInAggregate [aggregate | NAggregate aggregate <- specNodes spec]+  where+    usesInAggregate aggregate =+      [ NominalCommandUse (aggName aggregate) (cmdName command) (aggregateFieldName field)+      | command <- aggCommands aggregate,+        field <- cmdFields command,+        fieldReferences target field+      ]+        <> [ NominalEventUse (aggName aggregate) (evName event) (aggregateFieldName field)+           | event <- aggEvents aggregate,+             field <- eventFields aggregate event,+             fieldReferences target field+           ]+        <> [ NominalRegisterUse (aggName aggregate) (regName register)+           | register <- aggRegs aggregate,+             regType register == TRef target+           ]+    eventFields aggregate event = case evBody event of+      EventFields fields -> fields+      EventFromCommand commandName -> concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName]+    fieldReferences targetName field = case aggregateFieldType field of+      Just (TRef typeName) -> typeName == targetName+      Just _ -> False+      Nothing -> pascalName (aggregateFieldName field) == targetName+    pascalName value = case T.uncons value of+      Nothing -> value+      Just (initialChar, rest) -> T.cons (toUpper initialChar) rest++nominalBindingDeclDiff :: Spec -> Text -> Name -> Maybe NominalBindingDecl -> Maybe NominalBindingDecl -> [Change]+nominalBindingDeclDiff oldSpec category name oldBinding newBinding =+  concat+    [ nominalFinding NominalBindingChanged "binding source, symbol, or version changed; rebuild every consumer use and audit persisted event uses because hand-written conversion behavior is opaque"+    | bindingRuntimeFacts oldBinding /= bindingRuntimeFacts newBinding+    ]+    <> concat+      [ nominalFinding NominalFixturesChanged "fixture symbol changed; rerun nominal conformance without claiming runtime wire behavior changed"+      | (nominalFixtures =<< oldBinding) /= (nominalFixtures =<< newBinding)+      ]+    <> concat+      [ nominalFinding NominalCanonicalTypeChanged "canonical nominal identity changed; rebuild consumers and invalidate snapshot caches at register uses"+      | (nominalCanonicalType =<< oldBinding) /= (nominalCanonicalType =<< newBinding)+      ]+    <> concat+      [ nominalFinding NominalInitialChanged "consumer-owned initial value symbol changed; rebuild and invalidate snapshot-bearing register streams"+      | (nominalInitial =<< oldBinding) /= (nominalInitial =<< newBinding)+      ]+  where+    bindingRuntimeFacts declaration =+      ( nominalHaskell =<< declaration,+        nominalBinding =<< declaration,+        nominalBindingVersion =<< declaration+      )+    nominalFinding code detail =+      nominalDeclarationChange name code (category <> " " <> detail)+        : [nominalUseChange use code detail | use <- nominalUses oldSpec name, includeUse code use]+    includeUse NominalFixturesChanged _ = False+    includeUse NominalCanonicalTypeChanged NominalRegisterUse {} = True+    includeUse NominalCanonicalTypeChanged _ = False+    includeUse NominalInitialChanged NominalRegisterUse {} = True+    includeUse NominalInitialChanged _ = False+    includeUse _ NominalCommandUse {} = False+    includeUse _ _ = True++nominalDeclarationChange :: Name -> DiagnosticCode -> Text -> Change+nominalDeclarationChange name code detail =+  mkChange+    (deriveLabel defaultGate vector)+    context+    name+    "nominal-build"+    name+    code+    detail+  where+    context = (consumerBuildContext name [name]) {contextOriginalLabel = LabelAdvisory}+    vector = classifyCompatibility context code++nominalUseChange :: NominalUse -> DiagnosticCode -> Text -> Change+nominalUseChange use code detail =+  mkChange (deriveLabel defaultGate vector) context root facet subject code detail+  where+    (root, facet, subject, kind) = case use of+      NominalCommandUse aggregate command field -> (aggregate, "nominal-command", aggregate <> " command " <> command <> " ." <> field, ContextConsumerBuild)+      NominalEventUse aggregate event field -> (aggregate, "nominal-event", aggregate <> " event " <> event <> " ." <> field, ContextPrivateEvent)+      NominalRegisterUse aggregate register -> (aggregate, "nominal-register", aggregate <> " register " <> register, ContextSnapshot)+    context = ChangeContext root [subject] kind LabelAdvisory+    vector = classifyCompatibility context code++addedEnumDiff :: EnumDecl -> [Change]+addedEnumDiff 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))+  | (ctor, wire) <- enumCtors enumDecl+  ]++enumUsageSuffix :: Spec -> Name -> Text+enumUsageSuffix spec enumType = case enumUsages spec enumType of+  [] -> ""+  usages -> "; used by " <> commas usages++enumUsages :: Spec -> Name -> [Text]+enumUsages spec enumType =+  [aggName agg <> ".reg." <> regName reg | agg <- aggregates, reg <- aggRegs agg, regType reg == TRef enumType]+    ++ [ aggName agg <> ".event." <> evName event <> "." <> field+       | agg <- aggregates,+         event <- aggEvents agg,+         (field, Just fieldTypeName) <- eventFieldSigs agg event,+         fieldTypeName == TRef enumType+       ]+  where+    aggregates = [agg | NAggregate agg <- specNodes spec]++pairDeclarations :: (n -> Name) -> [n] -> [n] -> Paired n+pairDeclarations nameOf oldNodes newNodes =+  Paired+    { prMatched =+        [ (oldNode, newNode)+        | newNode <- newNodes,+          Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]+        ],+      prAdded = [newNode | newNode <- newNodes, isNothing (find ((== nameOf newNode) . nameOf) oldNodes)],+      prRemoved = [oldNode | oldNode <- oldNodes, isNothing (find ((== nameOf oldNode) . nameOf) newNodes)]+    }++contractDiff :: DiffEnv -> [Change]+contractDiff env =+  concatMap (uncurry contractPairDiff) (prMatched paired)+    ++ concatMap addedContractDiff (prAdded paired)+    ++ concatMap removedContractDiff (prRemoved paired)+  where+    paired = pairByName nodeContract ctrName env++contractPairDiff :: ContractNode -> ContractNode -> [Change]+contractPairDiff oldContract newContract =+  schemaChanges+    ++ discriminatorChanges+    ++ topicChanges+    ++ concatMap eventPairChanges matchedEvents+    ++ concatMap addedEventChanges addedEvents+    ++ concatMap removedEventChanges removedEvents'+  where+    schemaChanges =+      [ breaking+          (ctrName newContract)+          "schema-version"+          (ctrName newContract)+          ContractSchemaVersionDecreased+          ("schemaVersion decreased from " <> tInt (ctrSchemaVersion oldContract) <> " to " <> tInt (ctrSchemaVersion newContract))+      | ctrSchemaVersion newContract < ctrSchemaVersion oldContract+      ]+    discriminatorChanges =+      [ breaking+          (ctrName newContract)+          "discriminator"+          (ctrName newContract)+          ContractDiscriminatorChanged+          ("discriminator changed " <> ctrDiscriminator oldContract <> " -> " <> ctrDiscriminator newContract)+      | ctrDiscriminator oldContract /= ctrDiscriminator newContract+      ]+    topicChanges = contractTopicDiff oldContract newContract+    eventPairs = pairDeclarations ceName (ctrEvents oldContract) (ctrEvents newContract)+    matchedEvents = prMatched eventPairs+    addedEvents = prAdded eventPairs+    removedEvents' = prRemoved eventPairs+    eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent+    addedEventChanges event =+      [additive (ctrName newContract) "contract-event" (ceName event) 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) ContractEventAdded "new event in a new contract" | event <- ctrEvents contract]++removedContractDiff :: ContractNode -> [Change]+removedContractDiff contract =+  [breaking (ctrName contract) "contract-event" (ceName event) ContractEventRemoved "contract removed; its cross-service event decoder is no longer declared" | event <- ctrEvents contract]++contractTopicDiff :: ContractNode -> ContractNode -> [Change]+contractTopicDiff oldContract newContract =+  [ breaking+      (ctrName newContract)+      "contract-topic"+      alias+      ContractTopicChanged+      ("topic alias removed; previous topic was '" <> oldTopic <> "'")+  | (alias, oldTopic) <- ctrTopics oldContract,+    isNothing (lookup alias (ctrTopics newContract))+  ]+    ++ [ breaking+           (ctrName newContract)+           "contract-topic"+           alias+           ContractTopicChanged+           ("real topic changed '" <> oldTopic <> "' -> '" <> newTopic <> "'")+       | (alias, oldTopic) <- ctrTopics oldContract,+         Just newTopic <- [lookup alias (ctrTopics newContract)],+         oldTopic /= newTopic+       ]+    ++ [ additive (ctrName newContract) "contract-topic" alias ContractTopicAdded ("new topic alias for '" <> topic <> "'")+       | (alias, topic) <- ctrTopics newContract,+         isNothing (lookup alias (ctrTopics oldContract))+       ]++contractEventDiff :: ContractNode -> ContractNode -> ContractEvent -> ContractEvent -> [Change]+contractEventDiff oldContract newContract oldEvent newEvent =+  topicAliasChange+    ++ removedFieldChanges+    ++ changedFieldChanges+    ++ addedFieldChanges+  where+    fieldPairs = pairDeclarations cfName (ceFields oldEvent) (ceFields newEvent)+    topicAliasChange =+      [ breaking+          (ctrName newContract)+          "contract-topic"+          (ceName newEvent)+          ContractTopicChanged+          ("event topic alias changed " <> ceTopic oldEvent <> " -> " <> ceTopic newEvent)+      | ceTopic oldEvent /= ceTopic newEvent+      ]+    removedFieldChanges =+      [ breaking (ctrName newContract) "contract-field" (ceName newEvent <> "." <> cfName field) ContractFieldChanged "field removed; existing messages still carry the old contract shape"+      | field <- prRemoved fieldPairs+      ]+    changedFieldChanges =+      [ breaking+          (ctrName newContract)+          "contract-field"+          (ceName newEvent <> "." <> cfName newField)+          ContractFieldChanged+          ("field type changed " <> renderContractType (cfType oldField) <> " -> " <> renderContractType (cfType newField))+      | (oldField, newField) <- prMatched fieldPairs,+        cfType oldField /= cfType newField+      ]+    addedFieldChanges =+      [ if ctrSchemaVersion newContract > ctrSchemaVersion oldContract+          then advisory (ctrName newContract) "contract-field" subject ContractSchemaVersionBumped ("field added with schemaVersion bump " <> tInt (ctrSchemaVersion oldContract) <> " -> " <> tInt (ctrSchemaVersion newContract) <> "; coordinate the cross-service rollout")+          else breaking (ctrName newContract) "contract-field" subject ContractFieldChanged "field added without a schemaVersion bump; older in-flight messages do not contain it"+      | field <- prAdded fieldPairs,+        let subject = ceName newEvent <> "." <> cfName field+      ]++renderContractType :: ContractType -> Text+renderContractType (CTypeId prefix) = "typeid '" <> prefix <> "'"+renderContractType CText = "text"+renderContractType CInt = "int"++workqueueDiff :: DiffEnv -> [Change]+workqueueDiff env =+  concatMap (uncurry workqueuePairDiff) (prMatched paired)+    ++ concatMap addedWorkqueueDiff (prAdded paired)+    ++ concatMap removedWorkqueueDiff (prRemoved paired)+  where+    paired = pairByName nodeWorkqueue wqName env++workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+workqueuePairDiff oldQueue newQueue =+  concatMap pairedFieldDiff (prMatched fields)+    ++ concatMap addedFieldDiff (prAdded fields)+    ++ concatMap removedFieldDiff (prRemoved fields)+    ++ queueIdentityDiff oldQueue newQueue+    ++ queuePolicyDiff oldQueue newQueue+  where+    -- wqPayloadName is a generated Haskell type name, not a wire-visible name.+    fields = pairDeclarations wqfName (wqPayload oldQueue) (wqPayload newQueue)+    pairedFieldDiff (oldField, newField)+      | wqfWire oldField /= wqfWire newField = [payloadBreaking newField ("wire name changed '" <> wqfWire oldField <> "' -> '" <> wqfWire newField <> "'")]+      | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> wqfType oldField <> " -> " <> wqfType newField)]+      | not (wqfRequired oldField) && wqfRequired newField = [payloadBreaking newField "field changed from optional to required; queued jobs may omit it"]+      | wqfRequired oldField && not (wqfRequired newField) = [additive (wqName newQueue) "payload-field" (wqfName newField) 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) 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) DeclarationAdded "field belongs to a new workqueue payload" | field <- wqPayload queue]++removedWorkqueueDiff :: WorkqueueNode -> [Change]+removedWorkqueueDiff queue =+  [breaking (wqName queue) "payload-field" (wqfName field) WqPayloadFieldChanged "workqueue removed while persisted jobs may still carry this payload" | field <- wqPayload queue]+    ++ [breaking (wqName queue) "queue-identity" (wqName queue) QueueIdentityChanged "workqueue removed; its physical queue, DLQ, and pgmq table may still hold state"]++queueIdentityDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+queueIdentityDiff oldQueue newQueue =+  [ breaking+      (wqName newQueue)+      "queue-identity"+      (wqName newQueue)+      QueueIdentityChanged+      "logical, physical, DLQ, or table name changed; queued jobs and dispatch dedupe records remain under the old identity"+  | queueIdentity oldQueue /= queueIdentity newQueue+  ]++queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text)+queueIdentity queue = (wqLogical queue, wqPhysical queue, wqDlq queue, wqTable queue)++queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey+  where+    nodeName = wqName newQueue+    ordering =+      [ breaking nodeName "queue-ordering" nodeName WqOrderingChanged $+          "ordering changed " <> renderWqOrdering (wqOrdering oldQueue) <> " -> " <> renderWqOrdering (wqOrdering newQueue) <> "; consumers were written against the old delivery-order contract"+      | wqOrdering oldQueue /= wqOrdering newQueue+      ]+    provision =+      [ breaking nodeName "queue-provision" nodeName WqProvisionChanged $+          "provision changed " <> renderWqProvision (wqProvision oldQueue) <> " -> " <> renderWqProvision (wqProvision newQueue) <> "; provisioning is create-time only, so migrate the existing queue operationally before changing the spec"+      | wqProvision oldQueue /= wqProvision newQueue+      ]+    groupKey =+      [ breaking nodeName "queue-group-key" nodeName WqGroupKeyChanged $+          "group key derivation changed " <> renderWqGroupKey (wqGroupKey oldQueue) <> " -> " <> renderWqGroupKey (wqGroupKey newQueue) <> "; FIFO messages are re-partitioned across durable ordering groups"+      | wqGroupKey oldQueue /= wqGroupKey newQueue+      ]++renderWqOrdering :: WqOrdering -> Text+renderWqOrdering WqUnordered = "unordered"+renderWqOrdering WqFifoThroughput = "fifo-throughput"+renderWqOrdering WqFifoRoundRobin = "fifo-roundrobin"++renderWqProvision :: WqProvision -> Text+renderWqProvision WqStandard = "standard"+renderWqProvision WqUnlogged = "unlogged"+renderWqProvision (WqPartitioned interval duration) = "partitioned(interval=" <> interval <> ", retention=" <> duration <> ")"++renderWqGroupKey :: Maybe WqGroupKey -> Text+renderWqGroupKey Nothing = "none"+renderWqGroupKey (Just groupKey) =+  gkField groupKey+    <> " via "+    <> gkVia groupKey+    <> maybe "" (" fixture " <>) (gkFixture groupKey)++processDiff :: DiffEnv -> [Change]+processDiff env =+  concatMap (uncurry processPairDiff) (prMatched paired)+    ++ concatMap addedProcessDiff (prAdded paired)+    ++ concatMap removedProcessDiff (prRemoved paired)+  where+    paired = pairByName nodeProcess procId env++processPairDiff :: ProcessNode -> ProcessNode -> [Change]+processPairDiff oldProcess newProcess =+  concatMap pairedFieldDiff (prMatched fields)+    ++ map (fieldChange "field added; source events at the old shape cannot populate it") (prAdded fields)+    ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields)+    ++ processIdentityDiff oldProcess newProcess+    ++ processTimerWindowDiff oldProcess newProcess+    ++ 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))+    pairedFieldDiff (oldField, newField)+      | fieldType oldField /= fieldType newField = [fieldChange ("type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField)) newField]+      | otherwise = []+    fieldChange detail field = breaking (procId newProcess) "input-field" (fieldName field) ProcessInputChanged (detail <> "; version the source event before changing process input")++addedProcessDiff :: ProcessNode -> [Change]+addedProcessDiff process =+  [additive (procId process) "input-field" (fieldName field) DeclarationAdded "field belongs to a new process input" | field <- inFields (procInput process)]++removedProcessDiff :: ProcessNode -> [Change]+removedProcessDiff process =+  [breaking (procId process) "input-field" (fieldName field) ProcessInputChanged "process removed while persisted source events may still require this input decoder" | field <- inFields (procInput process)]+    ++ [breaking (procId process) "derived-identity" (procId process) DerivedIdentityChanged "process removed while persisted saga, dispatch, and timer identities may still exist"]++processIdentityDiff :: ProcessNode -> ProcessNode -> [Change]+processIdentityDiff oldProcess newProcess =+  [ breaking+      (procId newProcess)+      "derived-identity"+      (procId newProcess)+      DerivedIdentityChanged+      "process name, correlation derivation, saga stream category, timer id prefix, or fired-event-id prefix changed; replays and retries no longer derive the persisted identity"+  | processIdentity oldProcess /= processIdentity newProcess+  ]++processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Text)+processIdentity process =+  ( procName process,+    corrField (procCorrelate process),+    corrVia (procCorrelate process),+    sagaCategory (procSaga process),+    idePrefix (tmId (procTimer process)),+    idePrefix (fireFiredEventId (tmFire (procTimer process)))+  )++processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change]+processTimerWindowDiff oldProcess newProcess =+  [ advisory+      (procId newProcess)+      "timer"+      (tmName (procTimer newProcess))+      TimerWindowChanged+      ( "fireAt source/window changed "+          <> renderFireAt (tmFireAt (procTimer oldProcess))+          <> " -> "+          <> renderFireAt (tmFireAt (procTimer newProcess))+          <> "; already-scheduled timers keep their persisted deadline"+      )+  | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess)+  ]++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++workflowDiff :: DiffEnv -> [Change]+workflowDiff env =+  concatMap (uncurry workflowPairDiff) (prMatched paired)+    ++ concatMap addedWorkflowDiff (prAdded paired)+    ++ concatMap removedWorkflowDiff (prRemoved paired)+  where+    paired = pairByName nodeWorkflow wfId env++workflowPairDiff :: WorkflowNode -> WorkflowNode -> [Change]+workflowPairDiff oldWorkflow newWorkflow =+  inputChanges+    ++ outputChanges+    ++ classifyWorkflowBody oldWorkflow newWorkflow+    ++ workflowIdentityDiff oldWorkflow newWorkflow+  where+    fields = pairDeclarations fieldName (wfInputFields oldWorkflow) (wfInputFields newWorkflow)+    inputChanges =+      [workflowShape field "input field added; journaled inputs at the old shape do not contain it" | field <- prAdded fields]+        ++ [workflowShape field "input field removed; journaled inputs still contain the old shape" | field <- prRemoved fields]+        ++ [ workflowShape newField ("input field type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField))+           | (oldField, newField) <- prMatched fields,+             fieldType oldField /= fieldType newField+           ]+    outputChanges =+      [ breaking (wfId newWorkflow) "workflow-output" (wfOutput newWorkflow) WorkflowShapeChanged ("output type changed " <> wfOutput oldWorkflow <> " -> " <> wfOutput newWorkflow <> "; persisted outcomes may no longer decode")+      | wfOutput oldWorkflow /= wfOutput newWorkflow+      ]+    workflowShape field detail = breaking (wfId newWorkflow) "workflow-input" (fieldName field) WorkflowShapeChanged detail++addedWorkflowDiff :: WorkflowNode -> [Change]+addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) 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"]++workflowIdentityDiff :: WorkflowNode -> WorkflowNode -> [Change]+workflowIdentityDiff oldWorkflow newWorkflow =+  [ breaking+      (wfId newWorkflow)+      "workflow-name"+      (wfId newWorkflow)+      WorkflowStableNameChanged+      ("stable name changed '" <> wfStable oldWorkflow <> "' -> '" <> wfStable newWorkflow <> "'; in-flight journals remain under the old stream name")+  | wfStable oldWorkflow /= wfStable newWorkflow+  ]+    ++ [ breaking+           (wfId newWorkflow)+           "derived-identity"+           (wfId newWorkflow)+           DerivedIdentityChanged+           "workflow id source field or derivation changed; journal and deterministic child/step identities no longer coalesce with persisted executions"+       | (wfIdField oldWorkflow, wfIdVia oldWorkflow) /= (wfIdField newWorkflow, wfIdVia newWorkflow)+       ]++intakeDiff :: DiffEnv -> [Change]+intakeDiff env =+  concatMap (uncurry intakePairDiff) (prMatched paired)+    ++ concatMap addedIntakeDiff (prAdded paired)+    ++ concatMap removedIntakeDiff (prRemoved paired)+  where+    paired = pairByName nodeIntake inkName env++intakePairDiff :: IntakeNode -> IntakeNode -> [Change]+intakePairDiff oldIntake newIntake =+  [ breaking+      (inkName newIntake)+      "dedupe-identity"+      (inkName newIntake)+      DedupeIdentityChanged+      "dedupe key or policy changed; redelivered messages no longer match their persisted dedupe record"+  | (inkDedupeKey oldIntake, inkDedupePolicy oldIntake) /= (inkDedupeKey newIntake, inkDedupePolicy newIntake)+  ]+    ++ [ advisory+           (inkName newIntake)+           "decode-posture"+           (inkName newIntake)+           DecodePostureChanged+           "envelope/body decode posture changed; future messages are accepted or rejected differently"+       | inkDecode oldIntake /= inkDecode newIntake+       ]+    ++ [ advisory+           (inkName newIntake)+           "inbox-persistence"+           (inkName newIntake)+           IntakePersistenceChanged+           ("success-path envelope persistence changed " <> renderInkPersist (inkPersist oldIntake) <> " -> " <> renderInkPersist (inkPersist newIntake) <> "; existing rows are unchanged while future successful rows retain a different envelope shape")+       | inkPersist oldIntake /= inkPersist newIntake+       ]++renderInkPersist :: InkPersist -> Text+renderInkPersist InkPersistFull = "full-envelope"+renderInkPersist InkPersistDedupeOnly = "dedupe-only"++addedIntakeDiff :: IntakeNode -> [Change]+addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) 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"]++emitDiff :: DiffEnv -> [Change]+emitDiff env =+  concatMap (uncurry emitPairDiff) (prMatched paired)+    ++ concatMap addedEmitDiff (prAdded paired)+    ++ concatMap removedEmitDiff (prRemoved paired)+  where+    paired = pairByName nodeEmit emName env++emitPairDiff :: EmitNode -> EmitNode -> [Change]+emitPairDiff oldEmit newEmit =+  [ breaking+      (emName newEmit)+      "derived-identity"+      "messageId"+      DerivedIdentityChanged+      "messageId derive prefix changed; outbox retries no longer coalesce with persisted messages"+  | emMessageId oldEmit /= emMessageId newEmit+  ]+    ++ [ breaking+           (emName newEmit)+           "derived-identity"+           "idempotencyKey"+           DerivedIdentityChanged+           "idempotencyKey derive prefix changed; downstream dedupe no longer matches persisted messages"+       | emIdempotencyKey oldEmit /= emIdempotencyKey newEmit+       ]+    ++ [ advisory+           (emName newEmit)+           "emit-mapping"+           (emName newEmit)+           EmitMappingChanged+           "emit key, status discriminant, mapping rows, or explicit skip posture changed"+       | emitMapping oldEmit /= emitMapping newEmit+       ]++emitMapping :: EmitNode -> (Name, Name, [EmitMapRow], Bool)+emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit)++addedEmitDiff :: EmitNode -> [Change]+addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) 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"]++publisherDiff :: DiffEnv -> [Change]+publisherDiff env =+  concatMap (uncurry publisherPairDiff) (prMatched paired)+    ++ concatMap addedPublisherDiff (prAdded paired)+    ++ concatMap removedPublisherDiff (prRemoved paired)+  where+    paired = pairByName nodePublisher pubName env++publisherPairDiff :: PublisherNode -> PublisherNode -> [Change]+publisherPairDiff oldPublisher newPublisher =+  -- maxAttempts/backoff are retry tuning, not persisted decode or identity.+  [ breaking+      (pubName newPublisher)+      "derived-identity"+      "outboxId"+      DerivedIdentityChanged+      "stable outbox-id source field changed; retries no longer coalesce with persisted outbox rows"+  | pubOutboxField oldPublisher /= pubOutboxField newPublisher+  ]+    ++ [ advisory+           (pubName newPublisher)+           "publisher-policy"+           (pubName newPublisher)+           PublisherPolicyChanged+           ("ordering changed " <> pubOrdering oldPublisher <> " -> " <> pubOrdering newPublisher)+       | pubOrdering oldPublisher /= pubOrdering newPublisher+       ]++addedPublisherDiff :: PublisherNode -> [Change]+addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) 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"]++pgmqDispatchDiff :: DiffEnv -> [Change]+pgmqDispatchDiff env =+  concatMap (uncurry pgmqDispatchPairDiff) (prMatched paired)+    ++ concatMap addedPgmqDispatchDiff (prAdded paired)+    ++ concatMap removedPgmqDispatchDiff (prRemoved paired)+  where+    paired = pairByName nodePgmqDispatch pdName env++pgmqDispatchPairDiff :: PgmqDispatchNode -> PgmqDispatchNode -> [Change]+pgmqDispatchPairDiff oldDispatch newDispatch =+  [ breaking+      (pdName newDispatch)+      "dedupe-identity"+      (pdName newDispatch)+      DedupeIdentityChanged+      "dispatch dedupe key/read-model/queue surface changed; prior enqueue records no longer match"+  | dispatchDedupe oldDispatch /= dispatchDedupe newDispatch+  ]+    ++ [ advisory+           (pdName newDispatch)+           "retarget"+           (pdName newDispatch)+           DispatchRetargeted+           "source read model or target queue changed; future fan-out is routed differently"+       | dispatchTargets oldDispatch /= dispatchTargets newDispatch+       ]++dispatchDedupe :: PgmqDispatchNode -> (Name, Name, Text, Name, Text)+dispatchDedupe dispatch =+  ( pdDedupKey dispatch,+    pdDedupReadModel dispatch,+    pdDedupReadModelField dispatch,+    pdDedupQueue dispatch,+    pdDedupQueueField dispatch+  )++dispatchTargets :: PgmqDispatchNode -> (Name, Name)+dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch)++addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]+addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) 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"]++-- | Classify the runtime's sanctioned workflow-evolution mechanisms before+-- falling back to the conservative unguarded-body rule.+classifyWorkflowBody :: WorkflowNode -> WorkflowNode -> [Change]+classifyWorkflowBody oldWorkflow newWorkflow+  | oldBody == newBody = []+  | not (null removedPatchIds) = map removedPatch removedPatchIds+  | Just (oldSeedType, newSeedType) <- changedSeed =+      [ breaking nodeName "workflow-continue-as-new" nodeName WorkflowContinueSeedChanged $+          "continueAsNew seed type changed " <> oldSeedType <> " -> " <> newSeedType <> "; the next generation's restoreSeed must decode the seed written by the previous generation"+      ]+  | safeAdditions =+      map addedPatch newPatchIds+        ++ [ additive nodeName "workflow-continue-as-new" seedType WorkflowEvolutionGuardAdded "terminal continueAsNew is additive; old generations carry no rotation marker"+           | Just seedType <- [appendedSeed]+           ]+  | otherwise =+      [ breaking+          nodeName+          "workflow-body"+          nodeName+          WorkflowBodyChanged+          "workflow body labels, kinds, result types, or order changed without a new patch guard; wrap a cross-cutting change in patch, or rename the replay label for one changed step"+      ]+  where+    nodeName = wfId newWorkflow+    oldBody = normaliseWorkflowBody (wfBody oldWorkflow)+    newBody = normaliseWorkflowBody (wfBody newWorkflow)+    oldPatchIds = workflowBodyPatchIds oldBody+    newPatchIdsAll = workflowBodyPatchIds newBody+    newPatchIds = newPatchIdsAll \\ oldPatchIds+    removedPatchIds = oldPatchIds \\ newPatchIdsAll+    oldSeed = terminalContinueSeed oldBody+    newSeed = terminalContinueSeed newBody+    changedSeed = case (oldSeed, newSeed) of+      (Just oldSeedType, Just newSeedType)+        | oldSeedType /= newSeedType -> Just (oldSeedType, newSeedType)+      _ -> Nothing+    appendedSeed = case (oldSeed, newSeed) of+      (Nothing, Just seedType) -> Just seedType+      _ -> Nothing+    strippedNewBody = stripNewPatches newPatchIds newBody+    comparableNewBody = case appendedSeed of+      Just _ -> dropTerminalContinue strippedNewBody+      Nothing -> strippedNewBody+    safeAdditions =+      (not (null newPatchIds) || isJust appendedSeed)+        && comparableNewBody == oldBody+    removedPatch patchId =+      breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch"+    addedPatch patchId =+      additive nodeName "workflow-patch" patchId WorkflowEvolutionGuardAdded "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"++normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem]+normaliseWorkflowBody = map go+  where+    go (WfStep label result _) = WfStep label result noLoc+    go (WfAwait label result _) = WfAwait label result noLoc+    go (WfSleep label delay _) = WfSleep label delay noLoc+    go (WfChild label via result _) = WfChild label via result noLoc+    go (WfPatch patchId items _) = WfPatch patchId (normaliseWorkflowBody items) noLoc+    go (WfContinueAsNew seedType _) = WfContinueAsNew seedType noLoc++workflowBodyPatchIds :: [WfBodyItem] -> [Name]+workflowBodyPatchIds = concatMap go+  where+    go (WfPatch patchId items _) = patchId : workflowBodyPatchIds items+    go _ = []++stripNewPatches :: [Name] -> [WfBodyItem] -> [WfBodyItem]+stripNewPatches newPatchIds = concatMap go+  where+    go (WfPatch patchId _ _) | patchId `elem` newPatchIds = []+    go (WfPatch patchId items loc) = [WfPatch patchId (stripNewPatches newPatchIds items) loc]+    go item = [item]++terminalContinueSeed :: [WfBodyItem] -> Maybe Name+terminalContinueSeed items = case reverse items of+  WfContinueAsNew seedType _ : _ -> Just seedType+  _ -> Nothing++dropTerminalContinue :: [WfBodyItem] -> [WfBodyItem]+dropTerminalContinue items = case reverse items of+  WfContinueAsNew {} : rest -> reverse rest+  _ -> items++additive :: Name -> Text -> Text -> 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 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 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 `elem` [OwnershipMoved, WorkspaceAuthorityChanged] -> consumerBuildContext 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 ", "