keiro-dsl 0.10.0.0 → 0.11.0.0

raw patch · 338 files changed

+22612/−14050 lines, 338 filesdep ~containersdep ~keikidep ~keiro-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers, keiki, keiro-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +281/−1
• app/Main.hs +400/−48
• keiro-dsl.cabal +117/−52
• src/Keiro/Dsl/AggregateGenerationPlan.hs +42/−0
• src/Keiro/Dsl/AggregateType.hs +14/−8
• src/Keiro/Dsl/CheckReport.hs +341/−0
• src/Keiro/Dsl/ConformancePackage.hs +96/−16
• src/Keiro/Dsl/Coverage.hs +12/−3
• src/Keiro/Dsl/Diff.hs +265/−61
• src/Keiro/Dsl/DiffReport.hs +4/−0
• src/Keiro/Dsl/ExplainBindings.hs +12/−5
• src/Keiro/Dsl/FieldIdentity.hs +41/−0
• src/Keiro/Dsl/Goldens.hs +2/−1
• src/Keiro/Dsl/Grammar.hs +15/−7
• src/Keiro/Dsl/Harness.hs +218/−108
• src/Keiro/Dsl/HaskellImport.hs +1/−39
• src/Keiro/Dsl/HaskellName.hs +351/−0
• src/Keiro/Dsl/HaskellSourceMove.hs +214/−0
• src/Keiro/Dsl/LanguageVersion.hs +11/−1
• src/Keiro/Dsl/MappedDiff.hs +34/−3
• src/Keiro/Dsl/NominalType.hs +1/−30
• src/Keiro/Dsl/Parser/Aggregate.hs +10/−1
• src/Keiro/Dsl/Parser/Coordination.hs +25/−22
• src/Keiro/Dsl/Parser/Document.hs +1/−1
• src/Keiro/Dsl/Parser/Integration.hs +8/−3
• src/Keiro/Dsl/Parser/Queue.hs +5/−2
• src/Keiro/Dsl/PrettyPrint.hs +19/−6
• src/Keiro/Dsl/ReplayImpact.hs +12/−5
• src/Keiro/Dsl/Scaffold.hs +706/−189
• src/Keiro/Dsl/ScaffoldRecord.hs +69/−3
• src/Keiro/Dsl/ScaffoldRun.hs +693/−63
• src/Keiro/Dsl/SemanticContract.hs +28/−1
• src/Keiro/Dsl/ServiceHarness.hs +23/−11
• src/Keiro/Dsl/SidecarMigration.hs +270/−0
• src/Keiro/Dsl/SidecarNames.hs +56/−0
• src/Keiro/Dsl/Skeleton.hs +12/−9
• src/Keiro/Dsl/Validate.hs +3889/−2897
• src/Keiro/Dsl/Workspace.hs +29/−16
• src/Keiro/Dsl/WorkspaceAdoption.hs +28/−14
• src/Keiro/Dsl/WorkspaceRecord.hs +41/−21
• src/Keiro/Dsl/WorkspaceScaffold.hs +113/−16
• test/Keiro/Dsl/FrontendCompatibility.hs +2/−0
• test/Keiro/Dsl/FrontendProfiles.hs +23/−14
• test/Main.hs +10703/−8590
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ReplayAudit.hs +1/−1
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Codec.hs +42/−7
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Domain.hs +20/−2
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/EventStream.hs +1/−1
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Harness.hs +13/−6
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Projection.hs +3/−1
• test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Transducer.hs +1/−1
• test/conformance-behavior-complete/BehaviorComplete/Journey/BehaviorHoles.hs +13/−2
• test/conformance-behavior-complete/BehaviorComplete/Journey/Holes.hs +3/−2
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/BehaviorContract.hs +313/−35
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs +25/−10
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Domain.hs +15/−5
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/EventStream.hs +1/−1
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Harness.hs +23/−10
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Projection.hs +3/−1
• test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Transducer.hs +29/−6
• test/conformance-behavior-complete/Generated/BehaviorComplete/Nominals.hs +1/−8
• test/conformance-behavior-complete/Generated/BehaviorComplete/Nominals/Internal.hs +4/−1
• test/conformance-behavior-complete/Generated/BehaviorComplete/ReplayAudit.hs +1/−1
• test/conformance-behavior-complete/Generated/BehaviorComplete/Structural/Shape/StartPayload.hs +1/−1
• test/conformance-behavior-complete/Generated/BehaviorComplete/StructuralProjections.hs +1/−3
• test/conformance-coldstart/Generated/Billing/Nominals.hs +4/−7
• test/conformance-coldstart/Generated/Billing/Nominals/Internal.hs +6/−1
• test/conformance-coldstart/Generated/Billing/ReplayAudit.hs +1/−1
• test/conformance-coldstart/Generated/Billing/Subscription/Codec.hs +5/−5
• test/conformance-coldstart/Generated/Billing/Subscription/Domain.hs +2/−3
• test/conformance-coldstart/Generated/Billing/Subscription/EventStream.hs +2/−2
• test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs +18/−6
• test/conformance-coldstart/Generated/Billing/Subscription/Projection.hs +1/−1
• test/conformance-coldstart/Generated/Billing/Subscription/Transducer.hs +1/−1
• test/conformance-contract-v1-compat/Generated/HospitalCapacity/Emergency/Contract.hs +1/−1
• test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs +8/−4
• test/conformance-contract/Main.hs +12/−2
• test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/Queue.hs +50/−0
• test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +29/−0
• test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs +43/−0
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/Queue.hs +0/−50
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +0/−29
• test/conformance-dispatch-full/Generated/HospitalCapacity/Reservation_work/QueuePolicy.hs +0/−43
• test/conformance-dispatch-full/HospitalCapacity/ReservationWork/WorkqueueJob.hs +3/−3
• test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals.hs +1/−8
• test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals/Internal.hs +4/−1
• test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Codec.hs +7/−7
• test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Domain.hs +1/−2
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs +92/−24
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs +5/−10
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs +1/−3
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/EventStream.hs +2/−2
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Harness.hs +6/−18
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs +3/−1
• test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Transducer.hs +1/−1
• test/conformance-import-planning/Generated/ImportPlanningCollisions/NominalProjections.hs +3/−3
• test/conformance-import-planning/Generated/ImportPlanningCollisions/ReplayAudit.hs +1/−1
• test/conformance-import-planning/Generated/ImportPlanningCollisions/Structural/Shape/Details.hs +1/−1
• test/conformance-import-planning/Generated/ImportPlanningCollisions/StructuralProjections.hs +1/−3
• test/conformance-intake-full/Generated/HospitalCapacity/IncidentInbox/Inbox.hs +1/−1
• test/conformance-intake-runtime/Generated/HospitalCapacity/IncidentInbox/Inbox.hs +1/−1
• test/conformance-newsurface/Generated/TransferRouting/Conformance.hs +9/−9
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Codec.hs +6/−6
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Domain.hs +1/−2
• test/conformance-newsurface/Generated/TransferRouting/Hospital/EventStream.hs +2/−2
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs +5/−5
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Projection.hs +3/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital/Transducer.hs +1/−1
• test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModel.hs +61/−0
• test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs +33/−0
• test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs +9/−0
• test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/Router.hs +1/−1
• test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs +1/−1
• test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModel.hs +0/−61
• test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModelHarness.hs +0/−23
• test/conformance-newsurface/Generated/TransferRouting/Hospital_load/ReadModelTable.hs +0/−9
• test/conformance-newsurface/Generated/TransferRouting/ReplayAudit.hs +1/−1
• test/conformance-newsurface/Main.hs +1/−1
• test/conformance-newsurface/TransferRouting/HospitalLoad/ReadModelHoles.hs +35/−0
• test/conformance-newsurface/TransferRouting/HospitalTransferRouter/RouterValue.hs +1/−1
• test/conformance-newsurface/TransferRouting/Hospital_load/ReadModelHoles.hs +0/−35
• test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs +1/−1
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/BehaviorContract.hs +91/−23
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs +5/−5
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Domain.hs +1/−2
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/EventStream.hs +1/−1
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Harness.hs +5/−6
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Projection.hs +3/−1
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Transducer.hs +2/−2
• test/conformance-nominal-scalars/Generated/NominalScalars/NominalProjections.hs +4/−4
• test/conformance-nominal-scalars/Generated/NominalScalars/ReplayAudit.hs +1/−1
• test/conformance-nominal-scalars/Main.hs +27/−2
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Codec.hs +7/−7
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Domain.hs +2/−4
• test/conformance-process-full/Generated/SurgeDemo/Hospital/EventStream.hs +2/−2
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Projection.hs +1/−1
• test/conformance-process-full/Generated/SurgeDemo/Hospital/Transducer.hs +1/−1
• test/conformance-process-full/Generated/SurgeDemo/Nominals.hs +1/−8
• test/conformance-process-full/Generated/SurgeDemo/Nominals/Internal.hs +4/−1
• test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs +1/−1
• test/conformance-process-full/Generated/SurgeDemo/Surge/Codec.hs +7/−7
• test/conformance-process-full/Generated/SurgeDemo/Surge/Domain.hs +2/−4
• test/conformance-process-full/Generated/SurgeDemo/Surge/EventStream.hs +2/−2
• test/conformance-process-full/Generated/SurgeDemo/Surge/Projection.hs +1/−1
• test/conformance-process-full/Generated/SurgeDemo/Surge/Transducer.hs +1/−1
• test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/Process.hs +1/−1
• test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs +1/−1
• test/conformance-process-runtime/Generated/HospitalCapacity/Nominals.hs +1/−10
• test/conformance-process-runtime/Generated/HospitalCapacity/Nominals/Internal.hs +6/−1
• test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Codec.hs +7/−7
• test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Domain.hs +2/−3
• test/conformance-process-runtime/Generated/HospitalCapacity/Surge/EventStream.hs +2/−2
• test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Transducer.hs +1/−1
• test/conformance-process-runtime/HospitalCapacity/Surge/Holes.hs +1/−2
• test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs +1/−1
• test/conformance-publisher-runtime/Generated/HospitalCapacity/HospitalPublisher/Publisher.hs +2/−2
• test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/Queue.hs +50/−0
• test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +29/−0
• test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs +43/−0
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/Queue.hs +0/−50
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +0/−29
• test/conformance-queue-runtime/Generated/HospitalCapacity/Reservation_work/QueuePolicy.hs +0/−43
• test/conformance-queue-runtime/Main.hs +3/−3
• test/conformance-queue/Generated/HospitalCapacity/ReservationWork/Queue.hs +50/−0
• test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +29/−0
• test/conformance-queue/Generated/HospitalCapacity/Reservation_work/Queue.hs +0/−50
• test/conformance-queue/Generated/HospitalCapacity/Reservation_work/QueueCodec.hs +0/−29
• test/conformance-queue/Main.hs +3/−3
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs +61/−0
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs +33/−0
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs +9/−0
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModel.hs +0/−61
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModelHarness.hs +0/−19
• test/conformance-readmodel-runtime/Generated/HospitalCapacity/Transfer_decisions/ReadModelTable.hs +0/−9
• test/conformance-readmodel-runtime/HospitalCapacity/TransferDecisions/ReadModelHoles.hs +30/−0
• test/conformance-readmodel-runtime/HospitalCapacity/Transfer_decisions/ReadModelHoles.hs +0/−30
• test/conformance-readmodel-runtime/Main.hs +2/−2
• test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs +6/−6
• test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs +1/−1
• test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs +2/−2
• test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs +5/−5
• test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs +3/−1
• test/conformance-replay/Generated/ReplayDivergence/Note/Transducer.hs +1/−1
• test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs +1/−1
• test/conformance-replay/ReplayDivergence/Note/Holes.hs +5/−4
• test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs +6/−6
• test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs +1/−2
• test/conformance-router-full/Generated/IncidentPaging/Page/EventStream.hs +2/−2
• test/conformance-router-full/Generated/IncidentPaging/Page/Transducer.hs +1/−1
• test/conformance-router-full/Generated/IncidentPaging/PagingRouter/Router.hs +1/−1
• test/conformance-router-full/Generated/IncidentPaging/PagingRouter/RouterHarness.hs +1/−1
• test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs +1/−1
• test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/Router.hs +1/−1
• test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/RouterHarness.hs +1/−1
• test/conformance-router/Generated/IncidentPaging/PagingRouter/RouterHarness.hs +1/−1
• test/conformance-scalar-expressions/AggregateScalarExpressions/ScalarAccount/Holes.hs +1/−2
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals.hs +3/−4
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals/Internal.hs +4/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ReplayAudit.hs +1/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/BehaviorContract.hs +143/−27
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs +6/−8
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs +2/−2
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/EventStream.hs +1/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs +18/−18
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Projection.hs +3/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs +1/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Structural/Shape/Limits.hs +1/−1
• test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralProjections.hs +1/−3
• test/conformance-scalar-expressions/Main.hs +4/−2
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Nominals.hs +1/−8
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Nominals/Internal.hs +4/−1
• test/conformance-skeletons/SkelAggregate/Generated/MyService/ReplayAudit.hs +1/−1
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/BehaviorContract.hs +91/−23
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Codec.hs +7/−7
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Domain.hs +1/−2
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/EventStream.hs +2/−2
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Harness.hs +11/−5
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Projection.hs +3/−1
• test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/Transducer.hs +1/−1
• test/conformance-skeletons/SkelAggregate/MyService/Thing/BehaviorHoles.hs +2/−2
• test/conformance-skeletons/SkelContract/Generated/MyService/MyContract/Contract.hs +1/−1
• test/conformance-skeletons/SkelEmit/Generated/MyService/MyContract/Contract.hs +2/−2
• test/conformance-skeletons/SkelEmit/Generated/MyService/ThingPublisher/Publisher.hs +2/−2
• test/conformance-skeletons/SkelIntake/Generated/MyService/MyContract/Contract.hs +2/−2
• test/conformance-skeletons/SkelIntake/Generated/MyService/ThingInbox/Inbox.hs +1/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Codec.hs +7/−7
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Domain.hs +2/−4
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/EventStream.hs +2/−2
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Harness.hs +11/−5
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Projection.hs +3/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/Transducer.hs +1/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/Process.hs +1/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/HospitalSurge/ProcessHarness.hs +1/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Nominals.hs +1/−10
• test/conformance-skeletons/SkelProcess/Generated/MyService/Nominals/Internal.hs +6/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/ReplayAudit.hs +1/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Codec.hs +7/−7
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Domain.hs +2/−3
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/EventStream.hs +2/−2
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Harness.hs +14/−8
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Projection.hs +3/−1
• test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/Transducer.hs +1/−1
• test/conformance-skeletons/SkelQueue/Generated/MyService/AcceptedTransferNeeds/ReadModel.hs +61/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/AcceptedTransferNeeds/ReadModelHarness.hs +33/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/AcceptedTransferNeeds/ReadModelTable.hs +9/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModel.hs +0/−61
• test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModelHarness.hs +0/−23
• test/conformance-skeletons/SkelQueue/Generated/MyService/Accepted_transfer_needs/ReadModelTable.hs +0/−9
• test/conformance-skeletons/SkelQueue/Generated/MyService/ReservationWork/Queue.hs +40/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/ReservationWork/QueueCodec.hs +29/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/ReservationWork/QueuePolicy.hs +43/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/Queue.hs +0/−40
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueueCodec.hs +0/−29
• test/conformance-skeletons/SkelQueue/Generated/MyService/Reservation_work/QueuePolicy.hs +0/−43
• test/conformance-skeletons/SkelQueue/Generated/MyService/TransferDecisions/ReadModel.hs +61/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/TransferDecisions/ReadModelHarness.hs +33/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/TransferDecisions/ReadModelTable.hs +9/−0
• test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModel.hs +0/−61
• test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModelHarness.hs +0/−23
• test/conformance-skeletons/SkelQueue/Generated/MyService/Transfer_decisions/ReadModelTable.hs +0/−9
• test/conformance-skeletons/SkelQueue/MyService/AcceptedTransferNeeds/ReadModelHoles.hs +26/−0
• test/conformance-skeletons/SkelQueue/MyService/Accepted_transfer_needs/ReadModelHoles.hs +0/−26
• test/conformance-skeletons/SkelQueue/MyService/TransferDecisions/ReadModelHoles.hs +25/−0
• test/conformance-skeletons/SkelQueue/MyService/Transfer_decisions/ReadModelHoles.hs +0/−25
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Codec.hs +6/−6
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Domain.hs +1/−2
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/EventStream.hs +2/−2
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Harness.hs +5/−5
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Projection.hs +3/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/Page/Transducer.hs +1/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/PagingRouter/Router.hs +1/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/PagingRouter/RouterHarness.hs +1/−1
• test/conformance-skeletons/SkelRouter/Generated/MyService/ReplayAudit.hs +1/−1
• test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowFacts.hs +1/−1
• test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowRuntime.hs +1/−1
• test/conformance-snapshot/Generated/HospitalCapacity/Nominals.hs +5/−8
• test/conformance-snapshot/Generated/HospitalCapacity/Nominals/Internal.hs +8/−1
• test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs +1/−1
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs +5/−5
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs +2/−3
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs +1/−1
• test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Transducer.hs +1/−1
• test/conformance-snapshot/HospitalCapacity/Reservation/Holes.hs +3/−3
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/BehaviorContract.hs +348/−0
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs +15/−11
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs +1/−2
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs +2/−2
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs +7/−7
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs +3/−1
• test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Transducer.hs +1/−2
• test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs +1/−1
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs +1/−1
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs +1/−1
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs +1/−1
• test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs +1/−1
• test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs +1/−3
• test/conformance-v2/Generated/HospitalCapacity/Nominals.hs +5/−8
• test/conformance-v2/Generated/HospitalCapacity/Nominals/Internal.hs +8/−1
• test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs +1/−1
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs +5/−5
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs +2/−2
• test/conformance-v2/Generated/HospitalCapacity/Reservation/EventStream.hs +2/−2
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs +24/−6
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs +9/−9
• test/conformance-v2/Generated/HospitalCapacity/Reservation/Transducer.hs +1/−1
• test/conformance-v2/HospitalCapacity/Reservation/Holes.hs +3/−3
• test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs +1/−1
• test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs +1/−1
• test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs +13/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals.hs +3/−4
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals/Internal.hs +4/−1
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/BehaviorContract.hs +143/−27
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Codec.hs +5/−5
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Domain.hs +1/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/EventStream.hs +2/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Harness.hs +12/−6
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Projection.hs +3/−1
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Transducer.hs +2/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs +91/−23
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs +5/−5
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs +1/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs +2/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs +11/−5
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs +3/−1
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs +2/−2
• test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ReplayAudit.hs +1/−1
• test/conformance/Generated/HospitalCapacity/Nominals.hs +5/−8
• test/conformance/Generated/HospitalCapacity/Nominals/Internal.hs +8/−1
• test/conformance/Generated/HospitalCapacity/ReplayAudit.hs +1/−1
• test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs +5/−5
• test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs +2/−3
• test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs +2/−2
• test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs +24/−6
• test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs +9/−9
• test/conformance/Generated/HospitalCapacity/Reservation/Transducer.hs +1/−1
• test/conformance/HospitalCapacity/Reservation/Holes.hs +3/−3
• test/haskell-name/Main.hs +149/−0
• test/runtime-vocabulary/Main.hs +32/−0

@@ -4,7 +4,287 @@ [Keep a Changelog](https://keepachangelog.com/), and the package follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [Unreleased]+## [0.11.0.0] - 2026-08-05++### Breaking Changes++- `DiagnosticCode` gains `DecodeBodyPostureUnsupported`,+  `DispatchOnAppendedUnsupported`, `TimerNotMineUnsupported`, and+  `IntakeBindHeaderUnknown`; exhaustive matches must be extended. Each closes a+  spelling the grammar accepted that no runtime implements, and each warns on+  released languages below 4 and errors from language 4 on. `intake … body+  lenient` is refused because generated codecs decode a body strictly;+  `on-appended` other than `AckOk` is refused on both process and router+  dispatch rows because a successful append is always acked; `not-mine Fired` is+  refused because the timer worker marks a timer `Fired` only when the fire+  action returns an appended event id; and an intake `bind … from header "x"`+  naming a header outside keiro's canonical envelope set is refused because the+  Kafka inbox reads a fixed header set and cannot be remapped. The spelling that+  matches the runtime stays accepted and silent in every case.+- A process `dispatch-id` line is now checked as strictly as a router's. It must+  read exactly `strategy=uuidv5 from=(name, correlationId, sourceEventId,+  emitIndex)` — the tuple `Keiro.ProcessManager` actually derives from — where+  previously any strategy identifier and any tuple parsed and were discarded.+  Routers keep their own `(name, key, sourceEventId, targetStreamName,+  occurrence)`. A process spec that wrote anything else is now a parse error.+- `check`'s warning policy now covers structural coverage. When an invocation+  supplies `--coverage-report`, its findings are ordinary diagnostics of this+  run: `--deny-warnings` and `--deny CoverageOpaqueSurface` escalate them, they+  appear in the `keiro-dsl/check-report/1` diagnostics array as line-0 entries,+  and the report's `ok` therefore accounts for them. Previously+  `check spec --coverage-report r --deny-warnings` printed coverage warnings and+  exited 0, so a CI job that believed it had a no-warning gate did not have one.+  Coverage output is now emitted with the other diagnostics, before `--emit` and+  `--explain-bindings` output rather than after.+- `check --deny CODE` now refuses a code `check` cannot emit instead of+  accepting a denial that can never match. Cross-revision codes (for example+  `EvtFieldWireKeyChanged`, `WorkflowShapeChanged`) are a `diff` concern and are+  rejected outright; structural-coverage codes are rejected unless the same+  invocation passes `--coverage-report`; `--deny CoverageOpaqueGateExceeded` is+  rejected in every invocation, because that code is the error `--fail-on-opaque`+  itself raises and never a deniable warning — pass the flag instead. Any CI+  file that named such a code was not gating on it and now fails loudly.+  `Keiro.Dsl.Validate` exports the underlying `DiagnosticOrigin` and+  `diagnosticOrigin` registry.+- `keiro-dsl new intake` no longer spells the unenforced `required cross-check+  body` flags on its bind row, so the intake skeleton passes the documented+  `check --min-language 4 --deny-warnings` CI gate as generated (previously it+  warned `IntakeBindFlagUnenforced` out of the box). The router and process+  skeletons keep their idiomatic benign-inversion spellings and therefore gate+  CI with a selective `--deny` list rather than `--deny-warnings`.+- The `keiro-dsl/coverage-report/1` JSON now spells warning severity `"warning"`+  rather than `"advisory"`, matching `keiro-dsl/check-report/1`. There is one+  severity vocabulary across keiro-dsl's JSON. Consumers matching the literal+  string `"advisory"` (available since 0.4.0.0) must be updated.+- `DiagnosticCode` loses `EmitDeriveHoleUnrealized` and+  `WqFieldOptionalUnsupported`, and gains `TimerDecodeStatusUnknown`,+  `TimerDeadLetterTextInvalid`, and `PgmqFanoutFunctionInvalid`; exhaustive+  matches must be extended. The code fired unconditionally on every `emit` node because+  `derive … hole` is mandatory grammar, so it carried no information and made+  `check --deny-warnings` permanently red for any emit-bearing service. The+  scaffold report's no-modules line already names each emit node that+  contributes nothing. `WqFieldOptionalUnsupported` is removed with the model it+  described: every workqueue payload field is required, because generated+  decoders read all of them with `o .:`. `WqField` therefore loses `wqfRequired`,+  the `required` marker is accepted but selects nothing, and adding a payload+  field is now classified breaking however it is spelled — a job already queued+  under the old shape does not contain it, which the previous "new optional+  field is additive" classification denied.+- The three surfaces ExecPlan 197 recorded as descriptive-only are now checked+  against the references they name. A timer's `decode unknown-status` must be a+  status the timer table stores (`Scheduled`, `Firing`, `Fired`, `Cancelled`,+  `Dead`); its `dead-letter` reason must not be blank, since it is the text an+  operator-written worker passes to `Keiro.Timer.deadLetterTimer`; a pgmq+  `dedup key` must be a generated selector of its source read model, reported+  with the existing `DispatchReadModelFieldUnknown`; and a pgmq `fanout body`+  must be spellable as a Haskell value identifier. Emit `source`, `key`, and map+  discriminant names remain the one documented descriptive-only surface, because+  no typed source namespace exists to resolve them against.+- `WorkspaceScaffoldReport` gains `wsrInertNodes`, and a workspace scaffold now+  renders the same `no-modules:` line the single-spec report has always+  rendered. `Keiro.Dsl.ScaffoldRun` exports the shared `inertNodesOf` and+  `renderInertNodeSection`.+- `Keiro.Timer.Schema.TimerStatus` (in **keiro**) additionally derives `Enum` and+  `Bounded` so consumers can enumerate the lifecycle rather than restate it.+- `Keiro.Dsl.ScaffoldRun`'s `Refusal` gains `SidecarMovesAlreadyApplied`;+  exhaustive matches must be extended. Sidecar renames are applied before the+  later scaffold gates run, so a refusal after that point used to claim "nothing+  was written" while the renames were on disk. The note is appended to such a+  refusal set and states that the renames are idempotent and need no undo.+- A legacy `keiro-dsl-conformance-record.txt` anywhere in the output tree is now+  migrated, not only when the run also plans a conformance package. A spec that+  stopped generating one previously left the record orphaned and unreadable,+  because the current reader has no legacy parser. The scan is depth-bounded and+  skips the `.keiro-dsl-name-migrations` backup root.+- `FieldWireKeyInvalid` additionally refuses a wire key with leading or trailing+  whitespace or a control character, naming the offending codepoint. Aliases stay+  exempt from a declared `wire … fields=camelCase` convention — preserving a+  brownfield key is what they are for — so this is structural usability only. A+  spec that shipped `as "family "` now fails `check`.+- `Keiro.Dsl.CheckReport`'s `reportLanguage` is now+  `Maybe CheckReportLanguage`, and the new `workspaceRefusalReport` builds the+  report for a workspace refused during composition. Such a report serializes+  `"language": null` because no service graph was composed.+- Scaffold sidecars now use role-bearing names. On disk,+  `keiro-dsl-scaffold-record.<context>.txt` becomes+  `keiro-dsl-ledger.context.<context>.txt`, the workspace form becomes+  `keiro-dsl-ledger.workspace.<service>.txt`, `keiro-dsl-conformance-record.txt`+  becomes `keiro-dsl-conformance-ledger.txt`, and the generated+  `keiro-dsl-manifest.<context>.<ext>` / `keiro-dsl-manifest.workspace.*` files+  become `keiro-dsl-cabal-fragment.context.<context>.<ext>` and+  `keiro-dsl-cabal-fragment.workspace.<service>.<ext>`. The Cabal fragment — not+  the former manifest name — is the authoritative generated build inventory.+  An out tree holding legacy names now **refuses without writing**; review the+  listed moves and rerun `scaffold --apply-name-migrations` to rename them+  losslessly. Duplicate old files that cannot be renamed are preserved under+  `.keiro-dsl-name-migrations/sidecar-v1/`.+- `Keiro.Dsl.ScaffoldRun`'s `Refusal` gains `SidecarMigrationRequired` and+  `SidecarMigrationRefusal`; `ScaffoldReport` gains `reportSidecarMoves` and+  `WorkspaceScaffoldReport` gains `wsrSidecarMoves`. Exhaustive matches and+  record constructions must be extended. Two new modules are exposed:+  `Keiro.Dsl.SidecarNames` (the role-bearing name vocabulary and legacy-name+  recognition) and `Keiro.Dsl.SidecarMigration` (the planned move set and its+  apply path).+- The renamed conformance ledger also changes format: the whitespace-row+  `keiro-dsl-conformance-record.txt` becomes the versioned+  `keiro-dsl conformance ledger v1` with typed JSON file rows. The parser+  ignores unknown row kinds and unknown JSON keys so future rows decode, while+  retaining the service-key, malformed-record, unsafe-path, and case-folded+  duplicate-path refusals. Legacy conformance records are converted **only** by+  the explicit `--apply-name-migrations` path; no implicit upgrade exists.+- `AggregateField` gains `aggregateFieldSelector :: Maybe Name` and+  `aggregateFieldWireKey :: Maybe Text`, and `ContractField` gains+  `cfSelector :: Maybe Name`, `cfWireKey :: Maybe Text`, and `cfLoc :: Loc`+  (both in `Keiro.Dsl.Grammar`). Code that constructs these records positionally+  or matches them exhaustively must be updated; `Nothing` selector and wire-key+  values reproduce the pre-alias behavior exactly.+- `RouterReadModelUnverified` previously existed as a declared but never-emitted+  `DiagnosticCode` constructor. It now carries real semantics and is emitted+  when a router's resolved read model cannot be verified, so a consumer that+  matched the constructor as unreachable — or a `--deny` list that named it as a+  no-op — now sees live diagnostics.+- Router duplicate-disposition notices moved from `ProcessBenignInversion` to+  the distinct `RouterBenignInversion`. An adopter CI list that passes+  `--deny ProcessBenignInversion` silently stops matching router rows; add+  `--deny RouterBenignInversion` to preserve the previous gate.+- Requires `keiki >=0.9 && <0.10`, replacing `>=0.8 && <0.9`. Generated+  aggregate domains continue to use `deriveAggregateCtorsAll` and+  `deriveWireCtorsAll`, which now produce Keiki's trusted structural+  constructor evidence. Consumers must solve with Keiki 0.9 and recompile;+  generated validation results may change where 0.9 can distinguish structural+  heads or prove replay candidates disjoint.+- Generated module segments, types, constructors, values, selectors, and create-once+  source paths now use one checked UpperCamelCase/lowerCamelCase policy. Compound+  logical names such as `service_oncall` therefore move from `Service_oncall` to+  `ServiceOncall`; consumers must apply the reported source migration and recompile.+- `DiagnosticCode` gains `IdentUnsafeNormalization`,+  `GeneratedOccurrenceReserved`, `GeneratedOccurrenceCollision`, and+  `GeneratedHaskellNameChanged`. `Refusal` gains+  `GeneratedNameInvariantViolation`, `NameMigrationRequired`, and+  `NameMigrationRefusal`. Exhaustive matches must be extended.+- `ScaffoldReport` and `WorkspaceScaffoldReport` gain generated-name source-move+  evidence. `ScaffoldRecord` and `WorkspaceRecord` gain a generated-Haskell naming+  edition and stable module-role rows; missing additive rows decode as the legacy+  naming edition.+- `DiagnosticCode` gains `FieldWireKeyCollision`, `FieldWireKeyInvalid`, and+  `EvtFieldWireKeyChanged`. Exhaustive matches must be extended.+- `DiagnosticCode` appends `LanguageVersionBelowMinimum` and now derives `Ord`,+  `Enum`, and `Bounded`. Exhaustive matches must be extended. `check`, `scaffold`,+  and the working-tree side of `diff` add a stderr language-contract notice for+  compatibility-only sources, changing exact-stderr consumers.+- `DiagnosticCode` appends `AggregateEmpty`, `ContractEmpty`,+  `GeneratedPathCollision`, `GeneratedImportCycle`, `BehaviorDerivationInvalid`,+  `ConformanceFactKeyCollision`, and `GeneratedPlanningInvariantViolation`.+  Exhaustive matches must be extended; specs that scaffold already could not lower+  now fail earlier during `check`.+- `DiagnosticCode` appends thirteen accepted-surface warning and language-4 error+  codes, including process/router resolution, bounded windows, queue payload types,+  derived IDs, projection/outbox fields, and the distinct+  `RouterBenignInversion`; exhaustive matches must be extended. The never-emitted+  `DuplicateUpcasterSource`, `IdentHaskellKeyword`, `IdentNotConstructorSafe`, and+  `MappedGuardUnsupported` constructors are removed.+- `IdExpr` gains the parsed `ideField`, and `ScaffoldReport` gains+  `reportInertNodes`; callers constructing or exhaustively matching these exported+  records must be updated.++### New Features++- Generated-name collision planning now registers the selector generation+  actually emits — the explicit `haskell` alias when declared, otherwise the raw+  DSL name — instead of a camelized rendering of it. `{foo_bar, fooBar}` in one+  record is no longer reported as a collision between two fields that in fact+  generate distinct selectors, and the diagnostic no longer claims `foo_bar`+  "normalizes to" `fooBar`, which generation never did. A name that cannot be a+  Haskell selector is still refused, by the generated-name audit that owns that+  rule and names the offending declaration.+- `check --report-out` creates missing parent directories, and a workspace+  refused during composition now writes the report a single spec has always+  written for the equivalent failure. A parse failure and an unreadable or+  unparseable workspace manifest still write none: they precede any coded+  diagnostic.+- `scaffold --apply-name-migrations` applies an explicitly reviewed legacy-to-current+  source move, backs up original generated and create-once files, rewrites exact+  Haskell module references outside comments/literals, journals content digests, and+  resumes exact interrupted states. Ordinary scaffolding reports the complete plan+  and writes nothing.+- Generated-only source evolution is classified as consumer-build advisory with+  re-scaffold, recompile, and conformance remedies while wire, replay, SQL, runtime,+  and persisted identities remain compatible.+- Language 4 direct aggregate and integration-contract fields accept independent+  `haskell <selector>` and `as "<wire-key>"` aliases. Generated records use the+  selector, codecs/goldens use the wire key, and `fields(Command)` preserves both.+- `check --min-language N` enforces a registered released-language floor.+  `--deny-warnings` and repeatable/comma-separated `--deny CODE` make selected+  warnings CI-failing without changing their severity. `--report-out` writes the+  append-only `keiro-dsl/check-report/1` schema for sources and workspaces through+  the new `Keiro.Dsl.CheckReport` module.+- Language 4 now resolves every internally decidable process, router, projection,+  publisher, queue, pgmq source-key, read-model identity, and timer-ID surface,+  and rejects duration values that cannot fit the runtime `Int` seconds+  representation. Released languages 1–3 keep their prior acceptance.++### Other Changes++- The conformance-corpus driver cross-checks its plan against+  `keiro-dsl.cabal`: a suite compiling generated Haskell that no plan entry+  regenerates now fails `corpus-regen check` naming the suite, and a plan entry+  no test-suite compiles fails too. The plan is derived from tracked ledgers+  alone, so deleting one silently dropped a suite from regeneration *and* from+  both existing consistency checks, which are scoped to plan entries.+  `regenerate` also refuses a dirty corpus (with `--allow-dirty` for local+  iteration) and prints the exact `git checkout --` recovery line.+- The scaffold report's two sidecar lines are relabelled `fragment:` and+  `ledger:` to match the files they name; they read `manifest:` and `record:`+  while pointing at `keiro-dsl-cabal-fragment.*` and `keiro-dsl-ledger.*`.+  Consumers scraping those stderr labels must be updated.+- The `generated-output` Cabal stanza adds `-Werror` behind the new manual flag+  `werror-generated` (default off, because Hackage rejects an unconditional+  `-Werror`; this repository's `cabal.project` turns it on), so a warning+  regression in generated code fails the build instead of building green. `src`+  keeps `-Wall` non-fatal. Enabling it exposed five real import over-approximations in the+  generator, all now fixed: a publisher imported `ExponentialBackoffOptions`+  under a constant backoff; a nominal-projections module imported the four+  `Keiki.ProjectionDomain` text combinators used only by the unenforced-ID+  pattern; a transducer imported the type of every write source, when only guard+  operands are rendered with a `K.Index … Type` annotation; a transducer imported+  an enforced ID's `parse<Id>`, which only a literal names; and a contract codec+  imported `(.:)` when every field decodes through `explicitParseField`.+  Generated output is correspondingly smaller; no behavior changed.+  `keiro-dsl-conformance-skeletons` keeps `-Wunused-imports`/`-Wunused-matches`+  non-fatal, because its hole modules are deliberately unfilled templates.++- Generated behavior contracts and harnesses now carry complete signatures,+  annotated behavior cells, named sample constants, runtime-backed read-model+  facts, evidence-rich failures, and usage-conditional imports. The+  `keiro/behavior-conformance/1` JSON failure object adds the append-only+  `subject` field. The conformance corpus was regenerated under `-Wall` and now+  has a clean-tree regeneration policy gate; consumers should re-scaffold and+  recompile. Behavior keys, wire data, shape hashes, fold identity, and replay+  semantics are unchanged.+- Adds a record-derived conformance-corpus driver with focused public-CLI replay,+  create-once preservation, record/disk and Cabal/disk consistency checks, and a+  test-owned accept mode for the six renderer goldens.+- Adds the exported stable `ModuleRole`/`moduleRole` projection for+  `ScaffoldModule` artifacts and a generated-source naming audit plus repository+  policy gate.+- Language 4 selects syntax profile 3. The generated occurrence reserved set is+  narrowed to the 23 term identifiers GHC rejects under the advertised GHC2024+  contract, so contextual words including `family`, `via`, and `qualified` are+  accepted and compile-proven.+- Generated aggregate conformance now derives transducer rendering, predicate+  verification, behavior `EdgeRef`s, and initial live probes from one source-wide+  transition layout. Replay-only initial edges receive detailed replay witnesses but+  never `step`-based acceptance helpers, and duplicate generated declarations are+  rejected before writes.+- Source and workspace checking and both scaffold planners now share one pure gate+  order: fold surface, lowering, module construction, conformance-package planning,+  then module-plan refusals. Workspace planning therefore reports a lowering refusal+  before a simultaneous facade-key refusal. Valid generated output is unchanged.+- Accepted but inert intake flags, emit derivations, optional queue markers, and+  inline subscriptions now warn; scaffold reports list emit, pgmq dispatch, and+  operation nodes that contribute no modules. Timer dead-letter text, pgmq fanout+  functions, and pgmq top-level dedupe keys are explicitly descriptive-only.+  Existing valid generated output remains byte-identical.  ## 0.10.0.0 — 2026-08-03 

@@ -13,40 +13,43 @@ import Data.Text.IO qualified as TIO import Data.Text.Lazy.IO qualified as TLIO import Keiro.Dsl.BehaviorCoverage qualified as Behavior+import Keiro.Dsl.CheckReport qualified as CheckReport import Keiro.Dsl.Coverage qualified as Coverage import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSources, gateWith, gatedBreaking) import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding) import Keiro.Dsl.ExplainBindings (bindingObligationsForService, renderBindingObligations) import Keiro.Dsl.FoldFingerprint (renderFoldSurfaceError) import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads)-import Keiro.Dsl.Grammar (Placement (..), Spec (..))-import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, effectiveLanguageVersion, sourceFormText)+import Keiro.Dsl.Grammar (Loc (..), Placement (..), Spec (..))+import Keiro.Dsl.LanguageVersion (LanguageVersion, ParsedSource (..), SourceLanguage (..), declaredLanguageVersionMaybe, effectiveLanguageVersion, languageVersion, languageVersionText, lookupLanguageDefinition, sourceFormText, supportedLanguageVersions) import Keiro.Dsl.Parser (parseSource, renderParseFailure) import Keiro.Dsl.PrettyPrint (renderSource, renderSpec) import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpactServices) import Keiro.Dsl.RuntimePackage (RuntimePackageName, mkRuntimePackageName) import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule)-import Keiro.Dsl.ScaffoldRun (executeServiceScaffoldWithRuntimePackage, planServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport)-import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource)+import Keiro.Dsl.ScaffoldRun (checkServiceDiagnostics, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource, effectiveContractLanguageVersion, languageContractNotice) import Keiro.Dsl.Skeleton (skeletonFor)-import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateService)-import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure, WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, checkedWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, nodeOwner, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest)+import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), DiagnosticOrigin (..), Severity (..), diagnosticCodeText, diagnosticOrigin, minimumLanguageDiagnostics, parseDiagnosticCode, renderDiagnostic, validateService)+import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure (..), WorkspaceFile (..), WorkspaceLocation (..), WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, checkedWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, nodeOwner, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest) import Keiro.Dsl.WorkspaceDiff (WorkspaceChange (..), WorkspaceMeta (..), diffWorkspaces, renderWorkspaceFinding, workspaceDiffReport)-import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffold, planWorkspaceScaffoldWithRuntimePackageAndGoldens, renderWorkspaceScaffoldReport)+import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffoldWithNameMigrations, planWorkspaceScaffoldWithRuntimePackageAndGoldens, renderWorkspaceScaffoldReport)+import Numeric.Natural (Natural) import Options.Applicative import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist) import System.Exit (ExitCode (..), exitFailure) import System.FilePath (isAbsolute, makeRelative, normalise, takeDirectory, takeFileName, (</>)) import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode)+import Text.Read (readMaybe)  data Command   = Parse FilePath   | Pretty FilePath-  | Check FilePath Bool Bool (Maybe CheckCoverageOptions)+  | Check FilePath CheckOptions   | Inspect FilePath InspectionFormat   | BehaviorObligations FilePath BehaviorFormat-  | Scaffold FilePath FilePath (Maybe String) (Maybe RuntimePackageName) Bool Bool (Maybe FilePath) (Maybe (String, FilePath))+  | Scaffold FilePath FilePath (Maybe String) (Maybe RuntimePackageName) Bool Bool Bool (Maybe FilePath) (Maybe (String, FilePath))   | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions)   | New String @@ -59,6 +62,16 @@     checkFailOnOpaque :: !Bool   } +data CheckOptions = CheckOptions+  { checkEmit :: !Bool,+    checkExplainBindings :: !Bool,+    checkCoverage :: !(Maybe CheckCoverageOptions),+    checkMinLanguage :: !(Maybe LanguageVersion),+    checkDenyWarnings :: !Bool,+    checkDenyCodes :: ![DiagnosticCode],+    checkReportOut :: !(Maybe FilePath)+  }+ data DiffCoverageOptions = DiffCoverageOptions   { diffCoveragePath :: !FilePath,     diffFailOnOpaqueIncrease :: !Bool@@ -83,7 +96,7 @@           (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"))+          (info (Check <$> fileArg <*> checkOptions <**> 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"))@@ -92,7 +105,7 @@           (info (BehaviorObligations <$> fileArg <*> behaviorFormatOpt <**> helper) (progDesc "List static aggregate behavior obligations for a .keiro file or workspace"))         <> command           "scaffold"-          (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> optional runtimePackageOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))+          (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> optional runtimePackageOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> applyNameMigrationsSwitch <*> 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"))@@ -122,6 +135,9 @@ forceGeneratedOverwriteSwitch :: Parser Bool forceGeneratedOverwriteSwitch = switch (long "force-generated-overwrite" <> help "Overwrite a Generated path even when the existing file lacks the @generated banner") +applyNameMigrationsSwitch :: Parser Bool+applyNameMigrationsSwitch = switch (long "apply-name-migrations" <> help "Apply reviewed generated-Haskell source and sidecar moves with recoverable backups")+ goldensOpt :: Parser FilePath goldensOpt = strOption (long "goldens" <> metavar "DIR" <> help "Golden-payload root to embed in generated aggregate harnesses") @@ -159,6 +175,115 @@         <*> switch (long "fail-on-opaque" <> help "Fail when a private persisted root contains an opaque boundary (requires --coverage-report)")     ) +checkOptions :: Parser CheckOptions+checkOptions =+  CheckOptions+    <$> emitSwitch+    <*> explainBindingsSwitch+    <*> checkCoverageOptions+    <*> optional minLanguageOpt+    <*> switch (long "deny-warnings" <> help "Exit non-zero when any warning-severity diagnostic fires")+    <*> denyCodesOptions+    <*> optional checkReportOutOpt++minLanguageOpt :: Parser LanguageVersion+minLanguageOpt =+  option+    (eitherReader parseMinimumLanguage)+    (long "min-language" <> metavar "N" <> help "Require at least released keiro-dsl language version N")++parseMinimumLanguage :: String -> Either String LanguageVersion+parseMinimumLanguage raw =+  case (readMaybe raw :: Maybe Natural) >>= languageVersion of+    Just version+      | Just _ <- lookupLanguageDefinition version -> Right version+    _ ->+      Left+        ( "minimum keiro-dsl language version "+            <> raw+            <> " is unsupported; supported versions: "+            <> T.unpack (T.intercalate ", " (map languageVersionText (NE.toList supportedLanguageVersions)))+        )++denyCodesOptions :: Parser [DiagnosticCode]+denyCodesOptions =+  concat+    <$> many+      ( option+          (eitherReader parseDenyCodes)+          (long "deny" <> metavar "CODE[,CODE...]" <> help "Exit non-zero for warning diagnostics with these stable codes (repeatable)")+      )++-- | Parse a @--deny@ argument, refusing codes @check@ can never emit.+--+-- A denial that can never match is worse than no denial: it reads like a gate in+-- a CI file and silently is not one. Diff-side and codec-comparison codes are+-- therefore rejected outright here. Coverage codes are accepted at this stage+-- and validated against @--coverage-report@ once the whole invocation is known,+-- because an option reader cannot see its sibling options.+parseDenyCodes :: String -> Either String [DiagnosticCode]+parseDenyCodes raw = traverse parseOne (T.splitOn "," (T.pack raw))+  where+    parseOne token+      | T.null token = Left "--deny requires one or more comma-separated diagnostic codes"+      | otherwise = case parseDiagnosticCode token of+          Just diagnosticCode -> classify token diagnosticCode+          Nothing ->+            Left+              ( "unknown diagnostic code `"+                  <> T.unpack token+                  <> "`; copy the spelling exactly from warning[Code] output"+              )+    classify token diagnosticCode = case diagnosticOrigin diagnosticCode of+      CheckDiagnostic -> Right diagnosticCode+      CoverageDiagnostic -> Right diagnosticCode+      DiffDiagnostic ->+        Left+          ( "diagnostic code `"+              <> T.unpack token+              <> "` is emitted by `keiro-dsl diff`, which compares two revisions; `check` can never emit it, so denying it here would never match"+          )+      CodecCompareDiagnostic ->+        Left+          ( "diagnostic code `"+              <> T.unpack token+              <> "` is emitted only by the generated codec-comparison path; `check` can never emit it, so denying it here would never match"+          )++-- | Reject a @--deny@ selection of a coverage code when this invocation never+-- runs the coverage pass, for the same reason 'parseDenyCodes' rejects+-- diff-side codes: the denial could not fire.+--+-- 'CoverageOpaqueGateExceeded' is refused outright: it is the error+-- @--fail-on-opaque@ itself raises, never a warning, so the deny scan can never+-- match it — without the flag the code does not fire at all, and with the flag+-- the run already fails. A denial in CI must be either effective or an+-- immediate error, and this one could only ever be a silent no-op.+validateCheckDenyCodes :: CheckOptions -> IO ()+validateCheckDenyCodes options = do+  when (CoverageOpaqueGateExceeded `elem` checkDenyCodes options) $ do+    TIO.hPutStrLn+      stderr+      "check: --deny CoverageOpaqueGateExceeded can never match; the code is the error --fail-on-opaque itself raises, so pass --fail-on-opaque instead of denying it"+    exitFailure+  case [diagnosticCode | diagnosticCode <- checkDenyCodes options, diagnosticOrigin diagnosticCode == CoverageDiagnostic, diagnosticCode /= CoverageOpaqueGateExceeded] of+    [] -> pure ()+    unreachable+      | Just _ <- checkCoverage options -> pure ()+      | otherwise -> do+          TIO.hPutStrLn+            stderr+            ( "check: --deny "+                <> T.intercalate ", " (map diagnosticCodeText unreachable)+                <> " selects a structural-coverage code, which only the coverage pass emits; add --coverage-report FILE or drop the code"+            )+          exitFailure++checkReportOutOpt :: Parser FilePath+checkReportOutOpt =+  strOption+    (long "report-out" <> metavar "FILE" <> help "Write the full keiro-dsl/check-report/1 validation report as JSON")+ diffCoverageOptions :: Parser (Maybe DiffCoverageOptions) diffCoverageOptions =   optional@@ -201,19 +326,172 @@     parseFormat "json" = Right BehaviorJson     parseFormat other = Left ("unsupported behavior obligation format: " <> other <> " (expected text or json)") +emitLanguageContractNotice :: FilePath -> T.Text -> CheckedService -> IO ()+emitLanguageContractNotice subject sourceFormSummary service =+  mapM_+    (TIO.hPutStrLn stderr)+    (languageContractNotice subject sourceFormSummary (checkedLanguageContract service))++emitWorkspaceLanguageContractNotice :: FilePath -> WorkspaceSpec -> IO ()+emitWorkspaceLanguageContractNotice subject workspace =+  emitLanguageContractNotice subject (workspaceSourceFormSummary workspace) (checkedWorkspace workspace)++workspaceSourceFormSummary :: WorkspaceSpec -> T.Text+workspaceSourceFormSummary workspace =+  "workspace, "+    <> T.pack (show legacyCount)+    <> " legacy-unversioned member(s)"+  where+    legacyCount = length [() | member <- wsMembers workspace, LegacyUnversioned <- [wmSourceLanguage member]]++minimumWorkspaceLanguageDiagnostics :: LanguageVersion -> WorkspaceSpec -> [WorkspaceDiagnostic]+minimumWorkspaceLanguageDiagnostics floorVersion workspace+  | effectiveVersion >= floorVersion = []+  | otherwise =+      [ WorkspaceDiagnostic+          { wdLocations =+              NE.fromList+                ( WorkspaceLocation WorkspaceManifestFile 1 ""+                    : [ WorkspaceLocation+                          (WorkspaceMemberFile (wmPath member))+                          (sourceLanguageLine (wmSourceLanguage member))+                          ( "member selects effective language version "+                              <> languageVersionText (effectiveLanguageVersion (wmSourceLanguage member))+                          )+                      | member <- wsMembers workspace+                      ]+                ),+            wdSeverity = Error,+            wdCode = LanguageVersionBelowMinimum,+            wdSourceLanguageCause = Nothing,+            wdMessage =+              "effective language version "+                <> languageVersionText effectiveVersion+                <> " (workspace-composed) is below the required minimum "+                <> languageVersionText floorVersion+                <> "; declare `language keiro-dsl "+                <> languageVersionText floorVersion+                <> "` in every member"+          }+      ]+  where+    effectiveVersion = effectiveContractLanguageVersion (checkedLanguageContract (checkedWorkspace workspace))+    sourceLanguageLine LegacyUnversioned = 1+    sourceLanguageLine DeclaredLanguage {languageVersionLoc = Loc lineNumber} = lineNumber++deniesWarningCode :: CheckOptions -> DiagnosticCode -> Bool+deniesWarningCode options diagnosticCode =+  checkDenyWarnings options || diagnosticCode `elem` checkDenyCodes options++deniedSourceWarningCodes :: CheckOptions -> [Diagnostic] -> [DiagnosticCode]+deniedSourceWarningCodes options diagnostics =+  [ code diagnostic+  | diagnostic <- diagnostics,+    severity diagnostic == Warning,+    deniesWarningCode options (code diagnostic)+  ]++deniedWorkspaceWarningCodes :: CheckOptions -> [WorkspaceDiagnostic] -> [DiagnosticCode]+deniedWorkspaceWarningCodes options diagnostics =+  [ wdCode diagnostic+  | diagnostic <- diagnostics,+    wdSeverity diagnostic == Warning,+    deniesWarningCode options (wdCode diagnostic)+  ]++emitDeniedWarningSummary :: [DiagnosticCode] -> IO ()+emitDeniedWarningSummary deniedCodes =+  when (not (null deniedCodes)) $+    TIO.hPutStrLn stderr $+      "check: "+        <> T.pack (show (length deniedCodes))+        <> " warning(s) escalated to failure (denied: "+        <> T.intercalate ", " [diagnosticCodeText diagnosticCode | diagnosticCode <- [minBound .. maxBound], diagnosticCode `elem` deniedCodes]+        <> ")"++checkReportEnforcement :: CheckOptions -> CheckReport.CheckReportEnforcement+checkReportEnforcement options =+  CheckReport.CheckReportEnforcement+    { CheckReport.reportMinLanguage = checkMinLanguage options,+      CheckReport.reportDenyWarnings = checkDenyWarnings options,+      CheckReport.reportDenyCodes = checkDenyCodes options+    }++-- | Write a check report to @--report-out@, creating any missing parent+-- directories first. CI recipes routinely point this at a not-yet-created+-- artifact directory; the coverage writer has always done this.+writeCheckReportFile :: CheckOptions -> CheckReport.CheckReport -> IO ()+writeCheckReportFile options report =+  mapM_+    ( \path -> do+        createDirectoryIfMissing True (takeDirectory path)+        Aeson.encodeFile path report+    )+    (checkReportOut options)++writeSourceCheckReport :: FilePath -> ParsedSource -> CheckedService -> CheckOptions -> [Diagnostic] -> IO ()+writeSourceCheckReport subject parsedSource service options diagnostics =+  writeCheckReportFile+    options+    ( CheckReport.checkReport+        subject+        (parsedSourceLanguage parsedSource)+        (checkedLanguageContract service)+        enforcement+        diagnostics+        (CheckReport.effectiveDenyCodes enforcement)+    )+  where+    enforcement = checkReportEnforcement options++writeWorkspaceCheckReport :: FilePath -> WorkspaceSpec -> CheckedService -> CheckOptions -> [WorkspaceDiagnostic] -> IO ()+writeWorkspaceCheckReport subject workspace service options diagnostics =+  writeCheckReportFile+    options+    ( CheckReport.workspaceCheckReport+        subject+        workspace+        (checkedLanguageContract service)+        enforcement+        diagnostics+        (CheckReport.effectiveDenyCodes enforcement)+    )+  where+    enforcement = checkReportEnforcement options++-- | Write the machine report for a workspace refused during composition. The+-- single-spec path already reports the equivalent failure, so a CI job that+-- consumes @--report-out@ must not lose the workspace one.+writeWorkspaceRefusalReport :: FilePath -> CheckOptions -> WorkspaceFailure -> IO ()+writeWorkspaceRefusalReport subject options failure = case failure of+  WorkspaceRefused diagnostics ->+    writeCheckReportFile+      options+      ( CheckReport.workspaceRefusalReport+          subject+          enforcement+          diagnostics+          (CheckReport.effectiveDenyCodes enforcement)+      )+  -- An unreadable or unparseable manifest has no coded diagnostic, exactly as a+  -- `.keiro` parse error has none on the single-spec path. Both write no report.+  _ -> pure ()+  where+    enforcement = checkReportEnforcement options+ 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+run (Check fp checkOptionsValue)+  | isWorkspacePath fp = runWorkspaceCheck fp checkOptionsValue run (Inspect fp format)   | isWorkspacePath fp = runWorkspaceInspect fp format run (BehaviorObligations fp format)   | isWorkspacePath fp = runWorkspaceBehaviorObligations fp format-run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest)-  | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest+run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest)+  | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions)   | isWorkspacePath fp = runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions run (Parse fp) = do@@ -223,32 +501,44 @@       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure     Right parsedSource -> TIO.putStrLn (renderSource parsedSource)-run (Check fp emit explainBindings coverageOptions) = do+run (Check fp options) = do   input <- TIO.readFile fp   case parseSource fp input of     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure     Right parsedSource -> do+      validateCheckDenyCodes options       let service = checkedSource parsedSource           spec = checkedSpec service-          diags = validateService service-      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags-      if any ((== Error) . severity) diags+          floorDiags = maybe [] (\floorVersion -> minimumLanguageDiagnostics floorVersion (parsedSourceLanguage parsedSource)) (checkMinLanguage options)+          semanticDiags = floorDiags <> checkServiceDiagnostics Nothing (mkContext Nothing False spec) service+          semanticFailed = any ((== Error) . severity) semanticDiags+      emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage parsedSource)) service+      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) semanticDiags+      -- Coverage is part of this invocation's diagnostic surface, not a+      -- success-path artifact: its findings must reach the deny policy, the exit+      -- code, and the check report. It still runs only after semantic validation+      -- passes, because an unresolvable graph has nothing to cover.+      coveragePlan <- planCheckCoverage fp spec (if semanticFailed then Nothing else checkCoverage options)+      coverageOk <- emitPlannedCoverage coveragePlan+      let diags = semanticDiags <> plannedCoverageDiagnostics coveragePlan+          deniedWarningCodes = deniedSourceWarningCodes options diags+      emitDeniedWarningSummary deniedWarningCodes+      writeSourceCheckReport fp parsedSource service options diags+      if semanticFailed || not coverageOk || not (null deniedWarningCodes)         then exitFailure         else do-          when emit (TIO.putStrLn (renderSource parsedSource))-          if explainBindings+          when (checkEmit options) (TIO.putStrLn (renderSource parsedSource))+          if checkExplainBindings options             then case bindingObligationsForService service 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 cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) = do+          when (not (checkEmit options) && not (checkExplainBindings options)) (putStrLn "OK")+run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest) = do   input <- TIO.readFile fp   case parseSource fp input of     Left failure -> do@@ -257,6 +547,7 @@     Right parsedSource -> do       let service = checkedSource parsedSource           spec = checkedSpec service+      emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage parsedSource)) service       -- Validation gate: never scaffold an invalid spec. Abort on any       -- error-severity diagnostic before writing a single module.       let diags = validateService service@@ -275,7 +566,7 @@           case comparisonReady of             Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure             Right () -> do-              result <- executeServiceScaffoldWithRuntimePackage cliRuntimePackage out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx service modules+              result <- executeServiceScaffoldWithRuntimePackageAndNameMigrations cliRuntimePackage applyNameMigrations out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx service modules               case result of                 Left refusals -> do                   mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)@@ -330,6 +621,7 @@                   newService = checkedSource newSource                   oldSpec = checkedSpec oldService                   newSpec = checkedSpec newService+              emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage newSource)) newService               case (,) <$> diffSources oldSource newSource <*> replayImpactServices oldService newService of                 Left surfaceError -> TIO.hPutStrLn stderr (renderFoldSurfaceError surfaceError) >> exitFailure                 Right (changes, impact) -> do@@ -445,32 +737,43 @@ -- @--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+runWorkspaceCheck :: FilePath -> CheckOptions -> IO ()+runWorkspaceCheck fp options = do+  validateCheckDenyCodes options   loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp   case loaded of     Left failure -> do       mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)+      writeWorkspaceRefusalReport fp options failure       exitFailure     Right workspace -> do       let service = checkedWorkspace workspace-          diags = checkWorkspace workspace+          floorDiags = maybe [] (\floorVersion -> minimumWorkspaceLanguageDiagnostics floorVersion workspace) (checkMinLanguage options)+          semanticDiags = floorDiags <> checkWorkspace workspace           spec = checkedSpec service-      mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags-      if any ((== Error) . wdSeverity) diags+          semanticFailed = any ((== Error) . wdSeverity) semanticDiags+      emitWorkspaceLanguageContractNotice fp workspace+      mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) semanticDiags+      -- Same contract as the single-spec path: coverage findings are gated+      -- diagnostics, not success-path output. See `run (Check …)` above.+      coveragePlan <- planCheckCoverage fp spec (if semanticFailed then Nothing else checkCoverage options)+      coverageOk <- emitPlannedCoverage coveragePlan+      let diags = semanticDiags <> map (workspaceCoverageDiagnostic fp) (plannedCoverageFindings coveragePlan)+          deniedWarningCodes = deniedWorkspaceWarningCodes options diags+      emitDeniedWarningSummary deniedWarningCodes+      writeWorkspaceCheckReport fp workspace service options diags+      if semanticFailed || not coverageOk || not (null deniedWarningCodes)         then exitFailure         else do-          when emit (TIO.putStrLn (renderSpec spec))-          if explainBindings+          when (checkEmit options) (TIO.putStrLn (renderSpec spec))+          if checkExplainBindings options             then case bindingObligationsForService service 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+          when (not (checkEmit options) && not (checkExplainBindings options)) (putStrLn "OK")  -- | @scaffold@ on a workspace manifest: compose the whole service, then plan -- and emit the complete module set for every member in one invocation.@@ -491,16 +794,18 @@   Maybe RuntimePackageName ->   Bool ->   Bool ->+  Bool ->   Maybe FilePath ->   Maybe (String, FilePath) ->   IO ()-runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest = do+runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations 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+      emitWorkspaceLanguageContractNotice fp workspace       -- Validation gate: never scaffold an invalid service. Abort on any       -- error-severity diagnostic before writing a single module.       let diags = checkWorkspace workspace@@ -525,7 +830,7 @@           case comparisonReady of             Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure             Right () -> do-              result <- executeWorkspaceScaffold out forceGeneratedOverwrite plan+              result <- executeWorkspaceScaffoldWithNameMigrations out forceGeneratedOverwrite applyNameMigrations plan               case result of                 Left refusals -> do                   mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)@@ -572,6 +877,7 @@           case newLoaded of             Left failure -> printWorkspaceFailure fp failure             Right newWorkspace -> do+              emitWorkspaceLanguageContractNotice fp newWorkspace               currentManifestText <- TIO.readFile fp               case parseWorkspaceManifest fp currentManifestText of                 Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure@@ -766,16 +1072,62 @@   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+-- | What this @check@ invocation's coverage pass will do, decided before the+-- warning policy is applied so the findings can take part in it.+data PlannedCoverage+  = -- | @--coverage-report@ was not supplied, or semantic validation already failed.+    NoCoverage+  | -- | The report to render, and the path to write it to.+    PlannedCoverage !FilePath !Coverage.CoverageReport+  | -- | The mapped-type graph did not resolve; the pass cannot run.+    CoverageUnresolved !String++planCheckCoverage :: FilePath -> Spec -> Maybe CheckCoverageOptions -> IO PlannedCoverage+planCheckCoverage _ _ Nothing = pure NoCoverage+planCheckCoverage specPath spec (Just options) =+  pure $ case Coverage.coverageReport specPath spec of+    Left graphErrors -> CoverageUnresolved (show graphErrors)+    Right baseReport ->+      PlannedCoverage+        (checkCoveragePath options)+        (if checkFailOnOpaque options then Coverage.failOnOpaque baseReport else baseReport)++plannedCoverageFindings :: PlannedCoverage -> [Coverage.CoverageFinding]+plannedCoverageFindings (PlannedCoverage _ report) = Coverage.coverageFindings report+plannedCoverageFindings _ = []++-- | Coverage findings as ordinary source diagnostics. They carry no line, which+-- the rendered form has always shown as @:0:@.+plannedCoverageDiagnostics :: PlannedCoverage -> [Diagnostic]+plannedCoverageDiagnostics plan =+  [ Diagnostic+      { line = 0,+        severity = Coverage.findingSeverity finding,+        code = Coverage.findingCode finding,+        relatedLocations = [],+        message = Coverage.coverageFindingMessage finding+      }+  | finding <- plannedCoverageFindings plan+  ]++-- | The workspace twin: coverage runs on the merged graph, so every finding is+-- attributed to the manifest rather than to one member.+workspaceCoverageDiagnostic :: FilePath -> Coverage.CoverageFinding -> WorkspaceDiagnostic+workspaceCoverageDiagnostic _ finding =+  WorkspaceDiagnostic+    { wdLocations = NE.fromList [WorkspaceLocation WorkspaceManifestFile 0 ""],+      wdSeverity = Coverage.findingSeverity finding,+      wdCode = Coverage.findingCode finding,+      wdSourceLanguageCause = Nothing,+      wdMessage = Coverage.coverageFindingMessage finding+    }++emitPlannedCoverage :: PlannedCoverage -> IO Bool+emitPlannedCoverage NoCoverage = pure True+emitPlannedCoverage (CoverageUnresolved graphErrors) = do+  hPutStrLn stderr ("validated spec did not resolve its mapped type graph for coverage: " <> graphErrors)+  pure False+emitPlannedCoverage (PlannedCoverage path report) = emitCoverageReport path report  runDiffCoverage :: FilePath -> T.Text -> Spec -> Spec -> Maybe DiffCoverageOptions -> IO Bool runDiffCoverage _ _ _ _ Nothing = pure True

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-dsl-version:         0.10.0.0+version:         0.11.0.0 synopsis:        Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro@@ -29,10 +29,27 @@     OverloadedLabels     OverloadedStrings +-- Every component importing this stanza compiles only `keiro-dsl scaffold`+-- output plus hand-filled holes. Generated code is regenerated wholesale, so a+-- warning in it is a generator defect with nothing for a human to fix in place:+-- -Werror keeps such a regression from building green. This is deliberately not+-- added to `warnings`, where src/ keeps -Wall non-fatal. Hackage rejects an+-- unconditional -Werror, so the gate rides a manual flag that this repository's+-- cabal.project switches on; the published sdist defaults it off.+flag werror-generated+  description:+    Promote warnings in committed generated conformance output to errors++  manual:      True+  default:     False+ common generated-output   default-language:   GHC2024   default-extensions: OverloadedStrings +  if flag(werror-generated)+    ghc-options: -Werror+ library   import:          warnings, shared   hs-source-dirs:  src@@ -41,6 +58,7 @@     Keiro.Dsl.AggregateType     Keiro.Dsl.BehaviorCoverage     Keiro.Dsl.CanonicalEncoding+    Keiro.Dsl.CheckReport     Keiro.Dsl.CodecCompare     Keiro.Dsl.ConformancePackage     Keiro.Dsl.Coverage@@ -54,6 +72,7 @@     Keiro.Dsl.Goldens     Keiro.Dsl.Grammar     Keiro.Dsl.Harness+    Keiro.Dsl.HaskellSourceMove     Keiro.Dsl.IdDomain     Keiro.Dsl.LanguageVersion     Keiro.Dsl.Manifest@@ -70,6 +89,8 @@     Keiro.Dsl.ScaffoldRun     Keiro.Dsl.SemanticContract     Keiro.Dsl.ServiceHarness+    Keiro.Dsl.SidecarMigration+    Keiro.Dsl.SidecarNames     Keiro.Dsl.Skeleton     Keiro.Dsl.Source     Keiro.Dsl.Syntax@@ -82,9 +103,12 @@     Keiro.Dsl.WorkspaceScaffold    other-modules:+    Keiro.Dsl.AggregateGenerationPlan+    Keiro.Dsl.FieldIdentity     Keiro.Dsl.Frontend.Internal     Keiro.Dsl.GeneratedHaskellLanguage     Keiro.Dsl.HaskellImport+    Keiro.Dsl.HaskellName     Keiro.Dsl.Parser.Aggregate     Keiro.Dsl.Parser.Coordination     Keiro.Dsl.Parser.Core@@ -106,8 +130,8 @@     , containers          >=0.6       && <0.8     , directory           >=1.3       && <1.4     , filepath            >=1.4       && <1.6-    , keiki               >=0.8       && <0.9-    , keiro-core          ^>=0.10.0.0+    , keiki               >=0.9       && <0.10+    , keiro-core          ^>=0.11.0.0     , megaparsec          >=9.6       && <9.9     , mmzk-typeid         >=0.7       && <0.8     , parser-combinators  >=1.3       && <1.4@@ -150,7 +174,7 @@     , directory    >=1.3  && <1.4     , filepath     >=1.4  && <1.6     , hspec        >=2.11-    , keiki        >=0.8  && <0.9+    , keiki        >=0.9  && <0.10     , keiro-core     , keiro-dsl     , mmzk-typeid  >=0.7  && <0.8@@ -163,13 +187,44 @@   type:           exitcode-stdio-1.0   hs-source-dirs: test/import-planning src   main-is:        Main.hs-  other-modules:  Keiro.Dsl.HaskellImport+  other-modules:+    Keiro.Dsl.HaskellImport+    Keiro.Dsl.HaskellName+   build-depends:     , base        >=4.21 && <5     , containers  >=0.6  && <0.8     , hspec       >=2.11     , text        >=2.1  && <2.2 +test-suite keiro-dsl-haskell-name-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/haskell-name src+  main-is:        Main.hs+  other-modules:  Keiro.Dsl.HaskellName+  build-depends:+    , base        >=4.21 && <5+    , containers  >=0.6  && <0.8+    , hspec       >=2.11+    , QuickCheck  >=2.14+    , text        >=2.1  && <2.2++-- Plan 199: keiro-dsl validates specs without depending on the keiro runtime+-- package, so a few runtime vocabularies are restated in Keiro.Dsl.Validate.+-- This suite depends on both packages and fails when a restatement drifts from+-- the definition it mirrors.+test-suite keiro-dsl-runtime-vocabulary-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/runtime-vocabulary+  main-is:        Main.hs+  build-depends:+    , base       >=4.21 && <5+    , keiro+    , keiro-dsl+    , text       >=2.1  && <2.2+ -- Conformance: proves the scaffolded Generated modules plus a hand-filled -- Holes.hs compile against keiki/keiro and that the filled transducer passes -- keiki's validator and the codec round-trips. The Generated.* modules under@@ -196,7 +251,7 @@     , aeson       >=2.2  && <2.3     , base        >=4.21 && <5     , bytestring  >=0.12 && <0.13-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro     , text        >=2.1  && <2.2 @@ -221,7 +276,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.8  && <0.9+    , keiki  >=0.9  && <0.10     , keiro     , text   >=2.1  && <2.2     , time   >=1.12 && <1.15@@ -256,7 +311,7 @@     , aeson       >=2.2  && <2.3     , base        >=4.21 && <5     , containers  >=0.6  && <0.8-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro     , keiro-dsl     , text        >=2.1  && <2.2@@ -290,7 +345,7 @@     , base        >=4.21 && <5     , bytestring  >=0.12 && <0.13     , containers  >=0.6  && <0.8-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15@@ -321,7 +376,7 @@     , aeson        >=2.2  && <2.3     , base         >=4.21 && <5     , containers   >=0.6  && <0.8-    , keiki        >=0.8  && <0.9+    , keiki        >=0.9  && <0.10     , keiro     , mmzk-typeid  >=0.7  && <0.8     , text         >=2.1  && <2.2@@ -361,7 +416,7 @@     , aeson       >=2.2  && <2.3     , base        >=4.21 && <5     , containers  >=0.6  && <0.8-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro     , text        >=2.1  && <2.2 @@ -376,6 +431,7 @@   other-modules:     Conformance.Structural.Bindings     Conformance.Structural.Domain+    Generated.StructuralConformance.ArtifactCatalog.BehaviorContract     Generated.StructuralConformance.ArtifactCatalog.Codec     Generated.StructuralConformance.ArtifactCatalog.Domain     Generated.StructuralConformance.ArtifactCatalog.EventStream@@ -396,7 +452,7 @@     , bytestring  >=0.12 && <0.13     , containers  >=0.6  && <0.8     , deepseq     >=1.5  && <1.6-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15@@ -432,7 +488,7 @@     , base        >=4.21 && <5     , bytestring  >=0.12 && <0.13     , containers  >=0.6  && <0.8-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15@@ -466,7 +522,7 @@     , deepseq     >=1.5   && <1.6     , directory   >=1.3   && <1.4     , filepath    >=1.4   && <1.6-    , keiki       >=0.8   && <0.9+    , keiki       >=0.9   && <0.10     , keiro     , keiro-dsl     , text        >=2.1   && <2.2@@ -493,7 +549,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.8  && <0.9+    , keiki  >=0.9  && <0.10     , keiro     , text   >=2.1  && <2.2 @@ -517,7 +573,7 @@     , base         >=4.21 && <5     , containers   >=0.6  && <0.8     , deepseq      >=1.5  && <1.6-    , keiki        >=0.8  && <0.9+    , keiki        >=0.9  && <0.10     , keiro     , tasty-bench  >=0.5  && <0.6     , text         >=2.1  && <2.2@@ -544,15 +600,24 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.8  && <0.9+    , keiki  >=0.9  && <0.10     , keiro     , text   >=2.1  && <2.2  -- EP-106 M6: every distinct `new <kind>` skeleton is scaffolded into this -- committed tree. Compiling the union proves a starter that passes `check` -- cannot emit syntactically or type-invalid Haskell.+-- The only corpus suite whose hole modules are deliberately *unfilled*: it+-- exists to prove `keiro-dsl new <kind>` scaffolds a skeleton that compiles, so+-- its create-once files still carry their `-- HOLE` markers. A template cannot+-- be clean under -Wunused-imports/-Wunused-matches by construction — its imports+-- and its command binder are there for the fill that has not happened yet — so+-- those two classes are non-fatal here and everywhere-else-fatal. Every other+-- warning class remains an error, and the generated modules in this suite are+-- held to the same standard as the rest of the corpus. test-suite keiro-dsl-conformance-skeletons   import:         warnings, generated-output+  ghc-options:    -Wno-error=unused-imports -Wno-error=unused-matches   type:           exitcode-stdio-1.0   hs-source-dirs: test/conformance-skeletons   main-is:        Main.hs@@ -594,17 +659,17 @@     SkelProcess.MyService.Hospital.Holes     SkelProcess.MyService.HospitalSurge.ProcessHoles     SkelProcess.MyService.Surge.Holes-    SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModel-    SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelHarness-    SkelQueue.Generated.MyService.Accepted_transfer_needs.ReadModelTable-    SkelQueue.Generated.MyService.Reservation_work.Queue-    SkelQueue.Generated.MyService.Reservation_work.QueueCodec-    SkelQueue.Generated.MyService.Reservation_work.QueuePolicy-    SkelQueue.Generated.MyService.Transfer_decisions.ReadModel-    SkelQueue.Generated.MyService.Transfer_decisions.ReadModelHarness-    SkelQueue.Generated.MyService.Transfer_decisions.ReadModelTable-    SkelQueue.MyService.Accepted_transfer_needs.ReadModelHoles-    SkelQueue.MyService.Transfer_decisions.ReadModelHoles+    SkelQueue.Generated.MyService.AcceptedTransferNeeds.ReadModel+    SkelQueue.Generated.MyService.AcceptedTransferNeeds.ReadModelHarness+    SkelQueue.Generated.MyService.AcceptedTransferNeeds.ReadModelTable+    SkelQueue.Generated.MyService.ReservationWork.Queue+    SkelQueue.Generated.MyService.ReservationWork.QueueCodec+    SkelQueue.Generated.MyService.ReservationWork.QueuePolicy+    SkelQueue.Generated.MyService.TransferDecisions.ReadModel+    SkelQueue.Generated.MyService.TransferDecisions.ReadModelHarness+    SkelQueue.Generated.MyService.TransferDecisions.ReadModelTable+    SkelQueue.MyService.AcceptedTransferNeeds.ReadModelHoles+    SkelQueue.MyService.TransferDecisions.ReadModelHoles     SkelRouter.Generated.MyService.Page.Codec     SkelRouter.Generated.MyService.Page.Domain     SkelRouter.Generated.MyService.Page.EventStream@@ -625,7 +690,7 @@     , containers     , effectful-core     , hasql-transaction-    , keiki              >=0.8  && <0.9+    , keiki              >=0.9  && <0.10     , keiro     , keiro-core     , keiro-pgmq@@ -659,7 +724,7 @@   build-depends:     , aeson  >=2.2  && <2.3     , base   >=4.21 && <5-    , keiki  >=0.8  && <0.9+    , keiki  >=0.9  && <0.10     , keiro     , text   >=2.1  && <2.2 @@ -746,8 +811,8 @@   hs-source-dirs: test/conformance-queue   main-is:        Main.hs   other-modules:-    Generated.HospitalCapacity.Reservation_work.Queue-    Generated.HospitalCapacity.Reservation_work.QueueCodec+    Generated.HospitalCapacity.ReservationWork.Queue+    Generated.HospitalCapacity.ReservationWork.QueueCodec    build-depends:     , aeson       >=2.2  && <2.3@@ -764,9 +829,9 @@   hs-source-dirs: test/conformance-queue-runtime   main-is:        Main.hs   other-modules:-    Generated.HospitalCapacity.Reservation_work.Queue-    Generated.HospitalCapacity.Reservation_work.QueueCodec-    Generated.HospitalCapacity.Reservation_work.QueuePolicy+    Generated.HospitalCapacity.ReservationWork.Queue+    Generated.HospitalCapacity.ReservationWork.QueueCodec+    Generated.HospitalCapacity.ReservationWork.QueuePolicy    build-depends:     , aeson        >=2.2  && <2.3@@ -788,10 +853,10 @@   hs-source-dirs: test/conformance-readmodel-runtime   main-is:        Main.hs   other-modules:-    Generated.HospitalCapacity.Transfer_decisions.ReadModel-    Generated.HospitalCapacity.Transfer_decisions.ReadModelHarness-    Generated.HospitalCapacity.Transfer_decisions.ReadModelTable-    HospitalCapacity.Transfer_decisions.ReadModelHoles+    Generated.HospitalCapacity.TransferDecisions.ReadModel+    Generated.HospitalCapacity.TransferDecisions.ReadModelHarness+    Generated.HospitalCapacity.TransferDecisions.ReadModelTable+    HospitalCapacity.TransferDecisions.ReadModelHoles    build-depends:     , base               >=4.21 && <5@@ -810,9 +875,9 @@   hs-source-dirs: test/conformance-dispatch-full   main-is:        Main.hs   other-modules:-    Generated.HospitalCapacity.Reservation_work.Queue-    Generated.HospitalCapacity.Reservation_work.QueueCodec-    Generated.HospitalCapacity.Reservation_work.QueuePolicy+    Generated.HospitalCapacity.ReservationWork.Queue+    Generated.HospitalCapacity.ReservationWork.QueueCodec+    Generated.HospitalCapacity.ReservationWork.QueuePolicy     HospitalCapacity.ReservationWork.WorkqueueJob    build-depends:@@ -882,7 +947,7 @@   build-depends:     , aeson         >=2.2  && <2.3     , base          >=4.21 && <5-    , keiki         >=0.8  && <0.9+    , keiki         >=0.9  && <0.10     , keiro     , shibuya-core     , text          >=2.1  && <2.2@@ -930,7 +995,7 @@   build-depends:     , aeson         >=2.2  && <2.3     , base          >=4.21 && <5-    , keiki         >=0.8  && <0.9+    , keiki         >=0.9  && <0.10     , keiro     , keiro-dsl     , shibuya-core@@ -988,7 +1053,7 @@     , aeson           >=2.2  && <2.3     , base            >=4.21 && <5     , effectful-core-    , keiki           >=0.8  && <0.9+    , keiki           >=0.9  && <0.10     , keiro     , shibuya-core     , text            >=2.1  && <2.2@@ -1010,14 +1075,14 @@     Generated.TransferRouting.Hospital.Harness     Generated.TransferRouting.Hospital.Projection     Generated.TransferRouting.Hospital.Transducer-    Generated.TransferRouting.Hospital_load.ReadModel-    Generated.TransferRouting.Hospital_load.ReadModelHarness-    Generated.TransferRouting.Hospital_load.ReadModelTable+    Generated.TransferRouting.HospitalLoad.ReadModel+    Generated.TransferRouting.HospitalLoad.ReadModelHarness+    Generated.TransferRouting.HospitalLoad.ReadModelTable     Generated.TransferRouting.HospitalTransferRouter.Router     Generated.TransferRouting.HospitalTransferRouter.RouterHarness     Generated.TransferRouting.ReplayAudit     TransferRouting.Hospital.Holes-    TransferRouting.Hospital_load.ReadModelHoles+    TransferRouting.HospitalLoad.ReadModelHoles     TransferRouting.HospitalTransferRouter.RouterHoles     TransferRouting.HospitalTransferRouter.RouterValue @@ -1026,7 +1091,7 @@     , base               >=4.21 && <5     , effectful-core     , hasql-transaction-    , keiki              >=0.8  && <0.9+    , keiki              >=0.9  && <0.10     , keiro     , kiroku-store     , shibuya-core@@ -1073,7 +1138,7 @@     , aeson      >=2.2  && <2.3     , base       >=4.21 && <5     , directory  >=1.3  && <1.4-    , keiki      >=0.8  && <0.9+    , keiki      >=0.9  && <0.10     , keiro     , text       >=2.1  && <2.2 @@ -1094,6 +1159,6 @@   build-depends:     , aeson       >=2.2  && <2.3     , base        >=4.21 && <5-    , keiki       >=0.8  && <0.9+    , keiki       >=0.9  && <0.10     , keiro-core     , text        >=2.1  && <2.2

@@ -0,0 +1,42 @@+module Keiro.Dsl.AggregateGenerationPlan+  ( TransitionLayoutEntry (..),+    transitionLayout,+    groupTransitionLayoutBySource,+    transitionLayoutForSource,+  )+where++import Data.List (mapAccumL)+import Data.Map.Strict qualified as Map+import Keiro.Dsl.Grammar (Name, Transition (..))++data TransitionLayoutEntry = TransitionLayoutEntry+  { layoutDeclarationIndex :: !Int,+    layoutOutgoingIndex :: !Int,+    layoutTransition :: !Transition+  }+  deriving stock (Eq, Show)++transitionLayout :: [Transition] -> [TransitionLayoutEntry]+transitionLayout transitions = snd (mapAccumL buildEntry Map.empty (zip [1 ..] transitions))+  where+    buildEntry counts (declarationIndex, transition) =+      let source = tSource transition+          outgoingIndex = Map.findWithDefault 0 source counts+          counts' = Map.insert source (outgoingIndex + 1) counts+          entry = TransitionLayoutEntry declarationIndex outgoingIndex transition+       in (counts', entry)++groupTransitionLayoutBySource :: [TransitionLayoutEntry] -> [(Name, [TransitionLayoutEntry])]+groupTransitionLayoutBySource entries =+  [ (source, transitionLayoutForSource source entries)+  | source <- firstOccurrences (map (tSource . layoutTransition) entries)+  ]+  where+    firstOccurrences = foldl appendNew []+    appendNew seen value+      | value `elem` seen = seen+      | otherwise = seen ++ [value]++transitionLayoutForSource :: Name -> [TransitionLayoutEntry] -> [TransitionLayoutEntry]+transitionLayoutForSource source = filter ((== source) . tSource . layoutTransition)

@@ -32,7 +32,6 @@   ) where -import Data.Char (toUpper) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map@@ -45,6 +44,7 @@ import Data.Time.Format.ISO8601 (iso8601ParseM) import Keiro.Dsl.Grammar import Keiro.Dsl.HaskellImport+import Keiro.Dsl.HaskellName qualified as HaskellName import Keiro.Dsl.NominalType import Keiro.Dsl.TypeGraph import Numeric.Natural (Natural)@@ -261,10 +261,7 @@     mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration     mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration     timeImports =-      Set.fromList-        [ "Data.Time.Calendar (fromGregorian)",-          "Data.Time.Clock (UTCTime(..), picosecondsToDiffTime)"-        ]+      Set.singleton "Data.Time.Clock (UTCTime)"  aggregateSourceReferences :: AggregateHaskellSource -> Set HaskellReference aggregateSourceReferences source = maybe Set.empty Set.singleton (aggregateSourceReference source)@@ -420,9 +417,18 @@   InitialMapped {} -> "initial"  pascal :: Text -> Text-pascal value = case T.uncons value of-  Just (first, rest) -> T.cons (toUpper first) rest-  Nothing -> value+pascal value =+  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+    Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+    Left _ -> value+  where+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedTypeSite,+          HaskellName.siteLogicalName = value,+          HaskellName.siteOwner = "aggregate-type",+          HaskellName.siteLine = 0+        }  tshow :: Text -> Text tshow = T.pack . show

@@ -0,0 +1,341 @@+-- | Pure construction and JSON encoding for @check@ reports.+--+-- The JSON schema identifier is @keiro-dsl/check-report/1@. Object keys and+-- array element keys are append-only, and consumers must ignore unknown keys.+-- Source and workspace checks share the schema; workspace inputs add a+-- top-level @members@ array. The report's @ok@ field covers parse-successful+-- semantic validation, minimum-language enforcement, denied warnings, and — when+-- the invocation supplies @--coverage-report@ — the structural-coverage+-- findings, which appear as ordinary diagnostic entries at line 0 so one warning+-- policy governs every warning @check@ can emit. The separate coverage report+-- remains the place for the full root and boundary inventory.+--+-- Severity is spelled @"error"@ or @"warning"@ here and in the coverage report;+-- there is exactly one severity vocabulary across keiro-dsl's JSON.+module Keiro.Dsl.CheckReport+  ( CheckReportLanguage (..),+    CheckReportEnforcement (..),+    CheckReportRelated (..),+    CheckReportEntry (..),+    CheckReportSummary (..),+    CheckReportMember (..),+    CheckReport,+    effectiveDenyCodes,+    checkReport,+    workspaceCheckReport,+    workspaceRefusalReport,+  )+where++import Data.Aeson (ToJSON (..), Value, object, (.=))+import Data.List.NonEmpty qualified as NE+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Dsl.LanguageVersion (LanguageSupport (..), LanguageVersion, SourceLanguage, declaredLanguageVersionMaybe, languageSupportText, sourceFormText)+import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveContractLanguageVersion, effectiveLanguageSupport, effectiveRuntimeSemantics)+import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode, Severity (..), diagnosticCodeText)+import Keiro.Dsl.Workspace (WorkspaceDiagnostic (..), WorkspaceLocation (..), WorkspaceMember (..), WorkspaceSpec (..), workspaceDisplayPath)++data CheckReportLanguage = CheckReportLanguage+  { reportSourceForm :: !Text,+    reportDeclaredLanguageVersion :: !(Maybe LanguageVersion),+    reportEffectiveLanguageVersion :: !LanguageVersion,+    reportRuntimeSemantics :: !Text,+    reportLanguageSupport :: !LanguageSupport,+    reportStable :: !Bool+  }+  deriving stock (Eq, Show)++data CheckReportEnforcement = CheckReportEnforcement+  { reportMinLanguage :: !(Maybe LanguageVersion),+    reportDenyWarnings :: !Bool,+    reportDenyCodes :: ![DiagnosticCode]+  }+  deriving stock (Eq, Show)++data CheckReportRelated = CheckReportRelated+  { relatedFile :: !FilePath,+    relatedLine :: !Int,+    relatedNote :: !Text+  }+  deriving stock (Eq, Show)++data CheckReportEntry = CheckReportEntry+  { entryCode :: !DiagnosticCode,+    entrySeverity :: !Severity,+    entryFile :: !FilePath,+    entryLine :: !Int,+    entryMessage :: !Text,+    entryDenied :: !Bool,+    entryRelated :: ![CheckReportRelated]+  }+  deriving stock (Eq, Show)++data CheckReportSummary = CheckReportSummary+  { summaryErrors :: !Int,+    summaryWarnings :: !Int,+    summaryDeniedWarnings :: !Int+  }+  deriving stock (Eq, Show)++data CheckReportMember = CheckReportMember+  { memberPath :: !FilePath,+    memberSourceForm :: !Text,+    memberDeclaredLanguageVersion :: !(Maybe LanguageVersion)+  }+  deriving stock (Eq, Show)++data CheckReportKind = SourceReport | WorkspaceReport+  deriving stock (Eq, Show)++data CheckReport = CheckReport+  { reportKind :: !CheckReportKind,+    reportSubject :: !FilePath,+    -- | 'Nothing' only for a workspace that was refused during composition:+    -- there is no composed service, so no effective language contract exists to+    -- describe. Such a report serializes @"language": null@.+    reportLanguage :: !(Maybe CheckReportLanguage),+    reportEnforcement :: !CheckReportEnforcement,+    reportDiagnostics :: ![CheckReportEntry],+    reportSummary :: !CheckReportSummary,+    reportOk :: !Bool,+    reportMembers :: ![CheckReportMember]+  }+  deriving stock (Eq, Show)++-- | Expand one invocation's warning policy to the actual stable-code set used+-- by report entries. @--deny-warnings@ is the union with every registered code.+effectiveDenyCodes :: CheckReportEnforcement -> Set DiagnosticCode+effectiveDenyCodes enforcement+  | reportDenyWarnings enforcement = Set.fromList [minBound .. maxBound]+  | otherwise = Set.fromList (reportDenyCodes enforcement)++checkReport ::+  FilePath ->+  SourceLanguage ->+  EffectiveLanguageContract ->+  CheckReportEnforcement ->+  [Diagnostic] ->+  Set DiagnosticCode ->+  CheckReport+checkReport subject sourceLanguage contract enforcement diagnostics deniedCodes =+  buildReport+    SourceReport+    subject+    (Just (sourceLanguageValue sourceLanguage contract))+    enforcement+    (map (sourceEntry subject deniedCodes) diagnostics)+    []++workspaceCheckReport ::+  FilePath ->+  WorkspaceSpec ->+  EffectiveLanguageContract ->+  CheckReportEnforcement ->+  [WorkspaceDiagnostic] ->+  Set DiagnosticCode ->+  CheckReport+workspaceCheckReport subject workspace contract enforcement diagnostics deniedCodes =+  buildReport+    WorkspaceReport+    subject+    (Just (workspaceLanguageValue contract))+    enforcement+    (map (workspaceEntry subject deniedCodes) diagnostics)+    (map memberValue (wsMembers workspace))++-- | The report for a workspace refused during composition, before any service+-- graph exists. Composition refusals are coded diagnostics, so they belong in+-- the same machine contract as every other refusal; the single-spec path has+-- always written one for the equivalent failure. There is no composed language+-- contract and no member inventory to report, so both are omitted.+workspaceRefusalReport ::+  FilePath ->+  CheckReportEnforcement ->+  NE.NonEmpty WorkspaceDiagnostic ->+  Set DiagnosticCode ->+  CheckReport+workspaceRefusalReport subject enforcement diagnostics deniedCodes =+  buildReport+    WorkspaceReport+    subject+    Nothing+    enforcement+    (map (workspaceEntry subject deniedCodes) (NE.toList diagnostics))+    []++buildReport ::+  CheckReportKind ->+  FilePath ->+  Maybe CheckReportLanguage ->+  CheckReportEnforcement ->+  [CheckReportEntry] ->+  [CheckReportMember] ->+  CheckReport+buildReport kind subject language enforcement entries members =+  CheckReport+    { reportKind = kind,+      reportSubject = subject,+      reportLanguage = language,+      reportEnforcement = enforcement,+      reportDiagnostics = entries,+      reportSummary = summary,+      reportOk = summaryErrors summary == 0 && summaryDeniedWarnings summary == 0,+      reportMembers = members+    }+  where+    summary =+      CheckReportSummary+        { summaryErrors = length [() | entry <- entries, entrySeverity entry == Error],+          summaryWarnings = length [() | entry <- entries, entrySeverity entry == Warning],+          summaryDeniedWarnings = length [() | entry <- entries, entryDenied entry]+        }++sourceLanguageValue :: SourceLanguage -> EffectiveLanguageContract -> CheckReportLanguage+sourceLanguageValue sourceLanguage contract =+  languageValue+    (sourceFormText sourceLanguage)+    (declaredLanguageVersionMaybe sourceLanguage)+    contract++workspaceLanguageValue :: EffectiveLanguageContract -> CheckReportLanguage+workspaceLanguageValue = languageValue "workspace-composed" Nothing++languageValue :: Text -> Maybe LanguageVersion -> EffectiveLanguageContract -> CheckReportLanguage+languageValue sourceForm declared contract =+  CheckReportLanguage+    { reportSourceForm = sourceForm,+      reportDeclaredLanguageVersion = declared,+      reportEffectiveLanguageVersion = effectiveContractLanguageVersion contract,+      reportRuntimeSemantics = effectiveRuntimeSemantics contract,+      reportLanguageSupport = support,+      reportStable = support == Stable+    }+  where+    support = effectiveLanguageSupport contract++memberValue :: WorkspaceMember -> CheckReportMember+memberValue member =+  CheckReportMember+    { memberPath = wmPath member,+      memberSourceForm = sourceFormText (wmSourceLanguage member),+      memberDeclaredLanguageVersion = declaredLanguageVersionMaybe (wmSourceLanguage member)+    }++sourceEntry :: FilePath -> Set DiagnosticCode -> Diagnostic -> CheckReportEntry+sourceEntry subject deniedCodes diagnostic =+  CheckReportEntry+    { entryCode = code diagnostic,+      entrySeverity = severity diagnostic,+      entryFile = subject,+      entryLine = line diagnostic,+      entryMessage = message diagnostic,+      entryDenied = warningDenied deniedCodes (severity diagnostic) (code diagnostic),+      entryRelated =+        [ CheckReportRelated subject relatedLineNumber note+        | (relatedLineNumber, note) <- relatedLocations diagnostic+        ]+    }++workspaceEntry :: FilePath -> Set DiagnosticCode -> WorkspaceDiagnostic -> CheckReportEntry+workspaceEntry subject deniedCodes diagnostic =+  CheckReportEntry+    { entryCode = wdCode diagnostic,+      entrySeverity = wdSeverity diagnostic,+      entryFile = workspaceDisplayPath subject (wlFile primary),+      entryLine = wlLine primary,+      entryMessage = wdMessage diagnostic,+      entryDenied = warningDenied deniedCodes (wdSeverity diagnostic) (wdCode diagnostic),+      entryRelated =+        [ CheckReportRelated+            (workspaceDisplayPath subject (wlFile location))+            (wlLine location)+            (wlRole location)+        | location <- NE.tail (wdLocations diagnostic)+        ]+    }+  where+    primary = NE.head (wdLocations diagnostic)++warningDenied :: Set DiagnosticCode -> Severity -> DiagnosticCode -> Bool+warningDenied deniedCodes severityValue diagnosticCode =+  severityValue == Warning && diagnosticCode `Set.member` deniedCodes++instance ToJSON CheckReport where+  toJSON report =+    object+      ( [ "schema" .= ("keiro-dsl/check-report/1" :: Text),+          "kind" .= kindText (reportKind report),+          "subject" .= reportSubject report,+          "language" .= fmap languageJson (reportLanguage report),+          "enforcement" .= enforcementJson (reportEnforcement report),+          "diagnostics" .= map entryJson (reportDiagnostics report),+          "summary" .= summaryJson (reportSummary report),+          "ok" .= reportOk report+        ]+          <> ["members" .= map memberJson (reportMembers report) | reportKind report == WorkspaceReport]+      )++kindText :: CheckReportKind -> Text+kindText SourceReport = "source"+kindText WorkspaceReport = "workspace"++languageJson :: CheckReportLanguage -> Value+languageJson language =+  object+    [ "sourceForm" .= reportSourceForm language,+      "declaredLanguageVersion" .= reportDeclaredLanguageVersion language,+      "effectiveLanguageVersion" .= reportEffectiveLanguageVersion language,+      "runtimeSemantics" .= reportRuntimeSemantics language,+      "languageSupport" .= languageSupportText (reportLanguageSupport language),+      "stable" .= reportStable language+    ]++enforcementJson :: CheckReportEnforcement -> Value+enforcementJson enforcement =+  object+    [ "minLanguage" .= reportMinLanguage enforcement,+      "denyWarnings" .= reportDenyWarnings enforcement,+      "denyCodes" .= map diagnosticCodeText (Set.toAscList (Set.fromList (reportDenyCodes enforcement)))+    ]++entryJson :: CheckReportEntry -> Value+entryJson entry =+  object+    [ "code" .= diagnosticCodeText (entryCode entry),+      "severity" .= severityText (entrySeverity entry),+      "file" .= entryFile entry,+      "line" .= entryLine entry,+      "message" .= entryMessage entry,+      "denied" .= entryDenied entry,+      "related" .= map relatedJson (entryRelated entry)+    ]++relatedJson :: CheckReportRelated -> Value+relatedJson related =+  object+    [ "file" .= relatedFile related,+      "line" .= relatedLine related,+      "note" .= relatedNote related+    ]++summaryJson :: CheckReportSummary -> Value+summaryJson summary =+  object+    [ "errors" .= summaryErrors summary,+      "warnings" .= summaryWarnings summary,+      "deniedWarnings" .= summaryDeniedWarnings summary+    ]++memberJson :: CheckReportMember -> Value+memberJson member =+  object+    [ "path" .= memberPath member,+      "sourceForm" .= memberSourceForm member,+      "declaredLanguageVersion" .= memberDeclaredLanguageVersion member+    ]++severityText :: Severity -> Text+severityText Error = "error"+severityText Warning = "warning"

@@ -18,6 +18,7 @@     conformanceRecordFileName,     planConformancePackage,     parseConformancePackageRecord,+    parseLegacyConformancePackageRecord,     renderConformancePackageRecord,     preflightConformancePackage,     executePreparedConformancePackage,@@ -28,17 +29,22 @@ where  import Control.Monad (forM)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy qualified as BL import Data.Char (isAlphaNum, isAscii, ord) import Data.List (groupBy, sortOn) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import Data.Text.Encoding qualified as Text import Data.Text.IO qualified as TIO import Keiro.Dsl.RuntimePackage (RuntimePackageName (..), isCabalPackageName, mkRuntimePackageName) import Keiro.Dsl.Scaffold (ModuleKind (..), generatedBannerFor, isGeneratedBannerLine) import Keiro.Dsl.SemanticContract (CheckedService (..)) import Keiro.Dsl.ServiceHarness (serviceConformanceFactValues)+import Keiro.Dsl.SidecarNames (conformanceLedgerFileName) import Numeric (showHex) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (isAbsolute, splitDirectories, takeDirectory, (</>))@@ -126,7 +132,7 @@   deriving stock (Eq, Show)  conformanceRecordFileName :: FilePath-conformanceRecordFileName = "keiro-dsl-conformance-record.txt"+conformanceRecordFileName = conformanceLedgerFileName  conformancePackageDirectory :: ConformanceServiceKey -> FilePath conformancePackageDirectory = \case@@ -209,6 +215,7 @@       "  hs-source-dirs: src",       "  main-is: Main.hs",       "  other-modules: KeiroConformance.Expectations",+      "  ghc-options: -Wall",       "  build-depends:",       "      base >=4.18 && <5",       "    , " <> unRuntimePackageName runtimePackage,@@ -312,25 +319,49 @@ renderConformancePackageRecord :: ConformancePackageRecord -> Text renderConformancePackageRecord record =   T.unlines $-    [ "schema " <> tshow (cprSchema record),+    [ conformanceLedgerHeader,       "service-key " <> renderServiceKey (cprServiceKey record),       "runtime-package " <> unRuntimePackageName (cprRuntimePackage record),       "facade-module " <> cprFacadeModule record     ]-      <> ["file " <> kindLabel fileKind <> " " <> T.pack path | (fileKind, path) <- cprFiles record]-  where-    kindLabel Generated = "generated"-    kindLabel HoleStub = "create-once"+      <> ["file " <> encodeConformanceFileRow (ConformanceFileRow fileKind path) | (fileKind, path) <- cprFiles record]  parseConformancePackageRecord :: Text -> Maybe ConformancePackageRecord-parseConformancePackageRecord input = do+parseConformancePackageRecord input = case meaningfulLines input of+  header : rows+    | header == conformanceLedgerHeader -> parseRows rows+  _ -> Nothing+  where+    parseRows rows = do+      serviceKey <- exactlyOne [value | row <- rows, Just raw <- [T.stripPrefix "service-key " row], Just value <- [parseServiceKeyText raw]]+      runtimePackage <- exactlyOne [value | row <- rows, Just raw <- [T.stripPrefix "runtime-package " row], Right value <- [mkRuntimePackageName raw]]+      facadeModule <- exactlyOne [value | row <- rows, Just value <- [T.stripPrefix "facade-module " row], not (T.null value), T.all (not . (`elem` [' ', '\t'])) value]+      fileRows <- traverse decodeConformanceFileRow [row | row <- rows, "file " `T.isPrefixOf` row]+      let files = [(conformanceRowKind row, conformanceRowPath row) | row <- fileRows]+      if safeServiceKey serviceKey && safeConformanceFiles files+        then+          Just+            ConformancePackageRecord+              { cprSchema = 1,+                cprServiceKey = serviceKey,+                cprRuntimePackage = runtimePackage,+                cprFacadeModule = facadeModule,+                cprFiles = files+              }+        else Nothing++-- | Parser for the record format emitted before the ledger rename. It remains+-- exported only so the refuse-then-apply sidecar migration can convert an old+-- record without losing its stale-file history.+parseLegacyConformancePackageRecord :: Text -> Maybe ConformancePackageRecord+parseLegacyConformancePackageRecord input = do   schema <- exactlyOne [value | ["schema", raw] <- rows, Just value <- [readInt raw]]-  serviceKey <- exactlyOne [value | "service-key" : rest <- rows, Just value <- [parseServiceKey rest]]+  serviceKey <- exactlyOne [value | "service-key" : rest <- rows, Just value <- [parseServiceKeyWords rest]]   runtimePackage <- exactlyOne [value | ["runtime-package", raw] <- rows, Right value <- [mkRuntimePackageName raw]]   facadeModule <- exactlyOne [value | ["facade-module", value] <- rows]   files <- traverse parseFile [row | row@(keyword : _) <- rows, keyword == "file"]   let knownRows = 4 + length files-  if schema == 1 && knownRows == length rows && safeServiceKey serviceKey && safeFiles files+  if schema == 1 && knownRows == length rows && safeServiceKey serviceKey && safeConformanceFiles files     then       Just         ConformancePackageRecord@@ -342,19 +373,68 @@           }     else Nothing   where-    rows = [T.words line | line <- T.lines input, let stripped = T.strip line, not (T.null stripped), not (isGeneratedBannerLine stripped)]-    parseServiceKey ["workspace", value] = Just (WorkspaceConformanceService value)-    parseServiceKey ["standalone", value] = Just (StandaloneConformanceService value)-    parseServiceKey _ = Nothing+    rows = map T.words (meaningfulLines input)     parseFile ["file", "generated", path] = Just (Generated, T.unpack path)     parseFile ["file", "create-once", path] = Just (HoleStub, T.unpack path)     parseFile _ = Nothing-    safeFiles files =-      all (safeRelativePath . snd) files-        && length files == Set.size (Set.fromList (map (T.toCaseFold . T.pack . snd) files))     readInt raw = case reads (T.unpack raw) of       [(value, "")] -> Just value       _ -> Nothing++conformanceLedgerHeader :: Text+conformanceLedgerHeader = "keiro-dsl conformance ledger v1"++data ConformanceFileRow = ConformanceFileRow+  { conformanceRowKind :: !ModuleKind,+    conformanceRowPath :: !FilePath+  }++instance ToJSON ConformanceFileRow where+  toJSON row =+    object+      [ "kind" .= case conformanceRowKind row of Generated -> "generated" :: Text; HoleStub -> "create-once",+        "path" .= T.pack (conformanceRowPath row)+      ]++instance FromJSON ConformanceFileRow where+  parseJSON = withObject "ConformanceFileRow" $ \fields -> do+    kindLabel <- fields .: "kind"+    fileKind <- case (kindLabel :: Text) of+      "generated" -> pure Generated+      "create-once" -> pure HoleStub+      other -> fail ("unknown conformance file kind: " <> T.unpack other)+    path <- fields .: "path"+    pure (ConformanceFileRow fileKind (T.unpack (path :: Text)))++encodeConformanceFileRow :: ConformanceFileRow -> Text+encodeConformanceFileRow = Text.decodeUtf8 . BL.toStrict . Aeson.encode++decodeConformanceFileRow :: Text -> Maybe ConformanceFileRow+decodeConformanceFileRow row = do+  payload <- T.stripPrefix "file " row+  Aeson.decodeStrict' (Text.encodeUtf8 payload)++meaningfulLines :: Text -> [Text]+meaningfulLines input =+  [ stripped+  | line <- T.lines input,+    let stripped = T.strip line,+    not (T.null stripped),+    not (isGeneratedBannerLine stripped)+  ]++parseServiceKeyText :: Text -> Maybe ConformanceServiceKey+parseServiceKeyText = parseServiceKeyWords . T.words++parseServiceKeyWords :: [Text] -> Maybe ConformanceServiceKey+parseServiceKeyWords ["workspace", value] = Just (WorkspaceConformanceService value)+parseServiceKeyWords ["standalone", value] = Just (StandaloneConformanceService value)+parseServiceKeyWords _ = Nothing++safeConformanceFiles :: [(ModuleKind, FilePath)] -> Bool+safeConformanceFiles files =+  all (safeRelativePath . snd) files+    && length files == Set.size (Set.fromList (map (T.toCaseFold . T.pack . snd) files))  preflightConformancePackage :: FilePath -> Bool -> ConformancePackagePlan -> IO (Either [ConformancePackageFailure] PreparedConformancePackage) preflightConformancePackage out forceGeneratedOverwrite plan = do

@@ -27,6 +27,7 @@     coverageSucceeded,     renderCoverageSummary,     renderCoverageFinding,+    coverageFindingMessage,     writeCoverageReport,   ) where@@ -275,11 +276,16 @@     <> "["     <> T.pack (show (findingCode finding))     <> "]: "-    <> findingMessage finding-    <> rootsSuffix+    <> coverageFindingMessage finding   where     severityText Error = "error"     severityText Warning = "warning"++-- | The finding's message with its root list appended, shared by the rendered+-- stderr line and the machine check-report entry so both say the same thing.+coverageFindingMessage :: CoverageFinding -> Text+coverageFindingMessage finding = findingMessage finding <> rootsSuffix+  where     rootsSuffix = case findingRoots finding of       [] -> ""       roots -> " (roots: " <> T.intercalate ", " roots <> ")"@@ -612,8 +618,11 @@         "message" .= findingMessage finding       ]     where+      -- One severity vocabulary across every keiro-dsl JSON report. The check+      -- report has always spelled this "warning"; coverage spelled the same+      -- severity "advisory" until ExecPlan 199 unified them.       severityValue Error = "error" :: Text-      severityValue Warning = "advisory"+      severityValue Warning = "warning"  instance ToJSON CoveragePrevious where   toJSON previous =

@@ -62,8 +62,14 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType (typeExprCanonicalName)+import Keiro.Dsl.FieldIdentity+  ( ResolvedFieldIdentity (..),+    resolveAggregateFieldIdentity,+    resolveContractFieldIdentity,+  ) import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar+import Keiro.Dsl.HaskellName qualified as HaskellName import Keiro.Dsl.IdDomain (IdDomainContract (..), contractIdDomainContractFor, idDomainContractFor) import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, languageVersionText, sourceFormText) import Keiro.Dsl.MappedDiff (MappedFinding (..), diffMapped, renderMappedSubject)@@ -267,6 +273,7 @@ classifyCompatibility :: ChangeContext -> DiagnosticCode -> CompatibilityVector classifyCompatibility context code   | code == SourceLanguageDeclarationChanged = sourceProvenanceVector+  | code == GeneratedHaskellNameChanged = sourceProvenanceVector {cvConsumerBuild = VAdvisory}   | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged] = mappedBuildVector   | code == MappedFieldAddedWithDefault = mappedFieldAdditionVector context   | code `elem` [MappedArmAdded, MappedEnumValueAdded] = mappedDirectionalAdditionVector context@@ -320,6 +327,7 @@     privateDecodeCodes =       [ EvtFieldAddedWithoutBump,         EvtFieldRemovedSameVersion,+        EvtFieldWireKeyChanged,         EvtFieldTypeChanged,         EvtVersionDecreased,         EvtVersionMissingUpcaster,@@ -814,7 +822,7 @@ mappedFindingChanges :: MappedFinding -> [Change] mappedFindingChanges finding   | mfCode finding == MappedDeclAdded = [mappedDeclarationChange LabelAdditive finding]-  | mfCode finding `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] =+  | mfCode finding `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged, GeneratedHaskellNameChanged] =       [mappedBuildChange finding]   | mfCode finding `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] =       mappedBuildChange finding : map (mappedUseChange finding) registerPaths@@ -1073,7 +1081,8 @@  aggregatePairDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change] aggregatePairDiff oldSpec newSpec oldAgg newAgg =-  concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg)+  commandFieldIdentityDiff oldAgg newAgg+    ++ concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg)     ++ removedEvents oldAgg newAgg     ++ wireDiff oldAgg newAgg     ++ projectionDiff oldAgg newAgg@@ -1164,45 +1173,49 @@       [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)-                  )-              ]+          selectorChanges 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))]+          selectorChanges 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+          selectorChanges oldE ++ sameVersionEventDiff oldAgg newAgg oldE e+  where+    selectorChanges oldEvent = eventFieldSelectorChanges oldAgg newAgg oldEvent 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@@ -1228,33 +1241,80 @@     (\transition -> tMode transition == TmReplayOnly && eventName `elem` tEmits transition)     (aggTransitions aggregate) -eventFieldSigs :: Aggregate -> Event -> [(Name, Maybe TypeExpr)]+data EventFieldSig = EventFieldSig+  { eventFieldDslName :: !Name,+    eventFieldSelector :: !Name,+    eventFieldWireKey :: !Text,+    eventFieldType :: !(Maybe TypeExpr)+  }+  deriving stock (Eq, Show)++eventFieldSigs :: Aggregate -> Event -> [EventFieldSig] 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)+    fieldSig field =+      let identity = resolveAggregateFieldIdentity field+       in EventFieldSig+            { eventFieldDslName = fieldDslName identity,+              eventFieldSelector = fieldSelector identity,+              eventFieldWireKey = fieldWireKey identity,+              eventFieldType = aggregateFieldType field+            } +eventFieldSelectorChanges :: Aggregate -> Aggregate -> Event -> Event -> [Change]+eventFieldSelectorChanges oldAggregate newAggregate oldEvent newEvent =+  [ fieldSelectorChange+      (aggName newAggregate)+      "event-field-selector"+      (evName newEvent <> "." <> eventFieldDslName newField)+      (eventFieldSelector oldField)+      (eventFieldSelector newField)+      "event field selector"+  | newField <- eventFieldSigs newAggregate newEvent,+    Just oldField <- [find ((== eventFieldDslName newField) . eventFieldDslName) (eventFieldSigs oldAggregate oldEvent)],+    eventFieldSelector oldField /= eventFieldSelector newField+  ]++commandFieldIdentityDiff :: Aggregate -> Aggregate -> [Change]+commandFieldIdentityDiff oldAggregate newAggregate =+  [ fieldSelectorChange+      (aggName newAggregate)+      "command-field-selector"+      (cmdName newCommand <> "." <> aggregateFieldName newField)+      (fieldSelector (resolveAggregateFieldIdentity oldField))+      (fieldSelector (resolveAggregateFieldIdentity newField))+      "command field selector"+  | newCommand <- aggCommands newAggregate,+    Just oldCommand <- [find ((== cmdName newCommand) . cmdName) (aggCommands oldAggregate)],+    newField <- cmdFields newCommand,+    Just oldField <- [find ((== aggregateFieldName newField) . aggregateFieldName) (cmdFields oldCommand)],+    fieldSelector (resolveAggregateFieldIdentity oldField)+      /= fieldSelector (resolveAggregateFieldIdentity newField)+  ]+ sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change] sameVersionEventDiff oldAgg newAgg oldE newE =   addedChanges     ++ removedChanges     ++ typeChanges+    ++ wireKeyChanges     ++ deprecationChanges     ++ retirementChanges   where     oldFields = eventFieldSigs oldAgg oldE     newFields = eventFieldSigs newAgg newE-    oldNames = map fst oldFields-    newNames = map fst newFields+    oldNames = map eventFieldDslName oldFields+    newNames = map eventFieldDslName newFields     added = newNames \\ oldNames     removed = oldNames \\ newNames     changed =-      [ (field, oldType, newType)-      | (field, oldType) <- oldFields,-        Just newType <- [lookup field newFields],-        oldType /= newType+      [ (eventFieldDslName oldField, eventFieldType oldField, eventFieldType newField)+      | oldField <- oldFields,+        Just newField <- [find ((== eventFieldDslName oldField) . eventFieldDslName) newFields],+        eventFieldType oldField /= eventFieldType newField       ]     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")@@ -1273,6 +1333,22 @@           ("type changed " <> renderAggregateFieldType oldType <> " -> " <> renderAggregateFieldType newType <> " at the same version v" <> tInt (evVersion newE))       | (field, oldType, newType) <- changed       ]+    wireKeyChanges =+      [ breaking+          (aggName newAgg)+          "event-field-wire-key"+          (evName newE <> "." <> eventFieldDslName newField)+          EvtFieldWireKeyChanged+          ( "wire key changed '"+              <> eventFieldWireKey oldField+              <> "' -> '"+              <> eventFieldWireKey newField+              <> "'; restore the old key, or version the event and retain an upcaster"+          )+      | newField <- newFields,+        Just oldField <- [find ((== eventFieldDslName newField) . eventFieldDslName) oldFields],+        eventFieldWireKey oldField /= eventFieldWireKey newField+      ]     deprecationChanges       | not (evDeprecated oldE) && evDeprecated newE =           [ if hasReplayOnlyEmitter newAgg (evName newE)@@ -1570,10 +1646,11 @@ 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+    ++ [ aggName agg <> ".event." <> evName event <> "." <> eventFieldDslName field        | agg <- aggregates,          event <- aggEvents agg,-         (field, Just fieldTypeName) <- eventFieldSigs agg event,+         field <- eventFieldSigs agg event,+         Just fieldTypeName <- [eventFieldType field],          fieldTypeName == TRef enumType        ]   where@@ -1676,6 +1753,8 @@   topicAliasChange     ++ removedFieldChanges     ++ changedFieldChanges+    ++ selectorFieldChanges+    ++ wireKeyFieldChanges     ++ addedFieldChanges   where     fieldPairs = pairDeclarations cfName (ceFields oldEvent) (ceFields newEvent)@@ -1702,6 +1781,34 @@       | (oldField, newField) <- prMatched fieldPairs,         cfType oldField /= cfType newField       ]+    selectorFieldChanges =+      [ fieldSelectorChange+          (ctrName newContract)+          "contract-field-selector"+          (ceName newEvent <> "." <> cfName newField)+          (fieldSelector (resolveContractFieldIdentity oldField))+          (fieldSelector (resolveContractFieldIdentity newField))+          "contract field selector"+      | (oldField, newField) <- prMatched fieldPairs,+        fieldSelector (resolveContractFieldIdentity oldField)+          /= fieldSelector (resolveContractFieldIdentity newField)+      ]+    wireKeyFieldChanges =+      [ breaking+          (ctrName newContract)+          "contract-field"+          (ceName newEvent <> "." <> cfName newField)+          ContractFieldChanged+          ( "wire key changed '"+              <> fieldWireKey (resolveContractFieldIdentity oldField)+              <> "' -> '"+              <> fieldWireKey (resolveContractFieldIdentity newField)+              <> "'; restore the old key or revise the public contract with a consumer-first rollout"+          )+      | (oldField, newField) <- prMatched fieldPairs,+        fieldWireKey (resolveContractFieldIdentity oldField)+          /= fieldWireKey (resolveContractFieldIdentity 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")@@ -1721,27 +1828,77 @@     ++ concatMap addedWorkqueueDiff (prAdded paired)     ++ concatMap removedWorkqueueDiff (prRemoved paired)   where-    paired = pairByName nodeWorkqueue wqName env+    paired = pairWorkqueues env +-- | Prefer source identity, then pair a uniquely renamed queue by its complete+-- explicit runtime identity. This permits a generated module-segment rename to+-- remain a build-only finding without guessing when an external identity is+-- ambiguous.+pairWorkqueues :: DiffEnv -> Paired WorkqueueNode+pairWorkqueues env =+  Paired+    { prMatched = exact <> fallback,+      prAdded = [queue | queue <- unmatchedNew, queue `notElem` map snd fallback],+      prRemoved = [queue | queue <- unmatchedOld, queue `notElem` map fst fallback]+    }+  where+    oldQueues = mapMaybe nodeWorkqueue (specNodes (deOld env))+    newQueues = mapMaybe nodeWorkqueue (specNodes (deNew env))+    exact =+      [ (oldQueue, newQueue)+      | newQueue <- newQueues,+        Just oldQueue <- [find ((== wqName newQueue) . wqName) oldQueues]+      ]+    exactOldNames = map (wqName . fst) exact+    exactNewNames = map (wqName . snd) exact+    unmatchedOld = [queue | queue <- oldQueues, wqName queue `notElem` exactOldNames]+    unmatchedNew = [queue | queue <- newQueues, wqName queue `notElem` exactNewNames]+    fallback =+      [ (oldQueue, newQueue)+      | newQueue <- unmatchedNew,+        let matchingOld = [queue | queue <- unmatchedOld, queueIdentity queue == queueIdentity newQueue],+        [oldQueue] <- [matchingOld],+        length [queue | queue <- unmatchedNew, queueIdentity queue == queueIdentity newQueue] == 1+      ]+ workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change] workqueuePairDiff oldQueue newQueue =-  concatMap pairedFieldDiff (prMatched fields)+  generatedNameChanges+    ++ 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.+    generatedNameChanges =+      [ generatedNameChange+          (wqName newQueue)+          "workqueue-module"+          (wqName newQueue)+          (wqName oldQueue)+          (wqName newQueue)+          "workqueue module segment"+      | wqName oldQueue /= wqName newQueue,+        normalizedGeneratedUpper (wqName oldQueue) /= normalizedGeneratedUpper (wqName newQueue)+      ]+        ++ [ generatedNameChange+               (wqName newQueue)+               "workqueue-payload-type"+               (wqPayloadName newQueue)+               (wqPayloadName oldQueue)+               (wqPayloadName newQueue)+               "workqueue payload type"+           | wqPayloadName oldQueue /= wqPayloadName newQueue,+             normalizedGeneratedUpper (wqPayloadName oldQueue) /= normalizedGeneratedUpper (wqPayloadName newQueue)+           ]     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"]+    -- Every payload field is required, so adding one always breaks jobs already+    -- queued under the old shape; there is no optional variant to strengthen.+    addedFieldDiff field = [payloadBreaking field "new required field; queued jobs do not contain it"]     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 @@ -1768,6 +1925,50 @@ queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text) queueIdentity queue = (wqLogical queue, wqPhysical queue, wqDlq queue, wqTable queue) +generatedNameChange :: Name -> Text -> Text -> Text -> Text -> Text -> Change+generatedNameChange node facet subject oldLogical newLogical occurrenceKind =+  advisory+    node+    facet+    subject+    GeneratedHaskellNameChanged+    ( occurrenceKind+        <> " changed '"+        <> normalizedGeneratedUpper oldLogical+        <> "' -> '"+        <> normalizedGeneratedUpper newLogical+        <> "' while wire, SQL, queue, registry, subscription, and persisted runtime identities remain unchanged; re-scaffold and recompile consumers"+    )++fieldSelectorChange :: Name -> Text -> Text -> Text -> Text -> Text -> Change+fieldSelectorChange node facet subject oldSelector newSelector occurrenceKind =+  advisory+    node+    facet+    subject+    GeneratedHaskellNameChanged+    ( occurrenceKind+        <> " changed '"+        <> oldSelector+        <> "' -> '"+        <> newSelector+        <> "' while DSL and wire identities remain unchanged; re-scaffold and recompile consumers"+    )++normalizedGeneratedUpper :: Text -> Text+normalizedGeneratedUpper logicalName =+  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+    Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+    Left _ -> logicalName+  where+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedTypeSite,+          HaskellName.siteLogicalName = logicalName,+          HaskellName.siteOwner = "diff",+          HaskellName.siteLine = 0+        }+ queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change] queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey   where@@ -1847,18 +2048,20 @@       "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"+      "process name, correlation derivation, saga stream category, timer id expression, or fired-event-id expression changed; replays and retries no longer derive the persisted identity"   | processIdentity oldProcess /= processIdentity newProcess   ] -processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Text)+processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Name, Text, Name) processIdentity process =   ( procName process,     corrField (procCorrelate process),     corrVia (procCorrelate process),     sagaCategory (procSaga process),     idePrefix (tmId (procTimer process)),-    idePrefix (fireFiredEventId (tmFire (procTimer process)))+    ideField (tmId (procTimer process)),+    idePrefix (fireFiredEventId (tmFire (procTimer process))),+    ideField (fireFiredEventId (tmFire (procTimer process)))   )  processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change]@@ -2253,7 +2456,7 @@       | 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 `elem` [OwnershipMoved, WorkspaceAuthorityChanged, GeneratedHaskellNameChanged] -> consumerBuildContext root paths       | code == AggFoldSurfaceChanged -> snapshotContext root paths       | code == EnumCtorAdded -> ChangeContext root paths ContextGeneral label       | code `elem` privateCodes -> privateEventContext root paths@@ -2287,6 +2490,7 @@     privateCodes =       [ EvtFieldAddedWithoutBump,         EvtFieldRemovedSameVersion,+        EvtFieldWireKeyChanged,         EvtFieldTypeChanged,         EvtVersionDecreased,         EvtVersionMissingUpcaster,

@@ -46,6 +46,7 @@   | RemedyReplayOnlyEdge   | RemedyStateCodecBump   | RemedyRecompileConsumers+  | RemedyRescaffoldGenerated   | RemedyRescaffoldWorkspace   | RemedyRunConformance   | RemedyNoSemanticAction@@ -182,6 +183,7 @@ remediationFor :: ChangeContext -> DiagnosticCode -> NonEmpty Remedy remediationFor context code   | code == SourceLanguageDeclarationChanged = RemedyNoSemanticAction :| []+  | code == GeneratedHaskellNameChanged = RemedyRescaffoldGenerated :| [RemedyRecompileConsumers, RemedyRunConformance]   | code == OwnershipMoved = RemedyRescaffoldWorkspace :| []   | code == WorkspaceAuthorityChanged = RemedyRescaffoldWorkspace :| [RemedyRecompileConsumers]   | code == AggGuardTightened = RemedyReplayOnlyEdge :| [RemedyRunConformance]@@ -266,6 +268,7 @@     eventDecodeCodes =       [ EvtFieldAddedWithoutBump,         EvtFieldRemovedSameVersion,+        EvtFieldWireKeyChanged,         EvtFieldTypeChanged,         EvtVersionDecreased,         EvtVersionMissingUpcaster,@@ -310,6 +313,7 @@   RemedyReplayOnlyEdge -> "add the computed replay-only edge described by docs/adr/0002-replay-only-edges-are-the-sanctioned-remedy-for-guard-tightening.md"   RemedyStateCodecBump -> "invalidate and rebuild snapshots by bumping state-codec version when automatic fingerprinting cannot see the change"   RemedyRecompileConsumers -> "recompile every affected consumer against the generated interface"+  RemedyRescaffoldGenerated -> "re-run the scaffold so generated modules and create-once imports use the candidate Haskell names"   RemedyRescaffoldWorkspace -> "re-run the whole-workspace scaffold so the record's ownership and golden roots follow the change"   RemedyRunConformance -> "run the generated conformance and historical fixture suites"   RemedyNoSemanticAction -> "no semantic action is required; only source-language provenance changed"

@@ -18,13 +18,13 @@  import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) import Data.Bifunctor (first)-import Data.Char (toUpper) import Data.List (groupBy, sortOn) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar+import Keiro.Dsl.HaskellName qualified as HaskellName import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainVersion) import Keiro.Dsl.LanguageVersion (SourceLanguage (..)) import Keiro.Dsl.NominalType@@ -380,10 +380,17 @@   CollocatedLeaf -> root <> contextName <> ".Nominal.Shape." <> name <> ".Generated"   where     root = maybe "" (<> ".") (specModuleRoot spec)-    contextName = T.concat (map titleSegment (T.splitOn "-" (specContext spec)))-    titleSegment value = case T.uncons value of-      Nothing -> ""-      Just (initialChar, rest) -> T.cons (toUpper initialChar) rest+    contextName =+      case HaskellName.deriveHaskellName HaskellName.LogicalWireWord site of+        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+        Left _ -> specContext spec+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.ContextModuleSite,+          HaskellName.siteLogicalName = specContext spec,+          HaskellName.siteOwner = "binding-obligation-context",+          HaskellName.siteLine = 0+        }  renderBindingObligations :: Text -> [BindingObligation] -> Text renderBindingObligations context obligations = case obligations of

@@ -0,0 +1,41 @@+-- | Resolved field identities shared by validation and generation.+--+-- A direct aggregate or contract field has three independent namespaces: its+-- logical DSL identity, its generated Haskell selector, and its serialized wire+-- key. Resolution is total; validation of spelling and collisions belongs to+-- "Keiro.Dsl.Validate".+module Keiro.Dsl.FieldIdentity+  ( ResolvedFieldIdentity (..),+    resolveAggregateFieldIdentity,+    resolveContractFieldIdentity,+  )+where++import Data.Text (Text)+import Keiro.Dsl.Grammar++data ResolvedFieldIdentity = ResolvedFieldIdentity+  { fieldDslName :: !Name,+    fieldSelector :: !Text,+    fieldWireKey :: !Text,+    fieldLoc :: !Loc+  }+  deriving stock (Eq, Show)++resolveAggregateFieldIdentity :: AggregateField -> ResolvedFieldIdentity+resolveAggregateFieldIdentity field =+  ResolvedFieldIdentity+    { fieldDslName = aggregateFieldName field,+      fieldSelector = maybe (aggregateFieldName field) id (aggregateFieldSelector field),+      fieldWireKey = maybe (aggregateFieldName field) id (aggregateFieldWireKey field),+      fieldLoc = aggregateFieldLoc field+    }++resolveContractFieldIdentity :: ContractField -> ResolvedFieldIdentity+resolveContractFieldIdentity field =+  ResolvedFieldIdentity+    { fieldDslName = cfName field,+      fieldSelector = maybe (cfName field) id (cfSelector field),+      fieldWireKey = maybe (cfName field) id (cfWireKey field),+      fieldLoc = cfLoc field+    }

@@ -27,6 +27,7 @@ import Data.Text.IO qualified as TIO import Data.Text.Lazy qualified as TL import Keiro.Dsl.AggregateType+import Keiro.Dsl.FieldIdentity (fieldWireKey) import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType import Keiro.Dsl.Scaffold (Agg (..), ResolvedCtor (..), defaultContext, resolveAgg)@@ -150,7 +151,7 @@     graph = either (const Nothing) Just (resolveTypeGraph spec)     entries =       (Key.fromText "kind", String (rcName event))-        : [(Key.fromText fieldName, sampleValue graph spec aggregate fieldType) | (fieldName, fieldType) <- rcFields event]+        : [(Key.fromText (fieldWireKey identity), sampleValue graph spec aggregate fieldType) | (identity, fieldType) <- rcFields event]  sampleValue :: Maybe TypeGraph -> Spec -> Agg -> ResolvedAggregateType -> Value sampleValue graph spec _aggregate resolvedType =

@@ -458,11 +458,16 @@   }   deriving stock (Eq, Show, Generic) --- | An aggregate command/event field. A bare name reuses the field's inferred--- aggregate type; @name:Type@ accepts the complete 'TypeExpr' grammar so semantic--- validation can reject unsupported direct shapes with a located diagnostic.+-- | An aggregate command/event field. The logical DSL name remains the identity+-- used by expressions and evolution pairing. Optional aliases independently+-- select the generated Haskell record selector and serialized wire key.+-- A bare name reuses the field's inferred aggregate type; @name:Type@ accepts+-- the complete 'TypeExpr' grammar so semantic validation can reject unsupported+-- direct shapes with a located diagnostic. data AggregateField = AggregateField   { aggregateFieldName :: !Name,+    aggregateFieldSelector :: !(Maybe Name),+    aggregateFieldWireKey :: !(Maybe Text),     aggregateFieldType :: !(Maybe TypeExpr),     aggregateFieldLoc :: !Loc   }@@ -688,7 +693,8 @@ -- | A deterministic id derivation: @uuidv5 \"prefix:\" <> correlationId@. data IdExpr = IdExpr   { ideStrategy :: !IdStrategy,-    idePrefix :: !Text+    idePrefix :: !Text,+    ideField :: !Name   }   deriving stock (Eq, Show, Generic) @@ -813,7 +819,10 @@  data ContractField = ContractField   { cfName :: !Name,-    cfType :: !ContractType+    cfSelector :: !(Maybe Name),+    cfWireKey :: !(Maybe Text),+    cfType :: !ContractType,+    cfLoc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -967,8 +976,7 @@ data WqField = WqField   { wqfName :: !Name,     wqfWire :: !Text,-    wqfType :: !Name,-    wqfRequired :: !Bool+    wqfType :: !Name   }   deriving stock (Eq, Show, Generic) 

@@ -42,14 +42,15 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import Keiro.Dsl.AggregateGenerationPlan import Keiro.Dsl.AggregateType+import Keiro.Dsl.FieldIdentity import Keiro.Dsl.GeneratedHaskellLanguage import Keiro.Dsl.Goldens (GoldenPayload (..)) import Keiro.Dsl.Grammar import Keiro.Dsl.HaskellImport import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainSampleText) import Keiro.Dsl.NominalType-import Keiro.Dsl.ReadModelShape (deriveShapeHash, registryNameFor, subscriptionNameFor) import Keiro.Dsl.Scaffold import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService) import Keiro.Dsl.TypeGraph@@ -179,44 +180,57 @@  emitReadModelHarness :: Text -> Context -> ReadModelNode -> Text emitReadModelHarness genPrefix ctx readModel =-  nl-    [ generatedBanner,-      "module " <> genPrefix <> ".ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where",-      "",-      "-- | (fact, expected from notation, actual shared derivation/lowering).",-      "readModelFacts :: [(String, String, String)]",-      "readModelFacts =",-      "  [ (\"registryName\", " <> tshow expectedRegistry <> ", " <> tshow actualRegistry <> ")",-      "  , (\"subscriptionName\", " <> tshow expectedSubscription <> ", " <> tshow actualSubscription <> ")",-      "  , (\"shapeHash\", " <> tshow (rmShape readModel) <> ", " <> tshow (deriveShapeHash readModel) <> ")",-      "  , (\"asyncProjectionName\", " <> tshow expectedAsync <> ", " <> tshow actualAsync <> ")",-      "  , (\"consistency\", " <> tshow consistency <> ", " <> tshow consistency <> ")",-      "  , (\"strongScope\", " <> tshow scope <> ", " <> tshow scope <> ")",-      "  ]",-      "",-      "readModelFactResults :: [(String, Bool)]",-      "readModelFactResults =",-      "  [(fact, expected == actual) | (fact, expected, actual) <- readModelFacts]",-      "",-      "runReadModelFacts :: IO Bool",-      "runReadModelFacts = do",-      "  let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]",-      "  mapM_ (\\(fact, expected, actual) -> putStrLn (\"FAIL  \" <> fact <> \" expected=\" <> show expected <> \" actual=\" <> show actual)) failures",-      "  pure (null failures)"-    ]+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot]+      <> [ generatedBanner,+           "module " <> genPrefix <> ".ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where",+           "",+           "import " <> genPrefix <> ".ReadModel (" <> T.intercalate ", " readModelImports <> ")",+           "import Data.Text qualified as T",+           "import Keiro.ReadModel (ReadModel (..), StrongScope (..))"+         ]+      <> ["import Keiro.Projection (AsyncProjection (..))" | rmFeed readModel == RmSubscription]+      <> [ "",+           "-- | (fact, expected from notation, actual generated runtime value).",+           "readModelFacts :: [(String, String, String)]",+           "readModelFacts =",+           "  [ (\"registryName\", " <> tshow expectedRegistry <> ", T.unpack " <> readModelName <> ".name)",+           "  , (\"subscriptionName\", " <> tshow expectedSubscription <> ", T.unpack " <> readModelName <> ".subscriptionName)",+           "  , (\"shapeHash\", " <> tshow (rmShape readModel) <> ", T.unpack " <> readModelName <> ".shapeHash)",+           asyncFactRow,+           "  , (\"consistency\", " <> tshow consistency <> ", show " <> readModelName <> ".defaultConsistency)",+           "  , (\"strongScope\", " <> tshow scope <> ", renderStrongScope " <> readModelName <> ".strongScope)",+           "  ]",+           "",+           "renderStrongScope :: StrongScope -> String",+           "renderStrongScope EntireLog = \"EntireLog\"",+           "renderStrongScope (CategoryHead categoryName) = \"CategoryHead \" <> T.unpack categoryName",+           "",+           "readModelFactResults :: [(String, Bool)]",+           "readModelFactResults =",+           "  [(fact, expected == actual) | (fact, expected, actual) <- readModelFacts]",+           "",+           "runReadModelFacts :: IO Bool",+           "runReadModelFacts = do",+           "  let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]",+           "  mapM_ (\\(fact, expected, actual) -> putStrLn (\"FAIL  \" <> fact <> \" expected=\" <> show expected <> \" actual=\" <> show actual)) failures",+           "  pure (null failures)"+         ]   where+    stem = lowerFirst (pascal (rmName readModel))+    readModelName = stem <> "ReadModel"+    asyncProjectionName = stem <> "AsyncProjection"+    readModelImports = readModelName : [asyncProjectionName | rmFeed readModel == RmSubscription]     expectedRegistry = contextName ctx <> "-" <> T.replace "_" "-" (rmName readModel)-    actualRegistry = registryNameFor (contextName ctx) readModel     expectedSubscription = case rmSubscription readModel of       Just name -> name       Nothing -> expectedRegistry <> "-sub"-    actualSubscription = subscriptionNameFor (contextName ctx) readModel     expectedAsync = case rmFeed readModel of       RmInline -> "none"       RmSubscription -> expectedRegistry <> "-async"-    actualAsync = case rmFeed readModel of-      RmInline -> "none"-      RmSubscription -> actualRegistry <> "-async"+    asyncFactRow = case rmFeed readModel of+      RmInline -> "  , (\"asyncProjectionName\", \"none\", \"none\") -- Definitionally inert: inline feeds have no AsyncProjection value."+      RmSubscription -> "  , (\"asyncProjectionName\", " <> tshow expectedAsync <> ", T.unpack " <> asyncProjectionName <> ".name)"     consistency = case rmConsistency readModel of       Strong -> "Strong"       Eventual -> "Eventual"@@ -463,14 +477,14 @@            "-- entry False; the scaffold cannot.",            "harnessAssertions :: [(String, Bool)]",            "harnessAssertions =",-           "  [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))",-           "  , (\"clock-free: spec samples no wall clock\", " <> clockFreeLit <> ")"+           "  [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))"          ]+      ++ clockFreeRows       ++ [ "  , (\"golden round-trip: " <> rcName e <> "\", roundTrips sampleEvent" <> rcName e <> ")"          | e <- aEvents a          ]       ++ [ "  , (\"accepts " <> tCommand t <> " from " <> initialVertex a <> "\", accept" <> tCommand t <> ")"-         | t <- initialTransitions a+         | t <- map layoutTransition (initialLiveTransitionEntries a)          ]       ++ [ "  ]"          ]@@ -490,21 +504,24 @@            "roundTrips :: " <> nm <> "Event -> Bool",            "roundTrips e = parse" <> nm <> "Event (eventType " <> lowerFirst nm <> "Codec e) (encode" <> nm <> "Event e) == Right e"          ]+      ++ harnessSampleDeclarations a       ++ concatMap (sampleEventDecl a) (aEvents a)-      ++ concatMap (acceptDecl a) (initialTransitions a)+      ++ concatMap (acceptDecl a . layoutTransition) (initialLiveTransitionEntries a)       ++ concatMap (forwardReplayDecl a) replayTransitions       ++ concatMap (upcastDecl goldens a) upcastEvents       ++ mappedHarnessDeclarations a       ++ nominalHarnessDeclarations a   where     nm = aName a-    -- Bake the clock-free result computed from the spec at scaffold time.-    clockFreeLit = if specIsClockFree a then "True" else "False"+    clockFreeRows =+      if specIsClockFree a+        then ["  -- clock-free: spec samples no wall clock (verified at scaffold time)"]+        else ["  , (\"clock-free: spec samples no wall clock\", False)"]     upcastEvents = [e | e <- aEvents a, rcUpcastFrom e /= Nothing]     replayTransitions =       [ t-      | t <- initialTransitions a,-        tMode t == TmLive,+      | entry <- initialLiveTransitionEntries a,+        let t = layoutTransition entry,         not (null (tEmits t))       ]     coreImports =@@ -637,9 +654,13 @@ exprNames (EAtom (AName n)) = [n] exprNames (EAtom (ABool _)) = [] -initialTransitions :: Agg -> [Transition]-initialTransitions a = case map stName (aStates a) of-  (s0 : _) -> [t | t <- aTransitions a, tSource t == s0]+initialLiveTransitionEntries :: Agg -> [TransitionLayoutEntry]+initialLiveTransitionEntries a = case map stName (aStates a) of+  (s0 : _) ->+    [ entry+    | entry <- transitionLayoutForSource s0 (transitionLayout (aTransitions a)),+      tMode (layoutTransition entry) == TmLive+    ]   [] -> []  -- | @sampleEvent<Ctor> :: <Agg>Event@ — a sample built from per-field sample@@ -652,6 +673,38 @@     "sampleEvent" <> rcName e <> " = " <> ctorExpr a e   ] +harnessSampleDeclarations :: Agg -> [Text]+harnessSampleDeclarations aggregate =+  concatMap generatedIdDeclaration generatedIds <> timeDeclaration+  where+    generatedIds =+      [ nominal+      | nominal <- generatedNominalHarnessTypes aggregate,+        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+        idDomainContractFor (aLanguageContract aggregate) prefix /= Nothing+      ]+    generatedIdDeclaration nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> case idDomainContractFor (aLanguageContract aggregate) prefix of+        Just contract ->+          let typeName = resolvedNominalName nominal+              constantName = generatedIdSampleName nominal+           in [ "",+                constantName <> " :: " <> typeName,+                constantName <> " =",+                "  case parse" <> typeName <> " " <> tshow (idDomainSampleText contract) <> " of",+                "    Right parsed -> parsed",+                "    Left problem -> error (show problem)"+              ]+        Nothing -> []+      _ -> []+    timeDeclaration+      | harnessUsesTime aggregate =+          [ "",+            harnessTimeSampleName aggregate <> " :: UTCTime",+            harnessTimeSampleName aggregate <> " = UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)"+          ]+      | otherwise = []+ acceptDecl :: Agg -> Transition -> [Text] acceptDecl a t =   [ "",@@ -707,9 +760,9 @@ -- | @(<Ctor> (<Ctor>Data v1 v2 …))@ with positional sample field values. ctorExpr :: Agg -> ResolvedCtor -> Text ctorExpr a rc =-  "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))"+  rcName rc <> " (" <> rcName rc <> "Data" <> args <> ")"   where-    args = T.concat [" " <> sampleValue a fieldName ty | (fieldName, ty) <- rcFields rc]+    args = T.concat [" " <> sampleValue a (fieldDslName identity) ty | (identity, ty) <- rcFields rc]  -- | A transition command sample prefers the initial value of a same-named, -- same-typed register only when the guard explicitly equates those two paths.@@ -717,9 +770,9 @@ -- not accidentally inherit a forbidden @Free@ register initial value. commandCtorExpr :: Agg -> Transition -> ResolvedCtor -> Text commandCtorExpr a transition rc =-  "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))"+  rcName rc <> " (" <> rcName rc <> "Data" <> args <> ")"   where-    args = T.concat [" " <> commandSampleValue a transition fieldName ty | (fieldName, ty) <- rcFields rc]+    args = T.concat [" " <> commandSampleValue a transition (fieldDslName identity) ty | (identity, ty) <- rcFields rc]  commandSampleValue :: Agg -> Transition -> Text -> ResolvedAggregateType -> Text commandSampleValue aggregate transition fieldName fieldType = case fieldType of@@ -737,7 +790,10 @@       _ -> case rrType register of         AggregateNominal nominal -> case resolvedNominalOwnership nominal of           ConsumerNominal {} -> renderRegisterInitial (rrInitial register)-          GeneratedNominal -> fromMaybe (renderRegisterInitial (rrInitial register)) (generatedIdSampleHaskell owner nominal)+          GeneratedNominal ->+            fromMaybe+              (renderRegisterInitial (rrInitial register))+              (generatedIdSampleName nominal <$ generatedIdSampleHaskell owner nominal)         _ -> renderRegisterInitial (rrInitial register)  guardEquatesCommandAndRegister :: Transition -> Text -> Bool@@ -756,13 +812,14 @@ sampleValue a fieldName ty = case ty of   AggregateNominal nominal     | GeneratedNominal <- resolvedNominalOwnership nominal,-      Just sample <- generatedIdSampleHaskell a nominal ->-        sample+      Just _ <- generatedIdSampleHaskell a nominal ->+        generatedIdSampleName nominal   AggregateNominal nominal     | ConsumerNominal binding <- resolvedNominalOwnership nominal ->         "(nominalFixtureDomain (NonEmpty.head (nominalFixtureCases "           <> renderHarnessReference a (harnessQualifiedValueReference (consumerNominalFixtures binding))           <> ")))"+  AggregateTime -> harnessTimeSampleName a   _ -> fallback   where     fallback = case fieldCat a ty of@@ -775,14 +832,27 @@           | vertexType == aVertexType a -> initialVertex a         _ -> aggregateSampleHaskell (aSymbols a) fieldName ty +generatedIdSampleName :: ResolvedNominalType -> Text+generatedIdSampleName nominal = "sample" <> resolvedNominalName nominal++harnessUsesTime :: Agg -> Bool+harnessUsesTime aggregate =+  any ((== AggregateTime) . snd) (concatMap rcFields (aCommands aggregate <> aEvents aggregate))++harnessTimeSampleName :: Agg -> Text+harnessTimeSampleName aggregate+  | any isObservedAtTime (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) = "sampleObservedAt"+  | otherwise = "sampleTime"+  where+    isObservedAtTime (identity, resolvedType) = fieldDslName identity == "observedAt" && resolvedType == AggregateTime+ aggregateHarnessImports :: Agg -> [Text]-aggregateHarnessImports aggregate =-  unique-    [ "import " <> imported-    | resolvedType <- map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)),-      AggregateTime <- [resolvedType],-      imported <- Set.toAscList (aggregateSourceStaticImports (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType))-    ]+aggregateHarnessImports aggregate+  | harnessUsesTime aggregate =+      [ "import Data.Time.Calendar (fromGregorian)",+        "import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)"+      ]+  | otherwise = []  nominalHarnessImports :: Agg -> [Text] nominalHarnessImports aggregate@@ -927,23 +997,36 @@  mappedHarnessImports :: Agg -> [Text] mappedHarnessImports aggregate-  | null fixtures = []+  | null declarations = []   | otherwise =-      [ "import Data.Aeson qualified as Aeson",-        "import Data.Aeson.Key qualified as AesonKey",-        "import Data.Aeson.KeyMap qualified as AesonKeyMap",-        "import Data.Either (isLeft, isRight)",-        "import Data.List (nub)",-        "import Data.List.NonEmpty qualified as NonEmpty",-        "import Data.Maybe (isJust, isNothing)",-        "import Data.Proxy (Proxy (..))",-        "import Data.Text qualified as T",-        "import Keiki.Shape (CanonicalTypeName (..))",-        "import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)"-      ]+      ["import Data.Aeson qualified as Aeson" | not (null opaque) || not (null structuralWire)]+        ++ (if null structuralWire then [] else ["import Data.Aeson.Key qualified as AesonKey", "import Data.Aeson.KeyMap qualified as AesonKeyMap"])+        ++ [renderImport "Data.Either" eitherImports | not (null eitherImports)]+        ++ ["import Data.List (nub)", "import Data.List.NonEmpty qualified as NonEmpty"]+        ++ [renderImport "Data.Maybe" ["isJust", "isNothing"] | any shapeUsesMaybe structural]+        ++ ["import Data.Proxy (Proxy (..))" | not (null structural)]+        ++ ["import Data.Text qualified as T"]+        ++ ["import Keiki.Shape (CanonicalTypeName (..))" | not (null structural)]+        ++ [renderImport "Keiro.Codec.Structural" structuralCodecImports]         ++ ["import " <> structuralProjectionModuleName (aContext aggregate) <> " qualified as StructuralProjections" | not (null (mappedProjectionSpecs aggregate))]   where-    fixtures = [mappedFixtures declaration | declaration <- mappedHarnessDeclarationsResolved aggregate]+    declarations = mappedHarnessDeclarationsResolved aggregate+    structural = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]+    opaque = [declaration | ResolvedOpaque declaration <- declarations]+    structuralWire = [(declaration, shape) | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate]+    eitherImports =+      ["isLeft" | wirePoliciesUseIsLeft structuralWire]+        <> ["isRight" | wirePoliciesUseIsRight structuralWire]+    structuralCodecImports =+      ["FixtureCases (..)"]+        <> if null structural then [] else ["bindingDomainRoundTrip", "bindingShapeRoundTrip", "bindingToShape"]+    renderImport moduleName names = "import " <> moduleName <> " (" <> T.intercalate ", " names <> ")"+    shapeUsesMaybe (_, shape) = case shape of+      RRecord _ _ fields -> any (isOptional . rwfType) fields+      RUnion _ arms -> any (maybe False isOptional . rwaPayload) arms+      REnum {} -> False+    isOptional ROptional {} = True+    isOptional _ = False  mappedCodecHarnessExports :: Agg -> Text mappedCodecHarnessExports aggregate =@@ -981,27 +1064,18 @@         references     )   where-    resolvedTypes =-      map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate))-        <> map rrType (aRegs aggregate)-    aggregateReferences =-      Set.unions-        [ aggregateSourceReferences (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType)-        | resolvedType <- resolvedTypes-        ]     consumerNominalReferences =       Set.fromList         [ reference         | nominal <- consumerNominalHarnessTypes aggregate,           ConsumerNominal binding <- [resolvedNominalOwnership nominal],           reference <--            harnessTypeReference (consumerNominalHaskell binding)-              : map-                harnessQualifiedValueReference-                ( consumerNominalBinding binding-                    : consumerNominalFixtures binding-                    : maybeToListHarness (consumerNominalInitial binding)-                )+            map+              harnessQualifiedValueReference+              ( consumerNominalBinding binding+                  : consumerNominalFixtures binding+                  : maybeToListHarness (consumerNominalInitial binding)+              )         ]     mappedReferences =       Set.fromList@@ -1014,10 +1088,9 @@                   harnessQualifiedValueReference                   (sdBinding structural : sdFixtures structural : maybeToListHarness (sdInitial structural))             ResolvedOpaque opaque ->-              harnessTypeReference (odHaskell opaque)-                : map-                  harnessQualifiedValueReference-                  (odFixtures opaque : maybeToListHarness (odInitial opaque))+              map+                harnessQualifiedValueReference+                (odFixtures opaque : maybeToListHarness (odInitial opaque))         ]     shapeReferences =       Set.fromList@@ -1031,7 +1104,7 @@         | projection <- mappedProjectionSpecs aggregate,           (shapeModule, selector) <- spSelectors projection         ]-    references = aggregateReferences <> consumerNominalReferences <> mappedReferences <> shapeReferences <> projectionReferences+    references = consumerNominalReferences <> mappedReferences <> shapeReferences <> projectionReferences  harnessTypeReference :: HaskellSource -> HaskellReference harnessTypeReference source =@@ -1139,9 +1212,9 @@     opaque = [declaration | ResolvedOpaque declaration <- declarations]     structuralWire = [(declaration, shape) | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate]     mappedEventFields =-      [ (event, fieldName, fieldType, declaration)+      [ (event, fieldDslName identity, fieldType, declaration)       | event <- aEvents aggregate,-        (fieldName, fieldType) <- rcFields event,+        (identity, fieldType) <- rcFields event,         declaration <- maybeToListHarness (mappedDeclaration aggregate fieldType)       ]     assertionLists =@@ -1293,6 +1366,26 @@     map (unionArmAssertion aggregate declaration encoding) arms       <> [unknownFieldAssertion aggregate declaration (ueUnknownFields encoding)] +wirePoliciesUseIsLeft :: [(StructuralDecl, ResolvedMappedShape)] -> Bool+wirePoliciesUseIsLeft = any $ \(_, shape) -> case shape of+  RRecord _ unknownFields fields ->+    unknownFields == RejectUnknown+      || any (\field -> rwfPresence field == POptional && not (isOptionalType (rwfType field))) fields+  REnum {} -> True+  RUnion encoding _ -> ueUnknownFields encoding == RejectUnknown++wirePoliciesUseIsRight :: [(StructuralDecl, ResolvedMappedShape)] -> Bool+wirePoliciesUseIsRight = any $ \(_, shape) -> case shape of+  RRecord _ unknownFields fields ->+    unknownFields == IgnoreUnknown+      || any (\field -> rwfPresence field == POptional && isOptionalType (rwfType field)) fields+  REnum {} -> False+  RUnion encoding _ -> ueUnknownFields encoding == IgnoreUnknown++isOptionalType :: ResolvedTypeExpr -> Bool+isOptionalType ROptional {} = True+isOptionalType _ = False+ recordMissingAssertions :: Agg -> StructuralDecl -> ResolvedWireField -> [Text] recordMissingAssertions aggregate declaration field =   [ "(\"wire policy missing default: "@@ -1419,20 +1512,37 @@  wirePolicyHelpers :: [(StructuralDecl, ResolvedMappedShape)] -> [Text] wirePolicyHelpers [] = []-wirePolicyHelpers _ =-  [ "",-    "deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value",-    "deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue)",-    "deleteObjectField _ value = value",-    "",-    "insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value",-    "insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue)",-    "insertObjectField _ _ value = value",-    "",-    "objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value",-    "objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue",-    "objectField _ _ = Nothing"-  ]+wirePolicyHelpers declarations =+  ( if usesDelete+      then+        [ "",+          "deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value",+          "deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue)",+          "deleteObjectField _ value = value"+        ]+      else []+  )+    <> [ "",+         "insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value",+         "insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue)",+         "insertObjectField _ _ value = value"+       ]+    <> ( if usesObjectField+           then+             [ "",+               "objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value",+               "objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue",+               "objectField _ _ = Nothing"+             ]+           else []+       )+  where+    usesDelete = any hasOptionalRecordField declarations+    usesObjectField = usesDelete || any isUnion declarations+    hasOptionalRecordField (_, RRecord _ _ fields) = any ((== POptional) . rwfPresence) fields+    hasOptionalRecordField _ = False+    isUnion (_, RUnion {}) = True+    isUnion _ = False  mappedFixtures :: ResolvedMappedDecl -> QualifiedValueName mappedFixtures (ResolvedStructural declaration _) = sdFixtures declaration@@ -1444,8 +1554,8 @@   where     arguments =       T.concat-        [ " " <> if fieldName == target then replacement else sampleValue aggregate fieldName fieldType-        | (fieldName, fieldType) <- rcFields constructor+        [ " " <> if fieldDslName identity == target then replacement else sampleValue aggregate (fieldDslName identity) fieldType+        | (identity, fieldType) <- rcFields constructor         ]  projectionAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text]

@@ -24,6 +24,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import Keiro.Dsl.HaskellName (haskellKeywords)  data HaskellNamespace   = TypeNamespace@@ -231,42 +232,3 @@  asciiDigit :: Char -> Bool asciiDigit character = character >= '0' && character <= '9'--haskellKeywords :: Set Text-haskellKeywords =-  Set.fromList-    [ "as",-      "case",-      "class",-      "data",-      "default",-      "deriving",-      "do",-      "else",-      "family",-      "foreign",-      "forall",-      "if",-      "import",-      "in",-      "infix",-      "infixl",-      "infixr",-      "instance",-      "let",-      "mdo",-      "module",-      "newtype",-      "of",-      "proc",-      "qualified",-      "rec",-      "safe",-      "signature",-      "stock",-      "then",-      "type",-      "unsafe",-      "via",-      "where"-    ]

@@ -0,0 +1,351 @@+-- | Checked names for every Haskell declaration generated by keiro-dsl.+--+-- Logical DSL names and external spellings remain ordinary 'Text'.  A value+-- crosses into generated Haskell only through the total constructors in this+-- module, which share one ASCII word-segmentation policy and one keyword set.+module Keiro.Dsl.HaskellName+  ( UpperCamelName,+    LowerCamelName,+    HaskellModuleSegment,+    HaskellModuleName,+    DerivedHaskellName (..),+    NameSourceKind (..),+    NameSiteKind (..),+    HaskellOccurrenceSpace (..),+    NameSite (..),+    HaskellOccurrenceKey (..),+    PlannedOccurrence (..),+    HaskellNameError (..),+    GeneratedHaskellNamingEdition (..),+    currentGeneratedHaskellNamingEdition,+    renderGeneratedHaskellNamingEdition,+    parseGeneratedHaskellNamingEdition,+    deriveHaskellName,+    checkedModuleSegment,+    checkedModuleName,+    checkedUpperOccurrence,+    checkedLowerOccurrence,+    plannedOccurrence,+    detectNameCollisions,+    renderUpperCamelName,+    renderLowerCamelName,+    renderModuleSegment,+    renderModuleName,+    haskellKeywords,+  )+where++import Data.Char (toLower, toUpper)+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Maybe (listToMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T++newtype UpperCamelName = UpperCamelName Text+  deriving stock (Eq, Ord, Show)++newtype LowerCamelName = LowerCamelName Text+  deriving stock (Eq, Ord, Show)++newtype HaskellModuleSegment = HaskellModuleSegment Text+  deriving stock (Eq, Ord, Show)++newtype HaskellModuleName = HaskellModuleName Text+  deriving stock (Eq, Ord, Show)++data DerivedHaskellName = DerivedHaskellName+  { upperCamel :: !UpperCamelName,+    lowerCamel :: !LowerCamelName+  }+  deriving stock (Eq, Show)++data NameSourceKind+  = LogicalIdentifier+  | LogicalWireWord+  | ExplicitHaskellName+  deriving stock (Eq, Ord, Show)++-- | Stable declaration categories used in diagnostics and source-move roles.+data NameSiteKind+  = ContextModuleSite+  | NodeModuleSite+  | GeneratedTypeSite+  | GeneratedConstructorSite+  | GeneratedValueSite+  | GeneratedFieldSite+  | GeneratedHelperSite+  | ImportAliasSite+  deriving stock (Eq, Ord, Enum, Bounded, Show)++data HaskellOccurrenceSpace+  = ModuleSpace+  | TypeSpace+  | ConstructorSpace+  | ValueSpace+  | FieldSpace+  deriving stock (Eq, Ord, Enum, Bounded, Show)++-- | The source declaration responsible for a generated occurrence.  The+-- owner and kind form a stable identity; the line is evidence, not identity.+data NameSite = NameSite+  { siteKind :: !NameSiteKind,+    siteLogicalName :: !Text,+    siteOwner :: !Text,+    siteLine :: !Int+  }+  deriving stock (Eq, Ord, Show)++-- | A collision key.  Module names are compared case-insensitively because+-- generated trees must remain safe on case-insensitive filesystems.  Scope is+-- normally empty; record fields use their owning record so+-- DuplicateRecordFields can keep identical selectors on different records.+data HaskellOccurrenceKey = HaskellOccurrenceKey+  { occurrenceModule :: !Text,+    occurrenceSpace :: !HaskellOccurrenceSpace,+    occurrenceScope :: !Text,+    occurrenceName :: !Text+  }+  deriving stock (Eq, Ord, Show)++data PlannedOccurrence = PlannedOccurrence+  { plannedOccurrenceKey :: !HaskellOccurrenceKey,+    plannedOccurrenceSite :: !NameSite+  }+  deriving stock (Eq, Ord, Show)++data HaskellNameError+  = EmptyNameSegment !NameSite+  | UnsafeNameSeparator !NameSite !Text+  | ReservedGeneratedOccurrence !NameSite !Text+  | NormalizedNameCollision !HaskellOccurrenceKey !(NonEmpty NameSite)+  | InvalidExplicitHaskellName !NameSite !Text+  deriving stock (Eq, Show)++data GeneratedHaskellNamingEdition+  = LegacyNamingV1+  | IdiomaticNamingV1+  deriving stock (Eq, Ord, Show)++currentGeneratedHaskellNamingEdition :: GeneratedHaskellNamingEdition+currentGeneratedHaskellNamingEdition = IdiomaticNamingV1++renderGeneratedHaskellNamingEdition :: GeneratedHaskellNamingEdition -> Text+renderGeneratedHaskellNamingEdition = \case+  LegacyNamingV1 -> "legacy-v1"+  IdiomaticNamingV1 -> "idiomatic-v1"++parseGeneratedHaskellNamingEdition :: Text -> Maybe GeneratedHaskellNamingEdition+parseGeneratedHaskellNamingEdition = \case+  "legacy-v1" -> Just LegacyNamingV1+  "idiomatic-v1" -> Just IdiomaticNamingV1+  _ -> Nothing++renderUpperCamelName :: UpperCamelName -> Text+renderUpperCamelName (UpperCamelName value) = value++renderLowerCamelName :: LowerCamelName -> Text+renderLowerCamelName (LowerCamelName value) = value++renderModuleSegment :: HaskellModuleSegment -> Text+renderModuleSegment (HaskellModuleSegment value) = value++renderModuleName :: HaskellModuleName -> Text+renderModuleName (HaskellModuleName value) = value++-- | Derive both Haskell cases from exactly the same word list.  Explicit+-- Haskell references are checked by the namespace-specific smart constructors+-- below and are intentionally never re-cased here.+deriveHaskellName :: NameSourceKind -> NameSite -> Either HaskellNameError DerivedHaskellName+deriveHaskellName source site+  | source == ExplicitHaskellName = Left (InvalidExplicitHaskellName site (siteLogicalName site))+  | otherwise = do+      words' <- segmentLogicalName (source == LogicalWireWord) site+      case words' of+        [] -> Left (EmptyNameSegment site)+        firstWord : restWords -> do+          let upper = T.concat (map upperWord words')+              lower = lowerFirstWord firstWord <> T.concat (map upperWord restWords)+          upperName <- checkedUpperOccurrence site upper+          lowerName <- checkedLowerOccurrence site lower+          pure DerivedHaskellName {upperCamel = upperName, lowerCamel = lowerName}++checkedModuleSegment :: NameSite -> Text -> Either HaskellNameError HaskellModuleSegment+checkedModuleSegment site candidate+  | validUpperIdentifier False candidate = Right (HaskellModuleSegment candidate)+  | otherwise = Left (InvalidExplicitHaskellName site candidate)++checkedModuleName :: NameSite -> Text -> Either HaskellNameError HaskellModuleName+checkedModuleName site candidate+  | not (null components) && all (validUpperIdentifier True) components = Right (HaskellModuleName candidate)+  | otherwise = Left (InvalidExplicitHaskellName site candidate)+  where+    components = T.splitOn "." candidate++checkedUpperOccurrence :: NameSite -> Text -> Either HaskellNameError UpperCamelName+checkedUpperOccurrence site candidate+  | validUpperIdentifier False candidate = Right (UpperCamelName candidate)+  | otherwise = Left (InvalidExplicitHaskellName site candidate)++checkedLowerOccurrence :: NameSite -> Text -> Either HaskellNameError LowerCamelName+checkedLowerOccurrence site candidate+  | Set.member candidate haskellKeywords = Left (ReservedGeneratedOccurrence site candidate)+  | validLowerIdentifier candidate = Right (LowerCamelName candidate)+  | otherwise = Left (InvalidExplicitHaskellName site candidate)++-- | Construct a collision input after the occurrence has passed its checked+-- wrapper.  Field scope is the owning record name; use the empty string for+-- every other namespace.+plannedOccurrence :: Text -> HaskellOccurrenceSpace -> Text -> Text -> NameSite -> PlannedOccurrence+plannedOccurrence targetModule space scope rendered site =+  PlannedOccurrence+    { plannedOccurrenceKey =+        HaskellOccurrenceKey+          { occurrenceModule = T.toCaseFold targetModule,+            occurrenceSpace = space,+            occurrenceScope = T.toCaseFold scope,+            occurrenceName = case space of+              ModuleSpace -> T.toCaseFold rendered+              _ -> rendered+          },+      plannedOccurrenceSite = site+    }++-- | Report deterministic collisions independently of declaration traversal+-- order.  Repeated inventory entries for the same stable site are collapsed.+detectNameCollisions :: [PlannedOccurrence] -> [HaskellNameError]+detectNameCollisions occurrences =+  [ NormalizedNameCollision key (first :| rest)+  | (key, sites) <- Map.toAscList grouped,+    let orderedSites = Set.toAscList sites,+    first : rest <- [orderedSites]+  ]+  where+    grouped =+      Map.filter ((> 1) . Set.size) $+        Map.fromListWith+          Set.union+          [ (plannedOccurrenceKey occurrence, Set.singleton (plannedOccurrenceSite occurrence))+          | occurrence <- sortOn plannedOccurrenceKey occurrences+          ]++segmentLogicalName :: Bool -> NameSite -> Either HaskellNameError [Text]+segmentLogicalName allowHyphen site+  | T.null raw = Left (EmptyNameSegment site)+  | badUnderscore = Left (UnsafeNameSeparator site "underscore separators must be single and may not lead or trail a name")+  | not allowHyphen && T.any (== '-') raw = Left (UnsafeNameSeparator site "hyphens are allowed only in wire-word sources")+  | allowHyphen && badHyphen = Left (UnsafeNameSeparator site "hyphen separators must be single and may not lead or trail a name")+  | any T.null separated = Left (EmptyNameSegment site)+  | otherwise = Right (concatMap splitCamelWord separated)+  where+    raw = siteLogicalName site+    badUnderscore =+      T.isPrefixOf "_" raw+        || T.isSuffixOf "_" raw+        || T.isInfixOf "__" raw+    badHyphen =+      T.isPrefixOf "-" raw+        || T.isSuffixOf "-" raw+        || T.isInfixOf "--" raw+    separated = T.split (`elem` separators) raw+    separators = if allowHyphen then ['_', '-'] else ['_']++splitCamelWord :: Text -> [Text]+splitCamelWord value = map T.pack (go [] (T.unpack value))+  where+    go current [] = [reverse current | not (null current)]+    go [] (character : rest) = go [character] rest+    go current@(previous : _) remaining@(character : rest)+      | camelBoundary previous character (listToMaybe rest) = reverse current : go [] remaining+      | otherwise = go (character : current) rest++camelBoundary :: Char -> Char -> Maybe Char -> Bool+camelBoundary previous current next =+  (asciiLower previous || asciiDigit previous) && asciiUpper current+    || asciiUpper previous && asciiUpper current && maybe False asciiLower next++upperWord :: Text -> Text+upperWord word = case T.uncons word of+  Nothing -> ""+  Just (first, rest) -> T.cons (asciiToUpper first) rest++lowerFirstWord :: Text -> Text+lowerFirstWord word+  | hasUpper && T.all (\character -> not (asciiLower character)) word = T.map asciiToLower word+  | otherwise = case T.uncons word of+      Nothing -> ""+      Just (first, rest) -> T.cons (asciiToLower first) rest+  where+    hasUpper = T.any asciiUpper word++validUpperIdentifier :: Bool -> Text -> Bool+validUpperIdentifier allowUnderscore name = case T.uncons name of+  Just (first, rest) -> asciiUpper first && T.all (identifierTail allowUnderscore) rest+  Nothing -> False++validLowerIdentifier :: Text -> Bool+validLowerIdentifier name = case T.uncons name of+  Just (first, rest) -> asciiLower first && T.all (identifierTail False) rest+  Nothing -> False++identifierTail :: Bool -> Char -> Bool+identifierTail allowUnderscore character =+  asciiUpper character+    || asciiLower character+    || asciiDigit character+    || character == '\''+    || allowUnderscore && character == '_'++asciiUpper :: Char -> Bool+asciiUpper character = character >= 'A' && character <= 'Z'++asciiLower :: Char -> Bool+asciiLower character = character >= 'a' && character <= 'z'++asciiDigit :: Char -> Bool+asciiDigit character = character >= '0' && character <= '9'++asciiToUpper :: Char -> Char+asciiToUpper character+  | asciiLower character = toUpper character+  | otherwise = character++asciiToLower :: Char -> Char+asciiToLower character+  | asciiUpper character = toLower character+  | otherwise = character++-- | Words GHC rejects as term-level identifiers under the generated manifest+-- contract (GHC2024 plus the closed local-extension set in ADR 0019). Contextual+-- words are deliberately absent; widening this refusal set requires compile+-- evidence against that exact contract.+haskellKeywords :: Set Text+haskellKeywords =+  Set.fromList+    [ "case",+      "class",+      "data",+      "default",+      "deriving",+      "do",+      "else",+      "foreign",+      "forall",+      "if",+      "import",+      "in",+      "infix",+      "infixl",+      "infixr",+      "instance",+      "let",+      "module",+      "newtype",+      "of",+      "then",+      "type",+      "where"+    ]

@@ -0,0 +1,214 @@+-- | Pure planning and token-aware rewriting for generated-Haskell name moves.+module Keiro.Dsl.HaskellSourceMove+  ( SourceMove (..),+    SourceMoveError (..),+    planSourceMoves,+    rewriteHaskellModuleReferences,+    moduleNameFromPath,+    contentDigest,+  )+where++import Data.Bits (xor)+import Data.ByteString qualified as BS+import Data.List (sortBy, sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Ord (Down (..), comparing)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Word (Word64, Word8)+import Keiro.Dsl.HaskellName qualified as HaskellName+import Keiro.Dsl.Scaffold (ModuleKind, ModuleRole, ScaffoldModule, modulePath, moduleRole)+import Numeric (showHex)++data SourceMove = SourceMove+  { moveRole :: !ModuleRole,+    moveKind :: !ModuleKind,+    moveOldModule :: !Text,+    moveNewModule :: !Text,+    moveOldPath :: !FilePath,+    moveNewPath :: !FilePath,+    moveBackupPath :: !FilePath,+    -- | Digest of the exact legacy bytes.  Planning cannot populate it because+    -- it is pure and filesystem-independent; the complete migration preflight+    -- hydrates it before a move is reported or applied.+    moveContentDigest :: !(Maybe Text),+    -- | Digest of the token-aware transformed bytes, used with the durable+    -- migration state to recognize an installed or prepared crash state.+    moveTransformedDigest :: !(Maybe Text)+  }+  deriving stock (Eq, Show)++data SourceMoveError+  = AmbiguousLegacyModule !FilePath ![FilePath]+  | AmbiguousModuleRole !ModuleRole ![FilePath]+  | MalformedHaskellLexicalInput !Text+  deriving stock (Eq, Show)++-- | Pair prior paths with the current artifact plan.  New records provide a+-- stable role; historical records fall back to exact legacy-name+-- normalization.  Only actual path changes become moves.+planSourceMoves ::+  [(Maybe ModuleRole, ModuleKind, FilePath)] ->+  [ScaffoldModule] ->+  Either (NonEmpty SourceMoveError) [SourceMove]+planSourceMoves previous current =+  case errors of+    first : rest -> Left (first :| rest)+    [] -> Right (sortOn moveOldPath moves)+  where+    currentByRole = Map.fromListWith (<>) [(moduleRole scaffoldModule, [scaffoldModule]) | scaffoldModule <- current]+    currentByModule = Map.fromListWith (<>) [(moduleNameFromPath (modulePath scaffoldModule), [scaffoldModule]) | scaffoldModule <- current]+    planned = map pair previous+    errors = [err | Left err <- planned]+    moves = [move | Right (Just move) <- planned]++    pair (previousRole, previousKind, previousPath) = do+      candidate <- case previousRole of+        Just role -> uniqueRole role (Map.findWithDefault [] role currentByRole)+        Nothing ->+          let normalized = normalizeLegacyModuleName (moduleNameFromPath previousPath)+           in uniqueLegacy previousPath (Map.findWithDefault [] normalized currentByModule)+      case candidate of+        Nothing -> Right Nothing+        Just currentModule+          | modulePath currentModule == previousPath -> Right Nothing+          | normalizeLegacyModuleName (moduleNameFromPath previousPath) /= moduleNameFromPath (modulePath currentModule) -> Right Nothing+          | otherwise ->+              Right . Just $+                SourceMove+                  { moveRole = moduleRole currentModule,+                    moveKind = previousKind,+                    moveOldModule = moduleNameFromPath previousPath,+                    moveNewModule = moduleNameFromPath (modulePath currentModule),+                    moveOldPath = previousPath,+                    moveNewPath = modulePath currentModule,+                    moveBackupPath = ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/" <> previousPath,+                    moveContentDigest = Nothing,+                    moveTransformedDigest = Nothing+                  }++    uniqueRole _ [] = Right Nothing+    uniqueRole _ [candidate] = Right (Just candidate)+    uniqueRole role candidates = Left (AmbiguousModuleRole role (map modulePath candidates))+    uniqueLegacy _ [] = Right Nothing+    uniqueLegacy _ [candidate] = Right (Just candidate)+    uniqueLegacy path candidates = Left (AmbiguousLegacyModule path (map modulePath candidates))++moduleNameFromPath :: FilePath -> Text+moduleNameFromPath = T.replace "/" "." . T.dropEnd 3 . T.pack++normalizeLegacyModuleName :: Text -> Text+normalizeLegacyModuleName = T.intercalate "." . map normalizeSegment . T.splitOn "."+  where+    normalizeSegment segment =+      case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+        Left _ -> segment+      where+        site =+          HaskellName.NameSite+            { HaskellName.siteKind = HaskellName.NodeModuleSite,+              HaskellName.siteLogicalName = segment,+              HaskellName.siteOwner = "legacy-module-segment",+              HaskellName.siteLine = 0+            }++data LexState+  = Code+  | LineComment+  | BlockComment !Int+  | StringLiteral+  | CharacterLiteral+  deriving stock (Eq, Show)++-- | Rewrite exact module token sequences in Haskell code while preserving+-- comments, strings, character literals, and nested block comments byte for+-- byte.  Longer old modules win when one is a prefix of another.+rewriteHaskellModuleReferences :: Map Text Text -> Text -> Either SourceMoveError Text+rewriteHaskellModuleReferences replacements source =+  fmap (T.pack . reverse) (go Code Nothing (T.unpack source) [])+  where+    ordered =+      sortBy+        (comparing (Down . length . fst))+        [(T.unpack old, T.unpack new) | (old, new) <- Map.toAscList replacements, old /= new]++    go state previous input output = case (state, input) of+      (Code, []) -> Right output+      (LineComment, []) -> Right output+      (BlockComment _, []) -> Left (MalformedHaskellLexicalInput "unterminated block comment")+      (StringLiteral, []) -> Left (MalformedHaskellLexicalInput "unterminated string literal")+      (CharacterLiteral, []) -> Left (MalformedHaskellLexicalInput "unterminated character literal")+      (Code, '-' : '-' : rest) -> go LineComment (Just '-') rest ('-' : '-' : output)+      (Code, '{' : '-' : rest) -> go (BlockComment 1) (Just '-') rest ('-' : '{' : output)+      (Code, '"' : rest) -> go StringLiteral (Just '"') rest ('"' : output)+      (Code, '\'' : rest)+        | looksLikeCharacterLiteral rest -> go CharacterLiteral (Just '\'') rest ('\'' : output)+      (Code, remaining@(character : rest)) -> case firstReplacement previous remaining ordered of+        Just (old, new) ->+          let untouched = drop (length old) remaining+              newOutput = reverse new <> output+              newPrevious = case reverse old of oldLast : _ -> Just oldLast; [] -> previous+           in go Code newPrevious untouched newOutput+        Nothing -> go Code (Just character) rest (character : output)+      (LineComment, '\n' : rest) -> go Code (Just '\n') rest ('\n' : output)+      (LineComment, character : rest) -> go LineComment (Just character) rest (character : output)+      (BlockComment depth, '{' : '-' : rest) -> go (BlockComment (depth + 1)) (Just '-') rest ('-' : '{' : output)+      (BlockComment 1, '-' : '}' : rest) -> go Code (Just '}') rest ('}' : '-' : output)+      (BlockComment depth, '-' : '}' : rest) -> go (BlockComment (depth - 1)) (Just '}') rest ('}' : '-' : output)+      (BlockComment depth, character : rest) -> go (BlockComment depth) (Just character) rest (character : output)+      (StringLiteral, '\\' : escaped : rest) -> go StringLiteral (Just escaped) rest (escaped : '\\' : output)+      (StringLiteral, '"' : rest) -> go Code (Just '"') rest ('"' : output)+      (StringLiteral, character : rest) -> go StringLiteral (Just character) rest (character : output)+      (CharacterLiteral, '\\' : escaped : rest) -> go CharacterLiteral (Just escaped) rest (escaped : '\\' : output)+      (CharacterLiteral, '\'' : rest) -> go Code (Just '\'') rest ('\'' : output)+      (CharacterLiteral, character : rest) -> go CharacterLiteral (Just character) rest (character : output)++    firstReplacement previous remaining = firstMatch+      where+        firstMatch [] = Nothing+        firstMatch ((old, new) : rest)+          | old `isPrefixOfString` remaining,+            maybe True (not . moduleTokenCharacter) previous,+            afterBoundary old remaining =+              Just (old, new)+          | otherwise = firstMatch rest++    afterBoundary old remaining = case drop (length old) remaining of+      [] -> True+      next : _ -> not (identifierCharacter next)++    moduleTokenCharacter character = identifierCharacter character || character == '.'+    identifierCharacter character =+      (character >= 'A' && character <= 'Z')+        || (character >= 'a' && character <= 'z')+        || (character >= '0' && character <= '9')+        || character == '_'+        || character == '\''++    looksLikeCharacterLiteral rest = case rest of+      '\\' : _escaped : '\'' : _ -> True+      _character : '\'' : _ -> True+      _ -> False++isPrefixOfString :: String -> String -> Bool+isPrefixOfString [] _ = True+isPrefixOfString _ [] = False+isPrefixOfString (left : leftRest) (right : rightRest) = left == right && isPrefixOfString leftRest rightRest++-- | Stable UTF-8 content digest used by the local migration journal.  FNV-1a+-- is sufficient here: this is an integrity/recovery fingerprint rather than a+-- security boundary, and keeping it local avoids changing the package surface.+contentDigest :: Text -> Text+contentDigest source = T.pack (pad16 (showHex digest ""))+  where+    digest = BS.foldl' step fnvOffset (TE.encodeUtf8 source)+    step :: Word64 -> Word8 -> Word64+    step hash byte = (hash `xor` fromIntegral byte) * fnvPrime+    fnvOffset = 14695981039346656037 :: Word64+    fnvPrime = 1099511628211 :: Word64+    pad16 rendered = replicate (16 - length rendered) '0' <> rendered

@@ -219,7 +219,7 @@   LanguageDefinition version1 Nothing LanguageBodyParserV1 profileV1 runtimeProfileV1 CompatibilityOnly     :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2 profileV2 runtimeProfileV1 CompatibilityOnly,          LanguageDefinition version3 (Just version2) LanguageBodyParserV2 profileV2 runtimeProfileV2 CompatibilityOnly,-         LanguageDefinition version4 (Just version3) LanguageBodyParserV2 profileV2 runtimeProfileV3 Stable+         LanguageDefinition version4 (Just version3) LanguageBodyParserV2 profileV3 runtimeProfileV3 Stable        ]  profileV1 :: SyntaxProfile@@ -237,6 +237,15 @@         ]     ) +profileV3 :: SyntaxProfile+profileV3 =+  SyntaxProfile+    "keiro-dsl/syntax-profile/3"+    ( Set.insert+        FieldAliasSyntax+        (profileFeatures profileV2)+    )+ runtimeProfileV1 :: RuntimeSemanticsProfile runtimeProfileV1 =   RuntimeSemanticsProfile@@ -287,6 +296,7 @@   | IntegerScalarSyntax   | TypedAggregateExpressionSyntax   | ExplicitTransitionImplementationSyntax+  | FieldAliasSyntax   deriving stock (Eq, Ord, Show)  -- | The first released contract that owns each grammar feature.

@@ -20,6 +20,7 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar+import Keiro.Dsl.HaskellName qualified as HaskellName import Keiro.Dsl.TypeGraph import Keiro.Dsl.Validate (DiagnosticCode (..)) @@ -324,14 +325,30 @@       paths       declaration       leaf-      MappedWireKeyChanged-      ("wire key changed '" <> rwfKey oldField <> "' -> '" <> rwfKey newField <> "'; version and upcast every affected private event root")-  | rwfKey oldField /= rwfKey newField+      GeneratedHaskellNameChanged+      ( "generated record selector changed '"+          <> normalizedGeneratedLower (rwfHaskell oldField)+          <> "' -> '"+          <> normalizedGeneratedLower (rwfHaskell newField)+          <> "' while wire key '"+          <> rwfKey newField+          <> "' remains unchanged; re-scaffold and recompile consumers"+      )+  | rwfKey oldField == rwfKey newField,+    normalizedGeneratedLower (rwfHaskell oldField) /= normalizedGeneratedLower (rwfHaskell newField)   ]     ++ [ finding            paths            declaration            leaf+           MappedWireKeyChanged+           ("wire key changed '" <> rwfKey oldField <> "' -> '" <> rwfKey newField <> "'; version and upcast every affected private event root")+       | rwfKey oldField /= rwfKey newField+       ]+    ++ [ finding+           paths+           declaration+           leaf            MappedPresenceChanged            "field presence changed between required and optional; historical decode policy changed"        | rwfPresence oldField /= rwfPresence newField@@ -359,6 +376,20 @@                 "on-missing default changed; the same historical bytes now construct a different consumer value"             ]       _ -> []++normalizedGeneratedLower :: Text -> Text+normalizedGeneratedLower logicalName =+  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+    Right derived -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)+    Left _ -> logicalName+  where+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedFieldSite,+          HaskellName.siteLogicalName = logicalName,+          HaskellName.siteOwner = "mapped-diff",+          HaskellName.siteLine = 0+        }  diffExpr :: [UsePath] -> Name -> Text -> ResolvedTypeExpr -> ResolvedTypeExpr -> [MappedFinding] diffExpr paths declaration leaf oldExpression newExpression =

@@ -38,6 +38,7 @@ import Data.TypeID qualified as TypeID import GHC.Generics (Generic) import Keiro.Dsl.Grammar+import Keiro.Dsl.HaskellName (haskellKeywords) import Keiro.Dsl.IdDomain (enforcedIdDomainVersion) import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability) import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile)@@ -421,33 +422,3 @@ asciiAlphaNum c = asciiLetter c || (isAscii c && isDigit c) asciiAlphaNumOrUnderscore c = asciiAlphaNum c || c == '_' asciiControl c = ord c < 32 || ord c == 127--haskellKeywords :: Set.Set Text-haskellKeywords =-  Set.fromList-    [ "case",-      "class",-      "data",-      "default",-      "deriving",-      "do",-      "else",-      "foreign",-      "if",-      "import",-      "in",-      "infix",-      "infixl",-      "infixr",-      "instance",-      "let",-      "module",-      "newtype",-      "of",-      "then",-      "type",-      "where",-      "mdo",-      "rec",-      "proc"-    ]

@@ -153,8 +153,17 @@ pAggregateField context = do   loc <- getLoc   n <- ident+  selector <- optionalLanguageFeature context FieldAliasSyntax "haskell" (try (keyword "haskell" *> ident))+  wireKey <- optionalLanguageFeature context FieldAliasSyntax "as" (try (keyword "as" *> stringLit))   mty <- optional (symbol ":" *> pMappedTypeExpr context)-  pure AggregateField {aggregateFieldName = n, aggregateFieldType = mty, aggregateFieldLoc = loc}+  pure+    AggregateField+      { aggregateFieldName = n,+        aggregateFieldSelector = selector,+        aggregateFieldWireKey = wireKey,+        aggregateFieldType = mty,+        aggregateFieldLoc = loc+      }  pEvent :: FrontendContext -> P (Event, [Located SurfaceElement]) pEvent context = do

@@ -5,6 +5,7 @@   ) where +import Data.List (intersperse) import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar@@ -114,24 +115,23 @@       <*> (symbol ";" *> keyword "on-failed" *> pDisp)   pure RouterDispatchNode {rdCommand = command, rdFields = fields, rdDisposition = disposition, rdLoc = loc} -pRouterDispatchIdLine :: P ()-pRouterDispatchIdLine = do+-- | @dispatch-id strategy=uuidv5 from=(…)@ where the tuple is fixed by the+-- runtime that derives the id. The line documents a derivation the spec cannot+-- change, so the only sound thing to accept is the exact spelling that is true.+pFixedDispatchIdLine :: [Text] -> P ()+pFixedDispatchIdLine inputs = do   keyword "dispatch-id"   _ <- symbol "strategy" *> symbol "=" *> keyword "uuidv5"-  _ <- symbol "from" *> symbol "=" *> parens fixedInputs+  _ <- symbol "from" *> symbol "=" *> parens (sequence_ (intersperse (() <$ symbol ",") (map keyword inputs)))   pure ()-  where-    fixedInputs = do-      keyword "name"-      _ <- symbol ","-      keyword "key"-      _ <- symbol ","-      keyword "sourceEventId"-      _ <- symbol ","-      keyword "targetStreamName"-      _ <- symbol ","-      keyword "occurrence" +-- | @Keiro.Router.deterministicRouterCommandId@ keys on the router name, the+-- correlation key, the source event, the resolved target stream, and the+-- same-stream occurrence.+pRouterDispatchIdLine :: P ()+pRouterDispatchIdLine =+  pFixedDispatchIdLine ["name", "key", "sourceEventId", "targetStreamName", "occurrence"]+ pPolicyLine :: Text -> P PolicyChoice pPolicyLine clause = keyword clause *> symbol "=>" *> pPolicyChoice @@ -208,13 +208,16 @@       DDeadLetter <$> (keyword "DeadLetter" *> stringLit)     ] --- The dispatch-id line is a fixed, runtime-owned strategy; parse and discard.+-- | A process manager's twin of 'pRouterDispatchIdLine'.+-- @Keiro.ProcessManager.deterministicCommandId@ keys on the manager name, the+-- correlation id, the source event, and the positional emit index — a different+-- fixed tuple from the router's, so the two lines are checked separately but+-- equally strictly. Before ExecPlan 199 a process accepted any strategy+-- identifier and any tuple, so `dispatch-id strategy=md5 from=(banana)` checked+-- clean here while the same line was a parse error on a router. pDispatchIdLine :: P ()-pDispatchIdLine = do-  keyword "dispatch-id"-  _ <- symbol "strategy" *> symbol "=" *> ident-  _ <- symbol "from" *> symbol "=" *> parens (sepBy dottedRef (symbol ","))-  pure ()+pDispatchIdLine =+  pFixedDispatchIdLine ["name", "correlationId", "sourceEventId", "emitIndex"]  pTimerNode :: P TimerNode pTimerNode = do@@ -249,8 +252,8 @@   keyword "uuidv5"   pfx <- stringLit   _ <- symbol "<>"-  _ <- ident -- correlationId (fixed)-  pure IdExpr {ideStrategy = UuidV5Id, idePrefix = pfx}+  field <- ident+  pure IdExpr {ideStrategy = UuidV5Id, idePrefix = pfx, ideField = field}  pFireAt :: P FireAtExpr pFireAt = do

@@ -127,7 +127,7 @@       ]         ++ [ plain (SurfaceNode . NRouter <$> pRouter),              plain (SurfaceNode . NProcess <$> pProcess),-             plain (SurfaceNode . NContract <$> pContract),+             plain (SurfaceNode . NContract <$> pContract context),              plain (SurfaceNode . NIntake <$> pIntake),              plain (SurfaceNode . NEmit <$> pEmit),              plain (SurfaceNode . NPublisher <$> pPublisher),

@@ -7,15 +7,17 @@   ) where +import Keiro.Dsl.Frontend.Internal (FrontendContext) import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (LanguageFeature (FieldAliasSyntax)) import Keiro.Dsl.Parser.Core import Text.Megaparsec  -- Integration contract (EP-4) -------------------------------------------------------------------------------- -pContract :: P ContractNode-pContract = do+pContract :: FrontendContext -> P ContractNode+pContract context = do   loc <- getLoc   keyword "contract"   nm <- ident@@ -50,11 +52,14 @@       fs <- braces (many pContractField)       pure ContractEvent {ceName = nm, ceTopic = topicAlias, ceFields = fs}     pContractField = do+      loc <- getLoc       n <- ident+      selector <- optionalLanguageFeature context FieldAliasSyntax "haskell" (try (keyword "haskell" *> ident))+      wireKey <- optionalLanguageFeature context FieldAliasSyntax "as" (try (keyword "as" *> stringLit))       _ <- symbol ":"       ty <- pContractType       _ <- optional (symbol ";")-      pure ContractField {cfName = n, cfType = ty}+      pure ContractField {cfName = n, cfSelector = selector, cfWireKey = wireKey, cfType = ty, cfLoc = loc}     pContractType =       choice         [ CTypeId <$> (keyword "typeid" *> stringLit),

@@ -93,8 +93,11 @@       _ <- symbol "->"       w <- stringLit       ty <- ident-      req <- option False (True <$ keyword "required")-      pure WqField {wqfName = n, wqfWire = w, wqfType = ty, wqfRequired = req}+      -- Every payload field is required: generated decoders use `o .:` for all+      -- of them. The keyword stays accepted so existing sources still parse, but+      -- it selects nothing, so it is not retained. See ExecPlan 199.+      _ <- optional (keyword "required")+      pure WqField {wqfName = n, wqfWire = w, wqfType = ty}     pWqDispRow = do       loc <- getLoc       o <- ident

@@ -349,7 +349,9 @@       WqUnlogged -> [indent 2 "provision unlogged"]       WqPartitioned interval retention ->         [indent 2 ("provision partitioned(interval=" <> dquoted interval <> ", retention=" <> dquoted retention <> ")")]-    field f = pretty (wqfName f) <+> "->" <+> dquoted (wqfWire f) <+> pretty (wqfType f) <> (if wqfRequired f then " required" else mempty)+    -- Always rendered: every payload field is required, and stating it keeps+    -- the canonical form self-describing.+    field f = pretty (wqfName f) <+> "->" <+> dquoted (wqfWire f) <+> pretty (wqfType f) <> " required"     dispRow r = pretty (wqdOutcome r) <+> "->" <+> act (wqdAction r)     act IAckOk = "ackOk"     act (IRetry win) = "retry" <+> pretty win@@ -493,7 +495,14 @@         ["event" <+> pretty (ceName e) <+> "on" <+> pretty (ceTopic e) <+> "{"]           ++ map (indent 2 . docContractField) (ceFields e)           ++ ["}"]-    docContractField f = pretty (cfName f) <> ":" <+> docContractType (cfType f)+    docContractField f =+      hsep+        ( [pretty (cfName f)]+            ++ maybe [] (\selector -> ["haskell", pretty selector]) (cfSelector f)+            ++ maybe [] (\wireKey -> ["as", dquoted wireKey]) (cfWireKey f)+        )+        <> ":"+        <+> docContractType (cfType f)     docContractType (CTypeId p) = "typeid" <+> dquoted p     docContractType CText = "text"     docContractType CInt = "int"@@ -613,7 +622,7 @@     ]  docIdExpr :: IdExpr -> Doc ann-docIdExpr e = "uuidv5" <+> dquoted (idePrefix e) <+> "<>" <+> "correlationId"+docIdExpr e = "uuidv5" <+> dquoted (idePrefix e) <+> "<>" <+> pretty (ideField e)  docFireAt :: FireAtExpr -> Doc ann docFireAt f = ("input." <> pretty (faField f)) <+> "+" <+> pretty (faWindow f)@@ -723,9 +732,13 @@ docCommand c = "command" <+> pretty (cmdName c) <+> braced (map docAggregateField (cmdFields c))  docAggregateField :: AggregateField -> Doc ann-docAggregateField f = case aggregateFieldType f of-  Nothing -> pretty (aggregateFieldName f)-  Just ty -> pretty (aggregateFieldName f) <> ":" <> docTypeExpr ty+docAggregateField f =+  hsep+    ( [pretty (aggregateFieldName f)]+        ++ maybe [] (\selector -> ["haskell", pretty selector]) (aggregateFieldSelector f)+        ++ maybe [] (\wireKey -> ["as", dquoted wireKey]) (aggregateFieldWireKey f)+    )+    <> maybe mempty (\ty -> ":" <> docTypeExpr ty) (aggregateFieldType f)  docField :: Field -> Doc ann docField f = case fieldType f of

@@ -29,6 +29,7 @@ import Data.Text qualified as Text import Keiro.Dsl.AggregateType import Keiro.Dsl.CanonicalEncoding (canonicalExpr, canonicalTransition)+import Keiro.Dsl.FieldIdentity (ResolvedFieldIdentity (..), resolveAggregateFieldIdentity) import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType@@ -137,13 +138,19 @@       | aggWire oldAggregate == aggWire newAggregate = Set.empty       | otherwise = Set.fromList (evName <$> aggEvents oldAggregate) -eventDecodeSurface :: Event -> (EventBody, Int, Maybe (Int, Hole))-eventDecodeSurface event =-  (evBody event, evVersion event, evUpcastFrom event)+eventDecodeSurface :: Aggregate -> Event -> (Int, Maybe (Int, Hole), [(Name, Text, Maybe TypeExpr)])+eventDecodeSurface aggregate event =+  ( evVersion event,+    evUpcastFrom event,+    [ (fieldDslName identity, fieldWireKey identity, aggregateFieldType field)+    | field <- eventFields aggregate event,+      let identity = resolveAggregateFieldIdentity field+    ]+  ) -eventSurface :: Spec -> Aggregate -> Event -> ((EventBody, Int, Maybe (Int, Hole)), [(Name, Text)])+eventSurface :: Spec -> Aggregate -> Event -> ((Int, Maybe (Int, Hole), [(Name, Text, Maybe TypeExpr)]), [(Name, Text)]) eventSurface spec aggregate event =-  (eventDecodeSurface event, mappedFieldSurface spec aggregate event)+  (eventDecodeSurface aggregate event, mappedFieldSurface spec aggregate event)  mappedFieldSurface :: Spec -> Aggregate -> Event -> [(Name, Text)] mappedFieldSurface spec aggregate event = mapped <> nominal

@@ -19,6 +19,8 @@ -- concern. module Keiro.Dsl.Scaffold   ( ScaffoldModule (..),+    ModuleRole (..),+    moduleRole,     ModuleKind (..),     Context (..),     Placement (..),@@ -92,26 +94,29 @@   ) where -import Data.Char (isAlpha, isAlphaNum, isDigit, isUpper, toLower, toUpper)+import Data.Char (isAlpha, isAlphaNum, isDigit, isUpper) import Data.List (find, findIndex, groupBy, isSuffixOf, nub, sort, sortOn) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Version (showVersion)+import Keiro.Dsl.AggregateGenerationPlan import Keiro.Dsl.AggregateType import Keiro.Dsl.BehaviorCoverage qualified as Behavior import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..)) import Keiro.Dsl.EventOutput import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations) import Keiro.Dsl.Expression+import Keiro.Dsl.FieldIdentity import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprintForService, renderFoldSurfaceError) import Keiro.Dsl.GeneratedHaskellLanguage import Keiro.Dsl.Grammar import Keiro.Dsl.HaskellImport+import Keiro.Dsl.HaskellName qualified as HaskellName import Keiro.Dsl.IdDomain (IdDomainContract, contractIdDomainContractFor, idDomainContractFor, idDomainPrefix, idDomainSampleText) import Keiro.Dsl.LanguageVersion (SourceLanguage (LegacyUnversioned), languageVersionText) import Keiro.Dsl.NominalType@@ -134,6 +139,32 @@   }   deriving stock (Eq, Show) +-- | Stable semantic identity for a generated artifact.  It is deliberately+-- independent of the cased module path: source-name migrations pair artifacts+-- by this role, then compare their old and current paths.+data ModuleRole = ModuleRole+  { roleOwnerKind :: !Text,+    roleOwnerName :: !Text,+    roleFamily :: !Text+  }+  deriving stock (Eq, Ord, Show)++moduleRole :: ScaffoldModule -> ModuleRole+moduleRole scaffoldModule =+  ModuleRole+    { roleOwnerKind = headOr "module" originWords,+      roleOwnerName = origin scaffoldModule,+      roleFamily = case reverse (T.splitOn "." moduleName) of+        family : _ -> family+        [] -> moduleName+    }+  where+    originWords = T.words (origin scaffoldModule)+    moduleName = T.replace "/" "." (T.dropEnd 3 (T.pack (modulePath scaffoldModule)))+    headOr fallback = \case+      value : _ -> value+      [] -> fallback+ data ModuleKind   = -- | @-- \@generated@; overwritten on every scaffold.     Generated@@ -414,11 +445,12 @@   }   deriving stock (Eq, Show) --- | A command or event constructor with its fully-resolved field types.+-- | A command or event constructor with its fully-resolved field identities and+-- aggregate types. data ResolvedCtor = ResolvedCtor   { rcName :: !Text,-    -- | (field name, canonical aggregate type)-    rcFields :: ![(Text, ResolvedAggregateType)],+    -- | (DSL/selector/wire identity, canonical aggregate type)+    rcFields :: ![(ResolvedFieldIdentity, ResolvedAggregateType)],     -- | EP-2: schema version (1 for commands and unversioned events).     rcVersion :: !Int,     -- | EP-2: the source version this event migrates from (the upcaster step).@@ -489,7 +521,7 @@     mkCtor useSite cn fs =       ResolvedCtor         { rcName = cn,-          rcFields = map (\field -> (aggregateFieldName field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,+          rcFields = map (\field -> (resolveAggregateFieldIdentity field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,           rcVersion = 1,           rcUpcastFrom = Nothing         }@@ -1240,21 +1272,30 @@     ( renderGeneratedLanguagePragmas localExtensions         <> [ generatedBanner,              moduleHeader,-             "",-             "import Data.Aeson (FromJSON, ToJSON)",-             "import Data.Text (Text)",-             "import GHC.Generics (Generic)",-             "import Keiki.Shape (CanonicalTypeName)"+             ""            ]+        <> baseImports         <> internalImports         <> equalityImports-        <> [ "",-             sectionsOf [map emitOwner owners]-           ]+        <> if T.null declarations then [] else ["", declarations]     )   where     usesEquality = any nominalEqualityUsed owners-    usesExactEquality = any (\owner -> nominalEqualityUsed owner && exactOwner (nominalDeclaration owner)) owners+    exactEqualityOwners = [owner | owner <- owners, nominalEqualityUsed owner, exactOwner (nominalDeclaration owner)]+    inexactEqualityOwners = [owner | owner <- owners, nominalEqualityUsed owner, not (exactOwner (nominalDeclaration owner))]+    usesExactEquality = not (null exactEqualityOwners)+    usesInexactEquality = not (null inexactEqualityOwners)+    legacyNominals =+      [ nominal+      | owner <- owners,+        let nominal = nominalDeclaration owner,+        case resolvedNominalRepresentation nominal of+          IdRepresentation prefix -> not (isJust (idDomainContractFor languageContract prefix))+          EnumRepresentation {} -> True+          ScalarRepresentation {} -> False+      ]+    hasExactEnum = any (\owner -> case resolvedNominalRepresentation (nominalDeclaration owner) of EnumRepresentation {} -> True; _ -> False) exactEqualityOwners+    hasExactEnforcedId = any (\owner -> case resolvedNominalRepresentation (nominalDeclaration owner) of IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix); _ -> False) exactEqualityOwners     enforcingIds =       [ nominal       | owner <- owners,@@ -1287,12 +1328,28 @@     localExtensions =       [ExtDeriveAnyClass | any (nominalUsesDeriveAnyClass . nominalDeclaration) owners]         <> [ExtTypeFamilies | usesEquality]+    baseImports =+      ["import Data.Aeson (FromJSON, ToJSON)" | not (null legacyNominals)]+        <> ["import Data.Text (Text)" | not (null legacyNominals) || usesEquality]+        <> ["import GHC.Generics (Generic)" | not (null legacyNominals)]+        <> ["import Keiki.Shape (CanonicalTypeName)" | not (null legacyNominals)]     equalityImports =-      ["import Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)" | usesEquality]-        <> ["import Data.List.NonEmpty (NonEmpty (..))" | usesExactEquality]-        <> ["import Keiki.ProjectionDomain (finiteProjectionDomain)" | usesExactEquality && null enforcingIds]-        <> ["import Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, textProjectionDomain)" | usesExactEquality && not (null enforcingIds)]-        <> ["import Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain)" | not (null enforcingIds)]+      [ "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")"+      | usesEquality+      ]+        <> ["import Data.List.NonEmpty (NonEmpty (..))" | hasExactEnum]+        <> [ "import Keiki.ProjectionDomain (" <> T.intercalate ", " projectionDomainImports <> ")"+           | not (null projectionDomainImports)+           ]+        <> ["import Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain)" | hasExactEnforcedId]+      where+        coreImports =+          ["FieldProjection (..)", "FieldWitness"]+            <> (if usesExactEquality then ["ExactFieldProjection (..)", "exactFieldWitness"] else [])+            <> ["fieldWitness" | usesInexactEquality]+        projectionDomainImports =+          ["finiteProjectionDomain" | hasExactEnum]+            <> (if hasExactEnforcedId then ["TextPattern", "textProjectionDomain"] else [])     internalImports =       [ "import "           <> generatedNominalInternalModule ctx@@ -1303,6 +1360,7 @@           <> ")"       | not (null enforcingIds)       ]+    declarations = T.dropWhileEnd (== '\n') (sectionsOf [map emitOwner owners])     emitOwner owner = emitGeneratedNominal languageContract (nominalEqualityUsed owner) (nominalDeclaration owner)     exactOwner nominal = case resolvedNominalRepresentation nominal of       EnumRepresentation {} -> True@@ -1317,9 +1375,7 @@ emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of   IdRepresentation prefix     | Just _ <- idDomainContractFor languageContract prefix ->-        nl $-          ["instance CanonicalTypeName " <> name]-            <> equalitySection+        nl equalitySection   IdRepresentation {} ->     nl $       [ "newtype " <> name <> " = " <> name <> " Text",@@ -1412,6 +1468,7 @@       "import Data.Text (Text)",       "import Data.Text qualified as T",       "import GHC.Generics (Generic)",+      "import Keiki.Shape (CanonicalTypeName)",       "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)",       "",       sectionsOf [map emitInternal nominals]@@ -1429,6 +1486,8 @@         [ "newtype " <> name <> " = " <> name <> " Text",           "  deriving stock (Generic, Eq, Ord, Show)",           "",+          "instance CanonicalTypeName " <> name,+          "",           "instance ToJSON " <> name <> " where",           "  toJSON = toJSON . " <> textName,           "",@@ -1482,8 +1541,18 @@   ]  generatedNominalTypeImportsForService :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]-generatedNominalTypeImportsForService _ _ [] = [] generatedNominalTypeImportsForService service ctx nominals =+  generatedNominalTypeImportsWithParsers service ctx nominals nominals++-- | As 'generatedNominalTypeImportsForService', but importing an enforced ID's+-- @parse\<Name\>@ only for the nominals in @parsing@.+--+-- The parser is emitted only where a literal of that ID is constructed. A module+-- that merely mentions the type — a guard operand, say — needs the type name and+-- nothing else, and importing the parser there is an unused import.+generatedNominalTypeImportsWithParsers :: CheckedService -> Context -> [ResolvedNominalType] -> [ResolvedNominalType] -> [Text]+generatedNominalTypeImportsWithParsers _ _ [] _ = []+generatedNominalTypeImportsWithParsers service ctx nominals parsing =   [ "import "       <> generatedNominalModule ctx       <> " ("@@ -1491,10 +1560,12 @@       <> ")"   ]   where+    parsingNames = map resolvedNominalName (stableNominals parsing)     importsFor nominal = case resolvedNominalRepresentation nominal of       IdRepresentation prefix         | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix ->-            [resolvedNominalName nominal, "parse" <> resolvedNominalName nominal]+            [resolvedNominalName nominal]+              <> ["parse" <> resolvedNominalName nominal | resolvedNominalName nominal `elem` parsingNames]       _ -> [resolvedNominalName nominal <> " (..)"]  generatedNominalCodecImports :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]@@ -1506,7 +1577,7 @@       <> T.intercalate         ", "         ( concat-            [ [typeImport nominal, nominalTextName nominal]+            [ publicImports nominal             | nominal <- stableNominals nominals             ]         )@@ -1520,10 +1591,10 @@        | not (null enforcingIds)        ]   where-    typeImport nominal = case resolvedNominalRepresentation nominal of+    publicImports nominal = case resolvedNominalRepresentation nominal of       IdRepresentation prefix-        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> resolvedNominalName nominal-      _ -> resolvedNominalName nominal <> " (..)"+        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> [nominalTextName nominal]+      _ -> [resolvedNominalName nominal <> " (..)", nominalTextName nominal]     enforcingIds =       [ nominal       | nominal <- stableNominals nominals,@@ -1634,21 +1705,46 @@     moduleName = nominalProjectionModule ctx     imports =       sort . nub $-        [ "Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)",-          "Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)"+        [ "Keiki.Core (" <> T.intercalate ", " coreImports <> ")",+          "Keiro.Codec.Nominal (" <> T.intercalate ", " nominalCodecImports <> ")"         ]           <> ["Data.KindID qualified as KindID" | any hasId nominals]           <> ["Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain, validateIdDomainText)" | any hasEnforcedId nominals]           <> ["Data.List.NonEmpty (NonEmpty (..))" | any hasExactDomain nominals]           <> ["Data.Text (Text)" | any usesText nominals]           <> ["Data.Time (UTCTime)" | any (hasScalar NominalTime) nominals]-          <> ["Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, matchesTextPattern, textCharSet, textConcat, textLiteral, textProjectionDomain, textRepeatBetween)" | any hasExactDomain nominals]+          -- The four text combinators build the legacy hand-rolled TypeID+          -- pattern and are used only by the unenforced-ID branch; importing+          -- them unconditionally warns under -Wunused-imports whenever every+          -- exact-domain nominal is an enum or an enforced ID.+          <> [ "Keiki.ProjectionDomain ("+                 <> T.intercalate+                   ", "+                   ( ["TextPattern", "finiteProjectionDomain", "matchesTextPattern", "textProjectionDomain"]+                       <> (if any hasUnenforcedId nominals then ["textCharSet", "textConcat", "textLiteral", "textRepeatBetween"] else [])+                   )+                 <> ")"+             | any hasExactDomain nominals+             ]           <> ["Numeric.Natural (Natural)" | any (hasScalar NominalNatural) nominals]+    hasExactProjection nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation {} -> False; _ -> True+    hasInexactProjection = any (not . hasExactProjection) nominals+    hasReconstruction = any hasExactProjection nominals+    coreImports =+      ["FieldProjection (..)", "FieldWitness"]+        <> (if hasReconstruction then ["ExactFieldProjection (..)", "exactFieldWitness"] else [])+        <> ["fieldWitness" | hasInexactProjection]+    nominalCodecImports =+      ["nominalToRepresentation"]+        <> ["nominalFromRepresentation" | hasReconstruction]     hasScalar wanted nominal = resolvedNominalRepresentation nominal == ScalarRepresentation wanted     hasId nominal = case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False     hasEnforcedId nominal = case resolvedNominalRepresentation nominal of       IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)       _ -> False+    hasUnenforcedId nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> isNothing (idDomainContractFor languageContract prefix)+      _ -> False     hasExactDomain nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation {} -> False; _ -> True     usesText nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation NominalText -> True; IdRepresentation {} -> True; EnumRepresentation {} -> True; _ -> False     importPlan =@@ -2094,25 +2190,28 @@ emitStructuralProjections :: Context -> TypeGraph -> Text emitStructuralProjections ctx graph =   nl $-    renderGeneratedLanguagePragmas [ExtTypeFamilies]+    renderGeneratedLanguagePragmas [ExtTypeFamilies | not (null specs)]       <> [ generatedBanner,            "-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.",            "-- Int, Natural, and UTCTime belong to Keiki's ordered subset.",            "module " <> moduleName,            "  ( " <> T.intercalate "\n  , " (map spWitness specs),            "  ) where",-           "",-           "import Data.Text (Text)",-           "import Data.Time (UTCTime)",-           "import Numeric.Natural (Natural)",-           "import Keiro.Codec.Structural (bindingToShape)",-           "import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)"+           ""          ]+      <> staticImports       <> T.lines (renderPlannedImports importPlan)       <> concatMap renderProjection specs   where     moduleName = structuralProjectionModule ctx     specs = map (resolveProjectionModules ctx) (projectionSpecs graph)+    resultTypes = Set.fromList (map spResult specs)+    staticImports =+      ["import Data.Text (Text)" | "Text" `Set.member` resultTypes]+        <> ["import Data.Time (UTCTime)" | "UTCTime" `Set.member` resultTypes]+        <> ["import Numeric.Natural (Natural)" | "Natural" `Set.member` resultTypes]+        <> ["import Keiro.Codec.Structural (bindingToShape)" | not (null specs)]+        <> ["import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)" | not (null specs)]     importPlan =       planImportsOrDie         moduleName@@ -2263,9 +2362,24 @@ emitBehaviorContract aggregate =   nl $     renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null (aRegs aggregate))]-      <> [ "{-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-}",-           generatedBanner,-           "module " <> aGenPrefix aggregate <> ".BehaviorContract where",+      <> [ generatedBanner,+           "module " <> aGenPrefix aggregate <> ".BehaviorContract",+           "  ( BehaviorKey (..)",+           "  , ObligationKind (..)",+           "  , EvidenceLevel (..)",+           "  , GuardCoverage (..)",+           "  , BehaviorRequirement (..)",+           "  , RejectionClass (..)",+           "  , LiveExpectation (..)",+           "  , BehaviorWitness (..)",+           "  , BehaviorFailure (..)",+           "  , BehaviorConformanceReport (..)",+           "  , behaviorRequirements",+           "  , behaviorCoverageReport",+           "  , behaviorConformancePassed",+           "  , behaviorConformancePassedWith",+           "  , renderBehaviorConformanceText",+           "  ) where",            "",            "import " <> aGenPrefix aggregate <> ".Codec (encode" <> name <> "Event, parse" <> name <> "Event, " <> valueStem <> "Codec)",            "import " <> aGenPrefix aggregate <> ".Domain",@@ -2277,7 +2391,7 @@            "import Data.Map.Strict qualified as Map",            "import Data.Text (Text)",            "import Data.Text qualified as T",-           "import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))",+           "import Keiki.Core qualified as K (" <> T.intercalate ", " behaviorCoreImports <> ")",            "import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))",            "",            "newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }",@@ -2332,16 +2446,18 @@            "",            "data BehaviorFailure = BehaviorFailure",            "  { failureKey :: !BehaviorKey",+           "  , failureSubject :: !Text",            "  , failureCode :: !Text",            "  , failureDetail :: !Text",            "  }",            "  deriving stock (Eq, Show)",            "",            "instance ToJSON BehaviorFailure where",-           "  toJSON failure = object",-           "    [ \"key\" .= unBehaviorKey (failureKey failure)",-           "    , \"code\" .= failureCode failure",-           "    , \"detail\" .= failureDetail failure",+           "  toJSON behaviorFailure = object",+           "    [ \"key\" .= unBehaviorKey (failureKey behaviorFailure)",+           "    , \"subject\" .= failureSubject behaviorFailure",+           "    , \"code\" .= failureCode behaviorFailure",+           "    , \"detail\" .= failureDetail behaviorFailure",            "    ]",            "",            "data BehaviorConformanceReport = BehaviorConformanceReport",@@ -2398,7 +2514,7 @@            "    , not (isPending witness)",            "    , Just requirement <- [Map.lookup key requiredByKey]",            "    ]",-           "  failures = [failure | (_, Left failure) <- executions]",+           "  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]",            "",            "behaviorConformancePassed :: BehaviorConformanceReport -> Bool",            "behaviorConformancePassed = behaviorConformancePassedWith False",@@ -2425,7 +2541,7 @@            "  , \"failed: \" <> tshow (length (reportFailed report))",            "  , countLine \"verified\" (reportVerified report)",            "  , countLine \"unverified\" (reportUnverified report)",-           "  ] <> T.unlines [\"FAIL \" <> unBehaviorKey (failureKey failure) <> \" [\" <> failureCode failure <> \"] \" <> failureDetail failure | failure <- reportFailed report]",+           "  ] <> T.unlines [\"FAIL \" <> unBehaviorKey (failureKey behaviorFailure) <> \" \" <> failureSubject behaviorFailure <> \" [\" <> failureCode behaviorFailure <> \"] \" <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]",            "",            "runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()",            "runWitness requirement witness = case witness of",@@ -2443,6 +2559,7 @@            "    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",            "    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",            "",+           "runRejection :: BehaviorRequirement -> (" <> aVertexType aggregate <> ", K.RegFile " <> name <> "Regs) -> " <> name <> "Command -> LiveExpectation -> Either BehaviorFailure ()",            "runRejection requirement seed command expectation = case expectation of",            "  Emits _ -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect emitted events\"",            "  NoOp -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect an accepted no-op\"",@@ -2452,6 +2569,7 @@            "    Left K.AmbiguousEdges {} -> failure requirement \"ambiguous-edges\" \"AmbiguousEdges can never satisfy a rejection witness\"",            "    Right _ -> failure requirement \"unexpected-acceptance\" \"runtime accepted a command required to reject\"",            "",+           "runAcceptance :: BehaviorRequirement -> (" <> aVertexType aggregate <> ", K.RegFile " <> name <> "Regs) -> " <> name <> "Command -> LiveExpectation -> Either BehaviorFailure ()",            "runAcceptance requirement seed command expectation = case expectation of",            "  Rejects _ -> failure requirement \"expectation-kind\" \"a live-transition requirement needs Emits or NoOp\"",            "  NoOp -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",@@ -2467,8 +2585,8 @@            "      checkAcceptedEnvelope requirement success",            "      let expected = NonEmpty.toList expectedEvents",            "          actual = K.stepSuccessOutputs success",-           "      ensure requirement (actual == expected) \"event-value-mismatch\" \"runtime event values differ from the exact witness expectation\"",-           "      ensure requirement (map eventKind actual == requirementEventKinds requirement) \"event-envelope-mismatch\" \"runtime event kinds differ from the declared ordered envelope\"",+           "      ensure requirement (actual == expected) \"event-value-mismatch\" (\"runtime event values differ from the exact witness expectation; actual=\" <> tshow actual <> \" expected=\" <> tshow expected)",+           "      ensure requirement (map eventKind actual == requirementEventKinds requirement) \"event-envelope-mismatch\" (\"runtime event kinds differ from the declared ordered envelope; actual=\" <> tshow (map eventKind actual) <> \" expected=\" <> tshow (requirementEventKinds requirement))",            "      decoded <- either (failure requirement \"emitted-codec-decode\") Right (decodeEvents actual)",            "      replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer seed decoded of",            "        Left replayFailure -> failure requirement \"emitted-replay-failed\" (tshow replayFailure)",@@ -2477,10 +2595,11 @@            "      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) \"forward-replay-registers\" \"decoded emissions replay to different registers\"",            "      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)",            "",+           "checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess " <> name <> "Regs " <> aVertexType aggregate <> " " <> name <> "Event -> Either BehaviorFailure ()",            "checkAcceptedEnvelope requirement success = do",-           "  ensure requirement (K.stepSuccessMode success == K.Live) \"forward-mode\" \"forward execution selected a non-live edge\"",-           "  ensure requirement (Just (K.stepSuccessEdge success) == requirementExpectedEdge requirement) \"edge-attribution\" \"runtime selected a different guarded sibling\"",-           "  ensure requirement (Just (K.stepSuccessState success) == requirementTarget requirement) \"target-mismatch\" \"runtime reached a different target vertex\"",+           "  ensure requirement (K.stepSuccessMode success == K.Live) \"forward-mode\" (\"forward execution selected a non-live edge; actual=\" <> tshow (K.stepSuccessMode success) <> \" expected=\" <> tshow K.Live)",+           "  ensure requirement (Just (K.stepSuccessEdge success) == requirementExpectedEdge requirement) \"edge-attribution\" (\"runtime selected a different guarded sibling; actual=\" <> tshow (Just (K.stepSuccessEdge success)) <> \" expected=\" <> tshow (requirementExpectedEdge requirement))",+           "  ensure requirement (Just (K.stepSuccessState success) == requirementTarget requirement) \"target-mismatch\" (\"runtime reached a different target vertex; actual=\" <> tshow (Just (K.stepSuccessState success)) <> \" expected=\" <> tshow (requirementTarget requirement))",            "",            "runReplay :: BehaviorRequirement -> [" <> name <> "Event] -> [" <> name <> "Event] -> Either BehaviorFailure ()",            "runReplay requirement prefix chunk = case requirementKind requirement of",@@ -2492,19 +2611,21 @@            "    replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer (K.replaySuccessState settled, K.replaySuccessRegs settled) decoded of",            "      Left replayFailure -> failure requirement \"replay-chunk-failed\" (tshow replayFailure)",            "      Right replaySuccess -> Right replaySuccess",-           "    ensure requirement (Just (K.replaySuccessState replayed) == requirementTarget requirement) \"target-mismatch\" \"replay chunk reached a different target vertex\"",+           "    ensure requirement (Just (K.replaySuccessState replayed) == requirementTarget requirement) \"target-mismatch\" (\"replay chunk reached a different target vertex; actual=\" <> tshow (Just (K.replaySuccessState replayed)) <> \" expected=\" <> tshow (requirementTarget requirement))",            "    checkSingleAttribution requirement K.ReplayOnly (length decoded) (K.replaySuccessTrace replayed)",            "  _ -> failure requirement \"witness-kind\" \"ReplayWitness supplied for a non-replay requirement\"",            "",+           "checkSingleAttribution :: BehaviorRequirement -> K.EdgeMode -> Int -> [K.ReplayAttribution " <> aVertexType aggregate <> "] -> Either BehaviorFailure ()",            "checkSingleAttribution requirement expectedMode eventCount trace = case trace of",            "  [attribution] -> do",-           "    ensure requirement (Just (K.replayAttributionEdge attribution) == requirementExpectedEdge requirement) \"replay-edge-attribution\" \"replay selected a different edge\"",-           "    ensure requirement (K.replayAttributionMode attribution == expectedMode) \"replay-mode-attribution\" \"replay selected the wrong live/replay-only phase\"",-           "    ensure requirement (K.replayAttributionSource attribution == requirementSource requirement) \"replay-source-attribution\" \"replay attribution starts at the wrong source\"",-           "    ensure requirement (Just (K.replayAttributionTarget attribution) == requirementTarget requirement) \"replay-target-attribution\" \"replay attribution ends at the wrong target\"",-           "    ensure requirement (K.replayAttributionSpan attribution == K.ReplayEventSpan 0 eventCount) \"replay-span-attribution\" \"replay attribution did not consume the exact chunk\"",+           "    ensure requirement (Just (K.replayAttributionEdge attribution) == requirementExpectedEdge requirement) \"replay-edge-attribution\" (\"replay selected a different edge; actual=\" <> tshow (Just (K.replayAttributionEdge attribution)) <> \" expected=\" <> tshow (requirementExpectedEdge requirement))",+           "    ensure requirement (K.replayAttributionMode attribution == expectedMode) \"replay-mode-attribution\" (\"replay selected the wrong live/replay-only phase; actual=\" <> tshow (K.replayAttributionMode attribution) <> \" expected=\" <> tshow expectedMode)",+           "    ensure requirement (K.replayAttributionSource attribution == requirementSource requirement) \"replay-source-attribution\" (\"replay attribution starts at the wrong source; actual=\" <> tshow (K.replayAttributionSource attribution) <> \" expected=\" <> tshow (requirementSource requirement))",+           "    ensure requirement (Just (K.replayAttributionTarget attribution) == requirementTarget requirement) \"replay-target-attribution\" (\"replay attribution ends at the wrong target; actual=\" <> tshow (Just (K.replayAttributionTarget attribution)) <> \" expected=\" <> tshow (requirementTarget requirement))",+           "    ensure requirement (K.replayAttributionSpan attribution == K.ReplayEventSpan 0 eventCount) \"replay-span-attribution\" (\"replay attribution did not consume the exact chunk; actual=\" <> tshow (K.replayAttributionSpan attribution) <> \" expected=\" <> tshow (K.ReplayEventSpan 0 eventCount))",            "  _ -> failure requirement \"replay-trace-cardinality\" \"expected exactly one completed-edge attribution\"",            "",+           "settleHistory :: BehaviorRequirement -> Text -> [" <> name <> "Event] -> Either BehaviorFailure (K.ReplaySuccess " <> name <> "Regs " <> aVertexType aggregate <> ")",            "settleHistory requirement label history = do",            "  decoded <- either (failure requirement (label <> \"-codec-decode\")) Right (decodeEvents history)",            "  case K.applyEventsDetailedEither " <> valueStem <> "Transducer (" <> initialVertex aggregate <> ", initial" <> name <> "Regs) decoded of",@@ -2516,27 +2637,48 @@          ]       <> renderCommandKind aggregate       <> [ "",+           "eventKind :: " <> name <> "Event -> Text",            "eventKind event = case Codec.eventType " <> valueStem <> "Codec event of Codec.EventType tag -> tag",            "",            "regsEqual :: K.RegFile " <> name <> "Regs -> K.RegFile " <> name <> "Regs -> Bool",            regsEqualityExpression aggregate,            "",+           "proofStrength :: BehaviorRequirement -> Bool",            "proofStrength requirement =",            "  requirementEvidence requirement == GeneratedAuthoritative",            "    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]",            "",+           "behaviorWitnessKey :: BehaviorWitness -> BehaviorKey",            "behaviorWitnessKey witness = case witness of",            "  Pending key -> key",            "  LiveWitness { witnessKey = key } -> key",            "  ReplayWitness { witnessKey = key } -> key",            "",+           "isPending :: BehaviorWitness -> Bool",            "isPending Pending {} = True",            "isPending _ = False",            "",+           "ensure :: BehaviorRequirement -> Bool -> Text -> Text -> Either BehaviorFailure ()",            "ensure requirement condition code detail = if condition then Right () else failure requirement code detail",-           "failure requirement code detail = Left (BehaviorFailure (requirementKey requirement) code detail)",+           "failure :: BehaviorRequirement -> Text -> Text -> Either BehaviorFailure failed",+           "failure requirement code detail =",+           "  Left",+           "    ( BehaviorFailure",+           "        (requirementKey requirement)",+           "        (tshow (requirementSource requirement) <> \" x \" <> requirementCommandName requirement <> \": \" <> kindPhrase <> \" (spec line \" <> tshow (requirementLine requirement) <> \")\")",+           "        code",+           "        detail",+           "    )",+           " where",+           "  kindPhrase = case requirementKind requirement of",+           "    LiveTransition -> \"live transition\"",+           "    RequiredRejection -> \"required rejection\"",+           "    ReplayTransition -> \"replay-only transition\"",+           "sortedKeys :: [BehaviorKey] -> [BehaviorKey]",            "sortedKeys = sortOn unBehaviorKey",+           "keyTexts :: [BehaviorKey] -> [Text]",            "keyTexts = map unBehaviorKey",+           "countLine :: Text -> [BehaviorKey] -> Text",            "countLine label values = label <> \": \" <> tshow (length values)",            "tshow :: Show value => value -> Text",            "tshow = T.pack . show"@@ -2544,12 +2686,26 @@   where     name = aName aggregate     valueStem = lowerFirst name+    behaviorCoreImports =+      [ "EdgeMode (..)",+        "EdgeRef (..)",+        "RegFile",+        "ReplayAttribution (..)",+        "ReplayEventSpan (..)",+        "ReplaySuccess (..)",+        "StepFailure (..)",+        "StepSuccess (..)",+        "applyEventsDetailedEither",+        "stepDetailedEither"+      ]+        <> ["(!)" | not (null (aRegs aggregate))]  renderCommandKind :: Agg -> [Text] renderCommandKind aggregate = case aCommands aggregate of-  [] -> ["", "commandKind _ = \"\""]+  [] -> ["", "commandKind :: " <> aName aggregate <> "Command -> Text", "commandKind _ = \"\""]   commands ->     [ "",+      "commandKind :: " <> aName aggregate <> "Command -> Text",       "commandKind command = case command of"     ]       <> ["  " <> rcName command <> " _ -> " <> tshow (rcName command) | command <- commands]@@ -2559,34 +2715,43 @@   case behaviorRequirementsFor aggregate of     [] -> ["  []"]     requirements ->-      [ (if index == (0 :: Int) then "  [ " else "  , ") <> render requirement-      | (index, requirement) <- zip [0 ..] requirements-      ]+      concat+        [ render index requirement+        | (index, requirement) <- zip [0 ..] requirements+        ]         <> ["  ]"]   where-    render requirement =-      "BehaviorRequirement "-        <> keyExpr requirement-        <> " "-        <> T.pack (show (Behavior.requirementKind requirement))-        <> " "-        <> T.pack (show (Behavior.requirementEvidence requirement))-        <> " "-        <> T.pack (show (Behavior.requirementGuardCoverage requirement))-        <> " "-        <> vertexCtor aggregate (Behavior.requirementSource requirement)-        <> " "-        <> tshow (Behavior.requirementCommand requirement)-        <> " "-        <> edgeExpr aggregate requirement-        <> " "-        <> maybe "Nothing" (\target -> "(Just " <> vertexCtor aggregate target <> ")") (Behavior.requirementTarget requirement)-        <> " "-        <> renderBehaviorTextList (Behavior.requirementEvents requirement)-        <> " "-        <> tshow' (unLoc (Behavior.requirementLocation requirement))-    keyExpr requirement = "(BehaviorKey " <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)) <> ")"+    render index requirement =+      [ (if index == (0 :: Int) then "  [ -- " else "  , -- ") <> behaviorRequirementLabel aggregate requirement,+        "    BehaviorRequirement",+        "      { requirementKey = BehaviorKey " <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)),+        "      , requirementKind = " <> T.pack (show (Behavior.requirementKind requirement)),+        "      , requirementEvidence = " <> T.pack (show (Behavior.requirementEvidence requirement)),+        "      , requirementGuardCoverage = " <> T.pack (show (Behavior.requirementGuardCoverage requirement)),+        "      , requirementSource = " <> vertexCtor aggregate (Behavior.requirementSource requirement),+        "      , requirementCommandName = " <> tshow (Behavior.requirementCommand requirement),+        "      , requirementExpectedEdge = " <> edgeExpr aggregate requirement,+        "      , requirementTarget = " <> maybe "Nothing" (\target -> "Just " <> vertexCtor aggregate target) (Behavior.requirementTarget requirement),+        "      , requirementEventKinds = " <> renderBehaviorTextList (Behavior.requirementEvents requirement),+        "      , requirementLine = " <> tshow' (unLoc (Behavior.requirementLocation requirement)),+        "      }"+      ] +behaviorRequirementLabel :: Agg -> Behavior.BehaviorRequirement -> Text+behaviorRequirementLabel aggregate requirement =+  vertexCtor aggregate (Behavior.requirementSource requirement)+    <> " x "+    <> Behavior.requirementCommand requirement+    <> ": "+    <> ( case Behavior.requirementKind requirement of+           Behavior.LiveTransition -> "live transition"+           Behavior.RequiredRejection -> "required rejection"+           Behavior.ReplayTransition -> "replay-only transition"+       )+    <> " (spec line "+    <> tshow' (unLoc (Behavior.requirementLocation requirement))+    <> ")"+ edgeExpr :: Agg -> Behavior.BehaviorRequirement -> Text edgeExpr aggregate requirement = case Behavior.requirementKind requirement of   Behavior.RequiredRejection -> "Nothing"@@ -2658,7 +2823,8 @@           [ (if index == (0 :: Int) then "  [ " else "  , ")               <> "Pending (BehaviorKey "               <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement))-              <> ")"+              <> ") -- "+              <> behaviorRequirementLabel aggregate requirement           | (index, requirement) <- zip [0 ..] requirements           ]             <> ["  ]"]@@ -2774,7 +2940,12 @@         ++ [generatedBanner]         ++ moduleHeader         ++ [ "",-             "import Data.Aeson (Value, object, withObject, withText, (.:), (.=))",+             -- A typed-TypeID field decodes through explicitParseField, so a+             -- contract whose every field is one never uses (.:) and would warn+             -- under -Wunused-imports.+             "import Data.Aeson ("+               <> T.intercalate ", " (["Value", "object", "withObject", "withText"] <> ["(.:)" | usesPlainFieldDecode] <> ["(.=)"])+               <> ")",              aesonTypesImport            ]         ++ typedKindIdImports@@ -2824,6 +2995,7 @@   where     payloadTy = pascal (ctrName c) <> "Payload"     hasTypedTypeIds = any (any (isTypedTypeId . cfType) . ceFields) (ctrEvents c)+    usesPlainFieldDecode = any (any (not . isTypedTypeId . cfType) . ceFields) (ctrEvents c)     pragmas =       renderGeneratedLanguagePragmas         ( [ExtDuplicateRecordFields | contractNeedsDuplicateRecordFields c]@@ -2882,20 +3054,24 @@                  ]               ++ ["                )"]     encodeField field =-      tshow (cfName field)+      tshow (fieldWireKey identity)         <> " .= "         <> case cfType field of           CTypeId prefix-            | isJust (contractIdDomainContractFor languageContract prefix) -> "KindID.toText payload." <> cfName field-          _ -> "payload." <> cfName field+            | isJust (contractIdDomainContractFor languageContract prefix) -> "KindID.toText payload." <> fieldSelector identity+          _ -> "payload." <> fieldSelector identity+      where+        identity = resolveContractFieldIdentity field     decodeField field = case cfType field of       CTypeId prefix         | isJust (contractIdDomainContractFor languageContract prefix) ->-            "explicitParseField (parseKindIdV7Value @" <> tshow prefix <> ") o " <> tshow (cfName field)-      _ -> "o .: " <> tshow (cfName field)+            "explicitParseField (parseKindIdV7Value @" <> tshow prefix <> ") o " <> tshow wireKey+      _ -> "o .: " <> tshow wireKey+      where+        wireKey = fieldWireKey (resolveContractFieldIdentity field)  contractNeedsDuplicateRecordFields :: ContractNode -> Bool-contractNeedsDuplicateRecordFields = hasDuplicateNames . concatMap (map cfName . ceFields) . ctrEvents+contractNeedsDuplicateRecordFields = hasDuplicateNames . concatMap (map (fieldSelector . resolveContractFieldIdentity) . ceFields) . ctrEvents  contractUsesRecordDot :: ContractNode -> Bool contractUsesRecordDot = any (not . null . ceFields) . ctrEvents@@ -2918,7 +3094,7 @@         <> "Data = "         <> ceName e         <> (if hasTypedTypeIds then "Data {" else "Data { ")-        <> T.intercalate ", " [cfName f <> " :: !" <> hsType (cfType f) | f <- ceFields e]+        <> T.intercalate ", " [fieldSelector (resolveContractFieldIdentity f) <> " :: !" <> hsType (cfType f) | f <- ceFields e]         <> (if hasTypedTypeIds then "}\n  deriving stock (Eq, Show)" else " }\n  deriving stock (Eq, Show)")     arm e = ceName e <> " !" <> ceName e <> "Data"     sumDecl = case events of@@ -3068,7 +3244,12 @@       "  , publisherMaxAttempts",       "  ) where",       "",-      "import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))",+      -- Only an exponential schedule mentions ExponentialBackoffOptions, and an+      -- unconditional import makes a constant-backoff publisher warn under+      -- -Wunused-imports. Generated code compiles under -Werror.+      "import Keiro.Outbox.Types (BackoffSchedule (..), OrderingPolicy (..)"+        <> (if boKind (pubBackoff pb) == "exponential" then ", ExponentialBackoffOptions (..)" else "")+        <> ")",       "",       "publisherOrdering :: OrderingPolicy",       "publisherOrdering = " <> pubOrdering pb,@@ -3263,7 +3444,7 @@       "  , jobOrdering, jobTuningFor, queueProvision",       "  ) where",       "",-      "import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)",+      "import Keiro.PGMQ.Job (" <> T.intercalate ", " queuePolicyImports <> ")",       "",       "jobOrdering :: JobOrdering",       "jobOrdering = " <> orderingCtor,@@ -3296,6 +3477,21 @@       ++ ["  " <> pascal (wqdOutcome r) <> " -> " <> outcome (wqdAction r) | r <- wqDisposition w]   where     outcomeType = T.concat (map pascal (T.splitOn "_" (wqName w))) <> "Outcome"+    queuePolicyImports =+      [ "JobOrdering (..)",+        "JobOutcome (..)",+        "JobTuning",+        "QueueProvision",+        "RetryDelay (..)",+        "RetryPolicy (..)"+      ]+        <> ( case wqProvision w of+               WqStandard -> ["standardProvision"]+               WqUnlogged -> ["unloggedProvision"]+               WqPartitioned {} -> ["PartitionSpec (..)", "partitionedProvision"]+           )+        <> ["withFifoIndexProvision" | wqOrdering w /= WqUnordered]+        <> ["withOrdering"]     orderingCtor = case wqOrdering w of       WqUnordered -> "Unordered"       WqFifoThroughput -> "FifoThroughput"@@ -3820,13 +4016,13 @@            ""          ]       ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a]-      ++ [ "import Data.Proxy (Proxy (..))",-           "import Data.Text (Text)",-           "import GHC.Generics (Generic)",+      ++ ["import Data.Proxy (Proxy (..))" | not (null (aRegs a))]+      ++ ["import Data.Text (Text)" | AggregateText `elem` aggregateTypes a]+      ++ [ "import GHC.Generics (Generic)",            "import Keiki.Core (RegFile (..))"          ]       ++ ["import Keiki.Shape (CanonicalStateShape, CanonicalTypeName)" | hasSnapshot a]-      ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (aGeneratedNominals a)+      ++ generatedNominalDomainImports a       ++ map ("import " <>) (domainStaticImports a)       ++ T.lines (renderPlannedImports importPlan)       ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)",@@ -3850,8 +4046,8 @@ domainNeedsDuplicateRecordFields :: Agg -> Bool domainNeedsDuplicateRecordFields aggregate = hasDuplicateNames selectorNames   where-    commandSelectors = concatMap (map fst . rcFields) (aCommands aggregate)-    eventSelectors = concatMap (map fst . rcFields) (aEvents aggregate)+    commandSelectors = concatMap (map (fieldSelector . fst) . rcFields) (aCommands aggregate)+    eventSelectors = concatMap (map (fieldSelector . fst) . rcFields) (aEvents aggregate)     registerSelectors = map rrName (aRegs aggregate)     -- deriveWireCtorsAll creates one event TermFields record that repeats each     -- payload selector, so every field-bearing event contributes twice.@@ -3883,7 +4079,7 @@   nl $     [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data"     ]-      ++ recordFields [(name, renderDomainType importPlan a fieldType) | (name, fieldType) <- rcFields rc]+      ++ recordFields [(fieldSelector identity, renderDomainType importPlan a fieldType) | (identity, fieldType) <- rcFields rc]       ++ ["  deriving stock (Generic, Eq, Show)"]  recordFields :: [(Text, Text)] -> [Text]@@ -3988,8 +4184,44 @@                ]         ) +generatedNominalDomainImports :: Agg -> [Text]+generatedNominalDomainImports aggregate+  | null nominals = []+  | otherwise =+      [ "import "+          <> generatedNominalModule (aContext aggregate)+          <> " ("+          <> T.intercalate ", " (concatMap importsFor nominals)+          <> ")"+      ]+  where+    nominals = stableNominals (aGeneratedNominals aggregate)+    importsFor nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor (aLanguageContract aggregate) prefix ->+            resolvedNominalName nominal+              : ["parse" <> resolvedNominalName nominal | needsParser nominal]+      _ -> [resolvedNominalName nominal <> " (..)"]+    needsParser nominal =+      any+        (\register -> rrType register == AggregateNominal nominal && case rrInitial register of InitialId {} -> True; _ -> False)+        (aRegs aggregate)+ domainStaticImports :: Agg -> [Text]-domainStaticImports = Set.toAscList . Set.unions . map aggregateSourceStaticImports . domainAggregateSources+domainStaticImports aggregate =+  Set.toAscList (Set.delete timeTypeImport sourceImports <> Set.fromList timeImports)+  where+    sourceImports = Set.unions (map aggregateSourceStaticImports (domainAggregateSources aggregate))+    timeTypeImport = "Data.Time.Clock (UTCTime)"+    usesTimeType = AggregateTime `elem` aggregateTypes aggregate+    usesTimeLiteral = any (\register -> case rrInitial register of InitialTime {} -> True; _ -> False) (aRegs aggregate)+    timeImports+      | usesTimeLiteral =+          [ "Data.Time.Calendar (fromGregorian)",+            "Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)"+          ]+      | usesTimeType = [timeTypeImport]+      | otherwise = []  domainAggregateSources :: Agg -> [AggregateHaskellSource] domainAggregateSources aggregate =@@ -4050,20 +4282,15 @@            "import " <> aGenPrefix a <> ".Domain"          ]       ++ generatedNominalCodecImports (aggregateCheckedService a) (aContext a) (codecGeneratedNominals a)-      ++ ( if hasMappedCodec a-             then-               [ "import Control.Monad (unless)",-                 "import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))",-                 "import Data.Aeson.Key qualified as Key",-                 "import Data.Aeson.KeyMap qualified as KeyMap"-               ]-             else ["import Data.Aeson (Value, object, withObject, withText, (.:), (.=))"]-         )-      ++ [ "import Data.Aeson.Types (Parser, explicitParseField, parseEither)",+      ++ ["import Control.Monad (unless)" | codecUsesUnknownFieldRejection a]+      ++ [codecAesonImport a]+      ++ ["import Data.Aeson.Key qualified as Key" | codecUsesKeyMap a]+      ++ ["import Data.Aeson.KeyMap qualified as KeyMap" | codecUsesKeyMap a]+      ++ [ "import Data.Aeson.Types (" <> T.intercalate ", " (codecAesonTypesImports a) <> ")",            "import Data.List.NonEmpty (NonEmpty (..))",            "import Data.List.NonEmpty qualified as NonEmpty"          ]-      ++ ( if hasMappedCodec a+      ++ ( if codecUsesMap a              then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"]              else []          )@@ -4073,7 +4300,7 @@       ++ ["import Data.KindID qualified as KindID" | hasConsumerNominalIdCodec a]       ++ ["import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)" | hasEnforcedConsumerNominalIdCodec a]       ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" | hasConsumerNominalCodec a]-      ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasMappedCodec a]+      ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasStructuralMappedCodec a]       ++ [ "import Keiro.Codec (Codec (..), EventType (..))",            upcasterImport a          ]@@ -4097,16 +4324,27 @@            "mapLeftText :: Either String b -> Either Text b",            "mapLeftText = either (Left . T.pack) Right",            "",-           "_renderEventTypes :: NonEmpty EventType -> String",-           "_renderEventTypes =",+           "renderExpectedEventTypes :: NonEmpty EventType -> String",+           "renderExpectedEventTypes =",            "  T.unpack",            "    . T.intercalate \", \"",            "    . map (\\(EventType eventTypeName) -> eventTypeName)",            "    . NonEmpty.toList"          ]-      ++ ( if hasMappedCodec a+      ++ ( if codecUsesOptionalFieldHelper a              then                [ "",+                 "parseOptionalField :: Parser fieldValue -> (Value -> Parser fieldValue) -> KeyMap.KeyMap Value -> Key.Key -> Parser fieldValue",+                 "parseOptionalField onMissing parseItem objectValue key =",+                 "  case KeyMap.lookup key objectValue of",+                 "    Nothing -> onMissing",+                 "    Just _ -> explicitParseField parseItem objectValue key"+               ]+             else []+         )+      ++ ( if codecUsesUnknownFieldRejection a+             then+               [ "",                  "rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()",                  "rejectUnknownFields label allowed objectValue =",                  "  unless (null extras) (fail (label <> \" contains unknown fields: \" <> show extras))",@@ -4129,6 +4367,189 @@ hasMappedCodec :: Agg -> Bool hasMappedCodec = not . null . codecMappedDeclarations +hasStructuralMappedCodec :: Agg -> Bool+hasStructuralMappedCodec = any isStructural . codecMappedDeclarations+  where+    isStructural ResolvedStructural {} = True+    isStructural ResolvedOpaque {} = False++codecAesonImport :: Agg -> Text+codecAesonImport aggregate =+  "import Data.Aeson (" <> T.intercalate ", " imports <> ")"+  where+    imports =+      [if codecUsesValueConstructors aggregate then "Value (..)" else "Value"]+        <> ["object" | codecUsesObject aggregate]+        <> ["parseJSON" | codecUsesParseJSON aggregate]+        <> ["toJSON" | codecUsesToJSON aggregate]+        <> ["withObject"]+        <> ["withText" | codecUsesWithText aggregate]+        <> ["(.:)" | codecUsesDotColon aggregate]+        <> ["(.=)" | codecUsesObject aggregate]++codecUsesObject :: Agg -> Bool+codecUsesObject aggregate =+  not (null (aEvents aggregate)) || any structuralUsesObject (codecMappedDeclarations aggregate)+  where+    structuralUsesObject (ResolvedStructural _ shape) = case shape of REnum {} -> False; _ -> True+    structuralUsesObject ResolvedOpaque {} = False++codecAesonTypesImports :: Agg -> [Text]+codecAesonTypesImports aggregate =+  ["Parser" | codecUsesParserType aggregate]+    <> ["explicitParseField" | codecUsesExplicitParseField aggregate]+    <> ["parseEither"]++codecUsesParserType :: Agg -> Bool+codecUsesParserType aggregate =+  codecUsesWithText aggregate || hasStructuralMappedCodec aggregate++codecUsesExplicitParseField :: Agg -> Bool+codecUsesExplicitParseField aggregate =+  codecUsesWithText aggregate || any structuralUsesExplicitParseField (codecMappedDeclarations aggregate)+  where+    structuralUsesExplicitParseField (ResolvedStructural _ shape) = case shape of+      RRecord _ _ fields -> not (null fields)+      REnum {} -> False+      RUnion {} -> True+    structuralUsesExplicitParseField ResolvedOpaque {} = False++codecUsesWithText :: Agg -> Bool+codecUsesWithText aggregate =+  any nominalUsesWithText (codecGeneratedNominals aggregate <> codecConsumerNominals aggregate)+    || any mappedUsesWithText (codecMappedDeclarations aggregate)+  where+    nominalUsesWithText nominal = case resolvedNominalRepresentation nominal of+      EnumRepresentation {} -> True+      IdRepresentation {} -> case resolvedNominalOwnership nominal of ConsumerNominal {} -> True; GeneratedNominal -> False+      ScalarRepresentation {} -> False+    mappedUsesWithText (ResolvedStructural _ shape) = case shape of+      REnum {} -> True+      RUnion {} -> True+      RRecord {} -> False+    mappedUsesWithText ResolvedOpaque {} = False++codecUsesDotColon :: Agg -> Bool+codecUsesDotColon aggregate = any fieldUsesDotColon (concatMap rcFields (aEvents aggregate))+  where+    fieldUsesDotColon (_, resolvedType) = case resolvedType of+      AggregateNominal nominal -> case (resolvedNominalOwnership nominal, resolvedNominalRepresentation nominal) of+        (GeneratedNominal, EnumRepresentation {}) -> False+        (ConsumerNominal {}, IdRepresentation {}) -> False+        (ConsumerNominal {}, EnumRepresentation {}) -> False+        _ -> True+      _ -> case fieldCat aggregate resolvedType of+        MappedStructuralCat {} -> False+        _ -> True++codecUsesKeyMap :: Agg -> Bool+codecUsesKeyMap aggregate = codecUsesOptionalFieldHelper aggregate || codecUsesUnknownFieldRejection aggregate++codecUsesUnknownFieldRejection :: Agg -> Bool+codecUsesUnknownFieldRejection = any declarationRejectsUnknown . codecMappedDeclarations+  where+    declarationRejectsUnknown (ResolvedStructural _ shape) = case shape of+      RRecord _ RejectUnknown _ -> True+      RUnion encoding _ -> ueUnknownFields encoding == RejectUnknown+      _ -> False+    declarationRejectsUnknown ResolvedOpaque {} = False++codecUsesMap :: Agg -> Bool+codecUsesMap = any declarationUsesMap . codecMappedDeclarations+  where+    declarationUsesMap (ResolvedStructural _ shape) = any typeUsesMap (shapeTypeExpressions shape)+    declarationUsesMap ResolvedOpaque {} = False++codecUsesParseJSON :: Agg -> Bool+codecUsesParseJSON aggregate = any (declarationUsesAesonConversion aggregate) (codecMappedDeclarations aggregate)++codecUsesToJSON :: Agg -> Bool+codecUsesToJSON aggregate =+  any directOpaqueField (concatMap rcFields (aEvents aggregate))+    || any (declarationUsesAesonConversion aggregate) (codecMappedDeclarations aggregate)+  where+    directOpaqueField (_, resolvedType) = case fieldCat aggregate resolvedType of MappedOpaqueCat {} -> True; _ -> False++codecUsesValueConstructors :: Agg -> Bool+codecUsesValueConstructors = any declarationUsesConstructors . codecMappedDeclarations+  where+    declarationUsesConstructors (ResolvedStructural _ shape) =+      case shape of REnum {} -> True; _ -> any typeUsesOptional (shapeTypeExpressions shape)+    declarationUsesConstructors ResolvedOpaque {} = False++declarationUsesAesonConversion :: Agg -> ResolvedMappedDecl -> Bool+declarationUsesAesonConversion aggregate (ResolvedStructural _ shape) =+  any (typeUsesAesonConversion aggregate) (shapeTypeExpressions shape)+declarationUsesAesonConversion _ ResolvedOpaque {} = False++shapeTypeExpressions :: ResolvedMappedShape -> [ResolvedTypeExpr]+shapeTypeExpressions = \case+  RRecord _ _ fields -> map rwfType fields+  REnum {} -> []+  RUnion _ arms -> mapMaybe rwaPayload arms++typeUsesMap :: ResolvedTypeExpr -> Bool+typeUsesMap =+  foldTypeExpr+    TypeExprAlgebra+      { onText = False,+        onInt = False,+        onInteger = False,+        onBool = False,+        onNatural = False,+        onTime = False,+        onJson = False,+        onOptional = id,+        onList = id,+        onMap = const True,+        onRef = const False+      }++typeUsesOptional :: ResolvedTypeExpr -> Bool+typeUsesOptional =+  foldTypeExpr+    TypeExprAlgebra+      { onText = False,+        onInt = False,+        onInteger = False,+        onBool = False,+        onNatural = False,+        onTime = False,+        onJson = False,+        onOptional = const True,+        onList = id,+        onMap = id,+        onRef = const False+      }++typeUsesAesonConversion :: Agg -> ResolvedTypeExpr -> Bool+typeUsesAesonConversion aggregate =+  foldTypeExpr+    TypeExprAlgebra+      { onText = True,+        onInt = True,+        onInteger = True,+        onBool = True,+        onNatural = True,+        onTime = True,+        onJson = False,+        onOptional = id,+        onList = const True,+        onMap = const True,+        onRef = \key -> case aTypeGraph aggregate >>= \graph -> Map.lookup key (tgDeclarations graph) of+          Just ResolvedOpaque {} -> True+          _ -> False+      }++codecUsesOptionalFieldHelper :: Agg -> Bool+codecUsesOptionalFieldHelper aggregate =+  any structuralHasOptionalField (codecMappedDeclarations aggregate)+  where+    structuralHasOptionalField (ResolvedStructural _ (RRecord _ _ fields)) =+      any ((== POptional) . rwfPresence) fields+    structuralHasOptionalField (ResolvedStructural _ _) = False+    structuralHasOptionalField ResolvedOpaque {} = False+ hasConsumerNominalCodec :: Agg -> Bool hasConsumerNominalCodec = not . null . codecConsumerNominals @@ -4308,16 +4729,16 @@         ++ ["      ]"]     lead 0 = "      [ "     lead _ = "      , "-    encodeField (n, ty) =-      tshow n+    encodeField (identity, ty) =+      tshow (fieldWireKey identity)         <> " .= "-        <> encodeFieldValue n ty-    encodeFieldValue name ty = case ty of-      AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> name)+        <> encodeFieldValue (fieldSelector identity) ty+    encodeFieldValue selector ty = case ty of+      AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> selector)       _ -> case fieldCat a ty of-        MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> name-        MappedOpaqueCat {} -> "toJSON payload." <> name-        _ -> "payload." <> name+        MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> selector+        MappedOpaqueCat {} -> "toJSON payload." <> selector+        _ -> "payload." <> selector     encodeNominalValue nominal value = case resolvedNominalOwnership nominal of       GeneratedNominal -> case resolvedNominalRepresentation nominal of         IdRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value@@ -4359,12 +4780,12 @@                  | (index, field) <- zip [(0 :: Int) ..] fields                  ]               ++ ["                )"]-    decodeField (n, ty) = case ty of-      AggregateNominal nominal -> decodeNominalField n nominal+    decodeField (identity, ty) = case ty of+      AggregateNominal nominal -> decodeNominalField (fieldWireKey identity) nominal       _ -> case fieldCat a ty of-        MappedStructuralCat declaration _ -> "explicitParseField parse" <> sdName declaration <> "Mapped o " <> tshow n-        MappedOpaqueCat {} -> "o .: " <> tshow n-        _ -> "o .: " <> tshow n+        MappedStructuralCat declaration _ -> "explicitParseField parse" <> sdName declaration <> "Mapped o " <> tshow (fieldWireKey identity)+        MappedOpaqueCat {} -> "o .: " <> tshow (fieldWireKey identity)+        _ -> "o .: " <> tshow (fieldWireKey identity)     decodeNominalField name nominal = case resolvedNominalOwnership nominal of       GeneratedNominal -> case resolvedNominalRepresentation nominal of         IdRepresentation prefix -> case idDomainContractFor (aLanguageContract a) prefix of@@ -4418,11 +4839,12 @@       [ reference       | nominal <- codecConsumerNominals aggregate,         ConsumerNominal binding <- [resolvedNominalOwnership nominal],-        reference <--          [ haskellTypeReference (consumerNominalHaskell binding),-            qualifiedValueReference (consumerNominalBinding binding)-          ]+        reference <- qualifiedValueReference (consumerNominalBinding binding) : nominalParserTypeReferences nominal binding       ]+    nominalParserTypeReferences nominal binding = case resolvedNominalRepresentation nominal of+      IdRepresentation {} -> [haskellTypeReference (consumerNominalHaskell binding)]+      EnumRepresentation {} -> [haskellTypeReference (consumerNominalHaskell binding)]+      ScalarRepresentation {} -> []     mappedReferences =       [ reference       | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate,@@ -4600,7 +5022,7 @@             [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of"             ]               <> ["  " <> tshow (weTag entry) <> " -> pure " <> shapeConstructor (weCtor entry) | entry <- entries]-              <> ["  tag -> " <> renderUnknownFailure (name <> " wire value") "tag" (map weTag entries)],+              <> ["  unknownTag -> " <> renderUnknownFailure (name <> " wire value") "unknownTag" (map weTag entries)],         onUnion = \encoding arms ->           nl $             [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do",@@ -4644,15 +5066,12 @@   PRequired ->     "explicitParseField (" <> decoder <> ") objectValue " <> key   POptional ->-    "(case KeyMap.lookup (Key.fromText "-      <> key-      <> ") objectValue of Nothing -> "+    "parseOptionalField ("       <> missing-      <> "; Just _ -> explicitParseField ("+      <> ") ("       <> decoder       <> ") objectValue "       <> key-      <> ")"   where     key = tshow (rwfKey field)     decoder = decodeShapeExpr a graph (rwfType field)@@ -4751,7 +5170,7 @@     <> variable     <> " <> "     <> tshow "; expected one of: "-    <> " <> _renderEventTypes "+    <> " <> renderExpectedEventTypes "     <> eventTypesName aggregate     <> ")" @@ -4763,7 +5182,10 @@ hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions  transitionEntries :: Agg -> [(Int, Transition)]-transitionEntries aggregate = zip [1 ..] (aTransitions aggregate)+transitionEntries aggregate =+  [ (layoutDeclarationIndex entry, layoutTransition entry)+  | entry <- transitionLayout (aTransitions aggregate)+  ]  transitionStem :: Int -> Transition -> Text transitionStem index transition =@@ -4801,7 +5223,9 @@       outputFunctionName transitionIndex transition emitIndex eventName     )   | aggregate <- [value | NAggregate value <- specNodes spec],-    (transitionIndex, transition) <- zip [1 ..] (aggTransitions aggregate),+    entry <- transitionLayout (aggTransitions aggregate),+    let transitionIndex = layoutDeclarationIndex entry+        transition = layoutTransition entry,     (emitIndex, eventName) <- zip [1 ..] (tEmits transition),     Right GeneratedCommandIdentity {} <- [eventOutputMapping spec aggregate transition emitIndex eventName]   ]@@ -4872,6 +5296,32 @@       maybe [] pure (resolvedTransitionGuard resolved)         <> map snd (resolvedTransitionWrites resolved) +-- | Guard expressions only.+--+-- A guard renders its operands as @K.Index … SomeType@ annotations and so needs+-- each operand type in scope. A write renders @B.slot \@"x" =: d.x@, whose type+-- is inferred — importing its source type adds an unused import, which is an+-- error under the generated-output @-Werror@. Literals name their type in either+-- position and are collected separately.+generatedTransitionGuards :: [ResolvedGeneratedTransition] -> [TypedScalarExpr]+generatedTransitionGuards = concatMap (maybe [] pure . resolvedTransitionGuard)++-- | Every literal node in an expression tree.+typedExpressionLiterals :: TypedScalarExpr -> [TypedScalarExpr]+typedExpressionLiterals expression = own <> concatMap typedExpressionLiterals (typedExpressionChildren expression)+  where+    own = case typedScalarNode expression of+      TypedLiteral {} -> [expression]+      _ -> []++-- | Types named by literal construction anywhere in an expression.+typedExpressionLiteralTypes :: TypedScalarExpr -> [ResolvedAggregateType]+typedExpressionLiteralTypes expression = own <> concatMap typedExpressionLiteralTypes (typedExpressionChildren expression)+  where+    own = case typedScalarNode expression of+      TypedLiteral {} -> [typedScalarType expression]+      _ -> []+ anyTypedExpression :: (TypedScalarExpr -> Bool) -> TypedScalarExpr -> Bool anyTypedExpression predicate expression =   predicate expression || any (anyTypedExpression predicate) (typedExpressionChildren expression)@@ -5108,7 +5558,7 @@       <> " inCtor"       <> tCommand transition       <> " (#"-      <> fieldName+      <> commandFieldSelector aggregate (tCommand transition) fieldName       <> " :: K.Index ("       <> commandFieldsType transition       <> ") "@@ -5127,7 +5577,8 @@ renderKeikiTerm importPlan aliases aggregate transition expression = case typedScalarNode expression of   TypedLiteral value -> renderedAtom (renderKeikiLiteral importPlan aggregate (typedScalarType expression) value)   TypedRoot (ScalarRegisterRoot registerName _) -> renderedAtom ("B.reg @" <> tshow registerName)-  TypedRoot (ScalarCommandRoot fieldName _) -> renderedAtom ("d." <> fieldName)+  TypedRoot (ScalarCommandRoot fieldName _) ->+    renderedAtom ("d." <> commandFieldSelector aggregate (tCommand transition) fieldName)   TypedProject provenance projection ->     renderedAtom (projectionAliasFor aliases (StructuralProjectionAlias provenance projection))   TypedAdd _ left right -> arithmetic 6 ".+" left right@@ -5166,7 +5617,7 @@       <> " inCtor"       <> tCommand transition       <> " (#"-      <> fieldName+      <> commandFieldSelector aggregate (tCommand transition) fieldName       <> " :: K.Index ("       <> commandFieldsType transition       <> ") "@@ -5260,7 +5711,11 @@       ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral]       ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral]       ++ ["import Numeric.Natural (Natural)" | expressionUsesNaturalLiteral]-      ++ generatedNominalTypeImportsForService (aggregateCheckedService aggregate) (aContext aggregate) generatedExpressionNominals+      ++ generatedNominalTypeImportsWithParsers+        (aggregateCheckedService aggregate)+        (aContext aggregate)+        generatedExpressionNominals+        generatedLiteralNominals       ++ structuralProjectionImport       ++ generatedNominalProjectionImport       ++ consumerNominalProjectionImport@@ -5329,7 +5784,11 @@       ]     consumerImports =       T.lines (renderPlannedImports importPlan)-    expressionImportTypes = nub (concatMap typedExpressionImportTypes resolvedExpressions)+    expressionImportTypes =+      nub+        ( concatMap typedExpressionImportTypes (generatedTransitionGuards resolvedTransitions)+            <> concatMap typedExpressionLiteralTypes resolvedExpressions+        )     consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression]     importPlan = transducerImportPlan aggregate expressionImportTypes consumerLiteralNominals     generatedExpressionNominals =@@ -5338,6 +5797,14 @@         | expression <- resolvedExpressions,           nominal <- typedGeneratedNominals expression         ]+    -- Only a literal names `parse<Id>`; see 'generatedNominalTypeImportsWithParsers'.+    generatedLiteralNominals =+      stableNominals+        [ nominal+        | expression <- resolvedExpressions,+          literal <- typedExpressionLiterals expression,+          nominal <- typedGeneratedNominals literal+        ]     expressionUsesTimeLiteral = any (anyTypedExpression isTimeLiteral) resolvedExpressions     expressionUsesNaturalLiteral = any (anyTypedExpression isNaturalLiteral) resolvedExpressions     expressionUsesConsumerNominalLiteral = not (null consumerLiteralNominals)@@ -5476,8 +5943,11 @@   where     entries =       [ (source, edgeIndex, transitionIndex, transition)-      | (source, transitions) <- groupTransitionEntriesBySource aggregate,-        (edgeIndex, (transitionIndex, transition)) <- zip [0 ..] transitions+      | (source, transitions) <- groupTransitionLayoutBySource (transitionLayout (aTransitions aggregate)),+        entry <- transitions,+        let edgeIndex = layoutOutgoingIndex entry+            transitionIndex = layoutDeclarationIndex entry+            transition = layoutTransition entry       ]  foldFingerprintExpression :: Agg -> Text@@ -5497,13 +5967,12 @@       ]  groupTransitionEntriesBySource :: Agg -> [(Text, [(Int, Transition)])]-groupTransitionEntriesBySource aggregate = go [] (transitionEntries aggregate)-  where-    go accumulated [] = reverse accumulated-    go accumulated (entry@(_, transition) : remaining) =-      let source = tSource transition-          (same, rest) = span ((== source) . tSource . snd) remaining-       in go ((source, entry : same) : accumulated) rest+groupTransitionEntriesBySource aggregate =+  [ ( source,+      [(layoutDeclarationIndex entry, layoutTransition entry) | entry <- entries]+    )+  | (source, entries) <- groupTransitionLayoutBySource (transitionLayout (aTransitions aggregate))+  ]  generatedFromBlock :: HaskellImportPlan -> Agg -> [ResolvedGeneratedTransition] -> (Text, [(Int, Transition)]) -> [Text] generatedFromBlock importPlan aggregate resolvedTransitions (source, transitions) =@@ -5583,15 +6052,15 @@ generatedOutputLines :: Agg -> Int -> Transition -> Int -> Name -> [Text] generatedOutputLines aggregate transitionIndex transition emitIndex eventName =   case outputMappingFor aggregate transitionIndex emitIndex of-    GeneratedCommandIdentity _ fields -> case fields of+    GeneratedCommandIdentity sourceCommand fields -> case fields of       [] -> ["        B.emit wire" <> eventName <> " B.oNil"]       _ ->         [ "        B.emit wire" <> eventName <> " (" <> eventName <> "TermFields"         ]           <> [ lead fieldIndex-                 <> outputSelector field+                 <> resolvedSelector sourceCommand field                  <> " = d."-                 <> outputSelector field+                 <> resolvedSelector sourceCommand field              | (fieldIndex, field) <- zip [0 :: Int ..] fields              ]           <> ["          })"]@@ -5605,7 +6074,20 @@   where     lead 0 = "          { "     lead _ = "          , "+    resolvedSelector sourceCommand copiedField =+      commandFieldSelector aggregate sourceCommand (outputSelector copiedField) +commandFieldSelector :: Agg -> Name -> Name -> Text+commandFieldSelector aggregate commandName dslFieldName =+  case [ fieldSelector identity+       | command <- aCommands aggregate,+         rcName command == commandName,+         (identity, _) <- rcFields command,+         fieldDslName identity == dslFieldName+       ] of+    selector : _ -> selector+    [] -> error "validated generated command-field selector was not found"+ outputMappingFor :: Agg -> Int -> Int -> EventOutputMapping outputMappingFor aggregate transitionIndex emitIndex =   fromMaybe@@ -5703,8 +6185,7 @@       "import "         <> aGenPrefix aggregate         <> ".Transducer ("-        <> lowerFirst (aName aggregate)-        <> "FoldFingerprint, "+        <> (if hasSnapshot aggregate then lowerFirst (aName aggregate) <> "FoldFingerprint, " else "")         <> lowerFirst (aName aggregate)         <> "Transducer)"   | otherwise =@@ -5761,7 +6242,15 @@  emitProjection :: Agg -> Text emitProjection a = case aProjection a of-  Nothing -> nl (renderGeneratedLanguagePragmas [] <> [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"])+  Nothing ->+    nl+      ( renderGeneratedLanguagePragmas []+          <> [ generatedBanner,+               "module " <> aGenPrefix a <> ".Projection () where",+               "",+               "-- No projection declarations are present; this module keeps the generated manifest inventory total."+             ]+      )   Just p ->     nl       [ generatedBanner,@@ -6003,16 +6492,21 @@       | otherwise =           rcName event             <> "TermFields\n"-            <> nl (valueRecord [(fieldName, outputFieldValue fieldName fieldType) | (fieldName, fieldType) <- rcFields event])+            <> nl+              ( valueRecord+                  [ (fieldSelector identity, outputFieldValue identity fieldType)+                  | (identity, fieldType) <- rcFields event+                  ]+              )     command = commandForTransition aggregate transition-    outputFieldValue fieldName fieldType-      | Just commandType <- lookup fieldName (rcFields command),+    outputFieldValue identity fieldType+      | Just (commandIdentity, commandType) <- find ((== fieldDslName identity) . fieldDslName . fst) (rcFields command),         commandType == fieldType =-          "d." <> fieldName-      | Just register <- find ((== fieldName) . rrName) (aRegs aggregate),+          "d." <> fieldSelector commandIdentity+      | Just register <- find ((== fieldDslName identity) . rrName) (aRegs aggregate),         rrType register == fieldType =-          "B.reg @" <> tshow fieldName-      | otherwise = "error " <> tshow ("HOLE: fill output field " <> rcName event <> "." <> fieldName)+          "B.reg @" <> tshow (fieldDslName identity)+      | otherwise = "error " <> tshow ("HOLE: fill output field " <> rcName event <> "." <> fieldDslName identity)     valueRecord fields =       [ lead fieldIndex <> fieldName <> " = " <> fieldValue       | (fieldIndex, (fieldName, fieldValue)) <- zip [0 :: Int ..] fields@@ -6022,12 +6516,26 @@     lead _ = "  , "  emitHoleImplementation :: Agg -> Int -> Transition -> [Text]-emitHoleImplementation _ index transition+emitHoleImplementation aggregate index transition   | tImplementation transition /= HoleImplementation = []   | otherwise =       [ "",         "-- HOLE: add the predicate and ordered register updates for this transition.",         "-- The generated transducer still owns command matching, mode, emits, and goto.",+        holeFunctionName index transition+          <> " :: "+          <> payloadProjectionType aggregate transition+          <> " -> B.EdgeBuilder "+          <> aName aggregate+          <> "Regs "+          <> aName aggregate+          <> "Command "+          <> aName aggregate+          <> "Event "+          <> aVertexType aggregate+          <> " ('Just ("+          <> commandFieldsType transition+          <> ")) writes writes ()",         holeFunctionName index transition <> " _d = B.requireGuard K.PTop",         "",         "-- Bump this token whenever the Hole predicate or updates change.",@@ -6107,13 +6615,10 @@  -- Group transitions by source state, preserving order, for the B.from blocks. groupBySource :: Agg -> [(Text, [Transition])]-groupBySource a = go [] (transitionsOf a)-  where-    go acc [] = reverse acc-    go acc (t : ts) =-      let src = tSource t-          (same, rest) = span ((== src) . tSource) ts-       in go ((src, t : same) : acc) rest+groupBySource a =+  [ (source, map layoutTransition entries)+  | (source, entries) <- groupTransitionLayoutBySource (transitionLayout (transitionsOf a))+  ]  -- We don't keep the original Aggregate around in Agg, so reconstruct -- transitions from a stored field. (Filled in resolveAgg via aTransitions.)@@ -6361,9 +6866,7 @@ sectionsOf = T.intercalate "\n\n" . filter (not . T.null) . map (T.intercalate "\n\n")  lowerFirst :: Text -> Text-lowerFirst t = case T.uncons t of-  Just (c, rest) -> T.cons (toLower c) rest-  Nothing -> t+lowerFirst = generatedCase HaskellName.LogicalIdentifier False  -- | Assert the shared category proof at emission time as a belt-and-braces -- guard for callers that bypass the CLI's normal validate-before-scaffold path.@@ -6373,12 +6876,26 @@   Just reason -> error (T.unpack ("keiro-dsl scaffold: illegal " <> owner <> " category " <> tshow value <> " " <> reason))  pascal :: Text -> Text-pascal t = case T.uncons t of-  Just (c, rest) -> T.cons (toUpper c) rest-  Nothing -> t+pascal = generatedCase HaskellName.LogicalIdentifier True  pascalFromKebab :: Text -> Text-pascalFromKebab = T.concat . map pascal . T.splitOn "-"+pascalFromKebab = generatedCase HaskellName.LogicalWireWord True++generatedCase :: HaskellName.NameSourceKind -> Bool -> Text -> Text+generatedCase source upper name =+  case HaskellName.deriveHaskellName source site of+    Right derived+      | upper -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+      | otherwise -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)+    Left _ -> name+  where+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedHelperSite,+          HaskellName.siteLogicalName = name,+          HaskellName.siteOwner = "scaffold-renderer",+          HaskellName.siteLine = 0+        }  kebabFromPascal :: Text -> Text kebabFromPascal = T.intercalate "-" . map T.toLower . splitCamel

@@ -4,12 +4,15 @@ -- single-line JSON after a @mapping @ prefix; old readers ignore that row kind. module Keiro.Dsl.ScaffoldRecord   ( ScaffoldRecord (..),+    ScaffoldModuleRoleRow (..),+    GeneratedHaskellNamingEdition (..),     renderRecord,     parseRecord,     recordFileName,   ) where +import Data.Aeson ((.:), (.=)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BL import Data.List (nub)@@ -18,10 +21,12 @@ import Data.Text.Encoding qualified as Text import Keiro.Dsl.BehaviorCoverage (BehaviorRecordRow (..)) import Keiro.Dsl.ExplainBindings (BindingHole (..))+import Keiro.Dsl.HaskellName (GeneratedHaskellNamingEdition (..), parseGeneratedHaskellNamingEdition, renderGeneratedHaskellNamingEdition) import Keiro.Dsl.LanguageVersion (SourceLanguage (..)) import Keiro.Dsl.MappedConsumer (MappingIdentity (..))-import Keiro.Dsl.Scaffold (ModuleKind (..))+import Keiro.Dsl.Scaffold (ModuleKind (..), ModuleRole (..)) import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveLanguageContract)+import Keiro.Dsl.SidecarNames (contextLedgerFileName) import System.FilePath (isAbsolute, splitDirectories)  data ScaffoldRecord = ScaffoldRecord@@ -30,6 +35,8 @@     recLayout :: !Text,     recSourceLanguage :: !SourceLanguage,     recLanguageContract :: !EffectiveLanguageContract,+    recNamingEdition :: !GeneratedHaskellNamingEdition,+    recModuleRoles :: ![ScaffoldModuleRoleRow],     recFiles :: ![(ModuleKind, FilePath)],     recMappings :: ![MappingIdentity],     recIdDomains :: ![Text],@@ -39,6 +46,43 @@   }   deriving stock (Eq, Show) +data ScaffoldModuleRoleRow = ScaffoldModuleRoleRow+  { srrRole :: !ModuleRole,+    srrKind :: !ModuleKind,+    srrPath :: !FilePath+  }+  deriving stock (Eq, Show)++instance Aeson.ToJSON ScaffoldModuleRoleRow where+  toJSON row =+    Aeson.object+      [ "ownerKind" .= roleOwnerKind role,+        "ownerName" .= roleOwnerName role,+        "family" .= roleFamily role,+        "kind" .= (case srrKind row of Generated -> "generated" :: Text; HoleStub -> "hole"),+        "path" .= T.pack (srrPath row)+      ]+    where+      role = srrRole row++instance Aeson.FromJSON ScaffoldModuleRoleRow where+  parseJSON = Aeson.withObject "ScaffoldModuleRoleRow" $ \fields -> do+    ownerKind <- fields .: "ownerKind"+    ownerName <- fields .: "ownerName"+    family <- fields .: "family"+    kindLabel <- fields .: "kind"+    rowKind <- case (kindLabel :: Text) of+      "generated" -> pure Generated+      "hole" -> pure HoleStub+      other -> fail ("unknown module kind: " <> T.unpack other)+    rowPath <- fields .: "path"+    pure+      ScaffoldModuleRoleRow+        { srrRole = ModuleRole ownerKind ownerName family,+          srrKind = rowKind,+          srrPath = T.unpack (rowPath :: Text)+        }+ renderRecord :: ScaffoldRecord -> Text renderRecord record =   T.unlines $@@ -47,8 +91,10 @@       "module-root: " <> rootLabel,       "layout: " <> recLayout record,       "source-language " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode (recSourceLanguage record))),-      "semantic-contract " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode (recLanguageContract record)))+      "semantic-contract " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode (recLanguageContract record))),+      "naming-edition " <> renderGeneratedHaskellNamingEdition (recNamingEdition record)     ]+      <> map ("module-role " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) (recModuleRoles record))       <> map renderFile (recFiles record)       <> map renderMapping (recMappings record)       <> map ("id-domain " <>) (recIdDomains record)@@ -78,6 +124,8 @@         layout <- exactlyOne "layout: " rows         sourceLanguage <- parseSourceLanguage rows         languageContract <- parseLanguageContract sourceLanguage rows+        namingEdition <- parseNamingEdition rows+        moduleRoles <- traverse parseModuleRole (filter ("module-role " `T.isPrefixOf`) rows)         files <- traverse parseFile (filter isFileRow rows)         ordinaryMappings <- traverse (parseMapping "mapping ") (filter ("mapping " `T.isPrefixOf`) rows)         nominalMappings <- traverse (parseMapping "nominal-mapping ") (filter ("nominal-mapping " `T.isPrefixOf`) rows)@@ -96,6 +144,8 @@                   recLayout = layout,                   recSourceLanguage = sourceLanguage,                   recLanguageContract = languageContract,+                  recNamingEdition = namingEdition,+                  recModuleRoles = moduleRoles,                   recFiles = files,                   recMappings = mappings,                   recIdDomains = idDomains,@@ -127,6 +177,18 @@     parseBehaviorRequirement row = do       payload <- T.stripPrefix "behavior " row       Aeson.decodeStrict' (Text.encodeUtf8 payload)+    parseModuleRole row = do+      payload <- T.stripPrefix "module-role " row+      decoded <- Aeson.decodeStrict' (Text.encodeUtf8 payload)+      checkedRole decoded+    checkedRole roleRow = do+      path <- checkedPath (T.pack (srrPath roleRow))+      pure roleRow {srrPath = path}+    checkedPath pathText =+      let path = T.unpack pathText+       in if null path || isAbsolute path || ".." `elem` splitDirectories path+            then Nothing+            else Just path     parseSourceLanguage rows = case filter ("source-language " `T.isPrefixOf`) rows of       [] -> Just LegacyUnversioned       [row] -> do@@ -140,6 +202,10 @@         contract <- Aeson.decodeStrict' (Text.encodeUtf8 payload)         if contract == effectiveLanguageContract sourceLanguage then Just contract else Nothing       _ -> Nothing+    parseNamingEdition rows = case filter ("naming-edition " `T.isPrefixOf`) rows of+      [] -> Just LegacyNamingV1+      [row] -> T.stripPrefix "naming-edition " row >>= parseGeneratedHaskellNamingEdition+      _ -> Nothing     hasDuplicateMappingNames mappings =       let names = map mappingSpecName mappings        in length names /= length (nub names)@@ -159,7 +225,7 @@        in length keys /= length (nub keys)  recordFileName :: Text -> FilePath-recordFileName context = "keiro-dsl-scaffold-record." <> T.unpack context <> ".txt"+recordFileName = contextLedgerFileName  mappingRowPrefix :: MappingIdentity -> Text mappingRowPrefix NominalMapping {} = "nominal-mapping "

@@ -20,6 +20,7 @@     planScaffoldWithGoldens,     executeServiceScaffold,     executeServiceScaffoldWithRuntimePackage,+    executeServiceScaffoldWithRuntimePackageAndNameMigrations,     executeScaffold,     executeScaffoldWithLanguage,     renderRefusals,@@ -29,9 +30,21 @@      --     -- $shared+    planningGatePipeline,+    planningRefusalDiagnostics,+    checkServiceDiagnostics,+    inertNodesOf,+    renderInertNodeSection,+    withSidecarMovesApplied,+    originLine,     pureRefusals,+    auditGeneratedHaskell,     missingGeneratedBanners,     staleAgainst,+    PreparedSourceMove,+    preparedSourceMove,+    preflightSourceMoves,+    applyPreparedSourceMoves,     constraintPlan,     mappingDrift,     behaviorDrift,@@ -42,12 +55,14 @@ where  import Data.List (sortOn)+import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Keiro.Dsl.BehaviorCoverage (BehaviorDerivationError, BehaviorKey (..), BehaviorRecordRow (..), behaviorRecordRows, deriveBehaviorRequirements)+import Keiro.Dsl.BehaviorCoverage qualified as Behavior import Keiro.Dsl.ConformancePackage   ( ConformancePackageFailure,     ConformancePackageReport,@@ -61,8 +76,11 @@ import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligationKind (..), bindingHolesForService) import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService, renderFoldSurfaceError) import Keiro.Dsl.Goldens (GoldenPayload)-import Keiro.Dsl.Grammar (Node (..), Spec (..))+import Keiro.Dsl.Grammar (EmitNode (..), Loc (..), Node (..), OperationNode (..), PgmqDispatchNode (..), Spec (..)) import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow)+import Keiro.Dsl.HaskellName (currentGeneratedHaskellNamingEdition)+import Keiro.Dsl.HaskellName qualified as HaskellName+import Keiro.Dsl.HaskellSourceMove import Keiro.Dsl.IdDomain (idDomainIdentitiesForService) import Keiro.Dsl.LanguageVersion (SourceLanguage (..), effectiveLanguageVersion, languageVersionText, sourceFormText) import Keiro.Dsl.Manifest (moduleNameOf, renderManifestForServiceWithFacade)@@ -70,12 +88,16 @@ import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService) import Keiro.Dsl.RuntimePackage (RuntimePackageName) import Keiro.Dsl.Scaffold-import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName, renderRecord)+import Keiro.Dsl.ScaffoldRecord (ScaffoldModuleRoleRow (..), ScaffoldRecord (..), parseRecord, recordFileName, renderRecord) import Keiro.Dsl.SemanticContract (CheckedService (..), checkedService, effectiveLanguageContract, legacyCheckedService) import Keiro.Dsl.ServiceHarness (DuplicateServiceFactKey (..), serviceConformanceModuleName, serviceHarnessModule)+import Keiro.Dsl.SidecarMigration+import Keiro.Dsl.SidecarNames (contextCabalFragmentFileName) import Keiro.Dsl.TypeGraph (MappedKey (..), TypeGraph (..), UseSite (..), resolveTypeGraph)-import System.Directory (createDirectoryIfMissing, doesFileExist)+import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), validateService)+import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile) import System.FilePath (takeDirectory, (</>))+import Text.Read (readMaybe)  -- $shared -- These are the pieces whole-workspace scaffolding reuses verbatim rather than@@ -102,6 +124,17 @@     GoldenRootDivergence !FilePath ![FilePath]   | DuplicateConformanceFactKeys ![DuplicateServiceFactKey]   | ConformancePackageRefusal !ConformancePackageFailure+  | GeneratedNameInvariantViolation ![Text]+  | NameMigrationRequired ![SourceMove]+  | NameMigrationRefusal ![Text]+  | SidecarMigrationRequired ![SidecarMove]+  | SidecarMigrationRefusal ![Text]+  | -- | Not a refusal on its own: an accompanying note that the run had already+    --       applied its sidecar renames before a later gate refused. Every other+    --       refusal says "nothing was written", which without this note is false.+    --       The renames are idempotent and forward-consistent, so re-running after+    --       fixing the refusal is correct and needs no undo.+    SidecarMovesAlreadyApplied ![SidecarMove]   deriving stock (Eq, Show)  -- | What one module write did. 'Unchanged' is produced only by the workspace@@ -141,6 +174,7 @@     reportOutDir :: !FilePath,     reportContext :: !Context,     reportDispositions :: ![(ScaffoldModule, WriteDisposition)],+    reportInertNodes :: ![(Text, Text)],     reportManifestPath :: !FilePath,     reportRecordPath :: !FilePath,     reportPreviousSpecPath :: !(Maybe Text),@@ -153,7 +187,9 @@     reportAddedBehavior :: ![BehaviorRecordRow],     reportRemovedBehavior :: ![BehaviorRecordRow],     reportObsoleteOutputHooks :: ![(Text, Text)],-    reportConformancePackage :: !(Maybe ConformancePackageReport)+    reportConformancePackage :: !(Maybe ConformancePackageReport),+    reportNameMoves :: ![SourceMove],+    reportSidecarMoves :: ![SidecarMove]   }   deriving stock (Eq, Show) @@ -208,23 +244,163 @@  planServiceScaffoldWithRuntimePackageAndGoldens :: [GoldenPayload] -> Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule] planServiceScaffoldWithRuntimePackageAndGoldens goldens runtimePackage ctx service =+  planningGatePipeline ctx service modulePlan (Right ())+  where+    facadeModules = case runtimePackage of+      Nothing -> Right []+      Just _ -> fmap pure (serviceHarnessModule ctx service)+    modulePlan =+      case facadeModules of+        Left duplicates -> Left [DuplicateConformanceFactKeys duplicates]+        Right facades ->+          Right $+            stampGeneratedModules+              (checkedLanguageContract service)+              (scaffoldServiceModulesWithGoldens goldens ctx service <> facades)++-- | The one pure scaffold-planning gate sequence. Both scaffold planners and+-- both check paths consume this function, so the first reported refusal cannot+-- drift by input shape.+planningGatePipeline ::+  Context ->+  CheckedService ->+  Either [Refusal] [ScaffoldModule] ->+  Either [Refusal] () ->+  Either [Refusal] [ScaffoldModule]+planningGatePipeline ctx service modulePlan packagePlan =   case traverse (aggregateFoldSurfaceForService service) [aggregate | NAggregate aggregate <- specNodes spec] of     Left surfaceError -> Left [FoldSurfaceRefusal surfaceError]     Right _ -> case scaffoldRefusals spec of       lowering@(_ : _) -> Left [LoweringRefusal lowering]-      [] -> case facadeModules of-        Left duplicates -> Left [DuplicateConformanceFactKeys duplicates]-        Right facades ->-          let modules = stampGeneratedModules (checkedLanguageContract service) (scaffoldServiceModulesWithGoldens goldens ctx service <> facades)-           in case pureRefusals ctx spec modules of-                [] -> Right modules-                refusals -> Left refusals+      [] -> case modulePlan of+        Left refusals -> Left refusals+        Right modules -> case packagePlan of+          Left refusals -> Left refusals+          Right () -> case pureRefusals ctx spec modules of+            [] -> Right modules+            refusals -> Left refusals   where     spec = checkedSpec service-    facadeModules = case runtimePackage of-      Nothing -> Right []-      Just _ -> fmap pure (serviceHarnessModule ctx service) +-- | Validate a checked service, then run the shared planning gates unless an+-- error makes module generation unsound. 'GeneratedOccurrenceCollision' is the+-- deliberate exception: the workspace path already plans through it so the+-- stronger whole-path collision can cite every claimant. Existing diagnostics+-- retain their order and planning diagnostics follow them.+-- | The nodes a spec declares that contribute no generated module.+--+-- They are still parsed, validated, and diff-classified; naming them in the+-- scaffold report is what stops an author from concluding the toolchain lost+-- their declaration. Shared by the single-spec and workspace planners so a+-- workspace — the recommended layout — reports exactly what one spec reports.+inertNodesOf :: Spec -> [(Text, Text)]+inertNodesOf spec =+  [ (kindLabel, nodeName)+  | node <- specNodes spec,+    (kindLabel, nodeName) <- case node of+      NEmit emitNode -> [("emit", emName emitNode)]+      NPgmqDispatch dispatchNode -> [("dispatch", pdName dispatchNode)]+      NOperation operationNode -> [("operation", opName operationNode)]+      _ -> []+  ]++-- | The report line naming 'inertNodesOf', or nothing when every declaration+-- produced a module.+renderInertNodeSection :: [(Text, Text)] -> [Text]+renderInertNodeSection = \case+  [] -> []+  nodes ->+    [ "no-modules: "+        <> T.intercalate ", " [kindLabel <> " " <> nodeName | (kindLabel, nodeName) <- nodes]+        <> " (validated and diff-classified; no generated modules)"+    ]++checkServiceDiagnostics :: Maybe RuntimePackageName -> Context -> CheckedService -> [Diagnostic]+checkServiceDiagnostics runtimePackage ctx service+  | any blocksPlanning validationDiagnostics = validationDiagnostics+  | otherwise =+      validationDiagnostics+        <> case planServiceScaffoldWithRuntimePackage runtimePackage ctx service of+          Right _ -> []+          Left refusals -> planningRefusalDiagnostics refusals+  where+    validationDiagnostics = validateService service+    blocksPlanning diagnostic =+      severity diagnostic == Error+        && code diagnostic /= GeneratedOccurrenceCollision++-- | Present pure planning refusals through check's stable located diagnostic+-- vocabulary. Planner-invariant failures retain the detailed scaffold refusal+-- text in their message while receiving one machine code.+planningRefusalDiagnostics :: [Refusal] -> [Diagnostic]+planningRefusalDiagnostics = concatMap diagnosticsFor+  where+    diagnosticsFor (PathCollision path origins) = [pathCollisionDiagnostic path origins]+    diagnosticsFor (ImportCycle path) =+      [ planningError 1 GeneratedImportCycle $+          "generated/consumer import cycle "+            <> T.intercalate " -> " path+            <> "; keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural"+      ]+    diagnosticsFor (BehaviorRefusal errors) =+      [ planningError (behaviorErrorLine behaviorError) BehaviorDerivationInvalid $+          "behavior obligations cannot be derived soundly: " <> T.pack (show behaviorError)+      | behaviorError <- errors+      ]+    diagnosticsFor (DuplicateConformanceFactKeys duplicates) =+      [ planningError 1 ConformanceFactKeyCollision $+          "normalized service conformance fact key '"+            <> duplicateServiceFactKey duplicate+            <> "' is produced more than once"+      | duplicate <- duplicates+      ]+    diagnosticsFor refusal =+      [ planningError 1 GeneratedPlanningInvariantViolation $+          "validated service failed an internal scaffold-planning invariant: "+            <> T.intercalate " | " (renderRefusals [refusal])+      ]++    pathCollisionDiagnostic path origins =+      Diagnostic+        { line = primaryLine,+          severity = Error,+          code = GeneratedPathCollision,+          relatedLocations =+            [ (claimLine, "claimed here by " <> claimOrigin)+            | (claimLine, claimOrigin) <- remainingClaims+            ],+          message =+            "generated module path '"+              <> T.pack path+              <> "' is claimed more than once; on a case-insensitive filesystem these are one file; claimants: "+              <> T.intercalate "; " origins+        }+      where+        orderedClaims = reverse (sortOn fst [(claimLine, claimOrigin) | claimOrigin <- origins, Just claimLine <- [originLine claimOrigin]])+        (primaryLine, remainingClaims) = case orderedClaims of+          (claimLine, _) : rest -> (claimLine, rest)+          [] -> (1, [])++    behaviorErrorLine (Behavior.DuplicateBehaviorIdentity _ locations) = maximum (1 : map unLoc locations)+    behaviorErrorLine _ = 1++    planningError diagnosticLine diagnosticCode diagnosticMessage =+      Diagnostic+        { line = diagnosticLine,+          severity = Error,+          code = diagnosticCode,+          relatedLocations = [],+          message = diagnosticMessage+        }++-- | Recover the source line embedded in a generated module's origin text,+-- which scaffold formats as @<kind> <name> (line N)@.+originLine :: Text -> Maybe Int+originLine originText = do+  withoutClose <- T.stripSuffix ")" originText+  let (before, after) = T.breakOnEnd " (line " withoutClose+  if T.null before then Nothing else readMaybe (T.unpack after)+ -- | Run every pure refusal gate. A successful result is the exact write set; -- a refusal has no write set and therefore cannot be accidentally executed. planScaffold :: Context -> Spec -> Either [Refusal] [ScaffoldModule]@@ -243,11 +419,203 @@   collisionRefusals modules     <> dependencyRefusals ctx spec modules     <> [FirewallBreach breaches | not (null breaches)]+    <> [GeneratedNameInvariantViolation namingViolations | not (null namingViolations)]     <> [LoweringRefusal lowering | let lowering = scaffoldRefusals spec, not (null lowering)]     <> [BehaviorRefusal errors | Left errors <- [deriveBehaviorRequirements spec]]   where     breaches = firewallBreaches modules+    namingViolations = generatedNameInvariantViolations modules +generatedNameInvariantViolations :: [ScaffoldModule] -> [Text]+generatedNameInvariantViolations = concatMap auditGeneratedHaskell++-- | Inventory and check declarations in one generated source file.  The+-- lexical mask keeps comments and literals out of the declaration inventory;+-- this is deliberately a final defense after the typed naming plan, so a+-- literal template declaration cannot bypass the checked constructors.+auditGeneratedHaskell :: ScaffoldModule -> [Text]+auditGeneratedHaskell scaffoldModule = lexicalErrors <> declarationErrors <> duplicateDeclarationErrors <> occurrenceErrors+  where+    expectedModule = moduleNameOf (modulePath scaffoldModule)+    (lexicalErrors, codeSource) = case maskNonCode (moduleText scaffoldModule) of+      Left message -> ([prefix 1 <> message], "")+      Right masked -> ([], masked)+    sourceLines = zip [1 :: Int ..] (T.lines codeSource)+    declarationErrors = moduleDeclarationErrors <> moduleSegmentErrors+    moduleDeclarationErrors = case declaredModuleName codeSource of+      Nothing -> [T.pack (modulePath scaffoldModule) <> ": missing Haskell module declaration"]+      Just declared+        | declared == expectedModule -> []+        | otherwise ->+            [ T.pack (modulePath scaffoldModule)+                <> ": declares "+                <> declared+                <> " but its planned module is "+                <> expectedModule+            ]+    moduleSegmentErrors =+      [ prefix 1 <> "module segment '" <> segment <> "' is not UpperCamelCase"+      | segment <- T.splitOn "." expectedModule,+        isLeftName (HaskellName.checkedModuleSegment (auditSite HaskellName.NodeModuleSite segment 1) segment)+      ]+    occurrenceErrors =+      concat+        [ checkCandidates lineNumber (signatureCandidates sourceLine)+            <> checkCandidates lineNumber (typeCandidates sourceLine)+            <> checkCandidates lineNumber (constructorCandidates sourceLine)+            <> checkCandidates lineNumber (topLevelValueCandidates sourceLine)+        | (lineNumber, sourceLine) <- sourceLines+        ]++    duplicateDeclarationErrors = duplicateErrors "top-level type signature" signatureCandidates <> duplicateErrors "top-level type declaration" typeCandidates+    duplicateErrors label candidates =+      [ prefix laterLine+          <> "repeated "+          <> label+          <> " '"+          <> candidate+          <> "' (first declared at line "+          <> tshow firstLine+          <> ")"+      | (candidate, declarationLines) <- Map.toAscList declarations,+        firstLine : laterLines <- [declarationLines],+        laterLine <- laterLines+      ]+      where+        declarations =+          Map.fromListWith+            (flip (++))+            [ (candidate, [lineNumber])+            | (lineNumber, sourceLine) <- sourceLines,+              sourceLine == T.stripStart sourceLine,+              candidate <- candidates sourceLine+            ]++    checkCandidates lineNumber = concatMap (checkCandidate lineNumber)+    checkCandidate lineNumber candidate+      | T.null candidate = []+      | asciiUpperInitial candidate =+          [prefix lineNumber <> "generated declaration '" <> candidate <> "' is not UpperCamelCase" | isLeftName (HaskellName.checkedUpperOccurrence (auditSite HaskellName.GeneratedTypeSite candidate lineNumber) candidate)]+      | otherwise =+          [prefix lineNumber <> "generated declaration '" <> candidate <> "' is not lowerCamelCase" | isLeftName (HaskellName.checkedLowerOccurrence (auditSite HaskellName.GeneratedValueSite candidate lineNumber) candidate)]++    prefix lineNumber = T.pack (modulePath scaffoldModule) <> ":" <> tshow lineNumber <> ": "++    auditSite kind candidate lineNumber =+      HaskellName.NameSite+        { HaskellName.siteKind = kind,+          HaskellName.siteLogicalName = candidate,+          HaskellName.siteOwner = T.pack (modulePath scaffoldModule),+          HaskellName.siteLine = lineNumber+        }++isLeftName :: Either left right -> Bool+isLeftName = \case Left _ -> True; Right _ -> False++declaredModuleName :: Text -> Maybe Text+declaredModuleName source =+  case [T.takeWhile moduleCharacter (T.drop 7 sourceLine) | sourceLine <- T.lines source, "module " `T.isPrefixOf` sourceLine] of+    declaration : _ | not (T.null declaration) -> Just declaration+    _ -> Nothing+  where+    moduleCharacter character = identifierCharacter character || character == '.'++signatureCandidates :: Text -> [Text]+signatureCandidates sourceLine+  | T.null suffix || T.any (`elem` ['=', '(', ')', '[', ']']) prefix = []+  | otherwise = filter isIdentifier (map T.strip (T.splitOn "," prefix))+  where+    (prefix, suffix) = T.breakOn "::" (T.strip sourceLine)++typeCandidates :: Text -> [Text]+typeCandidates sourceLine = case T.words (T.strip sourceLine) of+  keyword : candidate : _+    | keyword `elem` ["data", "newtype", "type"], candidate /= "family", candidate /= "instance" -> [cleanIdentifier candidate]+  _ -> []++constructorCandidates :: Text -> [Text]+constructorCandidates sourceLine+  | "|" `T.isPrefixOf` stripped = takeFollowingIdentifier (T.drop 1 stripped)+  | any (`T.isPrefixOf` stripped) ["data ", "newtype "] = takeFollowingIdentifier (T.drop 1 (snd (T.breakOn "=" stripped)))+  | otherwise = []+  where+    stripped = T.strip sourceLine+    takeFollowingIdentifier value = case T.words value of+      candidate : _ | asciiUpperInitial (cleanIdentifier candidate) -> [cleanIdentifier candidate]+      _ -> []++topLevelValueCandidates :: Text -> [Text]+topLevelValueCandidates sourceLine+  | T.null sourceLine || T.head sourceLine == ' ' || T.head sourceLine == '\t' = []+  | T.null suffix = []+  | otherwise = case T.words prefix of+      candidate : _+        | candidate `notElem` declarationKeywords,+          isIdentifier candidate ->+            [candidate]+      _ -> []+  where+    (prefix, suffix) = T.breakOn "=" sourceLine+    declarationKeywords = ["data", "newtype", "type", "class", "instance", "module", "import", "deriving", "infix", "infixl", "infixr"]++cleanIdentifier :: Text -> Text+cleanIdentifier = T.takeWhile identifierCharacter . T.dropWhile (not . identifierCharacter)++isIdentifier :: Text -> Bool+isIdentifier candidate = not (T.null candidate) && T.all identifierCharacter candidate++identifierCharacter :: Char -> Bool+identifierCharacter character =+  (character >= 'A' && character <= 'Z')+    || (character >= 'a' && character <= 'z')+    || (character >= '0' && character <= '9')+    || character == '_'+    || character == '\''++asciiUpperInitial :: Text -> Bool+asciiUpperInitial candidate = case T.uncons candidate of+  Just (first, _) -> first >= 'A' && first <= 'Z'+  Nothing -> False++data AuditLexState = AuditCode | AuditLineComment | AuditBlockComment !Int | AuditString | AuditCharacter++maskNonCode :: Text -> Either Text Text+maskNonCode = fmap T.pack . go AuditCode . T.unpack+  where+    go state input = case (state, input) of+      (AuditCode, []) -> Right []+      (AuditLineComment, []) -> Right []+      (AuditBlockComment _, []) -> Left "unterminated block comment in generated source"+      (AuditString, []) -> Left "unterminated string literal in generated source"+      (AuditCharacter, []) -> Left "unterminated character literal in generated source"+      (AuditCode, '-' : '-' : rest) -> prependSpaces 2 <$> go AuditLineComment rest+      (AuditCode, '{' : '-' : rest) -> prependSpaces 2 <$> go (AuditBlockComment 1) rest+      (AuditCode, '"' : rest) -> (' ' :) <$> go AuditString rest+      (AuditCode, '\'' : rest)+        | looksLikeCharacterLiteral rest -> (' ' :) <$> go AuditCharacter rest+      (AuditCode, character : rest) -> (character :) <$> go AuditCode rest+      (AuditLineComment, '\n' : rest) -> ('\n' :) <$> go AuditCode rest+      (AuditLineComment, _ : rest) -> (' ' :) <$> go AuditLineComment rest+      (AuditBlockComment depth, '{' : '-' : rest) -> prependSpaces 2 <$> go (AuditBlockComment (depth + 1)) rest+      (AuditBlockComment 1, '-' : '}' : rest) -> prependSpaces 2 <$> go AuditCode rest+      (AuditBlockComment depth, '-' : '}' : rest) -> prependSpaces 2 <$> go (AuditBlockComment (depth - 1)) rest+      (AuditBlockComment depth, '\n' : rest) -> ('\n' :) <$> go (AuditBlockComment depth) rest+      (AuditBlockComment depth, _ : rest) -> (' ' :) <$> go (AuditBlockComment depth) rest+      (AuditString, '\\' : _escaped : rest) -> prependSpaces 2 <$> go AuditString rest+      (AuditString, '"' : rest) -> (' ' :) <$> go AuditCode rest+      (AuditString, '\n' : _) -> Left "newline in generated string literal"+      (AuditString, _ : rest) -> (' ' :) <$> go AuditString rest+      (AuditCharacter, '\\' : _escaped : rest) -> prependSpaces 2 <$> go AuditCharacter rest+      (AuditCharacter, '\'' : rest) -> (' ' :) <$> go AuditCode rest+      (AuditCharacter, '\n' : _) -> Left "newline in generated character literal"+      (AuditCharacter, _ : rest) -> (' ' :) <$> go AuditCharacter rest++    prependSpaces count suffix = replicate count ' ' <> suffix+    looksLikeCharacterLiteral = \case+      '\\' : _escaped : '\'' : _ -> True+      _character : '\'' : _ -> True+      _ -> False+ dependencyRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal] dependencyRefusals ctx spec modules = collisionWithConsumers <> namespaceCycles   where@@ -326,17 +694,36 @@ executeServiceScaffold = executeServiceScaffoldWithRuntimePackage Nothing  executeServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)-executeServiceScaffoldWithRuntimePackage runtimePackage out forceGeneratedOverwrite specPath sourceLanguage ctx service plannedModules+executeServiceScaffoldWithRuntimePackage runtimePackage =+  executeServiceScaffoldWithRuntimePackageAndNameMigrations runtimePackage False++executeServiceScaffoldWithRuntimePackageAndNameMigrations :: Maybe RuntimePackageName -> Bool -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeServiceScaffoldWithRuntimePackageAndNameMigrations runtimePackage applyNameMigrations out forceGeneratedOverwrite specPath sourceLanguage ctx service plannedModules   | effectiveLanguageContract sourceLanguage /= checkedLanguageContract service =       pure (Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"])   | otherwise = case packagePlan of       Left failures -> pure (Left (map ConformancePackageRefusal failures))-      Right Nothing -> executeCheckedScaffold Nothing-      Right (Just plannedPackage) -> do-        prepared <- preflightConformancePackage out forceGeneratedOverwrite plannedPackage-        case prepared of-          Left failures -> pure (Left (map ConformancePackageRefusal failures))-          Right packageReady -> executeCheckedScaffold (Just packageReady)+      Right plannedPackage -> do+        sidecarResult <- planSidecarMigrations out (ContextSidecars (specContext spec)) plannedPackage+        case sidecarResult of+          Left reasons -> pure (Left [SidecarMigrationRefusal reasons])+          Right preparedSidecars+            | not (null preparedSidecars) && not applyNameMigrations ->+                pure (Left [SidecarMigrationRequired (map preparedSidecarMove preparedSidecars)])+            | otherwise -> do+                applyPreparedSidecarMoves out preparedSidecars+                let moves = map preparedSidecarMove preparedSidecars+                    -- Past this point the renames are on disk, so a later+                    -- refusal's "nothing was written" needs qualifying.+                    noteApplied = withSidecarMovesApplied moves+                result <- case plannedPackage of+                  Nothing -> executeCheckedScaffold moves Nothing+                  Just package -> do+                    preparedPackage <- preflightConformancePackage out forceGeneratedOverwrite package+                    case preparedPackage of+                      Left failures -> pure (Left (map ConformancePackageRefusal failures))+                      Right packageReady -> executeCheckedScaffold moves (Just packageReady)+                pure (either (Left . noteApplied) Right result)   where     spec = checkedSpec service     modules = stampGeneratedModules (checkedLanguageContract service) plannedModules@@ -347,7 +734,7 @@       traverse         (\packageName -> planConformancePackage (StandaloneConformanceService (contextName ctx)) packageName (serviceConformanceModuleName ctx) service)         runtimePackage-    executeCheckedScaffold preparedPackage =+    executeCheckedScaffold sidecarMoves preparedPackage =       case deriveBehaviorRequirements spec of         Left errors -> pure (Left [BehaviorRefusal errors])         Right requirements -> do@@ -357,46 +744,227 @@             else do               let recordPath = out </> recordFileName (specContext spec)               previousRecord <- readRecord recordPath-              stale <- maybe (pure []) (existingStale out modules) previousRecord-              let currentConsumerPlan = consumerPlan spec-                  drift = maybe [] (mappingDrift (consumerMappings currentConsumerPlan) . recMappings) previousRecord-                  languageDrift = do-                    previous <- previousRecord-                    if recSourceLanguage previous == sourceLanguage-                      then Nothing-                      else Just (SourceLanguageDrift (recSourceLanguage previous) sourceLanguage)-                  currentObligations = either (const []) id (bindingHolesForService service)-                  newHoles = maybe [] (newBindingObligations currentObligations . recBindingObligations) previousRecord-                  currentBehavior = behaviorRecordRows requirements-                  (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . recBehaviorRequirements) previousRecord-              createDirectoryIfMissing True out-              dispositions <- mapM (writeModule out) modules-              let manifestPath = out </> ("keiro-dsl-manifest." <> T.unpack (specContext spec) <> ".txt")-              TIO.writeFile manifestPath (renderManifestForServiceWithFacade facadeModule (T.pack specPath) modules service)-              TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules currentBehavior))-              packageReport <- traverse executePreparedConformancePackage preparedPackage-              pure $-                Right-                  ScaffoldReport-                    { reportSpecPath = specPath,-                      reportOutDir = out,-                      reportContext = ctx,-                      reportDispositions = dispositions,-                      reportManifestPath = manifestPath,-                      reportRecordPath = recordPath,-                      reportPreviousSpecPath = recSpecPath <$> previousRecord,-                      reportStale = stale,-                      reportConsumerPlan = currentConsumerPlan,-                      reportConstraintPlan = constraintPlan spec currentConsumerPlan,-                      reportMappingDrift = drift,-                      reportSourceLanguageDrift = languageDrift,-                      reportNewHoles = newHoles,-                      reportAddedBehavior = addedBehavior,-                      reportRemovedBehavior = removedBehavior,-                      reportObsoleteOutputHooks = obsoleteGeneratedOutputHooks spec,-                      reportConformancePackage = packageReport-                    }+              case planRecordedSourceMoves previousRecord modules of+                Left moveErrors -> pure (Left [NameMigrationRefusal [T.pack (show moveError) | moveError <- NE.toList moveErrors]])+                Right moves -> do+                  preparedMoves <- preflightSourceMoves out moves+                  case preparedMoves of+                    Left moveErrors -> pure (Left [NameMigrationRefusal moveErrors])+                    Right prepared+                      | not (null prepared) && not applyNameMigrations ->+                          pure (Left [NameMigrationRequired (map preparedSourceMove prepared)])+                      | otherwise -> do+                          applyPreparedSourceMoves out prepared+                          stale <- maybe (pure []) (existingStale out modules) previousRecord+                          let currentConsumerPlan = consumerPlan spec+                              drift = maybe [] (mappingDrift (consumerMappings currentConsumerPlan) . recMappings) previousRecord+                              languageDrift = do+                                previous <- previousRecord+                                if recSourceLanguage previous == sourceLanguage+                                  then Nothing+                                  else Just (SourceLanguageDrift (recSourceLanguage previous) sourceLanguage)+                              currentObligations = either (const []) id (bindingHolesForService service)+                              newHoles = maybe [] (newBindingObligations currentObligations . recBindingObligations) previousRecord+                              currentBehavior = behaviorRecordRows requirements+                              (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . recBehaviorRequirements) previousRecord+                          createDirectoryIfMissing True out+                          dispositions <- mapM (writeModule out) modules+                          let manifestPath = out </> contextCabalFragmentFileName (specContext spec)+                          TIO.writeFile manifestPath (renderManifestForServiceWithFacade facadeModule (T.pack specPath) modules service)+                          TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules currentBehavior))+                          packageReport <- traverse executePreparedConformancePackage preparedPackage+                          pure $+                            Right+                              ScaffoldReport+                                { reportSpecPath = specPath,+                                  reportOutDir = out,+                                  reportContext = ctx,+                                  reportDispositions = dispositions,+                                  reportInertNodes = inertNodesOf spec,+                                  reportManifestPath = manifestPath,+                                  reportRecordPath = recordPath,+                                  reportPreviousSpecPath = recSpecPath <$> previousRecord,+                                  reportStale = stale,+                                  reportConsumerPlan = currentConsumerPlan,+                                  reportConstraintPlan = constraintPlan spec currentConsumerPlan,+                                  reportMappingDrift = drift,+                                  reportSourceLanguageDrift = languageDrift,+                                  reportNewHoles = newHoles,+                                  reportAddedBehavior = addedBehavior,+                                  reportRemovedBehavior = removedBehavior,+                                  reportObsoleteOutputHooks = obsoleteGeneratedOutputHooks spec,+                                  reportConformancePackage = packageReport,+                                  reportNameMoves = map preparedSourceMove prepared,+                                  reportSidecarMoves = sidecarMoves+                                } +planRecordedSourceMoves :: Maybe ScaffoldRecord -> [ScaffoldModule] -> Either (NE.NonEmpty SourceMoveError) [SourceMove]+planRecordedSourceMoves Nothing _ = Right []+planRecordedSourceMoves (Just previous) current =+  planSourceMoves priorArtifacts current+  where+    priorArtifacts = case recModuleRoles previous of+      [] -> [(Nothing, fileKind, path) | (fileKind, path) <- recFiles previous]+      rows -> [(Just (srrRole row), srrKind row, srrPath row) | row <- rows]++data PreparedSourceMove+  = SourceMoveReady !SourceMove !Text+  | SourceMoveAlreadyApplied !SourceMove++preparedSourceMove :: PreparedSourceMove -> SourceMove+preparedSourceMove = \case+  SourceMoveReady move _ -> move+  SourceMoveAlreadyApplied move -> move++preflightSourceMoves :: FilePath -> [SourceMove] -> IO (Either [Text] [PreparedSourceMove])+preflightSourceMoves out moves = do+  prepared <- mapM preflight moves+  let errors = [message | Left message <- prepared]+  pure $ if null errors then Right [value | Right value <- prepared] else Left errors+  where+    replacements = Map.fromList [(moveOldModule move, moveNewModule move) | move <- moves]+    preflight move = do+      let oldPath = out </> moveOldPath move+          newPath = out </> moveNewPath move+          backupPath = out </> moveBackupPath move+          preparedPath = preparedSourcePath out move+          statePath = sourceMoveStatePath out move+      oldExists <- doesFileExist oldPath+      newExists <- doesFileExist newPath+      backupExists <- doesFileExist backupPath+      preparedExists <- doesFileExist preparedPath+      stateExists <- doesFileExist statePath+      case (oldExists, backupExists) of+        (True, True) -> conflict move newExists backupExists preparedExists "both legacy source and backup exist"+        (False, False) ->+          if newExists+            then conflict move newExists backupExists preparedExists "target exists without a recoverable legacy source"+            else pure (Left (T.pack (moveOldPath move) <> ": recorded legacy source is missing"))+        _ -> do+          source <- TIO.readFile (if oldExists then oldPath else backupPath)+          if moveKind move == Generated && not (any isGeneratedBannerLine (T.lines source))+            then pure (Left (T.pack (moveOldPath move) <> ": generated source lacks an exact generated banner"))+            else case rewriteHaskellModuleReferences replacements source of+              Left lexicalError -> pure (Left (T.pack (moveOldPath move) <> ": " <> T.pack (show lexicalError)))+              Right rewritten+                | not (declaresExpectedModule (moveNewModule move) rewritten) ->+                    pure+                      ( Left+                          ( T.pack (moveOldPath move)+                              <> ": transformed source does not declare expected module "+                              <> moveNewModule move+                          )+                      )+                | otherwise -> do+                    let hydrated =+                          move+                            { moveContentDigest = Just (contentDigest source),+                              moveTransformedDigest = Just (contentDigest rewritten)+                            }+                        expectedState = renderSourceMoveState hydrated+                    stateError <- verifyOptionalText stateExists statePath expectedState "migration state"+                    preparedError <- verifyOptionalDigest preparedExists preparedPath (contentDigest rewritten) "prepared source"+                    targetError <- verifyOptionalDigest newExists newPath (contentDigest rewritten) "target source"+                    case [message | Just message <- [stateError, preparedError, targetError]] of+                      message : _ -> pure (Left (T.pack (moveOldPath move) <> ": " <> message))+                      []+                        | newExists && not backupExists && not oldExists -> conflict hydrated newExists backupExists preparedExists "target has no recoverable backup"+                        | newExists && backupExists && not oldExists -> pure (Right (SourceMoveAlreadyApplied hydrated))+                        | otherwise -> pure (Right (SourceMoveReady hydrated rewritten))++    conflict move newExists backupExists preparedExists reason =+      pure+        ( Left+            ( T.pack (moveOldPath move)+                <> ": migration state conflicts ("+                <> reason+                <> "; target="+                <> T.pack (show newExists)+                <> ", backup="+                <> T.pack (show backupExists)+                <> ", prepared="+                <> T.pack (show preparedExists)+                <> ")"+            )+        )++    verifyOptionalText False _ _ _ = pure Nothing+    verifyOptionalText True path expected label = do+      actual <- TIO.readFile path+      pure $ if actual == expected then Nothing else Just (label <> " digest/path evidence does not match")++    verifyOptionalDigest False _ _ _ = pure Nothing+    verifyOptionalDigest True path expected label = do+      actual <- contentDigest <$> TIO.readFile path+      pure $ if actual == expected then Nothing else Just (label <> " digest does not match " <> expected)++    declaresExpectedModule expected source =+      any (T.isPrefixOf ("module " <> expected <> " ")) (T.lines source)+        || any (== ("module " <> expected)) (T.lines source)++applyPreparedSourceMoves :: FilePath -> [PreparedSourceMove] -> IO ()+applyPreparedSourceMoves out prepared = do+  -- Prepare every transformed file and durable digest record before moving a+  -- single active source.  The temporary file lives beside its destination,+  -- so installation is a same-filesystem rename.+  mapM_ prepareMove prepared+  mapM_ backupMove prepared+  mapM_ installMove prepared+  where+    prepareMove preparedMove = do+      let move = preparedSourceMove preparedMove+          statePath = sourceMoveStatePath out move+      createDirectoryIfMissing True (takeDirectory statePath)+      TIO.writeFile statePath (renderSourceMoveState move)+      case preparedMove of+        SourceMoveAlreadyApplied _ -> pure ()+        SourceMoveReady _ rewritten -> do+          let path = preparedSourcePath out move+          createDirectoryIfMissing True (takeDirectory path)+          exists <- doesFileExist path+          if exists then pure () else TIO.writeFile path rewritten++    backupMove (SourceMoveAlreadyApplied _) = pure ()+    backupMove (SourceMoveReady move _) = do+      let oldPath = out </> moveOldPath move+          backupPath = out </> moveBackupPath move+      oldExists <- doesFileExist oldPath+      if oldExists+        then do+          createDirectoryIfMissing True (takeDirectory backupPath)+          renameFile oldPath backupPath+        else pure ()++    installMove preparedMove = do+      let move = preparedSourceMove preparedMove+          preparedPath = preparedSourcePath out move+          newPath = out </> moveNewPath move+      newExists <- doesFileExist newPath+      preparedExists <- doesFileExist preparedPath+      if newExists+        then if preparedExists then removeFile preparedPath else pure ()+        else do+          createDirectoryIfMissing True (takeDirectory newPath)+          renameFile preparedPath newPath++preparedSourcePath :: FilePath -> SourceMove -> FilePath+preparedSourcePath out move = out </> (moveNewPath move <> ".keiro-dsl-name-migration-prepared")++sourceMoveStatePath :: FilePath -> SourceMove -> FilePath+sourceMoveStatePath out move = out </> (moveBackupPath move <> ".keiro-dsl-name-migration-state")++renderSourceMoveState :: SourceMove -> Text+renderSourceMoveState move =+  T.unlines+    [ "keiro-dsl-name-migration-state v1",+      "old-path " <> T.pack (moveOldPath move),+      "new-path " <> T.pack (moveNewPath move),+      "old-module " <> moveOldModule move,+      "new-module " <> moveNewModule move,+      "source-digest " <> maybe "<missing>" id (moveContentDigest move),+      "transformed-digest " <> maybe "<missing>" id (moveTransformedDigest move)+    ]+ constraintPlan :: Spec -> ConsumerPlan -> [Text] constraintPlan spec plan = case resolveTypeGraph spec of   Left _ -> []@@ -489,6 +1057,8 @@       recLayout = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated",       recSourceLanguage = sourceLanguage,       recLanguageContract = checkedLanguageContract service,+      recNamingEdition = currentGeneratedHaskellNamingEdition,+      recModuleRoles = [ScaffoldModuleRoleRow (moduleRole m) (kind m) (modulePath m) | m <- modules],       recFiles = [(kind m, modulePath m) | m <- modules],       recMappings = consumerMappings (consumerPlan spec),       recIdDomains = idDomainIdentitiesForService service,@@ -526,6 +1096,16 @@         then pure (m, Skipped)         else TIO.writeFile path (moduleText m) >> pure (m, Created) +-- | Qualify a refusal set raised after the run's sidecar renames were applied.+--+-- Every refusal message says "nothing was written", which is true of the module+-- tree but not of the renames, so the note is appended rather than the claim+-- being weakened everywhere. A refusal set that is empty stays empty.+withSidecarMovesApplied :: [SidecarMove] -> [Refusal] -> [Refusal]+withSidecarMovesApplied [] refusals = refusals+withSidecarMovesApplied _ [] = []+withSidecarMovesApplied moves refusals = refusals <> [SidecarMovesAlreadyApplied moves]+ renderRefusals :: [Refusal] -> [Text] renderRefusals = concatMap render   where@@ -555,6 +1135,34 @@     render (BehaviorRefusal errors) =       ["error: behavior obligations cannot be derived soundly -- refusing to scaffold; nothing was written"]         <> ["  " <> T.pack (show behaviorError) | behaviorError <- errors]+    render (GeneratedNameInvariantViolation violations) =+      ["error: generated Haskell name invariant violated -- refusing to scaffold; nothing was written"]+        <> map ("  " <>) violations+    render (NameMigrationRequired moves) =+      [ "error: name migration required: legacy-v1 -> idiomatic-v1; nothing was written",+        "re-run scaffold with --apply-name-migrations after reviewing these source moves:"+      ]+        <> map renderMove moves+    render (NameMigrationRefusal reasons) =+      ["error: name migration could not be applied safely; nothing was written"]+        <> map ("  " <>) reasons+    render (SidecarMigrationRequired moves) =+      [ "error: sidecar migration required; nothing was written",+        "re-run scaffold with --apply-name-migrations after reviewing these sidecar renames:"+      ]+        <> map (("  " <>) . renderSidecarMove) moves+    render (SidecarMigrationRefusal reasons) =+      ["error: sidecar migration could not be applied safely; nothing was written"]+        <> map ("  " <>) reasons+    render (SidecarMovesAlreadyApplied moves) =+      [ "note: this run had already applied "+          <> tshow (length moves)+          <> " sidecar rename(s) before the refusal above, so \"nothing was written\" excludes them:"+      ]+        <> map (("  " <>) . renderSidecarMove) moves+        <> [ "The renames are idempotent and carry no spec content, so re-running scaffold",+             "after fixing the refusal is correct; nothing needs to be undone."+           ]     render (FoldSurfaceRefusal surfaceError) =       [ "error: aggregate fold identity could not be resolved -- refusing to scaffold; nothing was written",         "  " <> renderFoldSurfaceError surfaceError@@ -575,17 +1183,26 @@       ["error: duplicate normalized service conformance fact keys -- refusing to scaffold; nothing was written"]         <> ["  " <> duplicateServiceFactKey duplicate | duplicate <- duplicates]     render (ConformancePackageRefusal failure) = renderConformancePackageFailure failure+    renderMove move =+      "  "+        <> (case moveKind move of Generated -> "generated "; HoleStub -> "hole      ")+        <> moveOldModule move+        <> " -> "+        <> moveNewModule move+        <> "  backup: "+        <> T.pack (moveBackupPath move)  renderScaffoldReport :: ScaffoldReport -> [Text] renderScaffoldReport report =   [ "scaffold: " <> T.pack (reportSpecPath report) <> " -> " <> T.pack (reportOutDir report) <> " (module-root=" <> rootLabel <> ", layout=" <> layoutLabel <> ")"   ]     <> map moduleLine dispositions+    <> inertNodeSection     <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)",          harnessLine,          dependencyLine,-         "manifest: " <> T.pack (reportManifestPath report),-         "record:   " <> T.pack (reportRecordPath report)+         "fragment: " <> T.pack (reportManifestPath report),+         "ledger:   " <> T.pack (reportRecordPath report)        ]     <> previousSpecNote     <> constraintSection@@ -594,6 +1211,8 @@     <> sourceLanguageDriftSection     <> behaviorDriftSection     <> obsoleteOutputSection+    <> sidecarMoveSection+    <> nameMoveSection     <> staleSection     <> maybe [] renderConformancePackageReport (reportConformancePackage report)   where@@ -613,6 +1232,7 @@     dispositionTag Unchanged = "(unchanged)"     pad name = name <> T.replicate (nameWidth - T.length name) " "     generatedCount = length [() | (m, _) <- dispositions, kind m == Generated]+    inertNodeSection = renderInertNodeSection (reportInertNodes report)     harnesses =       sortOn         id@@ -688,6 +1308,16 @@       hooks ->         ["obsolete identity-copy output hooks (if still present, they are unused and may be removed):"]           <> ["  " <> aggregate <> ".Holes." <> hook | (aggregate, hook) <- hooks]+    sidecarMoveSection = case reportSidecarMoves report of+      [] -> []+      moves ->+        ["sidecar migration: applied (" <> tshow (length moves) <> " move(s))"]+          <> map (("  " <>) . renderSidecarMove) moves+    nameMoveSection = case reportNameMoves report of+      [] -> []+      moves ->+        ["name migration: applied (" <> tshow (length moves) <> " source move(s))"]+          <> ["  backup: " <> T.pack (moveBackupPath move) | move <- moves]     staleSection = case reportStale report of       [] -> []       stale ->